diff --git a/CLTL2/ADISPLAY b/CLTL2/ADISPLAY
new file mode 100644
index 00000000..5ac1f1c7
--- /dev/null
+++ b/CLTL2/ADISPLAY
@@ -0,0 +1,4533 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "13-Oct-93 18:25:23" "{Pele:mv:envos}<LispCore>Sources>CLTL2>ADISPLAY.;1" 253788 
+
+      previous date%: "19-Jan-93 10:17:39" "{Pele:mv:envos}<LispCore>Sources>ADISPLAY.;5")
+
+
+(* ; "
+Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT ADISPLAYCOMS)
+
+(RPAQQ ADISPLAYCOMS
+       [(COMS                                                (* ; "Interlisp-D dependent stuff.")
+              (EXPORT (RECORDS REGION BITMAP BITMAPWORD POSITION CURSOR MOUSEEVENT SCREENREGION 
+                             SCREENPOSITION))
+              (SYSRECORDS PILOTBBT \DISPLAYDATA)
+              (CONSTANTS (BITSPERINTEGER 32))
+              (FNS \BBTCURVEPT)
+              (FNS CREATETEXTUREFROMBITMAP PRINTBITMAP PRINT-BITMAPS-NICELY PRINTCURSOR \WRITEBITMAP)
+              (P (DEFPRINT 'BITMAP 'PRINT-BITMAPS-NICELY))
+              (FNS \GETINTEGERPART \CONVERTTOFRACTION)
+              (CONSTANTS (INTEGERBITS 12)))
+        [COMS                                                (* ; 
+                                                           "cursor functions not on LLDISPLAY")
+              (FNS CURSORP CURSORBITMAP CreateCursorBitMap)
+              (EXPORT (MACROS CURSORBITMAP)
+                     (CONSTANTS (HARDCURSORHEIGHT 16)
+                            (HARDCURSORWIDTH 16))
+                     (DECLARE%: EVAL@COMPILE (ADDVARS (GLOBALVARS CursorBitMap]
+        (COMS * CARETCOMS)
+        (COMS                                                (* ; "Region functions")
+              (FNS CREATEREGION REGIONP INTERSECTREGIONS UNIONREGIONS REGIONSINTERSECTP SUBREGIONP 
+                   EXTENDREGION EXTENDREGIONBOTTOM EXTENDREGIONLEFT EXTENDREGIONRIGHT EXTENDREGIONTOP
+                   INSIDEP STRINGREGION))
+        (COMS                                                (* ; "line and spline drawing.")
+              (COMS                                          (* ; 
+                                                           "Brushes and brush initialization")
+                    (GLOBALRESOURCES \BRUSHBBT)
+                    (FNS \BRUSHBITMAP \GETBRUSH \GETBRUSHBBT \InitCurveBrushes \BrushFromWidth)
+                    (FNS \MAKEBRUSH.DIAGONAL \MAKEBRUSH.HORIZONTAL \MAKEBRUSH.VERTICAL 
+                         \MAKEBRUSH.SQUARE \MAKEBRUSH.ROUND)
+                    (FNS INSTALLBRUSH)
+                    (VARS \BrushNames)
+                    (INITVARS (KNOWN.BRUSHES NIL)
+                           (\BrushAList NIL))
+                    (RECORDS BRUSHITEM)
+                    (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\InitCurveBrushes)))
+                    (DECLARE%: DONTCOPY (GLOBALVARS \BrushAList KNOWN.BRUSHES)))
+                                                             (* ; "Lines")
+              (FNS \DRAWLINE.DISPLAY RELMOVETO MOVETOUPPERLEFT)
+              (FNS \CLIPANDDRAWLINE \CLIPANDDRAWLINE1 \CLIPCODE \LEASTPTAT \GREATESTPTAT \DRAWLINE1 
+                   \DRAWLINE.UFN)
+              (DECLARE%: DONTCOPY (MACROS .DRAWLINEX. .DRAWLINEY.))
+                                                             (* ; "Curves")
+              (FNS \DRAWCIRCLE.DISPLAY \DRAWARC.DISPLAY \DRAWARC.GENERIC \COMPUTE.ARC.POINTS 
+                   \DRAWELLIPSE.DISPLAY \DRAWCURVE.DISPLAY \DRAWPOINT.DISPLAY \DRAWPOLYGON.DISPLAY 
+                   \LINEWITHBRUSH)
+              (FNS LOADPOLY PARAMETRICSPLINE \CURVE \CURVE2 \CURVEEND \CURVESLOPE \CURVESTART 
+                   \FDIFS/FROM/DERIVS)
+              (DECLARE%: DONTCOPY                            (* ; "Used by drawcurve")
+                     (EXPORT (RECORDS POLYNOMIAL SPLINE)))
+              (DECLARE%: DONTCOPY (EXPORT (MACROS HALF \FILLCIRCLEBLT))
+                     (MACROS \CURVEPT .SETUP.FOR.\BBTCURVEPT. \CIRCLEPTS \CURVESMOOTH))
+              (FNS \FILLCIRCLE.DISPLAY \LINEBLT))
+        [COMS                                                (* ; "making and copying bitmaps")
+              (FNS SCREENBITMAP BITMAPP BITMAPHEIGHT BITSPERPIXEL)
+              (EXPORT (FILEPKGCOMS BITMAPS CURSORS))
+              (DECLARE%: EVAL@COMPILE (EXPORT (ADDVARS (GLOBALVARS SCREENHEIGHT SCREENWIDTH 
+                                                              ScreenBitMap]
+        [COMS                                                (* ; 
+                             "Display stream functions that are not needed in the primitive system")
+              (FNS DSPFILL INVERTW)
+              (FNS \DSPCOLOR.DISPLAY \DSPBACKCOLOR.DISPLAY DSPEOLFN)
+              (EXPORT (CONSTANTS (BLACKSHADE 65535)
+                             (WHITESHADE 0))
+                     (VARS (GRAYSHADE 43605))
+                     (ADDVARS (GLOBALVARS GRAYSHADE)))
+              (MACROS DSPRUBOUTCHAR)
+              (FNS DSPCLEOL DSPRUBOUTCHAR \DSPMOVELR)
+              (COMS                                          (* ; "for cursor")
+                    (BITMAPS \DefaultCursor)
+                    [DECLARE%: DONTEVAL@LOAD DOCOPY (INITVARS (DEFAULTCURSOR (CURSORCREATE 
+                                                                                    \DefaultCursor 
+                                                                                    NIL 0 15)))
+                           (P (COND ((NULL \CURRENTCURSOR)
+                                     (SETQ \CURRENTCURSOR DEFAULTCURSOR]
+                    (DECLARE%: DONTCOPY (GLOBALVARS DEFAULTCURSOR]
+        [COMS                                                (* ; 
+      "stuff to interpret colors as textures which is needed even in system that don't have color.")
+              (FNS TEXTUREOFCOLOR \PRIMARYTEXTURE \LEVELTEXTURE INSURE.B&W.TEXTURE INSURE.RGB.COLOR 
+                   \LOOKUPCOLORNAME RGBP HLSP HLSTORGB \HLSVALUEFN)
+              (VARS COLORNAMES)
+              (GLOBALVARS COLORNAMES)
+              (DECLARE%: DONTCOPY (GLOBALVARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 
+                                         WHITESHADE16 REDTEXTURE GREENTEXTURE BLUETEXTURE))
+              (UGLYVARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE 
+                     GREENTEXTURE BLUETEXTURE)
+              (DECLARE%: DONTCOPY                            (* ; "Used by drawcurve")
+                     (EXPORT (RECORDS HLS RGB]
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML)
+                                                                             (LAMA UNIONREGIONS 
+                                                                                   INTERSECTREGIONS])
+
+
+
+(* ; "Interlisp-D dependent stuff.")
+
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
+
+(RECORD REGION (LEFT BOTTOM WIDTH HEIGHT)
+                   LEFT _ -16383 BOTTOM _ -16383 WIDTH _ 32767 HEIGHT _ 32767
+                   [ACCESSFNS ((TOP (IPLUS (fetch (REGION BOTTOM) of DATUM)
+                                           (fetch (REGION HEIGHT) of DATUM)
+                                           -1))
+                               (PTOP (IPLUS (fetch (REGION BOTTOM) of DATUM)
+                                            (fetch (REGION HEIGHT) of DATUM)))
+                               (RIGHT (IPLUS (fetch (REGION LEFT) of DATUM)
+                                             (fetch (REGION WIDTH) of DATUM)
+                                             -1))
+                               (PRIGHT (IPLUS (fetch (REGION LEFT) of DATUM)
+                                              (fetch (REGION WIDTH) of DATUM]
+                   [TYPE? (AND (EQLENGTH DATUM 4)
+                                   (EVERY DATUM (FUNCTION NUMBERP]
+                   (SYSTEM))
+
+(DATATYPE BITMAP ((BITMAPBASE POINTER)
+                      (BITMAPRASTERWIDTH WORD)
+                      (BITMAPHEIGHT WORD)
+                      (BITMAPWIDTH WORD)
+                      (BITMAPBITSPERPIXEL WORD))
+                     BITMAPBITSPERPIXEL _ 1 (BLOCKRECORD BITMAP ((BitMapHiLoc WORD)
+                                                                 (BitMapLoLoc WORD))
+                                                             (* ; "overlay initial pointer")
+                                                   )
+                     (SYSTEM))
+
+(BLOCKRECORD BITMAPWORD ((BITS WORD))
+                            (SYSTEM))
+
+(RECORD POSITION (XCOORD . YCOORD)
+                     [TYPE? (AND (LISTP DATUM)
+                                     (NUMBERP (CAR DATUM))
+                                     (NUMBERP (CDR DATUM]
+                     (SYSTEM))
+
+(DATATYPE CURSOR (CUIMAGE CUMASK CUHOTSPOTX CUHOTSPOTY CUDATA)
+                     [ACCESSFNS ((CUBITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL)
+                                                    of (fetch (CURSOR CUIMAGE) of DATUM]
+                     (SYSTEM))
+
+(RECORD MOUSEEVENT (MOUSEX MOUSEY MOUSEBUTTONS KEYBOARD MOUSETIME)
+                       (SYSTEM))
+
+(RECORD SCREENREGION (SCREEN . REGION)
+                         (SUBRECORD REGION)
+                         [TYPE? (AND (LISTP DATUM)
+                                         (type? SCREEN (CAR DATUM))
+                                         (type? REGION (CDR DATUM]
+                         (SYSTEM))
+
+(RECORD SCREENPOSITION (SCREEN . POSITION)
+                           (SUBRECORD POSITION)
+                           [TYPE? (AND (LISTP DATUM)
+                                           (type? SCREEN (CAR DATUM))
+                                           (type? POSITION (CDR DATUM]
+                           (SYSTEM))
+)
+
+(/DECLAREDATATYPE 'BITMAP '(POINTER WORD WORD WORD WORD)
+       '((BITMAP 0 POINTER)
+         (BITMAP 2 (BITS . 15))
+         (BITMAP 3 (BITS . 15))
+         (BITMAP 4 (BITS . 15))
+         (BITMAP 5 (BITS . 15)))
+       '6)
+
+(/DECLAREDATATYPE 'CURSOR '(POINTER POINTER POINTER POINTER POINTER)
+       '((CURSOR 0 POINTER)
+         (CURSOR 2 POINTER)
+         (CURSOR 4 POINTER)
+         (CURSOR 6 POINTER)
+         (CURSOR 8 POINTER))
+       '10)
+
+(* "END EXPORTED DEFINITIONS")
+
+(ADDTOVAR SYSTEMRECLST
+
+(DATATYPE PILOTBBT ((PBTDESTLO WORD)
+                        (PBTDESTHI WORD)
+                        (PBTDESTBIT WORD)
+                        (PBTDESTBPL SIGNEDWORD)
+                        (PBTSOURCELO WORD)
+                        (PBTSOURCEHI WORD)
+                        (PBTSOURCEBIT WORD)
+                        (PBTSOURCEBPL SIGNEDWORD)
+                        (PBTWIDTH WORD)
+                        (PBTHEIGHT WORD)
+                        (PBTFLAGS WORD)
+                        (NIL 5 WORD)))
+
+(DATATYPE \DISPLAYDATA 
+          (DDXPOSITION DDYPOSITION DDXOFFSET DDYOFFSET DDDestination DDClippingRegion DDFONT 
+                 DDSlowPrintingCase DDWIDTHSCACHE DDOFFSETSCACHE DDCOLOR DDLINEFEED DDRightMargin 
+                 DDLeftMargin DDScroll DDOPERATION DDSOURCETYPE (DDClippingLeft WORD)
+                 (DDClippingRight WORD)
+                 (DDClippingBottom WORD)
+                 (DDClippingTop WORD)
+                 (NIL WORD)
+                 (DDHELDFLG FLAG)
+                 (XWINDOWHINT XPOINTER)
+                 (DDPILOTBBT POINTER)
+                 DDXSCALE DDYSCALE DDCHARIMAGEWIDTHS DDEOLFN DDPAGEFULLFN DDTexture DDMICAXPOS 
+                 DDMICAYPOS DDMICARIGHTMARGIN DDCHARSET (DDCHARSETASCENT WORD)
+                 (DDCHARSETDESCENT WORD)
+                 DDCHARHEIGHTDELTA
+                 (DDSPACEWIDTH WORD)))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ BITSPERINTEGER 32)
+
+
+(CONSTANTS (BITSPERINTEGER 32))
+)
+(DEFINEQ
+
+(\BBTCURVEPT
+  [LAMBDA (X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH RIGHTPLUS1 NBITSRIGHTPLUS1 TOPMINUSBRUSH 
+             DestinationBitMap BRUSHHEIGHT BOTTOMMINUSBRUSH TOP BRUSHBASE DESTINATIONBASE RASTERWIDTH
+             BRUSHRASTERWIDTH COLORBRUSHBASE NBITS DISPLAYDATA)
+                                                             (* kbr%: "27-Aug-86 23:17")
+
+    (* ;; "Called by \CURVEPT macro.  Draws a brush point by bitblting BRUSHBM to point X,Y in DestinationBitMap.  BBT is a BitBlt table where everything is already set except the source and destination addresses, width and height.  In other words, only the easy stuff")
+                                                             (* ; "set the width fields of the bbt")
+    [PROG (CLIPPEDTOP STY)
+          [COND
+             [(ILEQ Y TOPMINUSBRUSH)                         (* ; 
+                                                           "the top part of the brush is visible")
+              (SETQ CLIPPEDTOP (IPLUS Y BRUSHHEIGHT))
+              (replace PBTSOURCE of BBT with BRUSHBASE)
+              (freplace PBTHEIGHT of BBT with (IMIN BRUSHHEIGHT (IDIFFERENCE Y 
+                                                                                   BOTTOMMINUSBRUSH]
+             (T                                              (* ; "only the bottom is visible")
+                (SETQ CLIPPEDTOP TOP)
+                [replace PBTSOURCE of BBT with (\ADDBASE BRUSHBASE
+                                                                  (ITIMES BRUSHRASTERWIDTH
+                                                                         (SETQ STY (IDIFFERENCE
+                                                                                    Y TOPMINUSBRUSH]
+                (freplace PBTHEIGHT of BBT with (IDIFFERENCE (IMIN BRUSHHEIGHT
+                                                                               (IDIFFERENCE Y 
+                                                                                     BOTTOMMINUSBRUSH
+                                                                                      ))
+                                                                   STY]
+          (freplace PBTDEST of BBT with (\ADDBASE DESTINATIONBASE (ITIMES RASTERWIDTH
+                                                                                     (\SFInvert
+                                                                                      
+                                                                                    DestinationBitMap
+                                                                                      CLIPPEDTOP]
+    [COND
+       (COLORBRUSHBASE [COND
+                          [(ILESSP X LEFT)                   (* ; 
+                                                      "only the right part of the brush is visible")
+                                                             (* ; 
+                                                           "FOR NOW BRUTE FORCE WITH NBITS CHECK")
+                           [freplace PBTDESTBIT of BBT with (COND
+                                                                           ((EQ NBITS 4)
+                                                                            (LLSH LEFT 2))
+                                                                           (T (LLSH LEFT 3]
+                           (freplace PBTSOURCEBIT of BBT
+                              with (IDIFFERENCE BRUSHWIDTH
+                                              (freplace PBTWIDTH of BBT
+                                                 with (COND
+                                                             ((EQ NBITS 4)
+                                                              (LLSH (IDIFFERENCE X LEFTMINUSBRUSH)
+                                                                    2))
+                                                             (T (LLSH (IDIFFERENCE X LEFTMINUSBRUSH)
+                                                                      3]
+                          (T                                 (* ; "left edge is visible")
+                             [freplace PBTDESTBIT of BBT with (SETQ X
+                                                                           (COND
+                                                                              ((EQ NBITS 4)
+                                                                               (LLSH X 2))
+                                                                              (T (LLSH X 3]
+                             (freplace PBTSOURCEBIT of BBT with 0)
+                                                             (* ; 
+                                                          "set width to the amount that is visible")
+                             (freplace PBTWIDTH of BBT with (IMIN BRUSHWIDTH
+                                                                              (IDIFFERENCE 
+                                                                                     NBITSRIGHTPLUS1
+                                                                                     X]
+                                                             (* ; 
+                   "if color brush is used, the ground must be cleared before the brush is put in.")
+              (\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA)
+                     'ERASE)
+              (\PILOTBITBLT BBT 0)                           (* ; 
+                                                   "reset the source to point to the color bitmap.")
+              [COND
+                 ((ILEQ Y TOPMINUSBRUSH)                     (* ; 
+                                                           "the top part of the brush is visible")
+                  (freplace PBTSOURCE of BBT with COLORBRUSHBASE))
+                 (T                                          (* ; "only the bottom is visible")
+                    (freplace PBTSOURCE of BBT with (\ADDBASE COLORBRUSHBASE
+                                                                       (ITIMES BRUSHRASTERWIDTH
+                                                                              (IDIFFERENCE Y 
+                                                                                     TOPMINUSBRUSH]
+              (\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA)
+                     'PAINT))
+       (T (COND
+             [(ILESSP X LEFT)                                (* ; 
+                                                      "only the right part of the brush is visible")
+              (freplace PBTDESTBIT of BBT with LEFT)
+              (freplace PBTSOURCEBIT of BBT with (IDIFFERENCE BRUSHWIDTH
+                                                                    (freplace PBTWIDTH
+                                                                       of BBT
+                                                                       with (IDIFFERENCE X 
+                                                                                       LEFTMINUSBRUSH
+                                                                                       ]
+             (T                                              (* ; "left edge is visible")
+                (freplace PBTDESTBIT of BBT with X)
+                (freplace PBTSOURCEBIT of BBT with 0)
+                                                             (* ; 
+                                                          "set width to the amount that is visible")
+                (freplace PBTWIDTH of BBT with (IMIN BRUSHWIDTH (IDIFFERENCE RIGHTPLUS1 X
+                                                                                   ]
+    (\PILOTBITBLT BBT 0])
+)
+(DEFINEQ
+
+(CREATETEXTUREFROMBITMAP
+  [LAMBDA (BITMAP)                                           (* rrb "17-May-84 11:22")
+
+    (* ;; "creates a texture object from the lower left corner of a bitmap")
+
+    (OR (BITMAPP BITMAP)
+        (\ILLEGAL.ARG BITMAP))
+    (PROG ((H (fetch BITMAPHEIGHT of BITMAP))
+           (W (fetch BITMAPWIDTH of BITMAP))
+           TEXTHEIGHT TEXTURE)
+          (COND
+             ((AND (OR (EQ W 2)
+                       (EQ W 4))
+                   (OR (EQ H 2)
+                       (EQ H 4)))                            (* ; 
+                           "small texture will match bitmap exactly so use integer representation.")
+              (SETQ TEXTURE 0)
+              [for X from 0 to 3
+                 do (for Y from 0 to 3
+                           do (COND
+                                     ([NOT (EQ 0 (BITMAPBIT BITMAP (IREMAINDER X W)
+                                                        (IREMAINDER Y H]
+                                      (SETQ TEXTURE (LOGOR TEXTURE
+                                                           (\BITMASK (IPLUS (ITIMES (IDIFFERENCE
+                                                                                     3 Y)
+                                                                                   4)
+                                                                            X]
+              (RETURN TEXTURE))
+             ((AND (EQ W 16)
+                   (ILESSP H 17))                            (* ; 
+                                                          "if it is already 16 by n n<=16, use it.")
+              (RETURN BITMAP))
+             (T                                              (* ; "make a 16 bit wide one.")
+                (SETQ TEXTURE (BITMAPCREATE 16 (IMIN H 16)))
+                (for X from 0 by W to 16
+                   do (BITBLT BITMAP 0 0 TEXTURE X 0 W H 'INPUT 'REPLACE))
+                (RETURN TEXTURE])
+
+(PRINTBITMAP
+  [LAMBDA (BITMAP FILE)                                      (* ; "Edited  1-Dec-86 16:24 by Pavel")
+
+(* ;;; "Writes a bitmap on a file such that READBITMAP will read it back in.")
+
+    (DECLARE (LOCALVARS . T))
+    (PROG ((BM BITMAP))
+          (COND
+             ((type? BITMAP BITMAP))
+             ([AND (LITATOM BITMAP)
+                   (type? BITMAP (SETQ BM (EVALV BITMAP] (* ; 
+                                    "Coerce litatoms for compatibility with original specification")
+              )
+             (T (printout T "******** " BITMAP " is not a BITMAP." T)
+                (RETURN NIL)))
+          (printout FILE "(" .P2 (BITMAPWIDTH BM)
+                 %, .P2 (BITMAPHEIGHT BM))               (* ; 
+                                          "if the number of bits per pixel is not 1, write it out.")
+          (COND
+             ((NEQ (BITSPERPIXEL BM)
+                   1)
+              (SPACES 1 FILE)
+              (PRIN2 (BITSPERPIXEL BM)
+                     FILE)))                                 (* ; 
+                                                   "Enclose in list so that compile-copying works.")
+          (\WRITEBITMAP BM FILE)                         (* ; "Now write out contents.")
+          (PRIN1 ")" FILE])
+
+(PRINT-BITMAPS-NICELY
+  [LAMBDA (BITMAP STREAM)                                    (* ; "Edited 20-Mar-87 17:06 by jop")
+
+(* ;;; "The syntax for bitmaps is")
+
+    (* ;; "#*(width height [bits-per-pixel])XXXXXX...")
+
+(* ;;; "where WIDTH and HEIGHT are the dimensions of the bitmap, BITS-PER-PIXEL can be omitted if it is equal to one, and the X's are single characters between @ and O (in ASCII), each representing four bits.  There will be exactly (* (ceiling (* WIDTH BITS-PER-PIXEL) 16) 4) characters for each row of the bitmap and exactly HEIGHT rows.  Note that there are no spaces allowed between the * and the (, between the ) and the first X, or anywhere inside the string of X's.  Also, the character after the last X must not be of type OTHER.")
+
+(* ;;; "This function %"observes%" *print-length*: it truncates after printing *print-length* characters in the bitmap's representation.")
+
+    (if (OR (NULL STREAM)
+                (NULL *PRINT-ARRAY*))
+        then 
+
+              (* ;; "Let it be printed in the normal way, with an address.")
+
+              NIL
+      else 
+
+            (* ;; "Print this bitmap in the preferred way.")
+
+            (LET* ((WIDTH (BITMAPWIDTH BITMAP))
+                   (HEIGHT (BITMAPHEIGHT BITMAP))
+                   (BITS-PER-PIXEL (BITSPERPIXEL BITMAP))
+                   (BASE (fetch BITMAPBASE of BITMAP))
+                   (QUAD-CHARS-PER-ROW (FOLDHI (LISP:* WIDTH BITS-PER-PIXEL)
+                                              16))
+                   (CHARS-SO-FAR *PRINT-LENGTH*))
+                  (PRINTOUT STREAM "#*(" .P2 WIDTH " " .P2 HEIGHT)
+                  (if (NEQ BITS-PER-PIXEL 1)
+                      then (PRINTOUT STREAM " " .P2 BITS-PER-PIXEL))
+                  (PRINTOUT STREAM ")")
+                  (PROG NIL
+                        [LISP:MACROLET [(ELIDE? NIL `(IF (AND CHARS-SO-FAR (EQ 0 (LISP:DECF
+                                                                                      CHARS-SO-FAR)))
+                                                         THEN (PRINTOUT STREAM "...")
+                                                               (GO OUT]
+                               (LISP:DOTIMES (ROW HEIGHT)
+                                   (LISP:DOTIMES (QUAD QUAD-CHARS-PER-ROW)
+                                       (LISP:WRITE-CHAR (LISP:INT-CHAR (+ (LRSH (\GETBASEBYTE BASE 0)
+                                                                                4)
+                                                                          (LISP:CHAR-INT #\@)))
+                                              STREAM)
+                                       (ELIDE?)
+                                       (LISP:WRITE-CHAR (LISP:INT-CHAR (+ (LOGAND (\GETBASEBYTE
+                                                                                   BASE 0)
+                                                                                 15)
+                                                                          (LISP:CHAR-INT #\@)))
+                                              STREAM)
+                                       (ELIDE?)
+                                       (LISP:WRITE-CHAR (LISP:INT-CHAR (+ (LRSH (\GETBASEBYTE BASE 1)
+                                                                                4)
+                                                                          (LISP:CHAR-INT #\@)))
+                                              STREAM)
+                                       (ELIDE?)
+                                       (LISP:WRITE-CHAR (LISP:INT-CHAR (+ (LOGAND (\GETBASEBYTE
+                                                                                   BASE 1)
+                                                                                 15)
+                                                                          (LISP:CHAR-INT #\@)))
+                                              STREAM)
+                                       (ELIDE?)
+                                       (SETQ BASE (\ADDBASE BASE 1))))]
+                    OUT (RETURN T])
+
+(PRINTCURSOR
+  [LAMBDA (VAR)                                              (* ; "Edited  2-Dec-86 14:15 by Pavel")
+
+    (* ;; "Writes an expression that will define the cursor value of VAR")
+
+    (PROG (CUR IMAGE MASK)
+          (COND
+             ([NOT (type? CURSOR (SETQ CUR (EVALV VAR 'PRINTCURSOR]
+              (printout T "******** " VAR " is not a CURSOR." T)
+              (RETURN NIL)))                                 (* ; "write out defining form.")
+          (\CURSORBITSPERPIXEL CUR 1)
+          (SETQ IMAGE (fetch (CURSOR CUIMAGE) of CUR))
+          (SETQ MASK (fetch (CURSOR CUMASK) of CUR))
+          (PRINT `(RPAQ (\, VAR)
+                        (CURSORCREATE ',IMAGE ',(AND (NOT (EQ IMAGE MASK))
+                                                     MASK)
+                               ,(fetch (CURSOR CUHOTSPOTX)
+                                       of CUR)
+                               ,(fetch (CURSOR CUHOTSPOTY)
+                                       of CUR)))])
+
+(\WRITEBITMAP
+  [LAMBDA (BITMAP FILE)                                      (* ; "Edited  1-Dec-86 16:24 by Pavel")
+
+(* ;;; "writes the contents of a bitmap onto the currently open output file.")
+
+    (PROG (LIM (BASE (fetch BITMAPBASE of BITMAP))
+               (OFD (GETSTREAM FILE 'OUTPUT))
+               (W (fetch BITMAPRASTERWIDTH of BITMAP)))
+          (FRPTQ (fetch BITMAPHEIGHT of BITMAP)
+                 (TERPRI FILE)
+                 (\BOUT OFD (CHARCODE %"))
+                 (SETQ LIM (\ADDBASE BASE W))
+                 (until (EQ BASE LIM) do (\BOUT OFD (IPLUS (SUB1 (CHARCODE A))
+                                                                   (LRSH (\GETBASEBYTE BASE 0)
+                                                                         4)))
+                                                (\BOUT OFD (IPLUS (SUB1 (CHARCODE A))
+                                                                  (LOGAND (\GETBASEBYTE BASE 0)
+                                                                         15)))
+                                                (\BOUT OFD (IPLUS (SUB1 (CHARCODE A))
+                                                                  (LRSH (\GETBASEBYTE BASE 1)
+                                                                        4)))
+                                                (\BOUT OFD (IPLUS (SUB1 (CHARCODE A))
+                                                                  (LOGAND (\GETBASEBYTE BASE 1)
+                                                                         15)))
+                                                (SETQ BASE (\ADDBASE BASE 1)))
+                 (\BOUT OFD (CHARCODE %"])
+)
+
+(DEFPRINT 'BITMAP 'PRINT-BITMAPS-NICELY)
+(DEFINEQ
+
+(\GETINTEGERPART
+  [LAMBDA (FRACT)                                            (* JonL " 7-May-84 02:43")
+
+    (* ;; "gets the integer part of a fixed point number.  The integer part has INTEGERBITS worth of significant bits the leftmost of which is sign.")
+
+    (PROG [HIPART (ROUNDER (COND
+                              ([EQ 0 (LOGAND (fetch (FIXP HINUM) of FRACT)
+                                            (CONSTANT (LLSH 1 (IDIFFERENCE BITSPERWORD (ADD1 
+                                                                                          INTEGERBITS
+                                                                                             ]
+                               0)
+                              (T 1]
+
+     (* ;; "assumes that the number of significant bits --- INTEGERBITS --- is less than can fit in the high order of the two words allocated for the integer.")
+
+          (RETURN (COND
+                     ([IGREATERP [SETQ HIPART (LRSH (fetch (FIXP HINUM) of FRACT)
+                                                    (CONSTANT (IDIFFERENCE BITSPERWORD INTEGERBITS]
+                             (CONSTANT (EXPT 2 (SUB1 INTEGERBITS]
+                                                             (* ; 
+                                                           "the sign bit is on, make it negative.")
+                      (IDIFFERENCE (IDIFFERENCE HIPART (CONSTANT (EXPT 2 INTEGERBITS)))
+                             ROUNDER))
+                     (T (IPLUS HIPART ROUNDER])
+
+(\CONVERTTOFRACTION
+  [LAMBDA (FLOAT)                                            (* rmk%: " 3-JUL-82 23:29")
+
+    (* ;; "converts a floating point number into a fixed point number with INTEGERBITS worth of integer part.  Always returns a large integer so that the box can be clobbered.")
+
+    (PROG (RESULT BOX)
+          (RETURN (COND
+                     ([SMALLP (SETQ RESULT (FIX (FTIMES FLOAT (CONSTANT (FLOAT (EXPT 2
+                                                                                     (IDIFFERENCE
+                                                                                      BITSPERINTEGER
+                                                                                      INTEGERBITS]
+                                                             (* ; "clobber a created box.")
+                      (PutUnboxed (SETQ BOX (CREATECELL \FIXP))
+                             RESULT)
+                      BOX)
+                     (T RESULT])
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ INTEGERBITS 12)
+
+
+(CONSTANTS (INTEGERBITS 12))
+)
+
+
+
+(* ; "cursor functions not on LLDISPLAY")
+
+(DEFINEQ
+
+(CURSORP
+  [LAMBDA (X)                                                (* kbr%: " 5-Jul-85 17:54")
+                                                             (* ; "is X a cursor?")
+    (type? CURSOR X])
+
+(CURSORBITMAP
+  [LAMBDA NIL CursorBitMap])
+
+(CreateCursorBitMap
+  [LAMBDA (ARRAY)                                            (* rmk%: " 1-APR-82 22:20")
+                                                             (* ; 
+                                                        "makes a bitmap out of an array of values.")
+    (PROG ((BM (BITMAPCREATE 16 16))
+           BASE)
+          (SETQ BASE (ffetch BITMAPBASE of BM))
+          (for I from 0 to 15 do (\PUTBASE BASE I (LOGAND (ELT ARRAY (ADD1 I))
+                                                                         WORDMASK)))
+          (RETURN BM])
+)
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS CURSORBITMAP MACRO (NIL CursorBitMap))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ HARDCURSORHEIGHT 16)
+
+(RPAQQ HARDCURSORWIDTH 16)
+
+
+(CONSTANTS (HARDCURSORHEIGHT 16)
+       (HARDCURSORWIDTH 16))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(ADDTOVAR GLOBALVARS CursorBitMap)
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(RPAQQ CARETCOMS
+       ((BITMAPS \DefaultCaret)
+        (INITVARS (\CARET.UP NIL 
+
+                         (* ;; "global.  NIL if no caret showing, otherwise a CARET1 record with CURSOR, stream, x, y, and RATE (= off rate)")
+)
+               (\CARET.DEFAULT NIL                           (* ; 
+                                "global = default caret to put up.  An instance of CARET1 datatype")
+                      )
+               (\CARET.TIMER (SETUPTIMER 0)
+                                                             (* ; "time for next caret action"))
+               (DEFAULTCARET (CURSORCREATE \DefaultCaret NIL 3 4))
+               (DEFAULTCARETRATE 333                         (* ; "default rate for flashing caret")
+                      )
+               (\CARET.ON.RATE DEFAULTCARETRATE)
+               (\CARET.OFF.RATE DEFAULTCARETRATE)
+               (\CARET.FORCED.OFF.RATE 0))
+        (ADDVARS (\SYSTEMTIMERVARS \CARET.TIMER))
+        (DECLARE%: DONTCOPY (RECORDS CARET1))
+        (INITRECORDS CARET1)
+        (FNS CARET \CARET.CREATE \CARET.DOWN \CARET.FLASH? \CARET.SHOW CARETRATE \CARET.FLASH.AGAIN 
+             \CARET.FLASH.MULTIPLE \CARET.FLASH)
+                                                             (* ; "some declarations are on LLDISPLAY -- macro for \CHECKCARET and globalvar declaration for \CARET.UP")
+        (GLOBALVARS \CARET.DEFAULT \CARET.ON.RATE \CARET.OFF.RATE DEFAULTCARET \CARET.TIMER \CARET.UP
+               \CARET.FORCED.OFF.RATE)
+        (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDVARS (TTYBACKGROUNDFNS \CARET.FLASH?)))
+        (FNS \AREAVISIBLE? \REGIONOVERLAPAREAP \AREAINREGIONP)
+        (P (CARET T))))
+
+(RPAQQ \DefaultCaret #*(7 6)A@@@CH@@CH@@FL@@FL@@LF@@)
+
+(RPAQ? \CARET.UP NIL 
+                         (* ;; "global.  NIL if no caret showing, otherwise a CARET1 record with CURSOR, stream, x, y, and RATE (= off rate)")
+)
+
+(RPAQ? \CARET.DEFAULT NIL                                (* ; 
+                                "global = default caret to put up.  An instance of CARET1 datatype")
+)
+
+(RPAQ? \CARET.TIMER (SETUPTIMER 0)
+                                                             (* ; "time for next caret action"))
+
+(RPAQ? DEFAULTCARET (CURSORCREATE \DefaultCaret NIL 3 4))
+
+(RPAQ? DEFAULTCARETRATE 333                              (* ; "default rate for flashing caret")
+)
+
+(RPAQ? \CARET.ON.RATE DEFAULTCARETRATE)
+
+(RPAQ? \CARET.OFF.RATE DEFAULTCARETRATE)
+
+(RPAQ? \CARET.FORCED.OFF.RATE 0)
+
+(ADDTOVAR \SYSTEMTIMERVARS \CARET.TIMER)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE
+
+(RECORD CARET1                                           (* ; 
+                                                          "a record that describes a SHOWING caret")
+                   (STREAM                                   (* ; 
+                                                           "the stream the caret is showing in")
+                          STREAMX                            (* ; 
+                                              "the X position stream relative that it was shown at")
+                          STREAMY                            (* ; 
+                                              "the Y position stream relative that it was shown at")
+                          CURSOR                             (* ; 
+                                           "the cursor bitmap + x and y that this caret represents")
+                          RATE                               (* ; "the 'down rate' for this caret, in ticks.  After comes down (when \CARET.TIMER expires), \CARET.TIMER will be rescheduled to put something up.  This is the rate to use")
+                                                             (* ; 
+                                                           "NEXT for threading carets together")
+                           . NEXT))
+)
+)
+(DEFINEQ
+
+(CARET
+  [LAMBDA (NEWCARET)                                         (* kbr%: " 6-Jul-85 16:13")
+                                                             (* ; 
+                                                           "changes the 'system default' caret")
+    (PROG1 (COND
+              (\CARET.DEFAULT                                (* ; 
+                                                "merely stored as a 'cursor' record for simplicity")
+                     (fetch (CARET1 CURSOR) of \CARET.DEFAULT))
+              (T 'OFF))
+        [COND
+           (NEWCARET (\CHECKCARET)
+                  (CARETRATE (CARETRATE))            (* ; "make sure the caret rate is set")
+                  (SETQ \CARET.DEFAULT (SELECTQ NEWCARET
+                                           (T (COND
+                                                 ((EQ DEFAULTCARET 'OFF)
+                                                  NIL)
+                                                 ((CURSORP DEFAULTCARET)
+                                                  (create CARET1
+                                                         CURSOR _ DEFAULTCARET))
+                                                 (T (ERROR "DEFAULTCARET is not a cursor" 
+                                                           DEFAULTCARET))))
+                                           (OFF NIL)
+                                           (COND
+                                              ((CURSORP NEWCARET)
+                                               (create CARET1
+                                                      CURSOR _ NEWCARET))
+                                              (T (LISPERROR "ILLEGAL ARG" NEWCARET])])
+
+(\CARET.CREATE
+  [LAMBDA (CURSOR)                                       (* jds "11-Jul-85 19:38")
+    (create CARET1
+           CURSOR _ (OR CURSOR DEFAULTCARET])
+
+(\CARET.DOWN
+  [LAMBDA (STREAM INTERVAL UNLESSOCCLUDED)                   (* lmm " 4-May-84 18:15")
+
+    (* ;; "take caret down if it is up.  If you take it down, reschedule to put it back up in INTERVAL (or 0) --- often called thru \CHECKCARET macro")
+
+    (COND
+       (\CARET.UP (COND
+                     ([OR (NULL STREAM)
+                          (fetch (CARET1 NEXT) of \CARET.UP)
+                          (EQ (fetch (CARET1 STREAM) of \CARET.UP)
+                              (COND
+                                 ((type? WINDOW STREAM)
+                                  (fetch (WINDOW DSP) of STREAM))
+                                 (T STREAM]
+                      [while (UNINTERRUPTABLY
+                                     [COND
+                                        ((\CARET.SHOW \CARET.UP UNLESSOCCLUDED)
+                                                             (* ; 
+                                                           "take caret down and set global state")
+                                         (replace (CARET1 STREAM) of \CARET.UP with
+                                                                                       NIL)
+                                         (SETQ \CARET.UP (fetch (CARET1 NEXT) of \CARET.UP])]
+                      (SETUPTIMER (OR INTERVAL \CARET.FORCED.OFF.RATE)
+                             \CARET.TIMER])
+
+(\CARET.FLASH?
+  [LAMBDA (STREAM CARET ONRATE OFFRATE X Y)                  (* AJB "17-Jul-85 12:47")
+
+(* ;;; "Flashes the CARET at the ONRATE/OFFRATE at the X,Y position in the current TTY window.  If CARET is NIL, uses \CARET.DEFAULT as the caret.  Takes either a display stream or a textstream as the destination stream to flash the caret.  The caret is not flashed on a shift-selection in a window")
+
+    (COND
+       (\CARET.UP [COND
+                     ((TIMEREXPIRED? \CARET.TIMER)
+                      (\CARET.DOWN NIL (fetch (CARET1 RATE) of \CARET.UP)
+                             (OR (KEYDOWNP 'LSHIFT)
+                                 (KEYDOWNP 'RSHIFT)
+                                 (KEYDOWNP 'COPY]
+              NIL)
+       ((AND (OR CARET (SETQ CARET \CARET.DEFAULT))
+             (TIMEREXPIRED? \CARET.TIMER)
+             [OR [DISPLAYSTREAMP (OR STREAM (SETQ STREAM (TTYDISPLAYSTREAM]
+                 (AND (IMAGESTREAMTYPEP STREAM 'TEXT)
+                      (SETQ STREAM (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ
+                                                                                         STREAM)))
+                                          'DSP]
+             (\CARET.FLASH CARET STREAM OFFRATE (OR (KEYDOWNP 'LSHIFT)
+                                                        (KEYDOWNP 'RSHIFT)
+                                                        (KEYDOWNP 'COPY))
+                    X Y))
+
+        (* ;; "\CARET.DEFAULT is NIL if by default the caret is OFF --- the KEYDOWNP clause is a hack to detect whether we are doing a copy-select")
+
+        (replace (CARET1 NEXT) of CARET with NIL)(* ; 
+           "Since this function is displaying a new caret, destroy any chaining of multiple carets")
+        (SETUPTIMER (OR ONRATE \CARET.ON.RATE)
+               \CARET.TIMER)
+        T])
+
+(\CARET.SHOW
+  [LAMBDA (CARET UNLESSOCCLUDED)                         (* kbr%: " 2-Sep-85 19:57")
+    (PROG (DS)
+          (SETQ DS (fetch (CARET1 STREAM) of CARET))
+          (RETURN (PROG (DD CARETWIN CBMX CBMY CURSOR CARETBM CWX CWY CARETBMWIDTH CARETBMHEIGHT 
+                            CLIPREG CLIPVAR)
+                        (SETQ DD (fetch (STREAM IMAGEDATA) of DS))
+                        (SETQ CARETWIN (WFROMDS DS))
+                        (SETQ CBMX 0)
+                        (SETQ CBMY 0)
+                        (SETQ CURSOR (fetch (CARET1 CURSOR) of CARET))
+                        (\CURSORBITSPERPIXEL CURSOR (BITSPERPIXEL (DSPDESTINATION NIL CARETWIN)))
+                        (SETQ CARETBM (fetch (CURSOR CUIMAGE) of CURSOR))
+                        (SETQ CWX (fetch (CARET1 STREAMX) of CARET))
+                        (SETQ CWY (fetch (CARET1 STREAMY) of CARET))
+                        (SETQ CARETBMWIDTH (fetch (BITMAP BITMAPWIDTH) of CARETBM))
+                        (SETQ CARETBMHEIGHT (fetch (BITMAP BITMAPHEIGHT) of CARETBM))
+                                                             (* ; 
+        "calculate how much to reduce the caret region by do to the clipping region of the window.")
+                        (SETQ CLIPREG (fetch (\DISPLAYDATA DDClippingRegion) of DD))
+                        (COND
+                           ((IGREATERP (SETQ CLIPVAR (fetch (REGION LEFT) of CLIPREG))
+                                   CWX)
+                            [SETQ CARETBMWIDTH (IDIFFERENCE CARETBMWIDTH (SETQ CBMX (IDIFFERENCE
+                                                                                     CLIPVAR CWX]
+                            (SETQ CWX CLIPVAR)))
+                        (COND
+                           ((IGREATERP CARETBMWIDTH (SETQ CLIPVAR (IDIFFERENCE
+                                                                   (IPLUS CLIPVAR (fetch
+                                                                                   (REGION WIDTH)
+                                                                                     of CLIPREG))
+                                                                   CWX)))
+                            (SETQ CARETBMWIDTH CLIPVAR)))
+                        (COND
+                           ((IGREATERP (SETQ CLIPVAR (fetch (REGION BOTTOM) of CLIPREG))
+                                   CWY)
+                            [SETQ CARETBMHEIGHT (IDIFFERENCE CARETBMHEIGHT (SETQ CBMY
+                                                                            (IDIFFERENCE CLIPVAR CWY]
+                            (SETQ CWY CLIPVAR)))
+                        (COND
+                           ((IGREATERP CARETBMHEIGHT (SETQ CLIPVAR (IDIFFERENCE
+                                                                    (IPLUS CLIPVAR
+                                                                           (fetch (REGION HEIGHT)
+                                                                              of CLIPREG))
+                                                                    CWY)))
+                            (SETQ CARETBMHEIGHT CLIPVAR)))
+
+         (* note the time of the next change. This must be done without creating boxes 
+       because happens during keyboard wait.)
+
+                        (COND
+                           ((OR (ILESSP CARETBMWIDTH 1)
+                                (ILESSP CARETBMHEIGHT 1))    (* caret isn't within clipping 
+                                                           region.)
+                            (RETURN T)))                     (* convert the base of the caret 
+                                                           location to screen coordinates.)
+                        (SETQ CWX (\DSPTRANSFORMX CWX DD))
+                        (SETQ CWY (\DSPTRANSFORMY CWY DD))
+
+         (* having only this section uninterruptable leaves open the possibility that 
+       the window moves or the timer is wrong but these will only mess up the display 
+       and are low frequency events.)
+
+                        (COND
+                           [(AND (OPENWP CARETWIN)
+                                 (\AREAVISIBLE? CARETWIN CWX CWY (IPLUS CWX (SUB1 CARETBMWIDTH))
+                                        (IPLUS CWY (SUB1 CARETBMHEIGHT]
+                           (UNLESSOCCLUDED (RETURN))
+                           (T (TOTOPW CARETWIN)))
+                        (BITBLT CARETBM CBMX CBMY (DSPDESTINATION NIL CARETWIN)
+                               CWX CWY CARETBMWIDTH CARETBMHEIGHT 'INPUT 'INVERT)
+                        (RETURN T])
+
+(CARETRATE
+  [LAMBDA (ONRATE OFFRATE)                                   (* lmm " 3-May-84 11:35")
+
+    (* ;; "sets the default caret rate (s) to be ONRATE/OFFRATE in milliseconds")
+
+    (PROG1 (COND
+              ((EQ \CARET.ON.RATE \CARET.OFF.RATE)
+               \CARET.ON.RATE)
+              (T (CONS \CARET.ON.RATE \CARET.OFF.RATE)))
+        [COND
+           ((OR ONRATE OFFRATE)
+            (SETUPTIMER 0 \CARET.TIMER)
+            (SETQ \CARET.ON.RATE (OR (FIXP ONRATE)
+                                     (FIX DEFAULTCARETRATE)))
+            (SETQ \CARET.OFF.RATE (OR (FIXP OFFRATE)
+                                      \CARET.ON.RATE])])
+
+(\CARET.FLASH.AGAIN
+  [LAMBDA (CARET STREAM X Y)                             (* AJB "14-Aug-85 17:04")
+    (LET ((OCARET \CARET.UP))
+         (COND
+            ([AND OCARET CARET (DISPLAYSTREAMP (OR STREAM (SETQ STREAM (TTYDISPLAYSTREAM]
+             (for (OC _ OCARET) by (fetch (CARET1 NEXT) of OC)
+                do (COND
+                          [(NULL OC)
+                           (RETURN (COND
+                                      ((\CARET.FLASH CARET STREAM (fetch (CARET1 RATE)
+                                                                         of \CARET.UP)
+                                              (OR (KEYDOWNP 'LSHIFT)
+                                                  (KEYDOWNP 'RSHIFT)
+                                                  (KEYDOWNP 'COPY))
+                                              X Y)           (* ; "OK, showed this one")
+                                       (OR (EQ \CARET.UP CARET)
+                                           (SHOULDNT))
+                                       (replace (CARET1 NEXT) of CARET with OCARET]
+                          ((EQ OC CARET)                     (* ; "this CARET is already showing")
+                           (RETURN])
+
+(\CARET.FLASH.MULTIPLE
+  [LAMBDA (STREAMS CARETS ONRATE OFFRATE)                    (* AJB "14-Aug-85 17:10")
+                                                             (* ; 
+                                "this is probably just a template for how to flash multiple carets")
+    (COND
+       ((\CARET.FLASH? (CAR STREAMS)
+               (CAR CARETS)
+               ONRATE OFFRATE)
+        (for STR in (CDR STREAMS) as CARET in (CDR CARETS)
+           do (\CARET.FLASH.AGAIN CARET STR])
+
+(\CARET.FLASH
+  [LAMBDA (CARET STREAM RATE UNLESSOCCLUDED X Y)         (* kbr%: " 5-Jul-85 17:51")
+    (PROG (CURSOR ANSWER)
+          (SETQ CURSOR (fetch (CARET1 CURSOR) of CARET))
+          (replace (CARET1 STREAM) of CARET with STREAM)
+          (replace (CARET1 STREAMX) of CARET with (IDIFFERENCE (OR X (DSPXPOSITION NIL 
+                                                                                        STREAM))
+                                                                     (fetch (CURSOR CUHOTSPOTX)
+                                                                        of CURSOR)))
+          (replace (CARET1 STREAMY) of CARET with (IDIFFERENCE (OR Y (DSPYPOSITION NIL 
+                                                                                        STREAM))
+                                                                     (fetch (CURSOR CUHOTSPOTY)
+                                                                        of CURSOR)))
+          (replace (CARET1 RATE) of CARET with (OR RATE \CARET.OFF.RATE))
+          (UNINTERRUPTABLY
+              (COND
+                 ((\CARET.SHOW CARET UNLESSOCCLUDED)
+                  (SETQ \CARET.UP CARET)
+                  (SETQ ANSWER T))))
+          (RETURN ANSWER])
+)
+
+
+
+(* ; 
+"some declarations are on LLDISPLAY -- macro for \CHECKCARET and globalvar declaration for \CARET.UP")
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \CARET.DEFAULT \CARET.ON.RATE \CARET.OFF.RATE DEFAULTCARET \CARET.TIMER \CARET.UP 
+       \CARET.FORCED.OFF.RATE)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(ADDTOVAR TTYBACKGROUNDFNS \CARET.FLASH?)
+)
+(DEFINEQ
+
+(\AREAVISIBLE?
+  [LAMBDA (WIN LFT BTM RGHT TOP)                             (* kbr%: "18-Feb-86 18:05")
+
+    (* ;; "is the area whose screen limits are LFT BTM RGHT and TOP eniretly visible within WIN,")
+
+    (PROG (WPTR)
+          (SETQ WPTR (fetch (SCREEN SCTOPW) of (fetch (WINDOW SCREEN) of WIN)))
+          (COND
+             ((NOT (\AREAINREGIONP (fetch (WINDOW REG) of WIN)
+                          LFT BTM RGHT TOP))                 (* ; 
+                               "if the caret region isn't completely within the window, forget it.")
+              (RETURN)))
+      LP  (COND
+             ((EQ WPTR WIN)
+              (RETURN T))
+             ((\REGIONOVERLAPAREAP (fetch (WINDOW REG) of WPTR)
+                     LFT BTM RGHT TOP)
+              (RETURN NIL))
+             ((SETQ WPTR (fetch (WINDOW NEXTW) of WPTR))
+              (GO LP])
+
+(\REGIONOVERLAPAREAP
+  [LAMBDA (REG LFT BTM RGHT TOP)                             (* rrb "17-Feb-86 18:50")
+
+    (* ;; 
+  "is there any overlap between the region REG and the area defined by left bottom right and top?")
+
+    (NOT (OR (IGREATERP (fetch (REGION LEFT) of REG)
+                    RGHT)
+             (IGREATERP LFT (fetch (REGION RIGHT) of REG))
+             (IGREATERP (fetch (REGION BOTTOM) of REG)
+                    TOP)
+             (IGREATERP BTM (fetch (REGION TOP) of REG])
+
+(\AREAINREGIONP
+  [LAMBDA (REGION LFT BTM RGHT TOP)                          (* rrb "14-OCT-83 15:32")
+    (AND (IGEQ LFT (fetch LEFT of REGION))
+         (IGEQ BTM (fetch BOTTOM of REGION))
+         (IGEQ (fetch PRIGHT of REGION)
+               RGHT)
+         (IGEQ (fetch PTOP of REGION)
+               TOP])
+)
+
+(CARET T)
+
+
+
+(* ; "Region functions")
+
+(DEFINEQ
+
+(CREATEREGION
+  [LAMBDA (LEFT BOTTOM WIDTH HEIGHT)                         (* rrb "17-JUN-83 08:56")
+                                                             (* ; "creates a region structure.")
+    (create REGION
+           LEFT _ LEFT
+           BOTTOM _ BOTTOM
+           WIDTH _ WIDTH
+           HEIGHT _ HEIGHT])
+
+(REGIONP
+  [LAMBDA (X)                                                (* rrb "29-Jun-84 18:00")
+    (AND (type? REGION X)
+         X])
+
+(INTERSECTREGIONS
+  [LAMBDA REGIONS                                            (* kbr%: "24-Jan-86 18:30")
+
+    (* ;; "returns the largest region that is contained in all of REGIONS")
+
+    (COND
+       ((EQ REGIONS 0)
+
+        (* ;; "this is documented as returning a very large region.  This one covers the entire FIXP range so should work for many purposes.  rrb")
+
+        (create REGION
+               LEFT _ (SUB1 MIN.FIXP)
+               BOTTOM _ (SUB1 MIN.FIXP)
+               WIDTH _ (PLUS (TIMES 2 MAX.FIXP)
+                             4)
+               HEIGHT _ (PLUS (TIMES 2 MAX.FIXP)
+                              4)))
+       (T (PROG (REG LFT RGHT BTTM TP)
+                (SETQ REG (ARG REGIONS 1))
+                (SETQ LFT (fetch (REGION LEFT) of REG))
+                [SETQ RGHT (SUB1 (IPLUS LFT (fetch (REGION WIDTH) of REG]
+                (SETQ BTTM (fetch (REGION BOTTOM) of REG))
+                [SETQ TP (SUB1 (IPLUS BTTM (fetch (REGION HEIGHT) of REG]
+                [for I from 2 thru REGIONS do (SETQ REG (ARG REGIONS I))
+                                                             [COND
+                                                                ((IGREATERP (fetch (REGION LEFT)
+                                                                               of REG)
+                                                                        LFT)
+                                                                 (SETQ LFT (fetch (REGION LEFT)
+                                                                              of REG]
+                                                             [COND
+                                                                ((IGREATERP (fetch (REGION BOTTOM
+                                                                                              )
+                                                                               of REG)
+                                                                        BTTM)
+                                                                 (SETQ BTTM (fetch (REGION BOTTOM
+                                                                                              )
+                                                                               of REG]
+                                                             [COND
+                                                                ((ILESSP (fetch (REGION RIGHT)
+                                                                            of REG)
+                                                                        RGHT)
+                                                                 (SETQ RGHT (fetch (REGION RIGHT)
+                                                                               of REG]
+                                                             (COND
+                                                                ((ILESSP (fetch (REGION TOP)
+                                                                            of REG)
+                                                                        TP)
+                                                                 (SETQ TP (fetch (REGION TOP)
+                                                                             of REG]
+                (RETURN (COND
+                           ((AND (IGEQ RGHT LFT)
+                                 (IGEQ TP BTTM))
+                            (create REGION
+                                   LEFT _ LFT
+                                   BOTTOM _ BTTM
+                                   WIDTH _ (ADD1 (IDIFFERENCE RGHT LFT))
+                                   HEIGHT _ (ADD1 (IDIFFERENCE TP BTTM])
+
+(UNIONREGIONS
+  [LAMBDA REGIONS                                            (* rrb "30-Dec-85 17:07")
+
+    (* ;; "returns the smallest region that encloses all of REGIONS")
+
+    (COND
+       ((EQ 0 REGIONS)
+        NIL)
+       (T (PROG (REG LFT RGHT BTTM TP)
+                (SETQ REG (ARG REGIONS 1))
+                (SETQ LFT (fetch (REGION LEFT) of REG))
+                (SETQ RGHT (fetch (REGION PRIGHT) of REG))
+                (SETQ BTTM (fetch (REGION BOTTOM) of REG))
+                (SETQ TP (fetch (REGION PTOP) of REG))
+                [for I from 2 thru REGIONS do (SETQ REG (ARG REGIONS I))
+                                                             [COND
+                                                                ((LESSP (fetch (REGION LEFT)
+                                                                           of REG)
+                                                                        LFT)
+                                                                 (SETQ LFT (fetch (REGION LEFT)
+                                                                              of REG]
+                                                             [COND
+                                                                ((LESSP (fetch (REGION BOTTOM)
+                                                                           of REG)
+                                                                        BTTM)
+                                                                 (SETQ BTTM (fetch (REGION BOTTOM
+                                                                                              )
+                                                                               of REG]
+                                                             [COND
+                                                                ((GREATERP (fetch (REGION PRIGHT)
+                                                                              of REG)
+                                                                        RGHT)
+                                                                 (SETQ RGHT (fetch (REGION PRIGHT
+                                                                                              )
+                                                                               of REG]
+                                                             (COND
+                                                                ((GREATERP (fetch (REGION PTOP)
+                                                                              of REG)
+                                                                        TP)
+                                                                 (SETQ TP (fetch (REGION PTOP)
+                                                                             of REG]
+                (RETURN (create REGION
+                               LEFT _ LFT
+                               BOTTOM _ BTTM
+                               WIDTH _ (DIFFERENCE RGHT LFT)
+                               HEIGHT _ (DIFFERENCE TP BTTM])
+
+(REGIONSINTERSECTP
+  [LAMBDA (REGION1 REGION2)                                  (* rrb "16-AUG-81 08:29")
+
+    (* ;; "determines if two regions intersect")
+
+    (NOT (OR (IGREATERP (fetch LEFT of REGION1)
+                    (fetch RIGHT of REGION2))
+             (IGREATERP (fetch LEFT of REGION2)
+                    (fetch RIGHT of REGION1))
+             (IGREATERP (fetch BOTTOM of REGION1)
+                    (fetch TOP of REGION2))
+             (IGREATERP (fetch BOTTOM of REGION2)
+                    (fetch TOP of REGION1])
+
+(SUBREGIONP
+  [LAMBDA (LARGEREGION SMALLREGION)                          (* rrb "25-JUN-82 15:09")
+
+    (* ;; "determines if small region is a subset of large region.  (SUBREGIONP '(9 0 100 100) '(0 10 100 80))")
+
+    (AND (IGEQ (fetch LEFT of SMALLREGION)
+               (fetch LEFT of LARGEREGION))
+         (IGEQ (fetch BOTTOM of SMALLREGION)
+               (fetch BOTTOM of LARGEREGION))
+         (IGEQ (fetch PRIGHT of LARGEREGION)
+               (fetch PRIGHT of SMALLREGION))
+         (IGEQ (fetch PTOP of LARGEREGION)
+               (fetch PTOP of SMALLREGION])
+
+(EXTENDREGION
+  [LAMBDA (REGION INCLUDEREGION)                             (* rrb " 5-FEB-82 09:25")
+
+    (* ;; "destructively extends REGION to include INCLUDEREGION")
+
+    [COND
+       ((IGREATERP (fetch (REGION LEFT) of REGION)
+               (fetch (REGION LEFT) of INCLUDEREGION))
+        (replace (REGION WIDTH) of REGION with (IDIFFERENCE (fetch (REGION PRIGHT)
+                                                                           of REGION)
+                                                                  (fetch (REGION LEFT)
+                                                                     of INCLUDEREGION)))
+        (replace (REGION LEFT) of REGION with (fetch (REGION LEFT) of 
+                                                                                        INCLUDEREGION
+                                                                 ]
+    [COND
+       ((IGREATERP (fetch (REGION BOTTOM) of REGION)
+               (fetch (REGION BOTTOM) of INCLUDEREGION))
+        (replace (REGION HEIGHT) of REGION with (IDIFFERENCE (fetch (REGION PTOP)
+                                                                            of REGION)
+                                                                   (fetch (REGION BOTTOM)
+                                                                      of INCLUDEREGION)))
+        (replace (REGION BOTTOM) of REGION with (fetch (REGION BOTTOM) of 
+                                                                                        INCLUDEREGION
+                                                                   ]
+    [COND
+       ((IGREATERP (fetch (REGION RIGHT) of INCLUDEREGION)
+               (fetch (REGION RIGHT) of REGION))
+        (replace (REGION WIDTH) of REGION with (ADD1 (IDIFFERENCE (fetch (REGION
+                                                                                          RIGHT)
+                                                                                 of INCLUDEREGION
+                                                                                     )
+                                                                        (fetch (REGION LEFT)
+                                                                           of REGION]
+    [COND
+       ((IGREATERP (fetch (REGION TOP) of INCLUDEREGION)
+               (fetch (REGION TOP) of REGION))
+        (replace (REGION HEIGHT) of REGION with (ADD1 (IDIFFERENCE (fetch
+                                                                                (REGION TOP)
+                                                                                  of 
+                                                                                        INCLUDEREGION
+                                                                                )
+                                                                         (fetch (REGION BOTTOM)
+                                                                            of REGION]
+    REGION])
+
+(EXTENDREGIONBOTTOM
+  [LAMBDA (REG NEWBOTTOM)                                    (* rrb "29-DEC-81 10:02")
+                                                             (* ; "extends a region to the bottom")
+    (PROG ((OLDBOTTOM (fetch (REGION BOTTOM) of REG)))
+          [COND
+             ((IGREATERP OLDBOTTOM NEWBOTTOM)
+              (replace (REGION BOTTOM) of REG with NEWBOTTOM)
+              (replace (REGION HEIGHT) of REG with (IPLUS (fetch (REGION HEIGHT)
+                                                                         of REG)
+                                                                      (IDIFFERENCE OLDBOTTOM 
+                                                                             NEWBOTTOM]
+          (RETURN REG])
+
+(EXTENDREGIONLEFT
+  [LAMBDA (REG NEWLEFT)                                      (* rrb "29-DEC-81 09:37")
+                                                             (* ; "extends a region to the left")
+    (PROG ((OLDLEFT (fetch (REGION LEFT) of REG)))
+          [COND
+             ((IGREATERP OLDLEFT NEWLEFT)
+              (replace (REGION LEFT) of REG with NEWLEFT)
+              (replace (REGION WIDTH) of REG with (IPLUS (fetch (REGION WIDTH)
+                                                                        of REG)
+                                                                     (IDIFFERENCE OLDLEFT NEWLEFT]
+          (RETURN REG])
+
+(EXTENDREGIONRIGHT
+  [LAMBDA (REG NEWRIGHT)                                     (* rrb "29-DEC-81 10:06")
+                                                             (* ; "extends a region to the left")
+    (PROG ((OLDRIGHT (fetch (REGION RIGHT) of REG)))
+          [COND
+             ((ILESSP OLDRIGHT NEWRIGHT)
+              (replace (REGION WIDTH) of REG with (IPLUS (fetch (REGION WIDTH)
+                                                                        of REG)
+                                                                     (IDIFFERENCE NEWRIGHT OLDRIGHT]
+          (RETURN REG])
+
+(EXTENDREGIONTOP
+  [LAMBDA (REG NEWTOP)                                       (* rrb "29-DEC-81 10:07")
+                                                             (* ; "extends a region to the top")
+    (PROG ((OLDTOP (fetch (REGION TOP) of REG)))
+          [COND
+             ((ILESSP OLDTOP NEWTOP)
+              (replace (REGION HEIGHT) of REG with (IPLUS (fetch (REGION HEIGHT)
+                                                                         of REG)
+                                                                      (IDIFFERENCE NEWTOP OLDTOP]
+          (RETURN REG])
+
+(INSIDEP
+  [LAMBDA (REGION POSORX Y)                                  (* rrb "18-May-84 21:04")
+
+    (* ;; "returns T if the position X Y is inside the region REGION.  If POSORX is a position, returns T if that position is inside of REGION")
+
+    (COND
+       ((WINDOWP REGION)
+        (INSIDEP (DSPCLIPPINGREGION NIL REGION)
+               POSORX Y))
+       (T (COND
+             ((AND (NUMBERP POSORX)
+                   (NUMBERP Y))
+              (INSIDE? REGION POSORX Y))
+             ((POSITIONP POSORX)
+              (INSIDE? REGION (fetch (POSITION XCOORD) of POSORX)
+                     (fetch (POSITION YCOORD) of POSORX)))
+             ((NUMBERP POSORX)
+              (\ILLEGAL.ARG Y))
+             (T (\ILLEGAL.ARG POSORX])
+
+(STRINGREGION
+  [LAMBDA (STR STREAM PRIN2FLG RDTBL)                        (* rmk%: "25-AUG-83 18:06")
+
+    (* ;; "returns the region taken up by STR if it were printed at the current position of STREAM")
+
+    (create REGION
+           LEFT _ (DSPXPOSITION NIL STREAM)
+           BOTTOM _ (IDIFFERENCE (DSPYPOSITION NIL STREAM)
+                           (FONTPROP STREAM 'DESCENT))
+           WIDTH _ (STRINGWIDTH STR STREAM PRIN2FLG RDTBL)
+           HEIGHT _ (FONTPROP STREAM 'HEIGHT])
+)
+
+
+
+(* ; "line and spline drawing.")
+
+
+
+
+(* ; "Brushes and brush initialization")
+
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+[PUTDEF '\BRUSHBBT 'RESOURCES '(NEW (create PILOTBBT]
+)
+)
+
+(/SETTOPVAL '\\BRUSHBBT.GLOBALRESOURCE NIL)
+(DEFINEQ
+
+(\BRUSHBITMAP
+  [LAMBDA (BRUSHSHAPE BRUSHWIDTH)                            (* rrb " 9-Sep-86 16:30")
+
+(* ;;; 
+"returns the bitmap for the brush of the shape and size.  See comments on \InitCurveBrushes.")
+
+    (DECLARE (GLOBALVARS \BrushAList))
+    (LET [(BRUSHES&METHOD (CDR (OR (FASSOC BRUSHSHAPE \BrushAList)
+                                   (\ILLEGAL.ARG BRUSHSHAPE]
+         (COND
+            ((NOT (GREATERP BRUSHWIDTH 0))
+
+             (* ;; "if brush is 0 or negative, return an empty brush.  Might want to error but this would require users to handle it.")
+
+             (BITMAPCREATE 0 0))
+            [(ILESSP BRUSHWIDTH 17)                          (* ; 
+                                            "lowest 16 brushes are stored.  FIX them so ELT works.")
+             (ELT (fetch (BRUSHITEM BRUSHARRAY) of BRUSHES&METHOD)
+                  (COND
+                     ((FIXP BRUSHWIDTH))
+                     ((GREATERP BRUSHWIDTH 1)
+                      (FIXR BRUSHWIDTH))
+                     (T 1]
+            [(CDR (FASSOC BRUSHWIDTH (fetch (BRUSHITEM BRUSHCACHE) of BRUSHES&METHOD]
+            (T 
+               (* ;; "cache the brush bitmap.  This is done so that the brush creation methods don't have to be efficient.")
+
+               (LET ((NEWBRUSHBM (APPLY* (fetch (BRUSHITEM CREATEMETHOD) of BRUSHES&METHOD)
+                                        BRUSHWIDTH)))
+                    (replace (BRUSHITEM BRUSHCACHE) of BRUSHES&METHOD
+                       with (CONS (CONS BRUSHWIDTH NEWBRUSHBM)
+                                      (fetch (BRUSHITEM BRUSHCACHE) of BRUSHES&METHOD)))
+                    NEWBRUSHBM])
+
+(\GETBRUSH
+  [LAMBDA (BRUSH)                                            (* rrb " 9-Sep-86 16:30")
+    (COND
+       ((type? BITMAP BRUSH)
+        BRUSH)
+       [(LISTP BRUSH)
+        (\BRUSHBITMAP (CAR BRUSH)
+               (CAR (LISTP (CDR BRUSH]
+       (T (\BRUSHBITMAP 'ROUND (OR BRUSH 1])
+
+(\GETBRUSHBBT
+  [LAMBDA (BRUSHBM DISPLAYDATA BBT)                          (* kbr%: "18-Aug-85 12:46")
+
+    (* ;; "Initializes BBT for the BRUSHBM and DS and returns BBT, unless the BRUSHBM is a 1-point brush, in which case it returns NIL.")
+
+    (COND
+       ((AND (EQ (fetch (BITMAP BITMAPHEIGHT) of BRUSHBM)
+                 1)
+             (EQ (ffetch (BITMAP BITMAPWIDTH) of BRUSHBM)
+                 1)
+             (EQ (BITMAPBIT BRUSHBM 0 0)
+                 1))                                         (* ; 
+                                                        "special case of single point brush shape.")
+        NIL)
+       (T                                                    (* ; 
+                             "update as many fields in the brush bitblt table as possible from DS.")
+          (replace (PILOTBBT PBTDESTBPL) of BBT with (UNFOLD (fetch (BITMAP 
+                                                                                    BITMAPRASTERWIDTH
+                                                                                           )
+                                                                            of
+                                                                            (fetch (\DISPLAYDATA
+                                                                                        DDDestination
+                                                                                        )
+                                                                               of DISPLAYDATA))
+                                                                        BITSPERWORD))
+          (freplace (PILOTBBT PBTSOURCEBPL) of BBT with (UNFOLD (ffetch (BITMAP
+                                                                                         
+                                                                                    BITMAPRASTERWIDTH
+                                                                                         )
+                                                                               of BRUSHBM)
+                                                                           BITSPERWORD))
+          (freplace (PILOTBBT PBTFLAGS) of BBT with 0)
+          (freplace (PILOTBBT PBTDISJOINT) of BBT with T)
+          (\SETPBTFUNCTION BBT (ffetch (\DISPLAYDATA DDSOURCETYPE) of DISPLAYDATA)
+                 (SELECTQ (ffetch (\DISPLAYDATA DDOPERATION) of DISPLAYDATA)
+                     ((PAINT REPLACE) 
+                          'PAINT)
+                     ((INVERT ERASE) 
+                          'ERASE)
+                     (SHOULDNT)))
+          BBT])
+
+(\InitCurveBrushes
+  [LAMBDA NIL                                                (* ; "Edited 13-Oct-87 14:31 by jds")
+
+    (* ;; "Set up the initial set of brush specs for curve drawing.  \BrushAList is an association list from brush-shape-names to a spec which is an instance of the record BRUSHITEM.")
+
+    (DECLARE (GLOBALVARS \BrushNames \BrushAList \SingleBitBitmap))
+    (PROG (BARRAY CREATIONMETHOD)
+          (SETQ \SingleBitBitmap (BITMAPCREATE 1 1))
+          (BITMAPBIT \SingleBitBitmap 0 0 1)
+          (for BRUSHNAME in \BrushNames do (SETQ BARRAY (ARRAY 16 'POINTER NIL 1))
+                                                      (SETQ CREATIONMETHOD (PACK* '\MAKEBRUSH. 
+                                                                                  BRUSHNAME))
+                                                      (SETA BARRAY 1 \SingleBitBitmap)
+                                                      (for SIZE from 2 to 16
+                                                         do (SETA BARRAY SIZE (APPLY* 
+                                                                                       CREATIONMETHOD
+                                                                                         SIZE)))
+                                                      (INSTALLBRUSH BRUSHNAME CREATIONMETHOD 
+                                                             BARRAY])
+
+(\BrushFromWidth
+  [LAMBDA (W)                                                (* hdj " 5-Nov-84 16:47")
+    (LIST 'ROUND W])
+)
+(DEFINEQ
+
+(\MAKEBRUSH.DIAGONAL
+  [LAMBDA (SIZE)                                             (* kbr%: "18-Aug-85 12:51")
+    (PROG (BM)
+          (SETQ BM (BITMAPCREATE SIZE SIZE))
+          (for X from 0 to (SUB1 SIZE) do (BITMAPBIT BM X X 1))
+          (RETURN BM])
+
+(\MAKEBRUSH.HORIZONTAL
+  [LAMBDA (SIZE)                                             (* kbr%: "18-Aug-85 12:52")
+
+(* ;;; "create a brush that has a horizontal line across it halfway down")
+
+    (PROG (BM)
+          (SETQ BM (BITMAPCREATE SIZE SIZE))
+          (BITBLT NIL NIL NIL BM 0 (SUB1 (FOLDHI SIZE 2))
+                 NIL 1 'TEXTURE 'REPLACE BLACKSHADE)
+          (RETURN BM])
+
+(\MAKEBRUSH.VERTICAL
+  [LAMBDA (SIZE)                                             (* kbr%: "18-Aug-85 12:53")
+    (PROG (BM)
+          (SETQ BM (BITMAPCREATE SIZE SIZE))
+          (BITBLT NIL NIL NIL BM (SUB1 (FOLDHI SIZE 2))
+                 0 1 SIZE 'TEXTURE 'REPLACE BLACKSHADE)
+          (RETURN BM])
+
+(\MAKEBRUSH.SQUARE
+  [LAMBDA (SIZE)                                             (* kbr%: "18-Aug-85 13:07")
+    (PROG (BM)
+          (SETQ BM (BITMAPCREATE SIZE SIZE))
+          (BITBLT NIL NIL NIL BM NIL NIL NIL NIL 'TEXTURE 'REPLACE BLACKSHADE)
+          (RETURN BM])
+
+(\MAKEBRUSH.ROUND
+  [LAMBDA (SIZE)                                             (* rrb "15-Sep-86 14:32")
+                                                             (* ; 
+                                       "special cased 8 so that it wouldn't have a width of 7. rrb")
+    (PROG (RADIUS BITMAP BASE)
+          (SETQ RADIUS (SUB1 (HALF SIZE)))
+          (SETQ BITMAP (BITMAPCREATE SIZE SIZE))
+          (SETQ BASE (fetch (BITMAP BITMAPBASE) of BITMAP))
+          (SELECTQ SIZE
+              (1 (\PUTBASE BASE 0 (MASK.1'S 15 1)))
+              (2 (\PUTBASE BASE 0 (MASK.1'S 14 2))
+                 (\PUTBASE BASE 1 (MASK.1'S 14 2)))
+              (3 (\PUTBASE BASE 0 (MASK.1'S 14 1))
+                 (\PUTBASE BASE 1 (MASK.1'S 13 3))
+                 (\PUTBASE BASE 2 (MASK.1'S 14 1)))
+              (4 (\PUTBASE BASE 0 (MASK.1'S 13 2))
+                 (\PUTBASE BASE 1 (MASK.1'S 12 4))
+                 (\PUTBASE BASE 2 (MASK.1'S 12 4))
+                 (\PUTBASE BASE 3 (MASK.1'S 13 2)))
+              (5 (\PUTBASE BASE 0 (MASK.1'S 13 1))
+                 (\PUTBASE BASE 1 (MASK.1'S 12 3))
+                 (\PUTBASE BASE 2 (MASK.1'S 11 5))
+                 (\PUTBASE BASE 3 (MASK.1'S 12 3))
+                 (\PUTBASE BASE 4 (MASK.1'S 13 1)))
+              (8 (\PUTBASE BASE 0 (MASK.1'S 10 4))
+                 (\PUTBASE BASE 1 (MASK.1'S 9 6))
+                 (\PUTBASE BASE 2 (MASK.1'S 8 8))
+                 (\PUTBASE BASE 3 (MASK.1'S 8 8))
+                 (\PUTBASE BASE 4 (MASK.1'S 8 8))
+                 (\PUTBASE BASE 5 (MASK.1'S 8 8))
+                 (\PUTBASE BASE 6 (MASK.1'S 9 6))
+                 (\PUTBASE BASE 7 (MASK.1'S 10 4)))
+              (FILLCIRCLE RADIUS RADIUS RADIUS BLACKSHADE (DSPCREATE BITMAP)))
+          (RETURN BITMAP])
+)
+(DEFINEQ
+
+(INSTALLBRUSH
+  [LAMBDA (BRUSHNAME BRUSHFN BRUSHARRAY)                     (* kbr%: "18-Jan-86 15:27")
+    (DECLARE (GLOBALVARS \BrushAList))
+    (PROG (OLDENTRY)
+          (SETQ OLDENTRY (FASSOC BRUSHNAME \BrushAList))
+          (COND
+             (OLDENTRY (AND BRUSHARRAY (replace (BRUSHITEM BRUSHARRAY) of (CDR OLDENTRY)
+                                          with BRUSHARRAY))
+                    (AND BRUSHFN (replace (BRUSHITEM CREATEMETHOD) of (CDR OLDENTRY)
+                                    with BRUSHFN)))
+             (T [COND
+                   ((AND BRUSHFN (NOT (ARRAYP BRUSHARRAY)))
+                    (SETQ BRUSHARRAY (ARRAY 16 'POINTER NIL 1))
+                    (for X from 1 to 16 do (SETA BRUSHARRAY X (APPLY* BRUSHFN X]
+                (push \BrushAList (CONS BRUSHNAME (create BRUSHITEM
+                                                             BRUSHARRAY _ BRUSHARRAY
+                                                             CREATEMETHOD _ BRUSHFN)))
+                (push KNOWN.BRUSHES BRUSHNAME])
+)
+
+(RPAQQ \BrushNames (ROUND SQUARE DIAGONAL HORIZONTAL VERTICAL))
+
+(RPAQ? KNOWN.BRUSHES NIL)
+
+(RPAQ? \BrushAList NIL)
+(DECLARE%: EVAL@COMPILE
+
+(RECORD BRUSHITEM (BRUSHARRAY CREATEMETHOD . BRUSHCACHE))
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(\InitCurveBrushes)
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \BrushAList KNOWN.BRUSHES)
+)
+)
+
+
+
+(* ; "Lines")
+
+(DEFINEQ
+
+(\DRAWLINE.DISPLAY
+  [LAMBDA (DISPLAYSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING)
+                                                             (* ; 
+                                                           "Edited 29-Jan-91 14:59 by matsuda")
+
+    (* ;; "DISPLAYSTREAM is guaranteed to be a display-stream.  Draws a line from x1,y1 to x2,y2 leaving the position at x2,y2")
+
+    (* ;; "Added handling of brushes (I think, this is actually pretty tricky).")
+
+    (DECLARE (LOCALVARS . T))
+    [COND
+       [(OR DASHING (BRUSHP WIDTH))
+        (GLOBALRESOURCE
+         \BRUSHBBT
+         (LET ((BBT \BRUSHBBT)
+               (BRUSH (INSURE.BRUSH WIDTH)))
+              (if COLOR
+                  then (replace (BRUSH BRUSHCOLOR) of BRUSH with COLOR))
+              (IF [NOT (type? BIGBM (ffetch DDDestination of (fetch IMAGEDATA
+                                                                                of DISPLAYSTREAM]
+                  THEN (\LINEWITHBRUSH X1 Y1 X2 Y2 BRUSH (\GOOD.DASHLST DASHING BRUSH)
+                                  DISPLAYSTREAM BBT (SELECTQ OPERATION
+                                                        (NIL (ffetch DDOPERATION
+                                                                of (fetch IMAGEDATA
+                                                                          of DISPLAYSTREAM)))
+                                                        ((REPLACE PAINT INVERT ERASE) 
+                                                             OPERATION)
+                                                        (\ILLEGAL.ARG OPERATION)))
+                ELSE (PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM))
+                                BITMAP BIGBMLIST HEIGHT BOTTOM BM YY1 YY2 ClippingTop ClippingBottom
+                                CTop CBottom)
+                               (SETQ BITMAP (ffetch DDDestination of DD))
+                               (SETQ BIGBMLIST (fetch (BIGBM BIGBMLIST) of BITMAP))
+                               (SETQ HEIGHT (BITMAPHEIGHT BITMAP))
+                               (SETQ ClippingTop (ffetch DDClippingTop of DD))
+                               (SETQ ClippingBottom (ffetch DDClippingBottom of DD))
+                               (SETQ BM (GetNewFragment BIGBMLIST))
+                               (while (AND BM (IGREATERP HEIGHT ClippingBottom))
+                                  do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM)))
+                                        [SETQ CTop (COND
+                                                      ((IGREATERP ClippingTop HEIGHT)
+                                                       (IDIFFERENCE HEIGHT BOTTOM))
+                                                      (T (IDIFFERENCE ClippingTop BOTTOM]
+                                        (if (IGEQ CTop 0)
+                                            then [SETQ CBottom (COND
+                                                                      ((ILESSP ClippingBottom BOTTOM)
+                                                                       0)
+                                                                      (T (IDIFFERENCE ClippingBottom
+                                                                                BOTTOM]
+                                                  (replace DDDestination of DD with
+                                                                                       BM)
+                                                  (replace DDClippingTop of DD with
+                                                                                       CTop)
+                                                  (replace DDClippingBottom of DD
+                                                     with CBottom)
+                                                  (\LINEWITHBRUSH
+                                                   X1
+                                                   (IDIFFERENCE Y1 BOTTOM)
+                                                   X2
+                                                   (IDIFFERENCE Y2 BOTTOM)
+                                                   BRUSH
+                                                   (\GOOD.DASHLST DASHING BRUSH)
+                                                   DISPLAYSTREAM BBT
+                                                   (SELECTQ OPERATION
+                                                       (NIL (ffetch DDOPERATION
+                                                               of (fetch IMAGEDATA
+                                                                         of DISPLAYSTREAM)))
+                                                       ((REPLACE PAINT INVERT ERASE) 
+                                                            OPERATION)
+                                                       (\ILLEGAL.ARG OPERATION)))
+                                                  (SETQ BM (GetNewFragment BIGBMLIST))
+                                                  (SETQ HEIGHT BOTTOM)))
+                               (freplace DDDestination of DD with BITMAP)
+                               (freplace DDClippingTop of DD with ClippingTop)
+                               (freplace DDClippingBottom of DD with ClippingBottom]
+       (T (PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM))
+                 BITMAP)
+                (\INSURETOPWDS DISPLAYSTREAM)                (* ; "bring the window to the top")
+                (SETQ BITMAP (ffetch DDDestination of DD))
+                (COND
+                   ((NOT (type? BIGBM BITMAP))
+                    (\CLIPANDDRAWLINE (\DSPTRANSFORMX (OR (FIXP X1)
+                                                              (FIXR X1))
+                                                 DD)
+                           (\DSPTRANSFORMY (OR (FIXP Y1)
+                                               (FIXR Y1))
+                                  DD)
+                           (\DSPTRANSFORMX (OR (FIXP X2)
+                                               (FIXR X2))
+                                  DD)
+                           (\DSPTRANSFORMY (OR (FIXP Y2)
+                                               (FIXR Y2))
+                                  DD)
+                           [COND
+                              ((NULL WIDTH)
+                               1)
+                              ((OR (FIXP WIDTH)
+                                   (FIXR WIDTH]
+                           (SELECTQ OPERATION
+                               (NIL (ffetch DDOPERATION of DD))
+                               ((REPLACE PAINT INVERT ERASE) 
+                                    OPERATION)
+                               (\ILLEGAL.ARG OPERATION))
+                           BITMAP
+                           (ffetch DDClippingLeft of DD)
+                           (SUB1 (ffetch DDClippingRight of DD))
+                           (ffetch DDClippingBottom of DD)
+                           (SUB1 (ffetch DDClippingTop of DD))
+                           DISPLAYSTREAM COLOR))
+                   (T (PROG ((BIGBMLIST (fetch (BIGBM BIGBMLIST) of BITMAP))
+                             (HEIGHT (BITMAPHEIGHT BITMAP))
+                             BOTTOM BM CTop CBottom (ClippingTop (ffetch DDClippingTop
+                                                                    of DD))
+                             (ClippingBottom (ffetch DDClippingBottom of DD))
+                             (YY1 (\DSPTRANSFORMY (OR (FIXP Y1)
+                                                      (FIXR Y1))
+                                         DD))
+                             (YY2 (\DSPTRANSFORMY (OR (FIXP Y2)
+                                                      (FIXR Y2))
+                                         DD)))
+                            (SETQ BM (GetNewFragment BIGBMLIST))
+                            (while (AND BM (IGREATERP HEIGHT ClippingBottom))
+                               do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM)))
+                                     [SETQ CTop (COND
+                                                   ((IGREATERP ClippingTop HEIGHT)
+                                                    (IDIFFERENCE HEIGHT BOTTOM))
+                                                   (T (IDIFFERENCE ClippingTop BOTTOM]
+                                     (COND
+                                        ((IGEQ CTop 0)
+                                         [SETQ CBottom (COND
+                                                          ((ILESSP ClippingBottom BOTTOM)
+                                                           0)
+                                                          (T (IDIFFERENCE ClippingBottom BOTTOM]
+                                         (\CLIPANDDRAWLINE (\DSPTRANSFORMX (OR (FIXP X1)
+                                                                                   (FIXR X1))
+                                                                      DD)
+                                                (IDIFFERENCE YY1 BOTTOM)
+                                                (\DSPTRANSFORMX (OR (FIXP X2)
+                                                                    (FIXR X2))
+                                                       DD)
+                                                (IDIFFERENCE YY2 BOTTOM)
+                                                [COND
+                                                   ((NULL WIDTH)
+                                                    1)
+                                                   ((OR (FIXP WIDTH)
+                                                        (FIXR WIDTH]
+                                                (SELECTQ OPERATION
+                                                    (NIL (ffetch DDOPERATION of DD))
+                                                    ((REPLACE PAINT INVERT ERASE) 
+                                                         OPERATION)
+                                                    (\ILLEGAL.ARG OPERATION))
+                                                BM
+                                                (ffetch DDClippingLeft of DD)
+                                                (SUB1 (ffetch DDClippingRight of DD))
+                                                CBottom
+                                                (SUB1 CTop)
+                                                DISPLAYSTREAM COLOR)))
+                                     (SETQ BM (GetNewFragment BIGBMLIST))
+                                     (SETQ HEIGHT BOTTOM]    (* ; 
+             "the generic case of MOVETO is used so that the hardcopy streams get handled as well.")
+    (MOVETO X2 Y2 DISPLAYSTREAM])
+
+(RELMOVETO
+  [LAMBDA (DX DY STREAM)                                     (* rmk%: "25-AUG-83 18:13")
+                                                             (* ; "moves the position by a vector")
+    (DSPXPOSITION [IPLUS DX (DSPXPOSITION NIL (SETQ STREAM (\OUTSTREAMARG STREAM]
+           STREAM)
+    (DSPYPOSITION (IPLUS DY (DSPYPOSITION NIL STREAM))
+           STREAM])
+
+(MOVETOUPPERLEFT
+  [LAMBDA (STREAM REGION)                                    (* hdj " 5-Jul-85 12:19")
+
+    (* ;; "moves the current position to the upper left corner so that the first line of text will all appear.")
+
+    (PROG [(ASCENT (FONTPROP (DSPFONT NIL STREAM)
+                          'ASCENT]
+          (COND
+             ((AND REGION (OR (type? REGION REGION)
+                              (\ILLEGAL.ARG REGION)))
+              (MOVETO (fetch (REGION LEFT) of REGION)
+                     (IDIFFERENCE (fetch (REGION PTOP) of REGION)
+                            ASCENT)
+                     STREAM))
+             (T (MOVETO (DSPLEFTMARGIN NIL STREAM)
+                       (IDIFFERENCE (fetch (REGION PTOP) of (DSPCLIPPINGREGION NIL STREAM))
+                              ASCENT)
+                       STREAM)))
+          (RETURN STREAM])
+)
+(DEFINEQ
+
+(\CLIPANDDRAWLINE
+  [LAMBDA (X1 Y1 X2 Y2 WIDTH OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS COLOR)
+                                                             (* ; "Edited 21-Aug-91 12:15 by jds")
+
+    (* ;; "draws a line from {X1,Y1} to {X2,Y2} clipped to region specified by LEFT RIGHT BOTTOM and TOP.  This code is a transliterated version of the BCPL routine that was in chat.")
+
+    (* ;; "assumes that the width is at least 1")
+
+    (* ;; "DS is passed so that window can be uninterruptably brought to top.")
+
+    (COND
+       ((NOT (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)
+                 1))                                         (* ; 
+                                                           "make adjustments in case of color.")
+        (SETQ COLOR (COLORNUMBERP (OR COLOR (DSPCOLOR NIL DS))
+                           (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)))
+                                                             (* ; "(COND ((EQ OPERATION 'ERASE) ; treat erase as AND of background (SETQ COLOR (OPPOSITECOLOR COLOR (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)))))")
+        )
+       (T (SETQ COLOR BLACKSHADE)))
+    (PROG NIL
+          (COND
+             [(EQ X1 X2)                                     (* ; "special case of vertical line.")
+              [COND
+                 ((IGREATERP WIDTH 2)
+                  (COND
+                     [(EQ Y1 Y2)
+
+                      (* ;; "special case.  Since we don't know whether the guy is headed horizontally or vertically, put out a round brush This is a fairly infrequent case because I didn't get any bug reports on it in three years so efficiency is not a consideration.")
+
+                      (RETURN (.WHILE.TOP.DS. DS (\DRAWPOINT.DISPLAY (DSPDESTINATION NIL DS)
+                                                        X1 Y1 (LIST 'ROUND WIDTH COLOR)
+                                                        OPERATION]
+                     (T (SETQ X1 (SETQ X2 (IDIFFERENCE X1 (LRSH (SUB1 WIDTH)
+                                                                1]
+              (PROG (MIN MAX)
+                    (RETURN (COND
+                               ([OR (IGREATERP X1 RIGHT)
+                                    (IGEQ LEFT (SETQ X2 (IPLUS X1 WIDTH)))
+                                    (IGREATERP (SETQ MIN (IMIN Y1 Y2))
+                                           TOP)
+                                    (IGREATERP BOTTOM (SETQ MAX (IMAX Y1 Y2]
+                                                             (* ; "outside clippingregion.")
+                                NIL)
+                               (T (.WHILE.TOP.DS. DS (BITBLT NIL 0 0 BITMAP (SETQ X1 (IMAX X1 LEFT))
+                                                            (SETQ MIN (IMAX MIN BOTTOM))
+                                                            (IDIFFERENCE (IMIN X2 (ADD1 RIGHT))
+                                                                   X1)
+                                                            (ADD1 (IDIFFERENCE (IMIN MAX TOP)
+                                                                         MIN))
+                                                            'TEXTURE OPERATION COLOR]
+             [(EQ Y1 Y2)                                     (* ; 
+                                                           "special case of horizontal line.")
+              [COND
+                 ((IGREATERP WIDTH 2)
+                  (SETQ Y1 (SETQ Y2 (IDIFFERENCE Y1 (LRSH (SUB1 WIDTH)
+                                                          1]
+              (PROG (MIN MAX)
+                    (RETURN (COND
+                               ([OR (IGREATERP Y1 TOP)
+                                    (IGEQ BOTTOM (SETQ Y2 (IPLUS Y1 WIDTH)))
+                                    (IGREATERP (SETQ MIN (IMIN X1 X2))
+                                           RIGHT)
+                                    (IGREATERP LEFT (SETQ MAX (IMAX X1 X2]
+                                                             (* ; "outside clippingregion.")
+                                NIL)
+                               (T (.WHILE.TOP.DS. DS (BITBLT NIL 0 0 BITMAP (SETQ MIN
+                                                                             (IMAX MIN LEFT))
+                                                            (SETQ Y1 (IMAX Y1 BOTTOM))
+                                                            (ADD1 (IDIFFERENCE (IMIN MAX RIGHT)
+                                                                         MIN))
+                                                            (IDIFFERENCE (IMIN Y2 (ADD1 TOP))
+                                                                   Y1)
+                                                            'TEXTURE OPERATION COLOR]
+             ((EQ WIDTH 1)                                   (* ; "special case of width 1")
+              (\CLIPANDDRAWLINE1 X1 Y1 X2 Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS COLOR))
+             ((IGREATERP (IABS (IDIFFERENCE X1 X2))
+                     (IABS (IDIFFERENCE Y1 Y2)))             (* ; 
+                         "slope is more horizontal, so make line grow in the positive y direction.")
+              [COND
+                 ((IGREATERP WIDTH 2)
+                  (PROG (HALFWIDTH)
+                        (SETQ HALFWIDTH (LRSH (SUB1 WIDTH)
+                                              1))
+                        (SETQ Y1 (IDIFFERENCE Y1 HALFWIDTH))
+                        (SETQ Y2 (IDIFFERENCE Y2 HALFWIDTH]
+              (for I from Y1 to (SUB1 (IPLUS Y1 WIDTH)) as J from Y2
+                 do (\CLIPANDDRAWLINE1 X1 I X2 J OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS 
+                               COLOR)))
+             (T                                              (* ; 
+                           "slope is more vertical, so make line grow in the positive x direction.")
+                [COND
+                   ((IGREATERP WIDTH 2)
+                    (PROG (HALFWIDTH)
+                          (SETQ HALFWIDTH (LRSH (SUB1 WIDTH)
+                                                1))
+                          (SETQ X1 (IDIFFERENCE X1 HALFWIDTH))
+                          (SETQ X2 (IDIFFERENCE X2 HALFWIDTH]
+                (for I from X1 to (SUB1 (IPLUS X1 WIDTH)) as J from X2
+                   do (\CLIPANDDRAWLINE1 I Y1 J Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS
+                                 COLOR])
+
+(\CLIPANDDRAWLINE1
+  [LAMBDA (X1 Y1 X2 Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS COLOR)
+                                                             (* JonL " 7-May-84 02:57")
+
+    (* ;; "LEFT, RIGHT, BOTTOM, TOP are set to the boundaries of the clipping region")
+
+    (* ;; "DS is passed so that window can be uninterruptably brought to top.")
+
+    (PROG (DX DY YMOVEUP HALFDX HALFDY (BMRASTERWIDTH (fetch BITMAPRASTERWIDTH of BITMAP)))
+          (COND
+             ((IGREATERP X1 X2)                              (* ; 
+                                                          "switch points so DX is always positive.")
+              (SETQ HALFDX X1)
+              (SETQ X1 X2)
+              (SETQ X2 HALFDX)
+              (SETQ HALFDX Y1)
+              (SETQ Y1 Y2)
+              (SETQ Y2 HALFDX)))                             (* ; 
+                                                    "calculate differences and sign of Y movement.")
+          (SETQ HALFDX (LRSH (SETQ DX (IDIFFERENCE X2 X1))
+                             1))
+          (SETQ HALFDY (LRSH [SETQ DY (COND
+                                         ((IGREATERP Y2 Y1)
+                                          (SETQ YMOVEUP T)
+                                          (IDIFFERENCE Y2 Y1))
+                                         (T (IDIFFERENCE Y1 Y2]
+                             1))
+          (COND
+             ((AND (IGEQ X1 LEFT)
+                   (IGEQ RIGHT X2)
+                   [COND
+                      (YMOVEUP (AND (IGEQ Y1 BOTTOM)
+                                    (IGEQ TOP Y2)))
+                      (T (AND (IGEQ Y2 BOTTOM)
+                              (IGEQ TOP Y1]
+                   (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)
+                       1))                                   (* ; 
+                                                           "line is completely visible, fast case.")
+              (.WHILE.TOP.DS. DS (\DRAWLINE1 X1 (SUB1 (\SFInvert BITMAP Y1))
+                                        DX DY DX DY (COND
+                                                       ((IGREATERP DX DY)
+                                                             (* ; "X is the fastest mover.")
+                                                        HALFDX)
+                                                       (T    (* ; "y is the fastest mover.")
+                                                          HALFDY))
+                                        (COND
+                                           (YMOVEUP          (* ; 
+                                  "y is moving in positive direction but bits are stored inversely")
+                                                  (IMINUS BMRASTERWIDTH))
+                                           (T BMRASTERWIDTH))
+                                        OPERATION
+                                        (fetch BITMAPBASE of BITMAP)
+                                        BMRASTERWIDTH)))
+             (T
+              (PROG ((CX1 X1)
+                     (CY1 Y1)
+                     (CX2 X2)
+                     (CY2 Y2)
+                     (CA1 (\CLIPCODE X1 Y1 LEFT RIGHT TOP BOTTOM))
+                     (CA2 (\CLIPCODE X2 Y2 LEFT RIGHT TOP BOTTOM)))
+                                                             (* ; 
+                                           "save the original points for the clipping computation.")
+                                                             (* ; 
+                                                  "determine the sectors in which the points fall.")
+                CLIPLP
+                    [COND
+                       ((NOT (EQ 0 (LOGAND CA1 CA2)))        (* ; 
+                                                          "line is entirely out of clipping region")
+                        (RETURN NIL))
+                       ((EQ 0 (IPLUS CA1 CA2))               (* ; "line is completely visible")
+
+                        (* ;; "\SFInvert has an off by one bug that everybody else in LLDISPLAY uses to save computation so SUB1 from what you would expect.")
+                                                             (* ; "reuse the variable CA1")
+                        (RETURN
+                         (.WHILE.TOP.DS.
+                          DS
+                          (SELECTQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)
+                              (1 (\DRAWLINE1 CX1 (SUB1 (\SFInvert BITMAP CY1))
+                                        (IDIFFERENCE CX2 CX1)
+                                        (COND
+                                           (YMOVEUP (IDIFFERENCE CY2 CY1))
+                                           (T (IDIFFERENCE CY1 CY2)))
+                                        DX DY (COND
+                                                 ((IGREATERP DX DY)
+                                                             (* ; "X is the fastest mover.")
+                                                  (IREMAINDER (IPLUS (ITIMES DY (IDIFFERENCE CX1 X1))
+                                                                     HALFDX)
+                                                         DX))
+                                                 (T          (* ; "y is the fastest mover.")
+                                                    (IREMAINDER (IPLUS [ITIMES DX
+                                                                              (COND
+                                                                                 (YMOVEUP
+                                                                                  (IDIFFERENCE CY1 Y1
+                                                                                         ))
+                                                                                 (T (IDIFFERENCE
+                                                                                     Y1 CY1]
+                                                                       HALFDY)
+                                                           DY)))
+                                        (COND
+                                           (YMOVEUP          (* ; 
+                                  "y is moving in positive direction but bits are stored inversely")
+                                                  (IMINUS BMRASTERWIDTH))
+                                           (T BMRASTERWIDTH))
+                                        OPERATION
+                                        (fetch BITMAPBASE of BITMAP)
+                                        BMRASTERWIDTH))
+                              ((4 8) 
+                                   (\DRAWCOLORLINE1
+                                    CX1
+                                    (SUB1 (\SFInvert BITMAP CY1))
+                                    (IDIFFERENCE CX2 CX1)
+                                    (COND
+                                       (YMOVEUP (IDIFFERENCE CY2 CY1))
+                                       (T (IDIFFERENCE CY1 CY2)))
+                                    DX DY (COND
+                                             ((IGREATERP DX DY)
+                                                             (* ; "X is the fastest mover.")
+                                              (IREMAINDER (IPLUS (ITIMES DY (IDIFFERENCE CX1 X1))
+                                                                 HALFDX)
+                                                     DX))
+                                             (T              (* ; "y is the fastest mover.")
+                                                (IREMAINDER (IPLUS [ITIMES DX
+                                                                          (COND
+                                                                             (YMOVEUP (IDIFFERENCE
+                                                                                       CY1 Y1))
+                                                                             (T (IDIFFERENCE Y1 CY1]
+                                                                   HALFDY)
+                                                       DY)))
+                                    (COND
+                                       (YMOVEUP              (* ; 
+                                  "y is moving in positive direction but bits are stored inversely")
+                                              (IMINUS BMRASTERWIDTH))
+                                       (T BMRASTERWIDTH))
+                                    OPERATION
+                                    (fetch BITMAPBASE of BITMAP)
+                                    BMRASTERWIDTH
+                                    (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)
+                                    COLOR))
+                              (SHOULDNT]
+                    [COND
+                       ((NEQ CA1 0)
+
+                        (* ;; "now move point CX1 CY1 so that one of the coordinates is on one of the boundaries.  Which boundary is done first was copied from BCPL.")
+
+                        (COND
+                           ((IGREATERP CA1 7)                (* ; "y1 less than bottom")
+                                                             (* ; 
+                                             "calculate the least X for which Y will be at bottom.")
+                            [SETQ CX1 (IPLUS X1 (\LEASTPTAT DX DY (IDIFFERENCE BOTTOM Y1]
+                            (SETQ CY1 BOTTOM))
+                           ((IGREATERP CA1 3)                (* ; "y1 is greater than top")
+                            [SETQ CX1 (IPLUS X1 (\LEASTPTAT DX DY (IDIFFERENCE Y1 TOP]
+                            (SETQ CY1 TOP))
+                           (T                                (* ; "x1 is less than left")
+                              [SETQ CY1 (COND
+                                           [YMOVEUP (IPLUS Y1 (\LEASTPTAT DY DX (IDIFFERENCE
+                                                                                     LEFT X1]
+                                           (T (IDIFFERENCE Y1 (\LEASTPTAT DY DX (IDIFFERENCE
+                                                                                     LEFT X1]
+                              (SETQ CX1 LEFT)))
+                        (SETQ CA1 (\CLIPCODE CX1 CY1 LEFT RIGHT TOP BOTTOM)))
+                       (T                                    (* ; 
+                "now move point CX2 CY2 so that one of the coordinates is on one of the boundaries")
+                          (COND
+                             ((IGREATERP CA2 7)              (* ; "y2 less than bottom")
+                              [SETQ CX2 (IPLUS X1 (\GREATESTPTAT DX DY (IDIFFERENCE Y1 BOTTOM]
+                              (SETQ CY2 BOTTOM))
+                             ((IGREATERP CA2 3)              (* ; "y2 is greater than top")
+                              [SETQ CX2 (IPLUS X1 (\GREATESTPTAT DX DY (IDIFFERENCE TOP Y1]
+                              (SETQ CY2 TOP))
+                             (T                              (* ; "x2 is greater than right")
+                                [SETQ CY2 (COND
+                                             [YMOVEUP (IPLUS Y1 (\GREATESTPTAT DY DX
+                                                                       (IDIFFERENCE RIGHT X1]
+                                             (T (IDIFFERENCE Y1 (\GREATESTPTAT DY DX
+                                                                       (IDIFFERENCE RIGHT X1]
+                                (SETQ CX2 RIGHT)))
+                          (SETQ CA2 (\CLIPCODE CX2 CY2 LEFT RIGHT TOP BOTTOM]
+                    (GO CLIPLP])
+
+(\CLIPCODE
+  [LAMBDA (X Y LEFT RIGHT TOP BOTTOM)                        (* rrb " 4-DEC-80 10:34")
+
+    (* ;; "determines the sector code for a point wrt a region.  Used to clip things quickly.")
+
+    (* ;; "RIGHT and TOP are one past the region.")
+
+    (COND
+       ((LESSP X LEFT)                                       (* ; "falls to left of region")
+        (COND
+           ((GREATERP Y TOP)                                 (* ; "left above")
+            5)
+           ((LESSP Y BOTTOM)                                 (* ; "left below")
+            9)
+           (T                                                (* ; "left inside")
+              1)))
+       ((GREATERP X RIGHT)                                   (* ; "right")
+        (COND
+           ((GREATERP Y TOP)                                 (* ; "right above")
+            6)
+           ((LESSP Y BOTTOM)                                 (* ; "right below")
+            10)
+           (T                                                (* ; "right inside")
+              2)))
+       ((GREATERP Y TOP)                                     (* ; "inside top")
+        4)
+       ((LESSP Y BOTTOM)                                     (* ; "inside below")
+        8)
+       (T                                                    (* ; "inside 0")
+          0])
+
+(\LEASTPTAT
+  [LAMBDA (DA DB THISB)                                      (* rrb " 7-JAN-82 11:56")
+
+    (* ;; "determines the smallest value in the dimension A that would give a B coordinate of THISB if a line were drawn from the point (0,0) with a slope of DA/DB.")
+
+    (COND
+       ((IGREATERP DA DB)
+        (ADD1 (IQUOTIENT (IPLUS (IDIFFERENCE (ITIMES THISB DA)
+                                       (HALF DA))
+                                -1)
+                     DB)))
+       (T (IQUOTIENT (IPLUS (ITIMES THISB DA)
+                            (HALF DB))
+                 DB])
+
+(\GREATESTPTAT
+  [LAMBDA (DA DB THISB)                                      (* rrb " 7-JAN-82 14:24")
+
+    (* ;; "determines the largest value in the dimension A that would give a B coordinate of THISB if a line were drawn from the point (0,0) with a slope of DA/DB.")
+
+    (COND
+       ((IGREATERP DA DB)
+        (IQUOTIENT (IPLUS (IDIFFERENCE (ITIMES (ADD1 THISB)
+                                              DA)
+                                 (HALF DA))
+                          -1)
+               DB))
+       (T (IQUOTIENT (IPLUS (ITIMES THISB DA)
+                            (HALF DB))
+                 DB])
+
+(\DRAWLINE1
+  [LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH)
+                                                             (* mpl " 2-Jan-84 18:00")
+
+    (* ;; "this was changed to interface with the opcode for line drawing.  It probably be incorporated into the places it is called.")
+
+    (* ;; "draws a line starting at X0,Y0 at a slope of DX/DY until reaching either XLIMIT or YLIMIT with an initial overflow bucket size of CDL in MODE.  Arranged so that the clipping routines can determine what the exact location of the end point of the clipped line is wrt line drawing coordinates eg.  amount in overflow bucket.  XLIMIT and YLIMIT are the number of points to be moved in that direction.")
+
+    (\DRAWLINE.UFN (\ADDBASE BITMAPBASE (IPLUS (ITIMES Y0 RASTERWIDTH)
+                                                   (FOLDLO X0 BITSPERWORD)))
+           (LOGAND X0 15)
+           DX YINC DY (SELECTQ MODE
+                          (INVERT 2)
+                          (ERASE 1)
+                          0)
+           CDL
+           (ADD1 XLIMIT)
+           (ADD1 YLIMIT])
+
+(\DRAWLINE.UFN
+  [LAMBDA (FIRSTADDR FIRSTBIT XDELTA YINCR YDELTA OPERATIONCODE INITIALBUCKET PIXELSINX PIXELSINY)
+                                                             (* jds " 6-Jan-86 11:27")
+
+    (* ;; "FIRSTADDR is the address of the word which contains the first point.  FIRSTBIT is the address of the first bit in FIRSTADDR.  XDELTA and YDELTA are how far the complete line has to move in X and Y respectively;  both are positive quantities.  YINCR is the amount the address should be incremented if the Y coordinate changes and can be either positive or negative.  OPERATIONCODE is 0 for REPLACE, 1 for ERASE and 2 for INVERT.  INITIALBUCKET is between 0 and the maximum of DX and DY and gives the starting amount of the bucket used to determine when to increment in the slower moving direction.  PIXELSINX and PIXELSINY indicates how many pixels should be drawn in the X and Y direction.")
+
+    (DECLARE (LOCALVARS . T))
+    (PROG ((MASK (\BITMASK FIRSTBIT)))
+          (COND
+             [(IGEQ XDELTA YDELTA)                           (* ; "X is the fastest mover.")
+              (SELECTQ OPERATIONCODE
+                  (0 (.DRAWLINEX. 'REPLACE/PAINT))
+                  (1 (.DRAWLINEX. 'ERASE))
+                  (.DRAWLINEX. 'INVERT]
+             (T                                              (* ; "Y is the fastest mover.")
+                (SELECTQ OPERATIONCODE
+                    (0 (.DRAWLINEY. 'REPLACE/PAINT))
+                    (1 (.DRAWLINEY. 'ERASE))
+                    (.DRAWLINEY. 'INVERT])
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS .DRAWLINEX. MACRO [(MODE)
+                                     (bind (NY _ 0) for PT from 1 to PIXELSINX
+                                        do               (* ; "main loop")
+                                              [replace (BITMAPWORD BITS) of FIRSTADDR
+                                                 with (SELECTQ MODE
+                                                              (INVERT (LOGXOR MASK
+                                                                             (fetch (BITMAPWORD
+                                                                                         BITS)
+                                                                                of FIRSTADDR)))
+                                                              (ERASE (LOGAND (LOGXOR MASK WORDMASK)
+                                                                            (fetch (BITMAPWORD
+                                                                                        BITS)
+                                                                               of FIRSTADDR)))
+                                                              (PROGN 
+                                                             (* ; 
+           "case is PAINT or REPLACE.  Legality of OPERATION has been checked by \CLIPANDDRAWLINE1")
+                                                                     (LOGOR MASK (fetch
+                                                                                  (BITMAPWORD BITS)
+                                                                                    of FIRSTADDR]
+                                              [COND
+                                                 ([NOT (IGREATERP XDELTA (SETQ INITIALBUCKET
+                                                                          (IPLUS INITIALBUCKET YDELTA
+                                                                                 ]
+                                                             (* ; "increment in the Y direction")
+                                                  (COND
+                                                     ((EQ (SETQ NY (ADD1 NY))
+                                                          PIXELSINY)
+                                                      (RETURN)))
+                                                  (SETQ INITIALBUCKET (IDIFFERENCE INITIALBUCKET 
+                                                                             XDELTA))
+                                                  (SETQ FIRSTADDR (\ADDBASE FIRSTADDR YINCR]
+                                              (SETQ MASK (LRSH MASK 1))
+                                              (COND
+                                                 ((EQ 0 MASK)(* ; "crossed word boundary")
+                                                  (SETQ FIRSTADDR (\ADDBASE FIRSTADDR 1))
+                                                  (SETQ MASK 32768])
+
+(PUTPROPS .DRAWLINEY. MACRO [(MODE)
+                                     (bind (NX _ 0) for PT from 1 to PIXELSINY
+                                        do               (* ; "main loop")
+                                              [replace (BITMAPWORD BITS) of FIRSTADDR
+                                                 with (SELECTQ MODE
+                                                              (INVERT (LOGXOR MASK
+                                                                             (fetch (BITMAPWORD
+                                                                                         BITS)
+                                                                                of FIRSTADDR)))
+                                                              (ERASE (LOGAND (LOGXOR MASK WORDMASK)
+                                                                            (fetch (BITMAPWORD
+                                                                                        BITS)
+                                                                               of FIRSTADDR)))
+                                                              (PROGN 
+                                                             (* ; 
+           "case is PAINT or REPLACE.  Legality of OPERATION has been checked by \CLIPANDDRAWLINE1")
+                                                                     (LOGOR MASK (fetch
+                                                                                  (BITMAPWORD BITS)
+                                                                                    of FIRSTADDR]
+                                              [COND
+                                                 ([NOT (IGREATERP YDELTA (SETQ INITIALBUCKET
+                                                                          (IPLUS INITIALBUCKET XDELTA
+                                                                                 ]
+                                                  (COND
+                                                     ((EQ (SETQ NX (ADD1 NX))
+                                                          PIXELSINX)
+                                                      (RETURN)))
+                                                  (SETQ INITIALBUCKET (IDIFFERENCE INITIALBUCKET 
+                                                                             YDELTA))
+                                                  (SETQ MASK (LRSH MASK 1))
+                                                  (COND
+                                                     ((EQ 0 MASK)
+                                                             (* ; "crossed word boundary")
+                                                      (SETQ FIRSTADDR (\ADDBASE FIRSTADDR 1))
+                                                      (SETQ MASK 32768]
+                                              (SETQ FIRSTADDR (\ADDBASE FIRSTADDR YINCR])
+)
+)
+
+
+
+(* ; "Curves")
+
+(DEFINEQ
+
+(\DRAWCIRCLE.DISPLAY
+  [LAMBDA (DISPLAYSTREAM CENTERX CENTERY RADIUS BRUSH DASHING)
+                                                             (* kbr%: "15-Feb-86 22:24")
+
+    (* ;; 
+"\DRAWCIRCLE.DISPLAY extended for color.  Color is specified by either BRUSH or the DSPCOLOR of DS.")
+
+    (DECLARE (LOCALVARS . T))
+    (COND
+       ((OR (NOT (NUMBERP RADIUS))
+            (ILESSP (SETQ RADIUS (FIXR RADIUS))
+                   0))
+        (\ILLEGAL.ARG RADIUS))
+       ((EQ RADIUS 0)                                        (* ; "don't draw anything.")
+        NIL)
+       (DASHING                                              (* ; 
+                       "draw it with the arc drawing code which does dashing.  Slow but effective.")
+
+              (* ;; "the CDR removes the first point to work around a bug in curve drawing when closed and first and last points the same.  AR 4623.0")
+
+              (DRAWCURVE (CDR (\COMPUTE.ARC.POINTS CENTERX CENTERY RADIUS 0 360))
+                     T BRUSH DASHING DISPLAYSTREAM))
+       (T (GLOBALRESOURCE \BRUSHBBT
+                 (PROG (X Y D DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT 
+                          LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE 
+                          BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH NBITSRIGHTPLUS1 OPERATION 
+                          HEIGHTMINUS1 CX CY BBT COLOR COLORBRUSHBASE NBITS DISPLAYDATA USERFN)
+                       (SETQ X 0)
+                       (SETQ Y RADIUS)
+                       (SETQ D (ITIMES 2 (IDIFFERENCE 1 RADIUS)))
+                       (SETQ BBT \BRUSHBBT)
+                       (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DISPLAYSTREAM))
+                       (SETQ USERFN (AND (LITATOM BRUSH)
+                                         BRUSH))
+
+                  (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT.  sets them up.")
+
+                       (COND
+                          (USERFN                            (* ; 
+             "if calling user fn, don't bother with set up and leave points in stream coordinates.")
+                                 (SETQ CX CENTERX)
+                                 (SETQ CY CENTERY))
+                          (T (.SETUP.FOR.\BBTCURVEPT.)
+                             (SELECTQ NBITS
+                                 (1 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX (FOLDLO BRUSHWIDTH
+                                                                                         2))
+                                                    DISPLAYDATA)))
+                                 (4 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX
+                                                                    (FOLDLO (LRSH BRUSHWIDTH 2)
+                                                                           2))
+                                                    DISPLAYDATA)))
+                                 (8 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX
+                                                                    (FOLDLO (LRSH BRUSHWIDTH 3)
+                                                                           2))
+                                                    DISPLAYDATA)))
+                                 (24                         (* ; 
+                                                           "I doubt that this will be right.")
+                                     (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX
+                                                                     (FOLDLO (IQUOTIENT BRUSHWIDTH 24
+                                                                                    )
+                                                                            2))
+                                                     DISPLAYDATA)))
+                                 (SHOULDNT))                 (* ; 
+                                                           "take into account the brush thickness.")
+                             (SETQ CY (\DSPTRANSFORMY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT 2))
+                                             DISPLAYDATA))
+
+                             (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points")
+
+                             (\INSURETOPWDS DISPLAYSTREAM)))
+                       [COND
+                          ((EQ RADIUS 1)                     (* ; "put a single brush down.")
+                                                             (* ; 
+                                                           "draw the top and bottom most points.")
+                           [COND
+                              (USERFN (APPLY* USERFN CX CY DISPLAYSTREAM))
+                              (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT CX CY]
+                           (RETURN))
+                          (T                                 (* ; 
+                                                           "draw the top and bottom most points.")
+                             (COND
+                                (USERFN (APPLY* USERFN CX (IPLUS CY RADIUS)
+                                               DISPLAYSTREAM)
+                                       (APPLY* USERFN CX (IDIFFERENCE CY RADIUS)
+                                              DISPLAYSTREAM))
+                                (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT CX (IPLUS CY RADIUS))
+                                          (\CURVEPT CX (IDIFFERENCE CY RADIUS]
+                   LP                                        (* ; 
+                                                     "(UNFOLD x 2) is used instead of (ITIMES x 2)")
+                       [COND
+                          [(IGREATERP 0 D)
+                           (SETQ X (ADD1 X))
+                           (COND
+                              ((IGREATERP (UNFOLD (IPLUS D Y)
+                                                 2)
+                                      1)
+                               (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
+                                                       2)
+                                              4))
+                               (SETQ Y (SUB1 Y)))
+                              (T (SETQ D (IPLUS D (UNFOLD X 2)
+                                                1]
+                          ((OR (EQ 0 D)
+                               (IGREATERP X D))
+                           (SETQ X (ADD1 X))
+                           (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
+                                                   2)
+                                          4))
+                           (SETQ Y (SUB1 Y)))
+                          (T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2))
+                                            3))
+                             (SETQ Y (SUB1 Y]
+                       (COND
+                          [(EQ Y 0)
+
+                           (* ;; "left most and right most points are drawn specially so that they are not duplicated which leaves a hole in XOR mode.")
+
+                           (COND
+                              (USERFN (APPLY* USERFN (IPLUS CX X)
+                                             CY DISPLAYSTREAM)
+                                     (APPLY* USERFN (IDIFFERENCE CX X)
+                                            CY DISPLAYSTREAM))
+                              (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT (IPLUS CX X)
+                                                                      CY)
+                                        (\CURVEPT (IDIFFERENCE CX X)
+                                               CY]
+                          (T [COND
+                                (USERFN (APPLY* USERFN (IPLUS CX X)
+                                               (IPLUS CY Y)
+                                               DISPLAYSTREAM)
+                                       (APPLY* USERFN (IDIFFERENCE CX X)
+                                              (IPLUS CY Y)
+                                              DISPLAYSTREAM)
+                                       (APPLY* USERFN (IPLUS CX X)
+                                              (IDIFFERENCE CY Y)
+                                              DISPLAYSTREAM)
+                                       (APPLY* USERFN (IDIFFERENCE CX X)
+                                              (IDIFFERENCE CY Y)
+                                              DISPLAYSTREAM))
+                                (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CIRCLEPTS CX CY X Y]
+                             (GO LP)))
+                       (MOVETO CENTERX CENTERY DISPLAYSTREAM)
+                       (RETURN NIL])
+
+(\DRAWARC.DISPLAY
+  [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING)
+                                                             (* ; "draws an arc on the display")
+    (\DRAWARC.GENERIC STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING])
+
+(\DRAWARC.GENERIC
+  [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING)
+                                                             (* rrb " 4-Oct-85 18:23")
+                                                             (* ; 
+                                                           "draws an arc by drawing a curve.")
+    (COND
+       ((AND (GREATERP 360 NDEGREES)
+             (LESSP -360 NDEGREES))
+        (DRAWCURVE (\COMPUTE.ARC.POINTS CENTERX CENTERY RADIUS STARTANGLE NDEGREES)
+               NIL BRUSH DASHING STREAM))
+       (T                                                    (* ; 
+                                                         "use circle drawing which could be faster")
+          (DRAWCIRCLE CENTERX CENTERY RADIUS BRUSH DASHING STREAM])
+
+(\COMPUTE.ARC.POINTS
+  [LAMBDA (CENTERX CENTERY RADIUS STARTANGLE NDEGREES)       (* DECLARATIONS%: FLOATING)
+                                                             (* rrb "30-Oct-85 11:48")
+
+    (* ;; "computes a list of knots that a spline goes through to make an arc")
+
+    (PROG ((ANGLESIZE (COND
+                         ((OR (GREATERP NDEGREES 360.0)
+                              (GREATERP -360.0 NDEGREES))
+                          360.0)
+                         (T NDEGREES)))
+           ANGLEINCR)
+
+     (* ;; "calculate an increment close to 10.0 that is exact but always have at least 5 knots and don't have more than a knot every 5 pts")
+
+          [SETQ ANGLEINCR (FQUOTIENT ANGLESIZE
+                                 (IMIN (IMAX (ABS (FIX (FQUOTIENT ANGLESIZE 10.0)))
+                                             5)
+                                       (PROGN                (* ; 
+                                                          "don't have more than a knot every 5 pts")
+                                              (IMAX (ABS (FIX (QUOTIENT (TIMES RADIUS 6.3
+                                                                               (QUOTIENT ANGLESIZE 
+                                                                                      360.0))
+                                                                     4)))
+                                                    3]
+
+     (* ;; "go from initial point to just past the last point.  The just past (PLUS BETA (QUOTIENT ANGLEINCR 5.0)) picks up the case where the floating pt rounding error accumulates to be greater than the last point when it is very close to it.")
+
+          (RETURN (for ANGLE from STARTANGLE to (PLUS STARTANGLE ANGLESIZE
+                                                                  (QUOTIENT ANGLEINCR 5.0))
+                     by ANGLEINCR collect (create POSITION
+                                                         XCOORD _ [FIXR (PLUS CENTERX
+                                                                              (TIMES RADIUS
+                                                                                     (COS ANGLE]
+                                                         YCOORD _ (FIXR (PLUS CENTERY
+                                                                              (TIMES RADIUS
+                                                                                     (SIN ANGLE])
+
+(\DRAWELLIPSE.DISPLAY
+  [LAMBDA (DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING)
+                                                             (* ; "Edited 12-Apr-88 23:58 by FS")
+    (DECLARE (LOCALVARS . T))
+
+    (* ;; "Draws an ellipse.  At ORIENTATION 0, the semimajor axis is horizontal, the semiminor axis vertical.  Orientation is positive in the counterclockwise direction.  The current location in the stream is left at the center of the ellipse.")
+
+    (PROG ((CENTERX (FIXR CENTERX))
+           (CENTERY (FIXR CENTERY))
+           (SEMIMINORRADIUS (FIXR SEMIMINORRADIUS))
+           (SEMIMAJORRADIUS (FIXR SEMIMAJORRADIUS)))
+          (COND
+             ((OR (EQ 0 SEMIMINORRADIUS)
+                  (EQ 0 SEMIMAJORRADIUS))
+              (MOVETO CENTERX CENTERY DISPLAYSTREAM)
+              (RETURN)))
+          (COND
+             ((ILESSP SEMIMINORRADIUS 1)
+              (\ILLEGAL.ARG SEMIMINORRADIUS))
+             ((ILESSP SEMIMAJORRADIUS 1)
+              (\ILLEGAL.ARG SEMIMAJORRADIUS))
+             ((OR (NULL ORIENTATION)
+                  (EQ SEMIMINORRADIUS SEMIMAJORRADIUS))
+              (SETQ ORIENTATION 0))
+             ((NULL (NUMBERP ORIENTATION))
+              (\ILLEGAL.ARG ORIENTATION)))
+
+     (* ;; "If dashing, draw it with the curve drawing code which can do dashing")
+
+          (COND
+             (DASHING (\DRAWELLIPSE.GENERIC DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS 
+                             SEMIMAJORRADIUS ORIENTATION BRUSH DASHING)
+                    (RETURN)))
+
+     (* ;; "If degenerate ellipse, attempt circumvention of Pitteway breakdown by trying spline code instead, which appears more numerically stable (see AR6502)")
+
+          (COND
+             ((< 40 (/ SEMIMAJORRADIUS SEMIMINORRADIUS))
+              (\DRAWELLIPSE.GENERIC DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS 
+                     ORIENTATION BRUSH DASHING)
+              (RETURN)))
+
+(* ;;; "This function is the implementation of the algorithm given in 'Algorithm for drawing ellipses or hyperbolae with a digital plotter' by Pitteway appearing in Computer Journal 10: (3) Nov 1967.0 The input parameters are used to determine the ellipse equation (1/8) Ayy+ (1/8) Bxx+ (1/4) Gxy+ (1/4) Ux+ (1/4) Vy= (1/4) K which specifies a translated version of the desired ellipse.  This ellipse passes through the mesh point (0,0), the initial point of the algorithm.  The power of 2 factors reflect an implementation convenience.")
+
+          (GLOBALRESOURCE \BRUSHBBT
+                 (PROG (DestinationBitMap LEFT RIGHTPLUS1 BOTTOM TOP BOTTOMMINUSBRUSH TOPMINUSBRUSH 
+                              LEFTMINUSBRUSH DESTINATIONBASE BRUSHBASE BRUSHHEIGHT BRUSHWIDTH 
+                              RASTERWIDTH BRUSHRASTERWIDTH BRUSHBM OPERATION HEIGHTMINUS1
+                              (BBT \BRUSHBBT)
+                              (cosOrientation (COS ORIENTATION))
+                              (sinOrientation (SIN ORIENTATION))
+                              (SEMIMINORRADIUSSQUARED (ITIMES SEMIMINORRADIUS SEMIMINORRADIUS))
+                              (SEMIMAJORRADIUSSQUARED (ITIMES SEMIMAJORRADIUS SEMIMAJORRADIUS))
+                              (x 0)
+                              (y 0)
+                              (x2 1)
+                              x1 y1 y2 k1 k2 k3 a b d w A B G U V K CX CY yOffset CYPlusOffset 
+                              CYMinusOffset NBITSRIGHTPLUS1 COLORBRUSHBASE COLOR NBITS
+                              (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM))
+                              (USERFN (AND (LITATOM BRUSH)
+                                           BRUSH)))
+
+                  (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT.  sets them up.")
+
+                       (COND
+                          (USERFN                            (* ; 
+             "if calling user fn, don't bother with set up and leave points in window coordinates.")
+                                 (SETQ CX CENTERX)
+                                 (SETQ CY CENTERY))
+                          (T (.SETUP.FOR.\BBTCURVEPT.)       (* ; 
+                                                           "take into account the brush thickness.")
+                             (SELECTQ NBITS
+                                 (1 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX (FOLDLO BRUSHWIDTH
+                                                                                         2))
+                                                    DISPLAYDATA)))
+                                 (4 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX
+                                                                    (FOLDLO (LRSH BRUSHWIDTH 2)
+                                                                           2))
+                                                    DISPLAYDATA)))
+                                 (8 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX
+                                                                    (FOLDLO (LRSH BRUSHWIDTH 3)
+                                                                           2))
+                                                    DISPLAYDATA)))
+                                 (SHOULDNT))
+                             (SETQ CY (\DSPTRANSFORMY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT 2))
+                                             DISPLAYDATA))
+
+                             (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points")
+
+                             (\INSURETOPWDS DISPLAYSTREAM)))
+                       (SETQ A (FPLUS (FTIMES SEMIMAJORRADIUSSQUARED cosOrientation cosOrientation)
+                                      (FTIMES SEMIMINORRADIUSSQUARED sinOrientation sinOrientation)))
+                       (SETQ B (LSH (FIXR (FPLUS (FTIMES SEMIMINORRADIUSSQUARED cosOrientation 
+                                                        cosOrientation)
+                                                 (FTIMES SEMIMAJORRADIUSSQUARED sinOrientation 
+                                                        sinOrientation)))
+                                    3))
+                       (SETQ G (FTIMES cosOrientation sinOrientation (LSH (IDIFFERENCE 
+                                                                               SEMIMINORRADIUSSQUARED
+                                                                                 
+                                                                               SEMIMAJORRADIUSSQUARED
+                                                                                 )
+                                                                          1)))
+                       [SETQ yOffset (FIXR (FQUOTIENT (ITIMES SEMIMINORRADIUS SEMIMAJORRADIUS)
+                                                  (SQRT A]
+                       (SETQ CYPlusOffset (IPLUS CY yOffset))
+                       (SETQ CYMinusOffset (IDIFFERENCE CY yOffset))
+                       (SETQ U (LSH (FIXR (FTIMES A (LSH yOffset 1)))
+                                    2))
+                       (SETQ V (LSH (FIXR (FTIMES G yOffset))
+                                    2))
+                       (SETQ K (LSH [FIXR (FDIFFERENCE (ITIMES SEMIMINORRADIUSSQUARED 
+                                                              SEMIMAJORRADIUSSQUARED)
+                                                 (FTIMES A (ITIMES yOffset yOffset]
+                                    2))
+                       (SETQ A (LSH (FIXR A)
+                                    3))
+                       (SETQ G (LSH (FIXR G)
+                                    2))
+
+                  (* ;; "The algorithm is incremental and iterates through the octants of a cartesian plane.  The octants are labeled from 1 through 8 beginning above the positive X axis and proceeding counterclockwise.  Decisions in making the incremental steps are determined according to the error term d which is updated according to the curvature terms a and b.  k1, k2, and k3 are used to correct the error and curvature terms at octant boundaries.  The initial values of these terms depends on the octant in which drawing begins.  The initial move steps (x1,y1) and (x2,y2) also depend on the starting octant.")
+
+                       [COND
+                          [(ILESSP (ABS U)
+                                  (ABS V))
+                           (SETQ x1 0)
+                           (COND
+                              [(MINUSP V)                    (* ; "start in octant 2")
+                               (SETQ y1 1)
+                               (SETQ y2 1)
+                               (SETQ k1 (IMINUS A))
+                               (SETQ k2 (IDIFFERENCE k1 G))
+                               (SETQ k3 (IDIFFERENCE k2 (IPLUS B G)))
+                               (SETQ b (IPLUS U (RSH (IPLUS A G)
+                                                     1)))
+                               (SETQ a (IMINUS (IPLUS b V)))
+                               (SETQ d (IPLUS b (RSH B 3)
+                                              (RSH V 1)
+                                              (IMINUS K]
+                              (T                             (* ; "start in octant 7")
+                                 (SETQ y1 -1)
+                                 (SETQ y2 -1)
+                                 (SETQ k1 A)
+                                 (SETQ k2 (IDIFFERENCE k1 G))
+                                 (SETQ k3 (IPLUS k2 B (IMINUS G)))
+                                 (SETQ b (IPLUS U (RSH (IDIFFERENCE G A)
+                                                       1)))
+                                 (SETQ a (IDIFFERENCE V b))
+                                 (SETQ d (IPLUS b K (IMINUS (IPLUS (RSH V 1)
+                                                                   (RSH B 3]
+                          (T (SETQ x1 1)
+                             (SETQ y1 0)
+                             (COND
+                                [(MINUSP V)                  (* ; "start in octant 1")
+                                 (SETQ y2 1)
+                                 (SETQ k1 B)
+                                 (SETQ k2 (IPLUS k1 G))
+                                 (SETQ k3 (IPLUS k2 A G))
+                                 [SETQ b (IMINUS (IPLUS V (RSH (IPLUS B G)
+                                                               1]
+                                 (SETQ a (IDIFFERENCE U b))
+                                 (SETQ d (IPLUS b K (IMINUS (IPLUS (RSH A 3)
+                                                                   (RSH U 1]
+                                (T                           (* ; "start in octant 8")
+                                   (SETQ y2 -1)
+                                   (SETQ k1 (IMINUS B))
+                                   (SETQ k2 (IPLUS k1 G))
+                                   (SETQ k3 (IPLUS k2 G (IMINUS A)))
+                                   (SETQ b (IPLUS V (RSH (IDIFFERENCE B G)
+                                                         1)))
+                                   (SETQ a (IDIFFERENCE U b))
+                                   (SETQ d (IPLUS b (RSH A 3)
+                                                  (IMINUS (IPLUS K (RSH U 1]
+
+                  (* ;; "The ellipse equation describes an ellipse of the desired size and ORIENTATION centered at (0,0) and then dropped yOffset mesh points so that it will pass through (0,0).  Thus, the intended starting point is (CX, CY+yOffset) where (CX, CY) is the center of the desired ellipse.  Drawing is accomplished with point relative steps.  In each octant, the error term d is used to choose between move 1 (an axis move) and move 2 (a diagonal move).")
+
+                   MOVE
+                       [COND
+                          ((MINUSP d)                        (* ; "move 1")
+                           (SETQ x (IPLUS x x1))
+                           (SETQ y (IPLUS y y1))
+                           (SETQ b (IDIFFERENCE b k1))
+                           (SETQ a (IPLUS a k2))
+                           (SETQ d (IPLUS b d)))
+                          (T                                 (* ; "move 2")
+                             (SETQ x (IPLUS x x2))
+                             (SETQ y (IPLUS y y2))
+                             (SETQ b (IDIFFERENCE b k2))
+                             (SETQ a (IPLUS a k3))
+                             (SETQ d (IDIFFERENCE d a]
+                       (COND
+                          ((MINUSP x)
+                           (MOVETO CENTERX CENTERY DISPLAYSTREAM)
+                           (RETURN NIL)))
+                       [COND
+                          (USERFN (APPLY* USERFN (IPLUS CX x)
+                                         (IPLUS CYPlusOffset y)
+                                         DISPLAYSTREAM)
+                                 (APPLY* USERFN (IDIFFERENCE CX x)
+                                        (IDIFFERENCE CYMinusOffset y)
+                                        DISPLAYSTREAM))
+                          (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT (IPLUS CX x)
+                                                                  (IPLUS CYPlusOffset y))
+                                    (\CURVEPT (IDIFFERENCE CX x)
+                                           (IDIFFERENCE CYMinusOffset y]
+                       (AND (MINUSP b)
+                            (GO SQUARE))
+                   DIAGONAL
+                       (OR (MINUSP a)
+                           (GO MOVE))                        (* ; "diagonal octant change")
+                       (SETQ x1 (IDIFFERENCE x2 x1))
+                       (SETQ y1 (IDIFFERENCE y2 y1))
+                       (SETQ w (IDIFFERENCE (LSH k2 1)
+                                      k3))
+                       (SETQ k1 (IDIFFERENCE w k1))
+                       (SETQ k2 (IDIFFERENCE k2 k3))
+                       (SETQ k3 (IMINUS k3))
+                       [SETQ b (IPLUS b a (IMINUS (RSH (ADD1 k2)
+                                                       1]
+                       [SETQ d (IPLUS b (RSH (IPLUS k3 4)
+                                             3)
+                                      (IMINUS d)
+                                      (IMINUS (RSH (ADD1 a)
+                                                   1]
+                       (SETQ a (IDIFFERENCE (RSH (ADD1 w)
+                                                 1)
+                                      a))
+                       (OR (MINUSP b)
+                           (GO MOVE))
+                   SQUARE
+                                                             (* ; "square octant change")
+                       [COND
+                          ((EQ 0 x1)
+                           (SETQ x2 (IMINUS x2)))
+                          (T (SETQ y2 (IMINUS y2]
+                       (SETQ w (IDIFFERENCE k2 k1))
+                       (SETQ k1 (IMINUS k1))
+                       (SETQ k2 (IPLUS w k1))
+                       (SETQ k3 (IDIFFERENCE (LSH w 2)
+                                       k3))
+                       (SETQ b (IDIFFERENCE (IMINUS b)
+                                      w))
+                       (SETQ d (IDIFFERENCE (IDIFFERENCE b a)
+                                      d))
+                       (SETQ a (IDIFFERENCE (IDIFFERENCE a w)
+                                      (LSH b 1)))
+                       (GO DIAGONAL])
+
+(\DRAWCURVE.DISPLAY
+  [LAMBDA (DISPLAYSTREAM KNOTS CLOSED BRUSH DASHING)         (* ; "Edited  9-Jan-87 16:49 by rrb")
+
+    (* ;; "draws a spline curve with a given brush.")
+
+    (GLOBALRESOURCE \BRUSHBBT (PROG ((BBT \BRUSHBBT)
+                                     (DASHLST (\GOOD.DASHLST DASHING BRUSH)))
+                                    (SELECTQ (LENGTH KNOTS)
+                                        (0                   (* ; 
+                                                       "No knots => empty curve rather than error?")
+                                           NIL)
+                                        (1                   (* ; 
+                                                           "only one knot, put down a brush shape")
+                                           (OR (type? POSITION (CAR KNOTS))
+                                               (ERROR "bad knot" (CAR KNOTS)))
+                                           (\DRAWPOINT.DISPLAY DISPLAYSTREAM (fetch XCOORD
+                                                                                    of
+                                                                                    (CAR KNOTS))
+                                                  (fetch YCOORD of (CAR KNOTS))
+                                                  BRUSH))
+                                        (2 (OR (type? POSITION (CAR KNOTS))
+                                               (ERROR "bad knot" (CAR KNOTS)))
+                                           (OR (type? POSITION (CADR KNOTS))
+                                               (ERROR "bad knot" (CADR KNOTS)))
+                                           (\LINEWITHBRUSH (fetch XCOORD of (CAR KNOTS))
+                                                  (fetch YCOORD of (CAR KNOTS))
+                                                  (fetch XCOORD of (CADR KNOTS))
+                                                  (fetch YCOORD of (CADR KNOTS))
+                                                  BRUSH DASHLST DISPLAYSTREAM BBT))
+                                        (\CURVE2 (PARAMETRICSPLINE KNOTS CLOSED)
+                                               BRUSH DASHLST BBT DISPLAYSTREAM))
+                                    (RETURN DISPLAYSTREAM])
+
+(\DRAWPOINT.DISPLAY
+  [LAMBDA (DISPLAYSTREAM X Y BRUSH OPERATION)                (* rrb "17-Sep-86 17:51")
+
+    (* ;; "draws a brush point at position X Y")
+
+    (* ;; "this is used in 4, 8, and 24 bit per pixel bitmaps as well.  For these, it may be should call BITMAPWIDTH instead of fetching.")
+
+    (PROG ((BRUSHBM (\GETBRUSH BRUSH)))                  (* ; 
+                                       "SUB1 is to put extra bit of even brush on the top or left.")
+          (RETURN (BITBLT BRUSHBM 0 0 DISPLAYSTREAM [IDIFFERENCE X (HALF (SUB1 (fetch
+                                                                                (BITMAP BITMAPWIDTH)
+                                                                                  of BRUSHBM]
+                         [IDIFFERENCE Y (HALF (SUB1 (fetch (BITMAP BITMAPHEIGHT) of BRUSHBM]
+                         NIL NIL NIL (SELECTQ (OR OPERATION (DSPOPERATION NIL DISPLAYSTREAM))
+                                         (REPLACE 'PAINT)
+                                         OPERATION])
+
+(\DRAWPOLYGON.DISPLAY
+  [LAMBDA (STREAM POINTS CLOSED BRUSH DASHING)               (* ; "Edited 13-Apr-88 14:14 by FS")
+
+    (* ;; "Somewhat less generic version of drawpolygon that calls \drawline.display.  Brush must be a brush (guaranteed in DRAWPOLYGON) other users must also ensure.")
+
+    (* ;; "This is different than drawline.generic, because drawline.display will use width argument instead of bltting brushes around.  That way you can get shades, dspoperation, eventually.")
+
+    (PROG [COLOR (PTBRUSH (COND
+                             ((EQ (fetch (BRUSH BRUSHSHAPE) of BRUSH)
+                                  'ROUND)
+                              BRUSH)
+                             (T (create BRUSH using BRUSH BRUSHSHAPE _ 'ROUND]
+          (SETQ COLOR (fetch (BRUSH BRUSHCOLOR) of PTBRUSH))
+          (for PTAIL on POINTS while (CDR PTAIL) do (\DRAWLINE.DISPLAY
+                                                                     STREAM
+                                                                     (fetch (POSITION XCOORD)
+                                                                        of (CAR PTAIL))
+                                                                     (ffetch (POSITION YCOORD)
+                                                                        of (CAR PTAIL))
+                                                                     (fetch (POSITION XCOORD)
+                                                                        of (CADR PTAIL))
+                                                                     (ffetch (POSITION YCOORD)
+                                                                        of (CADR PTAIL))
+                                                                     (fetch (BRUSH BRUSHSIZE)
+                                                                        of BRUSH)
+                                                                     NIL COLOR DASHING) 
+                                                             (* ; 
+    "put a brush between lines so it looks better.  It's not mitered this way but better than not.")
+                                                                   (\DRAWPOINT.DISPLAY
+                                                                    STREAM
+                                                                    (fetch (POSITION XCOORD)
+                                                                       of (CADR POINTS))
+                                                                    (fetch (POSITION YCOORD)
+                                                                       of (CADR POINTS))
+                                                                    PTBRUSH
+                                                                    'NIL)
+             finally (COND
+                            ((AND CLOSED (CDDR POINTS))      (* ; "draw the closing line.")
+                             (\DRAWLINE.DISPLAY STREAM (fetch (POSITION XCOORD)
+                                                              of (CAR PTAIL))
+                                    (ffetch (POSITION YCOORD) of (CAR PTAIL))
+                                    (fetch (POSITION XCOORD) of (CAR POINTS))
+                                    (ffetch (POSITION YCOORD) of (CAR POINTS))
+                                    (fetch (BRUSH BRUSHSIZE) of BRUSH)
+                                    NIL COLOR DASHING)))
+                   (OR (NULL (CDR POINTS))
+                       (\DRAWPOINT.DISPLAY STREAM (fetch (POSITION XCOORD)
+                                                         of (CAR POINTS))
+                              (fetch (POSITION YCOORD) of (CAR POINTS))
+                              PTBRUSH NIL])
+
+(\LINEWITHBRUSH
+  [LAMBDA (X1 Y1 X2 Y2 BRUSH DASHLST DISPLAYSTREAM BBT OPERATION)
+                                                             (* ; "Edited 29-Oct-87 17:40 by scp")
+
+    (* ;; "draws a line with a brush on a guaranteed display-stream DISPLAYSTREAM")
+
+    (DECLARE (LOCALVARS . T))
+    (PROG (DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT LEFTMINUSBRUSH 
+                 BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE RASTERWIDTH 
+                 BRUSHRASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 COLOR COLORBRUSHBASE NBITS 
+                 HALFBRUSHWIDTH HALFBRUSHHEIGHT DX DY YINC CDL (DASHON T)
+                 (DASHTAIL DASHLST)
+                 (DASHCNT (CAR DASHLST))
+                 (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM))
+                 (USERFN (AND (LITATOM BRUSH)
+                              BRUSH))
+                 (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)))
+
+     (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT.  sets them up.")
+                                                             (* ; 
+                           "move the display stream position before the coordinates are clobbered.")
+          (COND
+             ((NOT USERFN)
+              (.SETUP.FOR.\BBTCURVEPT.)
+              (SELECTQ NBITS
+                  (1                                         (* ; 
+  "SUB1 is so that the extra bit goes on the top and right as it is documented as doing for lines.")
+                     (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH
+                                                               (FOLDLO (SUB1 BRUSHWIDTH)
+                                                                      2)))
+                                     DISPLAYDATA)))
+                  (4 (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH
+                                                               (FOLDLO (LRSH (SUB1 BRUSHWIDTH)
+                                                                             2)
+                                                                      2)))
+                                     DISPLAYDATA)))
+                  (8 (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH
+                                                               (FOLDLO (LRSH (SUB1 BRUSHWIDTH)
+                                                                             3)
+                                                                      2)))
+                                     DISPLAYDATA)))
+                  (SHOULDNT))
+              (SETQ X2 (\DSPTRANSFORMX (IDIFFERENCE X2 HALFBRUSHWIDTH)
+                              DISPLAYDATA))
+              (SETQ Y1 (\DSPTRANSFORMY (IDIFFERENCE Y1 (SETQ HALFBRUSHHEIGHT (FOLDLO (SUB1 
+                                                                                          BRUSHHEIGHT
+                                                                                           )
+                                                                                    2)))
+                              DISPLAYDATA))                  (* ; 
+                                                           "take into account the brush thickness.")
+              (SETQ Y2 (\DSPTRANSFORMY (IDIFFERENCE Y2 HALFBRUSHHEIGHT)
+                              DISPLAYDATA))
+
+              (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points")
+
+              (\INSURETOPWDS DISPLAYSTREAM)))                (* ; 
+                                                           "arrange things so that dx is positive.")
+          (COND
+             ((IGREATERP X1 X2)                              (* ; "switch points")
+              (swap X1 X2)
+              (swap Y1 Y2)))
+          (SETQ DX (ADD1 (IDIFFERENCE X2 X1)))
+          [SETQ DY (ADD1 (COND
+                            ((IGREATERP Y2 Y1)
+                             (SETQ YINC 1)
+                             (IDIFFERENCE Y2 Y1))
+                            (T (SETQ YINC -1)
+                               (IDIFFERENCE Y1 Y2]
+          [SETQ CDL (HALF (COND
+                             ((IGREATERP DX DY)              (* ; 
+                                             "set up the bucket so that the ends will be the same.")
+                              (IREMAINDER DX DY))
+                             (T (IREMAINDER DY DX]
+          [COND
+             [USERFN                                         (* ; 
+           "if user function is being called, don't bother bringing window to top uninterruptably.")
+                    (COND
+                       ((IGEQ DX DY)                         (* ; "X is the fastest mover.")
+                        (until (IGREATERP X1 X2)
+                           do                            (* ; "main loop")
+                                 (COND
+                                    (DASHON (APPLY* USERFN X1 Y1 DISPLAYSTREAM)))
+                                 [COND
+                                    (DASHTAIL                (* ; "do dashing.")
+                                           (COND
+                                              ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
+                                               (SETQ DASHON (NOT DASHON))
+                                               (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL))
+                                                                  DASHLST))
+                                               (SETQ DASHCNT (CAR DASHTAIL]
+                                 [COND
+                                    ((NOT (IGREATERP DX (add CDL DY)))
+                                     (add Y1 YINC)
+                                     (COND
+                                        ((COND
+                                            ((EQ YINC -1)
+                                             (ILESSP Y1 Y2))
+                                            ((IGREATERP Y1 Y2)))
+                                         (RETURN)))
+                                     (SETQ CDL (IDIFFERENCE CDL DX]
+                                 (add X1 1)))
+                       (T                                    (* ; "Y is the fastest mover.")
+                          (until (COND
+                                        ((EQ YINC -1)
+                                         (ILESSP Y1 Y2))
+                                        ((IGREATERP Y1 Y2)))
+                             do                          (* ; "main loop")
+                                   (COND
+                                      (DASHON (APPLY* USERFN X1 Y1 DISPLAYSTREAM)))
+                                   [COND
+                                      (DASHTAIL              (* ; "do dashing.")
+                                             (COND
+                                                ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
+                                                 (SETQ DASHON (NOT DASHON))
+                                                 (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL))
+                                                                    DASHLST))
+                                                 (SETQ DASHCNT (CAR DASHTAIL]
+                                   [COND
+                                      ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
+                                       (COND
+                                          ((IGREATERP (SETQ X1 (ADD1 X1))
+                                                  X2)
+                                           (RETURN)))
+                                       (SETQ CDL (IDIFFERENCE CDL DY]
+                                   (add Y1 YINC]
+             (T                                              (* ; 
+                                              "when we put the points down make it uninterruptable")
+                (.WHILE.TOP.DS. DISPLAYSTREAM
+                       (COND
+                          [(IGEQ DX DY)                      (* ; "X is the fastest mover.")
+                           (until (IGREATERP X1 X2)
+                              do                         (* ; "main loop")
+                                    (COND
+                                       (DASHON (\CURVEPT X1 Y1)))
+                                    [COND
+                                       (DASHTAIL             (* ; "do dashing.")
+                                              (COND
+                                                 ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
+                                                  (SETQ DASHON (NOT DASHON))
+                                                  (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL))
+                                                                     DASHLST))
+                                                  (SETQ DASHCNT (CAR DASHTAIL]
+                                    [COND
+                                       ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY]
+                                        (SETQ Y1 (IPLUS Y1 YINC))
+                                        (COND
+                                           ((COND
+                                               ((EQ YINC -1)
+                                                (ILESSP Y1 Y2))
+                                               ((IGREATERP Y1 Y2)))
+                                            (RETURN)))
+                                        (SETQ CDL (IDIFFERENCE CDL DX]
+                                    (SETQ X1 (ADD1 X1]
+                          (T                                 (* ; "Y is the fastest mover.")
+                             (until (COND
+                                           ((EQ YINC -1)
+                                            (ILESSP Y1 Y2))
+                                           ((IGREATERP Y1 Y2)))
+                                do                       (* ; "main loop")
+                                      (COND
+                                         (DASHON (\CURVEPT X1 Y1)))
+                                      [COND
+                                         (DASHTAIL           (* ; "do dashing.")
+                                                (COND
+                                                   ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
+                                                    (SETQ DASHON (NOT DASHON))
+                                                    (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL))
+                                                                       DASHLST))
+                                                    (SETQ DASHCNT (CAR DASHTAIL]
+                                      [COND
+                                         ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
+                                          (COND
+                                             ((IGREATERP (SETQ X1 (ADD1 X1))
+                                                     X2)
+                                              (RETURN)))
+                                          (SETQ CDL (IDIFFERENCE CDL DY]
+                                      (SETQ Y1 (IPLUS Y1 YINC]
+          (RETURN NIL])
+)
+(DEFINEQ
+
+(LOADPOLY
+  [LAMBDA (POLY POLYPRIME A B C D)                           (* hdj "13-Mar-85 18:01")
+    (replace (POLYNOMIAL A) of POLY with (FQUOTIENT A 6.0))
+    (replace (POLYNOMIAL B) of POLY with (FQUOTIENT B 2.0))
+    (replace (POLYNOMIAL C) of POLY with C)
+    (replace (POLYNOMIAL D) of POLY with D)
+    (replace (POLYNOMIAL A) of POLYPRIME with (FQUOTIENT A 2.0))
+    (replace (POLYNOMIAL B) of POLYPRIME with B)
+    (replace (POLYNOMIAL C) of POLYPRIME with C])
+
+(PARAMETRICSPLINE
+  [LAMBDA (KNOTS CLOSEDFLG SPLINE)                           (* rmk%: "30-Nov-84 17:02")
+
+    (* ;; "KNOTS is a non-NIL list of knots, CLOSEDFLG => closed curve")
+
+    (PROG (DX DY DDX DDY DDDX DDDY %#KNOTS A BX BY X Y SX SY A C R D2X D2Y I)
+          [COND
+             (CLOSEDFLG                                      (* ; "Wrap around")
+                    (push KNOTS (CAR (LAST KNOTS]
+          (SETQ %#KNOTS (LENGTH KNOTS))
+          (SETQ DX (ARRAY %#KNOTS 0 0.0))
+          (SETQ DDX (ARRAY %#KNOTS 0 0.0))
+          (SETQ DDDX (ARRAY %#KNOTS 0 0.0))
+          (SETQ DY (ARRAY %#KNOTS 0 0.0))
+          (SETQ DDY (ARRAY %#KNOTS 0 0.0))
+          (SETQ DDDY (ARRAY %#KNOTS 0 0.0))
+          (SETQ X (ARRAY %#KNOTS 0 0.0))
+          (SETQ Y (ARRAY %#KNOTS 0 0.0))
+          (for KNOT in KNOTS as I from 1 to %#KNOTS
+             do (OR (type? POSITION KNOT)
+                        (ERROR "bad knot" KNOT))
+                   (SETA X I (CAR KNOT))
+                   (SETA Y I (CDR KNOT)))
+          (SETQ A (ARRAY %#KNOTS 0 0.0))
+          (SETQ BX (ARRAY %#KNOTS 0 0.0))
+          (SETQ BY (ARRAY %#KNOTS 0 0.0))
+          [COND
+             (CLOSEDFLG (SETQ C (ARRAY %#KNOTS 0 0.0))
+                    (SETQ R (ARRAY %#KNOTS 0 0.0))
+                    (SETQ SX (ARRAY %#KNOTS 0 0.0))
+                    (SETQ SY (ARRAY %#KNOTS 0 0.0]
+          (SETA A 1 4.0)
+          [for I from 2 to (IDIFFERENCE %#KNOTS 2)
+             do (SETA A I (FDIFFERENCE 4.0 (FQUOTIENT 1.0 (ELT A (SUB1 I]
+          [COND
+             (CLOSEDFLG (SETA C 1 1.0)
+                    (for I from 2 to (IDIFFERENCE %#KNOTS 2)
+                       do (SETA C I (FMINUS (FQUOTIENT (ELT C (SUB1 I))
+                                                       (ELT A (SUB1 I]
+          [COND
+             ((IGEQ %#KNOTS 3)
+              (COND
+                 [CLOSEDFLG [SETA BX 1 (FTIMES 6.0 (FPLUS (ELT X 2)
+                                                          (FMINUS (FTIMES 2.0 (ELT X 1)))
+                                                          (ELT X (SUB1 %#KNOTS]
+                        [SETA BY 1 (FTIMES 6.0 (FPLUS (ELT Y 2)
+                                                      (FMINUS (FTIMES 2.0 (ELT Y 1)))
+                                                      (ELT Y (SUB1 %#KNOTS]
+                        [for I from 2 to (IDIFFERENCE %#KNOTS 2)
+                           do [SETA BX I (FDIFFERENCE [FTIMES 6.0
+                                                                 (FPLUS (ELT X (ADD1 I))
+                                                                        (FMINUS (FTIMES 2.0
+                                                                                       (ELT X I)))
+                                                                        (ELT X (SUB1 I]
+                                                    (FQUOTIENT (ELT BX (SUB1 I))
+                                                           (ELT A (SUB1 I]
+                                 (SETA BY I (FDIFFERENCE [FTIMES 6.0
+                                                                (FPLUS (ELT Y (ADD1 I))
+                                                                       (FMINUS (FTIMES 2.0
+                                                                                      (ELT Y I)))
+                                                                       (ELT Y (SUB1 I]
+                                                   (FQUOTIENT (ELT BY (SUB1 I))
+                                                          (ELT A (SUB1 I]
+                        (SETA R (SUB1 %#KNOTS)
+                              1.0)
+                        (SETA SX (SUB1 %#KNOTS)
+                              0.0)
+                        (SETA SY (SUB1 %#KNOTS)
+                              0.0)
+                        (for I from (IDIFFERENCE %#KNOTS 2) to 1 by -1
+                           do [SETA R I (FMINUS (FQUOTIENT (FPLUS (ELT R (ADD1 I))
+                                                                      (ELT C I))
+                                                           (ELT A I]
+                                 (SETA SX I (FQUOTIENT (FDIFFERENCE (ELT BX I)
+                                                              (ELT SX (ADD1 I)))
+                                                   (ELT A I)))
+                                 (SETA SY I (FQUOTIENT (FDIFFERENCE (ELT BY I)
+                                                              (ELT SY (ADD1 I)))
+                                                   (ELT A I]
+                 (T [SETA BX 1 (FTIMES 6.0 (FPLUS (FDIFFERENCE (ELT X 3)
+                                                         (FTIMES 2.0 (ELT X 2)))
+                                                  (ELT X 1]
+                    [SETA BY 1 (FTIMES 6.0 (FPLUS (FDIFFERENCE (ELT Y 3)
+                                                         (FTIMES 2.0 (ELT Y 2)))
+                                                  (ELT Y 1]
+                    (for I from 2 to (IDIFFERENCE %#KNOTS 2)
+                       do [SETA BX I (FDIFFERENCE (FTIMES
+                                                       6.0
+                                                       (FPLUS [FDIFFERENCE (ELT X (IPLUS I 2))
+                                                                     (FTIMES 2 (ELT X (ADD1 I]
+                                                              (ELT X I)))
+                                                (FQUOTIENT (ELT BX (SUB1 I))
+                                                       (ELT A (SUB1 I]
+                             (SETA BY I (FDIFFERENCE (FTIMES 6.0
+                                                            (FPLUS [FDIFFERENCE
+                                                                    (ELT Y (IPLUS I 2))
+                                                                    (FTIMES 2 (ELT Y (ADD1 I]
+                                                                   (ELT Y I)))
+                                               (FQUOTIENT (ELT BY (SUB1 I))
+                                                      (ELT A (SUB1 I]
+          [COND
+             (CLOSEDFLG [SETQ D2X (FPLUS (ELT X %#KNOTS)
+                                         [FMINUS (FTIMES 2.0 (ELT X (SUB1 %#KNOTS]
+                                         (ELT X (IDIFFERENCE %#KNOTS 2]
+                    [SETQ D2Y (FPLUS (ELT Y %#KNOTS)
+                                     [FMINUS (FTIMES 2.0 (ELT Y (SUB1 %#KNOTS]
+                                     (ELT Y (IDIFFERENCE %#KNOTS 2]
+                    (SETA DDX (SUB1 %#KNOTS)
+                          (FQUOTIENT (FDIFFERENCE (FDIFFERENCE (FTIMES D2X 6.0)
+                                                         (ELT SX 1))
+                                            (ELT SX (IDIFFERENCE %#KNOTS 2)))
+                                 (FPLUS (ELT R 1)
+                                        (ELT R (IDIFFERENCE %#KNOTS 2))
+                                        4.0)))
+                    (SETA DDY (SUB1 %#KNOTS)
+                          (FQUOTIENT (FDIFFERENCE (FDIFFERENCE (FTIMES D2Y 6.0)
+                                                         (ELT SY 1))
+                                            (ELT SY (IDIFFERENCE %#KNOTS 2)))
+                                 (FPLUS (ELT R 1)
+                                        (ELT R (IDIFFERENCE %#KNOTS 2))
+                                        4.0)))
+                    [for I from 1 to (IDIFFERENCE %#KNOTS 2)
+                       do [SETA DDX I (FPLUS (ELT SX I)
+                                                 (FTIMES (ELT R I)
+                                                        (ELT DDX (SUB1 %#KNOTS]
+                             (SETA DDY I (FPLUS (ELT SY I)
+                                                (FTIMES (ELT R I)
+                                                       (ELT DDY (SUB1 %#KNOTS]
+                    (SETA DDX %#KNOTS (ELT DDX 1))
+                    (SETA DDY %#KNOTS (ELT DDY 1)))
+             (T                                              (* ; "COMPUTE SECOND DERIVATIVES.")
+                [SETA DDX 1 (SETA DDY 1 (SETA DDX %#KNOTS (SETA DDY %#KNOTS 0.0]
+                (for I from (SUB1 %#KNOTS) to 2 by -1
+                   do [SETA DDX I (FQUOTIENT (FDIFFERENCE (ELT BX (SUB1 I))
+                                                        (ELT DDX (ADD1 I)))
+                                             (ELT A (SUB1 I]
+                         (SETA DDY I (FQUOTIENT (FDIFFERENCE (ELT BY (SUB1 I))
+                                                       (ELT DDY (ADD1 I)))
+                                            (ELT A (SUB1 I]
+          [for I from 1 to (SUB1 %#KNOTS)
+             do                                          (* ; "COMPUTE 1ST & 3RD DERIVATIVES")
+                   (SETA DX I (FDIFFERENCE (FDIFFERENCE (ELT X (ADD1 I))
+                                                  (ELT X I))
+                                     (FQUOTIENT (FPLUS (FTIMES 2 (ELT DDX I))
+                                                       (ELT DDX (ADD1 I)))
+                                            6.0)))
+                   (SETA DY I (FDIFFERENCE (FDIFFERENCE (ELT Y (ADD1 I))
+                                                  (ELT Y I))
+                                     (FQUOTIENT (FPLUS (FTIMES 2 (ELT DDY I))
+                                                       (ELT DDY (ADD1 I)))
+                                            6.0)))
+                   (SETA DDDX I (FDIFFERENCE (ELT DDX (ADD1 I))
+                                       (ELT DDX I)))
+                   (SETA DDDY I (FDIFFERENCE (ELT DDY (ADD1 I))
+                                       (ELT DDY I]
+          (SETQ SPLINE
+           (create SPLINE
+                  %#KNOTS _ %#KNOTS
+                  SPLINEX _ X
+                  SPLINEY _ Y
+                  SPLINEDX _ DX
+                  SPLINEDY _ DY
+                  SPLINEDDX _ DDX
+                  SPLINEDDY _ DDY
+                  SPLINEDDDX _ DDDX
+                  SPLINEDDDY _ DDDY))
+          (RETURN SPLINE])
+
+(\CURVE
+  [LAMBDA (X0 Y0 X1 Y1 DX DY DDX DDY DDDX DDDY N BRUSHBM DISPLAYDATA BBT ENDING USERFN DISPLAYSTREAM)
+                                                             (* rrb "30-Apr-85 12:44")
+    (DECLARE (LOCALVARS . T))
+
+    (* ;; "Puts a spline segment down.  Since it calls BitBlt1 directly, it must clip to both clipping region and the size of the destination bit map.")
+
+    (PROG (OLDX X Y OLDY DELTAX DELTAY DELTA TX TY OOLDX OOLDY)
+          [COND
+             ((NEQ N 0)
+              [COND
+                 (USERFN                                     (* ; 
+                                                  "if there is a user fn, stay in his coordinates.")
+                        (SETQ OLDX X0)
+                        (SETQ OLDY Y0))
+                 (T 
+                    (* ;; "SUB1 on brush size is to cause the extra bit to be in the top left direction as is documented for lines.")
+
+                    (SETQ OLDX (\DSPTRANSFORMX (IDIFFERENCE X0 (LRSH (SUB1 BRUSHWIDTH)
+                                                                     1))
+                                      DISPLAYDATA))
+                    (SETQ OLDY (\DSPTRANSFORMY (IDIFFERENCE Y0 (LRSH (SUB1 BRUSHHEIGHT)
+                                                                     1))
+                                      DISPLAYDATA]           (* ; "draw origin point")
+              (\CURVESMOOTH OLDX OLDY USERFN DISPLAYSTREAM)  (* ; 
+                                            "convert the derivatives to fractional representation.")
+
+              (* ;; "\CONVERTTOFRACTION always returns a large number box.  This uses 0.49 because 0.5 causes rounding up.")
+
+              (SETQ X (\CONVERTTOFRACTION (FPLUS OLDX 0.49)))
+              (SETQ Y (\CONVERTTOFRACTION (FPLUS OLDY 0.49)))
+              (SETQ DX (\CONVERTTOFRACTION DX))
+              (SETQ DY (\CONVERTTOFRACTION DY))
+              (SETQ DDX (\CONVERTTOFRACTION DDX))
+              (SETQ DDY (\CONVERTTOFRACTION DDY))
+              (SETQ DDDX (\CONVERTTOFRACTION DDDX))
+              (SETQ DDDY (\CONVERTTOFRACTION DDDY))
+              [for I from 1 to N do          (* ; 
+                           "uses \BOXIPLUS to save box and also set the new value of the variable.")
+                                                   (\BOXIPLUS X DX)
+                                                   (\BOXIPLUS DX DDX)
+                                                   (\BOXIPLUS DDX DDDX)
+                                                   (\BOXIPLUS Y DY)
+                                                   (\BOXIPLUS DY DDY)
+                                                   (\BOXIPLUS DDY DDDY)
+                                                   (SETQ OOLDX OLDX)
+                                                   (SETQ OOLDY OLDY)
+                                                   (SETQ DELTAX (IDIFFERENCE (SETQ OLDX (
+                                                                                    \GETINTEGERPART
+                                                                                         X))
+                                                                       OOLDX))
+                                                   (SETQ DELTAY (IDIFFERENCE (SETQ OLDY (
+                                                                                    \GETINTEGERPART
+                                                                                         Y))
+                                                                       OOLDY))
+                                                   (SETQ DELTA (IMAX (IABS DELTAX)
+                                                                     (IABS DELTAY)))
+                                                   (COND
+                                                      ((EQ DELTA 1)
+                                                       (\CURVESMOOTH OLDX OLDY USERFN DISPLAYSTREAM))
+                                                      )
+                                                   (COND
+                                                      ((IGREATERP DELTA 1)
+                                                       (SETQ DELTAX (\CONVERTTOFRACTION
+                                                                     (FQUOTIENT DELTAX DELTA)))
+                                                       (SETQ DELTAY (\CONVERTTOFRACTION
+                                                                     (FQUOTIENT DELTAY DELTA)))
+                                                       (SETQ TX (\CONVERTTOFRACTION OOLDX))
+                                                       (SETQ TY (\CONVERTTOFRACTION OOLDY))
+                                                       (for I from 0 to DELTA
+                                                          do (\CURVESMOOTH (\GETINTEGERPART
+                                                                                TX)
+                                                                        (\GETINTEGERPART TY)
+                                                                        USERFN DISPLAYSTREAM)
+                                                                (\BOXIPLUS TX DELTAX)
+                                                                (\BOXIPLUS TY DELTAY]
+                                                             (* ; "draw the end point")
+              (COND
+                 (USERFN (\CURVESMOOTH X1 Y1 USERFN DISPLAYSTREAM))
+                 (T (\CURVESMOOTH (\DSPTRANSFORMX (IDIFFERENCE X1 (LRSH (SUB1 BRUSHWIDTH)
+                                                                        1))
+                                         DISPLAYDATA)
+                           (\DSPTRANSFORMY (IDIFFERENCE Y1 (LRSH (SUB1 BRUSHHEIGHT)
+                                                                 1))
+                                  DISPLAYDATA)
+                           NIL DISPLAYSTREAM)))
+              (AND DISPLAYSTREAM (MOVETO X1 Y1 DISPLAYSTREAM]
+          (COND
+             (ENDING (\CURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX))
+                            (IPLUS \CURY \CURY (IMINUS \OLDY))
+                            USERFN DISPLAYSTREAM)
+                    (\CURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX))
+                           (IPLUS \CURY \CURY (IMINUS \OLDY))
+                           USERFN DISPLAYSTREAM)))
+          (RETURN NIL])
+
+(\CURVE2
+  [LAMBDA (SPLINE BRUSH DASHLST BBT DISPLAYSTREAM)       (* jds "26-Nov-85 12:21")
+
+(* ;;; "Given a spline curve, represented as a set of derivatives for each segment, draw it on DISPLAYSTREAM using the brush BRUSH, and dashing it according to DASHLST.  For speed, use the bitblt table BBT.")
+
+    (DECLARE (SPECVARS . T))
+
+    (* ;; "DISPLAYSTREAM is guaranteed to be a display-stream.  Should declare most of these variables local but currently have the \CURVE function between here and \CURVEBBT so can't")
+
+    (PROG (BRUSHBM DestinationBitMap OPERATION BRUSHWIDTH BRUSHHEIGHT BRUSHBASE BRUSHRASTERWIDTH LEFT
+                 RIGHTPLUS1 TOP BOTTOM DESTINATIONBASE LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH
+                 RASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 COLOR COLORBRUSHBASE NBITS \CURX \CURY 
+                 \OLDX \OLDY \OLDERX \OLDERY LKNOT (DASHON T)
+                 (DASHTAIL DASHLST)
+                 (DASHCNT (CAR DASHLST))
+                 NPOINTS NSEGS POINTSPERSEG DX D2X D3X DY D2Y D3Y D1 D2 D3 X0 Y0 X1 Y1 DX DDX DDDX DY
+                 DDY DDDY (XPOLY (create POLYNOMIAL))
+                 (X/PRIME/POLY (create POLYNOMIAL))
+                 (YPOLY (create POLYNOMIAL))
+                 (Y/PRIME/POLY (create POLYNOMIAL))
+                 (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM))
+                 (USERFN (AND (LITATOM BRUSH)
+                              BRUSH)))
+
+     (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT.  sets them up.")
+
+          [COND
+             (USERFN                                         (* ; 
+             "if calling user fn, don't bother with set up and leave points in window coordinates.")
+                    (\CURVESTART (ELT (fetch (SPLINE SPLINEX) of SPLINE)
+                                          1)
+                           (ELT (fetch (SPLINE SPLINEY) of SPLINE)
+                                1)))
+             (T (.SETUP.FOR.\BBTCURVEPT.)                    (* ; 
+                 "Do it interruptably here to get set up, then uninterruptably when drawing points")
+                (\INSURETOPWDS DISPLAYSTREAM)                (* ; 
+                      "curve pts will be kept in screen coordinates, start smoothing values there.")
+                (\CURVESTART (\DSPTRANSFORMX (IDIFFERENCE (ELT (fetch (SPLINE SPLINEX)
+                                                                      of SPLINE)
+                                                                   1)
+                                                        (LRSH (SUB1 BRUSHWIDTH)
+                                                              1))
+                                        DISPLAYDATA)
+                       (\DSPTRANSFORMY (IDIFFERENCE (ELT (fetch (SPLINE SPLINEY) of SPLINE)
+                                                         1)
+                                              (LRSH (SUB1 BRUSHHEIGHT)
+                                                    1))
+                              DISPLAYDATA]
+          [bind PERSEG for KNOT from 1 to (SUB1 (fetch %#KNOTS of SPLINE))
+             when (PROGN 
+                             (* ;; 
+                           "Loop thru the segments of the spline curve, drawing each in turn.")
+
+                             (SETQ X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE)
+                                           KNOT))            (* ; 
+                                               "Set up X0,Y0 -- the starting point of this segment")
+                             (SETQ Y0 (ELT (fetch (SPLINE SPLINEY) of SPLINE)
+                                           KNOT))
+                             (SETQ X1 (ELT (fetch (SPLINE SPLINEX) of SPLINE)
+                                           (ADD1 KNOT)))     (* ; "And X1,Y1 -- the ending point")
+                             (SETQ Y1 (ELT (fetch (SPLINE SPLINEY) of SPLINE)
+                                           (ADD1 KNOT)))
+                             (SETQ DX (ELT (fetch (SPLINE SPLINEDX) of SPLINE)
+                                           KNOT))            (* ; 
+                                                           "And the initial derivatives -- first")
+                             (SETQ DY (ELT (fetch (SPLINE SPLINEDY) of SPLINE)
+                                           KNOT))
+                             (SETQ DDX (ELT (fetch SPLINEDDX of SPLINE)
+                                            KNOT))           (* ; "Second")
+                             (SETQ DDY (ELT (fetch SPLINEDDY of SPLINE)
+                                            KNOT))
+                             (SETQ DDDX (ELT (fetch SPLINEDDDX of SPLINE)
+                                             KNOT))          (* ; "And third.")
+                             (SETQ DDDY (ELT (fetch SPLINEDDDY of SPLINE)
+                                             KNOT))
+                             (SETQ NPOINTS (FOLDLO (ITIMES (IMAX (IABS (IDIFFERENCE X1 X0))
+                                                                 (IABS (IDIFFERENCE Y1 Y0)))
+                                                          3)
+                                                  2))
+
+                             (* ;; "Establish an upper bound on the number of points we'll draw while painting this segment.  We know that 3/2 the maximum DX or DY is the right amount.")
+
+                             (NOT (ZEROP NPOINTS)))
+             do 
+
+                   (* ;; "NPOINTS can be zero if a knot is duplicated in the spline curve to produce a discontinuity.  Skip over zero-length segments to avoid divide-by-zero trouble")
+
+                   (* ;; "To prevent round-off errors from accumulating, we'll draw this segment as runs of no more than 64 points each -- recomputing completely at the start of each run.  This is a trade off of speed and accuracy.")
+
+                   [COND
+                      ((ILEQ NPOINTS 64)                     (* ; 
+                                                 "Fewer than 64 points to draw.  Do it in one run.")
+                       (SETQ NSEGS 1)
+                       (SETQ POINTSPERSEG NPOINTS))
+                      (T                                     (* ; 
+                                                           "Figure out how many runs to do it in.")
+                         (SETQ NSEGS (FOLDLO NPOINTS 64))
+                         (SETQ POINTSPERSEG 64)
+                         (SETQ NPOINTS (UNFOLD NSEGS 64]
+                   (SETQ D1 (FQUOTIENT 1.0 NPOINTS))         (* ; 
+                                        "Set up �&E�t, �&E�t**2 and �&E�t**3, for computing the next point.")
+                   (SETQ D2 (FTIMES D1 D1))
+                   (SETQ D3 (FTIMES D2 D1))
+                   (SETQ D3X (FTIMES D3 DDDX))
+                   (SETQ D3Y (FTIMES D3 DDDY))
+                   (COND
+                      [(EQ NSEGS 1)                          (* ; "Just one segment to draw.")
+                       [SETQ DX (FPLUS (FTIMES D1 DX)
+                                       (FTIMES DDX D2 0.5)
+                                       (FTIMES DDDX D3 (CONSTANT (FQUOTIENT 1.0 6.0]
+                       (SETQ D2X (FPLUS (FTIMES D2 DDX)
+                                        (FTIMES D3 DDDX)))
+                       [SETQ DY (FPLUS (FTIMES D1 DY)
+                                       (FTIMES D2 DDY 0.5)
+                                       (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0]
+                       (SETQ D2Y (FPLUS (FTIMES D2 DDY)
+                                        (FTIMES D3 DDDY)))
+                       (COND
+                          (USERFN                            (* ; 
+                                     "Draw this run of points, using the user's supplied function.")
+                                 (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM 
+                                        DISPLAYDATA BBT NIL USERFN DISPLAYSTREAM))
+                          (T                                 (* ; 
+                                                        "Draw this run of points, using the brush.")
+                             (.WHILE.TOP.DS. DISPLAYSTREAM
+                                    (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM 
+                                           DISPLAYDATA BBT NIL NIL DISPLAYSTREAM]
+                      (T                                     (* ; 
+                                                         "Have to do this segment in several runs.")
+                         (SETQ PERSEG (FQUOTIENT 1.0 NSEGS))
+                         (LOADPOLY XPOLY X/PRIME/POLY DDDX DDX DX X0)
+                         (LOADPOLY YPOLY Y/PRIME/POLY DDDY DDY DY Y0)
+                         (bind (TT _ 0.0)
+                                (DDDX/PER/SEG _ (FTIMES DDDX PERSEG))
+                                (DDDY/PER/SEG _ (FTIMES DDDY PERSEG))
+                                [D3XFACTOR _ (FTIMES D3 DDDX (CONSTANT (FQUOTIENT 1.0 6.0]
+                                [D3YFACTOR _ (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0]
+                            for I from 0 to (SUB1 NSEGS)
+                            do 
+
+                                  (* ;; 
+       "TT is the parameter, and runs from 0 to 1 as the curve segment runs from beginning to end.")
+
+                                  (SETQ TT (FPLUS TT PERSEG))
+                                  (SETQ X1 (POLYEVAL TT XPOLY 3))
+                                  (SETQ Y1 (POLYEVAL TT YPOLY 3))
+                                  (SETQ DX (FPLUS (FTIMES D1 DX)
+                                                  (FTIMES D2 DDX 0.5)
+                                                  D3XFACTOR))
+                                  (SETQ D2X (FPLUS (FTIMES D2 DDX)
+                                                   (FTIMES D3 DDDX)))
+                                  (SETQ DY (FPLUS (FTIMES D1 DY)
+                                                  (FTIMES D2 DDY 0.5)
+                                                  D3YFACTOR))
+                                  (SETQ D2Y (FPLUS (FTIMES D2 DDY)
+                                                   (FTIMES D3 DDDY)))
+                                  [COND
+                                     (USERFN (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 BRUSHBM
+                                                    DISPLAYDATA BBT NIL USERFN DISPLAYSTREAM))
+                                     (T (.WHILE.TOP.DS. DISPLAYSTREAM
+                                               (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 
+                                                      BRUSHBM DISPLAYDATA BBT NIL NIL DISPLAYSTREAM]
+                                  (SETQ X0 X1)
+                                  (SETQ Y0 Y1)
+                                  (SETQ DDX (FPLUS DDX DDDX/PER/SEG))
+                                  (SETQ DDY (FPLUS DDY DDDY/PER/SEG))
+                                  (SETQ DX (POLYEVAL TT X/PRIME/POLY 2))
+                                  (SETQ DY (POLYEVAL TT Y/PRIME/POLY 2]
+
+     (* ;; "Draw the final point on the curve.")
+
+          (COND
+             (USERFN (\CURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DISPLAYDATA BBT T USERFN DISPLAYSTREAM
+                            ))
+             (T (.WHILE.TOP.DS. DISPLAYSTREAM
+                       (\CURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DISPLAYDATA BBT T NIL DISPLAYSTREAM])
+
+(\CURVEEND
+  [LAMBDA NIL                                                (* rrb " 5-JAN-82 17:24")
+
+    (* ;; "Put out the last two points, using \CURVEPT, since they were held back for smoothing.")
+
+    (PROG ((X \CURX)
+           (Y \CURY)
+           (DX (IDIFFERENCE \CURX \OLDX))
+           (DY (IDIFFERENCE \CURY \OLDY)))
+          (for I from 1 to 2 do (\CURVESMOOTH (SETQ X (IPLUS X DX))
+                                                       (SETQ Y (IPLUS Y DY])
+
+(\CURVESLOPE
+  [LAMBDA (KNOTS ENDFLG)                                     (* rrb "30-Nov-84 18:17")
+
+    (* ;; "returns a CONS of DX DY that gives the slope of the curve thru KNOTS.  If ENDFLG is NIL, it is at the beginning.  If ENDFLG is T, it is at the last point.")
+
+    (PROG (DX DY PARAMS (%#KNOTS (LENGTH KNOTS)))
+          (RETURN (SELECTQ %#KNOTS
+                      ((0 1)                                 (* ; "define slope as horizontal")
+                           '(1 . 0))
+                      (2 [CONS (DIFFERENCE (fetch (POSITION XCOORD) of (CADR KNOTS))
+                                      (fetch (POSITION XCOORD) of (CAR KNOTS)))
+                               (DIFFERENCE (fetch (POSITION YCOORD) of (CADR KNOTS))
+                                      (fetch (POSITION YCOORD) of (CAR KNOTS])
+                      (PROGN [SETQ PARAMS (COND
+                                             [ENDFLG (PARAMETRICSPLINE (REVERSE
+                                                                            (NLEFT KNOTS
+                                                                                   (IMIN %#KNOTS 4]
+                                             (T (PARAMETRICSPLINE (COND
+                                                                         ((EQ %#KNOTS 3)
+                                                                          (LIST (CAR KNOTS)
+                                                                                (CADR KNOTS)
+                                                                                (CADDR KNOTS)))
+                                                                         (T (LIST (CAR KNOTS)
+                                                                                  (CADR KNOTS)
+                                                                                  (CADDR KNOTS)
+                                                                                  (CADDDR KNOTS]
+                             (SETQ DX (ELT (fetch (SPLINE SPLINEDX) of PARAMS)
+                                           1))
+                             (SETQ DY (ELT (fetch (SPLINE SPLINEDY) of PARAMS)
+                                           1))
+                             (if ENDFLG
+                                 then (CONS (MINUS DX)
+                                                (MINUS DY))
+                               else (CONS DX DY])
+
+(\CURVESTART
+  [LAMBDA (X Y)                                          (* jds "27-OCT-81 15:48")
+
+    (* ;; "Set up the init vals for \OLDER* \OLD* \CUR*, for curve smoothing in \CURVEPT.")
+
+    (SETQ \OLDERX X)
+    (SETQ \OLDX X)
+    (SETQ \CURX X)
+    (SETQ \OLDERY Y)
+    (SETQ \OLDY Y)
+    (SETQ \CURY Y])
+
+(\FDIFS/FROM/DERIVS
+  [LAMBDA (DZ DDZ DDDZ RAD NSTEPS)                           (* rrb "12-MAY-81 10:59")
+
+    (* ;; "the derivatives of the function, plus a scale factor (radius for drawing circles) See 'Spline Curve Techniques' , equations 2.18.")
+
+    (PROG (S SS SSS)
+          (SETQ S (FQUOTIENT 1.0 NSTEPS))
+          (SETQ SS (FTIMES S S))
+          (SETQ SSS (FTIMES SS S))
+          (SETQ S (FTIMES S DZ RAD))
+          (SETQ SS (FTIMES SS DDZ RAD))
+          (SETQ SSS (FTIMES SSS DDDZ RAD))
+          (RETURN (LIST (FPLUS S (FQUOTIENT SS 2.0)
+                               (FQUOTIENT SSS 6.0))
+                        (FPLUS SS SSS)
+                        SSS])
+)
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
+
+(ARRAYRECORD POLYNOMIAL (A B C D)
+                            (CREATE (ARRAY 4 'FLOATP))
+                            (SYSTEM))
+
+(RECORD SPLINE (%#KNOTS SPLINEX SPLINEY SPLINEDX SPLINEDY SPLINEDDX SPLINEDDY SPLINEDDDX 
+                          SPLINEDDDY))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS HALF MACRO ((X)
+                              (LRSH X 1)))
+
+(PUTPROPS \FILLCIRCLEBLT MACRO (OPENLAMBDA (CX CY X Y)
+                                                             (* ; 
+                                            "calls bitblt twice to fill in one line of the circle.")
+                                              (\LINEBLT FCBBT (IDIFFERENCE CX X)
+                                                     (IPLUS CY Y)
+                                                     (IPLUS CX X)
+                                                     DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM 
+                                                     TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS)
+                                              (\LINEBLT FCBBT (IDIFFERENCE CX X)
+                                                     (IDIFFERENCE CY Y)
+                                                     (IPLUS CX X)
+                                                     DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM 
+                                                     TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS)))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \CURVEPT MACRO [OPENLAMBDA (X Y)
+                                        (COND
+                                           ((OR (ILEQ X LEFTMINUSBRUSH)
+                                                (IGEQ X RIGHTPLUS1)
+                                                (ILEQ Y BOTTOMMINUSBRUSH)
+                                                (IGEQ Y TOP))
+                                            NIL)
+                                           ((NULL BBT)
+                                            (\FBITMAPBIT DESTINATIONBASE X Y OPERATION HEIGHTMINUS1 
+                                                   RASTERWIDTH))
+                                           (T 
+                                              (* ;; 
+                       "This should have been done in .SETUP.FOR.\BBTCURVEPT., under \GETBRUSHBBT.")
+
+                                              (* ;; 
+                                     "Its a bug here, because brushes can't use operation REPLACE.")
+
+                                              (* ;; 
+                             "(\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA) OPERATION)")
+
+                                              (\BBTCURVEPT X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH
+                                                     RIGHTPLUS1 NBITSRIGHTPLUS1 TOPMINUSBRUSH 
+                                                     DestinationBitMap BRUSHHEIGHT BOTTOMMINUSBRUSH 
+                                                     TOP BRUSHBASE DESTINATIONBASE RASTERWIDTH 
+                                                     BRUSHRASTERWIDTH COLORBRUSHBASE NBITS 
+                                                     DISPLAYDATA])
+
+(PUTPROPS .SETUP.FOR.\BBTCURVEPT. MACRO
+          [NIL (PROGN (SETQ BOTTOM (ffetch (\DISPLAYDATA DDClippingBottom) of DISPLAYDATA))
+                      (SETQ TOP (ffetch (\DISPLAYDATA DDClippingTop) of DISPLAYDATA))
+                      (SETQ RIGHTPLUS1 (ffetch (\DISPLAYDATA DDClippingRight) of DISPLAYDATA)
+                       )
+                      (SETQ LEFT (ffetch (\DISPLAYDATA DDClippingLeft) of DISPLAYDATA))
+                      (SETQ DestinationBitMap (ffetch (\DISPLAYDATA DDDestination) of 
+                                                                                          DISPLAYDATA
+                                                     ))
+                      (SETQ OPERATION (OR OPERATION (ffetch (\DISPLAYDATA DDOPERATION)
+                                                       of DISPLAYDATA)))
+                      (SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DestinationBitMap))
+                      [COND
+                         [(NOT (EQ NBITS 1))
+                          (SETQ BRUSHBM (\GETCOLORBRUSH BRUSH (MAXIMUMCOLOR NBITS)
+                                               NBITS))
+                          [SETQ COLOR (COND
+                                         [(AND (LISTP BRUSH)
+                                               (CAR (LISTP (CDDR BRUSH]
+                                         ((DSPCOLOR NIL DISPLAYSTREAM))
+                                         (T (MAXIMUMCOLOR NBITS]
+                          [COND
+                             ((EQ OPERATION 'ERASE)
+                              (SETQ COLOR (OPPOSITECOLOR COLOR NBITS]
+                          (SETQ COLORBRUSHBASE (fetch (BITMAP BITMAPBASE)
+                                                  of (\GETCOLORBRUSH BRUSH COLOR NBITS]
+                         (T (SETQ BRUSHBM (\GETBRUSH BRUSH]
+                      (SETQ RASTERWIDTH (ffetch (BITMAP BITMAPRASTERWIDTH) of 
+                                                                                    DestinationBitMap
+                                               ))
+                      (SETQ DESTINATIONBASE (ffetch (BITMAP BITMAPBASE) of DestinationBitMap)
+                       )
+                      (SETQ BBT (\GETBRUSHBBT BRUSHBM DISPLAYDATA BBT))
+                      (SETQ BRUSHBASE (fetch (BITMAP BITMAPBASE) of BRUSHBM))
+                      (SETQ BRUSHRASTERWIDTH (ffetch (BITMAP BITMAPRASTERWIDTH) of BRUSHBM))
+                      [COND
+                         ((NULL BBT)
+                          (SETQ HEIGHTMINUS1 (SUB1 (ffetch (BITMAP BITMAPHEIGHT) of 
+                                                                                    DestinationBitMap
+                                                          )))
+                          (COND
+                             ((EQ (ffetch (\DISPLAYDATA DDOPERATION) of DISPLAYDATA)
+                                  'INVERT)
+                              (SETQ OPERATION 'INVERT]
+                      (SETQ BRUSHWIDTH (ffetch (BITMAP BITMAPWIDTH) of BRUSHBM))
+                      (SETQ BRUSHHEIGHT (ffetch (BITMAP BITMAPHEIGHT) of BRUSHBM))
+                      (SETQ LEFTMINUSBRUSH (IDIFFERENCE LEFT BRUSHWIDTH))
+                      (SETQ BOTTOMMINUSBRUSH (IDIFFERENCE BOTTOM BRUSHHEIGHT))
+                      (SETQ TOPMINUSBRUSH (IDIFFERENCE TOP BRUSHHEIGHT))
+                      (SETQ NBITSRIGHTPLUS1 (ITIMES RIGHTPLUS1 NBITS))
+                      (SETQ BRUSHWIDTH (ITIMES BRUSHWIDTH NBITS])
+
+(PUTPROPS \CIRCLEPTS MACRO (OPENLAMBDA (CX CY X Y)
+                                          (\CURVEPT (IPLUS CX X)
+                                                 (IPLUS CY Y))
+                                          (\CURVEPT (IDIFFERENCE CX X)
+                                                 (IPLUS CY Y))
+                                          (\CURVEPT (IPLUS CX X)
+                                                 (IDIFFERENCE CY Y))
+                                          (\CURVEPT (IDIFFERENCE CX X)
+                                                 (IDIFFERENCE CY Y))))
+
+(PUTPROPS \CURVESMOOTH MACRO (OPENLAMBDA
+                                      (NEWX NEWY USERFN DISPLAYSTREAM)
+                                      (PROG [(DX (IABS (IDIFFERENCE NEWX \OLDX)))
+                                             (DY (IABS (IDIFFERENCE NEWY \OLDY]
+                                            (COND
+                                               ((OR (IGREATERP DX 1)
+                                                    (IGREATERP DY 1))
+                                                [COND
+                                                   ((NEQ [IPLUS (ADD1 (IDIFFERENCE \OLDX \OLDERX))
+                                                                (ITIMES 3 (ADD1 (IDIFFERENCE \OLDY 
+                                                                                       \OLDERY]
+                                                         4)
+                                                    [COND
+                                                       (DASHON (COND
+                                                                  (USERFN (APPLY* USERFN \OLDX \OLDY
+                                                                                 DISPLAYSTREAM))
+                                                                  (T (.WHILE.TOP.DS. DISPLAYSTREAM
+                                                                            (\CURVEPT \OLDX \OLDY]
+                                                    (COND
+                                                       (DASHTAIL (COND
+                                                                    ((EQ 0 (SETQ DASHCNT (SUB1 
+                                                                                              DASHCNT
+                                                                                               )))
+                                                                     (SETQ DASHON (NOT DASHON))
+                                                                     (SETQ DASHTAIL
+                                                                      (OR (LISTP (CDR DASHTAIL))
+                                                                          DASHLST))
+                                                                     (SETQ DASHCNT (CAR DASHTAIL]
+                                                (SETQ \OLDERX \OLDX)
+                                                (SETQ \OLDERY \OLDY)
+                                                (SETQ \OLDX \CURX)
+                                                (SETQ \OLDY \CURY)))
+                                            (SETQ \CURX NEWX)
+                                            (SETQ \CURY NEWY))))
+)
+)
+(DEFINEQ
+
+(\FILLCIRCLE.DISPLAY
+  [LAMBDA (DISPLAYSTREAM CENTERX CENTERY RADIUS TEXTURE)     (* kbr%: "24-Jan-86 19:12")
+
+    (* ;; "Fill in area bounded by circle DRAWCIRCLE would draw.")
+
+    (COND
+       ((OR (NOT (NUMBERP RADIUS))
+            (ILESSP (SETQ RADIUS (FIXR RADIUS))
+                   0))
+        (\ILLEGAL.ARG RADIUS))
+       (T (GLOBALRESOURCE \BRUSHBBT
+                 (PROG (TOP BOTTOM RIGHT LEFT OPERATION DestinationBitMap DISPLAYDATA X Y D 
+                            DESTINATIONBASE RASTERWIDTH CX CY TEXTUREBM GRAYHEIGHT GRAYWIDTH GRAYBASE
+                            NBITS FCBBT)
+                       (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DISPLAYSTREAM))
+                       (SETQ X 0)
+                       (SETQ Y RADIUS)
+                       (SETQ D (ITIMES 2 (IDIFFERENCE 1 RADIUS)))
+                       (SETQ FCBBT \BRUSHBBT)
+                       (SETQ LEFT (fetch (\DISPLAYDATA DDClippingLeft) of DISPLAYDATA))
+                       (SETQ BOTTOM (fetch (\DISPLAYDATA DDClippingBottom) of DISPLAYDATA))
+                       (SETQ TOP (SUB1 (fetch (\DISPLAYDATA DDClippingTop) of DISPLAYDATA)))
+                       (SETQ RIGHT (SUB1 (fetch (\DISPLAYDATA DDClippingRight) of DISPLAYDATA
+                                                )))
+                       (SETQ OPERATION (fetch (\DISPLAYDATA DDOPERATION) of DISPLAYDATA))
+                       (SETQ DestinationBitMap (fetch (\DISPLAYDATA DDDestination) of 
+                                                                                          DISPLAYDATA
+                                                      ))
+                       (SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DestinationBitMap))
+                       [SETQ TEXTUREBM (COND
+                                          ((BITMAPP TEXTURE))
+                                          [(NOT (EQ NBITS 1))(* ; 
+                                                          "color case, default texture differently")
+                                           (COND
+                                              ((BITMAPP (COLORTEXTUREFROMCOLOR#
+                                                             (COLORNUMBERP (OR TEXTURE
+                                                                               (DSPCOLOR NIL 
+                                                                                      DISPLAYSTREAM))
+                                                                    NBITS T)
+                                                             NBITS)))
+                                              [(AND (LISTP TEXTURE)
+                                                    (BITMAPP (COLORTEXTUREFROMCOLOR#
+                                                                  (COLORNUMBERP (CADR TEXTURE)
+                                                                         NBITS)
+                                                                  NBITS]
+                                              (T (\ILLEGAL.ARG TEXTURE]
+                                          ((LISTP TEXTURE)   (* ; 
+                                                      "either a color or a list of (texture color)")
+                                           (INSURE.B&W.TEXTURE TEXTURE))
+                                          [(AND (NULL TEXTURE)
+                                                (BITMAPP (fetch (\DISPLAYDATA DDTexture)
+                                                                of DISPLAYDATA]
+                                          ([OR (FIXP TEXTURE)
+                                               (AND (NULL TEXTURE)
+                                                    (SETQ TEXTURE (fetch (\DISPLAYDATA DDTexture)
+                                                                     of DISPLAYDATA]
+                                                             (* ; 
+            "create bitmap for the texture.  Could reuse a bitmap but for now this is good enough.")
+                                           (SETQ TEXTUREBM (BITMAPCREATE 16 4))
+                                           (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of
+                                                                                         TEXTUREBM))
+                                           (\PUTBASE GRAYBASE 0 (\SFReplicate (LOGAND (LRSH TEXTURE 
+                                                                                            12)
+                                                                                     15)))
+                                           (\PUTBASE GRAYBASE 1 (\SFReplicate (LOGAND (LRSH TEXTURE 8
+                                                                                            )
+                                                                                     15)))
+                                           (\PUTBASE GRAYBASE 2 (\SFReplicate (LOGAND (LRSH TEXTURE 4
+                                                                                            )
+                                                                                     15)))
+                                           (\PUTBASE GRAYBASE 3 (\SFReplicate (LOGAND TEXTURE 15)))
+                                           TEXTUREBM)
+                                          (T (\ILLEGAL.ARG TEXTURE]
+                       (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM))
+                       (SETQ DESTINATIONBASE (fetch (BITMAP BITMAPBASE) of DestinationBitMap)
+                        )
+                       (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of 
+                                                                                    DestinationBitMap
+                                                ))           (* ; 
+                             "update as many fields in the brush bitblt table as possible from DS.")
+                       (replace (PILOTBBT PBTFLAGS) of FCBBT with 0)
+                       (replace (PILOTBBT PBTDESTBPL) of FCBBT with (UNFOLD RASTERWIDTH 
+                                                                                       BITSPERWORD))
+                                                             (* ; 
+                          "clear gray information.  PBTSOURCEBPL is used for gray information too.")
+                       (replace (PILOTBBT PBTSOURCEBPL) of FCBBT with 0)
+                       (replace (PILOTBBT PBTUSEGRAY) of FCBBT with T)
+                       [replace (PILOTBBT PBTGRAYWIDTHLESSONE) of FCBBT
+                          with (SUB1 (SETQ GRAYWIDTH (IMIN (fetch (BITMAP BITMAPWIDTH)
+                                                                  of TEXTUREBM)
+                                                               16]
+                       [replace (PILOTBBT PBTGRAYHEIGHTLESSONE) of FCBBT
+                          with (SUB1 (SETQ GRAYHEIGHT (IMIN (fetch (BITMAP BITMAPHEIGHT)
+                                                                   of TEXTUREBM)
+                                                                16]
+                       (replace (PILOTBBT PBTDISJOINT) of FCBBT with T)
+                       (\SETPBTFUNCTION FCBBT 'TEXTURE OPERATION)
+                       (replace (PILOTBBT PBTHEIGHT) of FCBBT with 1)
+                                                             (* ; 
+                                                           "take into account the brush thickness.")
+                       (SETQ CX (\DSPTRANSFORMX CENTERX DISPLAYDATA))
+                       (SETQ CY (\DSPTRANSFORMY CENTERY DISPLAYDATA))
+                                                             (* ; 
+                                              "change Y TOP and BOTTOM to be in bitmap coordinates")
+                       (SETQ CY (SUB1 (\SFInvert DestinationBitMap CY)))
+                       (SETQ TOP (SUB1 (\SFInvert DestinationBitMap TOP)))
+                       (SETQ BOTTOM (SUB1 (\SFInvert DestinationBitMap BOTTOM)))
+                       (swap TOP BOTTOM)
+                       (\INSURETOPWDS DISPLAYSTREAM)
+
+                  (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points")
+
+                       (COND
+                          ((EQ RADIUS 0)                     (* ; 
+                               "put a single point down.  Use \LINEBLT to get proper texture.  NIL")
+                           (.WHILE.TOP.DS. DISPLAYSTREAM
+                                  (\LINEBLT FCBBT CX CY CX DESTINATIONBASE RASTERWIDTH LEFT RIGHT
+                                         BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS))
+                           (RETURN)))
+                   LP                                        (* ; 
+                                                     "(UNFOLD x 2) is used instead of (ITIMES x 2)")
+                       [COND
+                          [(IGREATERP 0 D)
+                           (SETQ X (ADD1 X))
+                           (COND
+                              ((IGREATERP (UNFOLD (IPLUS D Y)
+                                                 2)
+                                      1)
+                               (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
+                                                       2)
+                                              4)))
+                              (T (SETQ D (IPLUS D (UNFOLD X 2)
+                                                1))          (* ; "don't draw unless Y changes.")
+                                 (GO LP]
+                          ((OR (EQ 0 D)
+                               (IGREATERP X D))
+                           (SETQ X (ADD1 X))
+                           (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
+                                                   2)
+                                          4)))
+                          (T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2))
+                                            3]
+                       (COND
+                          ((EQ Y 0)                          (* ; 
+                                           "draw the middle line differently to avoid duplication.")
+                           (.WHILE.TOP.DS. DISPLAYSTREAM
+                                  (\LINEBLT FCBBT (IDIFFERENCE CX X)
+                                         CY
+                                         (IPLUS CX X)
+                                         DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH
+                                         GRAYHEIGHT GRAYBASE NBITS)))
+                          (T (.WHILE.TOP.DS. DISPLAYSTREAM (\FILLCIRCLEBLT CX CY X Y))
+                             (SETQ Y (SUB1 Y))
+                             (GO LP)))
+                       (MOVETO CENTERX CENTERY DISPLAYSTREAM)
+                       (RETURN NIL])
+
+(\LINEBLT
+  [LAMBDA (BBT X Y XRIGHT DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT 
+               GRAYBASE NBITS)                               (* kbr%: "15-Feb-86 22:08")
+
+    (* ;; "fills in the changing fields of a bit blt tablt to draw one line of aan area.")
+
+    (PROG NIL
+          (COND
+             ((ILESSP X LEFT)
+              (SETQ X LEFT)))
+          (COND
+             ((IGREATERP XRIGHT RIGHT)
+              (SETQ XRIGHT RIGHT)))
+          (COND
+             ((OR (IGREATERP X XRIGHT)
+                  (IGREATERP Y TOP)
+                  (IGREATERP BOTTOM Y))
+              (RETURN)))
+          (replace (PILOTBBT PBTDEST) of BBT with (\ADDBASE DESTINATIONBASE
+                                                                     (ITIMES RASTERWIDTH Y)))
+          [freplace (PILOTBBT PBTSOURCE) of BBT with (\ADDBASE GRAYBASE
+                                                                        (freplace (PILOTBBT
+                                                                                       PBTGRAYOFFSET)
+                                                                           of BBT
+                                                                           with (MOD Y GRAYHEIGHT
+                                                                                         ]
+          (SELECTQ NBITS
+              (1 (freplace (PILOTBBT PBTDESTBIT) of BBT with X)
+                 (freplace (PILOTBBT PBTSOURCEBIT) of BBT with (MOD X GRAYWIDTH))
+                 (freplace (PILOTBBT PBTWIDTH) of BBT with (ADD1 (IDIFFERENCE XRIGHT X))))
+              (4                                             (* ; 
+                                "color case, shift x values {which are in pixels} into bit values.")
+                 (freplace (PILOTBBT PBTDESTBIT) of BBT with (SETQ X (LLSH X 2)))
+                                                             (* ; 
+                             "if TEXTURE is not a multiple of nbits wide this is probably garbage.")
+                 (freplace (PILOTBBT PBTSOURCEBIT) of BBT with (MOD X GRAYWIDTH))
+                 (freplace (PILOTBBT PBTWIDTH) of BBT with (IDIFFERENCE
+                                                                        (LLSH (ADD1 XRIGHT)
+                                                                              2)
+                                                                        X)))
+              (8                                             (* ; 
+                                "color case, shift x values {which are in pixels} into bit values.")
+                 (freplace (PILOTBBT PBTDESTBIT) of BBT with (SETQ X (LLSH X 3)))
+                 (freplace (PILOTBBT PBTSOURCEBIT) of BBT with (MOD X GRAYWIDTH))
+                 (freplace (PILOTBBT PBTWIDTH) of BBT with (IDIFFERENCE
+                                                                        (LLSH (ADD1 XRIGHT)
+                                                                              3)
+                                                                        X)))
+              (24                                            (* ; 
+                                "color case, shift x values {which are in pixels} into bit values.")
+                  (freplace (PILOTBBT PBTDESTBIT) of BBT with (SETQ X (ITIMES 24 X)))
+                  (freplace (PILOTBBT PBTSOURCEBIT) of BBT with (MOD X GRAYWIDTH))
+                  (freplace (PILOTBBT PBTWIDTH) of BBT with (IDIFFERENCE
+                                                                         (ITIMES 24 (ADD1 XRIGHT))
+                                                                         X)))
+              (SHOULDNT))
+          (\PILOTBITBLT BBT 0])
+)
+
+
+
+(* ; "making and copying bitmaps")
+
+(DEFINEQ
+
+(SCREENBITMAP
+  [LAMBDA (SCREEN)                                           (* ; "Edited 20-Feb-87 14:57 by rrb")
+
+    (* ;; "Return bitmap destination of SCREEN.")
+
+    (COND
+       ((NULL SCREEN)
+        ScreenBitMap)
+       ((type? SCREEN SCREEN)
+        (fetch (SCREEN SCDESTINATION) of SCREEN))
+       ((WINDOWP SCREEN)
+        (fetch (SCREEN SCDESTINATION) of (fetch (WINDOW SCREEN) of SCREEN)))
+       (T (\ILLEGAL.ARG SCREEN])
+
+(BITMAPP
+  [LAMBDA (X)                                                (* rrb "25-JUN-82 15:21")
+                                                             (* ; "is x a bitmap?")
+    (AND (type? BITMAP X)
+         X])
+
+(BITMAPHEIGHT
+  [LAMBDA (BITMAP)                                           (* kbr%: " 8-Jul-85 16:01")
+
+    (* ;; "returns the height in pixels of a bitmap.")
+
+    (COND
+       ((type? BITMAP BITMAP)
+        (fetch (BITMAP BITMAPHEIGHT) of BITMAP))
+       ((type? WINDOW BITMAP)
+        (WINDOWPROP BITMAP 'HEIGHT))
+       (T (\ILLEGAL.ARG BITMAP])
+
+(BITSPERPIXEL
+  [LAMBDA (BITMAP)                                           (* kbr%: " 5-Jun-86 19:17")
+
+    (* ;; "returns the height in pixels of a bitmap.")
+
+    (COND
+       ((type? BITMAP BITMAP)
+        (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP))
+       ((type? SCREEN BITMAP)
+        (BITSPERPIXEL (fetch (SCREEN SCDESTINATION) of BITMAP)))
+       ((type? WINDOW BITMAP)
+        (BITSPERPIXEL (fetch (WINDOW SCREEN) of BITMAP)))
+       ((ARRAYP BITMAP)                                      (* ; 
+                                                           "Consider array to be a colormap.")
+        (SELECTQ (ARRAYSIZE BITMAP)
+            (256 8)
+            (16 4)
+            (LISPERROR "ILLEGAL ARG" BITMAP)))
+       (T (LISPERROR "ILLEGAL ARG" BITMAP])
+)
+(* "FOLLOWING DEFINITIONS EXPORTED")(PUTDEF (QUOTE BITMAPS) (QUOTE FILEPKGCOMS) '[(COM
+                                                                                   MACRO
+                                                                                   (X (VARS . X])
+(PUTDEF (QUOTE CURSORS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (MAPC 'X 'PRINTCURSOR])
+
+(* "END EXPORTED DEFINITIONS")
+
+(DECLARE%: EVAL@COMPILE 
+(* "FOLLOWING DEFINITIONS EXPORTED")
+(ADDTOVAR GLOBALVARS SCREENHEIGHT SCREENWIDTH ScreenBitMap)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+
+
+
+(* ; "Display stream functions that are not needed in the primitive system")
+
+(DEFINEQ
+
+(DSPFILL
+  [LAMBDA (REGION TEXTURE OPERATION STREAM)                  (* kbr%: " 8-Jul-85 15:40")
+
+    (* ;; "wipes a region of an imagestream with texture.")
+
+    (* ;; "TEXTURE and OPERATION default to those of STREAM")
+
+    (PROG (STRM)
+          (SETQ STRM (\OUTSTREAMARG STREAM))
+          (OR REGION (SETQ REGION (DSPCLIPPINGREGION NIL STRM)))
+          (RETURN (BLTSHADE TEXTURE STRM (fetch (REGION LEFT) of REGION)
+                         (fetch (REGION BOTTOM) of REGION)
+                         (fetch (REGION WIDTH) of REGION)
+                         (fetch (REGION HEIGHT) of REGION)
+                         OPERATION])
+
+(INVERTW
+  [LAMBDA (WIN SHADE)                                        (* rrb "18-May-84 21:52")
+
+    (* ;; "inverts a window and returns the window.  Used in RESETFORMS.")
+
+    (DSPFILL (DSPCLIPPINGREGION NIL WIN)
+           (OR SHADE BLACKSHADE)
+           'INVERT WIN)
+    WIN])
+)
+(DEFINEQ
+
+(\DSPCOLOR.DISPLAY
+  [LAMBDA (STREAM COLOR)                                     (* ; 
+                                                           "Edited 29-Jan-91 11:33 by matsuda")
+
+    (* ;; "sets and returns a display stream's background color.")
+
+    (PROG (DD COLORCELL DESTINATION BITSPERPIXEL)
+          (SETQ DD (\GETDISPLAYDATA STREAM))
+          (SETQ COLORCELL (fetch (\DISPLAYDATA DDCOLOR) of DD))
+          (SETQ DESTINATION (fetch (\DISPLAYDATA DDDestination) of DD))
+          (SETQ BITSPERPIXEL (BITSPERPIXEL DESTINATION))
+          (RETURN (COND
+                     (COLOR (SETQ COLOR (COLORNUMBERP COLOR BITSPERPIXEL))
+                            (PROG1 (COND
+                                      (COLORCELL (PROG1 (CAR COLORCELL)
+                                                        (RPLACA COLORCELL COLOR)))
+                                      (T                     (* ; "no color cell yet, make one.")
+                                         (replace (\DISPLAYDATA DDCOLOR) of DD
+                                            with (CONS COLOR 0))
+                                         (MAXIMUMCOLOR BITSPERPIXEL)))
+                                   (\SFFixFont STREAM DD)))
+                     (T (OR (CAR COLORCELL)
+                            (MAXIMUMCOLOR BITSPERPIXEL])
+
+(\DSPBACKCOLOR.DISPLAY
+  [LAMBDA (STREAM COLOR)                                     (* kbr%: "25-Aug-85 18:15")
+
+    (* ;; "sets and returns a display stream's foreground color.")
+
+    (PROG (DD COLORCELL DESTINATION BITSPERPIXEL)
+          (SETQ DD (\GETDISPLAYDATA STREAM))
+          (SETQ COLORCELL (fetch (\DISPLAYDATA DDCOLOR) of DD))
+          (RETURN (COND
+                     (COLOR (SETQ DESTINATION (fetch (\DISPLAYDATA DDDestination) of DD))
+                            (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of 
+                                                                                          DESTINATION
+                                                      ))
+                            (SETQ COLOR (COLORNUMBERP COLOR BITSPERPIXEL))
+                            (PROG1 (COND
+                                      (COLORCELL (PROG1 (CDR COLORCELL)
+                                                        (RPLACD COLORCELL COLOR)))
+                                      (T                     (* ; "no color cell yet, make one.")
+                                         (replace (\DISPLAYDATA DDCOLOR) of DD
+                                            with (CONS (MAXIMUMCOLOR BITSPERPIXEL)
+                                                           COLOR))
+                                         0))
+                                   (\SFFixFont STREAM DD)))
+                     (T (OR (CDR COLORCELL)
+                            0])
+
+(DSPEOLFN
+  [LAMBDA (EOLFN DISPLAYSTREAM)                              (* rrb "18-May-84 21:44")
+
+    (* ;; "sets the end of line function for a displaystream.  EOLFN will be called every EOL with the argument of the display stream.  If EOLFN is 'OFF, the eolfn is cleared.")
+
+    (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM)))
+          (RETURN (PROG1 (COND
+                            ((fetch (\DISPLAYDATA DDEOLFN) of DD))
+                            (T 'OFF))
+                      [AND EOLFN (COND
+                                    [(LITATOM EOLFN)
+                                     (replace (\DISPLAYDATA DDEOLFN) of DD
+                                        with (COND
+                                                    ((EQ EOLFN 'OFF)
+                                                     NIL)
+                                                    (T EOLFN]
+                                    (T (\ILLEGAL.ARG EOLFN])])
+)
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ BLACKSHADE 65535)
+
+(RPAQQ WHITESHADE 0)
+
+
+(CONSTANTS (BLACKSHADE 65535)
+       (WHITESHADE 0))
+)
+
+(RPAQQ GRAYSHADE 43605)
+
+(ADDTOVAR GLOBALVARS GRAYSHADE)
+
+(* "END EXPORTED DEFINITIONS")
+
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS DSPRUBOUTCHAR MACRO ((DS CHAR X Y TTBL)
+                                       (\DSPMOVELR DS CHAR X Y TTBL NIL T)))
+)
+(DEFINEQ
+
+(DSPCLEOL
+  [LAMBDA (DISPLAYSTREAM XPOS YPOS HEIGHT)                   (* lmm " 3-May-84 10:31")
+    (\CHECKCARET DISPLAYSTREAM)
+    (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM DISPLAYSTREAM)))
+          (RETURN (BITBLT NIL NIL NIL DISPLAYSTREAM (OR (FIXP XPOS)
+                                                        (SETQ XPOS (ffetch DDLeftMargin
+                                                                      of DD)))
+                         [OR (FIXP YPOS)
+                             (IDIFFERENCE (ffetch DDYPOSITION of DD)
+                                    (FONTPROP DISPLAYSTREAM 'DESCENT]
+                         (IMAX 0 (IDIFFERENCE (ffetch DDRightMargin of DD)
+                                        XPOS))
+                         (OR (FIXP HEIGHT)
+                             (IMINUS (ffetch DDLINEFEED of DD)))
+                         'TEXTURE
+                         'REPLACE])
+
+(DSPRUBOUTCHAR
+  [LAMBDA (STREAM CHAR X Y TTBL)                             (* Pavel " 6-Oct-86 22:44")
+    (if (DISPLAYSTREAMP CHAR)
+        then 
+
+              (* ;; "Some older code may use the CHAR argument first.")
+
+              (swap STREAM CHAR)
+              (SETQ TTBL X)
+              (SETQ X)
+              (SETQ Y))
+    (\GETDISPLAYDATA STREAM STREAM)
+    (\DSPMOVELR STREAM CHAR X Y TTBL NIL T])
+
+(\DSPMOVELR
+  [LAMBDA (DS CHAR X Y TTBL RIGHTWARDSFLG ERASEFLG)          (* JonL " 7-May-84 02:47")
+
+    (* ;; "Moves the cursor 'leftwards' (or 'rightwards' if RIGHTWARDSFLG is non-null) over any main character and control or meta indicators.  Returns NIL if the move can't be determined, such as trying to move left when already at the left margin.  Effaces (or 'Rubs out') any bits moved over if ERASEFLG is non-null.")
+
+    ([LAMBDA (DD)
+
+       (* ;; 
+     "Must do the \GETDISPLAYDATA first, since it may reset DS when it coerces to a DISPLAYSTREAM")
+
+       (PROG [(WIDTH (\STREAMCHARWIDTH (COND
+                                          ((CHARCODEP CHAR)
+                                           CHAR)
+                                          (T (CHARCODE M)))
+                            DS TTBL))
+              (DEFAULTPOS? (AND (NULL X)
+                                (NULL Y]
+             (OR ERASEFLG DEFAULTPOS? (SHOULDNT))            (* ; 
+    "CURSORLEFT and CURSORRIGHT commands aren't allowed to start from anywhere except current spot")
+
+        (* ;; "Note that if CHAR is not specified and DS has a variable-pitch font, then the results may be somewhat random.  Smart terminal drivers thus can work well only on fixed-pitch fonts.")
+
+             (COND
+                ((NULL WIDTH)
+                 (RETURN))
+                ((EQ 0 WIDTH)                                (* ; "Ha, what an easy case")
+                 (RETURN T)))
+             (OR (FIXP X)
+                 (SETQ X (ffetch DDXPOSITION of DD)))
+             (OR (FIXP Y)
+                 (SETQ Y (ffetch DDYPOSITION of DD)))
+             (COND
+                ([COND
+                    (RIGHTWARDSFLG (IGREATERP (add X WIDTH)
+                                          (ffetch DDRightMargin of DD)))
+                    (T (ILESSP (add X (IMINUS WIDTH))
+                              (ffetch DDLeftMargin of DD]
+                                                             (* ; 
+                              "If we can't do the full backup, then return NIL to signal this fact")
+                 (RETURN)))
+             (\CHECKCARET DS)                                (* ; 
+                        "Take down the caret, if there is one, just in case we are moving over it.")
+             [COND
+                (ERASEFLG                                    (* ; "And do the erasure if requested")
+                       ([LAMBDA (FONT)
+                          (PROG ((YPRIME (IDIFFERENCE Y (FONTDESCENT FONT)))
+                                 (HEIGHT (FONTHEIGHT FONT)))
+                                (COND
+                                   ((NOT DEFAULTPOS?)
+                                    (MOVETO X Y DS)          (* ; 
+                                                       "Backup over the bits, and 'wipe' them out.")
+                                    ))
+                                (BITBLT NIL 0 0 DS X YPRIME WIDTH HEIGHT 'TEXTURE 'REPLACE)
+                                                             (* ; "wipe out some bits")
+                            ]
+                        (ffetch DDFONT of DD]
+             (DSPXPOSITION X DS)                             (* ; "Now do the move.")
+             (RETURN T]
+     (\GETDISPLAYDATA DS DS])
+)
+
+
+
+(* ; "for cursor")
+
+
+(RPAQQ \DefaultCursor #*(16 16)H@@@L@@@N@@@O@@@OH@@OL@@ON@@O@@@MH@@IH@@@L@@@L@@@F@@@F@@@C@@@C@@)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(RPAQ? DEFAULTCURSOR (CURSORCREATE \DefaultCursor NIL 0 15))
+
+
+(COND
+   ((NULL \CURRENTCURSOR)
+    (SETQ \CURRENTCURSOR DEFAULTCURSOR)))
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS DEFAULTCURSOR)
+)
+)
+
+
+
+(* ; "stuff to interpret colors as textures which is needed even in system that don't have color.")
+
+(DEFINEQ
+
+(TEXTUREOFCOLOR
+  [LAMBDA (COLOR NOERRORFLG)                                 (* rrb "30-Oct-85 19:43")
+
+    (* ;; "returns a texture to represent a color on a black and white display")
+
+    (PROG ((RGB (INSURE.RGB.COLOR COLOR NOERRORFLG)))
+          (RETURN (COND
+                     ((NULL RGB)
+                      NIL)
+                     ((AND (IGREATERP (fetch (RGB RED) of RGB)
+                                  245)
+                           (IGREATERP (fetch (RGB GREEN) of RGB)
+                                  245)
+                           (IGREATERP (fetch (RGB BLUE) of RGB)
+                                  245))                      (* ; "special case white")
+                      BLACKSHADE16)
+                     (T (PROG [(TEX (\PRIMARYTEXTURE 'RED (fetch (RGB RED) of RGB]
+                              (BITBLT NIL NIL NIL TEX 0 0 16 16 'TEXTURE 'PAINT
+                                     (\PRIMARYTEXTURE 'BLUE (fetch (RGB BLUE) of RGB)))
+                              (BITBLT NIL NIL NIL TEX 0 0 16 16 'TEXTURE 'PAINT
+                                     (\PRIMARYTEXTURE 'GREEN (fetch (RGB GREEN) of RGB)))
+                              (RETURN TEX])
+
+(\PRIMARYTEXTURE
+  [LAMBDA (PRIMARY LEVEL)                                    (* rrb "30-Oct-85 19:25")
+
+    (* ;; "returns the 16x16 texture for a primary color level.")
+
+    (PROG [(TEXTURE (BITMAPCOPY (SELECTQ PRIMARY
+                                    (RED REDTEXTURE)
+                                    (BLUE BLUETEXTURE)
+                                    (GREEN GREENTEXTURE)
+                                    (\ILLEGAL.ARG PRIMARY]
+          (BITBLT (\LEVELTEXTURE LEVEL)
+                 0 0 TEXTURE 0 0 16 16 'INPUT 'ERASE)
+          (RETURN TEXTURE])
+
+(\LEVELTEXTURE
+  [LAMBDA (LEVEL)                                            (* rrb "20-Aug-85 16:42")
+
+    (* ;; "returns a 16x16 texture which is merged so that only light bits on both go to light with a primary color pattern to get a level primary pattern.")
+
+    (COND
+       ((ILESSP LEVEL 100)
+        BLACKSHADE16)
+       ((ILESSP LEVEL 150)
+        DARKGRAY16)
+       ((ILESSP LEVEL 200)
+        MEDIUMGRAY16)
+       ((ILESSP LEVEL 245)
+        LIGHTGRAY16)
+       (T WHITESHADE16])
+
+(INSURE.B&W.TEXTURE
+  [LAMBDA (TEXTURE NOERRORFLG)                               (* rrb "30-Oct-85 19:47")
+
+    (* ;; "coerces a TEXTURE argument to a 1 bit per pixel bitmap or small number")
+
+    (SELECTQ (TYPENAME TEXTURE)
+        (LITATOM                                             (* ; "includes NIL case")
+                 (COND
+                    (TEXTURE                                 (* ; "should be a color name")
+                           (TEXTUREOFCOLOR (INSURE.RGB.COLOR TEXTURE NOERRORFLG)))
+                    (T WHITESHADE)))
+        ((SMALLP FIXP) 
+             (LOGAND TEXTURE BLACKSHADE))
+        (BITMAP TEXTURE)
+        (LISTP                                               (* ; 
+                                 "can be a list of (TEXTURE COLOR) or a list of levels rgb or hls.")
+               (COND
+                  ((TEXTUREOFCOLOR TEXTURE T))
+                  ((CAR TEXTURE)
+                   (INSURE.B&W.TEXTURE (CAR TEXTURE)
+                          NOERRORFLG))
+                  ((CAR (LISTP (CDR TEXTURE)))
+                   (TEXTUREOFCOLOR (CADR TEXTURE)
+                          NOERRORFLG))
+                  (T                                         (* ; "list of form (NIL NIL)")
+                     WHITESHADE)))
+        (COND
+           ((NULL NOERRORFLG)
+            (\ILLEGAL.ARG TEXTURE])
+
+(INSURE.RGB.COLOR
+  [LAMBDA (COLOR NOERRFLG)                                   (* rrb "30-Oct-85 19:34")
+                                                             (* ; 
+                                                           "returns the RGB triple for a color.")
+    (PROG (LEVELS)
+          (RETURN (COND
+                     [(FIXP COLOR)                           (* ; 
+                                                "don't know what to do with color numbers so error")
+                      (COND
+                         (NOERRFLG NIL)
+                         (T (\ILLEGAL.ARG COLOR]
+                     [(LITATOM COLOR)
+                      (COND
+                         ((SETQ LEVELS (\LOOKUPCOLORNAME COLOR))
+                                                             (* ; 
+                                                           "recursively look up color number")
+                          (INSURE.RGB.COLOR (CDR LEVELS)
+                                 NOERRFLG))
+                         (NOERRFLG NIL)
+                         (T (ERROR "Unknown color name" COLOR]
+                     ((HLSP COLOR)                       (* ; "HLS form convert to RGB")
+                      (HLSTORGB COLOR))
+                     ((RGBP COLOR)                       (* ; "check for RGB or HLS")
+                      COLOR)
+                     (NOERRFLG NIL)
+                     (T (\ILLEGAL.ARG COLOR])
+
+(\LOOKUPCOLORNAME
+  [LAMBDA (COLORNAME)                                        (* rrb "13-DEC-82 13:14")
+
+    (* ;; "looks up a prospective color name.  Returns a list whose CAR is the name and whose CDR is a color spec.")
+
+    (FASSOC COLORNAME COLORNAMES])
+
+(RGBP
+  [LAMBDA (X)                                                (* rrb "27-OCT-82 10:15")
+                                                             (* ; 
+                                                       "return X if it is a red green blue triple.")
+    (PROG (TMP)
+          (RETURN (AND (LISTP X)
+                       (SMALLP (SETQ TMP (CAR X)))
+                       (IGREATERP TMP -1)
+                       (IGREATERP 256 TMP)
+                       (SMALLP (SETQ TMP (CADR X)))
+                       (IGREATERP TMP -1)
+                       (IGREATERP 256 TMP)
+                       (SMALLP (SETQ TMP (CADDR X)))
+                       (IGREATERP TMP -1)
+                       (IGREATERP 256 TMP)
+                       X])
+
+(HLSP
+  [LAMBDA (X)                                                (* rrb "31-Oct-85 10:51")
+
+    (* ;; "return T if X is a hue lightness saturation triple.")
+
+    (AND (NUMBERP (CAR (LISTP X)))
+         (IGREATERP (CAR X)
+                -1)
+         (IGREATERP 361 (CAR X))
+         [FLOATP (CAR (LISTP (CDR X]
+         [FLOATP (CAR (LISTP (CDDR X]
+         X])
+
+(HLSTORGB
+  [LAMBDA (HLS)                                              (* rrb "30-Oct-85 19:59")
+
+    (* ;; "converts from a hue saturation lightness triple into red green blue triple.  HUE is in range 0 to 360, lightness and saturation are in the range 0 to 1.0")
+
+    (* ;; "this algorithm was taken from siggraph vol 13 number 3 August 1979: Status report on graphics standards planning committee.")
+
+    (PROG ((H (fetch (HLS HUE) of HLS))
+           (L (fetch (HLS LIGHTNESS) of HLS))
+           (S (fetch (HLS SATURATION) of HLS))
+           Max Min)
+          [SETQ Max (COND
+                       ((FGREATERP 0.5 L)
+                        (FTIMES L (FPLUS 1.0 S)))
+                       (T (FDIFFERENCE (FPLUS L S)
+                                 (FTIMES L S]
+          (SETQ Min (FDIFFERENCE (FTIMES L 2)
+                           Max))
+          (RETURN (create RGB
+                         RED _ (\HLSVALUEFN Min Max H)
+                         GREEN _ (\HLSVALUEFN Min Max (IDIFFERENCE H 120))
+                         BLUE _ (\HLSVALUEFN Min Max (IDIFFERENCE H 240])
+
+(\HLSVALUEFN
+  [LAMBDA (MIN MAX HUE)                                      (* rrb "25-OCT-82 10:47")
+
+    (* ;; "internal value function for converting from HLS to RGB.")
+
+    [COND
+       ((ILESSP HUE 0)
+        (SETQ HUE (IPLUS HUE 360]
+    (FIX (FTIMES (COND
+                    ((ILESSP HUE 60)
+                     (FPLUS MIN (FQUOTIENT (FTIMES (FDIFFERENCE MAX MIN)
+                                                  HUE)
+                                       60)))
+                    ((ILESSP HUE 180)
+                     MAX)
+                    ((ILESSP HUE 240)
+                     (FPLUS MIN (FQUOTIENT (FTIMES (FDIFFERENCE MAX MIN)
+                                                  (FDIFFERENCE 240 HUE))
+                                       60)))
+                    (T MIN))
+                255])
+)
+
+(RPAQQ COLORNAMES
+       ((WHITE 255 255 255)
+        (CYAN 0 255 255)
+        (MAGENTA 255 0 255)
+        (YELLOW 255 255 0)
+        (RED 255 0 0)
+        (GREEN 0 255 0)
+        (BLUE 0 0 255)
+        (BLACK 0 0 0)))
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS COLORNAMES)
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE GREENTEXTURE 
+       BLUETEXTURE)
+)
+)
+
+(READVARS-FROM-STRINGS '(BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE 
+                               GREENTEXTURE BLUETEXTURE)
+       "({(READBITMAP)(16 16
+%"OOOO%"
+%"OOOO%"
+%"OOOO%"
+%"OOOO%"
+%"OOOO%"
+%"OOOO%"
+%"OOOO%"
+%"OOOO%"
+%"OOOO%"
+%"OOOO%"
+%"OOOO%"
+%"OOOO%"
+%"OOOO%"
+%"OOOO%"
+%"OOOO%"
+%"OOOO%")}  {(READBITMAP)(16 16
+%"NMGG%"
+%"KGMM%"
+%"MNKK%"
+%"GKNN%"
+%"MNKK%"
+%"GKNM%"
+%"NMGN%"
+%"KGMG%"
+%"NKKM%"
+%"KNNK%"
+%"GGMN%"
+%"MMGG%"
+%"GGKM%"
+%"MJOG%"
+%"NOEK%"
+%"KMNN%")}  {(READBITMAP)(16 16
+%"JJJJ%"
+%"EEEE%"
+%"JJJJ%"
+%"EEEE%"
+%"JJJJ%"
+%"EEEE%"
+%"JJJJ%"
+%"EEEE%"
+%"JJJJ%"
+%"EEEE%"
+%"JJJJ%"
+%"EEEE%"
+%"JJJJ%"
+%"EEEE%"
+%"JJJJ%"
+%"EEEE%")}  {(READBITMAP)(16 16
+%"HBDB%"
+%"BHAA%"
+%"DDHD%"
+%"AABH%"
+%"HHDA%"
+%"BBAD%"
+%"DDHB%"
+%"AABH%"
+%"HDAD%"
+%"AADA%"
+%"DHBH%"
+%"BBHB%"
+%"HHAD%"
+%"ABDA%"
+%"DDHH%"
+%"BABB%")}  {(READBITMAP)(16 16
+%"@@@@%"
+%"@@@@%"
+%"@@@@%"
+%"@@@@%"
+%"@@@@%"
+%"@@@@%"
+%"@@@@%"
+%"@@@@%"
+%"@@@@%"
+%"@@@@%"
+%"@@@@%"
+%"@@@@%"
+%"@@@@%"
+%"@@@@%"
+%"@@@@%"
+%"@@@@%")}  {(READBITMAP)(16 16
+%"LLLL%"
+%"LLLL%"
+%"LLLL%"
+%"LLLL%"
+%"LLLL%"
+%"LLLL%"
+%"LLLL%"
+%"LLLL%"
+%"LLLL%"
+%"LLLL%"
+%"LLLL%"
+%"LLLL%"
+%"LLLL%"
+%"LLLL%"
+%"LLLL%"
+%"LLLL%")}  {(READBITMAP)(16 16
+%"CLCL%"
+%"O@O@%"
+%"LCLC%"
+%"@O@O%"
+%"CLCL%"
+%"O@O@%"
+%"LCLC%"
+%"@O@O%"
+%"CLCL%"
+%"O@O@%"
+%"LCLC%"
+%"@O@O%"
+%"CLCL%"
+%"O@O@%"
+%"LCLC%"
+%"@O@O%")}  {(READBITMAP)(16 16
+%"LFGA%"
+%"NCCH%"
+%"GAIL%"
+%"CHLN%"
+%"ALFG%"
+%"HNCC%"
+%"LGAI%"
+%"NCHL%"
+%"GALF%"
+%"CHNC%"
+%"ILGA%"
+%"LNCH%"
+%"FGAL%"
+%"CCHN%"
+%"AILG%"
+%"HLNC%")})
+")
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
+
+(RECORD HLS (HUE LIGHTNESS SATURATION))
+
+(RECORD RGB (RED GREEN BLUE))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA UNIONREGIONS INTERSECTREGIONS)
+)
+(PUTPROPS ADISPLAY COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991
+ 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (11899 19952 (\BBTCURVEPT 11909 . 19950)) (19953 30234 (CREATETEXTUREFROMBITMAP 19963 . 
+21995) (PRINTBITMAP 21997 . 23326) (PRINT-BITMAPS-NICELY 23328 . 27486) (PRINTCURSOR 27488 . 28517) (
+\WRITEBITMAP 28519 . 30232)) (30277 32823 (\GETINTEGERPART 30287 . 31830) (\CONVERTTOFRACTION 31832 . 
+32821)) (32960 33846 (CURSORP 32970 . 33189) (CURSORBITMAP 33191 . 33237) (CreateCursorBitMap 33239 . 
+33844)) (38181 52055 (CARET 38191 . 39939) (\CARET.CREATE 39941 . 40119) (\CARET.DOWN 40121 . 41574) (
+\CARET.FLASH? 41576 . 43473) (\CARET.SHOW 43475 . 48243) (CARETRATE 48245 . 48903) (\CARET.FLASH.AGAIN
+ 48905 . 50180) (\CARET.FLASH.MULTIPLE 50182 . 50714) (\CARET.FLASH 50716 . 52053)) (52419 54250 (
+\AREAVISIBLE? 52429 . 53351) (\REGIONOVERLAPAREAP 53353 . 53896) (\AREAINREGIONP 53898 . 54248)) (
+54299 70356 (CREATEREGION 54309 . 54645) (REGIONP 54647 . 54793) (INTERSECTREGIONS 54795 . 58618) (
+UNIONREGIONS 58620 . 61820) (REGIONSINTERSECTP 61822 . 62430) (SUBREGIONP 62432 . 63077) (EXTENDREGION
+ 63079 . 66299) (EXTENDREGIONBOTTOM 66301 . 67106) (EXTENDREGIONLEFT 67108 . 67811) (EXTENDREGIONRIGHT
+ 67813 . 68450) (EXTENDREGIONTOP 68452 . 69078) (INSIDEP 69080 . 69848) (STRINGREGION 69850 . 70354)) 
+(70601 76990 (\BRUSHBITMAP 70611 . 72335) (\GETBRUSH 72337 . 72648) (\GETBRUSHBBT 72650 . 75413) (
+\InitCurveBrushes 75415 . 76854) (\BrushFromWidth 76856 . 76988)) (76991 80056 (\MAKEBRUSH.DIAGONAL 
+77001 . 77281) (\MAKEBRUSH.HORIZONTAL 77283 . 77677) (\MAKEBRUSH.VERTICAL 77679 . 77991) (
+\MAKEBRUSH.SQUARE 77993 . 78270) (\MAKEBRUSH.ROUND 78272 . 80054)) (80057 81169 (INSTALLBRUSH 80067 . 
+81167)) (81570 93930 (\DRAWLINE.DISPLAY 81580 . 92645) (RELMOVETO 92647 . 93034) (MOVETOUPPERLEFT 
+93036 . 93928)) (93931 117661 (\CLIPANDDRAWLINE 93941 . 100506) (\CLIPANDDRAWLINE1 100508 . 112374) (
+\CLIPCODE 112376 . 113750) (\LEASTPTAT 113752 . 114350) (\GREATESTPTAT 114352 . 114980) (\DRAWLINE1 
+114982 . 116102) (\DRAWLINE.UFN 116104 . 117659)) (123819 170802 (\DRAWCIRCLE.DISPLAY 123829 . 132693)
+ (\DRAWARC.DISPLAY 132695 . 132985) (\DRAWARC.GENERIC 132987 . 133802) (\COMPUTE.ARC.POINTS 133804 . 
+136305) (\DRAWELLIPSE.DISPLAY 136307 . 151968) (\DRAWCURVE.DISPLAY 151970 . 154339) (
+\DRAWPOINT.DISPLAY 154341 . 155426) (\DRAWPOLYGON.DISPLAY 155428 . 159370) (\LINEWITHBRUSH 159372 . 
+170800)) (170803 204029 (LOADPOLY 170813 . 171373) (PARAMETRICSPLINE 171375 . 181644) (\CURVE 181646
+ . 188186) (\CURVE2 188188 . 200012) (\CURVEEND 200014 . 200512) (\CURVESLOPE 200514 . 203012) (
+\CURVESTART 203014 . 203338) (\FDIFS/FROM/DERIVS 203340 . 204027)) (214351 229503 (\FILLCIRCLE.DISPLAY
+ 214361 . 225559) (\LINEBLT 225561 . 229501)) (229547 231477 (SCREENBITMAP 229557 . 230030) (BITMAPP 
+230032 . 230266) (BITMAPHEIGHT 230268 . 230644) (BITSPERPIXEL 230646 . 231475)) (232118 233111 (
+DSPFILL 232128 . 232811) (INVERTW 232813 . 233109)) (233112 236979 (\DSPCOLOR.DISPLAY 233122 . 234481)
+ (\DSPBACKCOLOR.DISPLAY 234483 . 236012) (DSPEOLFN 236014 . 236977)) (237420 242198 (DSPCLEOL 237430
+ . 238376) (DSPRUBOUTCHAR 238378 . 238816) (\DSPMOVELR 238818 . 242196)) (242701 251323 (
+TEXTUREOFCOLOR 242711 . 243973) (\PRIMARYTEXTURE 243975 . 244557) (\LEVELTEXTURE 244559 . 245060) (
+INSURE.B&W.TEXTURE 245062 . 246455) (INSURE.RGB.COLOR 246457 . 247937) (\LOOKUPCOLORNAME 247939 . 
+248209) (RGBP 248211 . 248974) (HLSP 248976 . 249351) (HLSTORGB 249353 . 250493) (\HLSVALUEFN 250495
+ . 251321)))))
+STOP
diff --git a/CLTL2/ADISPLAY.LCOM b/CLTL2/ADISPLAY.LCOM
new file mode 100644
index 00000000..9429a0fc
Binary files /dev/null and b/CLTL2/ADISPLAY.LCOM differ
diff --git a/CLTL2/ADVISE b/CLTL2/ADVISE
new file mode 100644
index 00000000..27f739e9
--- /dev/null
+++ b/CLTL2/ADVISE
@@ -0,0 +1,269 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "SYSTEM")
+(IL:FILECREATED " 6-Jan-92 15:12:26" IL:|{DSK}<usr>local>lde>lispcore>sources>ADVISE.;2| 31117  
+
+      IL:|changes| IL:|to:|  (IL:FUNCTIONS XCL:ADVISE-FUNCTION XCL:UNADVISE-FUNCTION XCL:READVISE-FUNCTION FINISH-ADVISING)
+
+      IL:|previous| IL:|date:| "16-May-90 11:55:52" IL:|{DSK}<usr>local>lde>lispcore>sources>ADVISE.;1|
+)
+
+
+; Copyright (c) 1978, 1984, 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+; The following program was created in 1978 but has not been published
+; within the meaning of the copyright law, is furnished under license,
+; and may not be used, copied and/or disclosed except in accordance
+; with the terms of said license.
+
+(IL:PRETTYCOMPRINT IL:ADVISECOMS)
+
+(IL:RPAQQ IL:ADVISECOMS ((IL:STRUCTURES ADVICE) (IL:VARIABLES IL:ADVISEDFNS *UNADVISED-FNS*) (IL:* IL:|;;| "") (IL:* IL:|;;| "Interlisp entry points.") (IL:FNS IL:ADVISE IL:UNADVISE IL:READVISE) (IL:PROP IL:ARGNAMES IL:ADVISE) (IL:* IL:|;;| "") (IL:* IL:|;;| "XCL entry points.") (IL:FUNCTIONS XCL:ADVISE-FUNCTION XCL:UNADVISE-FUNCTION XCL:READVISE-FUNCTION) (IL:FUNCTIONS UNADVISE-FROM-RESTORE-CALLS FINISH-ADVISING FINISH-UNADVISING) (IL:* IL:|;;| "") (IL:* IL:|;;| "The advice database.") (IL:VARIABLES *ADVICE-HASH-TABLE*) (IL:FUNCTIONS ADD-ADVICE DELETE-ADVICE GET-ADVICE-MIDDLE-MAN SET-ADVICE-MIDDLE-MAN INSERT-ADVICE-FORM) (IL:SETFS GET-ADVICE-MIDDLE-MAN) (IL:* IL:|;;| "") (IL:* IL:|;;| "Hacking the actual advice forms.") (IL:FUNCTIONS CREATE-ADVISED-DEFINITION MAKE-AROUND-BODY) (IL:* IL:|;;| "") (IL:* IL:|;;| "Dealing with the File Manager") (IL:FILEPKGCOMS IL:ADVICE IL:ADVISE) (IL:FUNCTIONS XCL:REINSTALL-ADVICE) (IL:FUNCTIONS ADVICE-GETDEF ADVICE-PUTDEF ADVICE-DELDEF ADVICE-HASDEF ADVICE-NEWCOM ADVICE-FILE-DEFINITIONS ADVISE-CONTENTS ADVICE-ADDTOCOM) (IL:PROP IL:PROPTYPE IL:ADVISED) (IL:* IL:|;;| "") (IL:* IL:|;;| "Dealing with old-style advice") (IL:FUNCTIONS IL:READVISE1 ADD-OLD-STYLE-ADVICE CANONICALIZE-ADVICE-SYMBOL CANONICALIZE-ADVICE-WHEN-SPEC CANONICALIZE-ADVICE-WHERE-SPEC) (IL:DEFINE-TYPES XCL:ADVISED-FUNCTIONS) (IL:FUNCTIONS XCL:DEFADVICE) (IL:* IL:|;;| "Arrange for the proper package.  Because of the DEFSTRUCT above, we must have the file dumped in the SYSTEM package.") (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:ADVISE) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA IL:READVISE IL:UNADVISE) (IL:NLAML) (IL:LAMA IL:ADVISE)))))
+
+(DEFSTRUCT (ADVICE (:TYPE LIST)) BEFORE AFTER AROUND)
+
+(DEFVAR IL:ADVISEDFNS NIL)
+
+(DEFVAR *UNADVISED-FNS* NIL)
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;| "Interlisp entry points.")
+
+(IL:DEFINEQ
+
+(il:advise
+  (il:lambda il:args                                  (il:* il:\; "Edited  6-Apr-87 18:00 by Pavel")
+
+(il:* il:|;;;| "ADVISE the FN given.  ADVISE1 is for advice of the type (foo IN bar)")
+
+    (let (il:fn il:when il:where il:what)
+          
+          (il:* il:|;;| "First we straighten out the arguments given to us")
+
+         (il:setq il:fn (il:arg il:args 1))
+         (case il:args (2 (il:setq il:what (il:arg il:args 2)))
+               (3 (il:setq il:when (il:arg il:args 2))
+                  (il:setq il:what (il:arg il:args 3)))
+               (4 (il:setq il:when (il:arg il:args 2))
+                  (il:setq il:where (il:arg il:args 3))
+                  (il:setq il:what (il:arg il:args 4)))
+               (t (il:if (< il:args 2)
+                      il:then (error 'il:too-few-arguments :callee 'il:advise :actual il:args 
+                                     :minimum 2)
+                    il:else (error 'il:too-many-arguments :callee 'il:advise :actual il:args :maximum 
+                                   4))))
+         (il:setq il:when (canonicalize-advice-when-spec il:when))
+         (il:setq il:where (canonicalize-advice-where-spec il:where))
+         (il:if (il:nlistp il:fn)
+             il:then (xcl:advise-function il:fn il:what :when il:when :priority il:where)
+           il:elseif (il:string.equal (cadr il:fn)
+                            "IN")
+             il:then (xcl:advise-function (first il:fn)
+                            il:what :in (third il:fn)
+                            :when il:when :priority il:where)
+           il:else (il:for il:x il:in il:fn
+                      il:join (il:if (il:nlistp il:x)
+                                  il:then (xcl:advise-function il:x il:what :when il:when :priority 
+                                                 il:where)
+                                il:else (xcl:advise-function (first il:x)
+                                               il:what :in (third il:x)
+                                               :when il:when :priority il:where)))))))
+
+(il:unadvise
+  (il:nlambda il:fns                                  (il:* il:\; "Edited  6-Apr-87 16:21 by Pavel")
+    (il:setq il:fns (il:nlambda.args il:fns))
+    (flet ((il:unadvise-entry (il:entry)
+                  (il:if (il:listp il:entry)
+                      il:then (xcl::unadvise-function (first il:entry)
+                                     :in
+                                     (third il:entry))
+                    il:else (xcl::unadvise-function il:entry))))
+          (cond
+             ((null il:fns)
+              (il:for il:entry il:in (il:reverse il:advisedfns) il:join (il:unadvise-entry il:entry))
+              )
+             ((il:equal il:fns '(t))
+              (and (not (null il:advisedfns))
+                   (il:unadvise-entry (car il:advisedfns))))
+             (t (il:for il:entry il:in il:fns il:join (il:unadvise-entry il:entry)))))))
+
+(il:readvise
+  (il:nlambda il:fns                                  (il:* il:\; "Edited  6-Apr-87 16:52 by Pavel")
+    (il:setq il:fns (il:nlambda.args il:fns))
+    (flet ((il:readvise-entry (il:entry)
+                  (il:if (il:listp il:entry)
+                      il:then (xcl::readvise-function (first il:entry)
+                                     :in
+                                     (third il:entry))
+                    il:else (xcl::readvise-function il:entry))))
+          (cond
+             ((null il:fns)                                  (il:* il:\; 
+                                                             "readvise them all, in reverse order.")
+              (il:for il:entry il:in (il:reverse *unadvised-fns*) il:join (il:readvise-entry il:entry
+                                                                                 )))
+             ((il:equal il:fns '(t))                         (il:* il:\; 
+                                        "simple case, readvise just the last one that was unadvised.")
+              (and (not (null *unadvised-fns*))
+                   (il:readvise-entry (car *unadvised-fns*))))
+             (t                                              (il:* il:\; "they gave us some functions, so readvise THEM.  We can't use READVISE-ENTRY here, because we may have to deal with old-style advice.")
+                (il:for il:entry il:in il:fns il:join (il:readvise1 il:entry)))))))
+)
+
+(IL:PUTPROPS IL:ADVISE IL:ARGNAMES (IL:WHO IL:WHEN IL:WHERE IL:WHAT))
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;| "XCL entry points.")
+
+
+(DEFUN XCL:ADVISE-FUNCTION (XCL::FN-TO-ADVISE XCL::FORM &KEY ((:IN XCL::IN-FN)) (WHEN :BEFORE) (XCL::PRIORITY :LAST)) (MULTIPLE-VALUE-BIND (XCL::EXECUTABLE-TO-ADVISE XCL::NO-IN-FN) (XCL::NAME-OF-EXECUTABLE XCL::FN-TO-ADVISE) (COND ((AND (CONSP XCL::FN-TO-ADVISE) (NOT XCL::EXECUTABLE-TO-ADVISE)) (IL:FOR XCL::FN IL:IN XCL::FN-TO-ADVISE IL:JOIN (XCL:ADVISE-FUNCTION XCL::FN XCL::FORM :IN XCL::IN-FN :WHEN WHEN :PRIORITY XCL::PRIORITY))) ((AND (CONSP XCL::IN-FN) (NOT (XCL::NAME-OF-EXECUTABLE XCL::IN-FN))) (IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:ADVISE-FUNCTION XCL::FN-TO-ADVISE XCL::FORM :IN XCL::FN :WHEN WHEN :PRIORITY XCL::PRIORITY))) (T (LET (XCL::EXECUTABLE-TO-ADVISE-IN) (COND ((NULL XCL::FORM) (FORMAT *ERROR-OUTPUT* "No advice given, so nothing done.") NIL) ((IL:UNSAFE.TO.MODIFY XCL::FN-TO-ADVISE "advise") (FORMAT *ERROR-OUTPUT* "~S not advised.~%" XCL::FN-TO-ADVISE) NIL) (T (COND (XCL::IN-FN (SETQ XCL::EXECUTABLE-TO-ADVISE-IN (XCL::NAME-OF-EXECUTABLE XCL::IN-FN)) (IF (NOT (HAS-CALLS XCL::EXECUTABLE-TO-ADVISE-IN XCL::EXECUTABLE-TO-ADVISE)) (ERROR "~S is not called from ~S." XCL::FN-TO-ADVISE XCL::IN-FN))) (T (IF (NULL (IL:GETD XCL::EXECUTABLE-TO-ADVISE)) (ERROR (QUOTE XCL:UNDEFINED-FUNCTION) :NAME XCL::FN-TO-ADVISE)))) (XCL:UNBREAK-FUNCTION XCL::FN-TO-ADVISE :IN XCL::IN-FN :NO-ERROR T) (COND ((NULL XCL::IN-FN) (IL:* IL:|;;| "Adjust the database of advice for this function.") (WHEN (NOT (MEMBER XCL::FN-TO-ADVISE IL:ADVISEDFNS :TEST (QUOTE EQ))) (IL:* IL:\; "If FN-TO-ADVISE is not currently advised, the new advice replaces any that may have been given before.") (DELETE-ADVICE XCL::FN-TO-ADVISE)) (ADD-ADVICE XCL::FN-TO-ADVISE WHEN XCL::PRIORITY XCL::FORM) (IL:* IL:|;;| "Finish off the process.  This part is shared with READVISE-FUNCTION.") (FINISH-ADVISING XCL::FN-TO-ADVISE XCL::EXECUTABLE-TO-ADVISE)) (T (LET* ((XCL::ADVICE-NAME (IL:BQUOTE ((IL:\\\, XCL::FN-TO-ADVISE) :IN (IL:\\\, XCL::IN-FN)))) (XCL::ALREADY-ADVISED? (MEMBER XCL::ADVICE-NAME IL:ADVISEDFNS :TEST (QUOTE EQUAL)))) (IL:* IL:|;;| "Adjust the database of advice for this request.") (WHEN (NOT XCL::ALREADY-ADVISED?) (IL:* IL:\; "If not currently advised, the new advice replaces any that may have been given before.") (DELETE-ADVICE XCL::ADVICE-NAME)) (ADD-ADVICE XCL::ADVICE-NAME WHEN XCL::PRIORITY XCL::FORM) (IL:* IL:|;;| "Finish off the process.  This part is shared with READVISE-FUNCTION.") (FINISH-ADVISING XCL::FN-TO-ADVISE XCL::EXECUTABLE-TO-ADVISE XCL::IN-FN XCL::EXECUTABLE-TO-ADVISE-IN)))))))))))
+
+(DEFUN XCL:UNADVISE-FUNCTION (XCL::FN-TO-UNADVISE &KEY ((:IN XCL::IN-FN)) XCL::NO-ERROR) (MULTIPLE-VALUE-BIND (XCL::EXECUTABLE-TO-UNADVISE XCL::NO-IN-FN) (XCL::NAME-OF-EXECUTABLE XCL::FN-TO-UNADVISE) (COND ((AND (CONSP XCL::FN-TO-UNADVISE) (NOT XCL::EXECUTABLE-TO-UNADVISE)) (IL:FOR XCL::FN IL:IN XCL::FN-TO-UNADVISE IL:JOIN (XCL:UNADVISE-FUNCTION XCL::FN :IN XCL::IN-FN))) ((AND (CONSP XCL::IN-FN) (NOT (XCL::NAME-OF-EXECUTABLE XCL::IN-FN))) (IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:UNADVISE-FUNCTION XCL::FN-TO-UNADVISE :IN XCL::FN))) (T (XCL:UNBREAK-FUNCTION XCL::FN-TO-UNADVISE :IN XCL::IN-FN :NO-ERROR T) (IF (NULL XCL::IN-FN) (LET ((XCL::ORIGINAL (GET XCL::EXECUTABLE-TO-UNADVISE (QUOTE IL:ADVISED)))) (COND ((NULL XCL::ORIGINAL) (UNLESS XCL::NO-ERROR (FORMAT *ERROR-OUTPUT* "~S is not advised.~%" XCL::FN-TO-UNADVISE)) NIL) (T (IL:PUTD XCL::EXECUTABLE-TO-UNADVISE (IL:GETD XCL::ORIGINAL) T) (REMPROP XCL::EXECUTABLE-TO-UNADVISE (QUOTE IL:ADVISED)) (PUSH XCL::FN-TO-UNADVISE *UNADVISED-FNS*) (SETQ IL:ADVISEDFNS (DELETE XCL::FN-TO-UNADVISE IL:ADVISEDFNS :TEST (QUOTE EQUAL))) (LIST XCL::FN-TO-UNADVISE)))) (IF XCL::NO-IN-FN (ERROR "~S can't be selectively unadvised :IN ~S" XCL::FN-TO-UNADVISE XCL::IN-FN) (LET* ((XCL::EXECUTABLE-TO-UNADVISE-IN (XCL::NAME-OF-EXECUTABLE XCL::IN-FN)) (XCL::ADVICE-NAME (IL:BQUOTE ((IL:\\\, XCL::FN-TO-UNADVISE) :IN (IL:\\\, XCL::IN-FN)))) (XCL::MIDDLE-MAN (GET-ADVICE-MIDDLE-MAN XCL::ADVICE-NAME))) (COND ((NULL XCL::MIDDLE-MAN) (UNLESS XCL::NO-ERROR (FORMAT *ERROR-OUTPUT* "~S is not advised.~%" XCL::ADVICE-NAME)) NIL) (T (CHANGE-CALLS XCL::MIDDLE-MAN XCL::EXECUTABLE-TO-UNADVISE XCL::EXECUTABLE-TO-UNADVISE-IN) (FINISH-UNADVISING XCL::ADVICE-NAME XCL::MIDDLE-MAN) (LIST XCL::ADVICE-NAME))))))))))
+
+(DEFUN XCL:READVISE-FUNCTION (XCL::FN-TO-READVISE &KEY ((:IN XCL::IN-FN))) (MULTIPLE-VALUE-BIND (XCL::EXECUTABLE-TO-READVISE XCL::NO-IN-FN) (XCL::NAME-OF-EXECUTABLE XCL::FN-TO-READVISE) (COND ((AND (CONSP XCL::FN-TO-READVISE) (NOT XCL::EXECUTABLE-TO-READVISE)) (IL:FOR XCL::FN IL:IN XCL::FN-TO-READVISE IL:JOIN (XCL:READVISE-FUNCTION XCL::FN :IN XCL::IN-FN))) ((AND (CONSP XCL::IN-FN) (NOT (XCL::NAME-OF-EXECUTABLE XCL::IN-FN))) (IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:READVISE-FUNCTION XCL::FN-TO-READVISE :IN XCL::FN))) (T (XCL:UNADVISE-FUNCTION XCL::FN-TO-READVISE :IN XCL::IN-FN :NO-ERROR T) (IF XCL::IN-FN (FINISH-ADVISING XCL::FN-TO-READVISE XCL::EXECUTABLE-TO-READVISE XCL::IN-FN (XCL::NAME-OF-EXECUTABLE XCL::IN-FN)) (FINISH-ADVISING XCL::FN-TO-READVISE XCL::EXECUTABLE-TO-READVISE))))))
+
+(DEFUN UNADVISE-FROM-RESTORE-CALLS (FROM TO FN) (LET ((ENTRY (FIND-IF (FUNCTION (LAMBDA (ENTRY) (AND (CONSP ENTRY) (EQ (FIRST ENTRY) FROM) (EQ (THIRD ENTRY) FN)))) IL:ADVISEDFNS))) (ASSERT (NOT (NULL ENTRY)) NIL "BUG: Inconsistency in SI::UNADVISE-FROM-RESTORE-CALLS") (FINISH-UNADVISING ENTRY TO) (FORMAT *TERMINAL-IO* "~S unadvised.~%" ENTRY)))
+
+(DEFUN FINISH-ADVISING (FN-TO-ADVISE EXECUTABLE-TO-ADVISE &OPTIONAL IN-FN EXECUTABLE-TO-ADVISE-IN) (COND ((NULL IN-FN) (LET* ((ALREADY-ADVISED? (MEMBER FN-TO-ADVISE IL:ADVISEDFNS :TEST (QUOTE EQ))) (ORIGINAL (IF ALREADY-ADVISED? (GET EXECUTABLE-TO-ADVISE-IN (QUOTE IL:ADVISED)) (LET ((*PRINT-CASE* :UPCASE)) (MAKE-SYMBOL (FORMAT NIL "Original ~A" EXECUTABLE-TO-ADVISE)))))) (IL:* IL:|;;| "Adjust the database of advice for this function.") (WHEN (NOT ALREADY-ADVISED?) (IL:PUTD ORIGINAL (IL:GETD EXECUTABLE-TO-ADVISE) T)) (IL:PUTD EXECUTABLE-TO-ADVISE (COMPILE NIL (CREATE-ADVISED-DEFINITION EXECUTABLE-TO-ADVISE ORIGINAL FN-TO-ADVISE))) (WHEN (NOT ALREADY-ADVISED?) (SETF (GET EXECUTABLE-TO-ADVISE (QUOTE IL:ADVISED)) ORIGINAL)) (IL:* IL:|;;| "These are outside the WHEN because COMPILE calls VIRGINFN, which may unadvise the function.") (SETQ *UNADVISED-FNS* (DELETE FN-TO-ADVISE *UNADVISED-FNS* :TEST (QUOTE EQUAL))) (SETQ IL:ADVISEDFNS (IL:* IL:\; "Move FN-TO-ADVISE to the front of IL:ADVISEDFNS if there already, else just add to front.") (CONS FN-TO-ADVISE (DELETE FN-TO-ADVISE IL:ADVISEDFNS :TEST (QUOTE EQUAL)))) (IL:MARKASCHANGED FN-TO-ADVISE (QUOTE IL:ADVICE)) (LIST FN-TO-ADVISE))) (T (LET* ((ADVICE-NAME (IL:BQUOTE ((IL:\\\, FN-TO-ADVISE) :IN (IL:\\\, IN-FN)))) (ALREADY-ADVISED? (MEMBER ADVICE-NAME IL:ADVISEDFNS :TEST (QUOTE EQUAL))) MIDDLE-MAN) (IL:* IL:|;;| "Create a middle-man for this request.  If one has already been created, use it.") (SETQ MIDDLE-MAN (OR (GET-ADVICE-MIDDLE-MAN ADVICE-NAME) (SETF (GET-ADVICE-MIDDLE-MAN ADVICE-NAME) (CONSTRUCT-MIDDLE-MAN EXECUTABLE-TO-ADVISE EXECUTABLE-TO-ADVISE-IN)))) (IL:* IL:|;;| "Give the middle-man the new advised definition.") (IL:PUTD MIDDLE-MAN (COMPILE NIL (CREATE-ADVISED-DEFINITION EXECUTABLE-TO-ADVISE EXECUTABLE-TO-ADVISE ADVICE-NAME))) (WHEN (NOT ALREADY-ADVISED?) (IL:* IL:|;;| "Redirect any calls to FN-TO-ADVISE in IN-FN to call the middle-man.") (CHANGE-CALLS EXECUTABLE-TO-ADVISE MIDDLE-MAN EXECUTABLE-TO-ADVISE-IN (QUOTE UNADVISE-FROM-RESTORE-CALLS))) (IL:* IL:|;;| "Save a trail of information. These are outside the WHEN because COMPILE calls VIRGINFN, which may unadvise the function.") (SETQ *UNADVISED-FNS* (DELETE ADVICE-NAME *UNADVISED-FNS* :TEST (QUOTE EQUAL))) (SETQ IL:ADVISEDFNS (IL:* IL:\; "Move ADVICE-NAME to the front of IL:ADVISEDFNS if there already, else just add to front.") (CONS ADVICE-NAME (DELETE ADVICE-NAME IL:ADVISEDFNS :TEST (QUOTE EQUAL)))) (IL:MARKASCHANGED ADVICE-NAME (QUOTE IL:ADVICE)) (LIST ADVICE-NAME)))))
+
+(DEFUN FINISH-UNADVISING (ADVICE-NAME MIDDLE-MAN) (SETQ IL:ADVISEDFNS (DELETE ADVICE-NAME IL:ADVISEDFNS :TEST (QUOTE EQUAL))) (PUSH ADVICE-NAME *UNADVISED-FNS*))
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;| "The advice database.")
+
+
+(DEFVAR *ADVICE-HASH-TABLE* (MAKE-HASH-TABLE :TEST (QUOTE EQUAL)) (IL:* IL:|;;;| "Hash-table mapping either a function name or a list in the form (FOO :IN BAR) to a pair (advice . middle-man)."))
+
+(DEFUN ADD-ADVICE (NAME WHEN PRIORITY FORM) (IL:* IL:|;;;| "Advice is stored on the hash table SI::*ADVICE-HASH-TABLE*.  It is actually stored as a cons whose CAR is the advice and CDR is the middle-man name (for advice of the type (FOO :IN BAR)).") (LET* ((OLD-ADVICE (GETHASH NAME *ADVICE-HASH-TABLE*)) (ADVICE (IF (NULL OLD-ADVICE) (MAKE-ADVICE) (CAR OLD-ADVICE)))) (ECASE WHEN (:BEFORE (SETF (ADVICE-BEFORE ADVICE) (INSERT-ADVICE-FORM FORM PRIORITY (ADVICE-BEFORE ADVICE)))) (:AFTER (SETF (ADVICE-AFTER ADVICE) (INSERT-ADVICE-FORM FORM PRIORITY (ADVICE-AFTER ADVICE)))) (:AROUND (SETF (ADVICE-AROUND ADVICE) (INSERT-ADVICE-FORM FORM PRIORITY (ADVICE-AROUND ADVICE))))) (WHEN (NULL OLD-ADVICE) (SETF (GETHASH NAME *ADVICE-HASH-TABLE*) (CONS ADVICE NIL)))))
+
+(DEFUN DELETE-ADVICE (NAME) (REMHASH NAME *ADVICE-HASH-TABLE*))
+
+(DEFUN GET-ADVICE-MIDDLE-MAN (NAME) (CDR (GETHASH NAME *ADVICE-HASH-TABLE*)))
+
+(DEFUN SET-ADVICE-MIDDLE-MAN (NAME MIDDLE-MAN) (SETF (CDR (GETHASH NAME *ADVICE-HASH-TABLE*)) MIDDLE-MAN))
+
+(DEFUN INSERT-ADVICE-FORM (FORM PRIORITY ENTRY-LIST) (IL:* IL:|;;;| "Insert the new advice FORM into ENTRY-LIST using PRIORITY as a specification of where in that list to put it. If an equalish piece of advice already exists, remove it first.") (LET ((ENTRY (LIST PRIORITY FORM))) (SETF ENTRY-LIST (LABELS ((EQUALISH (X Y) (IL:* IL:|;;| "EQUALP, but don't ignore case in strings.") (TYPECASE X (SYMBOL (EQ X Y)) (CONS (AND (CONSP Y) (EQUALISH (CAR X) (CAR Y)) (EQUALISH (CDR X) (CDR Y)))) (NUMBER (AND (NUMBERP Y) (= X Y))) (CHARACTER (AND (CHARACTERP Y) (CHAR= X Y))) (STRING (AND (STRINGP Y) (STRING= X Y))) (PATHNAME (AND (PATHNAMEP Y) (IL:%PATHNAME-EQUAL X Y))) (VECTOR (AND (VECTORP Y) (LET ((SX (LENGTH X))) (AND (EQL SX (LENGTH Y)) (DOTIMES (I SX T) (IF (NOT (EQUALISH (AREF X I) (AREF Y I))) (RETURN NIL))))))) (ARRAY (AND (ARRAYP Y) (EQUAL (ARRAY-DIMENSIONS X) (ARRAY-DIMENSIONS Y)) (LET ((FX (IL:%FLATTEN-ARRAY X)) (FY (IL:%FLATTEN-ARRAY Y))) (DOTIMES (I (ARRAY-TOTAL-SIZE X) T) (IF (NOT (EQUALISH (AREF FX I) (AREF FY I))) (RETURN NIL)))))) (T (IL:* IL:|;;| "so that datatypes will be properly compared") (OR (EQ X Y) (LET ((TYPENAME (IL:TYPENAME X))) (AND (EQ TYPENAME (IL:TYPENAME Y)) (LET ((DESCRIPTORS (IL:GETDESCRIPTORS TYPENAME))) (IF DESCRIPTORS (IL:FOR FIELD IL:IN DESCRIPTORS IL:ALWAYS (EQUALISH (IL:FFETCHFIELD FIELD X) (IL:FFETCHFIELD FIELD Y)))))))))))) (DELETE-IF (FUNCTION (LAMBDA (OLD-ENTRY) (XCL:DESTRUCTURING-BIND (OLD-PRIORITY OLD-FORM) OLD-ENTRY (AND (EQUAL PRIORITY OLD-PRIORITY) (EQUALISH FORM OLD-FORM))))) ENTRY-LIST))) (COND ((NULL ENTRY-LIST) (LIST ENTRY)) ((EQ PRIORITY :FIRST) (CONS ENTRY ENTRY-LIST)) ((EQ PRIORITY :LAST) (NCONC ENTRY-LIST (LIST ENTRY))) (T (IL:* IL:\; "PRIORITY is a command to the old TTY Editor.") (UNLESS (AND (CONSP PRIORITY) (MEMBER (CAR PRIORITY) (QUOTE (IL:BEFORE IL:AFTER)))) (ERROR "Malformed priority argument to ADVISE: ~S" PRIORITY)) (XCL:CONDITION-CASE (IL:EDITE ENTRY-LIST (IL:BQUOTE ((IL:LC (IL:\\\,@ (CDR PRIORITY))) (IL:BELOW IL:^) ((IL:\\\, (CAR PRIORITY)) (IL:\\\, ENTRY))))) (ERROR (C) (ERROR "Error from EDITE during insertion of new advice:~%  ~A~%" C))) ENTRY-LIST))))
+
+(DEFSETF GET-ADVICE-MIDDLE-MAN SET-ADVICE-MIDDLE-MAN)
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;| "Hacking the actual advice forms.")
+
+
+(DEFUN CREATE-ADVISED-DEFINITION (ADVISED-FN FN-TO-CALL ADVICE-NAME) (MULTIPLE-VALUE-BIND (LAMBDA-CAR ARG-LIST CALLING-FORM) (FUNCTION-WRAPPER-INFO ADVISED-FN FN-TO-CALL) (LET* ((ADVICE (CAR (GETHASH ADVICE-NAME *ADVICE-HASH-TABLE*))) (BEFORE-FORMS (MAPCAR (QUOTE SECOND) (ADVICE-BEFORE ADVICE))) (AFTER-FORMS (MAPCAR (QUOTE SECOND) (ADVICE-AFTER ADVICE))) (AROUND-FORMS (MAPCAR (QUOTE SECOND) (ADVICE-AROUND ADVICE))) (BODY-FORM (MAKE-AROUND-BODY CALLING-FORM AROUND-FORMS))) (IL:BQUOTE ((IL:\\\, LAMBDA-CAR) (IL:\\\, (IF (EQ LAMBDA-CAR (QUOTE LAMBDA)) (QUOTE (&REST XCL:ARGLIST)) ARG-LIST)) (IL:\\\,@ (AND ARG-LIST (MEMBER LAMBDA-CAR (QUOTE (IL:LAMBDA IL:NLAMBDA))) (IL:BQUOTE ((DECLARE (SPECIAL (IL:\\\,@ (IF (SYMBOLP ARG-LIST) (LIST ARG-LIST) ARG-LIST)))))))) (IL:\\CALLME (QUOTE (:ADVISED (IL:\\\, ADVICE-NAME)))) (BLOCK NIL (XCL:DESTRUCTURING-BIND (IL:!VALUE . IL:!OTHER-VALUES) (MULTIPLE-VALUE-LIST (PROGN (IL:\\\,@ BEFORE-FORMS) (IL:\\\, BODY-FORM))) (IL:\\\,@ AFTER-FORMS) (APPLY (QUOTE VALUES) IL:!VALUE IL:!OTHER-VALUES))))))))
+
+(DEFUN MAKE-AROUND-BODY (CALLING-FORM AROUND-FORMS) (REDUCE (FUNCTION (LAMBDA (CURRENT-BODY NEXT-AROUND-FORM) (LET ((CANONICALIZED-AROUND-FORM (SUBST (QUOTE (XCL:INNER)) (QUOTE IL:*) NEXT-AROUND-FORM))) (IL:BQUOTE (MACROLET ((XCL:INNER NIL (QUOTE (IL:\\\, CURRENT-BODY)))) (IL:\\\, CANONICALIZED-AROUND-FORM)))))) AROUND-FORMS :INITIAL-VALUE CALLING-FORM))
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;| "Dealing with the File Manager")
+
+(IL:PUTDEF (QUOTE IL:ADVICE) (QUOTE IL:FILEPKGCOMS) (QUOTE ((IL:COM IL:MACRO (IL:X (IL:P IL:* (ADVICE-FILE-DEFINITIONS (QUOTE IL:X) NIL))) IL:CONTENTS IL:NILL IL:ADD ADVICE-ADDTOCOM) (TYPE IL:DESCRIPTION "advice" IL:NEWCOM ADVICE-NEWCOM IL:GETDEF ADVICE-GETDEF IL:DELDEF ADVICE-DELDEF IL:PUTDEF ADVICE-PUTDEF IL:HASDEF ADVICE-HASDEF)))
+)
+(IL:PUTDEF (QUOTE IL:ADVISE) (QUOTE IL:FILEPKGCOMS) (QUOTE ((IL:COM IL:MACRO (IL:X (IL:P IL:* (ADVICE-FILE-DEFINITIONS (QUOTE IL:X) T))) IL:CONTENTS ADVISE-CONTENTS IL:ADD ADVICE-ADDTOCOM)))
+)
+
+(DEFUN XCL:REINSTALL-ADVICE (XCL::NAME &KEY XCL::BEFORE XCL::AFTER XCL::AROUND) (IL:FOR XCL::ADVICE IL:IN XCL::BEFORE IL:DO (XCL:DESTRUCTURING-BIND (XCL::PRIORITY XCL::FORM) XCL::ADVICE (ADD-ADVICE XCL::NAME :BEFORE XCL::PRIORITY XCL::FORM))) (IL:FOR XCL::ADVICE IL:IN XCL::AFTER IL:DO (XCL:DESTRUCTURING-BIND (XCL::PRIORITY XCL::FORM) XCL::ADVICE (ADD-ADVICE XCL::NAME :AFTER XCL::PRIORITY XCL::FORM))) (IL:FOR XCL::ADVICE IL:IN XCL::AROUND IL:DO (XCL:DESTRUCTURING-BIND (XCL::PRIORITY XCL::FORM) XCL::ADVICE (ADD-ADVICE XCL::NAME :AROUND XCL::PRIORITY XCL::FORM))))
+
+(DEFUN ADVICE-GETDEF (NAME TYPE OPTIONS) (LET ((ADVICE (CAR (GETHASH NAME *ADVICE-HASH-TABLE*)))) (AND ADVICE (APPEND (IL:FOR ENTRY IL:IN (ADVICE-BEFORE ADVICE) IL:COLLECT (CONS (QUOTE :BEFORE) (COPY-TREE ENTRY))) (IL:FOR ENTRY IL:IN (ADVICE-AFTER ADVICE) IL:COLLECT (CONS (QUOTE :AFTER) (COPY-TREE ENTRY))) (IL:FOR ENTRY IL:IN (ADVICE-AROUND ADVICE) IL:COLLECT (CONS (QUOTE :AROUND) (COPY-TREE ENTRY)))))))
+
+(DEFUN ADVICE-PUTDEF (NAME TYPE DEFINITION) (LET ((CANONICAL-DEFN (IL:FOR ENTRY IL:IN DEFINITION IL:COLLECT (LIST (CANONICALIZE-ADVICE-WHEN-SPEC (CAR ENTRY)) (CANONICALIZE-ADVICE-WHERE-SPEC (COPY-TREE (CADR ENTRY))) (COPY-TREE (CADDR ENTRY))))) (CURRENT-ADVICE (OR (CAR (GETHASH NAME *ADVICE-HASH-TABLE*)) (CAR (SETF (GETHASH NAME *ADVICE-HASH-TABLE*) (CONS (MAKE-ADVICE) NIL)))))) (SETF (ADVICE-BEFORE CURRENT-ADVICE) (MAPCAR (FUNCTION REST) (IL:FOR ENTRY IL:IN CANONICAL-DEFN IL:WHEN (EQ (CAR ENTRY) :BEFORE) IL:COLLECT ENTRY))) (SETF (ADVICE-AFTER CURRENT-ADVICE) (MAPCAR (FUNCTION REST) (IL:FOR ENTRY IL:IN CANONICAL-DEFN IL:WHEN (EQ (CAR ENTRY) :AFTER) IL:COLLECT ENTRY))) (SETF (ADVICE-AROUND CURRENT-ADVICE) (MAPCAR (FUNCTION REST) (IL:FOR ENTRY IL:IN CANONICAL-DEFN IL:WHEN (EQ (CAR ENTRY) :AROUND) IL:COLLECT ENTRY))) (IF (CONSP NAME) (XCL:READVISE-FUNCTION (FIRST NAME) :IN (THIRD NAME)) (XCL:READVISE-FUNCTION NAME))))
+
+(DEFUN ADVICE-DELDEF (NAME TYPE) (DECLARE (IGNORE TYPE)) (WHEN (MEMBER NAME IL:ADVISEDFNS :TEST (QUOTE EQUAL)) (IF (CONSP NAME) (XCL:UNADVISE-FUNCTION (FIRST NAME) :IN (THIRD NAME)) (XCL:UNADVISE-FUNCTION NAME)) (FORMAT *TERMINAL-IO* "~S unadvised." NAME)) (REMHASH NAME *ADVICE-HASH-TABLE*))
+
+(DEFUN ADVICE-HASDEF (NAME TYPE SOURCE) (AND (GETHASH NAME *ADVICE-HASH-TABLE*) (OR NAME T)))
+
+(DEFUN ADVICE-NEWCOM (NAME TYPE LISTNAME FILE) (IL:* IL:|;;;| "If you make a new com for ADVICE, you should make an ADVISE command.") (IL:DEFAULTMAKENEWCOM NAME (QUOTE IL:ADVISE) LISTNAME FILE))
+
+(DEFUN ADVICE-FILE-DEFINITIONS (NAMES READVISE?) (IL:* IL:|;;;| "READVISE? is true for the File Manager command ADVISE and false for the command ADVICE.  For ADVISE, we want to emit a form to readvise the named functions after reinstalling the advice.") (LET ((REAL-NAMES NIL)) (IL:BQUOTE ((IL:\\\,@ (IL:FOR FN IL:IN NAMES IL:COLLECT (LET* ((NAME (IL:IF (CONSP FN) IL:THEN (ASSERT (AND (EQ (SECOND FN) :IN) (= 3 (LENGTH FN))) NIL "~S should be of the form (FOO :IN BAR)" FN) FN IL:ELSE (LET ((NAME (CANONICALIZE-ADVICE-SYMBOL FN)) (OLD-ADVICE (GET FN (QUOTE IL:READVICE)))) (WHEN OLD-ADVICE (ADD-OLD-STYLE-ADVICE NAME OLD-ADVICE) (REMPROP FN (QUOTE IL:READVICE))) NAME))) (ADVICE (CAR (GETHASH NAME *ADVICE-HASH-TABLE*)))) (ASSERT (NOT (NULL ADVICE)) NIL "Can't find advice for ~S" NAME) (PUSH NAME REAL-NAMES) (IL:BQUOTE (XCL:REINSTALL-ADVICE (QUOTE (IL:\\\, NAME)) (IL:\\\,@ (AND (ADVICE-BEFORE ADVICE) (IL:BQUOTE (:BEFORE (QUOTE (IL:\\\, (ADVICE-BEFORE ADVICE))))))) (IL:\\\,@ (AND (ADVICE-AFTER ADVICE) (IL:BQUOTE (:AFTER (QUOTE (IL:\\\, (ADVICE-AFTER ADVICE))))))) (IL:\\\,@ (AND (ADVICE-AROUND ADVICE) (IL:BQUOTE (:AROUND (QUOTE (IL:\\\, (ADVICE-AROUND ADVICE)))))))))))) (IL:\\\,@ (AND READVISE? (IL:BQUOTE ((IL:READVISE (IL:\\\,@ (REVERSE REAL-NAMES)))))))))))
+
+(DEFUN ADVISE-CONTENTS (COM NAME TYPE) (AND (EQ TYPE (QUOTE IL:ADVICE)) (COND ((NULL NAME) (IL:* IL:\; "Return a list of the ADVICE's in the given COM.") (CDR COM)) ((EQ NAME (QUOTE T)) (IL:* IL:\; "Return T if there are ANY ADVICE's in the given COM.") (NOT (NULL (CDR COM)))) ((OR (SYMBOLP NAME) (= (LENGTH NAME) 3) (EQ (SECOND NAME) :IN)) (IL:* IL:\; "Return T iff an ADVICE named NAME in the given COM.") (AND (MEMBER NAME (CDR COM) :TEST (QUOTE EQUAL)) T)) (T (IL:* IL:\; "NAME is a list of names.  Return the intersection of that list with the ADVICE's in the given COM.") (INTERSECTION NAME (CDR COM) :TEST (QUOTE EQUAL))))))
+
+(DEFUN ADVICE-ADDTOCOM (COM NAME TYPE NEAR) (IL:* IL:|;;;| "This is the ADD method for both of the ADVICE and ADVISE commands.") (IL:* IL:|;;;| "Add the given name only if the type is ADVICE.  Also, add it to ADVICE commands only if a NEAR was specified.  We want to normally create only ADVISE commands.  If the user really wants an ADVICE command, they'll have to create it themselves.") (AND (EQ TYPE (QUOTE IL:ADVICE)) (OR (EQ (CAR COM) (QUOTE IL:ADVISE)) (NOT (NULL NEAR))) (IL:ADDTOCOM1 COM NAME NEAR NIL)))
+
+(IL:PUTPROPS IL:ADVISED IL:PROPTYPE IGNORE)
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;| "Dealing with old-style advice")
+
+
+(DEFUN IL:READVISE1 (IL:FN) (FLET ((IL:READVISE-ENTRY (IL:ENTRY) (IL:IF (IL:LISTP IL:ENTRY) IL:THEN (XCL:READVISE-FUNCTION (FIRST IL:ENTRY) :IN (THIRD IL:ENTRY)) IL:ELSE (XCL:READVISE-FUNCTION IL:ENTRY)))) (IL:IF (IL:LISTP IL:FN) IL:THEN (ASSERT (IL:STRING.EQUAL (SECOND IL:FN) "IN") NIL "~S should be in the form (FOO IN BAR).~%" IL:FN) (IL:READVISE-ENTRY IL:FN) IL:ELSE (LET ((IL:NAME (CANONICALIZE-ADVICE-SYMBOL IL:FN)) (IL:OLD-ADVICE (GET IL:FN (QUOTE IL:READVICE)))) (IL:IF IL:OLD-ADVICE IL:THEN (ADD-OLD-STYLE-ADVICE IL:NAME IL:OLD-ADVICE) (REMPROP IL:FN (QUOTE IL:READVICE))) (IL:READVISE-ENTRY IL:NAME)))))
+
+(DEFUN ADD-OLD-STYLE-ADVICE (NAME OLD-ADVICE) (IL:* IL:|;;;| "OLD-ADVICE should the value of the READVICE property of some symbol.  Note that the CAR of that value is the old middle-man used for -IN- advice.  Thus, we take the CDR below.") (WHEN (NOT (MEMBER NAME IL:ADVISEDFNS :TEST (QUOTE EQUAL))) (DELETE-ADVICE NAME)) (IL:FOR ADVICE IL:IN (CDR OLD-ADVICE) IL:DO (XCL:DESTRUCTURING-BIND (WHEN WHERE WHAT) ADVICE (IL:* IL:|;;| "Translate Interlisp names to the new standard.") (ADD-ADVICE NAME (CANONICALIZE-ADVICE-WHEN-SPEC WHEN) (CANONICALIZE-ADVICE-WHERE-SPEC WHERE) WHAT))))
+
+(DEFUN CANONICALIZE-ADVICE-SYMBOL (SYMBOL) (LET ((IN-POS (IL:STRPOS "-IN-" SYMBOL))) (IF (NULL IN-POS) SYMBOL (LIST (IL:SUBATOM SYMBOL 1 (1- IN-POS)) :IN (IL:SUBATOM SYMBOL (+ IN-POS 4) NIL)))))
+
+(DEFUN CANONICALIZE-ADVICE-WHEN-SPEC (SPEC) (IF (NULL SPEC) (QUOTE :BEFORE) (INTERN (STRING SPEC) "KEYWORD")))
+
+(DEFUN CANONICALIZE-ADVICE-WHERE-SPEC (SPEC) (CASE SPEC ((NIL LAST IL:BOTTOM IL:END :LAST) (QUOTE :LAST)) ((IL:TOP IL:FIRST :FIRST) (QUOTE :FIRST)) (T (IF (CONSP SPEC) SPEC (ERROR "Illegal WHERE specification to ADVISE: ~S" SPEC)))))
+
+(XCL:DEF-DEFINE-TYPE XCL:ADVISED-FUNCTIONS "Advised function definitions")
+
+(XCL:DEFDEFINER (XCL:DEFADVICE (:PROTOTYPE (LAMBDA (XCL::NAME) (IL:BQUOTE (XCL:DEFADVICE (IL:\\\, XCL::NAME) "advice"))))) XCL:ADVISED-FUNCTIONS (XCL::NAME &BODY XCL::ADVICE-FORMS) (IL:BQUOTE (PROGN (IL:\\\,. (XCL:WITH-COLLECTION (DOLIST (XCL::ADVICE XCL::ADVICE-FORMS) (XCL:COLLECT (XCL:DESTRUCTURING-BIND (XCL::FN-TO-ADVISE XCL::FORM &KEY XCL::IN WHEN XCL::PRIORITY) XCL::ADVICE (IL:BQUOTE (XCL:ADVISE-FUNCTION (QUOTE (IL:\\\, XCL::FN-TO-ADVISE)) (QUOTE (IL:\\\, XCL::FORM)) (IL:\\\,@ (AND XCL::IN (IL:BQUOTE (:IN (QUOTE (IL:\\\, XCL::IN)))))) (IL:\\\,@ (AND WHEN (IL:BQUOTE (:WHEN (IL:\\\, WHEN))))) (IL:\\\,@ (AND XCL::PRIORITY (IL:BQUOTE (:PRIORITY (IL:\\\, XCL::PRIORITY)))))))))))))))
+
+
+
+(IL:* IL:|;;| 
+"Arrange for the proper package.  Because of the DEFSTRUCT above, we must have the file dumped in the SYSTEM package."
+)
+
+
+(IL:PUTPROPS IL:ADVISE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "SYSTEM"))
+
+(IL:PUTPROPS IL:ADVISE IL:FILETYPE :COMPILE-FILE)
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA IL:READVISE IL:UNADVISE)
+
+(IL:ADDTOVAR IL:NLAML)
+
+(IL:ADDTOVAR IL:LAMA IL:ADVISE)
+)
+(IL:PRETTYCOMPRINT IL:ADVISECOMS)
+
+(IL:RPAQQ IL:ADVISECOMS ((IL:STRUCTURES ADVICE) (IL:VARIABLES IL:ADVISEDFNS *UNADVISED-FNS*) (IL:* IL:|;;| "") (IL:* IL:|;;| "Interlisp entry points.") (IL:FNS IL:ADVISE IL:UNADVISE IL:READVISE) (IL:PROP IL:ARGNAMES IL:ADVISE) (IL:* IL:|;;| "") (IL:* IL:|;;| "XCL entry points.") (IL:FUNCTIONS XCL:ADVISE-FUNCTION XCL:UNADVISE-FUNCTION XCL:READVISE-FUNCTION) (IL:FUNCTIONS UNADVISE-FROM-RESTORE-CALLS FINISH-ADVISING FINISH-UNADVISING) (IL:* IL:|;;| "") (IL:* IL:|;;| "The advice database.") (IL:VARIABLES *ADVICE-HASH-TABLE*) (IL:FUNCTIONS ADD-ADVICE DELETE-ADVICE GET-ADVICE-MIDDLE-MAN SET-ADVICE-MIDDLE-MAN INSERT-ADVICE-FORM) (IL:SETFS GET-ADVICE-MIDDLE-MAN) (IL:* IL:|;;| "") (IL:* IL:|;;| "Hacking the actual advice forms.") (IL:FUNCTIONS CREATE-ADVISED-DEFINITION MAKE-AROUND-BODY) (IL:* IL:|;;| "") (IL:* IL:|;;| "Dealing with the File Manager") (IL:FILEPKGCOMS IL:ADVICE IL:ADVISE) (IL:FUNCTIONS XCL:REINSTALL-ADVICE) (IL:FUNCTIONS ADVICE-GETDEF ADVICE-PUTDEF ADVICE-DELDEF ADVICE-HASDEF ADVICE-NEWCOM ADVICE-FILE-DEFINITIONS ADVISE-CONTENTS ADVICE-ADDTOCOM) (IL:PROP IL:PROPTYPE IL:ADVISED) (IL:* IL:|;;| "") (IL:* IL:|;;| "Dealing with old-style advice") (IL:FUNCTIONS IL:READVISE1 ADD-OLD-STYLE-ADVICE CANONICALIZE-ADVICE-SYMBOL CANONICALIZE-ADVICE-WHEN-SPEC CANONICALIZE-ADVICE-WHERE-SPEC) (IL:DEFINE-TYPES XCL:ADVISED-FUNCTIONS) (IL:FUNCTIONS XCL:DEFADVICE) (IL:* IL:|;;| "Arrange for the proper package.  Because of the DEFSTRUCT above, we must have the file dumped in the SYSTEM package.") (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:ADVISE) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA IL:ADVISE)))))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA)
+
+(IL:ADDTOVAR IL:NLAML)
+
+(IL:ADDTOVAR IL:LAMA IL:ADVISE)
+)
+(IL:PUTPROPS IL:ADVISE IL:COPYRIGHT ("Venue & Xerox Corporation" T 1978 1984 1986 1987 1988 1990 1992)
+)
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL (2691 7263 (IL:ADVISE 2704 . 4833) (IL:UNADVISE 4835 . 5755) (IL:READVISE 5757 . 7261
+)))))
+IL:STOP
diff --git a/CLTL2/AERROR b/CLTL2/AERROR
new file mode 100644
index 00000000..f1344c56
--- /dev/null
+++ b/CLTL2/AERROR
@@ -0,0 +1,76 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "13-Mar-92 14:41:54" {DSK}<usr>local>lde>lispcore>sources>AERROR.;2 7354   
+
+      changes to%:  (VARS AERRORCOMS)
+
+      previous date%: "16-May-90 11:58:35" {DSK}<usr>local>lde>lispcore>sources>AERROR.;1)
+
+
+(* ; "
+Copyright (c) 1982, 1983, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT AERRORCOMS)
+
+(RPAQQ AERRORCOMS ((FNS ERRORSTRING SETERRORN LISPERROR \LISPERROR \ILLEGAL.ARG \ARG.NOT.LITATOM) (EXPORT (DECLARE%: EVAL@COMPILE (VARS \ERRORMESSAGELIST) DONTCOPY (OPTIMIZERS LISPERROR))) (VARIABLES *LAST-CONDITION*) (GLOBALVARS \ERRORMESSAGELIST) (FUNCTIONS ERRM-TO-CONDITION) (PROP FILETYPE AERROR) (LOCALVARS . T)))
+(DEFINEQ
+
+(ERRORSTRING
+(LAMBDA (X) (* lmm "21-APR-80 15:46") (CAR (NTH \ERRORMESSAGELIST (ADD1 (OR (NUMBERP X) 17))))))
+
+(SETERRORN
+(LAMBDA (NUM MESS) (* amd "30-Jul-86 17:00") (CL:SETQ *LAST-CONDITION* (ERRM-TO-CONDITION NUM MESS))))
+
+(LISPERROR
+  [LAMBDA (N X CONTINUEOKFLG)                            (* ; "Edited  1-Feb-89 09:38 by jds")
+
+    (* ;; "compiles open as call to \LISPERROR")
+
+    [COND
+       ((STRINGP N)
+
+        (* ;; "Case where LISPERROR is called with one of the %"canonical error message%" strings from the old IL implementation.  Need to translate it to a number.  THIS CODE IS STOLEN IN SPIRIT FROM THE OPTIMIZER.")
+
+        (FOR MSG IN \ERRORMESSAGELIST AS I FROM 0 WHEN (CL:EQUAL MSG N)
+           DO (SETQ N I]
+    (\LISPERROR X N CONTINUEOKFLG])
+
+(\LISPERROR
+(LAMBDA (X N CONTINUEOKFLG) (* amd "11-Nov-86 12:09") (DECLARE (USEDFREE \INTERRUPTABLE)) (PROG NIL (SELECTQ N ((5 22) (* ; "File errors that can happen to files open for output") (* ;; "(\STOP.DRIBBLE?  X)")) NIL) (OR \INTERRUPTABLE (\MP.ERROR \MP.UNINTERRUPTABLE "Error in uninterruptable system code -- ^N to continue into error handler" X)) RET (RETURN (PROG1 (COND ((SMALLP N) (ERRORX (LIST N X))) (T (ERROR N X))) (OR CONTINUEOKFLG (GO RET))))))
+)
+
+(\ILLEGAL.ARG
+(LAMBDA (X) (* lmm "25-APR-80 18:02") (LISPERROR "ILLEGAL ARG" X)))
+
+(\ARG.NOT.LITATOM
+(LAMBDA (X) (* lmm "25-APR-80 18:02") (LISPERROR "ARG NOT LITATOM" X)))
+)
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \ERRORMESSAGELIST ("SYSTEM ERROR" " " "STACK OVERFLOW" "ILLEGAL RETURN" "ARG NOT LIST" "HARD DISK ERROR" "ATTEMPT TO SET NIL OR T" "ATTEMPT TO RPLAC NIL" "UNDEFINED OR ILLEGAL GO" "FILE WON'T OPEN" "NON-NUMERIC ARG" "ATOM TOO LONG" "ATOM HASH TABLE FULL" "FILE NOT OPEN" "ARG NOT LITATOM" "! too many files open" "END OF FILE" "ERROR" "BREAK" "ILLEGAL STACK ARG" "FAULT IN EVAL" "ARRAYS FULL" "FILE SYSTEM RESOURCES EXCEEDED" "FILE NOT FOUND" "BAD SYSOUT FILE" "UNUSUAL CDR ARG LIST" "HASH TABLE FULL" "ILLEGAL ARG" "ARG NOT ARRAY" "ILLEGAL OR IMPOSSIBLE BLOCK" "STACK PTR HAS BEEN RELEASED" "STORAGE FULL" "ATTEMPT TO USE ITEM OF INCORRECT TYPE" "ILLEGAL DATA TYPE NUMBER" "DATA TYPES FULL" "ATTEMPT TO BIND NIL OR T" "! too many user interrupt characters" "! read-macro context error" "ILLEGAL READTABLE" "ILLEGAL TERMINAL TABLE" "! swapblock too big for buffer" "PROTECTION VIOLATION" "BAD FILE NAME" "USER BREAK" "UNBOUND ATOM" "UNDEFINED CAR OF FORM" "UNDEFINED FUNCTION" "CONTROL-E" "FLOATING UNDERFLOW" "FLOATING OVERFLOW" "OVERFLOW" "ARG NOT HARRAY" "TOO MANY ARGUMENTS"))
+DONTCOPY 
+
+(DEFOPTIMIZER LISPERROR (MESSAGE ARG) (BQUOTE (\LISPERROR (\, ARG) (\, (CL:IF (CL:STRINGP MESSAGE) (FOR X IN \ERRORMESSAGELIST AS I FROM 0 WHEN (CL:EQUAL X MESSAGE) DO (RETURN I) FINALLY (RETURN (HELP "Unknown error message" (LIST MESSAGE ARG)))) MESSAGE)))))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(CL:DEFVAR *LAST-CONDITION* NIL "Last condition signalled. This gets rebound to itself in nested execs.")
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \ERRORMESSAGELIST)
+)
+
+(CL:DEFUN ERRM-TO-CONDITION (NUM MESSAGE) (CL:IF (TYPEP NUM (QUOTE CONDITION)) NUM (CASE NUM (2 (* ; "STACK OVERFLOW") (MAKE-CONDITION (QUOTE STACK-OVERFLOW))) (3 (* ; "ILLEGAL RETURN") (MAKE-CONDITION (QUOTE ILLEGAL-RETURN) :TAG MESSAGE)) ((4 10 14 28 38 39 51) (* ; "ARG NOT x") (MAKE-CONDITION (QUOTE XCL:TYPE-MISMATCH) :NAME MESSAGE :VALUE MESSAGE :EXPECTED-TYPE (CL:ECASE NUM (4 (QUOTE LIST)) (10 (QUOTE CL:NUMBER)) (14 (QUOTE CL:SYMBOL)) (28 (QUOTE ARRAYP)) (38 (QUOTE READTABLEP)) (39 (QUOTE TERMTABLEP)) (51 (QUOTE CL:HASH-TABLE))))) (5 (* ; "HARD DISK ERROR") (MAKE-CONDITION (QUOTE XCL:SIMPLE-DEVICE-ERROR) :MESSAGE MESSAGE)) ((6 35) (* ; "ATTEMPT TO SET NIL, ATTEMPT TO BIND NIL OR T") (MAKE-CONDITION (QUOTE XCL:ATTEMPT-TO-CHANGE-CONSTANT) :NAME NIL)) (7 (* ; "ATTEMPT TO RPLAC NIL") (MAKE-CONDITION (QUOTE XCL:ATTEMPT-TO-RPLAC-NIL) :NAME MESSAGE)) (8 (* ; "UNDEFINED OR ILLEGAL GO") (MAKE-CONDITION (QUOTE ILLEGAL-GO) :TAG MESSAGE)) (9 (* ; "FILE WON'T OPEN") (MAKE-CONDITION (QUOTE XCL:FILE-WONT-OPEN) :PATHNAME MESSAGE)) (11 (* ; "ATOM TOO LONG") (MAKE-CONDITION (QUOTE XCL:SYMBOL-NAME-TOO-LONG))) (12 (* ; "ATOM HASH TABLE FULL") (MAKE-CONDITION (QUOTE XCL:SYMBOL-HT-FULL))) (13 (* ; "FILE NOT OPEN") (MAKE-CONDITION (QUOTE XCL:STREAM-NOT-OPEN) :STREAM MESSAGE)) (16 (* ; "END OF FILE") (MAKE-CONDITION (QUOTE END-OF-FILE) :STREAM MESSAGE)) (17 (* ; "ERROR") (MAKE-CONDITION (QUOTE INTERLISP-ERROR) :MESSAGE MESSAGE)) (19 (* ; "ILLEGAL STACK ARG") (MAKE-CONDITION (QUOTE ILLEGAL-STACK-ARG) :ARG MESSAGE)) (21 (* ; "ARRAYS FULL") (MAKE-CONDITION (QUOTE XCL:ARRAY-SPACE-FULL))) (22 (* ; "FILE SYSTEM RESOURCES EXCEEDED") (MAKE-CONDITION (QUOTE XCL:FS-RESOURCES-EXCEEDED) :PATHNAME MESSAGE)) (23 (* ; "FILE NOT FOUND") (MAKE-CONDITION (QUOTE XCL:FILE-NOT-FOUND) :PATHNAME MESSAGE)) ((25 27) (* ; "UNUSUAL CDR ARG LIST, ILLEGAL ARG") (MAKE-CONDITION (QUOTE INVALID-ARGUMENT-LIST) :ARGUMENT MESSAGE)) (26 (* ; "HASH TABLE FULL") (MAKE-CONDITION (QUOTE XCL:HASH-TABLE-FULL) :TABLE MESSAGE)) (30 (* ; "STACK PTR HAS BEEN RELEASED") (MAKE-CONDITION (QUOTE STACK-POINTER-RELEASED) :NAME MESSAGE)) (31 (* ; "STORAGE FULL") (MAKE-CONDITION (QUOTE XCL:STORAGE-EXHAUSTED))) (34 (* ; "DATA TYPES FULL") (MAKE-CONDITION (QUOTE XCL:DATA-TYPES-EXHAUSTED))) (41 (* ; "PROTECTION VIOLATION") (MAKE-CONDITION (QUOTE XCL:FS-PROTECTION-VIOLATION) :PATHNAME MESSAGE)) (42 (* ; "BAD FILE NAME") (MAKE-CONDITION (QUOTE XCL:INVALID-PATHNAME) :PATHNAME MESSAGE)) (44 (* ; "UNBOUND ATOM") (MAKE-CONDITION (QUOTE UNBOUND-VARIABLE) :NAME MESSAGE)) (45 (* ; "UNDEFINED CAR OF FORM") (MAKE-CONDITION (QUOTE UNDEFINED-CAR-OF-FORM) :FUNCTION MESSAGE)) (46 (* ; "UNDEFINED FUNCTION") (MAKE-CONDITION (QUOTE UNDEFINED-FUNCTION-IN-APPLY) :NAME (CL:FIRST MESSAGE) :ARGUMENTS (CL:SECOND MESSAGE))) (47 (* ; "CONTROL-E") (MAKE-CONDITION (QUOTE XCL:CONTROL-E-INTERRUPT))) (48 (* ; "FLOATING UNDERFLOW") (MAKE-CONDITION (QUOTE CL:FLOATING-POINT-UNDERFLOW))) (49 (* ; "FLOATING OVERFLOW") (MAKE-CONDITION (QUOTE CL:FLOATING-POINT-OVERFLOW))) (52 (* ; "TOO MANY ARGUMENTS") (MAKE-CONDITION (QUOTE TOO-MANY-ARGUMENTS) :CALLEE MESSAGE :MAXIMUM CL:CALL-ARGUMENTS-LIMIT)) (CL:OTHERWISE (CL:ERROR "Interlisp error number ~D (message: ~S) no longer supported" NUM MESSAGE)))))
+
+(PUTPROPS AERROR FILETYPE CL:COMPILE-FILE)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+(PUTPROPS AERROR COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1986 1987 1988 1989 1990 1992))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (773 2259 (ERRORSTRING 783 . 896) (SETERRORN 898 . 1015) (LISPERROR 1017 . 1604) (
+\LISPERROR 1606 . 2075) (\ILLEGAL.ARG 2077 . 2162) (\ARG.NOT.LITATOM 2164 . 2257)))))
+STOP
diff --git a/CLTL2/AERROR.LCOM b/CLTL2/AERROR.LCOM
new file mode 100644
index 00000000..2cdf63f7
Binary files /dev/null and b/CLTL2/AERROR.LCOM differ
diff --git a/CLTL2/APRINT b/CLTL2/APRINT
new file mode 100644
index 00000000..cb11e04a
--- /dev/null
+++ b/CLTL2/APRINT
@@ -0,0 +1,1882 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "11-Oct-93 16:04:23" "{Pele:mv:envos}<LispCore>Sources>CLTL2>APRINT.;1" 100667 
+
+      changes to%:  (VARS APRINTCOMS)
+                    (FUNCTIONS \PRINDATUM-LISTP)
+
+      previous date%: " 4-Jan-92 15:40:50" {DSK}<mo>usr>users>sybalsky>cltl2>sources>APRINT.;1)
+
+
+(* ; "
+Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT APRINTCOMS)
+
+(RPAQQ APRINTCOMS
+       [(COMS                                                (* ; "User-level print functions")
+              (FNS PRIN1 PRIN2 PRIN3 PRIN4 PRINT PRINTCCODE PRINTLEVEL RADIX SPACES TERPRI FRESHLINE
+                   DEFPRINT LINELENGTH))
+        (FNS ALPHANUMCHARARRAY)
+        (INITVARS (PLVLFILEFLG NIL)
+               (\LINELENGTH 82)
+               (\FLOATFORMAT T)
+               (PRXFLG NIL)
+               (*PRINT-BASE* 10)
+               (*READ-BASE* 10)
+               (*READ-EVAL* T)
+               (*PRINT-RADIX* NIL)
+               (*PRINT-ESCAPE* T)
+               (*PRINT-CASE* ':UPCASE)
+               (*PRINT-GENSYM* T)
+               (*PRINT-LEVEL* NIL)
+               (*PRINT-LENGTH* NIL)
+               (*PRINT-PRETTY* NIL)
+               (*PRINT-CIRCLE* NIL)
+               (*PRINT-ARRAY* NIL)
+               (*PRINT-CIRCLE-HASHTABLE* NIL)
+               (*PACKAGE* NIL)
+               (*KEYWORD-PACKAGE* NIL)
+               (*INTERLISP-PRIN1-CASE* ':UPCASE)
+               (*CLTL2-PEDANTIC* NIL)
+               (\DEFPRINTFNS NIL)
+               (ALPHANUMCHARARRAY (ALPHANUMCHARARRAY)))
+        (COMS                                                (* ; "PRINT internals")
+              (FNS PRINT-CIRCLE-LOOKUP PRINT-CIRCLE-LABEL-P PRINT-CIRCLE-SCAN PRINT-CIRCLE-ENTER)
+              (FNS \PRINDATUM \PRINT-USING-DEFPRINT \PRINT-USING-ADDRESS \ELIDE.PRINT.ELEMENT 
+                   \ELIDE.ELEMENT.CHAR \ELIDE.PRINT.TAIL \ELIDE.TAIL.STRING \CKPOSBOUT \CKPOSSOUT 
+                   \CONVERTNUMBER \LITPRIN \LITPRIN.INTERNAL \PNAME-CONTAINS-NO-EOL 
+                   \SYMBOL.ESCAPE.COUNT \NUMERIC.PNAMEP \PRINSTACKP \PRINTADDR \PRINSTRING \SOUT 
+                   \OUTCHAR)
+              (FNS \FILEOUTCHARFN \JISFILEOUTCHARFN \SHIFTJISFILEOUTCHARFN \EUCFILEOUTCHARFN 
+                   \THROUGHFILEOUTCHARFN)
+              (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS .FILELINELENGTH.)
+                     (FUNCTIONS \PRINDATUM-LISTP)
+                     (EXPORT (MACROS .SPACECHECK. \CHECKRADIX)
+                            (MACROS \XCCSFILEOUTCHARFN)))
+              (FNS \INVALID.RADIX)
+              (SPECVARS \THISFILELINELENGTH))
+        (COMS                                                (* ; "Internal printing")
+              (FNS \MAPPNAME \MAPPNAME.INTERNAL PNAMESTREAMP)
+              (DECLARE%: DONTCOPY (RESOURCES \MAPPNAMESTREAM)
+                     (MACROS PNAMESTREAMP))
+              (INITRESOURCES \MAPPNAMESTREAM)
+              [INITVARS (\PNAMEDEVICE (NCREATE 'FDEV (\GETDEVICEFROMHOSTNAME 'NULL T]
+              (GLOBALVARS \PNAMEDEVICE))
+        (COMS                                                (* ; "Obsolete")
+              (FNS \MAPCHARS))
+        (DECLARE%: EVAL@COMPILE DOCOPY
+               (ADDVARS (SYSSPECVARS *PRINT-BASE* *READ-BASE* *READ-EVAL* *PRINT-RADIX* 
+                               *PRINT-ESCAPE* *PRINT-CASE* *PRINT-GENSYM* *PRINT-LEVEL* 
+                               *PRINT-LENGTH* *PRINT-PRETTY* *PRINT-CIRCLE* *PRINT-ARRAY* *PACKAGE* 
+                               *CLTL2-PEDANTIC*)))
+        (COMS                                                (* ; "PRINTNUM and friends")
+              (FNS PRINTNUM FLTFMT \CHECKFLTFMT PRINTNUM-TO-STRING)
+              (MACROS NUMFORMATCODE)
+              (INITVARS (NILNUMPRINTFLG)))
+        (LOCALVARS . T)
+        (GLOBALVARS \LINELENGTH \FLOATFORMAT PRXFLG \DEFPRINTFNS ALPHANUMCHARARRAY)
+        (PROP (FILETYPE APRINT))
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML)
+                                                                             (LAMA])
+
+
+
+(* ; "User-level print functions")
+
+(DEFINEQ
+
+(PRIN1
+  [LAMBDA (X FILE)                                           (* bvm%: "29-Sep-86 23:59")
+
+(* ;;; "Like PRIN2 but no escaping.  Also implies no radix qualifiers, although Common Lisp separates *PRINT-RADIX* from *PRINT-ESCAPE* -- might want to bind *PRINT-RADIX* to (AND (fetch (READTABLEP COMMONLISP) of *READTABLE*) *PRINT-RADIX*)")
+
+    (LET* [(STRM (\GETSTREAM FILE 'OUTPUT))
+           (OBEY-PRINT-LEVEL (OR (ffetch (READTABLEP COMMONLISP) of (\DTEST *READTABLE*
+                                                                                   'READTABLEP))
+                                 (OR (\OUTTERMP STRM)
+                                     PLVLFILEFLG]
+          (LET ((*PRINT-ESCAPE* NIL)
+                (*PRINT-RADIX* NIL)
+                (*PRINT-LEVEL* (AND OBEY-PRINT-LEVEL *PRINT-LEVEL*))
+                (*PRINT-LENGTH* (AND OBEY-PRINT-LEVEL *PRINT-LENGTH*))
+                (*PRINT-CASE* (OR *INTERLISP-PRIN1-CASE* *PRINT-CASE*))
+                \THISFILELINELENGTH)
+               (DECLARE (SPECVARS *PRINT-RADIX* *PRINT-ESCAPE* *PRINT-LEVEL* *PRINT-LENGTH* 
+                                   *PRINT-CASE* \THISFILELINELENGTH))
+                                                             (* ; 
+      "*PRINT-CASE* because too many things in Interlisp prin1 things expecting the symbol's pname")
+               (SETQ \THISFILELINELENGTH (.FILELINELENGTH. STRM))
+               (\PRINDATUM X STRM 0)
+               X])
+
+(PRIN2
+  [LAMBDA (X FILE RDTBL)                                     (* ; "Edited 20-Jan-87 17:04 by bvm:")
+    (LET* [(STRM (\GETSTREAM FILE 'OUTPUT))
+           (OBEY-PRINT-LEVEL (OR (fetch (READTABLEP COMMONLISP) of (SETQ RDTBL (\GTREADTABLE
+                                                                                        RDTBL)))
+                                 (OR (\OUTTERMP STRM)
+                                     PLVLFILEFLG]
+          (LET ((*READTABLE* RDTBL)
+                (*PRINT-ESCAPE* T)
+                (*PRINT-LEVEL* (AND OBEY-PRINT-LEVEL *PRINT-LEVEL*))
+                (*PRINT-LENGTH* (AND OBEY-PRINT-LEVEL *PRINT-LENGTH*))
+                (*PACKAGE* (if (fetch (READTABLEP USESILPACKAGE) of RDTBL)
+                               then *INTERLISP-PACKAGE*
+                             else *PACKAGE*))
+                \THISFILELINELENGTH)
+               (DECLARE (SPECVARS *PRINT-ESCAPE* *READTABLE* *PRINT-LEVEL* *PRINT-LENGTH* 
+                                   *PACKAGE* \THISFILELINELENGTH))
+               (SETQ \THISFILELINELENGTH (.FILELINELENGTH. STRM))
+               (\PRINDATUM X STRM 0)
+               X])
+
+(PRIN3
+  [LAMBDA (X FILE)                                           (* bvm%: "29-Sep-86 23:59")
+
+(* ;;; "Like PRIN1 but no linelength checking")
+
+    (LET* [(STRM (\GETSTREAM FILE 'OUTPUT))
+           (OBEY-PRINT-LEVEL (OR (ffetch (READTABLEP COMMONLISP) of (\DTEST *READTABLE*
+                                                                                   'READTABLEP))
+                                 (OR (\OUTTERMP STRM)
+                                     PLVLFILEFLG]
+          (LET ((*PRINT-ESCAPE* NIL)
+                (*PRINT-RADIX* NIL)
+                (*PRINT-LEVEL* (AND OBEY-PRINT-LEVEL *PRINT-LEVEL*))
+                (*PRINT-LENGTH* (AND OBEY-PRINT-LEVEL *PRINT-LENGTH*))
+                (*PRINT-CASE* (OR *INTERLISP-PRIN1-CASE* *PRINT-CASE*))
+                \THISFILELINELENGTH)
+               (DECLARE (SPECVARS *PRINT-RADIX* *PRINT-ESCAPE* *PRINT-LEVEL* *PRINT-LENGTH* 
+                                   \THISFILELINELENGTH))
+               (\PRINDATUM X STRM 0)
+               X])
+
+(PRIN4
+  [LAMBDA (X FILE RDTBL)                                     (* ; "Edited 20-Jan-87 17:05 by bvm:")
+
+(* ;;; "Like PRIN2 but doesn't check linelength")
+
+    (LET* [(STRM (\GETSTREAM FILE 'OUTPUT))
+           (OBEY-PRINT-LEVEL (OR (fetch (READTABLEP COMMONLISP) of (SETQ RDTBL (\GTREADTABLE
+                                                                                        RDTBL)))
+                                 (OR (\OUTTERMP STRM)
+                                     PLVLFILEFLG]
+          (LET ((*READTABLE* RDTBL)
+                (*PRINT-ESCAPE* T)
+                (*PRINT-LEVEL* (AND OBEY-PRINT-LEVEL *PRINT-LEVEL*))
+                (*PRINT-LENGTH* (AND OBEY-PRINT-LEVEL *PRINT-LENGTH*))
+                (*PACKAGE* (if (fetch (READTABLEP USESILPACKAGE) of RDTBL)
+                               then *INTERLISP-PACKAGE*
+                             else *PACKAGE*))
+                \THISFILELINELENGTH)
+               (DECLARE (SPECVARS *PRINT-ESCAPE* *READTABLE* *PRINT-LEVEL* *PRINT-LENGTH* 
+                                   *PACKAGE* \THISFILELINELENGTH))
+               (\PRINDATUM X STRM 0)
+               X])
+
+(PRINT
+  [LAMBDA (X FILE RDTBL)                                     (* bvm%: " 9-May-86 23:08")
+    (LET [(STRM (\GETSTREAM FILE 'OUTPUT]
+         (PRIN2 X STRM RDTBL)
+         (\OUTCHAR STRM (CHARCODE EOL))
+         X])
+
+(PRINTCCODE
+  [LAMBDA (CHARCODE FILE)                                    (* bvm%: " 9-May-86 22:44")
+    (\OUTCHAR (\GETSTREAM FILE 'OUTPUT)
+           (COND
+              ((\CHARCODEP CHARCODE)
+               CHARCODE)
+              (T (\ILLEGAL.ARG CHARCODE])
+
+(PRINTLEVEL
+  [LAMBDA (CARVAL CDRVAL)                                    (* bvm%: " 9-May-86 22:47")
+
+(* ;;; "Sets Interlisp print level to the given values in CAR and CDR directions.  These correspond to *PRINT-LEVEL* and *PRINT-LENGTH* in Common Lisp")
+
+    [COND
+       ((LISTP CARVAL)
+        (SETQ CDRVAL (CDR CARVAL))
+        (SETQ CARVAL (CAR CARVAL]
+    (PROG1 (CONS (OR *PRINT-LEVEL* -1)
+                 (OR *PRINT-LENGTH* -1))
+        [COND
+           (CARVAL (SETQ *PRINT-LEVEL* (AND (IGEQ CARVAL 0)
+                                            CARVAL]
+        [COND
+           (CDRVAL (SETQ *PRINT-LENGTH* (AND (IGEQ CDRVAL 0)
+                                             CDRVAL])])
+
+(RADIX
+  [LAMBDA (N)                                                (* bvm%: " 5-May-86 10:56")
+    (PROG1 *PRINT-BASE*
+        (AND N (SETQ *PRINT-BASE* (\CHECKRADIX N))))])
+
+(SPACES
+  [LAMBDA (N FILE)                                           (* rmk%: "21-OCT-83 12:32")
+    [PROG ((STREAM (\GETSTREAM FILE 'OUTPUT))
+           \THISFILELINELENGTH)
+          (SETQ \THISFILELINELENGTH (.FILELINELENGTH. STREAM))
+          (.SPACECHECK. STREAM N)
+          (FRPTQ N (\OUTCHAR STREAM (CHARCODE SPACE]
+    NIL])
+
+(TERPRI
+  [LAMBDA (FILE)                                             (* rmk%: "21-OCT-83 12:31")
+    (\OUTCHAR (\GETSTREAM FILE 'OUTPUT)
+           (CHARCODE EOL))
+    NIL])
+
+(FRESHLINE
+  [LAMBDA (STREAM)                                           (* rmk%: "22-AUG-83 13:48")
+
+    (* ;; "Adjusts the STREAM to be at a new line -- does equivalent of TERPRI unless it is already 'sitting at the beginning of a line'")
+
+    (COND
+       ([NEQ 0 (fetch CHARPOSITION of (COND
+                                                 ((AND (type? STREAM STREAM)
+                                                       (WRITEABLE STREAM))
+                                                  STREAM)
+                                                 (T (SETQ STREAM (GETSTREAM STREAM 'OUTPUT]
+        (\OUTCHAR STREAM (CHARCODE EOL))
+        T])
+
+(DEFPRINT
+  [LAMBDA (TYPE FN)                                          (* rmk%: "28-APR-80 12:04")
+    (AND (FIXP TYPE)
+         (SETQ TYPE (\TYPENAMEFROMNUMBER TYPE)))             (* ; 
+                                                           "The FIXP case should never occur")
+    (PROG ((F (FASSOC TYPE \DEFPRINTFNS)))
+          [COND
+             (F (SETQ \DEFPRINTFNS (DREMOVE F \DEFPRINTFNS]
+          [COND
+             (FN (SETQ \DEFPRINTFNS (CONS (CONS TYPE FN)
+                                          \DEFPRINTFNS]
+          (RETURN (CDR F])
+
+(LINELENGTH
+  [LAMBDA (N FILE)                                           (* bvm%: "11-Mar-86 14:56")
+
+(* ;;; "Sets to N the linelength of FILE -- defaults to primary output file")
+
+    (LET [(STREAM (\GETSTREAM FILE 'OUTPUT]
+         (PROG1 (fetch (STREAM LINELENGTH) of STREAM)
+             [AND N (COND
+                       ((AND (NUMBERP N)
+                             (ILESSP N 1))
+                        (\ILLEGAL.ARG N))
+                       (T (replace (STREAM LINELENGTH) of STREAM with
+                                                                         (COND
+                                                                            ((EQ N T)
+                                                             (* ; "Infinite")
+                                                                             MAX.SMALLP)
+                                                                            (T (FIX N])])
+)
+(DEFINEQ
+
+(ALPHANUMCHARARRAY
+  [LAMBDA NIL                                                (* ; "Edited 19-Sep-91 19:46 by jrb:")
+    (SETQ ALPHANUMCHARARRAY (ARRAY 256 'BYTE 0 0))
+    (for I from (CHARCODE A) to (CHARCODE Z) do (SETA ALPHANUMCHARARRAY I 1))
+    (for I from (CHARCODE a) to (CHARCODE z) do (SETA ALPHANUMCHARARRAY I 2))
+    (for I from (CHARCODE 0) to (CHARCODE 9) do (SETA ALPHANUMCHARARRAY I 3))
+    ALPHANUMCHARARRAY])
+)
+
+(RPAQ? PLVLFILEFLG NIL)
+
+(RPAQ? \LINELENGTH 82)
+
+(RPAQ? \FLOATFORMAT T)
+
+(RPAQ? PRXFLG NIL)
+
+(RPAQ? *PRINT-BASE* 10)
+
+(RPAQ? *READ-BASE* 10)
+
+(RPAQ? *READ-EVAL* T)
+
+(RPAQ? *PRINT-RADIX* NIL)
+
+(RPAQ? *PRINT-ESCAPE* T)
+
+(RPAQ? *PRINT-CASE* ':UPCASE)
+
+(RPAQ? *PRINT-GENSYM* T)
+
+(RPAQ? *PRINT-LEVEL* NIL)
+
+(RPAQ? *PRINT-LENGTH* NIL)
+
+(RPAQ? *PRINT-PRETTY* NIL)
+
+(RPAQ? *PRINT-CIRCLE* NIL)
+
+(RPAQ? *PRINT-ARRAY* NIL)
+
+(RPAQ? *PRINT-CIRCLE-HASHTABLE* NIL)
+
+(RPAQ? *PACKAGE* NIL)
+
+(RPAQ? *KEYWORD-PACKAGE* NIL)
+
+(RPAQ? *INTERLISP-PRIN1-CASE* ':UPCASE)
+
+(RPAQ? *CLTL2-PEDANTIC* NIL)
+
+(RPAQ? \DEFPRINTFNS NIL)
+
+(RPAQ? ALPHANUMCHARARRAY (ALPHANUMCHARARRAY))
+
+
+
+(* ; "PRINT internals")
+
+(DEFINEQ
+
+(PRINT-CIRCLE-LOOKUP
+  [LAMBDA (OBJECT)                                           (* Pavel "16-Oct-86 21:13")
+    (LET ((TABLEENTRY (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)))
+         (CASE TABLEENTRY
+             ((T1 NIL) (CL:VALUES NIL NIL))
+             (T2 (CL:VALUES (PROG1 (CONCAT (CHARACTER (fetch (READTABLEP HASHMACROCHAR)
+                                                         of *READTABLE*))
+                                          *PRINT-CIRCLE-NUMBER* "=")
+                                (CL:SETF (CL:GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)
+                                       *PRINT-CIRCLE-NUMBER*)
+                                (CL:INCF *PRINT-CIRCLE-NUMBER*))
+                        T))
+             (CL:OTHERWISE (CL:IF (NUMBERP TABLEENTRY)
+                               (CL:VALUES (CONCAT (CHARACTER (fetch (READTABLEP HASHMACROCHAR)
+                                                                of *READTABLE*))
+                                                 TABLEENTRY "#")
+                                      NIL)
+                               (CL:ERROR "Print-circle-lookup hashtable error!"))))])
+
+(PRINT-CIRCLE-LABEL-P
+  [CL:LAMBDA (OBJECT)                                        (* jrb%: "30-Jun-86 23:04")
+         (DECLARE (CL:SPECIAL *PRINT-CIRCLE-HASHTABLE*))
+         (CL:BLOCK PRINT-CIRCLE-LABEL-P
+             (LET ((TABLEENTRY (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)))
+                  (COND
+                     ((EQ TABLEENTRY 'T2))
+                     ((CL:INTEGERP TABLEENTRY)
+                      TABLEENTRY)
+                     (T NIL))))])
+
+(PRINT-CIRCLE-SCAN
+  [CL:LAMBDA (OBJECT)                                        (* ; "Edited  3-Apr-91 10:33 by jrb:")
+         (DECLARE (CL:SPECIAL *PRINT-ARRAY*))
+         (CL:TYPECASE OBJECT
+             (CONS [COND
+                      ((NOT (PRINT-CIRCLE-ENTER OBJECT))
+                       (PRINT-CIRCLE-SCAN (CAR OBJECT))
+                       (PRINT-CIRCLE-SCAN (CDR OBJECT])
+             (CL:SYMBOL                                      (* ; 
+                                                           "Uninterned symbols must be entered")
+                (CL:UNLESS (ffetch (CL:SYMBOL PACKAGE) of OBJECT)
+                       (PRINT-CIRCLE-ENTER OBJECT)))
+             (CL::STRUCTURE-OBJECT [COND
+                                      ((AND XCL:*PRINT-STRUCTURE* (NOT (PRINT-CIRCLE-ENTER OBJECT
+                                                                              )))
+                                       (CL:MAPCAR [FUNCTION (LAMBDA (DESCRIPTOR)
+                                                              (PRINT-CIRCLE-SCAN (FETCHFIELD
+                                                                                      DESCRIPTOR 
+                                                                                      OBJECT]
+                                              (CL::STRUCTURE-POINTER-SLOTS (CL:TYPE-OF OBJECT])
+             ((CL:ARRAY T) [COND
+                              ((AND *PRINT-ARRAY* (NOT (PRINT-CIRCLE-ENTER OBJECT)))
+                                                             (* ; 
+                                                 "No need to walk array if we're not printing them")
+                               (LET* [(ASIZE (CL:ARRAY-TOTAL-SIZE OBJECT))
+                                      (VARRAY (COND
+                                                 ((> (CL:ARRAY-RANK OBJECT)
+                                                     1)
+                                                  (CL:MAKE-ARRAY ASIZE :DISPLACED-TO OBJECT))
+                                                 (T OBJECT]
+                                     (CL:DOTIMES (X ASIZE)
+                                         (PRINT-CIRCLE-SCAN (CL:AREF VARRAY X)))]))])
+
+(PRINT-CIRCLE-ENTER
+  [CL:LAMBDA (OBJECT)
+         (DECLARE (CL:SPECIAL *PRINT-CIRCLE-HASHTABLE* THERE-ARE-CIRCLES))
+                                                             (* ; "Edited 31-Mar-87 19:16 by jrb:")
+         (CASE (CL:GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)
+             ((NIL) 
+                (CL:SETF (CL:GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)
+                       'T1)
+                NIL)
+             (T1 
+                (CL:SETF (CL:GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)
+                       'T2)
+                (SETQ THERE-ARE-CIRCLES T)
+                T)
+             (T2 T)
+             (CL:OTHERWISE (CL:ERROR "Print-circle-enter hashtable error!")))])
+)
+(DEFINEQ
+
+(\PRINDATUM
+  [LAMBDA (OBJECT STREAM CPL)                                (* ; "Edited 11-Feb-91 14:34 by jds")
+    (DECLARE (USEDFREE *READTABLE* *PRINT-RADIX* *PRINT-BASE* *PRINT-ESCAPE*))
+    (SELECTC (NTYPX OBJECT)
+        ((LIST \LITATOM \NEW-ATOM) 
+             (\LITPRIN OBJECT STREAM))
+        (\LISTP 
+                (* ;; "macro call that uses the arguments already bound, to save a fn call.")
+
+                (\PRINDATUM-LISTP))
+        ((LIST \SMALLP \FIXP) 
+             (WITH-RESOURCES (\NUMSTR \NUMSTR1)
+                    (\CKPOSSOUT STREAM (\CONVERTNUMBER
+                                            OBJECT
+                                            (\CHECKRADIX *PRINT-BASE*)
+                                            T
+                                            (AND (if (fetch (READTABLEP COMMONLISP)
+                                                            of *READTABLE*)
+                                                     then 
+                                                             (* ; 
+                                                        "Common Lisp controlled solely by this var")
+                                                           *PRINT-RADIX*
+                                                   else  (* ; 
+                                          "Interlisp prints radix if it is not 10 and we are prin2")
+                                                         (AND *PRINT-ESCAPE* (NEQ *PRINT-BASE* 10)))
+                                                 *READTABLE*)
+                                            \NUMSTR \NUMSTR1))))
+        (\FLOATP [WITH-RESOURCES (\NUMSTR \NUMSTR1)
+                        (\CKPOSSOUT STREAM (\CONVERT.FLOATING.NUMBER OBJECT \NUMSTR \NUMSTR1
+                                                      (COND
+                                                         ((AND (PNAMESTREAMP STREAM)
+                                                               (NOT PRXFLG))
+
+                                    (* ;; "The pname of a number is unaffected by RADIX unless PRXFLG is true.  This seems silly, but assorted code will break otherwise")
+
+                                                          T)
+                                                         (T \FLOATFORMAT])
+        (\STACKP (\PRINSTACKP OBJECT STREAM))
+        (COND
+           ((STRINGP OBJECT)
+            (\PRINSTRING OBJECT STREAM))
+           ((TYPENAMEP OBJECT 'CL::STRUCTURE-OBJECT)
+
+            (* ;; "this is a structure, don't use defprint.")
+
+            (CL::PRINT-STRUCTURE-INSTANCE OBJECT STREAM CPL))
+           ((TYPENAMEP OBJECT 'T)
+
+            (* ;; 
+  "this is a common-loops object, since it is a sub-class of t, so call the print-instance method.")
+
+            (PRINT-INSTANCE OBJECT STREAM 0))
+           (T (\PRINT-USING-DEFPRINT OBJECT STREAM CPL])
+
+(\PRINT-USING-DEFPRINT
+  [LAMBDA (X STREAM CPL)                                     (* ; "Edited 18-Dec-86 12:22 by bvm:")
+    (DECLARE (USEDFREE *PRINT-LEVEL*))
+    (LET* ((TYPE (TYPENAME X))
+           (FN (FASSOC TYPE \DEFPRINTFNS)))
+          (COND
+             ([OR (NULL FN)
+                  (NULL (SETQ FN (LET [(*PRINT-LEVEL* (AND *PRINT-LEVEL* (IDIFFERENCE *PRINT-LEVEL*
+                                                                                (OR CPL 0]
+                                                             (* ; 
+                               "This way recursive calls to PRINT etc will be at the 'right' level")
+                                      (CL:FUNCALL (CDR FN)
+                                             X STREAM 0]
+
+              (* ;; "No defined printer, or printer declined to do anything")
+
+              (\PRINT-USING-ADDRESS X STREAM CPL))
+             ((LISTP FN)
+
+              (* ;; "PRIN1 the CAR (usually a macro char) and PRIN2 the CDR.  Nowadays there is little reason for a defprint fn to not do its own printing")
+
+              (AND (CAR FN)
+                   (LET (*PRINT-ESCAPE*)
+                        (\PRINDATUM (CAR FN)
+                               STREAM)))
+              (AND (CDR FN)
+                   (\PRINDATUM (CDR FN)
+                          STREAM CPL])
+
+(\PRINT-USING-ADDRESS
+  (CL:LAMBDA (X STREAM CPL)                                  (* ; "Edited 17-Oct-91 15:27 by jrb:")
+         (CL:BLOCK \PRINT-USING-ADDRESS
+             [LET ((TYPE (TYPENAME X)))
+                  (COND
+                     ((fetch (READTABLEP COMMONLISP) of *READTABLE*)
+                      (CL::CHECK-READABLY X)
+                      (.SPACECHECK. STREAM 2)
+                      (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))
+                      (\OUTCHAR STREAM (CHARCODE "<"))
+                      (AND TYPE (\LITPRIN TYPE STREAM))
+                      (\CKPOSSOUT STREAM " @ ")
+                      (\PRINTADDR X STREAM)
+                      (\CKPOSBOUT STREAM (CHARCODE ">")))
+                     (T (\CKPOSBOUT STREAM (CHARCODE {))
+                        (AND TYPE (\LITPRIN TYPE STREAM))
+                        (\CKPOSBOUT STREAM (CHARCODE }))
+                        (\OUTCHAR STREAM (CHARCODE "#"))
+                        (\PRINTADDR X STREAM]
+             T)))
+
+(\ELIDE.PRINT.ELEMENT
+  [LAMBDA (STREAM)                                           (* jrb%: "29-Jun-86 21:05")
+    (\OUTCHAR STREAM (\ELIDE.ELEMENT.CHAR])
+
+(\ELIDE.ELEMENT.CHAR
+  [LAMBDA NIL                                                (* jrb%: "29-Jun-86 21:04")
+    (COND
+       ((fetch (READTABLEP COMMONLISP) of *READTABLE*)
+        (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))
+       (T (CHARCODE "&"])
+
+(\ELIDE.PRINT.TAIL
+  [LAMBDA (STREAM NOSPACEP)                                  (* jrb%: "29-Jun-86 21:06")
+
+(* ;;; "Prints the appropriate elision indicator for elements beyond *PRINT-DEPTH* according to the read table we're using.  Prints first a space unless NOSPACEP")
+
+    [COND
+       ((NOT NOSPACEP)
+        (\OUTCHAR STREAM (CHARCODE SPACE]
+    (\SOUT (\ELIDE.TAIL.STRING)
+           STREAM])
+
+(\ELIDE.TAIL.STRING
+  [LAMBDA NIL                                                (* jrb%: "29-Jun-86 21:05")
+    (COND
+       ((fetch (READTABLEP COMMONLISP) of *READTABLE*)
+        "...")
+       (T "--"])
+
+(\CKPOSBOUT
+  [LAMBDA (STREAM X)                                         (* rmk%: "21-OCT-83 12:32")
+    (.SPACECHECK. STREAM 1)
+    (\OUTCHAR STREAM X])
+
+(\CKPOSSOUT
+  [LAMBDA (STREAM X)                                         (* rmk%: "21-OCT-83 12:32")
+    (.SPACECHECK. STREAM (\NSTRINGCHARS X))
+    (for I instring X do (\OUTCHAR STREAM I])
+
+(\CONVERTNUMBER
+  [LAMBDA (N R IGNORE RDTBL NS NSB)                          (* ; "Edited 18-Dec-86 17:53 by bvm:")
+
+(* ;;; "Convert integer N to a string in radix R.  RDTBL governs whether radix qualifiers appear.  NS is a scratch promised to be of sufficient length;  NSB is a scratch string pointer.  IGNORE is obsolete flag for printing unsigned numbers")
+
+    (LET* ((SIGN)
+           [MAGNITUDE (if (>= N 0)
+                          then N
+                        else (SETQ SIGN (IMINUS N]
+           (X MAGNITUDE)
+           (POS (\NSTRINGCHARS NS))
+           (END (SUB1 POS))
+           COMMONLISPY DIDQ)
+          (if RDTBL
+              then                                       (* ; 
+                                                           "do bletcherous suffix cases first")
+                    (if (SETQ COMMONLISPY (fetch (READTABLEP COMMONLISP) of RDTBL))
+                        then                             (* ; "decimal is suffix")
+                              (if (EQ R 10)
+                                  then (RPLCHARCODE NS (add END 1)
+                                                  (CHARCODE "."))
+                                        (SETQ DIDQ T))
+                      elseif (AND (EQ R 8)
+                                      (> MAGNITUDE 7))
+                        then                             (* ; "Octal numbers have Q suffix")
+                              (RPLCHARCODE NS (add END 1)
+                                     (CHARCODE Q))
+                              (SETQ DIDQ T)))
+          (repeatuntil (EQ X 0) do                   (* ; 
+                               "note this loop happens at least once, for benefit of MAGNITUDE = 0")
+                                          [RPLCHARCODE NS (add POS -1)
+                                                 (LET ((DIGIT (IREMAINDER X R)))
+                                                      (if (< DIGIT 10)
+                                                          then (+ DIGIT (CHARCODE 0))
+                                                        else 
+                                                             (* ; 
+                                 "For radices higher than 10, use letters of alphabet from A on up")
+                                                              (+ (- DIGIT 10)
+                                                                 (CHARCODE A]
+                                          (SETQ X (IQUOTIENT X R)))
+          (if SIGN
+              then (RPLCHARCODE NS (add POS -1)
+                              (CHARCODE -)))
+          (if [AND RDTBL (NOT DIDQ)
+                       (OR COMMONLISPY (AND (NEQ R 10)
+                                            (OR (> MAGNITUDE 9)
+                                                (>= MAGNITUDE R]
+              then 
+
+                    (* ;; "Prepend a radix qualifier if it wasn't already done as a suffix.  In Interlisp we don't do this if the radix is decimal or the number is smaller than the radix.")
+
+                    [SELECTQ R
+                        (16                                  (* ; "hex")
+                            (RPLCHARCODE NS (add POS -1)
+                                   (CHARCODE x)))
+                        (8                                   (* ; "octal")
+                           (RPLCHARCODE NS (add POS -1)
+                                  (CHARCODE o)))
+                        (2 (RPLCHARCODE NS (add POS -1)
+                                  (CHARCODE b)))
+                        (PROGN (RPLCHARCODE NS (add POS -1)
+                                      (CHARCODE r))
+                               (RPLCHARCODE NS (add POS -1)
+                                      (+ (CHARCODE 0)
+                                         (IREMAINDER R 10)))
+                               (if (>= R 10)
+                                   then                  (* ; "two-digit radix")
+                                         (RPLCHARCODE NS (add POS -1)
+                                                (+ (CHARCODE 0)
+                                                   (IQUOTIENT R 10]
+                    (RPLCHARCODE NS (add POS -1)
+                           (fetch (READTABLEP HASHMACROCHAR) of RDTBL)))
+          (SUBSTRING NS POS END NSB])
+
+(\LITPRIN
+  [LAMBDA (X STREAM)                                         (* ; "Edited 15-Aug-91 11:19 by jrb:")
+    (DECLARE (USEDFREE \THISFILELINELENGTH *PRINT-ESCAPE* *READTABLE* *PACKAGE* *PRINT-GENSYM* 
+                        *PRINT-CASE*))
+    (COND
+       (*PRINT-ESCAPE*
+        (LET ((RDTBL *READTABLE*)
+              PKG PKGSEPR)
+             [COND
+                (*PACKAGE*                                   (* ; 
+                                                         "This is NIL until packages get turned on")
+                 (COND
+                    ((EQ *PACKAGE* (SETQ PKG (fetch (CL:SYMBOL PACKAGE) of X)))
+                                                             (* ; 
+                                                           "No prefix needed in current package")
+                     (SETQ PKG NIL))
+                    [(NULL PKG)                              (* ; 
+                                                       "Uninterned.  Print something if flag is on")
+                     (COND
+                        (*PRINT-GENSYM*                      (* ; 
+       "Print  as prefix.  Not PACKAGECHAR here because colon hardwired into hashmacro dispatch.")
+                         [if *PRINT-CIRCLE-HASHTABLE*
+                             then 
+
+                                   (* ;; 
+                                 "*PRINT-CIRCLE-HASHTABLE* is only non-nil when *print-circle*.")
+
+                                   (CL:MULTIPLE-VALUE-BIND
+                                    (LABEL FIRSTTIME)
+                                    (PRINT-CIRCLE-LOOKUP X)
+                                    (if LABEL
+                                        then (\CKPOSSOUT STREAM LABEL)
+                                              (if (NOT FIRSTTIME)
+                                                  then (RETFROM '\LITPRIN X]
+                         (RPLCHARCODE (SETQ PKGSEPR (ALLOCSTRING 2 (CHARCODE ":")))
+                                1
+                                (fetch (READTABLEP HASHMACROCHAR) of RDTBL]
+                    ((EQ PKG *KEYWORD-PACKAGE*)              (* ; 
+                                                           "Keywords get single colon, no prefix")
+                     (SETQ PKGSEPR (ALLOCSTRING 1 (fetch (READTABLEP PACKAGECHAR) of RDTBL)))
+                     (SETQ PKG NIL))
+                    ((FIND-EXACT-SYMBOL X *PACKAGE*)
+
+                     (* ;; "Symbol is accessible in current package, either by being imported or by inheritance.  This is a messy test, which is why we test for special case of PKG being the current package first above.  No prefix needed here.")
+
+                     (SETQ PKG NIL))
+                    (T 
+                       (* ;; "Package qualifier is needed; we need only know now whether symbol is  internal or external in its home package.")
+
+                       (SETQ PKGSEPR (ALLOCSTRING (COND
+                                                     ((EQ X (FIND-EXTERNAL-SYMBOL X PKG))
+                                                             (* ; 
+                                                           "X is external in PKG, use single colon")
+                                                      1)
+                                                     (T 2))
+                                            (fetch (READTABLEP PACKAGECHAR) of RDTBL]
+             (\LITPRIN.INTERNAL X RDTBL STREAM (AND PKG (PACKAGE-NAME-AS-SYMBOL PKG))
+                    PKGSEPR \THISFILELINELENGTH)))
+       (T 
+          (* ;; "Used to be (.SPACECHECK. STREAM (\NATOMCHARS X)); expanded and check for EOL character in print-name of atom added- JRB")
+
+          (AND \THISFILELINELENGTH (IGREATERP (IPLUS (\NATOMCHARS X)
+                                                     (fetch CHARPOSITION of STREAM))
+                                          \THISFILELINELENGTH)
+               (\PNAME-CONTAINS-NO-EOL X (IDIFFERENCE \THISFILELINELENGTH (fetch CHARPOSITION
+                                                                                 of STREAM)))
+               (FRESHLINE STREAM))
+
+          (* ;; "Following code munged to match \LITPRIN.INTERNAL's handling of :CAPITALIZE")
+
+          (for C inatom X bind CAPLOWER CAPUPPER UPTODOWN DOWNTOUP WAS-ALPHA CHARTYPE 
+                                        CHARTYPEBASE
+             first 
+
+                   (* ;; 
+ "This mess encodes the requirements of *PRINT-CASE* x CL:READTABLE-CASE into the following flags:")
+
+                   (* ;; "CAPLOWER, CAPUPPER - :CAPITALIZE for upper and lower case, respectively (split because CL:READTABLE-CASE can make upper and lower case behave differently)")
+
+                   (* ;; 
+                 "UPTODOWN,  DOWNTOUP - Translate between upper and lower case, respectively")
+
+                   (* ;; "WAS-ALPHA - Previous char was alphanumeric, capitalize apropriately")
+
+                   (* ;; "CHARTYPE, CHARTYPEBASE - When CHARTYPEBASE is set, need to distinguish between upper, lower, numeric, and other characters; result is an integer in CHARTYPE")
+
+                   (AND (EQ *PRINT-CASE* :CAPITALIZE)
+                        (SETQ CAPLOWER T)
+                        (SETQ CAPUPPER T))
+                   (SELECTQ (CL:READTABLE-CASE *READTABLE*)
+                       (:PRESERVE (SETQ CAPLOWER NIL)
+                                  (SETQ CAPUPPER NIL))
+                       (:UPCASE (SELECTQ *PRINT-CASE*
+                                    (:DOWNCASE (SETQ UPTODOWN T))
+                                    (:CAPITALIZE (SETQ CAPLOWER NIL))
+                                    NIL))
+                       (:DOWNCASE (SELECTQ *PRINT-CASE*
+                                      (:UPCASE (SETQ DOWNTOUP T))
+                                      (:CAPITALIZE (SETQ CAPUPPER NIL))
+                                      NIL))
+                       (:INVERT                              (* ; "Have to prescan; YECCH!")
+                                (SETQ CAPLOWER NIL)
+                                (SETQ CAPUPPER NIL)
+                                (AND [NULL (CADR (CL:MULTIPLE-VALUE-LIST (\SYMBOL.ESCAPE.COUNT
+                                                                          X *READTABLE*]
+                                     (SETQ UPTODOWN T)
+                                     (SETQ DOWNTOUP T)))
+                       NIL)
+                   (if (OR UPTODOWN DOWNTOUP CAPLOWER CAPUPPER)
+                       then (SETQ CHARTYPEBASE (ffetch (ARRAYP BASE) of ALPHANUMCHARARRAY
+                                                          )))
+             do (if (AND CHARTYPEBASE (ILEQ C \MAXTHINCHAR)
+                                 (NOT (EQ (SETQ CHARTYPE (\GETBASEBYTE CHARTYPEBASE C))
+                                          0)))
+                        then                             (* ; "Vanilla character")
+                              (SELECTQ (\GETBASEBYTE CHARTYPEBASE C)
+                                  (1                         (* ; "Upper case")
+                                     [COND
+                                        ((OR UPTODOWN (AND CAPUPPER WAS-ALPHA))
+                                         (SETQ C (+ C (- (CHARCODE a)
+                                                         (CHARCODE A]
+                                     (SETQ WAS-ALPHA T))
+                                  (2                         (* ; "Lower case")
+                                     [COND
+                                        ((OR DOWNTOUP (AND CAPLOWER (NOT WAS-ALPHA)))
+                                         (SETQ C (- C (- (CHARCODE a)
+                                                         (CHARCODE A]
+                                     (SETQ WAS-ALPHA T))
+                                  (3                         (* ; "Numeric")
+                                     (SETQ WAS-ALPHA T))
+                                  (SETQ WAS-ALPHA NIL))
+                      else (SETQ WAS-ALPHA NIL))
+                   (\OUTCHAR STREAM C])
+
+(\LITPRIN.INTERNAL
+  [LAMBDA (SYMBOL RDTBL STREAM PKGNAME PKGSEPR CHECKLENGTH)  (* ; "Edited 15-Aug-91 11:18 by jrb:")
+
+(* ;;; "Print SYMBOL to STREAM according to RDTBL, preceded by PKGNAME (if non-NIL) and/or PKGSEPR.  PKGNAME is a symbol, PKGSEPR is a string.  If CHECKLENGTH is true, need to check that there is room for printing all three parts on this line;  else caller has verified that there is room")
+
+    (LET ((PNAMELENGTH (\NATOMCHARS SYMBOL))
+          (ESCAPE (fetch (READTABLEP ESCAPECHAR) of RDTBL))
+          (MULTESCAPE (fetch (READTABLEP MULTESCAPECHAR) of RDTBL))
+          USEMULTESCAPE CASEBASE PKGLEN SA NESCAPES MULTICASE CHECKESCAPE FIRSTESCAPE)
+         (if (OR (NEQ MULTESCAPE 0)
+                     CHECKLENGTH)
+             then                                        (* ; 
+                       "have to check now if linelength matters or we plan to use multiple escapes")
+                   (CL:MULTIPLE-VALUE-SETQ (NESCAPES MULTICASE)
+                          (\SYMBOL.ESCAPE.COUNT SYMBOL RDTBL (NULL CHECKLENGTH)))
+                   (if (EQ NESCAPES -1)
+                       then                              (* ; 
+        "Pname is numeric and we don't have a multiple escape available--need to escape first char")
+                             (SETQ NESCAPES 1)
+                             (SETQ FIRSTESCAPE T)
+                     elseif (< NESCAPES 0)
+                       then                              (* ; "Use multiple escapes")
+                             (SETQ NESCAPES (IMINUS NESCAPES))
+                             (SETQ USEMULTESCAPE T)
+                     elseif (NEQ NESCAPES 0)
+                       then (SETQ CHECKESCAPE T))
+           else                                          (* ; 
+                                          "if we don't check now then have to check while printing")
+                 (SETQ CHECKESCAPE T))
+         (if CHECKLENGTH
+             then                                        (* ; "Verify space for everything")
+
+                   (* ;; "Used to be (.SPACECHECK. STREAM (hairy-expression)); expanded and check for EOL character in print-name of atom added - JRB")
+
+                   (AND \THISFILELINELENGTH
+                        (IGREATERP (IPLUS PNAMELENGTH NESCAPES
+                                          (SETQ PKGLEN (IPLUS (if PKGNAME
+                                                                  then 
+                                                             (* ; 
+                                                           "How much space to print package name")
+                                                                        (IABS (\SYMBOL.ESCAPE.COUNT
+                                                                               PKGNAME RDTBL))
+                                                                else 0)
+                                                              (if PKGSEPR
+                                                                  then 
+                                                             (* ; 
+                                                "Extra characters between pkg name and symbol name")
+                                                                        (\NSTRINGCHARS PKGSEPR)
+                                                                else 0)))
+                                          (fetch CHARPOSITION of STREAM))
+                               \THISFILELINELENGTH)
+                        [\PNAME-CONTAINS-NO-EOL SYMBOL (IDIFFERENCE \THISFILELINELENGTH
+                                                                  (IPLUS PKGLEN (fetch 
+                                                                                       CHARPOSITION
+                                                                                   of STREAM]
+                        (FRESHLINE STREAM)))
+
+         (* ;; "First print any needed package qualifier")
+
+         (if PKGNAME
+             then                                        (* ; 
+                                                           "Print package name, don't check length")
+                   (\LITPRIN.INTERNAL PKGNAME RDTBL STREAM))
+         (if PKGSEPR
+             then (\SOUT PKGSEPR STREAM))
+         (if USEMULTESCAPE
+             then                                        (* ; 
+                           "Surround pname with multiple escape char, only escape internal escapes")
+                   (\OUTCHAR STREAM MULTESCAPE)
+                   (for C inatom SYMBOL do (if (OR (EQ C MULTESCAPE)
+                                                                   (EQ C ESCAPE))
+                                                           then (\OUTCHAR STREAM ESCAPE))
+                                                      (\OUTCHAR STREAM C))
+                   (\OUTCHAR STREAM MULTESCAPE)
+           else [if FIRSTESCAPE
+                        then                             (* ; 
+                  "Need an escape character at start to keep atom from being interpreted as number")
+                              (\OUTCHAR STREAM ESCAPE)
+                      elseif CHECKESCAPE
+                        then (if (AND (EQ PNAMELENGTH 1)
+                                              (EQ (CHCON1 SYMBOL)
+                                                  (CHARCODE ".")))
+                                     then                (* ; 
+                     "have to handle period special because it is only special in a dotted context")
+                                           (\OUTCHAR STREAM ESCAPE)
+                                           (SETQ CHECKESCAPE NIL)
+                                   else                  (* ; 
+                                      "prepare to check for escaping of chars in the printing loop")
+                                         (SETQ SA (fetch READSA of RDTBL] 
+
+                 (* ;; 
+               "There are a zillion flags bound and set below; their meanings are as follows:")
+
+                 (* ;; "FIRSTFLG - First time through the loop")
+
+                 (* ;; "CAPITALIZING - *PRINT-CASE* is :CAPITALIZE")
+
+                 (* ;; 
+ "WAS-ALPHA - Last char output was alphanumeric (thus current character should not be capitalized)")
+
+                 (* ;; "ESCUPPER and ESCLOWER - Upper/lower case characters should be escaped here")
+
+                 (* ;; 
+               "UPTODOWN and DOWNTOUP - Upper/lower case characters should be case-converted here")
+
+                 (* ;; "CHARTYPE - a character type number; 1=uppercase, 2=lowercase, 3=numeric")
+
+                 (for C inatom SYMBOL bind (FIRSTFLG _ T)
+                                                    (CAPITALIZING _ (EQ *PRINT-CASE* :CAPITALIZE))
+                                                    (CHARTYPEBASE _ (ffetch (ARRAYP BASE)
+                                                                       of ALPHANUMCHARARRAY))
+                                                    WAS-ALPHA ESCUPPER ESCLOWER UPTODOWN DOWNTOUP 
+                                                    CHARTYPE SYN
+                    first 
+
+                          (* ;; "This mess encodes the requirements of *PRINT-CASE* x CL:READTABLE-CASE into the flags ESCUPPER ESCLOWER UPTODOWN DOWNTOUP CAPITALIZING")
+
+                          (SELECTQ (CL:READTABLE-CASE RDTBL)
+                              (:PRESERVE (SETQ CAPITALIZING NIL))
+                              (:UPCASE (AND CHECKESCAPE (SETQ ESCLOWER T))
+                                       (AND (EQ *PRINT-CASE* :DOWNCASE)
+                                            (SETQ UPTODOWN T)))
+                              (:DOWNCASE (AND CHECKESCAPE (SETQ ESCUPPER T))
+                                         (AND (EQ *PRINT-CASE* :UPCASE)
+                                              (SETQ DOWNTOUP T)))
+                              (:INVERT (SETQ CAPITALIZING NIL)
+                                       (AND (NOT MULTICASE)
+                                            (SETQ UPTODOWN T)
+                                            (SETQ DOWNTOUP T)))
+                              NIL)
+                    do (if (AND (ILEQ C \MAXTHINCHAR)
+                                        (NOT (EQ (SETQ CHARTYPE (\GETBASEBYTE CHARTYPEBASE C))
+                                                 0)))
+                               then                      (* ; "Vanilla character")
+                                     [COND
+                                        [(EQ CHARTYPE 1)     (* ; "Upper case")
+                                         (COND
+                                            (ESCUPPER (\OUTCHAR STREAM ESCAPE))
+                                            ((OR UPTODOWN (AND CAPITALIZING WAS-ALPHA))
+                                             (SETQ C (+ C (- (CHARCODE a)
+                                                             (CHARCODE A]
+                                        ((EQ CHARTYPE 2)     (* ; "Lower case")
+                                         (COND
+                                            (ESCLOWER (\OUTCHAR STREAM ESCAPE))
+                                            ((OR DOWNTOUP (AND CAPITALIZING (NOT WAS-ALPHA)))
+                                             (SETQ C (- C (- (CHARCODE a)
+                                                             (CHARCODE A]
+                                     (SETQ WAS-ALPHA T)
+                             else (if (AND CHECKESCAPE (fetch (READCODE ESCQUOTE)
+                                                                  of (SETQ SYN (\SYNCODE SA C)))
+                                                   (OR FIRSTFLG (fetch (READCODE INNERESCQUOTE)
+                                                                   of SYN)))
+                                          then           (* ; 
+                                                           "Needs escaped for another reason")
+                                                (\OUTCHAR STREAM ESCAPE))
+                                   (SETQ WAS-ALPHA NIL))
+                          (\OUTCHAR STREAM C)
+                          (SETQ FIRSTFLG NIL])
+
+(\PNAME-CONTAINS-NO-EOL
+  [LAMBDA (A WITHIN)                                         (* ; "Edited 15-Aug-91 11:16 by jrb:")
+    (for C inatom A as I from 0 to (OR WITHIN 65535) by 1
+       never (EQ C (CHARCODE EOL])
+
+(\SYMBOL.ESCAPE.COUNT
+  [LAMBDA (SYMBOL RDTBL INEXACTOK)                           (* ; "Edited  3-Apr-91 10:47 by jrb:")
+
+(* ;;; "Counts the number of escape characters needed to print SYMBOL by RDTBL.  If RDTBL has a multiple-escape character, then we return a negative count if we're assuming it is used instead of single escapes;  else a positive count.  The special value -1 means the symbol is numeric, so must be quoted, but no multiple escape is available, so just escape the first character.  If INEXACTOK is true and we discover we want to use multiple escape char, returns -2 immediately.")
+
+(* ;;; "JRB - Added a little junk for support of (CL:READTABLE-CASE RDTBL) = :INVERT.  We return a second value of T if the current readtable-case is :INVERT and the symbol has both upper and lower cases in it.")
+
+    (LET
+     ((CASEBASE (READTABLE-CASEARRAY RDTBL))
+      CASECHECK UPPERSEEN LOWERSEEN MULTICASE)
+     (if (EQ (COMMON-LISP:READTABLE-CASE RDTBL)
+                 :INVERT)
+         then (SETQ CASEBASE NIL)
+               (SETQ CASECHECK T))
+     (for C inatom SYMBOL bind (RESULT _ 0)
+                                        (NESCAPES _ 0)
+                                        (FIRSTFLG _ T)
+                                        (MULTESCAPE _ (fetch (READTABLEP MULTESCAPECHAR)
+                                                         of RDTBL))
+                                        (ESCAPE _ (fetch (READTABLEP ESCAPECHAR) of RDTBL))
+                                        (SA _ (fetch READSA of RDTBL))
+                                        SYN first (if (EQ MULTESCAPE 0)
+                                                          then 
+                                                             (* ; "Can't use multiple-escape")
+                                                                (SETQ MULTESCAPE NIL))
+        do [if [OR (AND CASEBASE (ILEQ C \MAXTHINCHAR)
+                                (NEQ C (\GETBASEBYTE CASEBASE C)))
+                           (AND (fetch (READCODE ESCQUOTE) of (SETQ SYN (\SYNCODE SA C)))
+                                (OR FIRSTFLG (fetch (READCODE INNERESCQUOTE) of SYN]
+                   then 
+
+                         (* ;; "Need protection if char is lowercase in a case-insensitive read table or the read table says it needs it")
+
+                         (add RESULT 1)
+                         (if MULTESCAPE
+                             then (if (OR (EQ C MULTESCAPE)
+                                                  (EQ C ESCAPE))
+                                          then           (* ; 
+                                                          "These have to be escaped no matter what")
+                                                (add NESCAPES 1)
+                                        elseif (AND INEXACTOK (> (- RESULT NESCAPES)
+                                                                     1))
+                                          then           (* ; 
+   "If at least 2 chars need escaping, better to use multiple escape, and we can quit scanning now")
+                                                (RETURN -2]
+              (SETQ FIRSTFLG NIL)
+              [AND CASECHECK (OR MULTICASE (COND
+                                              ((AND (ILEQ C (CHARCODE z))
+                                                    (IGEQ C (CHARCODE a)))
+                                               (if UPPERSEEN
+                                                   then (SETQ MULTICASE T)
+                                                 else (SETQ LOWERSEEN T)))
+                                              ((AND (ILEQ C (CHARCODE Z))
+                                                    (IGEQ C (CHARCODE A)))
+                                               (if LOWERSEEN
+                                                   then (SETQ MULTICASE T)
+                                                 else (SETQ UPPERSEEN T]
+        finally (PROGN (SETQ RESULT
+                            (if (EQ RESULT 0)
+                                then                     (* ; 
+                                              "No funny chars, check for some other perverse cases")
+                                      (LET ((LEN (\NATOMCHARS SYMBOL)))
+                                           (if (EQ LEN 0)
+                                               then      (* ; 
+                      "The bletcherous null symbol.  Shouldn't be allowed to create this, grumble.")
+                                                     (if MULTESCAPE
+                                                         then 
+                                                             (* ; "Can print as ||")
+                                                               -2
+                                                       else 
+                                                             (* ; "Single escape can't work")
+                                                             0)
+                                             elseif (AND (EQ LEN 1)
+                                                             (EQ C (CHARCODE ".")))
+                                               then      (* ; 
+         "Special case, dot is always escaped when by itself, and prefer single escape to multiple")
+                                                     -1
+                                             elseif (\NUMERIC.PNAMEP
+                                                         SYMBOL
+                                                         (if (fetch (READTABLEP COMMONLISP)
+                                                                    of RDTBL)
+                                                             then *READ-BASE*
+                                                           else 10))
+                                               then 
+
+                                 (* ;; "Is numeric, must escape it.  Note that if pname is numeric, there can't be any special chars inside it needing escaping.  We wait until now to test numeric on the grounds that it is more likely we will print a symbol with escapable chars than one that is a potential number.")
+
+                                                     (if MULTESCAPE
+                                                         then 
+                                                             (* ; 
+                                                 "Nicer to use multiple escape around whole symbol")
+                                                               -2
+                                                       else 
+                                                             (* ; "Say to escape first char")
+                                                             -1)
+                                             else 0))
+                              elseif (AND MULTESCAPE (> (- RESULT NESCAPES)
+                                                            1))
+                                then 
+
+                                 (* ;; "The number of characters needing escaping, not counting the ones that have to be escaped in any case, is at least two.  Use two multiple-escapes and NESCAPES regular escapes for the internal escapes = -(NESCAPES+2) total extra characters")
+
+                                      (- -2 NESCAPES)
+                              else RESULT))
+                           (RETURN (if MULTICASE
+                                       then (CL:VALUES RESULT T)
+                                     else RESULT])
+
+(\NUMERIC.PNAMEP
+  [LAMBDA (SYMBOL RADIX)                                     (* ; "Edited 18-Dec-91 11:25 by jrb:")
+
+(* ;;; "True if the chars in SYMBOL are a potential number in RADIX, which defaults to the current read base (according to current read table)")
+
+    (LET* ((LASTCHARTYPE 'FIRST)
+           [EFFECTIVE-RADIX (OR RADIX (COND
+                                         ((fetch (READTABLEP COMMONLISP) of *READTABLE*)
+                                          *READ-BASE*)
+                                         (T 10]
+           (MAXALPHADIGIT (+ (CHARCODE A)
+                             (- EFFECTIVE-RADIX 11)))
+           SEENALPHADIGITS SEENDIGITS SEENDECPT SEENEXPONENT SEENTIGHTLETTERS SEEN-INVALID-SYNTAX)
+                                                             (* ; 
+                                        "If RADIX is bigger than 10, this allows alphabetic digits")
+          (for C inpname SYMBOL
+             do 
+
+                   (* ;; "The inpname is a nicety so it works on strings too (useful for testing) --- Note that we are assuming a partitioning of character space as follows: (--- + / decpt) (digits) (A-Z) (_ ^) (a-z)")
+
+                   [SETQ LASTCHARTYPE
+                    (COND
+                       [(< C (CHARCODE A))                   (* ; "Numeric or funny char")
+                        (COND
+                           ((< C (CHARCODE 0))
+                            (SELCHARQ C
+                                 ((- +)                      (* ; "Signs anywhere but end")
+                                      'SIGN)
+                                 ("." (COND
+                                         (SEENALPHADIGITS 
+
+                                  (* ;; "Can't have decimal point in other radices, so if we saw combinations of chars that would have been invalid in radix 10, bomb out")
+
+                                                (COND
+                                                   (SEENTIGHTLETTERS (RETURN NIL)))
+                                                (SETQ SEENALPHADIGITS NIL))
+                                         (SEENDECPT          (* ; "Can't have 2 decimal points")
+                                                (SETQ SEEN-INVALID-SYNTAX T)))
+                                      (SETQ MAXALPHADIGIT 0)
+                                      (SETQ SEENDECPT T))
+                                 (/ (COND
+                                       ((EQ LASTCHARTYPE 'FIRST)
+                                                             (* ; "Can't start with ratio marker")
+                                        (RETURN NIL))))
+                                 (RETURN NIL)))
+                           ((<= C (CHARCODE 9))              (* ; "digit")
+                            (SETQ SEENDIGITS T)
+                            'DIGIT)
+                           (T (RETURN NIL]
+                       ((> C (CHARCODE z))                   (* ; "Out in the wilderness.")
+                        (RETURN NIL))
+                       ((PROGN [COND
+                                  ((>= C (CHARCODE a))       (* ; "Raise it")
+                                   (SETQ C (- C (- (CHARCODE a)
+                                                   (CHARCODE A]
+                               (<= C (CHARCODE Z)))          (* ; "Letter")
+                        [COND
+                           ((<= C MAXALPHADIGIT)             (* ; 
+                        "Letter is a digit in this base.  Can't be digit in number with decimal pt")
+                            (COND
+                               (SEENDECPT 
+
+                                      (* ;; "If there was a decimal point earlier, bail out.")
+
+                                      (RETURN NIL)))
+                            (SETQ SEENALPHADIGITS T)
+                            (SELECTQ LASTCHARTYPE
+                                ((LETTER FIRST)              (* ; 
+           "Two letters in a row or started with letter.  Notice this in case a dec pt comes along")
+                                     (SETQ SEENTIGHTLETTERS T))
+                                NIL))
+                           (T                                (* ; 
+                                                      "Potential exponent marker, only in radix 10")
+                              (OR (IEQP 10 EFFECTIVE-RADIX)
+                                  (RETURN NIL))
+                              (AND SEENEXPONENT (RETURN NIL))
+                              (SELECTQ LASTCHARTYPE
+                                  ((LETTER FIRST) 
+                                       (RETURN NIL))
+                                  (COND
+                                     ((FMEMB C (CHARCODE (E S F D L)))
+                                      (SETQ SEENEXPONENT T))
+                                     (T (RETURN NIL]
+                        'LETTER)
+                       ((OR (EQ C (CHARCODE "_"))
+                            (EQ C (CHARCODE "^")))           (* ; 
+                "Extension chars, not used now but maybe some day.  We're supposed to escape these")
+                        NIL)
+                       (T (RETURN NIL]
+             finally                                     (* ; "Success if there was at least one digit and didn't end in a sign.  Also true if symbol consisted solely of periods.")
+                   (RETURN (OR (AND (NOT SEEN-INVALID-SYNTAX)
+                                    (OR SEENDIGITS SEENALPHADIGITS)
+                                    (NEQ LASTCHARTYPE 'SIGN))
+                               (AND SEENDECPT (EQ LASTCHARTYPE T)
+                                    (for C inpname SYMBOL always (EQ C (CHARCODE "."])
+
+(\PRINSTACKP
+  [LAMBDA (X STREAM)                                         (* bvm%: "11-May-86 16:09")
+
+(* ;;; 
+"Print stackp as addr/framename.  If stackp is released or framename is not a symbol, print mumble")
+
+    (.SPACECHECK. STREAM (IPLUS 1 (CONSTANT (NCHARS "<StackP "))
+                                (PROGN                       (* ; 
+                                                           "Longest stack address is '177,177777'")
+                                       10)
+                                1
+                                (COND
+                                   ((RELSTKP X)
+                                    (CONSTANT (NCHARS "released")))
+                                   ((LITATOM (STKNAME X))
+                                    (\NATOMCHARS (STKNAME X)))
+                                   (T 6))
+                                1))
+    (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))
+    (\SOUT "<StackP " STREAM)
+    (\PRINTADDR X STREAM)
+    (\OUTCHAR STREAM (CHARCODE /))
+    (COND
+       ((RELSTKP X)
+        (\SOUT "released" STREAM))
+       ((LITATOM (SETQ X (STKNAME X)))
+        (\LITPRIN X STREAM))
+       (T (\SOUT "*form*" STREAM)))
+    (\OUTCHAR STREAM (CHARCODE >])
+
+(\PRINTADDR
+  [LAMBDA (X STREAM)                                         (* bvm%: "11-May-86 15:13")
+    (WITH-RESOURCES (\NUMSTR \NUMSTR1)
+           (SELECTQ (SYSTEMTYPE)
+               (D (\CKPOSSOUT STREAM (\CONVERTNUMBER (\HILOC X)
+                                                8 NIL NIL \NUMSTR \NUMSTR1))
+                  (\CKPOSBOUT STREAM (CHARCODE %,))
+                  (\CKPOSSOUT STREAM (\CONVERTNUMBER (\LOLOC X)
+                                                8 NIL NIL \NUMSTR \NUMSTR1)))
+               (JERICHO (\CKPOSSOUT STREAM (\CONVERTNUMBER (LOGAND \ADDRMASK (LOC X))
+                                                      8 NIL NIL \NUMSTR \NUMSTR1)))
+               (VAX (\CKPOSSOUT STREAM (\CONVERTNUMBER (LOC X)
+                                                  16 T NIL \NUMSTR \NUMSTR1)))
+               ((TENEX TOPS-20) 
+                    (\CKPOSSOUT STREAM (\CONVERTNUMBER (LOC X)
+                                                  8 T NIL \NUMSTR \NUMSTR1)))
+               (SYSTEMTYPEPUNT '(\PRINDATUM X])
+
+(\PRINSTRING
+  [LAMBDA (X STREAM)                                         (* bvm%: "11-May-86 15:08")
+    (COND
+       [*PRINT-ESCAPE*                                       (* ; 
+                                                   "Print with double quotes and escaped as needed")
+              (LET ((ESC (fetch (READTABLEP ESCAPECHAR) of *READTABLE*)))
+                   [.SPACECHECK. STREAM (IPLUS 2 (\NSTRINGCHARS X)
+                                               (for C instring X
+                                                  count (OR (EQ C (CHARCODE %"))
+                                                                (EQ C ESC]
+                   (\OUTCHAR STREAM (CHARCODE %"))
+                   (for C instring X do (COND
+                                                       ((OR (EQ C (CHARCODE %"))
+                                                            (EQ C (CHARCODE LF))
+                                                            (EQ C ESC))
+                                                             (* ; 
+                                     "VM says only %" is escaped no matter what stringdelim's are.")
+                                                        (\OUTCHAR STREAM ESC)))
+                                                   (\OUTCHAR STREAM C))
+                   (\OUTCHAR STREAM (CHARCODE %"]
+       (T (.SPACECHECK. STREAM (\NSTRINGCHARS X))
+          (\SOUT X STREAM])
+
+(\SOUT
+  [LAMBDA (X STREAM)                                         (* ; "Edited 14-Dec-88 22:17 by jds")
+
+    (* ;; "Print the string X onto STREAM, which -must- be a stream.")
+
+    (DECLARE (GLOBALVARS \DISPLAYSTREAMTYPES))
+    (DECLARE (SPECVARS *DRIBBLE-OUTPUT* \PRIMTERMSA \TERM.OFD))
+    (COND
+       [(FMEMB (ffetch (IMAGEOPS IMAGETYPE) of (fetch (STREAM IMAGEOPS) of STREAM))
+               \DISPLAYSTREAMTYPES)
+        (LET ((*DRIBBLE-OUTPUT* *DRIBBLE-OUTPUT*)
+              (\PRIMTERMSA \PRIMTERMSA)
+              (\TERM.OFD \TERM.OFD))
+             (for I instring X do (\OUTCHAR STREAM I]
+       ((for I instring X do (\OUTCHAR STREAM I])
+
+(\OUTCHAR
+  [LAMBDA (STREAM CHARCODE)                                  (* rmk%: " 7-APR-82 00:25")
+    (STREAMOP 'OUTCHARFN STREAM STREAM CHARCODE])
+)
+(DEFINEQ
+
+(\FILEOUTCHARFN
+  [LAMBDA (ST CHARCODE)                                      (* ; "Edited 25-Feb-91 17:15 by nm")
+    (\XCCSFILEOUTCHARFN ST CHARCODE])
+
+(\JISFILEOUTCHARFN
+  [LAMBDA (OUTSTREAM CHARCODE)                               (* ; "Edited 11-Mar-91 11:49 by nm")
+
+(* ;;; "Encoder for JIS format.")
+
+    (COND
+       ((EQ CHARCODE (CHARCODE EOL))
+        (COND
+           ((\KIMODEP OUTSTREAM NIL)
+            (\OUTKO OUTSTREAM)
+            (\CHNAGE.KI.MODE OUTSTREAM NIL NIL)))
+        (\BOUT OUTSTREAM (SELECTC (ffetch EOLCONVENTION of OUTSTREAM)
+                             (CR.EOLC (CHARCODE CR))
+                             (LF.EOLC (CHARCODE LF))
+                             (CRLF.EOLC (\BOUT OUTSTREAM (CHARCODE CR))
+
+                                 (* ;; "Don't put out high-order byte preceding LF.  The CRLF is EOL only if the bytes are immediately adjacent in the stream, with no additional encoding bytes")
+
+                                        (CHARCODE LF))
+                             (SHOULDNT)))
+        (freplace CHARPOSITION of OUTSTREAM with 0))
+       (T (SETQ CHARCODE (\CONV.XCCS.TO.JIS OUTSTREAM CHARCODE))
+                                                             (* ; 
+          "\CONV.XCCS.TO.JIS converts ZENKAKUKATAKANA to HANKAKUKATAKANA if the stream desires it.")
+          (COND
+             ((> CHARCODE 255)
+              (COND
+                 ((NOT (\KIMODEP OUTSTREAM NIL))
+                  (\OUTKI OUTSTREAM)
+                  (\CHNAGE.KI.MODE OUTSTREAM NIL T)))
+              (\BOUT OUTSTREAM (\CHARSET CHARCODE))
+              (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE)))
+             (T                                              (* ; "ASCII or HANKAKUKATAKANA")
+                (COND
+                   ((\KIMODEP OUTSTREAM NIL)
+                    (\OUTKO OUTSTREAM)
+                    (\CHNAGE.KI.MODE OUTSTREAM NIL NIL)))
+                (\BOUT OUTSTREAM CHARCODE)))
+          (freplace CHARPOSITION of OUTSTREAM with (PROGN 
+                                                             (* ; "Ugh.  Don't overflow")
+                                                                      (IPLUS16 (ffetch 
+                                                                                      CHARPOSITION
+                                                                                  of OUTSTREAM)
+                                                                             1])
+
+(\SHIFTJISFILEOUTCHARFN
+  [LAMBDA (OUTSTREAM CHARCODE)                               (* ; "Edited  7-Mar-91 21:55 by nm")
+
+(* ;;; "Encoder for Shift-JIS format.")
+
+    (COND
+       ((EQ CHARCODE (CHARCODE EOL))
+        (\BOUT OUTSTREAM (SELECTC (ffetch EOLCONVENTION of OUTSTREAM)
+                             (CR.EOLC (CHARCODE CR))
+                             (LF.EOLC (CHARCODE LF))
+                             (CRLF.EOLC (\BOUT OUTSTREAM (CHARCODE CR))
+
+                                 (* ;; "Don't put out high-order byte preceding LF.  The CRLF is EOL only if the bytes are immediately adjacent in the stream, with no additional encoding bytes")
+
+                                        (CHARCODE LF))
+                             (SHOULDNT)))
+        (freplace CHARPOSITION of OUTSTREAM with 0))
+       (T (SETQ CHARCODE (\CONV.XCCS.TO.JIS OUTSTREAM CHARCODE))
+                                                             (* ; 
+          "\CONV.XCCS.TO.JIS converts ZENKAKUKATAKANA to HANKAKUKATAKANA if the stream desires it.")
+          (COND
+             [(> CHARCODE 255)
+              (LET ((CH1 (FOLDLO CHARCODE 256))
+                    (CH2 (LOGAND CHARCODE 255)))
+                   (\CONV.JIS.TO.SJIS CH1 CH2)
+                   (COND
+                      ((AND (< CH1 256)
+                            (< CH2 256))
+                       (\BOUT OUTSTREAM CH1)
+                       (\BOUT OUTSTREAM CH2]
+             (T (\BOUT OUTSTREAM CHARCODE)))
+          (freplace CHARPOSITION of OUTSTREAM with (PROGN 
+                                                             (* ; "Ugh.  Don't overflow")
+                                                                      (IPLUS16 (ffetch 
+                                                                                      CHARPOSITION
+                                                                                  of OUTSTREAM)
+                                                                             1])
+
+(\EUCFILEOUTCHARFN
+  [LAMBDA (OUTSTREAM CHARCODE)                               (* ; "Edited 11-Mar-91 11:29 by nm")
+
+(* ;;; "Encoder for EUC format.")
+
+    (COND
+       ((EQ CHARCODE (CHARCODE EOL))
+        (\BOUT OUTSTREAM (SELECTC (ffetch EOLCONVENTION of OUTSTREAM)
+                             (CR.EOLC (CHARCODE CR))
+                             (LF.EOLC (CHARCODE LF))
+                             (CRLF.EOLC (\BOUT OUTSTREAM (CHARCODE CR))
+
+                                 (* ;; "Don't put out high-order byte preceding LF.  The CRLF is EOL only if the bytes are immediately adjacent in the stream, with no additional encoding bytes")
+
+                                        (CHARCODE LF))
+                             (SHOULDNT)))
+        (freplace CHARPOSITION of OUTSTREAM with 0))
+       (T (SETQ CHARCODE (\CONV.XCCS.TO.JIS OUTSTREAM CHARCODE))
+                                                             (* ; 
+          "\CONV.XCCS.TO.JIS converts ZENKAKUKATAKANA to HANKAKUKATAKANA if the stream desires it.")
+          (COND
+             ((> CHARCODE 255)                               (* ; "KANJI or GAIJI")
+              (AND (NOT (\NOTGAIJIP CHARCODE))
+                   (\BOUT OUTSTREAM 143))
+              (\BOUT OUTSTREAM (LOGOR (\CHARSET CHARCODE)
+                                      128))
+              (\BOUT OUTSTREAM (LOGOR (\CHAR8CODE CHARCODE)
+                                      128)))
+             ((\HANKAKUP CHARCODE)
+              (\BOUT OUTSTREAM 142)
+              (\BOUT OUTSTREAM (LOGOR CHARCODE 128)))
+             (T                                              (* ; "C0, C1, SP, DEL or G0")
+                (\BOUT OUTSTREAM CHARCODE)))
+          (freplace CHARPOSITION of OUTSTREAM with (PROGN 
+                                                             (* ; "Ugh.  Don't overflow")
+                                                                      (IPLUS16 (ffetch 
+                                                                                      CHARPOSITION
+                                                                                  of OUTSTREAM)
+                                                                             1])
+
+(\THROUGHFILEOUTCHARFN
+  [LAMBDA (OUTSTREAM CHARCODE)                               (* ; "Edited 26-Feb-91 13:44 by nm")
+
+(* ;;; "Encoder for THROUGH format.")
+
+    (COND
+       ((> CHARCODE 255)
+        (\BOUT OUTSTREAM (\CHARSET CHARCODE))
+        (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE)))
+       (T (\BOUT OUTSTREAM CHARCODE])
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS .FILELINELENGTH. MACRO ((STRM)
+                                          (LET ((L (fetch (STREAM LINELENGTH) of STRM)))
+                                               (SELECTC L
+                                                   (0        (* Some default)
+                                                      \LINELENGTH)
+                                                   (MAX.SMALLP 
+                                                             (* Infinite)
+                                                               NIL)
+                                                   L))))
+)
+
+
+(DEFMACRO \PRINDATUM-LISTP ()
+
+   (* ;; "This is a hokey macro call to save the function call.  Read it as though it were inline code in \prindatum")
+
+   `[LET (LABEL FIRSTTIME)
+         (OR CPL (SETQ CPL 0))
+         (if *PRINT-CIRCLE-HASHTABLE*
+             then 
+
+                   (* ;; "*PRINT-CIRCLE-HASHTABLE* is only non-nil when *print-circle*.")
+
+                   (CL:MULTIPLE-VALUE-SETQ (LABEL FIRSTTIME)
+                          (PRINT-CIRCLE-LOOKUP OBJECT)))
+         [if LABEL
+             then (\CKPOSSOUT STREAM LABEL)
+                   (CL:WHEN FIRSTTIME
+                       (\CKPOSBOUT STREAM (CHARCODE SPACE)))]
+         (COND
+            ((AND LABEL (NOT FIRSTTIME))                     (* ; 
+                                                           "Second reference --- just print label")
+             NIL)
+            ((AND *PRINT-LEVEL* (ILEQ *PRINT-LEVEL* CPL))
+             (\ELIDE.PRINT.ELEMENT STREAM))
+            (T (PROG (CDRCNT)
+                     [COND
+                        (*PRINT-LENGTH* (SETQ CDRCNT (COND
+                                                        ((fetch (READTABLEP COMMONLISP)
+                                                            of *READTABLE*)
+                                                         0)
+                                                        (T   (* ; 
+                                           "Interlisp print depth is triangular, Common Lisp isn't")
+                                                           [COND
+                                                              ((IGEQ CPL *PRINT-LENGTH*)
+                                                             (* ; 
+                                            "We would just print '(--)' so it's nicer to print '&'")
+                                                               (RETURN (\ELIDE.PRINT.ELEMENT
+                                                                        STREAM]
+                                                           CPL]
+                     (add CPL 1)                         (* ; 
+                                                       "Recursive calls will be at 1 greater depth")
+                     (\CKPOSBOUT STREAM (CHARCODE %())
+                 LP  [COND
+                        ((AND CDRCNT (IGREATERP (add CDRCNT 1)
+                                            *PRINT-LENGTH*)) (* ; 
+                                                         "have printed as many elements as allowed")
+                         (\ELIDE.PRINT.TAIL STREAM T))
+                        (T (\PRINDATUM (CAR OBJECT)
+                                  STREAM CPL)
+                           (COND
+                              ((LISTP (SETQ OBJECT (CDR OBJECT)))
+                               (\CKPOSBOUT STREAM (CHARCODE SPACE))
+                               (if (AND *PRINT-CIRCLE-HASHTABLE* (PRINT-CIRCLE-LABEL-P OBJECT
+                                                                            ))
+                                   then                  (* ; "Must print as a dotted tail")
+                                         (\CKPOSSOUT STREAM ". ")
+                                         (\PRINDATUM OBJECT STREAM CPL)
+                                 else (GO LP)))
+                              (OBJECT                        (* ; "Dotted tail")
+                                     (\CKPOSSOUT STREAM " . ")
+                                     (\PRINDATUM OBJECT STREAM]
+                     (\CKPOSBOUT STREAM (CHARCODE ")"])
+
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS .SPACECHECK. MACRO ((STRM N)
+                                      (AND \THISFILELINELENGTH (IGREATERP (IPLUS N
+                                                                                 (fetch 
+                                                                                        CHARPOSITION
+                                                                                    of STRM))
+                                                                      \THISFILELINELENGTH)
+                                           (FRESHLINE STRM))))
+
+(PUTPROPS \CHECKRADIX MACRO [LAMBDA (R)
+                                      (COND
+                                         ((OR (NOT (SMALLP R))
+                                              (ILESSP R 1)
+                                              (IGREATERP R 36))
+                                          (\INVALID.RADIX R))
+                                         (T R])
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \XCCSFILEOUTCHARFN MACRO [(OUTSTREAM CHARCODE)
+                                            (COND
+                                               ((EQ CHARCODE (CHARCODE EOL))
+                                                [COND
+                                                   [(NOT (\RUNCODED OUTSTREAM))
+                                                    (\BOUT OUTSTREAM (\CHARSET (CHARCODE EOL]
+                                                   ((EQ (\CHARSET (CHARCODE EOL))
+                                                        (ffetch (STREAM CHARSET) of OUTSTREAM
+                                                               )))
+                                                   (T (\BOUT OUTSTREAM NSCHARSETSHIFT)
+                                                      (\BOUT OUTSTREAM (freplace (STREAM CHARSET)
+                                                                          of OUTSTREAM
+                                                                          with
+                                                                          (\CHARSET (CHARCODE EOL]
+                                                (\BOUT OUTSTREAM (SELECTC (ffetch EOLCONVENTION
+                                                                             of OUTSTREAM)
+                                                                     (CR.EOLC (CHARCODE CR))
+                                                                     (LF.EOLC (CHARCODE LF))
+                                                                     (CRLF.EOLC (\BOUT OUTSTREAM
+                                                                                       (CHARCODE
+                                                                                        CR))
+                                                                                (CHARCODE LF))
+                                                                     (SHOULDNT)))
+                                                (freplace CHARPOSITION of OUTSTREAM
+                                                   with 0))
+                                               (T [COND
+                                                     ((NOT (\RUNCODED OUTSTREAM))
+                                                      (\BOUT OUTSTREAM (\CHARSET CHARCODE))
+                                                      (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE)))
+                                                     ((EQ (\CHARSET CHARCODE)
+                                                          (ffetch (STREAM CHARSET) of 
+                                                                                            OUTSTREAM
+                                                                 ))
+                                                      (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE)))
+                                                     (T (\BOUT OUTSTREAM NSCHARSETSHIFT)
+                                                        (\BOUT OUTSTREAM (freplace (STREAM 
+                                                                                              CHARSET
+                                                                                              )
+                                                                            of OUTSTREAM
+                                                                            with (\CHARSET 
+                                                                                            CHARCODE)
+                                                                                ))
+                                                        (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE]
+                                                  (freplace CHARPOSITION of OUTSTREAM
+                                                     with (PROGN (IPLUS16 (ffetch 
+                                                                                     CHARPOSITION
+                                                                                 of OUTSTREAM)
+                                                                            1])
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+(DEFINEQ
+
+(\INVALID.RADIX
+  [LAMBDA (N)                                                (* bvm%: " 5-May-86 10:58")
+    (ERROR "Bad value for *print-base*" N])
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(SPECVARS \THISFILELINELENGTH)
+)
+
+
+
+(* ; "Internal printing")
+
+(DEFINEQ
+
+(\MAPPNAME
+  [LAMBDA (FN X FLG RDTBL *PRINT-LEVEL* *PRINT-LENGTH*)      (* ; "Edited 23-Mar-87 11:01 by bvm:")
+
+(* ;;; "Run thru the characters in the pname of X, calling FN on each character.  For speed, FN is defined to be of the same form as an OUTCHARFN, viz., arglist = (stream char);  stream in this case is a dummy")
+
+    (LET [(*READTABLE* (if FLG
+                           then (\GTREADTABLE RDTBL)
+                         else (\DTEST *READTABLE* 'READTABLEP]
+         (LET ((*PACKAGE* (if (AND FLG (fetch (READTABLEP USESILPACKAGE) of *READTABLE*))
+                              then *INTERLISP-PACKAGE*
+                            else *PACKAGE*))
+               (*PRINT-ESCAPE* FLG)
+               (*PRINT-BASE* (if (OR FLG PRXFLG)
+                                 then *PRINT-BASE*
+                               else 10))
+               (*PRINT-RADIX* (AND FLG *PRINT-RADIX*)))
+              (\MAPPNAME.INTERNAL FN X])
+
+(\MAPPNAME.INTERNAL
+  [LAMBDA (FN X)                                             (* bvm%: "13-May-86 15:01")
+    (WITH-RESOURCE (\MAPPNAMESTREAM)
+           (replace OUTCHARFN of \MAPPNAMESTREAM with FN)
+           (replace STRMBOUTFN of \MAPPNAMESTREAM with FN)
+                                                             (* ; 
+       "Should never use the bout fn, but include it just in case somebody thinks \OUTCHAR = \BOUT")
+           (LET (\THISFILELINELENGTH)                        (* ; "Stream has no linelength checks")
+                (DECLARE (SPECVARS \THISFILELINELENGTH))
+                (\PRINDATUM X \MAPPNAMESTREAM 0])
+
+(PNAMESTREAMP
+  [LAMBDA (STRM)                                             (* bvm%: "24-Mar-86 17:37")
+
+(* ;;; "True if STRM is an internal-printing stream for pnames, i.e., one of the values of the \MAPPNAMESTREAM resource")
+
+    (AND (TYPENAMEP STRM 'STREAM)
+         (EQ (fetch (STREAM DEVICE) of STRM)
+             \PNAMEDEVICE])
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+[PUTDEF '\MAPPNAMESTREAM 'RESOURCES
+       '(NEW (create STREAM
+                    DEVICE _ \PNAMEDEVICE
+                    ACCESSBITS _ OutputBits
+                    LINELENGTH _ MAX.SMALLP]
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS PNAMESTREAMP DMACRO ((STRM)
+                                       (EQ (fetch (STREAM DEVICE) of STRM)
+                                           \PNAMEDEVICE)))
+)
+)
+
+(/SETTOPVAL '\\MAPPNAMESTREAM.GLOBALRESOURCE NIL)
+
+(RPAQ? \PNAMEDEVICE (NCREATE 'FDEV (\GETDEVICEFROMHOSTNAME 'NULL T)))
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \PNAMEDEVICE)
+)
+
+
+
+(* ; "Obsolete")
+
+(DEFINEQ
+
+(\MAPCHARS
+  [LAMBDA (\MAPCHARFN X FLG RDTBL)                           (* bvm%: "13-Mar-86 18:53")
+    (DECLARE (SPECVARS RDTBL))
+
+(* ;;; "Run thru the characters in the pname of X, calling \MAPCHARFN on each character.")
+
+    (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CHAR)
+                               (SPREADAPPLY* \MAPCHARFN CHAR]
+           X FLG RDTBL])
+)
+(DECLARE%: EVAL@COMPILE DOCOPY 
+
+(ADDTOVAR SYSSPECVARS *PRINT-BASE* *READ-BASE* *READ-EVAL* *PRINT-RADIX* *PRINT-ESCAPE* 
+                                *PRINT-CASE* *PRINT-GENSYM* *PRINT-LEVEL* *PRINT-LENGTH* 
+                                *PRINT-PRETTY* *PRINT-CIRCLE* *PRINT-ARRAY* *PACKAGE* 
+                                *CLTL2-PEDANTIC*)
+)
+
+
+
+(* ; "PRINTNUM and friends")
+
+(DEFINEQ
+
+(PRINTNUM
+  [LAMBDA (FORMAT NUMBER FILE)                               (* DECLARATIONS%: (RECORD FIXFMT
+                                                           (WIDTH RADIX PAD0 LEFTFLUSH))
+                                                           (RECORD FLOATFMT (WIDTH DECPART 
+                                                           EXPPART PAD0 SIGDIGITS)))
+                                                             (* rmk%: "17-MAY-82 10:07")
+    (DECLARE (GLOBALVARS NILNUMPRINTFLG))
+    (GLOBALRESOURCE (\NUMSTR \NUMSTR1)
+           (PROG (STR WIDTH PAD TEMP RAD (FLOATFLAG (SELECTQ (CAR (LISTP FORMAT))
+                                                        (FLOAT T)
+                                                        (FIX NIL)
+                                                        (LISPERROR "ILLEGAL ARG" FORMAT)))
+                      (FMT (CDR FORMAT)))
+                 (SETQ WIDTH (fetch WIDTH of FMT))
+                 [SETQ STR (COND
+                              ((AND (NULL NUMBER)
+                                    NILNUMPRINTFLG))
+                              (FLOATFLAG (\CONVERT.FLOATING.NUMBER (FLOAT NUMBER)
+                                                \NUMSTR \NUMSTR1 (\CHECKFLTFMT FORMAT)))
+                              (T (\CONVERTNUMBER (OR (FIXP NUMBER)
+                                                         (FIXR NUMBER))
+                                        (COND
+                                           ((SETQ RAD (fetch RADIX of FMT))
+                                            (SETQ TEMP (IABS RAD))
+                                            (COND
+                                               ((OR (IGREATERP 2 TEMP)
+                                                    (IGREATERP TEMP 16))
+                                                (\ILLEGAL.ARG RAD)))
+                                            TEMP)
+                                           (T 10))
+                                        (OR (NULL RAD)
+                                            (IGREATERP RAD 0))
+                                        NIL \NUMSTR \NUMSTR1]
+                 (SETQ PAD (COND
+                              (WIDTH (IDIFFERENCE WIDTH (NCHARS STR)))
+                              (T 0)))
+                 [COND
+                    ([AND (IGREATERP PAD 0)
+                          (OR FLOATFLAG (NULL (fetch LEFTFLUSH of FMT]
+                     (COND
+                        ((COND
+                            (FLOATFLAG (fetch (FLOATFMT PAD0) of FMT))
+                            (T (fetch (FIXFMT PAD0) of FMT)))
+                         (FRPTQ PAD (PRIN1 "0" FILE)))
+                        (T (SPACES PAD FILE]
+                 (PRIN1 STR FILE)
+                 (COND
+                    ((AND (IGREATERP PAD 0)
+                          (NOT FLOATFLAG)
+                          (fetch LEFTFLUSH of FMT))
+                     (SPACES PAD FILE)))
+                 (RETURN NUMBER])
+
+(FLTFMT
+  [LAMBDA (FORMAT)                                           (* bvm%: "30-JAN-81 23:20")
+                                                             (* ; 
+                                                           "numeric arg, as on 10, not allowed")
+    (PROG1 \FLOATFORMAT
+        (AND FORMAT (\CHECKFLTFMT FORMAT)
+             (SETQ \FLOATFORMAT FORMAT)))])
+
+(\CHECKFLTFMT
+  [LAMBDA (FORMAT)                                           (* bvm%: "29-JAN-81 15:41")
+
+(* ;;; 
+"Generates error if FORMAT is not legal FLOAT format: (FLOAT WIDTH DECPART EXPPART PAD SIGDIGITS)")
+
+    (COND
+       ([OR (EQ FORMAT T)
+            (AND (EQ (CAR FORMAT)
+                     'FLOAT)
+                 (EVERY (CDR FORMAT)
+                        (FUNCTION (LAMBDA (X)
+                                    (OR (NULL X)
+                                        (FIXP X]
+        FORMAT)
+       (T (LISPERROR "ILLEGAL ARG" FORMAT])
+
+(PRINTNUM-TO-STRING
+  [LAMBDA (FORMAT NUMBER)                                    (* DECLARATIONS%: (RECORD FIXFMT
+                                                           (WIDTH RADIX PAD0 LEFTFLUSH))
+                                                           (RECORD FLOATFMT (WIDTH DECPART 
+                                                           EXPPART PAD0 SIGDIGITS)))
+                                                             (* ; "Edited 27-Nov-91 13:32 by jds")
+    (DECLARE (GLOBALVARS NILNUMPRINTFLG))
+    (GLOBALRESOURCE (\NUMSTR \NUMSTR1)
+           (PROG (STR WIDTH PAD TEMP RAD (FLOATFLAG (SELECTQ (CAR (LISTP FORMAT))
+                                                        (FLOAT T)
+                                                        (FIX NIL)
+                                                        (LISPERROR "ILLEGAL ARG" FORMAT)))
+                      (FMT (CDR FORMAT)))
+                 (SETQ WIDTH (fetch WIDTH of FMT))
+                 [SETQ STR (COND
+                              ((AND (NULL NUMBER)
+                                    NILNUMPRINTFLG))
+                              (FLOATFLAG (\CONVERT.FLOATING.NUMBER (FLOAT NUMBER)
+                                                \NUMSTR \NUMSTR1 (\CHECKFLTFMT FORMAT)))
+                              (T (\CONVERTNUMBER (OR (FIXP NUMBER)
+                                                         (FIXR NUMBER))
+                                        (COND
+                                           ((SETQ RAD (fetch RADIX of FMT))
+                                            (SETQ TEMP (IABS RAD))
+                                            (COND
+                                               ((OR (IGREATERP 2 TEMP)
+                                                    (IGREATERP TEMP 16))
+                                                (\ILLEGAL.ARG RAD)))
+                                            TEMP)
+                                           (T 10))
+                                        (OR (NULL RAD)
+                                            (IGREATERP RAD 0))
+                                        NIL \NUMSTR \NUMSTR1]
+                 (SETQ PAD (COND
+                              (WIDTH (IDIFFERENCE WIDTH (NCHARS STR)))
+                              (T 0)))
+                 (RETURN (CONCAT (COND
+                                    [[AND (IGREATERP PAD 0)
+                                          (OR FLOATFLAG (NULL (fetch LEFTFLUSH of FMT]
+                                     (COND
+                                        ((COND
+                                            (FLOATFLAG (fetch (FLOATFMT PAD0) of FMT))
+                                            (T (fetch (FIXFMT PAD0) of FMT)))
+                                         (ALLOCSTRING PAD "0"))
+                                        (T (ALLOCSTRING PAD " "]
+                                    (T ""))
+                                STR])
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PROGN (PUTPROPS NUMFORMATCODE BYTEMACRO (= . PROG1))
+       (PUTPROPS NUMFORMATCODE DMACRO (= . PROG1)))
+)
+
+(RPAQ? NILNUMPRINTFLG )
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \LINELENGTH \FLOATFORMAT PRXFLG \DEFPRINTFNS ALPHANUMCHARARRAY)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA )
+)
+(PRETTYCOMPRINT APRINTCOMS)
+
+(RPAQQ APRINTCOMS
+       [(COMS                                                (* ; "User-level print functions")
+              (FNS PRIN1 PRIN2 PRIN3 PRIN4 PRINT PRINTCCODE PRINTLEVEL RADIX SPACES TERPRI FRESHLINE
+                   DEFPRINT LINELENGTH))
+        (FNS ALPHANUMCHARARRAY)
+        (INITVARS (PLVLFILEFLG NIL)
+               (\LINELENGTH 82)
+               (\FLOATFORMAT T)
+               (PRXFLG NIL)
+               (*PRINT-BASE* 10)
+               (*READ-BASE* 10)
+               (*READ-EVAL* T)
+               (*PRINT-RADIX* NIL)
+               (*PRINT-ESCAPE* T)
+               (*PRINT-CASE* ':UPCASE)
+               (*PRINT-GENSYM* T)
+               (*PRINT-LEVEL* NIL)
+               (*PRINT-LENGTH* NIL)
+               (*PRINT-PRETTY* NIL)
+               (*PRINT-CIRCLE* NIL)
+               (*PRINT-ARRAY* NIL)
+               (*PRINT-CIRCLE-HASHTABLE* NIL)
+               (*PACKAGE* NIL)
+               (*KEYWORD-PACKAGE* NIL)
+               (*INTERLISP-PRIN1-CASE* ':UPCASE)
+               (*CLTL2-PEDANTIC* NIL)
+               (\DEFPRINTFNS NIL)
+               (ALPHANUMCHARARRAY (ALPHANUMCHARARRAY)))
+        (COMS                                                (* ; "PRINT internals")
+              (FNS PRINT-CIRCLE-LOOKUP PRINT-CIRCLE-LABEL-P PRINT-CIRCLE-SCAN PRINT-CIRCLE-ENTER)
+              (FNS \PRINDATUM \PRINT-USING-DEFPRINT \PRINT-USING-ADDRESS \ELIDE.PRINT.ELEMENT 
+                   \ELIDE.ELEMENT.CHAR \ELIDE.PRINT.TAIL \ELIDE.TAIL.STRING \CKPOSBOUT \CKPOSSOUT 
+                   \CONVERTNUMBER \LITPRIN \LITPRIN.INTERNAL \PNAME-CONTAINS-NO-EOL 
+                   \SYMBOL.ESCAPE.COUNT \NUMERIC.PNAMEP \PRINSTACKP \PRINTADDR \PRINSTRING \SOUT 
+                   \OUTCHAR)
+              (FNS \FILEOUTCHARFN \JISFILEOUTCHARFN \SHIFTJISFILEOUTCHARFN \EUCFILEOUTCHARFN 
+                   \THROUGHFILEOUTCHARFN)
+              (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS .FILELINELENGTH.)
+                     (FUNCTIONS \PRINDATUM-LISTP)
+                     (EXPORT (MACROS .SPACECHECK. \CHECKRADIX)
+                            (MACROS \XCCSFILEOUTCHARFN)))
+              (FNS \INVALID.RADIX)
+              (SPECVARS \THISFILELINELENGTH))
+        (COMS                                                (* ; "Internal printing")
+              (FNS \MAPPNAME \MAPPNAME.INTERNAL PNAMESTREAMP)
+              (DECLARE%: DONTCOPY (RESOURCES \MAPPNAMESTREAM)
+                     (MACROS PNAMESTREAMP))
+              (INITRESOURCES \MAPPNAMESTREAM)
+              [INITVARS (\PNAMEDEVICE (NCREATE 'FDEV (\GETDEVICEFROMHOSTNAME 'NULL T]
+              (GLOBALVARS \PNAMEDEVICE))
+        (COMS                                                (* ; "Obsolete")
+              (FNS \MAPCHARS))
+        (DECLARE%: EVAL@COMPILE DOCOPY
+               (ADDVARS (SYSSPECVARS *PRINT-BASE* *READ-BASE* *READ-EVAL* *PRINT-RADIX* 
+                               *PRINT-ESCAPE* *PRINT-CASE* *PRINT-GENSYM* *PRINT-LEVEL* 
+                               *PRINT-LENGTH* *PRINT-PRETTY* *PRINT-CIRCLE* *PRINT-ARRAY* *PACKAGE* 
+                               *CLTL2-PEDANTIC*)))
+        (COMS                                                (* ; "PRINTNUM and friends")
+              (FNS PRINTNUM FLTFMT \CHECKFLTFMT PRINTNUM-TO-STRING)
+              (MACROS NUMFORMATCODE)
+              (INITVARS (NILNUMPRINTFLG)))
+        (LOCALVARS . T)
+        (GLOBALVARS \LINELENGTH \FLOATFORMAT PRXFLG \DEFPRINTFNS ALPHANUMCHARARRAY)
+        (PROP (FILETYPE APRINT))
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML)
+                      (LAMA \PRINT-USING-ADDRESS PRINT-CIRCLE-ENTER PRINT-CIRCLE-SCAN 
+                            PRINT-CIRCLE-LABEL-P])
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA \PRINT-USING-ADDRESS PRINT-CIRCLE-ENTER PRINT-CIRCLE-SCAN PRINT-CIRCLE-LABEL-P)
+)
+(PUTPROPS APRINT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 
+1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (4313 13379 (PRIN1 4323 . 5808) (PRIN2 5810 . 7003) (PRIN3 7005 . 8039) (PRIN4 8041 . 
+9224) (PRINT 9226 . 9462) (PRINTCCODE 9464 . 9737) (PRINTLEVEL 9739 . 10445) (RADIX 10447 . 10629) (
+SPACES 10631 . 10977) (TERPRI 10979 . 11164) (FRESHLINE 11166 . 11843) (DEFPRINT 11845 . 12417) (
+LINELENGTH 12419 . 13377)) (13380 13875 (ALPHANUMCHARARRAY 13390 . 13873)) (14649 19280 (
+PRINT-CIRCLE-LOOKUP 14659 . 15825) (PRINT-CIRCLE-LABEL-P 15827 . 16303) (PRINT-CIRCLE-SCAN 16305 . 
+18570) (PRINT-CIRCLE-ENTER 18572 . 19278)) (19281 68340 (\PRINDATUM 19291 . 22233) (
+\PRINT-USING-DEFPRINT 22235 . 23607) (\PRINT-USING-ADDRESS 23609 . 24706) (\ELIDE.PRINT.ELEMENT 24708
+ . 24878) (\ELIDE.ELEMENT.CHAR 24880 . 25163) (\ELIDE.PRINT.TAIL 25165 . 25589) (\ELIDE.TAIL.STRING 
+25591 . 25812) (\CKPOSBOUT 25814 . 25979) (\CKPOSSOUT 25981 . 26195) (\CONVERTNUMBER 26197 . 30686) (
+\LITPRIN 30688 . 38989) (\LITPRIN.INTERNAL 38991 . 49606) (\PNAME-CONTAINS-NO-EOL 49608 . 49860) (
+\SYMBOL.ESCAPE.COUNT 49862 . 57735) (\NUMERIC.PNAMEP 57737 . 63556) (\PRINSTACKP 63558 . 64863) (
+\PRINTADDR 64865 . 65962) (\PRINSTRING 65964 . 67460) (\SOUT 67462 . 68180) (\OUTCHAR 68182 . 68338)) 
+(68341 75545 (\FILEOUTCHARFN 68351 . 68510) (\JISFILEOUTCHARFN 68512 . 70873) (\SHIFTJISFILEOUTCHARFN 
+70875 . 72926) (\EUCFILEOUTCHARFN 72928 . 75201) (\THROUGHFILEOUTCHARFN 75203 . 75543)) (85227 85395 (
+\INVALID.RADIX 85237 . 85393)) (85499 87553 (\MAPPNAME 85509 . 86504) (\MAPPNAME.INTERNAL 86506 . 
+87196) (PNAMESTREAMP 87198 . 87551)) (88236 88624 (\MAPCHARS 88246 . 88622)) (89017 96056 (PRINTNUM 
+89027 . 92084) (FLTFMT 92086 . 92476) (\CHECKFLTFMT 92478 . 93046) (PRINTNUM-TO-STRING 93048 . 96054))
+)))
+STOP
diff --git a/CLTL2/APRINT.LCOM b/CLTL2/APRINT.LCOM
new file mode 100644
index 00000000..86de3e2c
Binary files /dev/null and b/CLTL2/APRINT.LCOM differ
diff --git a/CLTL2/ATBL b/CLTL2/ATBL
new file mode 100644
index 00000000..fc6201ef
--- /dev/null
+++ b/CLTL2/ATBL
@@ -0,0 +1,535 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED " 6-Nov-91 14:39:39" {DSK}<usr>local>lde>lispcore>sources>ATBL.;6 153503Q
+
+      changes to%:  (FNS \ORIGREADTABLE GETSYNTAX SETSYNTAX SYNTAXP \COPYSYNTAX \GETCHARCODE \SETFATSYNCODE CONTROL COPYTERMTABLE DELETECONTROL GETDELETECONTROL ECHOCHAR ECHOCONTROL ECHOMODE GETECHOMODE GETCONTROL GETTERMTABLE RAISE GETRAISE RESETTERMTABLE SETTERMTABLE TERMTABLEP \GETTERMSYNTAX \GTTERMTABLE \ORIGTERMTABLE \SETTERMSYNTAX \TERMCLASSTOCODE \TERMCODETOCLASS \LITCHECK COPYREADTABLE FIND-READTABLE IN-READTABLE ESCAPE GETBRK GETREADTABLE GETSEPR READMACROS READTABLEP READTABLEPROP RESETREADTABLE SETBRK SETREADTABLE SETSEPR \GETREADSYNTAX \GTREADTABLE \GTREADTABLE1 \READCLASSTOCODE \SETMACROSYNTAX \SETREADSYNTAX \READTABLEP.DEFPRINT \ATBLSET MAKE-READER-ENVIRONMENT EQUAL-READER-ENVIRONMENT SET-READER-ENVIRONMENT)
+ (RECORDS READTABLEP)
+
+      previous date%: " 4-Apr-91 22:36:35" {DSK}<usr>local>lde>lispcore>sources>ATBL.;2)
+
+
+(* ; "
+Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT ATBLCOMS)
+
+(RPAQQ ATBLCOMS ((E (RESETSAVE (RADIX 8))) (COMS (* ; "Common features of read and terminal tables") (DECLARE%: DONTCOPY (EXPORT (MACROS \SYNCODE \SETSYNCODE) (RECORDS CHARTABLE)) (CONSTANTS \NSCHARHASHKEYS \NSCHARHASHOVERFLOW) (MACROS \CREATENSCHARHASH \MAPCHARTABLE)) (FNS GETSYNTAX SETSYNTAX SYNTAXP \COPYSYNTAX \GETCHARCODE \SETFATSYNCODE)) (COMS (* ; "terminal tables") (FNS CONTROL COPYTERMTABLE DELETECONTROL GETDELETECONTROL ECHOCHAR ECHOCONTROL ECHOMODE GETECHOMODE GETCONTROL GETTERMTABLE RAISE GETRAISE RESETTERMTABLE SETTERMTABLE TERMTABLEP \GETTERMSYNTAX \GTTERMTABLE \ORIGTERMTABLE \SETTERMSYNTAX \TERMCLASSTOCODE \TERMCODETOCLASS \LITCHECK) (DECLARE%: DONTCOPY (EXPORT (CONSTANTS * CCECHOMODES) (CONSTANTS * TERMCLASSES) (RECORDS TERMCODE TERMTABLEP))) (INITRECORDS TERMTABLEP)) (COMS (* ; "read tables") (FNS COPYREADTABLE FIND-READTABLE IN-READTABLE ESCAPE GETBRK GETREADTABLE GETSEPR READMACROS READTABLEP READTABLEPROP RESETREADTABLE SETBRK SETREADTABLE SETSEPR \GETREADSYNTAX \GTREADTABLE \GTREADTABLE1 \ORIGREADTABLE \READCLASSTOCODE \SETMACROSYNTAX \SETREADSYNTAX \READTABLEP.DEFPRINT) (PROP ARGNAMES READTABLEPROP) (DECLARE%: EVAL@COMPILE DONTCOPY (* ; "READCLASSTOKENS Generates READCLASSES and some interesting SELECTQ's") (* ; "OTHER must be zero because of initialization.") (VARS READCLASSTOKENS (READCLASSES (MAPCAR READCLASSTOKENS (FUNCTION (LAMBDA (PAIR) (LIST (PACK* (CAR PAIR) ".RC") (CADR PAIR))))))) (MACROS \COMPUTED.FORM) (* ; "This macro ought to be official somehow") (RECORDS CONTEXTS ESCAPES WAKEUPS) (EXPORT (MACROS \GETREADMACRODEF \GTREADTABLE \GTREADTABLE1) (CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT) (CONSTANTS * READCODEMASKS) (CONSTANTS * READMACROCONTEXTS) (CONSTANTS * READCLASSES) (CONSTANTS * READMACROWAKEUPS) (CONSTANTS * READMACROESCAPES) (RECORDS READCODE READMACRODEF READTABLEP)) (GLOBALVARS \ORIGREADTABLE \READTABLEHASH \ORIGTERMTABLE)) (INITRECORDS READTABLEP)) (COMS (FNS \ATBLSET) (INITRECORDS READER-ENVIRONMENT) (* ; "Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*") (FNS MAKE-READER-ENVIRONMENT EQUAL-READER-ENVIRONMENT SET-READER-ENVIRONMENT) (INITVARS (*LISP-PACKAGE*) (*INTERLISP-PACKAGE*) (*KEYWORD-PACKAGE*)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\ATBLSET)))) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA READTABLEPROP)))))
+
+
+
+(* ; "Common features of read and terminal tables")
+
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \SYNCODE DMACRO (OPENLAMBDA (TABLE CHAR) (CHECK (type? CHARTABLE TABLE)) (* ; "0 is either NONE.TC, REAL.CCE, or OTHER.RC") (COND ((IGREATERP CHAR \MAXTHINCHAR) (OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE) (GETHASH CHAR (fetch (CHARTABLE NSCHARHASH) of TABLE))) 0)) (T (\GETBASEBYTE TABLE CHAR)))))
+
+(PUTPROPS \SETSYNCODE DMACRO (LAMBDA (TABLE CHAR CODE) (CHECK (type? CHARTABLE TABLE)) (* ; "0 is REAL.CCE, NONE.TC, OTHER.RC") (COND ((ILEQ CHAR \MAXTHINCHAR) (\PUTBASEBYTE TABLE CHAR CODE)) (T (\SETFATSYNCODE TABLE CHAR CODE)))))
+)
+(DECLARE%: EVAL@COMPILE
+
+(DATATYPE CHARTABLE ((CHARSET0 400Q BYTE) (NSCHARHASH FULLPOINTER)))
+)
+
+(/DECLAREDATATYPE (QUOTE CHARTABLE) (QUOTE (BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE FULLPOINTER)) (QUOTE ((CHARTABLE 0 (BITS . 7)) (CHARTABLE 0 (BITS . 207Q)) (CHARTABLE 1 (BITS . 7)) (CHARTABLE 1 (BITS . 207Q)) (CHARTABLE 2 (BITS . 7)) (CHARTABLE 2 (BITS . 207Q)) (CHARTABLE 3 (BITS . 7)) (CHARTABLE 3 (BITS . 207Q)) (CHARTABLE 4 (BITS . 7)) (CHARTABLE 4 (BITS . 207Q)) (CHARTABLE 5 (BITS . 7)) (CHARTABLE 5 (BITS . 207Q)) (CHARTABLE 6 (BITS . 7)) (CHARTABLE 6 (BITS . 207Q)) (CHARTABLE 7 (BITS . 7)) (CHARTABLE 7 (BITS . 207Q)) (CHARTABLE 10Q (BITS . 7)) (CHARTABLE 10Q (BITS . 207Q)) (CHARTABLE 11Q (BITS . 7)) (CHARTABLE 11Q (BITS . 207Q)) (CHARTABLE 12Q (BITS . 7)) (CHARTABLE 12Q (BITS . 207Q)) (CHARTABLE 13Q (BITS . 7)) (CHARTABLE 13Q (BITS . 207Q)) (CHARTABLE 14Q (BITS . 7)) (CHARTABLE 14Q (BITS . 207Q)) (CHARTABLE 15Q (BITS . 7)) (CHARTABLE 15Q (BITS . 207Q)) (CHARTABLE 16Q (BITS . 7)) (CHARTABLE 16Q (BITS . 207Q)) (CHARTABLE 17Q (BITS . 7)) (CHARTABLE 17Q (BITS . 207Q)) (CHARTABLE 20Q (BITS . 7)) (CHARTABLE 20Q (BITS . 207Q)) (CHARTABLE 21Q (BITS . 7)) (CHARTABLE 21Q (BITS . 207Q)) (CHARTABLE 22Q (BITS . 7)) (CHARTABLE 22Q (BITS . 207Q)) (CHARTABLE 23Q (BITS . 7)) (CHARTABLE 23Q (BITS . 207Q)) (CHARTABLE 24Q (BITS . 7)) (CHARTABLE 24Q (BITS . 207Q)) (CHARTABLE 25Q (BITS . 7)) (CHARTABLE 25Q (BITS . 207Q)) (CHARTABLE 26Q (BITS . 7)) (CHARTABLE 26Q (BITS . 207Q)) (CHARTABLE 27Q (BITS . 7)) (CHARTABLE 27Q (BITS . 207Q)) (CHARTABLE 30Q (BITS . 7)) (CHARTABLE 30Q (BITS . 207Q)) (CHARTABLE 31Q (BITS . 7)) (CHARTABLE 31Q (BITS . 207Q)) (CHARTABLE 32Q (BITS . 7)) (CHARTABLE 32Q (BITS . 207Q)) (CHARTABLE 33Q (BITS . 7)) (CHARTABLE 33Q (BITS . 207Q)) (CHARTABLE 34Q (BITS . 7)) (CHARTABLE 34Q (BITS . 207Q)) (CHARTABLE 35Q (BITS . 7)) (CHARTABLE 35Q (BITS . 207Q)) (CHARTABLE 36Q (BITS . 7)) (CHARTABLE 36Q (BITS . 207Q)) (CHARTABLE 37Q (BITS . 7)) (CHARTABLE 37Q (BITS . 207Q)) (CHARTABLE 40Q (BITS . 7)) (CHARTABLE 40Q (BITS . 207Q)) (CHARTABLE 41Q (BITS . 7)) (CHARTABLE 41Q (BITS . 207Q)) (CHARTABLE 42Q (BITS . 7)) (CHARTABLE 42Q (BITS . 207Q)) (CHARTABLE 43Q (BITS . 7)) (CHARTABLE 43Q (BITS . 207Q)) (CHARTABLE 44Q (BITS . 7)) (CHARTABLE 44Q (BITS . 207Q)) (CHARTABLE 45Q (BITS . 7)) (CHARTABLE 45Q (BITS . 207Q)) (CHARTABLE 46Q (BITS . 7)) (CHARTABLE 46Q (BITS . 207Q)) (CHARTABLE 47Q (BITS . 7)) (CHARTABLE 47Q (BITS . 207Q)) (CHARTABLE 50Q (BITS . 7)) (CHARTABLE 50Q (BITS . 207Q)) (CHARTABLE 51Q (BITS . 7)) (CHARTABLE 51Q (BITS . 207Q)) (CHARTABLE 52Q (BITS . 7)) (CHARTABLE 52Q (BITS . 207Q)) (CHARTABLE 53Q (BITS . 7)) (CHARTABLE 53Q (BITS . 207Q)) (CHARTABLE 54Q (BITS . 7)) (CHARTABLE 54Q (BITS . 207Q)) (CHARTABLE 55Q (BITS . 7)) (CHARTABLE 55Q (BITS . 207Q)) (CHARTABLE 56Q (BITS . 7)) (CHARTABLE 56Q (BITS . 207Q)) (CHARTABLE 57Q (BITS . 7)) (CHARTABLE 57Q (BITS . 207Q)) (CHARTABLE 60Q (BITS . 7)) (CHARTABLE 60Q (BITS . 207Q)) (CHARTABLE 61Q (BITS . 7)) (CHARTABLE 61Q (BITS . 207Q)) (CHARTABLE 62Q (BITS . 7)) (CHARTABLE 62Q (BITS . 207Q)) (CHARTABLE 63Q (BITS . 7)) (CHARTABLE 63Q (BITS . 207Q)) (CHARTABLE 64Q (BITS . 7)) (CHARTABLE 64Q (BITS . 207Q)) (CHARTABLE 65Q (BITS . 7)) (CHARTABLE 65Q (BITS . 207Q)) (CHARTABLE 66Q (BITS . 7)) (CHARTABLE 66Q (BITS . 207Q)) (CHARTABLE 67Q (BITS . 7)) (CHARTABLE 67Q (BITS . 207Q)) (CHARTABLE 70Q (BITS . 7)) (CHARTABLE 70Q (BITS . 207Q)) (CHARTABLE 71Q (BITS . 7)) (CHARTABLE 71Q (BITS . 207Q)) (CHARTABLE 72Q (BITS . 7)) (CHARTABLE 72Q (BITS . 207Q)) (CHARTABLE 73Q (BITS . 7)) (CHARTABLE 73Q (BITS . 207Q)) (CHARTABLE 74Q (BITS . 7)) (CHARTABLE 74Q (BITS . 207Q)) (CHARTABLE 75Q (BITS . 7)) (CHARTABLE 75Q (BITS . 207Q)) (CHARTABLE 76Q (BITS . 7)) (CHARTABLE 76Q (BITS . 207Q)) (CHARTABLE 77Q (BITS . 7)) (CHARTABLE 77Q (BITS . 207Q)) (CHARTABLE 100Q (BITS . 7)) (CHARTABLE 100Q (BITS . 207Q)) (CHARTABLE 101Q (BITS . 7)) (CHARTABLE 101Q (BITS . 207Q)) (CHARTABLE 102Q (BITS . 7)) (CHARTABLE 102Q (BITS . 207Q)) (CHARTABLE 103Q (BITS . 7)) (CHARTABLE 103Q (BITS . 207Q)) (CHARTABLE 104Q (BITS . 7)) (CHARTABLE 104Q (BITS . 207Q)) (CHARTABLE 105Q (BITS . 7)) (CHARTABLE 105Q (BITS . 207Q)) (CHARTABLE 106Q (BITS . 7)) (CHARTABLE 106Q (BITS . 207Q)) (CHARTABLE 107Q (BITS . 7)) (CHARTABLE 107Q (BITS . 207Q)) (CHARTABLE 110Q (BITS . 7)) (CHARTABLE 110Q (BITS . 207Q)) (CHARTABLE 111Q (BITS . 7)) (CHARTABLE 111Q (BITS . 207Q)) (CHARTABLE 112Q (BITS . 7)) (CHARTABLE 112Q (BITS . 207Q)) (CHARTABLE 113Q (BITS . 7)) (CHARTABLE 113Q (BITS . 207Q)) (CHARTABLE 114Q (BITS . 7)) (CHARTABLE 114Q (BITS . 207Q)) (CHARTABLE 115Q (BITS . 7)) (CHARTABLE 115Q (BITS . 207Q)) (CHARTABLE 116Q (BITS . 7)) (CHARTABLE 116Q (BITS . 207Q)) (CHARTABLE 117Q (BITS . 7)) (CHARTABLE 117Q (BITS . 207Q)) (CHARTABLE 120Q (BITS . 7)) (CHARTABLE 120Q (BITS . 207Q)) (CHARTABLE 121Q (BITS . 7)) (CHARTABLE 121Q (BITS . 207Q)) (CHARTABLE 122Q (BITS . 7)) (CHARTABLE 122Q (BITS . 207Q)) (CHARTABLE 123Q (BITS . 7)) (CHARTABLE 123Q (BITS . 207Q)) (CHARTABLE 124Q (BITS . 7)) (CHARTABLE 124Q (BITS . 207Q)) (CHARTABLE 125Q (BITS . 7)) (CHARTABLE 125Q (BITS . 207Q)) (CHARTABLE 126Q (BITS . 7)) (CHARTABLE 126Q (BITS . 207Q)) (CHARTABLE 127Q (BITS . 7)) (CHARTABLE 127Q (BITS . 207Q)) (CHARTABLE 130Q (BITS . 7)) (CHARTABLE 130Q (BITS . 207Q)) (CHARTABLE 131Q (BITS . 7)) (CHARTABLE 131Q (BITS . 207Q)) (CHARTABLE 132Q (BITS . 7)) (CHARTABLE 132Q (BITS . 207Q)) (CHARTABLE 133Q (BITS . 7)) (CHARTABLE 133Q (BITS . 207Q)) (CHARTABLE 134Q (BITS . 7)) (CHARTABLE 134Q (BITS . 207Q)) (CHARTABLE 135Q (BITS . 7)) (CHARTABLE 135Q (BITS . 207Q)) (CHARTABLE 136Q (BITS . 7)) (CHARTABLE 136Q (BITS . 207Q)) (CHARTABLE 137Q (BITS . 7)) (CHARTABLE 137Q (BITS . 207Q)) (CHARTABLE 140Q (BITS . 7)) (CHARTABLE 140Q (BITS . 207Q)) (CHARTABLE 141Q (BITS . 7)) (CHARTABLE 141Q (BITS . 207Q)) (CHARTABLE 142Q (BITS . 7)) (CHARTABLE 142Q (BITS . 207Q)) (CHARTABLE 143Q (BITS . 7)) (CHARTABLE 143Q (BITS . 207Q)) (CHARTABLE 144Q (BITS . 7)) (CHARTABLE 144Q (BITS . 207Q)) (CHARTABLE 145Q (BITS . 7)) (CHARTABLE 145Q (BITS . 207Q)) (CHARTABLE 146Q (BITS . 7)) (CHARTABLE 146Q (BITS . 207Q)) (CHARTABLE 147Q (BITS . 7)) (CHARTABLE 147Q (BITS . 207Q)) (CHARTABLE 150Q (BITS . 7)) (CHARTABLE 150Q (BITS . 207Q)) (CHARTABLE 151Q (BITS . 7)) (CHARTABLE 151Q (BITS . 207Q)) (CHARTABLE 152Q (BITS . 7)) (CHARTABLE 152Q (BITS . 207Q)) (CHARTABLE 153Q (BITS . 7)) (CHARTABLE 153Q (BITS . 207Q)) (CHARTABLE 154Q (BITS . 7)) (CHARTABLE 154Q (BITS . 207Q)) (CHARTABLE 155Q (BITS . 7)) (CHARTABLE 155Q (BITS . 207Q)) (CHARTABLE 156Q (BITS . 7)) (CHARTABLE 156Q (BITS . 207Q)) (CHARTABLE 157Q (BITS . 7)) (CHARTABLE 157Q (BITS . 207Q)) (CHARTABLE 160Q (BITS . 7)) (CHARTABLE 160Q (BITS . 207Q)) (CHARTABLE 161Q (BITS . 7)) (CHARTABLE 161Q (BITS . 207Q)) (CHARTABLE 162Q (BITS . 7)) (CHARTABLE 162Q (BITS . 207Q)) (CHARTABLE 163Q (BITS . 7)) (CHARTABLE 163Q (BITS . 207Q)) (CHARTABLE 164Q (BITS . 7)) (CHARTABLE 164Q (BITS . 207Q)) (CHARTABLE 165Q (BITS . 7)) (CHARTABLE 165Q (BITS . 207Q)) (CHARTABLE 166Q (BITS . 7)) (CHARTABLE 166Q (BITS . 207Q)) (CHARTABLE 167Q (BITS . 7)) (CHARTABLE 167Q (BITS . 207Q)) (CHARTABLE 170Q (BITS . 7)) (CHARTABLE 170Q (BITS . 207Q)) (CHARTABLE 171Q (BITS . 7)) (CHARTABLE 171Q (BITS . 207Q)) (CHARTABLE 172Q (BITS . 7)) (CHARTABLE 172Q (BITS . 207Q)) (CHARTABLE 173Q (BITS . 7)) (CHARTABLE 173Q (BITS . 207Q)) (CHARTABLE 174Q (BITS . 7)) (CHARTABLE 174Q (BITS . 207Q)) (CHARTABLE 175Q (BITS . 7)) (CHARTABLE 175Q (BITS . 207Q)) (CHARTABLE 176Q (BITS . 7)) (CHARTABLE 176Q (BITS . 207Q)) (CHARTABLE 177Q (BITS . 7)) (CHARTABLE 177Q (BITS . 207Q)) (CHARTABLE 200Q FULLPOINTER))) (QUOTE 202Q))
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \NSCHARHASHKEYS 12Q)
+
+(RPAQQ \NSCHARHASHOVERFLOW 1.3)
+
+
+(CONSTANTS \NSCHARHASHKEYS \NSCHARHASHOVERFLOW)
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \CREATENSCHARHASH MACRO (ARGS (* ; "added size argument for creation of \ORIGTERMTABLE during initialization.") (LIST (QUOTE HASHARRAY) (OR (CAR ARGS) (QUOTE \NSCHARHASHKEYS)) (QUOTE \NSCHARHASHOVERFLOW))))
+
+(PUTPROPS \MAPCHARTABLE MACRO (LAMBDA (FN CHARTBL) (for I from 0 to \MAXTHINCHAR do (APPLY* FN (\GETBASEBYTE CHARTBL I) I)) (COND ((fetch (CHARTABLE NSCHARHASH) of CHARTBL) (MAPHASH (fetch (CHARTABLE NSCHARHASH) of CHARTBL) FN)))))
+)
+)
+(DEFINEQ
+
+(GETSYNTAX
+(LAMBDA (CH TABLE) (* bvm%: " 8-Mar-86 17:22") (COND ((FIXP (SETQ CH (\GETCHARCODE CH))) (COND ((type? TERMTABLEP TABLE) (\GETTERMSYNTAX CH TABLE)) (T (\GETREADSYNTAX CH (\GTREADTABLE TABLE T))))) (T (PROG (TEM CHARTBL RESULT) (COND ((SETQ TEM (\READCLASSTOCODE CH)) (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T))) (\MAPCHARTABLE (FUNCTION (LAMBDA (VAL KEY) (DECLARE (USEDFREE TEM RESULT)) (COND ((EQ TEM VAL) (push RESULT KEY))))) CHARTBL)) ((EQ CH (QUOTE BREAK)) (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T))) (\MAPCHARTABLE (FUNCTION (LAMBDA (VAL KEY) (DECLARE (USEDFREE TEM RESULT)) (COND ((fetch BREAK of VAL) (push RESULT KEY))))) CHARTBL)) ((SETQ TEM (\TERMCLASSTOCODE CH)) (SETQ CHARTBL (fetch TERMSA of (\GTTERMTABLE TABLE T))) (\MAPCHARTABLE (FUNCTION (LAMBDA (VAL KEY) (DECLARE (USEDFREE TEM RESULT)) (COND ((EQ TEM (fetch TERMCLASS of VAL)) (push RESULT (PROG1 KEY (* SELECTC TEM ((LIST NONE.TC WORDSEPR.TC) (* ; "Only these classes have multiple members") KEY) (RETURN (CONS KEY))))))))) CHARTBL)) ((FMEMB CH (QUOTE (MACRO SPLICE INFIX))) (PROG (LST (A (fetch READMACRODEFS of (\GTREADTABLE TABLE T)))) (COND (A (MAPHASH A (FUNCTION (LAMBDA (DEF C) (AND (EQ CH (fetch MACROTYPE of DEF)) (push LST C))))) (RETURN LST))))) ((SETQ TEM (fetch (CONTEXTS VAL) of CH)) (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T))) (\MAPCHARTABLE (FUNCTION (LAMBDA (VAL KEY) (DECLARE (USEDFREE TEM RESULT)) (COND ((EQ TEM (fetch MACROCONTEXT of VAL)) (push RESULT KEY))))) CHARTBL)) ((SETQ TEM (fetch (WAKEUPS VAL) of CH)) (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T))) (\MAPCHARTABLE (FUNCTION (LAMBDA (VAL KEY) (DECLARE (USEDFREE TEM RESULT)) (COND ((EQ TEM (fetch WAKEUP of VAL)) (push RESULT KEY))))) CHARTBL)) ((SETQ TEM (fetch (ESCAPES VAL) of CH)) (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T))) (\MAPCHARTABLE (FUNCTION (LAMBDA (VAL KEY) (DECLARE (USEDFREE TEM RESULT)) (COND ((EQ TEM (fetch ESCAPE of VAL)) (push RESULT KEY))))) CHARTBL)) (T (\ILLEGAL.ARG CH))) (RETURN RESULT)))))
+)
+
+(SETSYNTAX
+(LAMBDA (CHAR CLASS TBL) (* rmk%: "20-Nov-84 15:47") (OR (FIXP (SETQ CHAR (\GETCHARCODE CHAR))) (\ILLEGAL.ARG CHAR)) (OR (type? READTABLEP TBL) (type? TERMTABLEP TBL) (SETQ TBL (COND ((OR (type? TERMTABLEP CLASS) (\TERMCLASSTOCODE CLASS)) (\GTTERMTABLE TBL)) (T (\GTREADTABLE TBL))))) (COND ((OR (type? READTABLEP CLASS) (type? TERMTABLEP CLASS) (SELECTQ CLASS ((NIL T ORIG) T) NIL)) (SETQ CLASS (GETSYNTAX CHAR CLASS))) ((FIXP (SETQ CLASS (\GETCHARCODE CLASS))) (SETQ CLASS (GETSYNTAX CLASS TBL)))) (COND ((type? READTABLEP TBL) (PROG1 (\GETREADSYNTAX CHAR TBL) (\SETREADSYNTAX CHAR CLASS TBL))) (T (PROG1 (\GETTERMSYNTAX CHAR TBL) (\SETTERMSYNTAX CHAR CLASS TBL)))))
+)
+
+(SYNTAXP
+(LAMBDA (CODE CLASS TABLE) (* rmk%: " 5-JUN-80 22:40") (PROG (D) (RETURN (COND ((EQ CLASS (QUOTE BREAK)) (fetch BREAK of (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE)) CODE))) ((SETQ D (\READCLASSTOCODE CLASS)) (EQ D (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE)) CODE))) ((SETQ D (\TERMCLASSTOCODE CLASS)) (EQ D (fetch TERMCLASS of (\SYNCODE (fetch TERMSA of (\GTTERMTABLE TABLE)) CODE)))) ((FMEMB CLASS (QUOTE (MACRO SPLICE INFIX))) (AND (SETQ D (fetch READMACRODEFS of (\GTREADTABLE TABLE))) (EQ CLASS (fetch MACROTYPE of (GETHASH CODE D))))) ((SETQ D (fetch (CONTEXTS VAL) of CLASS)) (EQ D (fetch MACROCONTEXT of (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE)) CODE)))) ((SETQ D (fetch (WAKEUPS VAL) of CLASS)) (EQ D (fetch WAKEUP of (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE)) CODE)))) ((SETQ D (fetch (ESCAPES VAL) of CLASS)) (EQ D (fetch ESCAPE of (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE)) CODE)))) (T (\ILLEGAL.ARG CLASS))))))
+)
+
+(\COPYSYNTAX
+(LAMBDA (A B) (* gbn "15-Sep-85 22:36") (* ;; "Copies chartable A into chartable B") (CHECK (AND (type? CHARTABLE A) (type? CHARTABLE B))) (\MOVEBYTES A 0 B 0 (ADD1 \MAXTHINCHAR)) (COND ((fetch (CHARTABLE NSCHARHASH) of A) (replace (CHARTABLE NSCHARHASH) of B with (REHASH (fetch (CHARTABLE NSCHARHASH) of A) (\CREATENSCHARHASH))))))
+)
+
+(\GETCHARCODE
+(LAMBDA (C) (* rmk%: "20-Nov-84 15:46") (COND ((AND (NUMBERP C) (\CHARCODEP (FIX C))) (FIX C)) ((AND (LITATOM C) (EQ 1 (NCHARS C))) (CHCON1 C)) (T C)))
+)
+
+(\SETFATSYNCODE
+(LAMBDA (TABLE CHAR CODE) (* bvm%: " 8-Mar-86 17:03") (* ;;; "Called by \SETSYNCODE macro for fat characters") (SETQ TABLE (\DTEST TABLE (QUOTE CHARTABLE))) (* ; "CODE = 0 is REAL.CCE, NONE.TC, OTHER.RC") (COND ((ILEQ CHAR \MAXTHINCHAR) (\PUTBASEBYTE TABLE CHAR CODE)) ((EQ 0 CODE) (COND ((fetch (CHARTABLE NSCHARHASH) of TABLE) (* ; "there was already a table here so record the change") (PUTHASH CHAR CODE (fetch (CHARTABLE NSCHARHASH) of TABLE))) (T (* ; "No hashtable yet, and only the default is being stored, so don't build the hashtable") 0))) (T (PUTHASH CHAR CODE (OR (fetch (CHARTABLE NSCHARHASH) of TABLE) (replace (CHARTABLE NSCHARHASH) of TABLE with (\CREATENSCHARHASH)))))))
+)
+)
+
+
+
+(* ; "terminal tables")
+
+(DEFINEQ
+
+(CONTROL
+(LAMBDA (MODE TTBL) (* rmk%: " 8-FEB-80 11:59") (PROG1 (fetch CONTROLFLG of (SETQ TTBL (\GTTERMTABLE TTBL))) (replace CONTROLFLG of TTBL with (AND MODE T))))
+)
+
+(COPYTERMTABLE
+(LAMBDA (TTBL) (* lmm "14-APR-81 14:27") (create TERMTABLEP using (SETQ TTBL (\GTTERMTABLE TTBL T)) TERMSA _ (create CHARTABLE using (fetch TERMSA of TTBL))))
+)
+
+(DELETECONTROL
+(LAMBDA (TYPE MESSAGE TTBL) (* lmm " 1-Jan-85 21:34") (PROG (VAL (TBL (\GTTERMTABLE TTBL (NULL MESSAGE)))) (SETQ VAL (SELECTQ TYPE ((ECHO NOECHO) (PROG1 (fetch DELCHARECHO of TBL) (replace DELCHARECHO of TBL with TYPE))) (DELCHARECHO (PROG1 (fetch DELCHARECHO of TBL) (SELECTQ MESSAGE (NIL (* ; "Called only to get current value")) ((ECHO NOECHO) (replace DELCHARECHO of TBL with MESSAGE)) (LISPERROR "ILLEGAL ARG" MESSAGE)))) ((LINEDELETE DELETELINE) (PROG1 (fetch LINEDELETE of TBL) (AND MESSAGE (replace LINEDELETE of TBL with (\LITCHECK MESSAGE))))) (1STCHDEL (PROG1 (fetch 1STCHDEL of TBL) (AND MESSAGE (replace 1STCHDEL of TBL with (\LITCHECK MESSAGE))))) (NTHCHDEL (PROG1 (fetch NTHCHDEL of TBL) (AND MESSAGE (replace NTHCHDEL of TBL with (\LITCHECK MESSAGE))))) (POSTCHDEL (PROG1 (fetch POSTCHDEL of TBL) (AND MESSAGE (replace POSTCHDEL of TBL with (\LITCHECK MESSAGE))))) (EMPTYCHDEL (PROG1 (fetch EMPTYCHDEL of TBL) (AND MESSAGE (replace EMPTYCHDEL of TBL with (\LITCHECK MESSAGE))))) (LISPERROR "ILLEGAL ARG" TYPE))) (RETURN (COND ((STRINGP VAL) (CONCAT VAL)) (T VAL)))))
+)
+
+(GETDELETECONTROL
+(LAMBDA (TYPE TTBL) (* lmm " 1-Jan-85 21:20") (PROG (TBL VAL) (SETQ TBL (\GTTERMTABLE TTBL T)) (SETQ VAL (SELECTQ TYPE ((ECHO NOECHO) (fetch DELCHARECHO of TBL)) (DELCHARECHO (fetch DELCHARECHO of TBL)) ((LINEDELETE DELETELINE) (fetch LINEDELETE of TBL)) (1STCHDEL (fetch 1STCHDEL of TBL)) (NTHCHDEL (fetch NTHCHDEL of TBL)) (POSTCHDEL (fetch POSTCHDEL of TBL)) (EMPTYCHDEL (fetch EMPTYCHDEL of TBL)) (LISPERROR "ILLEGAL ARG" TYPE))) (RETURN (COND ((STRINGP VAL) (CONCAT VAL)) (T VAL)))))
+)
+
+(ECHOCHAR
+(LAMBDA (CHARCODE MODE TTBL) (* lmm " 1-Jan-85 21:29") (COND ((LISTP CHARCODE) (for X in CHARCODE do (ECHOCHAR X MODE TTBL))) (T (PROG (B (SA (fetch TERMSA of (\GTTERMTABLE TTBL (NULL MODE))))) (RETURN (PROG1 (SELECTC (fetch CCECHO of (SETQ B (\SYNCODE SA CHARCODE))) (REAL.CCE (QUOTE REAL)) (IGNORE.CCE (QUOTE IGNORE)) (SIMULATE.CCE (QUOTE SIMULATE)) (QUOTE INDICATE)) (AND MODE (\SETSYNCODE SA CHARCODE (create TERMCODE using B CCECHO _ (SELECTQ MODE (REAL REAL.CCE) (IGNORE IGNORE.CCE) (SIMULATE SIMULATE.CCE) ((INDICATE UPARROW) INDICATE.CCE) (\ILLEGAL.ARG MODE)))))))))))
+)
+
+(ECHOCONTROL
+(LAMBDA (CHAR MODE TTBL) (* rmk%: "20-Nov-84 15:14") (PROG ((C (\GETCHARCODE CHAR))) (OR (AND (\THINCHARCODEP C) (OR (ILESSP C 40Q) (AND (IGEQ C (CHARCODE A)) (ILEQ C (CHARCODE Z)) (SETQ C (IDIFFERENCE C 100Q))))) (\ILLEGAL.ARG C)) (RETURN (ECHOCHAR C MODE TTBL))))
+)
+
+(ECHOMODE
+(LAMBDA (FLG TTBL) (* rmk%: " 8-FEB-80 11:57") (PROG1 (fetch ECHOFLG of (SETQ TTBL (\GTTERMTABLE TTBL))) (replace ECHOFLG of TTBL with (AND FLG T))))
+)
+
+(GETECHOMODE
+(LAMBDA (TTBL) (* lmm " 1-Jan-85 21:21") (fetch ECHOFLG of (\GTTERMTABLE TTBL T))))
+
+(GETCONTROL
+(LAMBDA (TTBL) (* lmm " 1-Jan-85 21:21") (fetch CONTROLFLG of (\GTTERMTABLE TTBL T))))
+
+(GETTERMTABLE
+(LAMBDA (TTBL) (\GTTERMTABLE TTBL NIL)))
+
+(RAISE
+(LAMBDA (FLG TTBL) (* bvm%: "14-Feb-85 00:17") (PROG1 (fetch RAISEFLG of (SETQ TTBL (\GTTERMTABLE TTBL))) (replace RAISEFLG of TTBL with (COND ((EQ FLG 0) 0) (FLG T)))))
+)
+
+(GETRAISE
+(LAMBDA (TTBL) (* lmm " 1-Jan-85 21:21") (fetch RAISEFLG of (\GTTERMTABLE TTBL T))))
+
+(RESETTERMTABLE
+(LAMBDA (TTBL FROM) (* lmm "14-APR-81 14:34") (PROG ((FR (\GTTERMTABLE FROM T)) (TT (\GTTERMTABLE TTBL))) (\COPYSYNTAX (fetch TERMSA of FR) (fetch TERMSA of TT)) (replace RAISEFLG of TT with (fetch RAISEFLG of FR)) (replace DELCHARECHO of TT with (fetch DELCHARECHO of FR)) (replace LINEDELETE of TT with (fetch LINEDELETE of FR)) (replace 1STCHDEL of TT with (fetch 1STCHDEL of FR)) (replace NTHCHDEL of TT with (fetch NTHCHDEL of FR)) (replace POSTCHDEL of TT with (fetch POSTCHDEL of FR)) (replace EMPTYCHDEL of TT with (fetch EMPTYCHDEL of FR)) (replace CONTROLFLG of TT with (fetch CONTROLFLG of FR)) (replace ECHOFLG of TT with (fetch ECHOFLG of FR)) (RETURN TT)))
+)
+
+(SETTERMTABLE
+(LAMBDA (TBL) (* rmk%: " 8-FEB-80 12:16") (PROG1 \PRIMTERMTABLE (SETQ \PRIMTERMSA (fetch TERMSA of (SETQ \PRIMTERMTABLE (\GTTERMTABLE TBL))))))
+)
+
+(TERMTABLEP
+(LAMBDA (TTBL) (* rmk%: "20-FEB-80 12:29") (AND (type? TERMTABLEP TTBL) TTBL)))
+
+(\GETTERMSYNTAX
+(LAMBDA (C TBL) (* rmk%: "24-APR-80 09:44") (\TERMCODETOCLASS (fetch TERMCLASS of (\SYNCODE (fetch TERMSA of TBL) C))))
+)
+
+(\GTTERMTABLE
+(LAMBDA (TTBL FLG) (* lmm " 6-MAY-80 20:35") (COND ((type? TERMTABLEP TTBL) TTBL) ((NULL TTBL) \PRIMTERMTABLE) ((AND (EQ TTBL (QUOTE ORIG)) FLG) \ORIGTERMTABLE) (T (LISPERROR "ILLEGAL TERMINAL TABLE" TTBL))))
+)
+
+(\ORIGTERMTABLE
+(LAMBDA NIL (* rrb " 5-Oct-85 10:33") (* ;; "Creates the original terminal table") (* ;; "must be created with a hash table big enough to hold all of the indicates in character set 1 because this gets evaluated in the loadup before HASHOVERFLOW is defined.  rrb 5-oct-85") (PROG ((TBL (create TERMTABLEP TERMSA _ (create CHARTABLE NSCHARHASH _ (\CREATENSCHARHASH 454Q)) DELCHARECHO _ (QUOTE ECHO) ECHOFLG _ T LINEDELETE _ "##
+" 1STCHDEL _ "\" NTHCHDEL _ "" POSTCHDEL _ "\" EMPTYCHDEL _ "##
+"))) (PROGN (\SETTERMSYNTAX (SELECTQ (SYSTEMTYPE) ((TENEX D) (CHARCODE ^A)) ((JERICHO VAX TOPS-20) (CHARCODE DEL)) (SHOULDNT)) (QUOTE CHARDELETE) TBL) (\SETTERMSYNTAX (CHARCODE ^H) (QUOTE CHARDELETE) TBL) (* ; "Added ^H as a CHARDELETE character 9/30/85") (\SETTERMSYNTAX (CHARCODE ^W) (QUOTE WORDDELETE) TBL) (\SETTERMSYNTAX (SELECTQ (SYSTEMTYPE) ((TENEX D) (CHARCODE ^Q)) ((JERICHO VAX) (CHARCODE ^U)) (SHOULDNT)) (QUOTE LINEDELETE) TBL) (\SETTERMSYNTAX (CHARCODE ^R) (QUOTE RETYPE) TBL) (\SETTERMSYNTAX (CHARCODE ^V) (QUOTE CTRLV) TBL) (\SETTERMSYNTAX (CHARCODE EOL) (QUOTE WAKEUPCHAR) TBL) (for C in (CHARCODE (SPACE TAB ! @ %# $ ~ & * - = + %| { } ^ _ %: ; < > %, %. ? /)) do (\SETTERMSYNTAX C (QUOTE WORDSEPR) TBL))) (PROGN (ECHOCHAR (CHARCODE (NULL ^A ^B ^C ^D ^E ^F ^H ^K ^L ^N ^O ^P ^Q ^R ^S ^T ^U ^V ^W ^X ^Y ^Z ^\ ^%] ^^)) (QUOTE INDICATE) TBL) (ECHOCHAR (CHARCODE (BELL TAB LF CR)) (QUOTE REAL) TBL) (SELECTQ (SYSTEMTYPE) (D (ECHOCHAR (CHARCODE (NULL ^A ^W ^Q ^R)) (QUOTE IGNORE) TBL) (ECHOCHAR (CHARCODE (BELL TAB ESCAPE LF TENEXEOL)) (QUOTE SIMULATE) TBL)) (JERICHO (ECHOCHAR (CONSTANT (CONS ERASECHARCODE (CHARCODE (BELL TAB ESCAPE EOL)))) (QUOTE SIMULATE) TBL)) (VAX (ECHOCHAR (CHARCODE (TAB ESCAPE EOL DEL)) (QUOTE SIMULATE) TBL)) NIL)) (for C from 200Q to \MAXTHINCHAR do (ECHOCHAR C (QUOTE REAL) TBL)) (for C from (CHARCODE 1,0) to (CHARCODE 1,377) do (ECHOCHAR C (QUOTE INDICATE) TBL)) (RETURN TBL)))
+)
+
+(\SETTERMSYNTAX
+(LAMBDA (C CLASS TBL) (* rmk%: "26-Mar-85 23:45") (* ;; "Changes the terminal syntax class for charcode C.  Unlike Interlisp-10, does not turn off previous characters for CHARDELETE, etc.  classes") (\SETSYNCODE (fetch TERMSA of TBL) C (create TERMCODE using (\SYNCODE (fetch TERMSA of TBL) C) TERMCLASS _ (OR (\TERMCLASSTOCODE CLASS) (LISPERROR "ILLEGAL ARG" CLASS)))))
+)
+
+(\TERMCLASSTOCODE
+(LAMBDA (CLASS) (* rmk%: "11-FEB-82 21:24") (SELECTQ CLASS ((EOL WAKEUPCHAR) EOL.TC) (NONE NONE.TC) (CHARDELETE CHARDELETE.TC) (WORDDELETE WORDDELETE.TC) (WORDSEPR WORDSEPR.TC) (LINEDELETE LINEDELETE.TC) (RETYPE RETYPE.TC) ((CTRLV CNTRLV) CTRLV.TC) NIL))
+)
+
+(\TERMCODETOCLASS
+(LAMBDA (CODE) (* rmk%: "11-FEB-82 21:24") (SELECTC CODE (EOL.TC (QUOTE EOL)) (NONE.TC (QUOTE NONE)) (CHARDELETE.TC (QUOTE CHARDELETE)) (WORDDELETE.TC (QUOTE WORDDELETE)) (WORDSEPR.TC (QUOTE WORDSEPR)) (LINEDELETE.TC (QUOTE LINEDELETE)) (RETYPE.TC (QUOTE RETYPE)) (CTRLV.TC (QUOTE CNTRLV)) NIL))
+)
+
+(\LITCHECK
+(LAMBDA (X) (* rmk%: "11-FEB-82 21:26") (COND ((EQ X (QUOTE BACKUP)) (* ; "Means take terminal/implementation dependent backup action") X) ((LITATOM X) (MKSTRING X)) ((STRINGP X) (CONCAT X)) (T (\ILLEGAL.ARG X))))
+)
+)
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")
+(RPAQQ CCECHOMODES (REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ REAL.CCE 0)
+
+(RPAQQ IGNORE.CCE 10Q)
+
+(RPAQQ SIMULATE.CCE 20Q)
+
+(RPAQQ INDICATE.CCE 30Q)
+
+
+(CONSTANTS REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE)
+)
+
+(RPAQQ TERMCLASSES (NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC RETYPE.TC CTRLV.TC))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ NONE.TC 0)
+
+(RPAQQ EOL.TC 1)
+
+(RPAQQ CHARDELETE.TC 2)
+
+(RPAQQ WORDDELETE.TC 6)
+
+(RPAQQ WORDSEPR.TC 7)
+
+(RPAQQ LINEDELETE.TC 3)
+
+(RPAQQ RETYPE.TC 4)
+
+(RPAQQ CTRLV.TC 5)
+
+
+(CONSTANTS NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC RETYPE.TC CTRLV.TC)
+)
+(DECLARE%: EVAL@COMPILE
+
+(ACCESSFNS TERMCODE ((CCECHO (LOGAND DATUM 30Q)) (TERMCLASS (LOGAND DATUM 7))) (* ; "We assume that values are appropriately shifted")
+ (CREATE (LOGOR CCECHO TERMCLASS)))
+
+(DATATYPE TERMTABLEP (TERMSA RAISEFLG DELCHARECHO LINEDELETE 1STCHDEL NTHCHDEL POSTCHDEL EMPTYCHDEL (CONTROLFLG FLAG) (ECHOFLG FLAG))
+ TERMSA _ (create CHARTABLE))
+)
+
+(/DECLAREDATATYPE (QUOTE TERMTABLEP) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG)) (QUOTE ((TERMTABLEP 0 POINTER) (TERMTABLEP 2 POINTER) (TERMTABLEP 4 POINTER) (TERMTABLEP 6 POINTER) (TERMTABLEP 10Q POINTER) (TERMTABLEP 12Q POINTER) (TERMTABLEP 14Q POINTER) (TERMTABLEP 16Q POINTER) (TERMTABLEP 16Q (FLAGBITS . 0)) (TERMTABLEP 16Q (FLAGBITS . 20Q)))) (QUOTE 20Q))
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+
+(/DECLAREDATATYPE (QUOTE TERMTABLEP) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG)) (QUOTE ((TERMTABLEP 0 POINTER) (TERMTABLEP 2 POINTER) (TERMTABLEP 4 POINTER) (TERMTABLEP 6 POINTER) (TERMTABLEP 10Q POINTER) (TERMTABLEP 12Q POINTER) (TERMTABLEP 14Q POINTER) (TERMTABLEP 16Q POINTER) (TERMTABLEP 16Q (FLAGBITS . 0)) (TERMTABLEP 16Q (FLAGBITS . 20Q)))) (QUOTE 20Q))
+
+
+
+(* ; "read tables")
+
+(DEFINEQ
+
+(COPYREADTABLE
+(LAMBDA (RDTBL) (* rmk%: " 2-FEB-80 12:26") (RESETREADTABLE (create READTABLEP) (\GTREADTABLE RDTBL T)))
+)
+
+(FIND-READTABLE
+(LAMBDA (NAME) (* bvm%: "27-Jul-86 15:53") (GETHASH NAME \READTABLEHASH)))
+
+(IN-READTABLE
+(LAMBDA (RDTBL) (* bvm%: "27-Jul-86 15:55") (SETQ *READTABLE* (\GTREADTABLE RDTBL T))))
+
+(ESCAPE
+(LAMBDA (FLG RDTBL) (* rmk%: " 1-FEB-80 13:12") (PROG1 (fetch ESCAPEFLG of (SETQ RDTBL (\GTREADTABLE RDTBL))) (replace ESCAPEFLG of RDTBL with (NEQ FLG NIL))))
+)
+
+(GETBRK
+(LAMBDA (RDTBL) (* rmk%: " 2-MAY-80 17:04") (GETSYNTAX (QUOTE BREAK) RDTBL)))
+
+(GETREADTABLE
+(LAMBDA (RDTBL) (* lmm%: 4-FEB-76 3 62Q) (\GTREADTABLE RDTBL)))
+
+(GETSEPR
+(LAMBDA (RDTBL) (* rmk%: " 2-MAY-80 17:05") (GETSYNTAX (QUOTE SEPR) RDTBL)))
+
+(READMACROS
+(LAMBDA (FLG RDTBL) (* rmk%: " 1-FEB-80 13:11") (PROG1 (fetch READMACROFLG of (SETQ RDTBL (\GTREADTABLE RDTBL))) (replace READMACROFLG of RDTBL with (NEQ FLG NIL))))
+)
+
+(READTABLEP
+(LAMBDA (RDTBL) (* rmk%: "20-FEB-80 12:32") (AND (type? READTABLEP RDTBL) RDTBL)))
+
+(READTABLEPROP
+(LAMBDA ARGS (* ; "Edited  3-Apr-91 20:57 by jrb:") (COND ((LESSP ARGS 2) (\ILLEGAL.ARG NIL)) ((GREATERP ARGS 3) (\ILLEGAL.ARG (ARG ARGS 4))) (T (LET ((RDTBL (\GTREADTABLE (ARG ARGS 1))) (NEWVALUEP (EQ ARGS 3)) (NEWVALUE (AND (EQ ARGS 3) (ARG ARGS 3)))) (SELECTQ (ARG ARGS 2) (NUMBERBASE (PROG1 (fetch (READTABLEP NUMBERBASE) of RDTBL) (COND (NEWVALUEP (replace (READTABLEP NUMBERBASE) of RDTBL with NEWVALUE))))) (NAME (LET ((OLDNAME (fetch (READTABLEP READTBLNAME) of RDTBL))) (PROG1 OLDNAME (COND (NEWVALUEP (COND (OLDNAME (REMHASH OLDNAME \READTABLEHASH))) (replace (READTABLEP READTBLNAME) of RDTBL with NEWVALUE) (PUTHASH NEWVALUE RDTBL \READTABLEHASH)))))) (COMMONLISP (PROG1 (fetch (READTABLEP COMMONLISP) of RDTBL) (COND (NEWVALUEP (replace (READTABLEP COMMONLISP) of RDTBL with NEWVALUE) (if NEWVALUE then (* ; "COMMONLISP implies COMMONNUMSYNTAX and not USESILPACKAGE") (replace (READTABLEP COMMONNUMSYNTAX) of RDTBL with T) (replace (READTABLEP USESILPACKAGE) of RDTBL with NIL)))))) (COMMONNUMSYNTAX (PROG1 (fetch (READTABLEP COMMONNUMSYNTAX) of RDTBL) (COND (NEWVALUEP (replace (READTABLEP COMMONNUMSYNTAX) of RDTBL with NEWVALUE))))) (USESILPACKAGE (PROG1 (fetch (READTABLEP USESILPACKAGE) of RDTBL) (COND (NEWVALUEP (replace (READTABLEP USESILPACKAGE) of RDTBL with NEWVALUE))))) (CASEINSENSITIVE (PROG1 (fetch (READTABLEP CASEINSENSITIVE) of RDTBL) (COND (NEWVALUEP (replace (READTABLEP CASEINSENSITIVE) of RDTBL with NEWVALUE))))) (LOWER/FLIPCASE (PROG1 (fetch (READTABLEP LOWER/FLIPCASE) of RDTBL) (COND (NEWVALUEP (replace (READTABLEP LOWER/FLIPCASE) of RDTBL with NEWVALUE))))) (ESCAPECHAR (PROG1 (fetch (READTABLEP ESCAPECHAR) of RDTBL) (COND (NEWVALUEP (\SETREADSYNTAX NEWVALUE (QUOTE ESCAPE) RDTBL) (replace (READTABLEP ESCAPECHAR) of RDTBL with NEWVALUE))))) (MULTIPLE-ESCAPECHAR (PROG1 (fetch (READTABLEP MULTESCAPECHAR) of RDTBL) (COND (NEWVALUEP (\SETREADSYNTAX NEWVALUE (QUOTE MULTIPLE-ESCAPE) RDTBL) (replace (READTABLEP MULTESCAPECHAR) of RDTBL with NEWVALUE))))) (PACKAGECHAR (PROG1 (fetch (READTABLEP PACKAGECHAR) of RDTBL) (COND (NEWVALUEP (\SETREADSYNTAX NEWVALUE (QUOTE PACKAGEDELIM) RDTBL) (replace (READTABLEP PACKAGECHAR) of RDTBL with NEWVALUE))))) (HASHMACROCHAR (PROG1 (fetch (READTABLEP HASHMACROCHAR) of RDTBL) (COND (NEWVALUEP (\SETREADSYNTAX NEWVALUE (QUOTE (INFIX ALWAYS NONIMMEDIATE ESCQUOTE READVBAR)) RDTBL) (replace (READTABLEP HASHMACROCHAR) of RDTBL with NEWVALUE))))) (\ILLEGAL.ARG (ARG ARGS 2)))))))
+)
+
+(RESETREADTABLE
+(LAMBDA (RDTBL FROM) (* ; "Edited  3-Apr-91 21:00 by jrb:") (replace READMACROFLG of (SETQ RDTBL (\GTREADTABLE RDTBL)) with (fetch READMACROFLG of (SETQ FROM (\GTREADTABLE FROM T)))) (replace ESCAPEFLG of RDTBL with (fetch ESCAPEFLG of FROM)) (replace (READTABLEP COMMONLISP) of RDTBL with (fetch (READTABLEP COMMONLISP) of FROM)) (replace (READTABLEP NUMBERBASE) of RDTBL with (fetch (READTABLEP NUMBERBASE) of FROM)) (replace (READTABLEP CASEINSENSITIVE) of RDTBL with (fetch (READTABLEP CASEINSENSITIVE) of FROM)) (replace (READTABLEP LOWER/FLIPCASE) of RDTBL with (fetch (READTABLEP LOWER/FLIPCASE) of FROM)) (replace (READTABLEP COMMONNUMSYNTAX) of RDTBL with (fetch (READTABLEP COMMONNUMSYNTAX) of FROM)) (replace (READTABLEP USESILPACKAGE) of RDTBL with (fetch (READTABLEP USESILPACKAGE) of FROM)) (replace (READTABLEP HASHMACROCHAR) of RDTBL with (fetch (READTABLEP HASHMACROCHAR) of FROM)) (replace (READTABLEP ESCAPECHAR) of RDTBL with (fetch (READTABLEP ESCAPECHAR) of FROM)) (replace (READTABLEP MULTESCAPECHAR) of RDTBL with (fetch (READTABLEP MULTESCAPECHAR) of FROM)) (replace (READTABLEP PACKAGECHAR) of RDTBL with (fetch (READTABLEP PACKAGECHAR) of FROM)) (replace (READTABLEP DISPATCHMACRODEFS) of RDTBL with (COPY (fetch (READTABLEP DISPATCHMACRODEFS) of FROM))) (* ;; "Placeholder.  If DISPATCHMACRODEFS ends up containing a CHARTABLE or a hash table, will have to do a REHASH or \COPYSYNTAX as well") (LET ((RDEFS (fetch (READTABLEP READMACRODEFS) of RDTBL)) (FDEFS (fetch (READTABLEP READMACRODEFS) of FROM)) N) (COND (RDEFS (CLRHASH RDEFS))) (AND FDEFS (REHASH FDEFS (OR RDEFS (replace (READTABLEP READMACRODEFS) of RDTBL with (HASHARRAY (HARRAYSIZE FDEFS) 7)))))) (\COPYSYNTAX (fetch READSA of FROM) (fetch READSA of RDTBL)) RDTBL)
+)
+
+(SETBRK
+(LAMBDA (LST FLG RDTBL) (* rmk%: "13-AUG-81 00:01") (* ; "This is a very ugly def which needs to be cleaned up cause a lot of people call SETBRK") (COND ((EQ LST T) (MAPC (GETSYNTAX (QUOTE BREAK) RDTBL) (FUNCTION (LAMBDA (X) (SETSYNTAX X (QUOTE OTHER) RDTBL)))) (MAPC (GETSYNTAX (QUOTE BREAK) (COND ((EQ RDTBL T) (QUOTE ORIG)) (T T))) (FUNCTION (LAMBDA (X) (SETSYNTAX X (QUOTE BREAK) RDTBL))))) (T (SELECTQ FLG (NIL (* ; "reset") (MAPC (GETSYNTAX (QUOTE BREAK) RDTBL) (FUNCTION (LAMBDA (X) (OR (MEMB X LST) (SETSYNTAX X (QUOTE OTHER) RDTBL))))) (MAPC LST (FUNCTION (LAMBDA (X) (SETSYNTAX X (QUOTE BREAK) RDTBL))))) (0 (* ; "clear out lst") (MAPC LST (FUNCTION (LAMBDA (X) (SETSYNTAX X (QUOTE OTHER) RDTBL))))) (1 (* ; "add chars") (MAPC LST (FUNCTION (LAMBDA (X) (SETSYNTAX X (QUOTE BREAK) RDTBL))))) NIL))))
+)
+
+(SETREADTABLE
+(LAMBDA (RDTBL FLG) (* bvm%: " 4-May-86 16:32") (PROG1 *READTABLE* (SETQ *READTABLE* (\GTREADTABLE RDTBL))))
+)
+
+(SETSEPR
+(LAMBDA (LST FLG RDTBL) (* rmk%: " 8-JUN-80 07:16") (* ; "This one also needs to be cleaned up") (COND ((EQ LST T) (MAPC (GETSYNTAX (QUOTE SEPR) RDTBL) (FUNCTION (LAMBDA (X) (SETSYNTAX X (QUOTE OTHER) RDTBL)))) (MAPC (GETSYNTAX (QUOTE SEPR) (COND ((EQ RDTBL T) (QUOTE ORIG)) (T T))) (FUNCTION (LAMBDA (X) (SETSYNTAX X (QUOTE SEPR) RDTBL))))) (T (SELECTQ FLG (NIL (* ; "reset") (MAPC (GETSYNTAX (QUOTE SEPR) RDTBL) (FUNCTION (LAMBDA (X) (SETSYNTAX X (QUOTE OTHER) RDTBL)))) (MAPC LST (FUNCTION (LAMBDA (X) (SETSYNTAX X (QUOTE SEPR) RDTBL))))) (0 (* ; "clear out lst") (MAPC LST (FUNCTION (LAMBDA (X) (SETSYNTAX X (QUOTE OTHER) RDTBL))))) (1 (* ; "add chars") (MAPC LST (FUNCTION (LAMBDA (X) (SETSYNTAX X (QUOTE SEPR) RDTBL))))) NIL))))
+)
+
+(\GETREADSYNTAX
+(LAMBDA (C TBL) (* bvm%: "30-Jun-86 17:49") (LET ((B (\SYNCODE (fetch READSA of TBL) C))) (* ;; "This will turn into a SELECTQ that keys off syntax code numbers and produces class tokens.  The default clause at the end: if it's not a built-in class, must be a macro") (* ;; "Sample code:") (* (SELECTQ B (0 (QUOTE OTHER)) (140Q (QUOTE SEPRCHAR)) (160Q (QUOTE BREAKCHAR)) (161Q (QUOTE STRINGDELIM)) (162Q (QUOTE LEFTPAREN)) (163Q (QUOTE RIGHTPAREN)) (164Q (QUOTE LEFTBRACKET)) (165Q (QUOTE RIGHTBRACKET)) (106Q (QUOTE ESCAPE)) (107Q (QUOTE MULTIPLE-ESCAPE)) (105Q (QUOTE PACKAGEDELIM)) <default>)) (\COMPUTED.FORM (BQUOTE (SELECTQ B (\,@ (for PAIR in READCLASSTOKENS collect (LIST (EVAL (CADR PAIR)) (KWOTE (CAR PAIR))))) (LET ((E (\GETREADMACRODEF C TBL)) KEY) (BQUOTE ((\, (fetch MACROTYPE of E)) (\, (fetch (CONTEXTS KEY) of (fetch MACROCONTEXT of B))) (\,@ (AND (NEQ (SETQ KEY (fetch (WAKEUPS KEY) of (fetch WAKEUP of B))) (QUOTE NONIMMEDIATE)) (LIST KEY))) (\,@ (AND (NEQ (SETQ KEY (fetch (ESCAPES KEY) of (fetch ESCAPE of B))) (QUOTE ESCQUOTE)) (LIST KEY))) (\, (fetch MACROFN of E))))))))))
+)
+
+(\GTREADTABLE
+(LAMBDA (X FLG) (* bvm%: " 5-May-86 11:05") (SELECTQ X ((NIL T) (\DTEST *READTABLE* (QUOTE READTABLEP))) (\GTREADTABLE1 X FLG)))
+)
+
+(\GTREADTABLE1
+(LAMBDA (X FLG) (* bvm%: "27-Jul-86 15:37") (COND ((type? READTABLEP X) X) ((AND FLG (GETHASH X \READTABLEHASH))) (T (LISPERROR "ILLEGAL READTABLE" X))))
+)
+
+(\ORIGREADTABLE
+(LAMBDA NIL (* ; "Edited  6-Nov-91 14:37 by jrb:") (* ;; "Creates a copy of the 'original' read-table.") (LET ((FOO (\TYPEGLOBALVARIABLE (QUOTE READTABLEP) T))) (DECLARE (SPECVARS FOO)) (PROG ((TBL (create READTABLEP READMACROFLG _ T ESCAPEFLG _ T NUMBERBASE _ 12Q USESILPACKAGE _ T ESCAPECHAR _ (CHARCODE %%) PACKAGECHAR _ (PROGN (* ;; "Need to have a character for package delimiter in all read tables, but for old read tables want one that is unlikely to have appeared in a symbol in an old source file.  Also would like it to be a 7-bit char, so we don't needlessly force MAKEFILE to produce binary files.") (CHARCODE "^^")) HASHMACROCHAR _ (CHARCODE "|")))) (* ;; "Actually, '|' is not defined in ORIG table, but rather later.  But the radix printer and others want it, and this is better than nothing") (SETSEPR (CHARCODE (SPACE TENEXEOL CR ^L LF TAB)) 1 TBL) (\SETREADSYNTAX (CHARCODE %]) (QUOTE RIGHTBRACKET) TBL) (\SETREADSYNTAX (CHARCODE %[) (QUOTE LEFTBRACKET) TBL) (\SETREADSYNTAX (CHARCODE %)) (QUOTE RIGHTPAREN) TBL) (\SETREADSYNTAX (CHARCODE %() (QUOTE LEFTPAREN) TBL) (\SETREADSYNTAX (CHARCODE %%) (QUOTE ESCAPE) TBL) (\SETREADSYNTAX (CHARCODE %") (QUOTE STRINGDELIM) TBL) (\SETREADSYNTAX 247Q (QUOTE PACKAGEDELIM) TBL) (* ; "Old choice for package delim char: the NS section symbol.  Keep for compatibility with Lyric Beta files") (\SETREADSYNTAX (CHARCODE "^^") (QUOTE PACKAGEDELIM) TBL) (RETURN TBL))))
+)
+
+(\READCLASSTOCODE
+(LAMBDA (CLASS) (* bvm%: " 9-Jul-85 00:43") (* ;;; "This turns into a SELECTQ that goes from CLASS token to numeric code") (\COMPUTED.FORM (BQUOTE (SELECTQ CLASS (\,@ READCLASSTOKENS) (SEPR (* ; "Synonym for SEPRCHAR") SEPRCHAR.RC) NIL))))
+)
+
+(\SETMACROSYNTAX
+(LAMBDA (C CLASS TBL) (* rmk%: " 3-Jan-84 13:20") (OR (AND (FMEMB (CAR CLASS) (QUOTE (MACRO SPLICE INFIX))) (CDR CLASS)) (\ILLEGAL.ARG CLASS)) (PROG (CONTEXT WAKEUP ESCAPE (LST CLASS) (A (fetch READMACRODEFS of TBL))) LP (COND ((CDR (SETQ LST (LISTP (CDR LST)))) (OR (AND (NULL CONTEXT) (SETQ CONTEXT (fetch (CONTEXTS VAL) of (CAR LST)))) (AND (NULL WAKEUP) (SETQ WAKEUP (fetch (WAKEUPS VAL) of (CAR LST)))) (AND (NULL ESCAPE) (SETQ ESCAPE (fetch (ESCAPES VAL) of (CAR LST)))) (\ILLEGAL.ARG CLASS)) (GO LP))) (OR (LISTP LST) (\ILLEGAL.ARG CLASS)) (COND (A (* ;; "This hack guarantees that the hasharray will not overflow and cause an error in the uninterruptable PUTHASH below.  If it didn't already have a value for C, then the macro bits are not set in C's syntax code, so the T value is harmless.") (OR (GETHASH C A) (PUTHASH C T A))) (T (replace READMACRODEFS of TBL with (SETQ A (HASHARRAY 7 7))))) (UNINTERRUPTABLY (PUTHASH C (create READMACRODEF MACROTYPE _ (CAR CLASS) MACROFN _ (CAR LST)) A) (\SETSYNCODE (fetch READSA of TBL) C (LOGOR (OR CONTEXT ALWAYS.RMC) (OR ESCAPE ESC.RME) (OR WAKEUP NONIMMEDIATE.RMW))))))
+)
+
+(\SETREADSYNTAX
+(LAMBDA (C CLASS TBL) (* bvm%: " 8-Mar-86 16:37") (PROG ((OLDSYNTAX (\SYNCODE (fetch (READTABLEP READSA) of TBL) C)) TEM) (COND ((EQ CLASS (QUOTE BREAK)) (COND ((fetch BREAK of OLDSYNTAX) (RETURN)) (T (SETQ CLASS (QUOTE BREAKCHAR)))))) (* ; "If already a BREAK character but also something else, like LPAR, leave it alone") (COND ((LISTP CLASS) (\SETMACROSYNTAX C CLASS TBL)) ((SETQ TEM (\READCLASSTOCODE CLASS)) (UNINTERRUPTABLY (COND ((fetch MACROP of OLDSYNTAX) (* ; "No longer a macro") (REMHASH C (fetch READMACRODEFS of TBL)))) (\SETSYNCODE (fetch READSA of TBL) C TEM))) (T (\ILLEGAL.ARG CLASS)))))
+)
+
+(\READTABLEP.DEFPRINT
+(LAMBDA (RDTBL STREAM) (* bvm%: "13-Oct-86 17:32") (* ;; "Print read table as, for example, #<ReadTable name/76,5432>") (LET ((NAME (fetch (READTABLEP READTBLNAME) of RDTBL))) (.SPACECHECK. STREAM (IPLUS (CONSTANT (NCHARS "<ReadTable />")) (PROGN (* ; "Longest address is `177,177777'") 12Q) (COND (NAME (NCHARS NAME)) (T 0)))) (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*)) (\SOUT "<ReadTable" STREAM) (COND (NAME (\OUTCHAR STREAM (CHARCODE SPACE)) (\SOUT (MKSTRING NAME) STREAM))) (\OUTCHAR STREAM (CHARCODE /)) (\PRINTADDR RDTBL STREAM) (\OUTCHAR STREAM (CHARCODE >)) T))
+)
+)
+
+(PUTPROPS READTABLEPROP ARGNAMES (RDTBL PROP NEWVALUE))
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+
+(RPAQQ READCLASSTOKENS ((OTHER 0) (SEPRCHAR (LOGOR ESCAPEBIT STOPATOMBIT 0)) (BREAKCHAR (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0)) (STRINGDELIM (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) (LEFTPAREN (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RIGHTPAREN (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3)) (LEFTBRACKET (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RIGHTBRACKET (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5)) (ESCAPE (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (MULTIPLE-ESCAPE (LOGOR ESCAPEBIT INNERESCAPEBIT 7)) (PACKAGEDELIM (LOGOR ESCAPEBIT INNERESCAPEBIT 1))))
+
+(RPAQ READCLASSES (MAPCAR READCLASSTOKENS (FUNCTION (LAMBDA (PAIR) (LIST (PACK* (CAR PAIR) ".RC") (CADR PAIR))))))
+
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \COMPUTED.FORM MACRO (X (CONS (QUOTE PROGN) (MAPCAR X (FUNCTION EVAL)))))
+)
+
+(DECLARE%: EVAL@COMPILE
+
+(ACCESSFNS CONTEXTS ((KEY (SELECTC DATUM (ALWAYS.RMC (QUOTE ALWAYS)) (FIRST.RMC (QUOTE FIRST)) (ALONE.RMC (QUOTE ALONE)) NIL)) (VAL (SELECTQ DATUM (ALWAYS ALWAYS.RMC) (FIRST FIRST.RMC) (ALONE ALONE.RMC) NIL)))
+)
+
+(ACCESSFNS ESCAPES ((KEY (SELECTC DATUM (ESC.RME (QUOTE ESCQUOTE)) (NOESC.RME (QUOTE NOESCQUOTE)) NIL)) (VAL (SELECTQ DATUM ((ESCQUOTE ESC) ESC.RME) ((NOESCQUOTE NOESC) NOESC.RME) NIL)))
+)
+
+(ACCESSFNS WAKEUPS ((KEY (SELECTC DATUM (IMMEDIATE.RMW (QUOTE IMMEDIATE)) (NONIMMEDIATE.RMW (QUOTE NONIMMEDIATE)) NIL)) (VAL (SELECTQ DATUM ((IMMEDIATE IMMED WAKEUP) IMMEDIATE.RMW) ((NONIMMEDIATE NONIMMED NOWAKEUP) NONIMMEDIATE.RMW) NIL)))
+)
+)
+
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \GETREADMACRODEF MACRO ((C TBL) (GETHASH C (fetch READMACRODEFS of TBL))))
+
+(PUTPROPS \GTREADTABLE MACRO (ARGS (COND ((LITATOM (CAR ARGS)) (SUBPAIR (QUOTE (X . FLG)) ARGS (QUOTE (SELECTQ X ((NIL T) (\DTEST *READTABLE* (QUOTE READTABLEP))) (\GTREADTABLE1 X . FLG))))) (T (QUOTE IGNOREMACRO)))))
+
+(PUTPROPS \GTREADTABLE1 DMACRO (ARGS (COND ((NULL (CDR ARGS)) (LIST (QUOTE \DTEST) (CAR ARGS) (QUOTE (QUOTE READTABLEP)))) (T (QUOTE IGNOREMACRO)))))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ MACROBIT 10Q)
+
+(RPAQQ BREAKBIT 20Q)
+
+(RPAQQ STOPATOMBIT 40Q)
+
+(RPAQQ ESCAPEBIT 100Q)
+
+(RPAQQ INNERESCAPEBIT 4)
+
+
+(CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT)
+)
+
+(RPAQQ READCODEMASKS ((CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1)) (WAKEUPMASK (LOGOR MACROBIT 2))))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQ CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1))
+
+(RPAQ WAKEUPMASK (LOGOR MACROBIT 2))
+
+
+(CONSTANTS (CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1)) (WAKEUPMASK (LOGOR MACROBIT 2)))
+)
+
+(RPAQQ READMACROCONTEXTS ((ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0)) (FIRST.RMC (LOGOR MACROBIT 0)) (ALONE.RMC (LOGOR MACROBIT 1))))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQ ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0))
+
+(RPAQ FIRST.RMC (LOGOR MACROBIT 0))
+
+(RPAQ ALONE.RMC (LOGOR MACROBIT 1))
+
+
+(CONSTANTS (ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0)) (FIRST.RMC (LOGOR MACROBIT 0)) (ALONE.RMC (LOGOR MACROBIT 1)))
+)
+
+(RPAQQ READCLASSES ((OTHER.RC 0) (SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0)) (BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0)) (STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) (LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3)) (LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5)) (ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7)) (PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1))))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ OTHER.RC 0)
+
+(RPAQ SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0))
+
+(RPAQ BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0))
+
+(RPAQ STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1))
+
+(RPAQ LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2))
+
+(RPAQ RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3))
+
+(RPAQ LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4))
+
+(RPAQ RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5))
+
+(RPAQ ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6))
+
+(RPAQ MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7))
+
+(RPAQ PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1))
+
+
+(CONSTANTS (OTHER.RC 0) (SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0)) (BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0)) (STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) (LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3)) (LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5)) (ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7)) (PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1)))
+)
+
+(RPAQQ READMACROWAKEUPS ((IMMEDIATE.RMW (LOGOR MACROBIT 2)) (NONIMMEDIATE.RMW (LOGOR MACROBIT 0))))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQ IMMEDIATE.RMW (LOGOR MACROBIT 2))
+
+(RPAQ NONIMMEDIATE.RMW (LOGOR MACROBIT 0))
+
+
+(CONSTANTS (IMMEDIATE.RMW (LOGOR MACROBIT 2)) (NONIMMEDIATE.RMW (LOGOR MACROBIT 0)))
+)
+
+(RPAQQ READMACROESCAPES ((ESC.RME ESCAPEBIT) (NOESC.RME 0)))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQ ESC.RME ESCAPEBIT)
+
+(RPAQQ NOESC.RME 0)
+
+
+(CONSTANTS (ESC.RME ESCAPEBIT) (NOESC.RME 0))
+)
+(DECLARE%: EVAL@COMPILE
+
+(ACCESSFNS READCODE ((ESCAPE (LOGAND DATUM ESCAPEBIT)) (ESCQUOTE (BITTEST DATUM ESCAPEBIT)) (STOPATOM (BITTEST DATUM STOPATOMBIT)) (INNERESCQUOTE (BITTEST DATUM (LOGOR STOPATOMBIT INNERESCAPEBIT))) (MACROCONTEXT (LOGAND DATUM CONTEXTMASK)) (MACROP (BITTEST DATUM MACROBIT)) (WAKEUP (LOGAND DATUM WAKEUPMASK)) (BREAK (BITTEST DATUM BREAKBIT)))
+)
+
+(RECORD READMACRODEF (MACROTYPE . MACROFN))
+
+(DATATYPE READTABLEP ((READSA POINTER) (* ; "A CHARTABLE defining syntax of each char") (READMACRODEFS POINTER) (* ; "A hash table associating macro chars with macro definitions") (READMACROFLG FLAG) (* ; "True if read macros are enabled (turned off by Interlisp's crufty READMACROS function)") (ESCAPEFLG FLAG) (* ; "True if the char(s) with escape syntax are enabled (turned off by Interlisp's crufty ESCAPE function)") (COMMONLISP FLAG) (* ; "True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules") (NUMBERBASE BITS 5) (* ; "Not used") (CASEINSENSITIVE FLAG) (* ; "If true, unescaped lowercase chars are converted to uppercase in symbols") (COMMONNUMSYNTAX FLAG) (* ; "True if number notation includes Common Lisp numbers: rationals as a/b, and the dfls exponent markers") (USESILPACKAGE FLAG) (* ; "If true, IL:READ ignores *PACKAGE* and reads in the IL package") (LOWER/FLIPCASE FLAG) (* ; "This flag plus CASEINSENSITIVE = CL:READTABLE-CASE as required by CLtL2, as follows:") (* ; ":PRESERVE - (not ci) and (not lf)") (* ; ":INVERT - (not ci) and lf") (* ; ":UPCASE - ci and (not lf)") (* ; ":DOWNCASE - ci and lf") (* ; "You are urged to use CL:READTABLE-CASE and its setf instead of accessing these flags directly") (NIL 4 FLAG) (DISPATCHMACRODEFS POINTER) (* ; "An a-list of dispatching macro char and its dispatch definitions") (HASHMACROCHAR BYTE) (* ; "The character code used in this read table for the # dispatch macro") (ESCAPECHAR BYTE) (* ; "The character code used in this read table for single escape") (MULTESCAPECHAR BYTE) (* ; "The character code used in this read table for multiple escape") (PACKAGECHAR BYTE) (* ; "The character code used in this read table for package delimiter") (READTBLNAME POINTER) (* ; "The canonical 'name' of this read table"))
+ READSA _ (create CHARTABLE))
+)
+
+(/DECLAREDATATYPE (QUOTE READTABLEP) (QUOTE (POINTER POINTER FLAG FLAG FLAG (BITS 5) FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER)) (QUOTE ((READTABLEP 0 POINTER) (READTABLEP 2 POINTER) (READTABLEP 2 (FLAGBITS . 0)) (READTABLEP 2 (FLAGBITS . 20Q)) (READTABLEP 2 (FLAGBITS . 40Q)) (READTABLEP 2 (BITS . 64Q)) (READTABLEP 0 (FLAGBITS . 0)) (READTABLEP 0 (FLAGBITS . 20Q)) (READTABLEP 0 (FLAGBITS . 40Q)) (READTABLEP 0 (FLAGBITS . 60Q)) (READTABLEP 0 (FLAGBITS . 100Q)) (READTABLEP 0 (FLAGBITS . 120Q)) (READTABLEP 0 (FLAGBITS . 140Q)) (READTABLEP 0 (FLAGBITS . 160Q)) (READTABLEP 4 POINTER) (READTABLEP 4 (BITS . 7)) (READTABLEP 6 (BITS . 7)) (READTABLEP 6 (BITS . 207Q)) (READTABLEP 7 (BITS . 7)) (READTABLEP 10Q POINTER))) (QUOTE 12Q))
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \ORIGREADTABLE \READTABLEHASH \ORIGTERMTABLE)
+)
+)
+
+(/DECLAREDATATYPE (QUOTE READTABLEP) (QUOTE (POINTER POINTER FLAG FLAG FLAG (BITS 5) FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER)) (QUOTE ((READTABLEP 0 POINTER) (READTABLEP 2 POINTER) (READTABLEP 2 (FLAGBITS . 0)) (READTABLEP 2 (FLAGBITS . 20Q)) (READTABLEP 2 (FLAGBITS . 40Q)) (READTABLEP 2 (BITS . 64Q)) (READTABLEP 0 (FLAGBITS . 0)) (READTABLEP 0 (FLAGBITS . 20Q)) (READTABLEP 0 (FLAGBITS . 40Q)) (READTABLEP 0 (FLAGBITS . 60Q)) (READTABLEP 0 (FLAGBITS . 100Q)) (READTABLEP 0 (FLAGBITS . 120Q)) (READTABLEP 0 (FLAGBITS . 140Q)) (READTABLEP 0 (FLAGBITS . 160Q)) (READTABLEP 4 POINTER) (READTABLEP 4 (BITS . 7)) (READTABLEP 6 (BITS . 7)) (READTABLEP 6 (BITS . 207Q)) (READTABLEP 7 (BITS . 7)) (READTABLEP 10Q POINTER))) (QUOTE 12Q))
+(DEFINEQ
+
+(\ATBLSET
+(LAMBDA NIL (* ; "Edited  3-Dec-86 18:07 by Pavel") (DECLARE (GLOBALVARS \ORIGREADTABLE \ORIGTERMTABLE)) (COND ((NULL (BOUNDP (QUOTE \PRIMREADTABLE))) (initrecord CHARTABLE) (* ;; "Read tables") (SETQ \READTABLEHASH (HASHARRAY 24Q NIL (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING-EQUAL))) (LET (TRDTBL NEW-IL-RDTBL) (PROGN (* ; "The ORIG read table") (SETQ \ORIGREADTABLE (\ORIGREADTABLE)) (READTABLEPROP \ORIGREADTABLE (QUOTE NAME) (QUOTE ORIG))) (PROGN (* ; "The old Interlisp T read table.  May not have a use for this any more") (SETQ TRDTBL (COPYREADTABLE \ORIGREADTABLE)) (SETSYNTAX (CHARCODE "|") (QUOTE (MACRO READVBAR)) TRDTBL) (SETSYNTAX (CHARCODE "`") (QUOTE (MACRO FIRST READBQUOTE)) TRDTBL) (SETSYNTAX (CHARCODE ",") (QUOTE (MACRO FIRST READBQUOTECOMMA)) TRDTBL) (SETSYNTAX (CHARCODE "'") (QUOTE (MACRO FIRST READQUOTE)) TRDTBL) (READTABLEPROP TRDTBL (QUOTE NAME) "OLD-INTERLISP-T") (PROGN (* ; "Temporary") (SETTOPVAL (QUOTE %#CURRENTRDTBL#) TRDTBL))) (PROGN (* ; "The old FILERDTBL") (SETQ FILERDTBL (COPYREADTABLE \ORIGREADTABLE)) (SETSYNTAX (CHARCODE "|") TRDTBL FILERDTBL) (READTABLEPROP FILERDTBL (QUOTE NAME) "OLD-INTERLISP-FILE") (SETQ *OLD-INTERLISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REREADTABLE _ FILERDTBL REBASE _ 12Q)) (* ; "need this to read files in the loadup")) (PROGN (SETQ NEW-IL-RDTBL (COPYREADTABLE TRDTBL)) (* ; "The new Interlisp read table is more common lispy") (READTABLEPROP NEW-IL-RDTBL (QUOTE MULTIPLE-ESCAPECHAR) (CHARCODE "|")) (READTABLEPROP NEW-IL-RDTBL (QUOTE HASHMACROCHAR) (CHARCODE "#")) (SET-DEFAULT-HASHMACRO-SETTINGS NEW-IL-RDTBL) (READTABLEPROP NEW-IL-RDTBL (QUOTE COMMONNUMSYNTAX) T) (READTABLEPROP NEW-IL-RDTBL (QUOTE USESILPACKAGE) NIL) (READTABLEPROP NEW-IL-RDTBL (QUOTE NAME) "INTERLISP") (for I from 1 to 32Q do (SETSYNTAX I (QUOTE SEPRCHAR) FILERDTBL) (* ; "Make font switch chars seprs") (SETSYNTAX I (QUOTE SEPRCHAR) NEW-IL-RDTBL)) (SETQ *READTABLE* NEW-IL-RDTBL)) (* ;; "Make ^Y like #. in the old T readtable and the new INTERLISP one.") (SETSYNTAX (CHARCODE ^Y) (QUOTE (MACRO ALWAYS (LAMBDA (FILE RDTBL) (EVAL (READ FILE RDTBL))))) TRDTBL) (SETSYNTAX (CHARCODE ^Y) TRDTBL NEW-IL-RDTBL) (DEFPRINT (QUOTE READTABLEP) (QUOTE \READTABLEP.DEFPRINT))) (* ;; "Terminal tables") (SETQ \ORIGTERMTABLE (\ORIGTERMTABLE)) (SETQ \PRIMTERMTABLE (COPYTERMTABLE \ORIGTERMTABLE)) (SETQ \PRIMTERMSA (fetch TERMSA of \PRIMTERMTABLE)) (PUTD (QUOTE \ATBLSET)) (PUTD (QUOTE \ORIGTERMTABLE)) NIL)))
+)
+)
+
+(/DECLAREDATATYPE (QUOTE READER-ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((READER-ENVIRONMENT 0 POINTER) (READER-ENVIRONMENT 2 POINTER) (READER-ENVIRONMENT 4 POINTER) (READER-ENVIRONMENT 6 POINTER))) (QUOTE 10Q))
+
+
+
+(* ; "Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")
+
+(DEFINEQ
+
+(MAKE-READER-ENVIRONMENT
+(LAMBDA (PACKAGE READTABLE BASE) (* ; "Edited 18-Dec-86 18:28 by bvm:") (create READER-ENVIRONMENT REPACKAGE _ (COND (PACKAGE (\DTEST PACKAGE (QUOTE PACKAGE))) (T *PACKAGE*)) REREADTABLE _ (COND (READTABLE (\DTEST READTABLE (QUOTE READTABLEP))) (T *READTABLE*)) REBASE _ (COND (BASE (\CHECKRADIX BASE)) (T *PRINT-BASE*))))
+)
+
+(EQUAL-READER-ENVIRONMENT
+(LAMBDA (ENV1 ENV2) (* bvm%: "31-Jul-86 12:54") (AND (EQ (fetch (READER-ENVIRONMENT REREADTABLE) of ENV1) (fetch (READER-ENVIRONMENT REREADTABLE) of ENV2)) (EQ (fetch (READER-ENVIRONMENT REPACKAGE) of ENV1) (fetch (READER-ENVIRONMENT REPACKAGE) of ENV2)) (EQ (fetch (READER-ENVIRONMENT REBASE) of ENV1) (fetch (READER-ENVIRONMENT REBASE) of ENV2))))
+)
+
+(SET-READER-ENVIRONMENT
+(LAMBDA (ENV) (* bvm%: "28-Aug-86 17:44") (* ;;; "Sets the reader environment variables from ENV.  Should usually only be called inside a WITH-READER-ENVIRONMENT.") (SETQ *PACKAGE* (ffetch REPACKAGE of (\DTEST ENV (QUOTE READER-ENVIRONMENT)))) (SETQ *READTABLE* (ffetch REREADTABLE of ENV)) (SETQ *READ-BASE* (SETQ *PRINT-BASE* (ffetch REBASE of ENV))) ENV)
+)
+)
+
+(RPAQ? *LISP-PACKAGE*)
+
+(RPAQ? *INTERLISP-PACKAGE*)
+
+(RPAQ? *KEYWORD-PACKAGE*)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(\ATBLSET)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA)
+
+(ADDTOVAR NLAML)
+
+(ADDTOVAR LAMA READTABLEPROP)
+)
+(PUTPROPS ATBL COPYRIGHT ("Venue & Xerox Corporation" 3676Q 3677Q 3700Q 3701Q 3702Q 3703Q 3706Q 3707Q)
+)
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (32764Q 44506Q (GETSYNTAX 32776Q . 36766Q) (SETSYNTAX 36770Q . 40245Q) (SYNTAXP 40247Q
+ . 42155Q) (\COPYSYNTAX 42157Q . 42717Q) (\GETCHARCODE 42721Q . 43174Q) (\SETFATSYNCODE 43176Q . 
+44504Q)) (44547Q 64356Q (CONTROL 44561Q . 45035Q) (COPYTERMTABLE 45037Q . 45322Q) (DELETECONTROL 
+45324Q . 47443Q) (GETDELETECONTROL 47445Q . 50445Q) (ECHOCHAR 50447Q . 51567Q) (ECHOCONTROL 51571Q . 
+52225Q) (ECHOMODE 52227Q . 52474Q) (GETECHOMODE 52476Q . 52642Q) (GETCONTROL 52644Q . 53012Q) (
+GETTERMTABLE 53014Q . 53106Q) (RAISE 53110Q . 53376Q) (GETRAISE 53400Q . 53542Q) (RESETTERMTABLE 
+53544Q . 55030Q) (SETTERMTABLE 55032Q . 55275Q) (TERMTABLEP 55277Q . 55436Q) (\GETTERMSYNTAX 55440Q . 
+55655Q) (\GTTERMTABLE 55657Q . 56223Q) (\ORIGTERMTABLE 56225Q . 62041Q) (\SETTERMSYNTAX 62043Q . 
+62653Q) (\TERMCLASSTOCODE 62655Q . 63303Q) (\TERMCODETOCLASS 63305Q . 64004Q) (\LITCHECK 64006Q . 
+64354Q)) (70234Q 120703Q (COPYREADTABLE 70246Q . 70443Q) (FIND-READTABLE 70445Q . 70603Q) (
+IN-READTABLE 70605Q . 70756Q) (ESCAPE 70760Q . 71235Q) (GETBRK 71237Q . 71370Q) (GETREADTABLE 71372Q
+ . 71513Q) (GETSEPR 71515Q . 71646Q) (READMACROS 71650Q . 72137Q) (READTABLEP 72141Q . 72303Q) (
+READTABLEPROP 72305Q . 77160Q) (RESETREADTABLE 77162Q . 102543Q) (SETBRK 102545Q . 104233Q) (
+SETREADTABLE 104235Q . 104435Q) (SETSEPR 104437Q . 106014Q) (\GETREADSYNTAX 106016Q . 110154Q) (
+\GTREADTABLE 110156Q . 110402Q) (\GTREADTABLE1 110404Q . 110662Q) (\ORIGREADTABLE 110664Q . 113527Q) (
+\READCLASSTOCODE 113531Q . 114140Q) (\SETMACROSYNTAX 114142Q . 116333Q) (\SETREADSYNTAX 116335Q . 
+117520Q) (\READTABLEP.DEFPRINT 117522Q . 120701Q)) (143022Q 147707Q (\ATBLSET 143034Q . 147705Q)) (
+150431Q 152612Q (MAKE-READER-ENVIRONMENT 150443Q . 151204Q) (EQUAL-READER-ENVIRONMENT 151206Q . 
+152003Q) (SET-READER-ENVIRONMENT 152005Q . 152610Q)))))
+STOP
diff --git a/CLTL2/ATBL.LCOM b/CLTL2/ATBL.LCOM
new file mode 100644
index 00000000..a6c14131
Binary files /dev/null and b/CLTL2/ATBL.LCOM differ
diff --git a/CLTL2/ATERM b/CLTL2/ATERM
new file mode 100644
index 00000000..b71fa582
--- /dev/null
+++ b/CLTL2/ATERM
@@ -0,0 +1,341 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED " 8-Jul-92 17:20:45" {DSK}<usr>local>lde>lispcore>sources>ATERM.;3 36408  
+
+      changes to%:  (RECORDS LINEBUFFER) (VARS ATERMCOMS) (FNS \SETUP.DEFAULT.LINEBUF \LINEBUFFER.GETNEXTBUFFER)
+
+      previous date%: "16-May-90 12:08:04" {DSK}<usr>local>lde>lispcore>sources>ATERM.;1)
+
+
+(* ; "
+Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT ATERMCOMS)
+
+(RPAQQ ATERMCOMS ((* ; "Line-buffering") (FNS BKLINBUF CLEARBUF LINBUF PAGEFULLFN SETLINELENGTH SYSBUF TERMCHARWIDTH TERMINAL-INPUT TERMINAL-OUTPUT \CHDEL1 \CLOSELINE \DECPARENCOUNT \ECHOCHAR \FILLBUFFER \FILLBUFFER.WORDSEPRP \FILLBUFFER.BACKUP \GETCHAR \INCPARENCOUNT \RESETLINE \RESETTERMINAL \SAVELINEBUF \STOPSCROLL?) (COMS * BCPLDISPLAYCOMS) (COMS (FNS VIDEOCOLOR) (VARS (\VideoColor)) (PROP ARGNAMES VIDEOCOLOR)) (DECLARE%: DOCOPY DONTEVAL@LOAD (P (MOVD? (QUOTE NILL) (QUOTE SETDISPLAYHEIGHT)))) (DECLARE%: DONTCOPY (MACROS \RAISECHAR \LINEBUFBOUT)) (FNS \PEEKREFILL \READREFILL \RATOM/RSTRING-REFILL \READCREFILL) (FNS DRIBBLE DRIBBLEFILE) (FNS \SETUP.DEFAULT.LINEBUF \CREATELINEBUFFER \LINEBUF.READP \LINEBUF.EOFP \LINEBUF.PEEKBIN \LINEBUFFER.GETNEXTBUFFER \OPENLINEBUF) (COMS (* ; "User entries to make up for fact that (EOFP T) = NIL now.") (FNS LINEBUFFER-EOFP LINEBUFFER-SKIPSEPRS)) (DECLARE%: DOCOPY DONTEVAL@LOAD (VARS (\#DISPLAYLINES 58) (\DISPLAYLINELENGTH 82) (\CURRENTDISPLAYLINE 0) (\STOPSCROLLMESSAGE "---MORE---")) (VARS (\SYSBUF NIL) (\LINBUF NIL)) (P (MOVD? (QUOTE \OPENLINEBUF) (QUOTE \CREATE.TTYDISPLAYSTREAM))) (VARS (\DEFAULTLINEBUF (\SETUP.DEFAULT.LINEBUF))) (P (\OPENLINEBUF))) (FNS \INTERMP \OUTTERMP) (EXPORT (DECLARE%: DONTCOPY (RECORDS LINEBUFFER) (CONSTANTS * LINEBUFFERSTATES) (MACROS \INTERMP \OUTTERMP) (GLOBALVARS \DEFAULTLINEBUF))) (DECLARE%: DONTCOPY (CONSTANTS * FILLTYPES)) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA VIDEOCOLOR TERMINAL-OUTPUT TERMINAL-INPUT))) (PROP FILETYPE ATERM)))
+
+
+
+(* ; "Line-buffering")
+
+(DEFINEQ
+
+(BKLINBUF
+(LAMBDA (STR) (* bvm%: " 5-May-86 11:38") (COND ((STRINGP STR) (\RESETLINE) (for J C (SA _ (fetch READSA of (\DTEST *READTABLE* (QUOTE READTABLEP)))) from 1 while (SETQ C (NTHCHARCODE STR J)) do (\OUTCHAR \LINEBUF.OFD C) (\INCPARENCOUNT (\SYNCODE SA C))) (\CLOSELINE) STR)))
+)
+
+(CLEARBUF
+(LAMBDA (FILE FLG) (* ; "Edited 17-Jan-87 16:08 by bvm:") (PROG ((STRM (SELECTQ FILE (T \LINEBUF.OFD) (NIL *STANDARD-INPUT*) (\GETSTREAM FILE (QUOTE INPUT)))) SYSBUF LINBUF) (* ; "Do the stream coercion in line so we don't needlessly create a tty window just to clear input") (COND ((AND (EQ STRM \LINEBUF.OFD) (NEQ STRM \DEFAULTLINEBUF)) (* ; "Don't do this if \LINEBUF.OFD is the default, since then there really isn't anything to save") (COND (FLG (SETQ LINBUF (\SAVELINEBUF)) (SETQ SYSBUF (\SAVESYSBUF)) (COND ((OR LINBUF SYSBUF) (* ; "note in manual: if both buffers are empty, don't change saved ones.") (SETQ \LINBUF LINBUF) (SETQ \SYSBUF SYSBUF)))) (T (\CLEARSYSBUF))) (* ; "check for mouse events enabled and coordinated with keyboard") (\RESETTERMINAL)))) NIL)
+)
+
+(LINBUF
+(LAMBDA (FLG) (* rrb "21-JUL-83 15:33") (COND (FLG (AND \LINBUF (CONCAT \LINBUF))) (T (SETQ \LINBUF NIL))))
+)
+
+(PAGEFULLFN
+(LAMBDA (STREAM) (* lmm "10-Jan-86 01:19") (* ;; "default function that is called by \STOPSCROLL?  when more lines are printed in a row than will fit on the screen or window.") (* ;; "If no input is pending, it waits for a character to be typed.") (LET ((KEYSTREAM (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD))) (COND ((READP KEYSTREAM)) ((DISPLAYSTREAMP STREAM) (* ; "reverse only this window.") (RESETLST (RESETSAVE (SETDISPLAYHEIGHT T)) (COND ((AND (NOT (TTY.PROCESSP)) (EQ (PROCESSPROP (THIS.PROCESS) (QUOTE NAME)) (QUOTE MOUSE))) (* ; "Running under mouse, so can't make this proc be the tty process") (RESETSAVE (TTY.PROCESS (THIS.PROCESS))))) (RESETSAVE (INVERTW STREAM) (LIST (FUNCTION INVERTW) STREAM)) (BIN KEYSTREAM))) (T (PRIN1 \STOPSCROLLMESSAGE STREAM) (BIN KEYSTREAM) (* ; "Now erase the message") (FRPTQ (NCHARS \STOPSCROLLMESSAGE) (\OUTCHAR STREAM ERASECHARCODE)) (BLOCK)))))
+)
+
+(SETLINELENGTH
+(LAMBDA (N) (* rrb "22-JUL-83 10:10") (LINELENGTH (OR N (fetch (STREAM LINELENGTH) of \TERM.OFD)) T)))
+
+(SYSBUF
+(LAMBDA (FLG) (* rrb "21-JUL-83 15:34") (COND (FLG (AND \SYSBUF (CONCAT \SYSBUF))) (T (SETQ \SYSBUF NIL))))
+)
+
+(TERMCHARWIDTH
+(LAMBDA (CHARCODE STREAM TTBL) (* JonL " 8-NOV-83 03:28") (* ;; "Returns the width that the printed representation of CHARCODE would occupy if printed on the terminal STREAM, allowing for the various escape sequences.  Used by \ECHOCHAR") (\STREAMCHARWIDTH (LOGAND CHARCODE \CHARMASK) (\OUTSTREAMARG STREAM) (GETTERMTABLE TTBL)))
+)
+
+(TERMINAL-INPUT
+(LAMBDA U (* ; "Edited 17-Jan-87 16:08 by bvm:") (* ;;; "Return the current terminal output stream.  If an argument is supplied, make it the new terminal output stream") (PROG1 \LINEBUF.OFD (COND ((IGEQ U 1) (LET ((STREAM (GETSTREAM (ARG U 1) (QUOTE INPUT)))) (if (EQ *STANDARD-INPUT* \LINEBUF.OFD) then (SETQ *STANDARD-INPUT* STREAM)) (SETQ \LINEBUF.OFD STREAM))))))
+)
+
+(TERMINAL-OUTPUT
+(LAMBDA U (* ; "Edited 17-Jan-87 16:08 by bvm:") (* ;;; "Return the current terminal output stream.  If an argument is supplied, make it the new terminal output stream") (PROG1 \TERM.OFD (COND ((IGEQ U 1) (LET ((STREAM (GETSTREAM (ARG U 1) (QUOTE OUTPUT)))) (if (EQ *STANDARD-OUTPUT* \TERM.OFD) then (SETQ *STANDARD-OUTPUT* STREAM)) (SETQ TtyDisplayStream (SETQ \TERM.OFD STREAM)))))))
+)
+
+(\CHDEL1
+(LAMBDA NIL (* rmk%: "28-Mar-85 18:25") (COND ((\BACKNSCHAR \LINEBUF.OFD (UNFOLD \NORUNCODE 256)) (PROG1 (\NSPEEK \LINEBUF.OFD (UNFOLD \NORUNCODE 256)) (\SETEOFPTR \LINEBUF.OFD (GETFILEPTR \LINEBUF.OFD))))))
+)
+
+(\CLOSELINE
+(LAMBDA NIL (* lmm "10-Jan-86 03:07") (SETQ \CURRENTDISPLAYLINE 0) (UNINTERRUPTABLY (\SETFILEPTR \LINEBUF.OFD 0) (replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with READING.LBS)))
+)
+
+(\DECPARENCOUNT
+(LAMBDA (RSNX) (* bvm%: "14-Feb-85 00:29") (* ;; "This updates parencounts as characters are removed from the buffer due to line-editting.  RSNX is a readtable syntax code") (COND ((EQ RSNX STRINGDELIM.RC) (replace (LINEBUFFER INSTRINGP) of \LINEBUF.OFD with (NOT (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD)))) ((NOT (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD)) (SELECTC RSNX (LEFTPAREN.RC (COND ((EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) 0) (add (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD) -1)))) (RIGHTPAREN.RC (COND ((EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) 0) (add (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD) 1)))) (LEFTBRACKET.RC (add (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) -1)) (RIGHTBRACKET.RC (add (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) 1)) NIL))))
+)
+
+(\ECHOCHAR
+(LAMBDA (C) (* ; "Edited 15-Jun-87 16:58 by jds") (* ;; "Echo the character-code C appropriately.  If it really got echoed, return T, otherwise NIL.") (COND ((fetch ECHOFLG of \PRIMTERMTABLE) (COND ((AND (EQ (fetch RAISEFLG of \PRIMTERMTABLE) 0) (IGEQ C (CHARCODE a)) (ILEQ C (CHARCODE z))) (* ; "This is doing a raise if flag is set") (SETQ C (IDIFFERENCE C 32)))) (\OUTCHAR \TERM.OFD C) T)))
+)
+
+(\FILLBUFFER
+(LAMBDA (FILLTYPE) (* ; "Edited 20-Aug-87 17:52 by jds") (* ;; "While filling the line, the current file pointer is the end of the line.  When the line is closed, this is made the eof.   *READTABLE* is used for syntactic delimiters and paren counting on READ and RATOM calls but isn't referenced (or bound) for READC") (DECLARE (USEDFREE *READTABLE* *READ-NEWLINE-SUPPRESS*)) (\RESETLINE) (PROG ((ILB (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD)) (ISP (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD)) (ILP (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD)) (KEYSTREAM (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD)) (RTBLSA (fetch READSA of *READTABLE*)) (CONTROLTON (fetch CONTROLFLG of \PRIMTERMTABLE)) RSNX TCLASS CHAR RAISEDCHAR PEEKEDECHOED) (* ;; "AR 8999/9000 the RTBLSA init code used to set it to nil if FILLTYPE were READC.FT; alas, RTBLSA is used even when that's true. --JDS 8/20/87") (DECLARE (SPECVARS RTBLSA)) (* ; "TCLASS is terminal syntax class, RSNX is read-table code") (COND ((SETQ CHAR (fetch (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD)) (* ; "Account for peeked character, adn remember if for further down.") (SETQ CHAR (IABS CHAR)) (* ; "The peeked char may be negative because it was BIN'ed earlier.  Make sure it is positive.") (COND ((NOT (fetch (LINEBUFFER PEEKEDECHOFLG) of \LINEBUF.OFD)) (* ; "It wasn't echoed when first read, so echo it now if desired") (* ; "Incompatible with I-10 to do it this way") (\ECHOCHAR CHAR))) (replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with NIL) (replace (LINEBUFFER PEEKEDECHOFLG) of \LINEBUF.OFD with NIL) (SETQ PEEKEDECHOED T) (SETQ RAISEDCHAR (\RAISECHAR CHAR)))) (COND ((AND CONTROLTON (EQ FILLTYPE READC.FT)) (\LINEBUFBOUT \LINEBUF.OFD (OR CHAR (\GETCHAR))) (GO EXIT))) (COND (CHAR (GO NEXTTCLASS))) NEXT (SETQ CHAR (BIN KEYSTREAM)) NEXTTCLASS (SETQ TCLASS (fetch TERMCLASS of (\SYNCODE \PRIMTERMSA (SETQ RAISEDCHAR (\RAISECHAR CHAR))))) REDO (SELECTC TCLASS (RETYPE.TC (\OUTCHAR \TERM.OFD (CHARCODE EOL)) (\SETEOFPTR \LINEBUF.OFD (\GETFILEPTR \LINEBUF.OFD)) (* ;; "Make the EOF be accurate during retyping, in case an interrupt happens and the buffer gets saved via \SAVELINEBUF.") (UNINTERRUPTABLY (\SETFILEPTR \LINEBUF.OFD 0) (replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with RETYPING.LBS)) (until (\PAGEDEOFP \LINEBUF.OFD) do (\OUTCHAR \TERM.OFD (\NSIN \LINEBUF.OFD (UNFOLD \NORUNCODE 256)))) (replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with FILLING.LBS) (GO NEXT)) (CHARDELETE.TC (COND ((SETQ CHAR (\CHDEL1)) (\FILLBUFFER.BACKUP CHAR))) (GO RECOMPUTE)) (LINEDELETE.TC (while (SETQ CHAR (\CHDEL1)) do (\FILLBUFFER.BACKUP CHAR)) (GO RECOMPUTE)) (WORDDELETE.TC (COND ((SETQ CHAR (\CHDEL1)) (while (\FILLBUFFER.WORDSEPRP CHAR) do (* ; "first chars are seprs, delete them all") (\FILLBUFFER.BACKUP CHAR) (OR (SETQ CHAR (\CHDEL1)) (GO RECOMPUTE))) (\FILLBUFFER.BACKUP CHAR) (OR (SETQ CHAR (\CHDEL1)) (GO RECOMPUTE)) (while (NULL (\FILLBUFFER.WORDSEPRP CHAR)) do (\FILLBUFFER.BACKUP CHAR) (OR (SETQ CHAR (\CHDEL1)) (GO RECOMPUTE))) (* ; "put CHAR back") (\LINEBUFBOUT \LINEBUF.OFD CHAR) (GO RECOMPUTE))) (GO NEXT)) (CTRLV.TC (* ;; "The reasonable thing to do is coerce the character, set TCLASS to NONE.TC, and go REDO.  But on the 10, ctlv disables the immediacy of read-macros.  This is quite bizarre, cause a macro that was suppose to do something in the middle of reading will be done out of context.  We simulate that behavior, however.") (COND (PEEKEDECHOED (* ; "Has been echoed already, don't echo it again.") (SETQ PEEKEDECHOED NIL)) (T (\ECHOCHAR CHAR))) (* ; "Want to echo ^V") (\LINEBUFBOUT \LINEBUF.OFD (COND ((OR (AND (IGEQ (SETQ RAISEDCHAR (\GETCHAR)) (CHARCODE A)) (ILEQ RAISEDCHAR (CHARCODE Z))) (AND (IGEQ RAISEDCHAR (CHARCODE a)) (ILEQ RAISEDCHAR (CHARCODE z)))) (LOGAND RAISEDCHAR 31)) (T RAISEDCHAR))) (GO NEXT)) (EOL.TC (COND (PEEKEDECHOED (* ; "Has been echoed already, don't echo it again.") (SETQ PEEKEDECHOED NIL)) (T (\ECHOCHAR CHAR))) (\LINEBUFBOUT \LINEBUF.OFD RAISEDCHAR) (GO EXIT)) NIL) (COND (PEEKEDECHOED (SETQ PEEKEDECHOED NIL)) (T (\ECHOCHAR CHAR))) (* ; "Here if it isn't a terminal class.  Only echo if it isn't a special terminal class") (\LINEBUFBOUT \LINEBUF.OFD RAISEDCHAR) (AND (EQ FILLTYPE READC.FT) (GO NEXT)) (COND ((EQ ESCAPE.RC (SETQ RSNX (\SYNCODE RTBLSA RAISEDCHAR))) (* ; "On Tenex the escape inhibits the action of all terminal characters except control-V.") (COND ((EQ CTRLV.TC (SETQ TCLASS (fetch TERMCLASS of (\SYNCODE \PRIMTERMSA (SETQ RAISEDCHAR (\GETCHAR)))))) (GO REDO))) (\LINEBUFBOUT \LINEBUF.OFD RAISEDCHAR) (GO NEXT))) (SELECTC FILLTYPE (RATOM/RSTRING.FT (COND ((AND CONTROLTON (fetch STOPATOM of RSNX)) (GO EXIT)))) (READ.FT (COND ((AND CONTROLTON (EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) 0) (EQ (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD) 0) (fetch STOPATOM of RSNX) (SELECTC RSNX ((LIST LEFTPAREN.RC LEFTBRACKET.RC) NIL) (STRINGDELIM.RC (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD)) (NOT (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD)))) (* ;; "READ is reading an atom.  Return when atom ends, but also obey bracket/paren exception noted on page 14.33 of manual.") (GO EXIT))) (COND ((\INCPARENCOUNT RSNX) (* ;; "Parens balance--throw the carriage if the closing paren or bracket character was not a CR, and if FLG argument of READ is NIL.  (We know we are under a READ call because of FILLTYPE)") (\CLOSELINE) (* ; "\CLOSELINE first so dribble happens before EOL") (COND ((AND (NEQ RAISEDCHAR (CHARCODE EOL)) (NOT *READ-NEWLINE-SUPPRESS*)) (\OUTCHAR \TERM.OFD (CHARCODE EOL)))) (RETURN)) ((EQ IMMEDIATE.RMW (fetch WAKEUP of RSNX)) (* ; "Immediate read-macro") (GO EXIT)))) (SHOULDNT)) (GO NEXT) RECOMPUTE (AND (EQ FILLTYPE READ.FT) (PROGN (UNINTERRUPTABLY (\SETFILEPTR \LINEBUF.OFD 0) (replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with RETYPING.LBS) (replace (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD with ILB) (replace (LINEBUFFER INSTRINGP) of \LINEBUF.OFD with ISP) (replace (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD with ILP)) (until (\PAGEDEOFP \LINEBUF.OFD) do (SETQ CHAR (\NSIN \LINEBUF.OFD (UNFOLD \NORUNCODE 256))) (COND ((EQ ESCAPE.RC (SETQ RSNX (\SYNCODE RTBLSA CHAR))) (OR (\PAGEDEOFP \LINEBUF.OFD) (\NSIN \LINEBUF.OFD (UNFOLD \NORUNCODE 256)))) (T (\INCPARENCOUNT RSNX)))) (replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with FILLING.LBS))) (GO NEXT) EXIT (\CLOSELINE)))
+)
+
+(\FILLBUFFER.WORDSEPRP
+(LAMBDA (CHAR) (* lmm "17-Jan-86 19:44") (OR (EQ WORDSEPR.TC (fetch TERMCLASS of (\SYNCODE \PRIMTERMSA CHAR))) (NEQ OTHER.RC (\SYNCODE RTBLSA CHAR))))
+)
+
+(\FILLBUFFER.BACKUP
+(LAMBDA (CHAR) (* lmm "10-Jan-86 18:32") (DSPBACKUP (CHARWIDTH CHAR \TERM.OFD) \TERM.OFD)))
+
+(\GETCHAR
+(LAMBDA NIL (* lmm "30-Dec-85 17:25") (PROG ((C (BIN (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD)))) (\ECHOCHAR C) (* ; "Echo here so raise-echo is correct") (RETURN (\RAISECHAR C))))
+)
+
+(\INCPARENCOUNT
+(LAMBDA (RSNX) (* bvm%: "14-Feb-85 00:30") (* ;; "This maintains the paren count as characters are added to the buffer.  RSNX is a readtable syntax code.  Returns T when parens balance.") (COND ((EQ RSNX STRINGDELIM.RC) (replace (LINEBUFFER INSTRINGP) of \LINEBUF.OFD with (NOT (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD))) NIL) ((NOT (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD)) (SELECTC RSNX (LEFTPAREN.RC (AND (EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) 0) (add (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD) 1)) NIL) (RIGHTPAREN.RC (* ; "NOTE: RP's never match left-brackets, just like on 10") (AND (EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) 0) (OR (EQ (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD) 0) (EQ (add (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD) -1) 0)))) (LEFTBRACKET.RC (add (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) 1) NIL) (RIGHTBRACKET.RC (COND ((EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) 0) (replace (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD with 0)) (T (AND (EQ (add (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) -1) 0) (EQ (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD) 0))))) NIL))))
+)
+
+(\RESETLINE
+(LAMBDA NIL (* jds "10-Apr-85 23:17") (UNINTERRUPTABLY (replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with FILLING.LBS) (\SETFILEPTR \LINEBUF.OFD 0) (\SETEOFPTR \LINEBUF.OFD 0)) (SETQ \CURRENTDISPLAYLINE 0))
+)
+
+(\RESETTERMINAL
+(LAMBDA NIL (* bvm%: "11-Jul-84 23:15") (DECLARE (GLOBALVARS \VideoColor)) (* ;; "Called by CLEARBUF and by RESET and ERROR! when returning to the TOPFRAME on the stack") (replace (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD with 0) (replace (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD with 0) (replace (LINEBUFFER INSTRINGP) of \LINEBUF.OFD with NIL) (replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with NIL) (\RESETLINE) (* ; "Since we aren't immediately filling the buffer, guarantee that the next read causes an EOF error") (VIDEOCOLOR \VideoColor))
+)
+
+(\SAVELINEBUF
+(LAMBDA NIL (* ; "Edited  9-Mar-88 11:41 by bvm") (* ;; "Don't have to set the fileptr to its original place cause we are heading for a \RESETTERMINAL in CLEARBUF") (SELECTC (fetch (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD) (FILLING.LBS (\CLOSELINE)) (RETYPING.LBS (* ; "EOF is valid, but current fileptr isn't") (\SETFILEPTR \LINEBUF.OFD 0)) NIL) (COND ((NOT (\PAGEDEOFP \LINEBUF.OFD)) (LET* ((NBYTES (- (\GETEOFPTR \LINEBUF.OFD) (\GETFILEPTR \LINEBUF.OFD))) (NC NBYTES) (STR (if (EQ (fetch (STREAM CHARSET) of \LINEBUF.OFD) 0) then (* ; "Thin linebuffer") (ALLOCSTRING NC) else (* ; "Fat linebuffer.  This should always be the case now") (ALLOCSTRING (SETQ NC (FOLDHI NBYTES 2)) NIL NIL T)))) (* ;; "Read chars into string.  Do it this way, rather than thru, say RSTRING, because we want to treat linebuf as an ordinary stream, not a terminal stream;  (EOFP T) = NIL would defeat us.") (\BINS \LINEBUF.OFD (fetch (STRINGP BASE) of STR) 0 NBYTES) (if (OR (> NC 1) (NEQ (CHCON1 STR) (CHARCODE CR))) then (* ; "Only something to save if it's not a naked eol.") STR)))))
+)
+
+(\STOPSCROLL?
+(LAMBDA NIL (* lmm "11-Feb-86 09:56") (* ;; "Called whenever a carriage-return is printed on the display.  Keeps track of number of lines since last user input.  If this one would scroll information off the screen, it calls the users window specific function or the function PAGEFULLFN which waits for the user to type a character.") (DECLARE (GLOBALVARS \STOPSCROLLMESSAGE)) (* ; "Set \#DISPLAYLINEs to NIL to disable") (COND ((AND (NEQ \CURRENTDISPLAYLINE -1) (OR (EQ \#DISPLAYLINES 0) (NOT (SMALLP \#DISPLAYLINES))))) ((OR (EQ \CURRENTDISPLAYLINE -1) (EQ \#DISPLAYLINES (SETQ \CURRENTDISPLAYLINE (ADD1 \CURRENTDISPLAYLINE)))) (SETQ \CURRENTDISPLAYLINE 0) (LET ((W (AND \WINDOWWORLD (WFROMDS (TTYDISPLAYSTREAM)))) WINDOWFN) (COND ((AND W (SETQ WINDOWFN (WINDOWPROP W (QUOTE PAGEFULLFN)))) (APPLY* WINDOWFN (TTYDISPLAYSTREAM))) (T (PAGEFULLFN (TTYDISPLAYSTREAM))))))))
+)
+)
+
+(RPAQQ BCPLDISPLAYCOMS ((FNS \DSCCOUT \INITBCPLDISPLAY) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\INITBCPLDISPLAY))) (EXPORT (GLOBALVARS \BCPLDISPLAY))))
+(DEFINEQ
+
+(\DSCCOUT
+(LAMBDA (STREAM CHARCODE) (* lmm " 5-OCT-83 18:31") (* ;; "The terminal outcharfn, prior for non-displaystream systems.  STREAM is always \TERM.OFD, but passed as an argument so that calling structure is the same as the more general display outcharfn, and thus, so that a simple MOVD can be done to install the display world.") (SELECTC (fetch CCECHO of (\SYNCODE \PRIMTERMSA CHARCODE)) (INDICATE.CCE (PROG ((CC CHARCODE)) (add (fetch CHARPOSITION of STREAM) (IPLUS (COND ((IGREATERP CC 127) (* ; "META character") (DSPBOUT (CHARCODE %#)) (SETQ CC (LOGAND CC 127)) 1) (T 0)) (COND ((ILESSP CC 32) (* ; "CONTROL character") (DSPBOUT (CHARCODE ^)) (SETQ CC (LOGOR CC 64)) 1) (T 0)) (PROGN (DSPBOUT CC) 1))))) (SIMULATE.CCE (SELCHARQ CHARCODE (LF (DSPBOUT (CHARCODE EOL)) (RPTQ (fetch CHARPOSITION of STREAM) (DSPBOUT (CHARCODE SPACE))) (\STOPSCROLL?)) (EOL (DSPBOUT (CHARCODE EOL)) (\STOPSCROLL?) (replace CHARPOSITION of STREAM with 0)) (ESCAPE (DSPBOUT (CHARCODE $)) (* ; "change to $") (add (fetch CHARPOSITION of STREAM) 1)) (TAB (FRPTQ (IDIFFERENCE 8 (MOD (fetch CHARPOSITION of STREAM) 8)) (DSPBOUT (CHARCODE SPACE)) (add (fetch CHARPOSITION of STREAM) 1))) (PROGN (DSPBOUT CHARCODE) (add (fetch CHARPOSITION of STREAM) 1)))) (REAL.CCE (DSPBOUT CHARCODE) (COND ((EQ CHARCODE (CHARCODE EOL)) (\STOPSCROLL?) (replace CHARPOSITION of STREAM with 0)) (T (add (fetch CHARPOSITION of STREAM) 1)))) (IGNORE.CCE) (SHOULDNT)))
+)
+
+(\INITBCPLDISPLAY
+(LAMBDA NIL (* ; "Edited 17-Jan-87 16:08 by bvm:") (SETQ \BCPLDISPLAY (create STREAM DEVICE _ (create FDEV BOUT _ (FUNCTION \DSCCOUT)) ACCESS _ (QUOTE OUTPUT) LINELENGTH _ 72 USERCLOSEABLE _ NIL USERVISIBLE _ NIL OUTCHARFN _ (FUNCTION \DSCCOUT))) (OR (STREAMP \TERM.OFD) (SETQ \TERM.OFD \BCPLDISPLAY)) (OR (STREAMP *STANDARD-OUTPUT*) (SETQ *STANDARD-OUTPUT* \BCPLDISPLAY)))
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(\INITBCPLDISPLAY)
+)
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \BCPLDISPLAY)
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+(DEFINEQ
+
+(VIDEOCOLOR
+(LAMBDA NARGS (* ; "Edited 29-Jul-88 15:30 by drc:") (DECLARE (GLOBALVARS \VideoColor)) (* ;; "sets the interpretation of bits that are displayed on the screen so that 1 is black {NIL} or 1 is white {anything else}.") (PROG1 \VideoColor (COND ((NEQ NARGS 0) (SETQ \VideoColor (AND (ARG NARGS 1) T)) (SELECTC \MACHINETYPE (\MAIKO (SETQ \VideoColor (SUBRCALL DSP-VIDEOCOLOR \VideoColor))) (\DANDELION (replace DLDISPCONTROL of \IOPAGE with (COND (\VideoColor (* ; "Inverse video") (LOGOR 2048 (fetch DLDISPCONTROL of \IOPAGE))) (T (LOGAND (LOGXOR 2048 MAX.SMALLP) (fetch DLDISPCONTROL of \IOPAGE)))))) (\DAYBREAK (DOVE.XOR.CURSOR \DoveDisplay.XorCursor)) (SETSCREENCOLOR \VideoColor))))))
+)
+)
+
+(RPAQQ \VideoColor NIL)
+
+(PUTPROPS VIDEOCOLOR ARGNAMES (BLACKFLG))
+(DECLARE%: DOCOPY DONTEVAL@LOAD 
+
+(MOVD? (QUOTE NILL) (QUOTE SETDISPLAYHEIGHT))
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \RAISECHAR MACRO (OPENLAMBDA (C) (COND ((AND (fetch RAISEFLG of \PRIMTERMTABLE) (IGEQ C (CHARCODE a)) (ILEQ C (CHARCODE z))) (IDIFFERENCE C 32)) (T C))))
+
+(PUTPROPS \LINEBUFBOUT MACRO (OPENLAMBDA (STRM CHAR) (\BOUT STRM (\CHARSET CHAR)) (\BOUT STRM (\CHAR8CODE CHAR))))
+)
+)
+(DEFINEQ
+
+(\PEEKREFILL
+(LAMBDA NIL (* ; "Edited 15-Jun-87 16:26 by jds") (* ;; "Called from \ENDOFFILE via \RefillBufferFn when the linebuffer is empty") (PROG (C) (COND ((SETQ C (fetch (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD)) (* ;; "Saved char, just return it.  Ideally we might want to pay attention to echo state, but Interlisp-10 doesn't, so be compatible") (* ;; "Following code is a major crock.  Problem is that the eof interface is at the BIN level, but terminal deals in characters, which take two BINs.  The code here assumes that the main way we get called is via \NSPEEK macro, which does a \PEEKBIN to start, then a BIN of that character to get it out of the way, then another \PEEKBIN followed by \BACKFILEPTR.  We're assuming the \BACKFILEPTR on the buffer stream is a no-op and that it is always called after the second \PEEKBIN.  We keep track of whether we're peeking at the left or right half of the character by negating it after the first half is consumed, then making it normal again after the second one (so that a subsequent PEEKC would still return the character).  It is also possible to be called here from SKIPSEPR[CODE]S, in which case there might be a real BIN to consume the char if it's a sepr.") (* ;; "Anyway, this code should be reworked someday using the READ-CHAR, PEEK-CHAR stream interface.") (RETURN (SELECTQ (STKNAME (QUOTE (\BIN \PEEKBIN))) (\BIN (* ;; "He is doing a \BIN -- remember for later calls that we have passed over the left half of the character") (COND ((IGREATERP C 0) (* ; "We're looking at the left half.  Return it and move to right half.") (replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with (IMINUS C)) (\CHARSET (\RAISECHAR C))) (T (* ; "We looked at the left half before.  Now return the right half and char is now totally consumed.") (replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with NIL) (\CHAR8CODE (\RAISECHAR (IMINUS C)))))) (COND ((IGREATERP C 0) (* ; "We're still looking at the left half.  Return it.") (\CHARSET (\RAISECHAR C))) (T (* ; "We looked at the left half before.  Now look at the right half.") (replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with (IMINUS C)) (\CHAR8CODE (\RAISECHAR (IMINUS C))))))))) (* ;; "Echo the character, and remember whether we echoed it or not:") (replace (LINEBUFFER PEEKEDECHOFLG) of \LINEBUF.OFD with (\ECHOCHAR (SETQ C (BIN (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD))))) (* ; "First time thru this: Get a key, and echo it.") (\RESETLINE) (* ; "Clear the line buffer.") (* ;; "Save the peeked character OUTSIDE the line buffer, to avoid problems if the guy later types ^E before the character is really read.") (replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with C) (RETURN (\CHARSET (\RAISECHAR C)))))
+)
+
+(\READREFILL
+(LAMBDA NIL (* AJB "15-Jan-86 14:52") (* ;; "Called from \ENDOFFILE via \RefillBufferFn when the linebuffer is empty") (DECLARE (USEDFREE \LINEBUF.OFD)) (* ;; "If the LINEBUFFER has a REFILLBUFFERFN use it, otherwise call \FILLBUFFER as default") (COND ((STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN)) (APPLY* (STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN)) READ.FT)) (T (\FILLBUFFER READ.FT))) (CL:FUNCALL (STKNAME (QUOTE (\BIN \PEEKBIN))) \LINEBUF.OFD))
+)
+
+(\RATOM/RSTRING-REFILL
+(LAMBDA NIL (* AJB "15-Jan-86 14:53") (* ;; "Called from \ENDOFFILE via \RefillBufferFn when the linebuffer is empty") (DECLARE (USEDFREE \LINEBUF.OFD)) (* ;; "If the LINEBUFFER has a REFILLBUFFERFN use it, otherwise call \FILLBUFFER as default") (COND ((STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN)) (APPLY* (STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN)) RATOM/RSTRING.FT)) (T (\FILLBUFFER RATOM/RSTRING.FT))) (\BIN \LINEBUF.OFD))
+)
+
+(\READCREFILL
+(LAMBDA NIL (* AJB "15-Jan-86 14:53") (* ;; "Called from \ENDOFFILE via \RefillBufferFn when the linebuffer is empty") (DECLARE (USEDFREE \LINEBUF.OFD)) (* ;; "If the LINEBUFFER has a REFILLBUFFERFN use it, otherwise call \FILLBUFFER as default") (COND ((STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN)) (APPLY* (STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN)) READC.FT)) (T (\FILLBUFFER READC.FT))) (\BIN \LINEBUF.OFD))
+)
+)
+(DEFINEQ
+
+(DRIBBLE
+(LAMBDA (FILE APPENDFLG) (* ; "Edited 16-Jan-87 17:03 by hdj") (* ;; "Turn on/off dribbling for this process") (* ;; "") (* ;; "Dribbling is on if the special variable *dribble-output* is bound to a stream.") (LET ((OLD-DRIBBLE-STREAM (DRIBBLEFILE)) (NEW-DRIBBLE-STREAM NIL)) (* ;;; "Turn off dribbling.") (if OLD-DRIBBLE-STREAM then (* ;; "disable dribbling to old dribble stream") (SETQ *DRIBBLE-OUTPUT* NIL) (replace (STREAM USERCLOSEABLE) of OLD-DRIBBLE-STREAM with T) (replace (STREAM USERVISIBLE) of OLD-DRIBBLE-STREAM with T) (CLOSEF OLD-DRIBBLE-STREAM)) (* ;;; "Turn on dribbling.") (if (AND FILE (NEQ FILE T)) then (SETQ NEW-DRIBBLE-STREAM (OPENSTREAM FILE (COND (APPENDFLG (QUOTE APPEND)) (T (QUOTE OUTPUT))))) (UNINTERRUPTABLY (replace (STREAM USERCLOSEABLE) of NEW-DRIBBLE-STREAM with NIL) (replace (STREAM USERVISIBLE) of NEW-DRIBBLE-STREAM with NIL) (* ;; "Start dribbling to new-dribble-stream.") (SETQ *DRIBBLE-OUTPUT* NEW-DRIBBLE-STREAM))) (AND OLD-DRIBBLE-STREAM (fetch (STREAM FULLNAME) of OLD-DRIBBLE-STREAM))))
+)
+
+(DRIBBLEFILE
+(LAMBDA NIL (* ; "Edited 16-Jan-87 16:06 by hdj") (* ;; "return the stream that this process is dribbling to.") *DRIBBLE-OUTPUT*)
+)
+)
+(DEFINEQ
+
+(\SETUP.DEFAULT.LINEBUF
+(LAMBDA NIL (* ; "Edited 13-Apr-87 17:07 by bvm:") (* ;; "Line buffer initialization.  First create the line buffer device.") (LET ((DEV (\NODIRCOREFDEV (QUOTE LINEBUFFER)))) (replace (FDEV READP) of DEV with (FUNCTION \LINEBUF.READP)) (* ; "Readp has to look at both keyboard stream and buffer") (replace (FDEV EOFP) of DEV with (FUNCTION NILL)) (* ; "EOFP is always false from terminal.  May want this to be different for network terminals") (replace (FDEV PEEKBIN) of DEV with (FUNCTION \LINEBUF.PEEKBIN)) (* ; "PEEKBIN method has implicit EOFP test, so have to supply that ourselves, too.") (replace (FDEV GETNEXTBUFFER) of DEV with (FUNCTION \LINEBUFFER.GETNEXTBUFFER)) (* ; "JRB - LINEBUFFER needs its own GETNEXTBUFFER to avoid overloading the ENDOFSTREAMOP slot; Common Lisp uses it to implement EOF-ERROR-P, and LINEBUFFER used to use it for refilling its buffer.  The latter use is bogus in my humble opinion, BvM's impelmentation aside...")) (* ;; "create a line buffer device which creates a line buffer the first time one is needed.") (PROG ((STREAM (\OPENFILE (QUOTE {LINEBUFFER}) (QUOTE BOTH) (QUOTE NEW)))) (replace FULLFILENAME of STREAM with T) (* ;; "No-one cares about the true file-name after this, so we make it convenient for code that wants to give a name back to the user") (replace LINEBUFSTATE of STREAM with READING.LBS) (replace USERCLOSEABLE of STREAM with NIL) (replace USERVISIBLE of STREAM with NIL) (* ; "Other linebuffer fields default properly") (replace ENDOFSTREAMOP of STREAM with (FUNCTION (LAMBDA (STREAM) (* ; "create a TTY window and make it the tty stream.  This also sets up a line buffer.") (\CREATE.TTYDISPLAYSTREAM) (STREAMOP (QUOTE ENDOFSTREAMOP) \LINEBUF.OFD \LINEBUF.OFD)))) (RETURN STREAM)))
+)
+
+(\CREATELINEBUFFER
+(LAMBDA (TERMINAL.STREAM) (* ; "Edited 13-Apr-87 22:57 by bvm:") (* ;; "Create a new stream that buffers the raw input from TERMINAL.STREAM (default is the keyboard).") (LET* ((STREAM (\OPENFILE (QUOTE {LINEBUFFER}) (QUOTE BOTH) (QUOTE NEW) (QUOTE ((CHARSET T))))) (DEV (fetch (STREAM DEVICE) of STREAM)) EOFMETHOD) (replace LINEBUFSTATE of STREAM with READING.LBS) (replace (LINEBUFFER KEYBOARDSTREAM) of STREAM with (OR TERMINAL.STREAM \KEYBOARD.STREAM)) (replace USERCLOSEABLE of STREAM with NIL) (replace USERVISIBLE of STREAM with NIL) (* ; "Other linebuffer fields default properly") (replace ENDOFSTREAMOP of STREAM with (FUNCTION (LAMBDA (STREAM) (CL:FUNCALL \RefillBufferFn)))) (if (AND TERMINAL.STREAM (NEQ (SETQ EOFMETHOD (fetch (FDEV EOFP) of TERMINAL.STREAM)) (QUOTE NILL))) then (* ;; "Need to install an eof method for the buffered stream that looks at TERMINAL.STREAM when the buffer runs out.  This is optimized away for the normal keyboard case, which never runs out.") (replace (STREAM DEVICE) of STREAM with (SETQ DEV (NCREATE (QUOTE FDEV) DEV))) (* ; "Copy the basic linebuffer device") (replace (FDEV EOFP) of DEV with EOFMETHOD)) STREAM))
+)
+
+(\LINEBUF.READP
+(LAMBDA (STREAM FLG) (* ; "Edited 13-Apr-87 22:05 by bvm:") (LET ((KEYSTREAM (fetch (LINEBUFFER KEYBOARDSTREAM) of STREAM))) (OR (AND KEYSTREAM (READP KEYSTREAM)) (fetch (LINEBUFFER PEEKEDCHAR) of STREAM) (\PAGEDREADP STREAM FLG))))
+)
+
+(\LINEBUF.EOFP
+(LAMBDA (STREAM) (* ; "Edited 13-Apr-87 18:09 by bvm:") (* ;; "End of file for linebuffer: true if both the buffer and the source of characters are empty") (AND (\PAGEDEOFP STREAM) (\EOFP (fetch (LINEBUFFER KEYBOARDSTREAM) of STREAM))))
+)
+
+(\LINEBUF.PEEKBIN
+(LAMBDA (STREAM NOERROR) (* ; "Edited 13-Apr-87 16:53 by bvm:") (OR (\BUFFERED.PEEKBIN STREAM T) (CL:FUNCALL \RefillBufferFn STREAM)))
+)
+
+(\LINEBUFFER.GETNEXTBUFFER
+(LAMBDA (STREAM WHATFOR NOERRORFLG) (* ;; "Code stolen from \CORE.GETNEXTBUFFER and slightly modified.  Old LINEBUFFER relied on refilling its buffer from the ENDOFSTREAMOP function; this is bogus and was causing Common Lisp READ with EOF-ERROR-P off to fail, as it also uses the ENDOFSTREAMOP function") (PROG ((CPAGE# (fetch CPAGE of STREAM)) (COFF (fetch COFFSET of STREAM)) EPAGE# COREBUF) (COND ((NOT (OPENED STREAM)) (LISPERROR "FILE NOT OPEN" (fetch (STREAM FULLNAME) of STREAM)))) (if (AND (ILESSP COFF (SELECTQ WHATFOR (READ (fetch CBUFSIZE of STREAM)) BYTESPERPAGE)) (fetch CBUFPTR of STREAM)) then (* ; " all OK, why were we called?") (SHOULDNT) (RETURN T)) (* ;; "Buffer exhausted or empty, prepare new one") (UNINTERRUPTABLY (* ; "Clean up current page") (replace CBUFSIZE of STREAM with 0) (replace CBUFPTR of STREAM with NIL) (if (EQ COFF BYTESPERPAGE) then (* ; "Change to be first byte of next page instead of beyond last byte of previous page") (replace COFFSET of STREAM with (SETQ COFF 0)) (replace CPAGE of STREAM with (add CPAGE# 1)))) (COND ((AND (IGEQ CPAGE# (SETQ EPAGE# (fetch EPAGE of STREAM))) (OR (NEQ CPAGE# EPAGE#) (IGEQ COFF (fetch EOFFSET of STREAM)))) (* ; "Current file pointer is at or past end of file") (SELECTQ WHATFOR (READ (* ;; "This used to do (\EOF.ACTION STREAM)") (RETURN (AND (NULL NOERRORFLG) (CL:FUNCALL \RefillBufferFn)))) (WRITE (UNINTERRUPTABLY (replace EPAGE of STREAM with (SETQ EPAGE# CPAGE#)) (replace EOFFSET of STREAM with COFF))) (\ILLEGAL.ARG WHATFOR)))) (* ;; "Now fill the buffer -- map in current page") (SETQ COREBUF (\CORE.FINDPAGE STREAM CPAGE#)) (* ; "This is interruptable") (UNINTERRUPTABLY (* ; "But these two fields must be set uninterruptably for benefit of ucode") (replace CBUFSIZE of STREAM with (COND ((ILESSP CPAGE# EPAGE#) (* ; "Full page") BYTESPERPAGE) ((EQ EPAGE# CPAGE#) (* ; "Last page") (fetch EOFFSET of STREAM)) (T (* ; "Beyond EOF so no data") 0))) (replace CBUFPTR of STREAM with COREBUF)) (COND (\INTERRUPTABLE (BLOCK))) (* ; "Let someone else run.  Useful for those long writings of scratch files.") (RETURN T)))
+)
+
+(\OPENLINEBUF
+(LAMBDA NIL (* ; "Edited 17-Jan-87 16:08 by bvm:") (* ;; "Don't assume that \LINEBUF.OFD or \TERM.OFD have been initialized.  That way, they won't get smashed if ATERM is reloaded.") (DECLARE (GLOBALVARS DisplayFDEV)) (PROG (STREAM) (* ; "Output parameters") (* ; "Input parameters") (COND ((OR (NOT (type? STREAM \LINEBUF.OFD)) (EQ \LINEBUF.OFD \DEFAULTLINEBUF)) (SETQ \LINEBUF.OFD (\CREATELINEBUFFER)) (OR (AND (type? STREAM *STANDARD-INPUT*) (NEQ *STANDARD-INPUT* \DEFAULTLINEBUF)) (SETQ *STANDARD-INPUT* \LINEBUF.OFD)))) (\RESETTERMINAL)))
+)
+)
+
+
+
+(* ; "User entries to make up for fact that (EOFP T) = NIL now.")
+
+(DEFINEQ
+
+(LINEBUFFER-EOFP
+(LAMBDA (STREAM) (* ; "Edited 13-Apr-87 17:12 by bvm:") (* ;; "Public interface to %"old functionality%" of (EOFP T) -- returns true if there is no buffered input waiting on stream.  If stream is not terminal input, is same as EOFP.") (LET ((S (\GETSTREAM STREAM (QUOTE INPUT)))) (if (EQ S \LINEBUF.OFD) then (\PAGEDEOFP S) else (\EOFP S))))
+)
+
+(LINEBUFFER-SKIPSEPRS
+(LAMBDA (STREAM RDTBL) (* ; "Edited 13-Apr-87 22:05 by bvm:") (* ;; "SKIPSEPRS applied to the terminal input linebuffer.  If run out of buffer, return NIL.") (LET ((S (\GETSTREAM STREAM (QUOTE INPUT))) (*READTABLE* (\GTREADTABLE RDTBL)) CH) (if (EQ S \LINEBUF.OFD) then (until (\PAGEDEOFP S) do (if (SYNTAXP (SETQ CH (PEEKCCODE S)) (QUOTE SEPRCHAR)) then (READCCODE S) else (RETURN (CHARACTER CH)))) else (SKIPSEPRS S *READTABLE*))))
+)
+)
+(DECLARE%: DOCOPY DONTEVAL@LOAD 
+
+(RPAQQ \#DISPLAYLINES 58)
+
+(RPAQQ \DISPLAYLINELENGTH 82)
+
+(RPAQQ \CURRENTDISPLAYLINE 0)
+
+(RPAQ \STOPSCROLLMESSAGE "---MORE---")
+
+
+(RPAQQ \SYSBUF NIL)
+
+(RPAQQ \LINBUF NIL)
+
+
+(MOVD? (QUOTE \OPENLINEBUF) (QUOTE \CREATE.TTYDISPLAYSTREAM))
+
+
+(RPAQ \DEFAULTLINEBUF (\SETUP.DEFAULT.LINEBUF))
+
+
+(\OPENLINEBUF)
+)
+(DEFINEQ
+
+(\INTERMP
+(LAMBDA (OFD) (* rrb "21-JUL-83 16:33") (EQ OFD \LINEBUF.OFD)))
+
+(\OUTTERMP
+(LAMBDA (OFD) (* rrb "21-JUL-83 07:23") (EQ OFD \TERM.OFD)))
+)
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE
+
+(ACCESSFNS LINEBUFFER ((LPARCOUNT (fetch FW6 of DATUM) (replace FW6 of DATUM with NEWVALUE)) (LBRKCOUNT (fetch FW7 of DATUM) (replace FW7 of DATUM with NEWVALUE)) (LINEBUFSTATE (fetch F5 of DATUM) (replace F5 of DATUM with NEWVALUE)) (KEYBOARDSTREAM (fetch F2 of DATUM) (replace F2 of DATUM with NEWVALUE)) (PEEKEDCHAR (fetch F3 of DATUM) (replace F3 of DATUM with NEWVALUE)) (LBFLAGS (fetch FW9 of DATUM) (replace FW9 of DATUM with NEWVALUE)))
+ (ACCESSFNS LINEBUFFER ((LBFLAGBASE (LOCF (fetch LBFLAGS of DATUM)))) (BLOCKRECORD LBFLAGBASE ((PEEKEDECHOFLG FLAG) (INSTRINGP FLAG))))
+)
+)
+
+
+(RPAQQ LINEBUFFERSTATES (FILLING.LBS READING.LBS RETYPING.LBS))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ FILLING.LBS 0)
+
+(RPAQQ READING.LBS 1)
+
+(RPAQQ RETYPING.LBS 2)
+
+
+(CONSTANTS FILLING.LBS READING.LBS RETYPING.LBS)
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \INTERMP MACRO ((OFD) (EQ OFD \LINEBUF.OFD)))
+
+(PUTPROPS \OUTTERMP MACRO ((OFD) (EQ OFD \TERM.OFD)))
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \DEFAULTLINEBUF)
+)
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+(DECLARE%: DONTCOPY 
+
+(RPAQQ FILLTYPES ((READ.FT 0) (RATOM/RSTRING.FT 1) (READC.FT 2)))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ READ.FT 0)
+
+(RPAQQ RATOM/RSTRING.FT 1)
+
+(RPAQQ READC.FT 2)
+
+
+(CONSTANTS (READ.FT 0) (RATOM/RSTRING.FT 1) (READC.FT 2))
+)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA)
+
+(ADDTOVAR NLAML)
+
+(ADDTOVAR LAMA VIDEOCOLOR TERMINAL-OUTPUT TERMINAL-INPUT)
+)
+
+(PUTPROPS ATERM FILETYPE BCOMPL)
+(PUTPROPS ATERM COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1992))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (2156 18174 (BKLINBUF 2166 . 2456) (CLEARBUF 2458 . 3244) (LINBUF 3246 . 3367) (
+PAGEFULLFN 3369 . 4286) (SETLINELENGTH 4288 . 4409) (SYSBUF 4411 . 4532) (TERMCHARWIDTH 4534 . 4884) (
+TERMINAL-INPUT 4886 . 5275) (TERMINAL-OUTPUT 5277 . 5685) (\CHDEL1 5687 . 5909) (\CLOSELINE 5911 . 
+6112) (\DECPARENCOUNT 6114 . 6939) (\ECHOCHAR 6941 . 7351) (\FILLBUFFER 7353 . 13722) (
+\FILLBUFFER.WORDSEPRP 13724 . 13903) (\FILLBUFFER.BACKUP 13905 . 14020) (\GETCHAR 14022 . 14228) (
+\INCPARENCOUNT 14230 . 15393) (\RESETLINE 15395 . 15624) (\RESETTERMINAL 15626 . 16191) (\SAVELINEBUF 
+16193 . 17281) (\STOPSCROLL? 17283 . 18172)) (18325 20173 (\DSCCOUT 18335 . 19772) (\INITBCPLDISPLAY 
+19774 . 20171)) (20362 21078 (VIDEOCOLOR 20372 . 21076)) (21560 25684 (\PEEKREFILL 21570 . 24297) (
+\READREFILL 24299 . 24775) (\RATOM/RSTRING-REFILL 24777 . 25241) (\READCREFILL 25243 . 25682)) (25685 
+26893 (DRIBBLE 25695 . 26741) (DRIBBLEFILE 26743 . 26891)) (26894 33244 (\SETUP.DEFAULT.LINEBUF 26904
+ . 28677) (\CREATELINEBUFFER 28679 . 29865) (\LINEBUF.READP 29867 . 30121) (\LINEBUF.EOFP 30123 . 
+30380) (\LINEBUF.PEEKBIN 30382 . 30540) (\LINEBUFFER.GETNEXTBUFFER 30542 . 32677) (\OPENLINEBUF 32679
+ . 33242)) (33319 34158 (LINEBUFFER-EOFP 33329 . 33693) (LINEBUFFER-SKIPSEPRS 33695 . 34156)) (34497 
+34663 (\INTERMP 34507 . 34584) (\OUTTERMP 34586 . 34661)))))
+STOP
diff --git a/CLTL2/ATERM.LCOM b/CLTL2/ATERM.LCOM
new file mode 100644
index 00000000..ed274d82
Binary files /dev/null and b/CLTL2/ATERM.LCOM differ
diff --git a/CLTL2/BOOTSTRAP b/CLTL2/BOOTSTRAP
new file mode 100644
index 00000000..2ff56c66
--- /dev/null
+++ b/CLTL2/BOOTSTRAP
@@ -0,0 +1,864 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "12-Oct-93 15:20:15" "{Pele:mv:envos}<LispCore>Sources>CLTL2>BOOTSTRAP.;1" 41500  
+
+      changes to%:  (VARS BOOTSTRAPCOMS)
+                    (FNS \LOAD-STREAM)
+
+      previous date%: " 2-Nov-92 04:15:40" "{Pele:mv:envos}<LispCore>Sources>BOOTSTRAP.;4")
+
+
+(* ; "
+Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT BOOTSTRAPCOMS)
+
+(RPAQQ BOOTSTRAPCOMS
+       [(COMS                                                (* ; "Some basic fns.  Note that several are redefined later.  E.g., RPAQQ et al real definitions are on UNDO")
+              (FNS GETPROP SETATOMVAL RPAQQ RPAQ RPAQ? MOVD MOVD? SELECTQ SELECTQ1 NCONC1 PUTPROP 
+                   PROPNAMES ADDPROP REMPROP MEMB CLOSEF?))
+        (COMS                                                (* ; 
+                                          "Need these in order to load even compiled files SYSLOAD")
+              (FNS LOAD \LOAD-STREAM FILECREATED FILECREATED1 PRETTYCOMPRINT BOOTSTRAP-NAMEFIELD 
+                   PUTPROPS DECLARE%: DECLARE%:1 ROOTFILENAME DEFINE-FILE-INFO \DO-DEFINE-FILE-INFO))
+        (INITVARS (EOLCHARCODE (CHCON1 "
+"))
+               (PRETTYHEADER)
+               (DWIMFLG)
+               (UPDATEMAPFLG)
+               (DFNFLG)
+               (ADDSPELLFLG)
+               (BUILDMAPFLG)
+               (FILEPKGFLG)
+               (SYSFILES)
+               (NOTCOMPILEDFILES)
+               (RESETVARSLST)
+               [LOADPARAMETERS '((SEQUENTIAL T]
+               (LISPXHIST)
+               (LISPXPRINTFLG T)
+               (PRETTYHEADER "File created ")
+               (LOAD-VERBOSE-STREAM T)
+               (BELLS '"")
+               (LOADOPTIONS '(SYSLOAD NIL T PROP ALLPROP))
+               (PRETTYDEFMACROS NIL)
+               (PRETTYTYPELST NIL)
+               (FILEPKGTYPES NIL))
+        (ADDVARS (LOADEDFILELST))
+        (GLOBALVARS DWIMFLG UPDATEMAPFLG LOADOPTIONS LOADPARAMETERS FILERDTBL SYSFILES)
+        (DECLARE%: DONTEVAL@LOAD DOCOPY [P [MAPC '((PUTD . /PUTD)
+                                                   (PUTPROP . /PUTPROP)
+                                                   (PUTPROP . PUT)
+                                                   (PUTPROP . SAVEPUT)
+                                                   (ADDPROP . /ADDPROP)
+                                                   (PUT . /PUT)
+                                                   (PRIN1 . LISPXPRIN1)
+                                                   (PRIN2 . LISPXPRIN2)
+                                                   (PRINT . LISPXPRINT)
+                                                   (TERPRI . LISPXTERPRI)
+                                                   (SPACES . LISPXSPACES)
+                                                   (GETPROP . GETP)
+                                                   (SET . SAVESET)
+                                                   (SET . /SET)
+                                                   (NILL . MISSPELLED?)
+                                                   (SETTOPVAL . /SETTOPVAL)
+                                                   (BOOTSTRAP-NAMEFIELD . NAMEFIELD)
+                                                   (BOOTSTRAP-NAMEFIELD . COMSNAME)
+                                                   (NILL . RESETRESTORE))
+                                                 (FUNCTION (LAMBDA (X)
+                                                                  (OR (CCODEP (CDR X))
+                                                                      (MOVD (CAR X)
+                                                                            (CDR X)
+                                                                            NIL T]
+                                           (AND (CCODEP 'BOOTSTRAP-NAMEFIELD)
+                                                (PUTD 'BOOTSTRAP-NAMEFIELD]
+               (P (RADIX 10)))
+        (DECLARE%: DOEVAL@COMPILE DONTCOPY                   (* ; "eventually imported from FASL")
+               (CONSTANTS FASL:SIGNATURE))
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA DEFINE-FILE-INFO DECLARE%: PUTPROPS FILECREATED SELECTQ)
+                      (NLAML PRETTYCOMPRINT RPAQ? RPAQ RPAQQ)
+                      (LAMA])
+
+
+
+(* ; 
+"Some basic fns.  Note that several are redefined later.  E.g., RPAQQ et al real definitions are on UNDO"
+)
+
+(DEFINEQ
+
+(GETPROP
+  [LAMBDA (ATM PROP)                                     (* lmm " 5-SEP-83 22:29")
+                                                             (* ; "Used to be called GETP")
+
+    (AND (LITATOM ATM)
+         (PROG ((PLIST (GETPROPLIST ATM)))
+           LP  [COND
+                  ((OR (NLISTP PLIST)
+                       (NLISTP (CDR PLIST)))
+                   (RETURN NIL))
+                  ((EQ (CAR PLIST)
+                       PROP)
+                   (RETURN (CADR PLIST]
+               (SETQ PLIST (CDDR PLIST))
+               (GO LP])
+
+(SETATOMVAL
+  [LAMBDA (X Y)                                          (* bvm%: "29-Sep-86 16:14")
+    (SETTOPVAL X Y])
+
+(RPAQQ
+  [NLAMBDA (X Y)
+    (SETATOMVAL X Y])
+
+(RPAQ
+  [NLAMBDA (RPAQX RPAQY)                                 (* lmm "23-JUL-83 16:10")
+                                                             (* ; 
+                                               "RPAQ and RPAQQ are used by PRETTYDEF to save VARS.")
+
+    (SETTOPVAL RPAQX (EVAL RPAQY])
+
+(RPAQ?
+  [NLAMBDA (RPAQX RPAQY)                                 (* lmm "23-JUL-83 16:12")
+                                                             (* ; 
+                                             "RPAQ?  and RPAQQ are used by PRETTYDEF to save VARS.")
+
+    (OR (NEQ (GETTOPVAL RPAQX)
+             'NOBIND)
+        (SETTOPVAL RPAQX (EVAL RPAQY])
+
+(MOVD
+  [LAMBDA (FROM TO COPYFLG DONTCOPY)  (* ; 
+                                                "Edited  2-Nov-92 03:50 by sybalsky:mv:envos")
+    (COND
+       ((AND DONTCOPY (NULL COPYFLG))
+
+        (* ;; "He really wants NO copy made, not a renamed version.")
+
+        (* ;; 
+      "This is like MOVD, but absolutely no consing is done, frame names are not changed, etc.")
+
+        (LET ((FROMCELL (fetch (LITATOM DEFINITIONCELL) of FROM))
+              (TOCELL (fetch (LITATOM DEFINITIONCELL) of TO)))
+             (UNINTERRUPTABLY
+                 (replace (DEFINITIONCELL DEFPOINTER) of TOCELL with (fetch
+                                                                                  (DEFINITIONCELL
+                                                                                   DEFPOINTER)
+                                                                                    of FROMCELL))
+                 (replace (DEFINITIONCELL DEFCELLFLAGS) of TOCELL with
+                                                                          (fetch (DEFINITIONCELL
+                                                                                      DEFCELLFLAGS)
+                                                                             of FROMCELL))
+                 (replace (DEFINITIONCELL AUXDEFCELLFLAGS) of TOCELL
+                    with (fetch (DEFINITIONCELL AUXDEFCELLFLAGS) of FROMCELL))
+                 TO)))
+       (T (LET [(NEWFLG (NULL (GETD TO]
+               (PUTD TO (COND
+                           (COPYFLG (COPY (VIRGINFN FROM)))
+                           (T (GETD FROM)))
+                     DONTCOPY)
+               (AND FILEPKGFLG (EXPRP TO)
+                    (MARKASCHANGED TO 'FNS NEWFLG))
+               TO])
+
+(MOVD?
+  [LAMBDA (FROM TO COPYFLG DONTCOPY)             (* bvm%: "10-Jul-85 13:00")
+    (* ;; "Like MOVD but only does it if TO is not defined.")
+
+    (COND
+       ((NULL (GETD TO))
+        (PUTD TO (COND
+                    (COPYFLG (COPY (VIRGINFN FROM)))
+                    (T (GETD FROM)))
+              DONTCOPY)
+        (AND FILEPKGFLG (EXPRP TO)
+             (MARKASCHANGED TO 'FNS T))
+        TO])
+
+(SELECTQ
+  [NLAMBDA SELCQ
+    (APPLY 'PROGN (SELECTQ1 (EVAL (CAR SELCQ)
+                                      'SELECTQ)
+                         (CDR SELCQ))
+           'SELECTQ])
+
+(SELECTQ1
+  [LAMBDA (M L)
+    (PROG (C)
+      LP  (SETQ C L)
+          [COND
+             ((NULL (SETQ L (CDR L)))
+              (RETURN C))
+             ([OR (EQ (CAR (SETQ C (CAR C)))
+                      M)
+                  (AND (LISTP (CAR C))
+                       (FMEMB M (CAR C]
+              (RETURN (CDR C]
+          (GO LP])
+
+(NCONC1
+  [LAMBDA (LST X)
+          (* included in wtmisc so can make the call to nconc be linked.
+        so that user can then break on nconc.)
+
+    (NCONC LST (FRPLACD (CONS X LST])
+
+(PUTPROP
+  [LAMBDA (ATM PROP VAL)                                 (* ; "Edited 28-May-87 09:16 by jop")
+
+    (* ;; "Included because it must be defined before the MOVD's in BOOTSTRAPCOMS that initialize /PUTPROP are executed.")
+
+    [COND
+       ((NOT (LITATOM ATM))
+        (ERRORX (LIST 14 ATM]
+    (PROG ((X (GETPROPLIST ATM))
+           X0)
+      LP  (COND
+             ((NLISTP X)
+              (COND
+                 ((AND (NULL X)
+                       X0)                                   (* ; 
+                "typical case.  property list ran out on an even parity position.  e.g.  (A B C D)")
+
+                  (FRPLACD (CDR X0)
+                         (LIST PROP VAL))
+                  (RETURN VAL)))
+              (* ;; "propety list was initially NIL or a non-list, or else it ended in a non-list following an even parity position, e.g.  (A B  . C) fall through and add new property at beginning")
+
+              )
+             ((NLISTP (CDR X))
+              (* ;; "property list runs out on an odd parity, or ends in an odd list following an odd parity, e.g.  (A B C) or (A B C  . D) fall through and add at beginning")
+
+              )
+             ((EQ (CAR X)
+                  PROP)
+              (FRPLACA (CDR X)
+                     VAL)
+              (RETURN VAL))
+             (T (SETQ X (CDDR (SETQ X0 X)))
+                (GO LP)))
+          [SETPROPLIST ATM (CONS PROP (CONS VAL (GETPROPLIST ATM]
+          (RETURN VAL])
+
+(PROPNAMES
+  [LAMBDA (ATM)                                          (* wt%: " 3-AUG-78 01:23")
+    (MAPLIST (GETPROPLIST ATM)
+           (FUNCTION CAR)
+           (FUNCTION CDDR])
+
+(ADDPROP
+  [LAMBDA (ATM PROP NEW FLG)                                 (* ; 
+                       "If FLG is T, NEW is consed onto the front, otherwise NCONCED onto the end.")
+                                                             (* ; "Value is new PROP value.")
+
+    [COND
+       [(NULL ATM)
+        (ERRORX (LIST 7 (LIST PROP NEW]
+       ((NOT (LITATOM ATM))
+        (ERRORX (LIST 14 ATM]
+    (PROG ((X (GETPROPLIST ATM))
+           X0)
+      LP  (COND
+             ((NLISTP X)
+              (COND
+                 ((AND (NULL X)
+                       X0)                                   (* ; 
+                                 "typical case.  property list ran out on an even parity position.")
+
+                  [FRPLACD (CDR X0)
+                         (LIST PROP (SETQ NEW (LIST NEW]
+                  (RETURN NEW)))
+              (* ;; "proprty list was initially NIL or a non-lit, or ele it ended in a non-list following an even parity position, e.g.  (A B . C) fall through and add property at beginning of property list.")
+
+              )
+             ((NLISTP (CDR X))
+              (* ;; "property list runs out on an odd parity, or else ends in a non-list following an odd parity, e.g.  (A B C) or (A B C . D) fall through and add at beginning")
+
+              )
+             ((EQ (CAR X)
+                  PROP)                                      (* ; "PROP found")
+
+              [FRPLACA (CDR X)
+                     (SETQ NEW (COND
+                                  (FLG (CONS NEW (CADR X)))
+                                  (T (NCONC1 (CADR X)
+                                            NEW]
+              (RETURN NEW))
+             (T (SETQ X (CDDR (SETQ X0 X)))
+                (GO LP)))                                    (* ; 
+                                                           "Add to beginning of property list.")
+
+          [SETPROPLIST ATM (CONS PROP (CONS (SETQ NEW (LIST NEW))
+                                            (GETPROPLIST ATM]
+          (RETURN NEW])
+
+(REMPROP
+  [LAMBDA (ATM PROP)                                     (* bvm%: "17-Sep-86 17:29")
+    [COND
+       ((NULL (LITATOM ATM))
+        (ERRORX (LIST 14 ATM]
+    (PROG ((X (GETPROPLIST ATM))
+           X0 VAL)
+      LP  [COND
+             ((OR (NLISTP X)
+                  (NLISTP (CDR X)))
+              (RETURN VAL))
+             ((EQ (CAR X)
+                  PROP)
+              (SETQ VAL (OR PROP T))                         (* ; "T in case indicator is NIL")
+
+              [COND
+                 (X0 (FRPLACD (CDR X0)
+                            (CDDR X)))
+                 (T (SETPROPLIST ATM (CDDR X]                (* ; "iterate in case there are more occurrences.  Shouldn't happen unless users manually clobber prop list")
+
+              (SETQ X (CDDR X)))
+             (T (SETQ X (CDDR (SETQ X0 X]
+          (GO LP])
+
+(MEMB
+  [LAMBDA (X Y)
+    (PROG NIL
+      LP  (RETURN (COND
+                     ((NLISTP Y)
+                      NIL)
+                     ((EQ X (CAR Y))
+                      Y)
+                     (T (SETQ Y (CDR Y))
+                        (GO LP])
+
+(CLOSEF?
+  [LAMBDA (FL)                                               (* wt%: 18-MAR-77 12 20)
+                                                             (* ; 
+                               "useful for resetsaves, in case somebody else might close the file.")
+
+    (AND FL (OPENP FL)
+         (CLOSEF FL])
+)
+
+
+
+(* ; "Need these in order to load even compiled files SYSLOAD")
+
+(DEFINEQ
+
+(LOAD
+  [LAMBDA (FILE LDFLG PRINTFLG PACKAGE)                  (* ; "Edited  9-Apr-87 18:44 by bvm:")
+
+    (RESETLST (PROG (STREAM TEM)
+                TOP (if (FMEMB LDFLG LOADOPTIONS)
+                      elseif (AND DWIMFLG (SETQ TEM (FIXSPELL LDFLG NIL LOADOPTIONS T)))
+                        then (SETQ LDFLG TEM)
+                      else (SETQ LDFLG (ERROR "unrecognized load option" LDFLG))
+                            (GO TOP))
+                    [if (AND PACKAGE (NOT (CL:PACKAGEP PACKAGE)))
+                        then                             (* ; 
+                                                           "Make sure package arg is ok, too")
+
+                              (SETQ PACKAGE (OR (CL:FIND-PACKAGE PACKAGE)
+                                                (\DTEST PACKAGE 'PACKAGE]
+                    [RESETSAVE NIL (LIST 'CLOSEF? (SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD 
+                                                                      LOADPARAMETERS]
+                    (RETURN (\LOAD-STREAM STREAM LDFLG PRINTFLG (AND PRETTYHEADER T)
+                                   PACKAGE])
+
+(\LOAD-STREAM
+  [LAMBDA (STREAM LDFLG PRINTFLG LOAD-VERBOSE-STREAM PACKAGE)
+    (DECLARE (SPECVARS LDFLG PRINTFLG LOAD-VERBOSE-STREAM))
+                                                             (* ; "Edited 29-Jan-88 19:02 by jop")
+
+(* ;;; "Internal function that loads from an already open stream.  LOAD-VERBOSE-STREAM if non-nil is the stream to which to print %"file created%" messages and such.  Similarly, PRINTFLG, if non-nil, is the stream to which to print the value of each expression.")
+
+    (PROG ((*STANDARD-INPUT* STREAM)
+           (FILE (FULLNAME STREAM))
+           (*PACKAGE* *PACKAGE*)
+           (*READTABLE* (PROG1 FILERDTBL                     (* ; "This initial value important for SKIPSEPRCODES below, but *READTABLE* gets reset appropriately before anything else is read")
+                               ))
+           (DFNFLG DFNFLG)
+           (BUILDMAPFLG BUILDMAPFLG)
+           (FILEPKGFLG FILEPKGFLG)
+           (ADDSPELLFLG ADDSPELLFLG)
+           (LISPXHIST LISPXHIST)
+           (PRLST (AND FILEPKGFLG (FILEPKGCHANGES)))
+           (FILECREATEDENV *OLD-INTERLISP-READ-ENVIRONMENT*)
+           FILEMAP FNADRLST ROOTNAME TEM FILECREATEDLST LOADA MAYBEWANTFILEMAP INTERLISP-P 
+           FILECREATEDLOC)
+          (DECLARE (SPECVARS DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FILECREATEDLST 
+                              FILECREATEDENV FILECREATEDLOC FILE))
+          (if (AND LOAD-VERBOSE-STREAM FILE)
+              then (LISPXTERPRI LOAD-VERBOSE-STREAM)
+                    (if (NEQ LOAD-VERBOSE-STREAM T)
+                        then                             (* ; 
+                                            "CL:LOAD says to prefix this stuff with comment marker")
+                              (PRIN1 "; Loading " LOAD-VERBOSE-STREAM)) 
+                                                             (* ; 
+                          "Might use EXEC-FORMAT here except that it isn't defined early in loadup")
+                    (LISPXPRIN1 FILE LOAD-VERBOSE-STREAM)
+                    (LISPXTERPRI LOAD-VERBOSE-STREAM))
+          (if (EQ (SETQ DFNFLG LDFLG)
+                      'SYSLOAD)
+              then (SETQ DFNFLG T)
+                    (SETQ ADDSPELLFLG NIL)
+                    (SETQ BUILDMAPFLG NIL)
+                    (SETQ FILEPKGFLG NIL)
+                    (SETQ LISPXHIST NIL))
+          (if LISPXHIST
+              then                                       (* ; 
+                       "Want UNDOSAVE to keep saving regardless of how many undosaves are involved")
+                    (if (SETQ LOADA (FMEMB 'SIDE LISPXHIST))
+                        then (FRPLACA (CADR LOADA)
+                                        -1)
+                      else (LISPXPUT 'SIDE (LIST -1)
+                                      NIL LISPXHIST)))
+          [if (EQ (SETQ TEM (SKIPSEPRCODES STREAM))
+                      FASL:SIGNATURE)
+              then                                       (* ; 
+                                                           "FASL file handled by FASL loader")
+                    (FASL:PROCESS-FILE STREAM)
+                    [LET [(MANAGED-FILE-P (GET (SETQ ROOTNAME (ROOTFILENAME FILE T))
+                                               'FILEDATES]
+                         (if (NOT (MEMB FILE LOADEDFILELST))
+                             then                        (* ; 
+                                                           "Keep track of every file loaded.")
+                                   (SETQ LOADEDFILELST (CONS FILE LOADEDFILELST)))
+                         (if MANAGED-FILE-P
+                             then (if (EQ LDFLG 'SYSLOAD)
+                                          then 
+
+                                                (* ;; 
+   "Don't notice DFASL's when you are coming from CL:LOAD, and the user didn't specify a load flag")
+
+                                                (if (NOT (MEMB ROOTNAME SYSFILES))
+                                                    then (SETQ SYSFILES (NCONC1 SYSFILES 
+                                                                                   ROOTNAME)))
+                                                (SMASHFILECOMS ROOTNAME)
+                                        elseif FILEPKGFLG
+                                          then (ADDFILE ROOTNAME 'Compiled]
+                    (RETURN FILE)
+            elseif (NEQ TEM (CHARCODE "("))
+              then (RETURN (\CML-LOAD STREAM PRINTFLG LOAD-VERBOSE-STREAM (CL::DEFAULT-IO-PACKAGE
+                                                                               PACKAGE]
+          (if (AND BUILDMAPFLG (RANDACCESSP STREAM))
+              then (SETQ MAYBEWANTFILEMAP T))
+          (WITH-READER-ENVIRONMENT FILECREATEDENV
+              (PROG (ADR)
+                LP  (if FILEMAP
+                        then                             (* ; 
+                                                           "need to build map, so read carefully")
+                              (SETQ LOADA (SKIPSEPRCODES STREAM))
+                              (if (OR (SYNTAXP LOADA 'LEFTPAREN)
+                                          (SYNTAXP LOADA 'LEFTBRACKET))
+                                  then                   (* ; "See if we have a DEFINEQ")
+                                        (SETQ ADR (GETFILEPTR STREAM))
+                                        (READCCODE STREAM)   (* ; "Eat paren")
+                                        (if (EQ (RATOM STREAM)
+                                                    'DEFINEQ)
+                                            then (SETQ FNADRLST (TCONC NIL ADR))
+                                                  (TCONC FNADRLST NIL)
+                                                  (TCONC FILEMAP (CAR FNADRLST))
+                                                  (GO DEFQLP)) 
+                                                             (* ; "Not a DEFINEQ, so back out")
+                                        (SETFILEPTR STREAM ADR)))
+                    (SELECTQ (SETQ LOADA (READ STREAM))
+                          ((STOP NIL) 
+                                 (if (EQ LDFLG 'SYSLOAD)
+                                     then (if (NOT (MEMB (SETQ ROOTNAME
+                                                                      (ROOTFILENAME FILE
+                                                                             (CDR FILECREATEDLST)))
+                                                                  SYSFILES))
+                                                  then (SETQ SYSFILES (NCONC1 SYSFILES 
+                                                                                 ROOTNAME)))
+                                           (SMASHFILECOMS ROOTNAME)
+                                   elseif FILEPKGFLG
+                                     then 
+
+                                 (* ;; "Do not want any items that are added to FILEPKGCHANGES as a result of being mentioned in this file to remain on FILEPKGCHANGES.  Also, we want items mentioned earlier to be deleted if they are taken care of by this file.  The extra argument to ADDFILE allows it to restore FILEPKGCHANGES to the intersection of its current value and its previous value.")
+
+                                           (ADDFILE FILE T PRLST FILECREATEDLST))
+                                 [if FILEMAP
+                                     then (PUTFILEMAP FILE (CAR FILEMAP)
+                                                     FILECREATEDLST FILECREATEDENV NIL 
+                                                     FILECREATEDLOC)
+                                           (if UPDATEMAPFLG
+                                               then (SETFILEPTR STREAM ADR) 
+                                                             (* ; 
+                                  "address of last expression read.  good hint for finding filemap")
+                                                     (UPDATEFILEMAP STREAM (CAR FILEMAP]
+                                 (if (NOT (MEMB FILE LOADEDFILELST))
+                                     then (/SETTOPVAL 'LOADEDFILELST (CONS FILE LOADEDFILELST)))
+                                 (RETURN))
+                          NIL)
+                    [if (LISTP LOADA)
+                        then
+                        (SELECTQ (CAR LOADA)
+                              (DEFINE-FILE-INFO              (* ; 
+                                 "Handle this specially, since we want to remember the environment")
+                                                (SETQ FILECREATEDLOC (GETFILEPTR STREAM))
+                                                [SET-READER-ENVIRONMENT (SETQ LOADA
+                                                                         (SETQ FILECREATEDENV
+                                                                          (\DO-DEFINE-FILE-INFO
+                                                                           NIL
+                                                                           (CDR LOADA]
+                                                (if PACKAGE
+                                                    then (* ; 
+                                          "Caller better really mean it--overrides what's on file!")
+                                                          (replace REPACKAGE of 
+                                                                                       FILECREATEDENV
+                                                             with (SETQ *PACKAGE*
+                                                                       (OR (CL:FIND-PACKAGE *PACKAGE*
+                                                                                  )
+                                                                           (CL:CERROR 
+                                                                              "Use current *PACKAGE*"
+                                                                                  
+                                                                         "~s does not name a package"
+                                                                                  *PACKAGE*)
+                                                                           *PACKAGE*)))
+                                                          (LISTPUT (fetch RESPEC of 
+                                                                                       FILECREATEDENV
+                                                                          )
+                                                                 :PACKAGE
+                                                                 (CL:PACKAGE-NAME *PACKAGE*))))
+                              (FILECREATED (if MAYBEWANTFILEMAP
+                                               then      (* ; "See if we have a valid file map")
+                                               (SETQ ADR (GETFILEPTR STREAM))
+                                               (if [AND (FIXP (SETQ TEM (CADDDR LOADA)))
+                                                            [SETQ TEM (CAR (NLSETQ (SETFILEPTR STREAM
+                                                                                          TEM)
+                                                                                  (READ STREAM]
+                                                            (EQ (CAR TEM)
+                                                                'FILEMAP)
+                                                            (NULL (CAR (SETQ TEM (CADR TEM]
+                                                   then  (* ; "Has ok map")
+                                                         (PUTFILEMAP FILE TEM NIL FILECREATEDENV)
+                                                 else    (* ; 
+                                                           "Need to build a file map as we go")
+                                                       (SETQ FILEMAP (TCONC NIL NIL)))
+                                               (SETFILEPTR STREAM ADR)
+                                               (SETQ MAYBEWANTFILEMAP NIL))
+                                           (SETQ LOADA (\EVAL LOADA)))
+                              (SETQ LOADA (\EVAL LOADA)))
+                      else                               (* ; 
+                                                           "Atom found.  Compiled code definition.")
+                            (if ADDSPELLFLG
+                                then (ADDSPELL LOADA))
+                            (if FILEMAP
+                                then (SETQ ADR (GETFILEPTR STREAM)))
+                            (LAPRD LOADA)
+                            (if FILEMAP
+                                then (TCONC FILEMAP (CONS ADR (CONS (GETFILEPTR STREAM)
+                                                                        LOADA]
+                LP1 (if PRINTFLG
+                        then (PRINT LOADA PRINTFLG))
+                    (GO LP)
+                DEFQLP
+                    (SELCHARQ (SKIPSEPRCODES STREAM)
+                         ((%) %])                            (* ; "Closes DEFINEQ.")
+                              (READCCODE STREAM)
+                              (if FNADRLST
+                                  then (RPLACA (CDAR FNADRLST)
+                                                  (GETFILEPTR STREAM)))
+                                                             (* ; 
+                        "FNADRLST is a TCONC format list, hence want to RPLACA CDAR, not just CDR.")
+                              (SETQ LOADA (DEFINE (DREVERSE LOADA)))
+                              (GO LP1))
+                         ((%( %[)                            (* ; 
+                                                           "another function/definition pair")
+                              (SETQ ADR (GETFILEPTR STREAM))
+                              (SETQ LOADA (CONS (READ STREAM)
+                                                LOADA))
+                              [if FNADRLST
+                                  then (TCONC FNADRLST (CONS (CAAR LOADA)
+                                                                 (CONS ADR (GETFILEPTR STREAM]
+                              (GO DEFQLP))
+                         NIL)
+                    (ERROR "illegal argument in defineq")))
+          (RETURN FILE])
+
+(FILECREATED
+  [NLAMBDA X                                             (* ; "Edited 12-Jan-88 10:44 by bvm")
+
+    (DECLARE (USEDFREE FILECREATEDLST LOAD-VERBOSE-STREAM))
+    (PROG ((FILEDATE (CAR X))
+           (FILE (CADR X)))
+          (SETQ FILECREATEDLST (NCONC1 FILECREATEDLST X))
+          (COND
+             (LOAD-VERBOSE-STREAM 
+                    (* ;; "Presumably if user sets prettyheader to NIL, he doesnt want to see any file created messages, even those frm compiled files.")
+
+                    (if (NEQ LOAD-VERBOSE-STREAM T)
+                        then                             (* ; 
+                                            "CL:LOAD says to prefix this stuff with comment marker")
+
+                              (PRIN1 "; " LOAD-VERBOSE-STREAM))
+                    (LISPXPRIN1 (FILECREATED1 X)
+                           LOAD-VERBOSE-STREAM)
+                    (LISPXPRIN1 FILEDATE LOAD-VERBOSE-STREAM)
+                    (LISPXTERPRI LOAD-VERBOSE-STREAM)))
+          (COND
+             ((AND FILE (NLISTP FILE))
+              (* ;; "This is just temporary, primarily for keeping dates of system files which are loaded with FILEPKGFLG=NIL.  The real setting up of file property lists is done when ADDFILE is called.")
+
+              (/PUT (ROOTFILENAME FILE)
+                    'FILEDATES
+                    (LIST (CONS FILEDATE FILE])
+
+(FILECREATED1
+  [LAMBDA (X)                                            (* ; "Edited 12-Jan-88 10:44 by bvm")
+
+    (* ;; "performs error checking on filecreated expressions.  returns the thing to be printed.  used by filecreated, and loadfns.")
+
+    (* ;; "FILECREATED expression for source file is of form (FILECREATED date filename mapaddress . historyinfo).  For compiled file, is of form (FILECREATED date (%"compiled on%" sourceFile)). ")
+
+    (LET ((FILE (CADR X)))
+         (COND
+            ((AND NIL (STRINGP FILE))                        (* ; 
+ "old way of doing COMPILED ON -- we no longer have such files, and the file name can be a string.")
+
+             FILE)
+            ((LISTP FILE)                                    (* ; 
+    "New.  also used for printing COMPILED ON message.  CDR is a list of files that were compiled.")
+
+             (CAR FILE))
+            (T                                               (* ; 
+                                                           "FILE is atomic, the name of the file")
+
+               PRETTYHEADER])
+
+(PRETTYCOMPRINT
+  [NLAMBDA (X)                                           (* bvm%: "22-Sep-86 17:02")
+    (if LOAD-VERBOSE-STREAM
+        then (if (NEQ LOAD-VERBOSE-STREAM T)
+                     then                                (* ; 
+                                            "CL:LOAD says to prefix this stuff with comment marker")
+
+                           (PRIN1 "; " LOAD-VERBOSE-STREAM))
+              (LISPXPRINT X LOAD-VERBOSE-STREAM])
+
+(BOOTSTRAP-NAMEFIELD
+  [LAMBDA (FILE SUFFIXFLG)                               (* bvm%: " 2-Aug-86 14:50")
+    (* ;; "BOOTSTRAP VERSION -- this is replaced by real version from MACHINEINDEPENDENT")
+
+    (PROG ((START 1)
+           POS END)
+          (while (SETQ POS (OR (STRPOS '} FILE START)
+                                   (STRPOS '> FILE START)
+                                   (STRPOS '/ FILE START))) do (SETQ START (ADD1 POS)))
+          [COND
+             ((SETQ POS (STRPOS '; FILE))
+              (SETQ END (SUB1 POS))
+              (COND
+                 ((EQ (NTHCHARCODE FILE END)
+                      (CHARCODE "."))                        (* ; "eliminates null suffix")
+
+                  (SETQ END (SUB1 END]
+          [COND
+             ((SETQ POS (STRPOS '%. FILE START))
+              (COND
+                 ((NULL SUFFIXFLG)
+                  (SETQ END (SUB1 POS]
+          (RETURN (SUBATOM FILE START END])
+
+(PUTPROPS
+  [NLAMBDA X                                             (* bvm%: " 8-Sep-86 11:20")
+    (* ;; "Later in the loadup, the PUTPROP is changed to SAVEPUT")
+
+    (MAP (CDR X)
+         [FUNCTION (LAMBDA (Y)
+                     (PUTPROP (CAR X)
+                            (CAR Y)
+                            (CADR Y]
+         (FUNCTION CDDR])
+
+(DECLARE%:
+  [NLAMBDA X                                             (* wt%: "20-OCT-77 13:00")
+    (DECLARE%:1 X T])
+
+(DECLARE%:1
+  [LAMBDA (X EVALFLG)                                    (* wt%: "20-OCT-77 13:09")
+    (PROG NIL
+      LP  (COND
+             ((NLISTP X)
+              (RETURN))
+             [(LISTP (CAR X))
+              (AND EVALFLG (COND
+                              ((EQ (CAAR X)
+                                   'DECLARE%:)
+                               (DECLARE%:1 (CDAR X)
+                                      T))
+                              (T (EVAL (CAR X]
+             (T (SELECTQ (CAR X)
+                      ((EVAL@LOAD DOEVAL@LOAD) 
+                             (SETQ EVALFLG T))
+                      (EVAL@LOADWHEN (SETQ EVALFLG (EVAL (CADR X)))
+                                     (SETQ X (CDR X)))
+                      (DONTEVAL@LOAD (SETQ EVALFLG NIL))
+                      NIL)))
+          (SETQ X (CDR X))
+          (GO LP])
+
+(ROOTFILENAME
+  [LAMBDA (NAME COMPFLG)                                 (* ; "Edited 22-May-92 11:59 by jds")
+
+    (* ;; "Returns the root of the filename NAME, the atom that all file package properties will be associated with.  If NAME names a compiled file, then COMPFLG~=NIL and we assume that the extension is COMPILE.EXT, which is to be stripped off.  We thus have something of an anomaly: We can keep track of 2 symbolic files whose names differ only in extension, but we confuse them when we deal with their compiled versions.")
+
+    (* ;; "The name is always returned in upper case, so that file-system case dependencies don't carry over into Medley, where source file names are NOT case dependent. JDS, fixing AR 11518 5/21/92")
+
+    (U-CASE (NAMEFIELD (COND
+                          ((TYPEP NAME 'STREAM)
+                           (FULLNAME NAME))
+                          (T NAME))
+                   (NOT COMPFLG])
+
+(DEFINE-FILE-INFO
+  [NLAMBDA ARGS                                          (* bvm%: "13-Oct-86 17:24")
+    (* ;; "Evaluated when it appears at top of file.  Caller (e.g., LOAD) binds reader environment, so we just set it.  Also return the env in case someone wants it.")
+
+    (DECLARE (USEDFREE FILECREATEDLOC))
+    (SETQ FILECREATEDLOC (GETFILEPTR))
+    (SET-READER-ENVIRONMENT (\DO-DEFINE-FILE-INFO NIL ARGS])
+
+(\DO-DEFINE-FILE-INFO
+  [LAMBDA (STREAM ARGS)                                  (* bvm%: "14-Oct-86 00:28")
+(* ;;; "Processes the (DEFINE-FILE-INFO . ARGS) at the front of STREAM")
+
+    (LET (PACKAGE READTABLE BASE VALUE)
+         [for TAIL on ARGS by (CDDR TAIL)
+            do (SETQ VALUE (CADR TAIL))
+                  (SELECTQ (CAR TAIL)
+                        (:PACKAGE (SETQ PACKAGE
+                                   (OR (if (LISTP VALUE)
+                                           then (LET ((P (EVAL VALUE)))
+                                                         (if (TYPEP P 'PACKAGE)
+                                                             then P
+                                                           else (CL:FIND-PACKAGE P)))
+                                         else (CL:FIND-PACKAGE VALUE))
+                                       (ERROR "Can't find package for reader environment" VALUE))))
+                        (:READTABLE (SETQ READTABLE (OR (if (LISTP VALUE)
+                                                            then (\DTEST (EVAL VALUE)
+                                                                            'READTABLEP)
+                                                          else (FIND-READTABLE VALUE))
+                                                        (ERROR 
+                                                       "Can't find read table for reader environment" 
+                                                               VALUE))))
+                        (:BASE (SETQ BASE (OR (\CHECKRADIX (if (LISTP VALUE)
+                                                               then (EVAL VALUE)
+                                                             else VALUE))
+                                              (ERROR "Bad read base for reader environment" VALUE))))
+                        (ERROR "Unrecognized file info key" (CAR TAIL]
+         (create READER-ENVIRONMENT
+                REPACKAGE _ (OR PACKAGE *INTERLISP-PACKAGE*)
+                REREADTABLE _ (OR READTABLE FILERDTBL)
+                REBASE _ (OR BASE 10)
+                RESPEC _ ARGS])
+)
+
+(RPAQ? EOLCHARCODE (CHCON1 "
+"))
+
+(RPAQ? PRETTYHEADER )
+
+(RPAQ? DWIMFLG )
+
+(RPAQ? UPDATEMAPFLG )
+
+(RPAQ? DFNFLG )
+
+(RPAQ? ADDSPELLFLG )
+
+(RPAQ? BUILDMAPFLG )
+
+(RPAQ? FILEPKGFLG )
+
+(RPAQ? SYSFILES )
+
+(RPAQ? NOTCOMPILEDFILES )
+
+(RPAQ? RESETVARSLST )
+
+(RPAQ? LOADPARAMETERS '((SEQUENTIAL T)))
+
+(RPAQ? LISPXHIST )
+
+(RPAQ? LISPXPRINTFLG T)
+
+(RPAQ? PRETTYHEADER "File created ")
+
+(RPAQ? LOAD-VERBOSE-STREAM T)
+
+(RPAQ? BELLS '"")
+
+(RPAQ? LOADOPTIONS '(SYSLOAD NIL T PROP ALLPROP))
+
+(RPAQ? PRETTYDEFMACROS NIL)
+
+(RPAQ? PRETTYTYPELST NIL)
+
+(RPAQ? FILEPKGTYPES NIL)
+
+(ADDTOVAR LOADEDFILELST )
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS DWIMFLG UPDATEMAPFLG LOADOPTIONS LOADPARAMETERS FILERDTBL SYSFILES)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+[MAPC '((PUTD . /PUTD)
+        (PUTPROP . /PUTPROP)
+        (PUTPROP . PUT)
+        (PUTPROP . SAVEPUT)
+        (ADDPROP . /ADDPROP)
+        (PUT . /PUT)
+        (PRIN1 . LISPXPRIN1)
+        (PRIN2 . LISPXPRIN2)
+        (PRINT . LISPXPRINT)
+        (TERPRI . LISPXTERPRI)
+        (SPACES . LISPXSPACES)
+        (GETPROP . GETP)
+        (SET . SAVESET)
+        (SET . /SET)
+        (NILL . MISSPELLED?)
+        (SETTOPVAL . /SETTOPVAL)
+        (BOOTSTRAP-NAMEFIELD . NAMEFIELD)
+        (BOOTSTRAP-NAMEFIELD . COMSNAME)
+        (NILL . RESETRESTORE))
+      (FUNCTION (LAMBDA (X)
+                  (OR (CCODEP (CDR X))
+                      (MOVD (CAR X)
+                             (CDR X)
+                             NIL T]
+
+(AND (CCODEP 'BOOTSTRAP-NAMEFIELD)
+     (PUTD 'BOOTSTRAP-NAMEFIELD))
+
+
+(RADIX 10)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ FASL:SIGNATURE 145)
+
+
+(CONSTANTS FASL:SIGNATURE)
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA DEFINE-FILE-INFO DECLARE%: PUTPROPS FILECREATED SELECTQ)
+
+(ADDTOVAR NLAML PRETTYCOMPRINT RPAQ? RPAQ RPAQQ)
+
+(ADDTOVAR LAMA )
+)
+(PUTPROPS BOOTSTRAP COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 
+1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (4584 14256 (GETPROP 4594 . 5166) (SETATOMVAL 5168 . 5297) (RPAQQ 5299 . 5352) (RPAQ 
+5354 . 5666) (RPAQ? 5668 . 6038) (MOVD 6040 . 7904) (MOVD? 7906 . 8336) (SELECTQ 8338 . 8525) (
+SELECTQ1 8527 . 8869) (NCONC1 8871 . 9067) (PUTPROP 9069 . 10553) (PROPNAMES 10555 . 10746) (ADDPROP 
+10748 . 12811) (REMPROP 12813 . 13667) (MEMB 13669 . 13928) (CLOSEF? 13930 . 14254)) (14329 39341 (
+LOAD 14339 . 15508) (\LOAD-STREAM 15510 . 30380) (FILECREATED 30382 . 31800) (FILECREATED1 31802 . 
+32910) (PRETTYCOMPRINT 32912 . 33397) (BOOTSTRAP-NAMEFIELD 33399 . 34359) (PUTPROPS 34361 . 34729) (
+DECLARE%: 34731 . 34863) (DECLARE%:1 34865 . 35737) (ROOTFILENAME 35739 . 36687) (DEFINE-FILE-INFO 
+36689 . 37124) (\DO-DEFINE-FILE-INFO 37126 . 39339)))))
+STOP
diff --git a/CLTL2/BOOTSTRAP.LCOM b/CLTL2/BOOTSTRAP.LCOM
new file mode 100644
index 00000000..960dff25
Binary files /dev/null and b/CLTL2/BOOTSTRAP.LCOM differ
diff --git a/CLTL2/BREAK-AND-TRACE b/CLTL2/BREAK-AND-TRACE
new file mode 100644
index 00000000..94ced36f
--- /dev/null
+++ b/CLTL2/BREAK-AND-TRACE
@@ -0,0 +1,902 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "SYSTEM")
+(IL:FILECREATED "13-Oct-93 18:35:41" "{Pele:mv:envos}<LispCore>Sources>CLTL2>BREAK-AND-TRACE.;2" 48661  
+
+      IL:|previous| IL:|date:| " 4-Feb-92 10:31:42" 
+"{Pele:mv:envos}<LispCore>Sources>CLTL2>BREAK-AND-TRACE.;1")
+
+
+; Copyright (c) 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:BREAK-AND-TRACECOMS)
+
+(IL:RPAQQ IL:BREAK-AND-TRACECOMS
+          (
+
+(IL:* IL:|;;;| "Support for tracing.")
+
+           (IL:VARIABLES XCL:*TRACE-DEPTH* XCL::*TRACED-FNS* IL:TRACEREGION)
+           (IL:FUNCTIONS XCL:CREATE-TRACE-WINDOW)
+           (IL:FUNCTIONS CREATE-TRACED-DEFINITION CONSTRUCT-ENTRY-PRINTING-CODE 
+                  PRINT-TRACE-ENTRY-INFO PRINT-TRACE-EXIT-INFO PRINT-TRACED-ARGUMENT 
+                  PRINT-TRACED-CL-ARGLIST)
+           (IL:VARIABLES XCL:*TRACE-LEVEL* XCL:*TRACE-LENGTH* XCL:*TRACE-VERBOSE* *TRACE-OUTPUT*)
+           (IL:FNS TRACE UNTRACE)
+           (IL:FUNCTIONS XCL:TRACE-FUNCTION)
+           
+
+(IL:* IL:|;;;| "Support for breaking.")
+
+           (IL:FUNCTIONS XCL:BREAK-FUNCTION XCL:UNBREAK-FUNCTION XCL:REBREAK-FUNCTION 
+                  CREATE-BROKEN-DEFINITION UNBREAK-FROM-RESTORE-CALLS FINISH-UNBREAKING)
+           (IL:VARIABLES IL:BROKENFNS XCL::*BREAK-HASH-TABLE* XCL::*UNBROKEN-FNS*)
+           (IL:PROP IL:PROPTYPE IL:BROKEN)
+           
+           (IL:* IL:|;;| "The old Interlisp interface to breaking.")
+
+           (IL:FNS IL:BREAK IL:BREAK0 IL:REBREAK XCL:UNBREAK IL:UNBREAK0)
+           (IL:FNS IL:BREAK1)
+           (IL:SPECIAL-FORMS IL:BREAK1)
+           (XCL:OPTIMIZERS IL:BREAK1)
+           
+           (IL:* IL:|;;| "Arrange for the proper compiler and package")
+
+           (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                  IL:BREAK-AND-TRACE)
+           (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS
+                  (IL:ADDVARS (IL:NLAMA)
+                         (IL:NLAML IL:BREAK1)
+                         (IL:LAMA)))))
+
+
+
+(IL:* IL:|;;;| "Support for tracing.")
+
+
+(DEFVAR XCL:*TRACE-DEPTH* 0)
+
+(DEFVAR XCL::*TRACED-FNS* NIL
+
+(IL:* IL:|;;;| "A subset of the entries on IL:BROKENFNS, being those that resulted from calls to TRACE as opposed to calls to BREAK-FUNCTION.")
+
+   )
+
+(DEFVAR IL:TRACEREGION (IL:|create| IL:REGION
+                                  IL:LEFT IL:_ 8
+                                  IL:BOTTOM IL:_ 3
+                                  IL:WIDTH IL:_ 547
+                                  IL:HEIGHT IL:_ 310))
+
+(DEFUN XCL:CREATE-TRACE-WINDOW (&KEY (XCL::REGION IL:TRACEREGION)
+                                         (XCL::OPEN? NIL)
+                                         (XCL::TITLE "*Trace-Output*"))
+                                                             (IL:* IL:\; 
+                                                           "Edited 29-Jan-92 13:14 by jrb:")
+
+(IL:* IL:|;;;| "Create and return a display stream associated with a window suitable for use as the value of *TRACE-OUTPUT*.")
+
+(IL:* IL:|;;;| 
+"REGION is the initial region of the window.  It defaults to the value of IL:TRACEREGION.")
+
+(IL:* IL:|;;;| "OPEN? is true if the newly-created window should be left opened on the screen.  If false, the window will be closed and will open the first time any output is sent to it.")
+
+(IL:* IL:|;;;| "Because display streams only have an xpointer back to their windows, we give the stream a STREAMPROP pointer to the window; this makes them reference each other circularly, so they'll NEVER be GCed (*sigh*).")
+
+   (LET* ((XCL::WINDOW (IL:CREATEW XCL::REGION XCL::TITLE NIL (NOT XCL::OPEN?)))
+          (STREAM (IL:GETSTREAM XCL::WINDOW)))
+         (IL:DSPSCROLL 'IL:ON XCL::WINDOW)
+         (IL:STREAMPROP STREAM 'IL:WINDOW XCL::WINDOW)
+         STREAM))
+
+(DEFUN CREATE-TRACED-DEFINITION (TRACED-FN IN-FN FN-TO-CALL)
+   (MULTIPLE-VALUE-BIND
+    (LAMBDA-CAR ARG-LIST CALLING-FORM)
+    (FUNCTION-WRAPPER-INFO TRACED-FN FN-TO-CALL)
+    `(,LAMBDA-CAR ,(IF (EQ LAMBDA-CAR 'LAMBDA)
+                       '(&REST XCL:ARGLIST)
+                       ARG-LIST)
+            ,@(AND ARG-LIST (MEMBER LAMBDA-CAR '(IL:LAMBDA IL:NLAMBDA))
+                   `((DECLARE (SPECIAL ,@(IF (SYMBOLP ARG-LIST)
+                                                 (LIST ARG-LIST)
+                                                 ARG-LIST)))))
+            (IL:\\CALLME '(:TRACED ,(IF (NULL IN-FN)
+                                        TRACED-FN
+                                        `(,TRACED-FN :IN ,IN-FN))))
+            (LET* (($THE-REAL-TRACE-OUTPUT$ (XCL:FOLLOW-SYNONYM-STREAMS (IL:\\GETSTREAM 
+                                                                               *TRACE-OUTPUT*)))
+                   ($IMAGE-STREAM?$ (IL:IMAGESTREAMP $THE-REAL-TRACE-OUTPUT$)))
+                  (LET ((*STANDARD-OUTPUT* $THE-REAL-TRACE-OUTPUT$)
+                        (IL:FONTCHANGEFLG $IMAGE-STREAM?$))
+                       (DECLARE (SPECIAL IL:FONTCHANGEFLG))
+                       ,@(CONSTRUCT-ENTRY-PRINTING-CODE TRACED-FN IN-FN LAMBDA-CAR ARG-LIST))
+                  (LET (($TRACED-FN-VALUES$ (MULTIPLE-VALUE-LIST (LET ((XCL:*TRACE-DEPTH*
+                                                                        (1+ XCL:*TRACE-DEPTH*)))
+                                                                      ,CALLING-FORM))))
+                       (LET ((*STANDARD-OUTPUT* $THE-REAL-TRACE-OUTPUT$)
+                             (IL:FONTCHANGEFLG $IMAGE-STREAM?$))
+                            (DECLARE (SPECIAL IL:FONTCHANGEFLG))
+                            (PRINT-TRACE-EXIT-INFO ',TRACED-FN ',IN-FN $TRACED-FN-VALUES$))
+                       (VALUES-LIST $TRACED-FN-VALUES$))))))
+
+(DEFUN CONSTRUCT-ENTRY-PRINTING-CODE (TRACED-FN IN-FN LAMBDA-CAR ARG-LIST)
+   `((PRINT-TRACE-ENTRY-INFO ',TRACED-FN ',IN-FN)
+     (LET
+      ((*PRINT-LEVEL* XCL:*TRACE-LEVEL*)
+       (*PRINT-LENGTH* XCL:*TRACE-LENGTH*))
+      ,@(CASE LAMBDA-CAR
+            ((IL:LAMBDA IL:NLAMBDA) 
+               (IL:IF (LISTP ARG-LIST)
+                   IL:THEN 
+
+                         (IL:* IL:|;;| 
+                  "Interlisp spread function.  The ARG-LIST is, in fact, a list of argument names.")
+
+                         `((LET (($$INDENT$$ (+ 10 (* XCL:*TRACE-DEPTH* 4))))
+                                ,@(IL:FOR VAR IL:IN ARG-LIST
+                                     IL:COLLECT `(PRINT-TRACED-ARGUMENT ',VAR ,VAR $$INDENT$$
+                                                            ))))
+                 IL:ELSEIF (EQ LAMBDA-CAR 'IL:LAMBDA)
+                   IL:THEN 
+
+                         (IL:* IL:|;;| 
+                "Interlisp Lambda no-spread function.  Print out at most *TRACE-LENGTH* arguments.")
+
+                         `((IL:BIND ($$INDENT$$ IL:_ (+ 10 (* XCL:*TRACE-DEPTH* 4))) IL:FOR
+                                                                                         
+                                                                                        $ARG-COUNTER$
+                              IL:FROM 1 IL:TO (IF (NULL XCL:*TRACE-LENGTH*)
+                                                          ,ARG-LIST
+                                                          (MIN XCL:*TRACE-LENGTH* ,ARG-LIST))
+                              IL:DO (PRINT-TRACED-ARGUMENT $ARG-COUNTER$ (IL:ARG ,ARG-LIST 
+                                                                                        $ARG-COUNTER$
+                                                                                        )
+                                               $$INDENT$$)))
+                 IL:ELSE 
+
+                       (IL:* IL:|;;| "Interlisp NLambda no-spread function.  Print out at most *TRACE-LENGTH* arguments.  Also, be careful to check that the argument list is really a list.")
+
+                       `((LET (($$INDENT$$ (+ 10 (* XCL:*TRACE-DEPTH* 4))))
+                              (IF (LISTP ,ARG-LIST)
+                                  (IL:FOR $ARGUMENT$ IL:IN ,ARG-LIST IL:AS $ARG-COUNTER$
+                                     IL:FROM 1 IL:WHILE (OR (NULL XCL:*TRACE-LENGTH*)
+                                                                    (<= $ARG-COUNTER$ 
+                                                                        XCL:*TRACE-LENGTH*))
+                                     IL:DO (PRINT-TRACED-ARGUMENT $ARG-COUNTER$ $ARGUMENT$ 
+                                                      $$INDENT$$))
+                                  (PRINT-TRACED-ARGUMENT ',ARG-LIST ,ARG-LIST $$INDENT$$))))))
+            ((LAMBDA) 
+
+               (IL:* IL:|;;| "A Common Lisp function.")
+
+               (MULTIPLE-VALUE-BIND (REQUIRED OPTIONAL REST KEY KEY-APPEARED? ALLOW-OTHER-KEYS)
+                      (PARSE-CL-ARGLIST ARG-LIST)
+                      `((PRINT-TRACED-CL-ARGLIST XCL:ARGLIST ',REQUIRED ',OPTIONAL
+                               ',REST
+                               ',KEY
+                               ,KEY-APPEARED?
+                               ,ALLOW-OTHER-KEYS
+                               (+ 8 (* XCL:*TRACE-DEPTH* 4))
+                               XCL:*TRACE-VERBOSE*))))))))
+
+(DEFUN PRINT-TRACE-ENTRY-INFO (TRACED-FN IN-FN)
+   (DECLARE (SPECIAL IL:BOLDFONT IL:DEFAULTFONT))
+   (SETQ TRACED-FN (OR (GET TRACED-FN 'TRUE-NAME)
+                       TRACED-FN))
+   (SETQ IN-FN (OR (GET IN-FN 'TRUE-NAME)
+                   IN-FN))
+   (IL:SPACES (* XCL:*TRACE-DEPTH* 4))
+   (PRINC (1+ XCL:*TRACE-DEPTH*))
+   (PRINC " - Enter ")
+   (IL:CHANGEFONT IL:BOLDFONT)
+   (PRIN1 TRACED-FN)
+   (IL:CHANGEFONT IL:DEFAULTFONT)
+   (WHEN (NOT (NULL IN-FN))
+       (PRINC " in ")
+       (IL:CHANGEFONT IL:BOLDFONT)
+       (PRIN1 IN-FN)
+       (IL:CHANGEFONT IL:DEFAULTFONT))
+   (PRINC ":")
+   (TERPRI))
+
+(DEFUN PRINT-TRACE-EXIT-INFO (TRACED-FN IN-FN FN-VALUES)
+   (DECLARE (SPECIAL IL:BOLDFONT IL:DEFAULTFONT))
+   (SETQ TRACED-FN (OR (GET TRACED-FN 'TRUE-NAME)
+                       TRACED-FN))
+   (SETQ IN-FN (OR (GET IN-FN 'TRUE-NAME)
+                   IN-FN))
+   (IL:SPACES (* XCL:*TRACE-DEPTH* 4))
+   (PRINC (1+ XCL:*TRACE-DEPTH*))
+   (PRINC " - Exit ")
+   (IL:CHANGEFONT IL:BOLDFONT)
+   (PRIN1 TRACED-FN)
+   (IL:CHANGEFONT IL:DEFAULTFONT)
+   (WHEN (NOT (NULL IN-FN))
+       (PRINC " in ")
+       (IL:CHANGEFONT IL:BOLDFONT)
+       (PRIN1 IN-FN)
+       (IL:CHANGEFONT IL:DEFAULTFONT))
+   (PRINC " =>")
+   (TERPRI)
+   (IL:FOR VALUE IL:IN FN-VALUES IL:DO (IL:SPACES (+ 10 (* XCL:*TRACE-DEPTH* 4)))
+                                               (PRIN1 VALUE)
+                                               (TERPRI)))
+
+(DEFUN PRINT-TRACED-ARGUMENT (NAME VALUE INDENT &OPTIONAL PRIN1-THE-NAME?)
+   (IL:SPACES INDENT)
+   (WHEN (TYPEP NAME 'FIXNUM)
+         (PRINC "Arg "))
+   (IF PRIN1-THE-NAME?
+       (PRIN1 NAME)
+       (PRINC NAME))
+   (PRINC " = ")
+   (PRIN1 VALUE)
+   (TERPRI))
+
+(DEFUN PRINT-TRACED-CL-ARGLIST (ARGS REQUIRED OPTIONAL REST KEY KEY-APPEARED? ALLOW-OTHER-KEYS 
+                                         SMALL-INDENT VERBOSE?)
+   (DECLARE (SPECIAL IL:BOLDFONT IL:DEFAULTFONT))
+   (LET* ((INDENT (+ SMALL-INDENT 2)))
+         (WHEN REQUIRED
+             (IL:FOR VAR IL:IN REQUIRED IL:DO (COND
+                                                             ((NULL ARGS)
+                                                              (IL:SPACES INDENT)
+                                                              (PRINC VAR)
+                                                              (IL:CHANGEFONT IL:BOLDFONT)
+                                                              (PRINC " ** NOT SUPPLIED **")
+                                                              (IL:CHANGEFONT IL:DEFAULTFONT)
+                                                              (TERPRI))
+                                                             (T (PRINT-TRACED-ARGUMENT
+                                                                 VAR
+                                                                 (POP ARGS)
+                                                                 INDENT)))))
+         (WHEN OPTIONAL
+             (WHEN VERBOSE?
+                 (IL:SPACES SMALL-INDENT)
+                 (PRINC '&OPTIONAL)
+                 (TERPRI))
+             (IL:FOR VAR IL:IN OPTIONAL IL:DO (IF (NULL ARGS)
+                                                              (WHEN VERBOSE?
+                                                                  (IL:SPACES INDENT)
+                                                                  (PRINC VAR)
+                                                                  (PRINC " not supplied")
+                                                                  (TERPRI))
+                                                              (PRINT-TRACED-ARGUMENT VAR
+                                                                     (POP ARGS)
+                                                                     INDENT))))
+         (WHEN REST
+             (WHEN VERBOSE?
+                 (IL:SPACES SMALL-INDENT)
+                 (PRINC '&REST)
+                 (TERPRI))
+             (PRINT-TRACED-ARGUMENT REST ARGS INDENT))
+         (WHEN KEY
+             (WHEN VERBOSE?
+                 (IL:SPACES SMALL-INDENT)
+                 (PRINC '&KEY)
+                 (TERPRI))
+             (IL:FOR VAR IL:IN KEY IL:DO (IL:FOR TAIL IL:ON ARGS IL:BY CDDR
+                                                        IL:DO (WHEN (EQ VAR (CAR TAIL))
+                                                                      (PRINT-TRACED-ARGUMENT
+                                                                       VAR
+                                                                       (CADR TAIL)
+                                                                       INDENT T)
+                                                                      (RETURN)))))
+         (WHEN KEY-APPEARED?
+             (LET (TEMP)
+                  (COND
+                     ((ODDP (LENGTH ARGS))
+                      (IL:SPACES SMALL-INDENT)
+                      (IL:CHANGEFONT IL:BOLDFONT)
+                      (PRINC "** Odd-length &KEY argument list: **")
+                      (IL:CHANGEFONT IL:DEFAULTFONT)
+                      (TERPRI)
+                      (IL:SPACES INDENT)
+                      (PRIN1 ARGS)
+                      (TERPRI))
+                     ((SETQ TEMP (IL:FIND KEYWORD IL:IN ARGS IL:BY (CDDR KEYWORD)
+                                    IL:SUCHTHAT (IF ALLOW-OTHER-KEYS
+                                                        (NOT (KEYWORDP KEYWORD))
+                                                        (NOT (MEMBER KEYWORD KEY :TEST 'EQ)))))
+                      (IL:SPACES SMALL-INDENT)
+                      (IL:CHANGEFONT IL:BOLDFONT)
+                      (PRINC "** Illegal &KEY argument: **")
+                      (IL:CHANGEFONT IL:DEFAULTFONT)
+                      (TERPRI)
+                      (IL:SPACES INDENT)
+                      (PRIN1 TEMP)
+                      (TERPRI)))))
+         (WHEN (AND (NOT REST)
+                    (NOT KEY-APPEARED?)
+                    (NOT (NULL ARGS)))
+             (IL:SPACES SMALL-INDENT)
+             (IL:CHANGEFONT IL:BOLDFONT)
+             (PRINC "** Extra arguments: **")
+             (IL:CHANGEFONT IL:DEFAULTFONT)
+             (TERPRI)
+             (IL:SPACES INDENT)
+             (PRIN1 ARGS)
+             (TERPRI))))
+
+(DEFVAR XCL:*TRACE-LEVEL* NIL
+
+(IL:* IL:|;;;| "What to bind *PRINT-LEVEL* to when printing argument values in TRACE output.")
+
+   )
+
+(DEFVAR XCL:*TRACE-LENGTH* NIL
+
+(IL:* IL:|;;;| "What to bind *PRINT-LENGTH* to during the printing of argument values in TRACE output.  Also controls the number of arguments to no-spread functions that will be printed.")
+
+   )
+
+(DEFVAR XCL:*TRACE-VERBOSE* T
+
+(IL:* IL:|;;;| "Controls whether or not various parts of TRACE output are printed:")
+
+   (IL:* IL:|;;| "The lambda-list keywords &OPTIONAL, &REST, and &KEY.")
+
+   (IL:* IL:|;;| "Trailing unsupplied &OPTIONAL arguments.")
+
+   )
+
+(DEFVAR *TRACE-OUTPUT* (XCL:CREATE-TRACE-WINDOW))
+(IL:DEFINEQ
+
+(TRACE
+  (IL:NLAMBDA LISP::FNS                                      (IL:* IL:\; 
+                                                           "Edited  2-Apr-87 16:10 by Pavel")
+    (SETQ LISP::FNS (IL:NLAMBDA.ARGS LISP::FNS))
+    (IF (NULL LISP::FNS)
+        XCL::*TRACED-FNS*
+        (IL:FOR LISP::FN IL:IN LISP::FNS IL:JOIN (IF (CONSP LISP::FN)
+                                                                 (XCL:TRACE-FUNCTION (FIRST
+                                                                                          LISP::FN)
+                                                                        :IN
+                                                                        (THIRD LISP::FN))
+                                                                 (XCL:TRACE-FUNCTION LISP::FN))))
+    ))
+
+(UNTRACE
+  (IL:NLAMBDA LISP::FNS                                      (IL:* IL:\; 
+                                                           "Edited  2-Apr-87 16:39 by Pavel")
+    (SETQ LISP::FNS (IL:NLAMBDA.ARGS LISP::FNS))
+    (FLET ((LISP::UNTRACE-ENTRY (LISP::ENTRY)
+                  (IF (CONSP LISP::ENTRY)
+                      (XCL:UNBREAK-FUNCTION (FIRST LISP::ENTRY)
+                             :IN
+                             (SECOND LISP::ENTRY))
+                      (XCL:UNBREAK-FUNCTION LISP::ENTRY))))
+          (COND
+             ((NULL LISP::FNS)
+              (IL:FOR LISP::ENTRY IL:IN (REVERSE XCL::*TRACED-FNS*) IL:JOIN (
+                                                                                  LISP::UNTRACE-ENTRY
+                                                                                         LISP::ENTRY)
+                     ))
+             ((EQUAL LISP::FNS '(T))
+              (WHEN XCL::*TRACED-FNS*
+                  (LISP::UNTRACE-ENTRY (CAR XCL::*TRACED-FNS*))))
+             (T (IL:FOR LISP::FN IL:IN LISP::FNS IL:JOIN (IF (CONSP LISP::FN)
+                                                                         (XCL:UNBREAK-FUNCTION
+                                                                          (FIRST LISP::FN)
+                                                                          :IN
+                                                                          (THIRD LISP::FN))
+                                                                         (XCL:UNBREAK-FUNCTION
+                                                                          LISP::FN))))))))
+)
+
+(DEFUN XCL:TRACE-FUNCTION (XCL::FN-TO-TRACE &KEY ((:IN XCL::IN-FN))
+                                     XCL::REBREAK?)
+   (MULTIPLE-VALUE-BIND (XCL::EXECUTABLE-TO-TRACE XCL::NO-IN-FN)
+          (XCL::NAME-OF-EXECUTABLE XCL::FN-TO-TRACE)
+          (COND
+             ((AND (CONSP XCL::FN-TO-TRACE)
+                   (NOT XCL::EXECUTABLE-TO-TRACE))
+              (IL:FOR XCL::FN IL:IN XCL::FN-TO-TRACE IL:JOIN (XCL:TRACE-FUNCTION
+                                                                          XCL::FN :IN XCL::IN-FN)))
+             ((AND (CONSP XCL::IN-FN)
+                   (NOT (XCL::NAME-OF-EXECUTABLE XCL::IN-FN)))
+              (IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:TRACE-FUNCTION 
+                                                                          XCL::FN-TO-TRACE :IN 
+                                                                          XCL::FN)))
+             (T 
+                (IL:* IL:|;;| "General philosophy here: all external functions take the \"real\" names and not the names of the executables; the \"real\" names are the ones that are published on *TRACED-FNS* and the like.")
+
+                (IL:* IL:|;;| "One exception: the BROKEN property is placed on the name of the executable, since that is guaranteed to be a symbol")
+
+                (COND
+                   ((NULL (IL:GETD XCL::EXECUTABLE-TO-TRACE))
+                    (ERROR 'XCL:UNDEFINED-FUNCTION :NAME XCL::FN-TO-TRACE)
+                    NIL)
+                   ((IL:UNSAFE.TO.MODIFY XCL::FN-TO-TRACE "trace")
+                    (FORMAT *ERROR-OUTPUT* "~S not traced.~%" XCL::FN-TO-TRACE)
+                    NIL)
+                   (T (XCL:UNBREAK-FUNCTION XCL::FN-TO-TRACE :IN XCL::IN-FN :NO-ERROR T)
+                      (UNLESS XCL::REBREAK?                  (IL:* IL:\; "Save the breaking information for REBREAK, but don't save it if we're being called from REBREAK itself.")
+                          (SETF (GETHASH (IF (NULL XCL::IN-FN)
+                                             XCL::FN-TO-TRACE
+                                             `(,XCL::FN-TO-TRACE :IN ,XCL::IN-FN))
+                                       XCL::*BREAK-HASH-TABLE*)
+                                (LIST XCL::FN-TO-TRACE :IN XCL::IN-FN :TRACE? T :REBREAK? T)))
+                      (IF (NULL XCL::IN-FN)
+                          (LET ((XCL::ORIGINAL (LET ((*PRINT-CASE* :UPCASE))
+                                                    (MAKE-SYMBOL (FORMAT NIL "Original ~A" 
+                                                                        XCL::EXECUTABLE-TO-TRACE)))))
+                               (IL:PUTD XCL::ORIGINAL (IL:GETD XCL::EXECUTABLE-TO-TRACE)
+                                      T)
+                               (IL:PUTD XCL::EXECUTABLE-TO-TRACE (COMPILE NIL (
+                                                                           CREATE-TRACED-DEFINITION
+                                                                               
+                                                                             XCL::EXECUTABLE-TO-TRACE
+                                                                               NIL XCL::ORIGINAL))
+                                      T)
+                               (SETF (GET XCL::EXECUTABLE-TO-TRACE 'IL:BROKEN)
+                                     XCL::ORIGINAL)
+                               (PUSH XCL::FN-TO-TRACE IL:BROKENFNS)
+                               (PUSH XCL::FN-TO-TRACE XCL::*TRACED-FNS*)
+                               (SETQ XCL::*UNBROKEN-FNS* (DELETE XCL::FN-TO-TRACE XCL::*UNBROKEN-FNS*
+                                                                :TEST 'EQUAL))
+                               (LIST XCL::FN-TO-TRACE))
+                          (IF XCL::NO-IN-FN
+                              (ERROR "~S can't be selectively traced :IN ~S" XCL::FN-TO-TRACE 
+                                     XCL::IN-FN)
+                              (LET* ((XCL::EXECUTABLE-TO-TRACE-IN (XCL::NAME-OF-EXECUTABLE XCL::IN-FN
+                                                                         ))
+                                     (XCL::MIDDLE-MAN (CONSTRUCT-MIDDLE-MAN XCL::EXECUTABLE-TO-TRACE
+                                                             XCL::EXECUTABLE-TO-TRACE-IN)))
+                                    (IF (NOT (HAS-CALLS XCL::EXECUTABLE-TO-TRACE-IN 
+                                                    XCL::EXECUTABLE-TO-TRACE))
+                                        (ERROR "~S is not called from ~S." XCL::FN-TO-TRACE 
+                                               XCL::IN-FN))
+                                    (COMPILE XCL::MIDDLE-MAN (CREATE-TRACED-DEFINITION 
+                                                                    XCL::EXECUTABLE-TO-TRACE 
+                                                                    XCL::EXECUTABLE-TO-TRACE-IN 
+                                                                    XCL::EXECUTABLE-TO-TRACE))
+                                    (CHANGE-CALLS XCL::EXECUTABLE-TO-TRACE XCL::MIDDLE-MAN 
+                                           XCL::EXECUTABLE-TO-TRACE-IN 'UNBREAK-FROM-RESTORE-CALLS)
+                                    (LET ((XCL::ENTRY (LIST XCL::FN-TO-TRACE XCL::IN-FN 
+                                                            XCL::MIDDLE-MAN)))
+                                         (PUSH XCL::ENTRY IL:BROKENFNS)
+                                         (PUSH XCL::ENTRY XCL::*TRACED-FNS*))
+                                    (SETQ XCL::*UNBROKEN-FNS* (DELETE `(,XCL::FN-TO-TRACE
+                                                                        :IN
+                                                                        ,XCL::IN-FN)
+                                                                     XCL::*UNBROKEN-FNS* :TEST
+                                                                     'EQUAL))
+                                    (LIST `(,XCL::FN-TO-TRACE :IN ,XCL::IN-FN)))))))))))
+
+
+
+(IL:* IL:|;;;| "Support for breaking.")
+
+
+(DEFUN XCL:BREAK-FUNCTION (XCL::FN-TO-BREAK &KEY ((:IN XCL::IN-FN))
+                                     ((:WHEN XCL::WHEN-EXPR)
+                                      T)
+                                     XCL::TRACE? XCL::REBREAK?)
+   (MULTIPLE-VALUE-BIND
+    (XCL::EXECUTABLE-TO-BREAK XCL::NO-IN-FN)
+    (XCL::NAME-OF-EXECUTABLE XCL::FN-TO-BREAK)
+    (COND
+       (XCL::TRACE? (XCL:TRACE-FUNCTION XCL::FN-TO-BREAK :IN XCL::IN-FN :REBREAK? XCL::REBREAK?))
+       ((AND (CONSP XCL::FN-TO-BREAK)
+             (NOT XCL::EXECUTABLE-TO-BREAK))
+        (IL:FOR XCL::FN IL:IN XCL::FN-TO-BREAK
+           IL:JOIN (XCL:BREAK-FUNCTION XCL::FN :IN XCL::IN-FN :WHEN XCL::WHEN-EXPR :REBREAK?
+                              XCL::REBREAK?)))
+       ((AND (CONSP XCL::IN-FN)
+             (NOT (XCL::NAME-OF-EXECUTABLE XCL::IN-FN)))
+        (IL:FOR XCL::FN IL:IN XCL::IN-FN
+           IL:JOIN (XCL:BREAK-FUNCTION XCL::FN-TO-BREAK :IN XCL::FN :WHEN XCL::WHEN-EXPR 
+                              :REBREAK? XCL::REBREAK?)))
+       (T
+        (IF (IL:UNSAFE.TO.MODIFY XCL::FN-TO-BREAK "break")
+            (PROGN (FORMAT *ERROR-OUTPUT* "~S not broken." XCL::FN-TO-BREAK)
+                   NIL)
+            (PROGN (UNLESS XCL::REBREAK?                     (IL:* IL:\; "Save the breaking information for REBREAK.  Don't do it, though, if we're being called from REBREAK.")
+                       (SETF (GETHASH (IF (NULL XCL::IN-FN)
+                                          XCL::FN-TO-BREAK
+                                          `(,XCL::FN-TO-BREAK :IN ,XCL::IN-FN))
+                                    XCL::*BREAK-HASH-TABLE*)
+                             (LIST XCL::FN-TO-BREAK :IN XCL::IN-FN :WHEN XCL::WHEN-EXPR :REBREAK? T)))
+                   (WHEN (EQ XCL::WHEN-EXPR :ONCE)
+                       (SETQ XCL::WHEN-EXPR
+                             `(FUNCALL ',(LET ((XCL::TRIGGERED-YET? NIL))
+                                              #'(LAMBDA NIL (IF XCL::TRIGGERED-YET?
+                                                                NIL
+                                                                (SETQ XCL::TRIGGERED-YET? T)))))))
+                   (XCL:UNBREAK-FUNCTION XCL::FN-TO-BREAK :IN XCL::IN-FN :NO-ERROR T)
+                   (IF (NULL XCL::IN-FN)
+                       (LET* ((XCL::ORIGINAL-DEF (OR (IL:GETD XCL::EXECUTABLE-TO-BREAK)
+                                                     (ERROR 'XCL:UNDEFINED-FUNCTION :NAME 
+                                                            XCL::FN-TO-BREAK)))
+                              (XCL::ORIGINAL (LET ((*PRINT-CASE* :UPCASE))
+                                                  (MAKE-SYMBOL (FORMAT NIL "Original ~A" 
+                                                                      XCL::FN-TO-BREAK)))))
+                             (IL:PUTD XCL::ORIGINAL XCL::ORIGINAL-DEF T)
+                             (IL:PUTD XCL::EXECUTABLE-TO-BREAK (COMPILE NIL
+                                                                      (CREATE-BROKEN-DEFINITION
+                                                                       XCL::EXECUTABLE-TO-BREAK 
+                                                                       XCL::EXECUTABLE-TO-BREAK 
+                                                                       XCL::ORIGINAL XCL::WHEN-EXPR 
+                                                                       XCL::EXECUTABLE-TO-BREAK))
+                                    T)
+                             (SETF (GET XCL::EXECUTABLE-TO-BREAK 'IL:BROKEN)
+                                   XCL::ORIGINAL)
+                             (PUSH XCL::FN-TO-BREAK IL:BROKENFNS)
+                             (SETQ XCL::*UNBROKEN-FNS* (DELETE XCL::FN-TO-BREAK XCL::*UNBROKEN-FNS* 
+                                                              :TEST 'EQUAL))
+                             (LIST XCL::FN-TO-BREAK))
+                       (IF XCL::NO-IN-FN
+                           (ERROR "~S can't be selectively broken :IN ~S" XCL::FN-TO-BREAK XCL::IN-FN
+                                  )
+                           (LET* ((XCL::EXECUTABLE-TO-BREAK-IN (XCL::NAME-OF-EXECUTABLE XCL::IN-FN))
+                                  (XCL::MIDDLE-MAN (CONSTRUCT-MIDDLE-MAN XCL::EXECUTABLE-TO-BREAK 
+                                                          XCL::EXECUTABLE-TO-BREAK-IN)))
+                                 (IF (NOT (HAS-CALLS XCL::EXECUTABLE-TO-BREAK-IN 
+                                                 XCL::EXECUTABLE-TO-BREAK))
+                                     (IF (MACRO-FUNCTION XCL::FN-TO-BREAK)
+                                         (ERROR "Macros can't be selectively traced: sorry")
+                                         (ERROR "~S is not called from ~S." XCL::FN-TO-BREAK 
+                                                XCL::IN-FN)))
+                                 (XCL:UNADVISE-FUNCTION XCL::FN-TO-BREAK :IN XCL::IN-FN :NO-ERROR T)
+                                 (COMPILE XCL::MIDDLE-MAN (CREATE-BROKEN-DEFINITION
+                                                           XCL::EXECUTABLE-TO-BREAK XCL::MIDDLE-MAN 
+                                                           XCL::EXECUTABLE-TO-BREAK XCL::WHEN-EXPR
+                                                           `(,XCL::EXECUTABLE-TO-BREAK :IN
+                                                                   ,XCL::EXECUTABLE-TO-BREAK-IN)))
+                                 (CHANGE-CALLS XCL::EXECUTABLE-TO-BREAK XCL::MIDDLE-MAN 
+                                        XCL::EXECUTABLE-TO-BREAK-IN 'UNBREAK-FROM-RESTORE-CALLS)
+                                 (PUSH (LIST XCL::FN-TO-BREAK XCL::IN-FN XCL::MIDDLE-MAN)
+                                       IL:BROKENFNS)
+                                 (SETQ XCL::*UNBROKEN-FNS* (DELETE `(,XCL::FN-TO-BREAK :IN
+                                                                           ,XCL::IN-FN)
+                                                                  XCL::*UNBROKEN-FNS* :TEST
+                                                                  'EQUAL))
+                                 (LIST `(,XCL::FN-TO-BREAK :IN ,XCL::IN-FN)))))))))))
+
+(DEFUN XCL:UNBREAK-FUNCTION (XCL::BROKEN-FN &KEY ((:IN XCL::IN-FN))
+                                       XCL::NO-ERROR)
+   (MULTIPLE-VALUE-BIND
+    (XCL::EXECUTABLE-TO-UNBREAK XCL::NO-IN-FN)
+    (XCL::NAME-OF-EXECUTABLE XCL::BROKEN-FN)
+    (COND
+       ((AND (CONSP XCL::BROKEN-FN)
+             (NOT XCL::EXECUTABLE-TO-UNBREAK))
+        (IL:FOR XCL::FN IL:IN XCL::BROKEN-FN IL:JOIN (XCL:UNBREAK-FUNCTION XCL::FN 
+                                                                        :IN XCL::IN-FN)))
+       ((AND (CONSP XCL::IN-FN)
+             (NOT (XCL::NAME-OF-EXECUTABLE XCL::IN-FN)))
+        (IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:UNBREAK-FUNCTION XCL::BROKEN-FN
+                                                                    :IN XCL::FN)))
+       (T (IF (NULL XCL::IN-FN)
+              (LET ((XCL::ORIGINAL (GET XCL::EXECUTABLE-TO-UNBREAK 'IL:BROKEN)))
+                   (COND
+                      ((NULL XCL::ORIGINAL)
+                       (UNLESS XCL::NO-ERROR (FORMAT *ERROR-OUTPUT* "~S is not broken.~%" 
+                                                    XCL::BROKEN-FN))
+                       NIL)
+                      (T (IL:PUTD XCL::EXECUTABLE-TO-UNBREAK (IL:GETD XCL::ORIGINAL)
+                                T)
+                         (REMPROP XCL::EXECUTABLE-TO-UNBREAK 'IL:BROKEN)
+                         (SETQ IL:BROKENFNS (DELETE XCL::BROKEN-FN IL:BROKENFNS :TEST 'EQUAL))
+                         (SETQ XCL::*TRACED-FNS* (DELETE XCL::BROKEN-FN XCL::*TRACED-FNS* :TEST
+                                                        'EQUAL))
+                         (PUSH XCL::BROKEN-FN XCL::*UNBROKEN-FNS*)
+                         (LIST XCL::BROKEN-FN))))
+              (IF XCL::NO-IN-FN
+                  (ERROR "~s can't be selectively unbroken :IN ~s" XCL::BROKEN-FN XCL::IN-FN)
+                  (LET* ((XCL::EXECUTABLE-TO-UNBREAK-IN (XCL::NAME-OF-EXECUTABLE XCL::IN-FN))
+                         (XCL::ENTRY (FIND-IF #'(LAMBDA (XCL::ENTRY)
+                                                       (AND (CONSP XCL::ENTRY)
+                                                            (EQUAL (FIRST XCL::ENTRY)
+                                                                   XCL::BROKEN-FN)
+                                                            (EQUAL (SECOND XCL::ENTRY)
+                                                                   XCL::IN-FN)))
+                                            IL:BROKENFNS))
+                         (XCL::MIDDLE-MAN (THIRD XCL::ENTRY)))
+                        (COND
+                           ((NULL XCL::ENTRY)
+                            (UNLESS XCL::NO-ERROR (FORMAT *ERROR-OUTPUT* "~S :IN ~S is not broken.~%"
+                                                         XCL::BROKEN-FN XCL::IN-FN))
+                            NIL)
+                           (T (CHANGE-CALLS XCL::MIDDLE-MAN XCL::EXECUTABLE-TO-UNBREAK 
+                                     XCL::EXECUTABLE-TO-UNBREAK-IN)
+                              (FINISH-UNBREAKING XCL::EXECUTABLE-TO-UNBREAK 
+                                     XCL::EXECUTABLE-TO-UNBREAK-IN XCL::MIDDLE-MAN XCL::ENTRY)
+                              (LIST `(,XCL::BROKEN-FN :IN ,XCL::IN-FN)))))))))))
+
+(DEFUN XCL:REBREAK-FUNCTION (XCL::FN-TO-REBREAK &KEY ((:IN XCL::IN-FN)))
+   (COND
+      ((CONSP XCL::FN-TO-REBREAK)
+       (IL:FOR XCL::FN IL:IN XCL::FN-TO-REBREAK IL:JOIN (XCL:REBREAK-FUNCTION XCL::FN
+                                                                           :IN XCL::IN-FN)))
+      ((CONSP XCL::IN-FN)
+       (IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:REBREAK-FUNCTION 
+                                                                   XCL::FN-TO-REBREAK :IN XCL::FN)))
+      (T (LET* ((XCL::NAME (IF (NULL XCL::IN-FN)
+                               XCL::FN-TO-REBREAK
+                               `(,XCL::FN-TO-REBREAK :IN ,XCL::IN-FN)))
+                (XCL::INFO (GETHASH XCL::NAME XCL::*BREAK-HASH-TABLE*)))
+               (COND
+                  ((NULL XCL::INFO)
+                   (FORMAT *ERROR-OUTPUT* "~S has never been broken.~%" XCL::NAME)
+                   NIL)
+                  (T (APPLY 'XCL:BREAK-FUNCTION XCL::INFO)))))))
+
+(DEFUN CREATE-BROKEN-DEFINITION (WRAPPED-FN-NAME BROKEN-FN-NAME FN-TO-CALL WHEN-EXPR 
+                                           BREAKPOINT-NAME)
+
+(IL:* IL:|;;;| 
+"WRAPPED-FN-NAME must be the symbol naming the function that will break when it is called.")
+
+(IL:* IL:|;;;| "BROKEN-FN-NAME is the symbol in whose function cell our lambda-form will be put.")
+
+(IL:* IL:|;;;| "FN-TO-CALL is the function-object to be FUNCALL'ed when we want to call the unbroken version of the wrapped function.")
+
+(IL:* IL:|;;;| "BREAKPOINT-NAME is the value the debugger will use for BRKFN.")
+
+(IL:* IL:|;;;| 
+"We return a lambda-form suitable for being called in order to (possibly) activate the breakpoint.")
+
+   (MULTIPLE-VALUE-BIND
+    (LAMBDA-CAR ARG-LIST CALLING-FORM)
+    (FUNCTION-WRAPPER-INFO WRAPPED-FN-NAME FN-TO-CALL)
+    `(,LAMBDA-CAR ,(IF (EQ LAMBDA-CAR 'LAMBDA)
+                       '(&REST XCL:ARGLIST)
+                       ARG-LIST)
+            ,@(AND ARG-LIST (MEMBER LAMBDA-CAR '(IL:LAMBDA IL:NLAMBDA))
+                   `((DECLARE (SPECIAL ,@(IF (SYMBOLP ARG-LIST)
+                                                 (LIST ARG-LIST)
+                                                 ARG-LIST)))))
+            (IL:\\CALLME '(:BROKEN ,BREAKPOINT-NAME))
+            (IF ,WHEN-EXPR
+                (LET (($POS$ (IL:STKNTH -1)))
+                     (UNWIND-PROTECT
+                         (XCL:DEBUGGER :FORM `(FUNCALL ',#'(LAMBDA NIL ,CALLING-FORM))
+                                :ENVIRONMENT NIL :STACK-POSITION $POS$ :CONDITION
+                                ',(XCL:MAKE-CONDITION 'BREAKPOINT :FUNCTION BREAKPOINT-NAME))
+                         (IL:RELSTK $POS$)))
+                ,CALLING-FORM))))
+
+(DEFUN UNBREAK-FROM-RESTORE-CALLS (FROM TO FN)
+
+(IL:* IL:|;;;| "Somebody has restored all of the changed calls in FN, including one we made, changing calls to FROM into calls to TO.  This came about from breaking (FROM :IN FN), where TO was the middle-man.  Undo that breaking.")
+
+   (LET ((ENTRY (FIND-IF #'(LAMBDA (ENTRY)
+                                  (AND (CONSP ENTRY)
+                                       (EQ (FIRST ENTRY)
+                                           FROM)
+                                       (EQ (SECOND ENTRY)
+                                           FN)))
+                       IL:BROKENFNS)))
+        (ASSERT (EQ TO (THIRD ENTRY))
+               NIL "BUG: Inconsistency in SI::UNBREAK-FROM-RESTORE-CALLS")
+        (FINISH-UNBREAKING FROM FN TO ENTRY)
+        (FORMAT *TERMINAL-IO* "(~S :IN ~S) unbroken.~%" FROM FN)))
+
+(DEFUN FINISH-UNBREAKING (BROKEN-FN IN-FN MIDDLE-MAN ENTRY)
+   (SETQ IL:BROKENFNS (DELETE ENTRY IL:BROKENFNS))
+   (SETQ XCL::*TRACED-FNS* (DELETE ENTRY XCL::*TRACED-FNS*))
+   (PUSH `(,BROKEN-FN :IN ,IN-FN)
+         XCL::*UNBROKEN-FNS*))
+
+(DEFVAR IL:BROKENFNS NIL)
+
+(DEFVAR XCL::*BREAK-HASH-TABLE* (MAKE-HASH-TABLE :TEST 'EQUAL))
+
+(DEFVAR XCL::*UNBROKEN-FNS* NIL)
+
+(IL:PUTPROPS IL:BROKEN IL:PROPTYPE IGNORE)
+
+
+
+(IL:* IL:|;;| "The old Interlisp interface to breaking.")
+
+(IL:DEFINEQ
+
+(IL:BREAK
+  (IL:NLAMBDA IL:X                                           (IL:* IL:\; 
+                                                           "Edited 13-Apr-87 13:51 by Pavel")
+    (IL:FOR IL:X IL:IN (IL:NLAMBDA.ARGS IL:X)
+       IL:JOIN (IL:IF (OR (IL:LITATOM IL:X)
+                                  (IL:STRING.EQUAL (CADR IL:X)
+                                         "IN"))
+                       IL:THEN (IL:BREAK0 IL:X T)
+                     IL:ELSE (IL:APPLY 'IL:BREAK0 IL:X)))))
+
+(IL:BREAK0
+  (IL:LAMBDA (IL:FN IL:WHEN IL:COMS IL:BRKFN)                (IL:* IL:\; 
+                                                           "Edited 18-Apr-87 18:56 by Pavel")
+    (WHEN IL:COMS (CERROR "Ignore COMS" "Break 'commands' ~S no longer supported." IL:COMS))
+    (WHEN (AND IL:BRKFN (IL:NEQ IL:BRKFN 'IL:BREAK1))
+          (CERROR "Ignore BRKFN" "Unexpected BRKFN passed to BREAK0: ~S" IL:BRKFN))
+    (WHEN (NULL IL:WHEN)
+          (IL:SETQ IL:WHEN T))
+    (COND
+       ((IL:LISTP IL:FN)
+        (COND
+           ((IL:STRING.EQUAL (SECOND IL:FN)
+                   "IN")
+            (XCL:BREAK-FUNCTION (FIRST IL:FN)
+                   :IN
+                   (THIRD IL:FN)
+                   :WHEN IL:WHEN))
+           (T (IL:FOR IL:X IL:IN IL:FN IL:JOIN (IL:BREAK0 IL:X IL:WHEN)))))
+       (T (XCL:BREAK-FUNCTION IL:FN :WHEN IL:WHEN)))))
+
+(IL:REBREAK
+  (IL:NLAMBDA IL:FNS                                         (IL:* IL:\; 
+                                                           "Edited  3-Apr-87 12:07 by Pavel")
+    (IL:SETQ IL:FNS (IL:NLAMBDA.ARGS IL:FNS))
+    (FLET ((IL:REBREAK-FN (IL:FN)
+                  (IL:IF (IL:LISTP IL:FN)
+                      IL:THEN (XCL:REBREAK-FUNCTION (FIRST IL:FN)
+                                         :IN
+                                         (THIRD IL:FN))
+                    IL:ELSE (XCL:REBREAK-FUNCTION IL:FN))))
+          (COND
+             ((NULL IL:FNS)
+              (IL:FOR IL:FN IL:IN XCL::*UNBROKEN-FNS* IL:JOIN (IL:REBREAK-FN IL:FN)))
+             ((IL:EQUAL IL:FNS '(T))
+              (AND (NOT (NULL XCL::*UNBROKEN-FNS*))
+                   (IL:REBREAK-FN (CAR XCL::*UNBROKEN-FNS*))))
+             (T (IL:FOR IL:FN IL:IN IL:FNS IL:JOIN (IL:REBREAK-FN IL:FN)))))))
+
+(XCL:UNBREAK
+  (IL:NLAMBDA XCL::FNS                                       (IL:* IL:\; 
+                                                           "Edited  2-Apr-87 16:39 by Pavel")
+    (SETQ XCL::FNS (IL:NLAMBDA.ARGS XCL::FNS))
+    (FLET ((XCL::UNBREAK-ENTRY (XCL::ENTRY)
+                  (IF (CONSP XCL::ENTRY)
+                      (XCL:UNBREAK-FUNCTION (FIRST XCL::ENTRY)
+                             :IN
+                             (SECOND XCL::ENTRY))
+                      (XCL:UNBREAK-FUNCTION XCL::ENTRY))))
+          (COND
+             ((NULL XCL::FNS)
+              (IL:FOR XCL::ENTRY IL:IN (REVERSE IL:BROKENFNS) IL:JOIN (XCL::UNBREAK-ENTRY
+                                                                                   XCL::ENTRY)))
+             ((EQUAL XCL::FNS '(T))
+              (WHEN IL:BROKENFNS
+                  (XCL::UNBREAK-ENTRY (CAR IL:BROKENFNS))))
+             (T (IL:FOR XCL::FN IL:IN XCL::FNS IL:JOIN (IF (CONSP XCL::FN)
+                                                                       (XCL:UNBREAK-FUNCTION
+                                                                        (FIRST XCL::FN)
+                                                                        :IN
+                                                                        (THIRD XCL::FN))
+                                                                       (XCL:UNBREAK-FUNCTION
+                                                                        XCL::FN))))))))
+
+(IL:UNBREAK0
+  (IL:LAMBDA (IL:FN)                                         (IL:* IL:\; 
+                                                           "Edited  1-Apr-87 22:12 by Pavel")
+    (IL:IF (IL:LISTP IL:FN)
+        IL:THEN (XCL:UNBREAK-FUNCTION (CAR IL:FN)
+                           :IN
+                           (CADDR IL:FN))
+      IL:ELSE (XCL:UNBREAK-FUNCTION IL:FN))))
+)
+(IL:DEFINEQ
+
+(IL:BREAK1
+  (IL:NLAMBDA (IL:BRKEXP IL:BRKWHEN IL:BRKFN IL:BRKCOMS IL:BRKTYPE XCL:CONDITION)
+                                                             (IL:* IL:\; 
+                                                           "Edited 24-Mar-87 16:07 by amd")
+    (IL:|if| (EVAL IL:BRKWHEN)
+        IL:|then| 
+
+              (IL:* IL:|;;| 
+     "should probably default CONDITION  depending on BRKTYPE to interrupt, breakpoint error, etc.")
+
+              (WHEN IL:BRKCOMS (IL:PRINTOUT T "BRKCOMS no longer supported:" IL:BRKCOMS T))
+              (LET ((IL:POS (IL:STKNTH 0 IL:BRKFN)))
+                   (UNWIND-PROTECT
+                       (XCL:DEBUGGER :FORM IL:BRKEXP :ENVIRONMENT NIL :STACK-POSITION IL:POS 
+                              :CONDITION (OR XCL:CONDITION (XCL:MAKE-CONDITION 'BREAKPOINT :FUNCTION
+                                                                  IL:BRKFN)))
+                       (IL:RELSTK IL:POS)))
+      IL:|else| (EVAL IL:BRKEXP))))
+)
+
+(XCL:DEFINE-SPECIAL-FORM IL:BREAK1 (&OPTIONAL IL:EXP IL:WHEN IL:FN IL:COMS TYPE XCL:CONDITION 
+                                              &ENVIRONMENT IL:ENV)
+   (IL:IF (EVAL IL:WHEN IL:ENV)
+       IL:THEN (WHEN IL:COMS (IL:PRINTOUT T "BRKCOMS no longer supported:" IL:COMS T))
+             (LET ((IL:POS (IL:STKNTH 0 IL:FN)))
+                  (UNWIND-PROTECT
+                      (XCL:DEBUGGER :FORM IL:EXP :ENVIRONMENT IL:ENV :STACK-POSITION IL:POS 
+                             :CONDITION (OR XCL:CONDITION (XCL:MAKE-CONDITION 'BREAKPOINT :FUNCTION 
+                                                                 IL:FN)))
+                      (IL:RELSTK IL:POS)))
+     IL:ELSE (EVAL IL:EXP IL:ENV)))
+
+(XCL:DEFOPTIMIZER IL:BREAK1 (&OPTIONAL IL:EXP IL:WHEN IL:FN IL:COMS TYPE XCL:CONDITION)
+                                (WHEN IL:COMS (IL:PRINTOUT T "BRKCOMS no longer supported:" IL:COMS T
+                                                     ))
+                                `(FLET
+                                  (($BRKEXP$ NIL ,IL:EXP))
+                                  (IL:IF ,IL:WHEN
+                                      IL:THEN
+                                      (LET
+                                       (($POS$ (IL:STKNTH 0 ',IL:FN)))
+                                       (UNWIND-PROTECT
+                                           (XCL:DEBUGGER
+                                            :FORM
+                                            `(FUNCALL ',#'$BRKEXP$)
+                                            :ENVIRONMENT NIL :STACK-POSITION $POS$ :CONDITION
+                                            ,(OR XCL:CONDITION
+                                                 `(IL:LOADTIMECONSTANT (XCL:MAKE-CONDITION
+                                                                        'BREAKPOINT :FUNCTION
+                                                                        ',IL:FN))))
+                                           (IL:RELSTK $POS$)))
+                                    IL:ELSE ($BRKEXP$))))
+
+
+
+(IL:* IL:|;;| "Arrange for the proper compiler and package")
+
+
+(IL:PUTPROPS IL:BREAK-AND-TRACE IL:FILETYPE :COMPILE-FILE)
+
+(IL:PUTPROPS IL:BREAK-AND-TRACE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "SYSTEM"))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA )
+
+(IL:ADDTOVAR IL:NLAML IL:BREAK1)
+
+(IL:ADDTOVAR IL:LAMA )
+)
+(IL:PRETTYCOMPRINT IL:BREAK-AND-TRACECOMS)
+
+(IL:RPAQQ IL:BREAK-AND-TRACECOMS
+          (
+
+(IL:* IL:|;;;| "Support for tracing.")
+
+           (IL:VARIABLES XCL:*TRACE-DEPTH* XCL::*TRACED-FNS* IL:TRACEREGION)
+           (IL:FUNCTIONS XCL:CREATE-TRACE-WINDOW)
+           (IL:FUNCTIONS CREATE-TRACED-DEFINITION CONSTRUCT-ENTRY-PRINTING-CODE 
+                  PRINT-TRACE-ENTRY-INFO PRINT-TRACE-EXIT-INFO PRINT-TRACED-ARGUMENT 
+                  PRINT-TRACED-CL-ARGLIST)
+           (IL:VARIABLES XCL:*TRACE-LEVEL* XCL:*TRACE-LENGTH* XCL:*TRACE-VERBOSE* *TRACE-OUTPUT*)
+           (IL:FNS TRACE UNTRACE)
+           (IL:FUNCTIONS XCL:TRACE-FUNCTION)
+           
+
+(IL:* IL:|;;;| "Support for breaking.")
+
+           (IL:FUNCTIONS XCL:BREAK-FUNCTION XCL:UNBREAK-FUNCTION XCL:REBREAK-FUNCTION 
+                  CREATE-BROKEN-DEFINITION UNBREAK-FROM-RESTORE-CALLS FINISH-UNBREAKING)
+           (IL:VARIABLES IL:BROKENFNS XCL::*BREAK-HASH-TABLE* XCL::*UNBROKEN-FNS*)
+           (IL:PROP IL:PROPTYPE IL:BROKEN)
+           
+           (IL:* IL:|;;| "The old Interlisp interface to breaking.")
+
+           (IL:FNS IL:BREAK IL:BREAK0 IL:REBREAK XCL:UNBREAK IL:UNBREAK0)
+           (IL:FNS IL:BREAK1)
+           (IL:SPECIAL-FORMS IL:BREAK1)
+           (XCL:OPTIMIZERS IL:BREAK1)
+           
+           (IL:* IL:|;;| "Arrange for the proper compiler and package")
+
+           (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                  IL:BREAK-AND-TRACE)
+           (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS
+                  (IL:ADDVARS (IL:NLAMA XCL:UNBREAK IL:REBREAK IL:BREAK UNTRACE TRACE)
+                         (IL:NLAML IL:BREAK1)
+                         (IL:LAMA)))))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA XCL:UNBREAK IL:REBREAK IL:BREAK UNTRACE TRACE)
+
+(IL:ADDTOVAR IL:NLAML IL:BREAK1)
+
+(IL:ADDTOVAR IL:LAMA )
+)
+(IL:PUTPROPS IL:BREAK-AND-TRACE IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 1991 1992 
+1993))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL (16480 19023 (TRACE 16493 . 17332) (UNTRACE 17334 . 19021)) (38743 43068 (IL:BREAK 
+38756 . 39284) (IL:BREAK0 39286 . 40173) (IL:REBREAK 40175 . 41120) (XCL:UNBREAK 41122 . 42655) (
+IL:UNBREAK0 42657 . 43066)) (43069 44089 (IL:BREAK1 43082 . 44087)))))
+IL:STOP
diff --git a/CLTL2/BREAK-AND-TRACE.DFASL b/CLTL2/BREAK-AND-TRACE.DFASL
new file mode 100644
index 00000000..63f245ec
Binary files /dev/null and b/CLTL2/BREAK-AND-TRACE.DFASL differ
diff --git a/CLTL2/BYTECOMPILER b/CLTL2/BYTECOMPILER
new file mode 100644
index 00000000..f568fadd
--- /dev/null
+++ b/CLTL2/BYTECOMPILER
@@ -0,0 +1,5679 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+(FILECREATED "13-Oct-93 18:39:09" "{Pele:mv:envos}<LispCore>Sources>CLTL2>BYTECOMPILER.;2" 272754 
+
+      previous date%: " 3-Sep-91 17:29:56" "{Pele:mv:envos}<LispCore>Sources>CLTL2>BYTECOMPILER.;1"
+)
+
+
+(* ; "
+Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1900, 1988, 1989, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT BYTECOMPILERCOMS)
+
+(RPAQQ BYTECOMPILERCOMS
+       [
+
+(* ;;; "THE BYTE LISP COMPILER")
+
+        (COMS (INITVARS (*BYTECOMPILER-IS-EXPANDING* NIL))
+              (FNS BYTEBLOCKCOMPILE2 BYTECOMPILE2 COMP.ATTEMPT.COMPILE COMP.RETFROM.POINT 
+                   COMP.TRANSFORM COMPERROR COMPPRINT COMPERRM)
+              (FNS COMP.TOPLEVEL.COMPILE COMP.BINDLIST COMP.CHECK.VAR COMP.BIND.VARS COMP.UNBIND.VARS
+                   )
+              (FNS COMP.VALN COMP.PROGN COMP.PROGLST COMP.EXP1 COMP.EXPR COMP.TRYUSERFN COMP.USERFN 
+                   COMP.CONST COMP.CALL COMP.VAR COMP.VAL1 COMP.PROG1 COMP.EFFECT COMP.VAL COMP.MACRO
+                   )
+              (FNS COMP.VARTYPE COMP.LOOKUPVAR COMP.LOOKUPCONST)
+              (FNS COMP.ST COMP.STFN COMP.STCONST COMP.STVAR COMP.STPOP COMP.DELFN COMP.STRETURN 
+                   COMP.STTAG COMP.STJUMP COMP.STSETQ COMP.STCOPY COMP.DELPUSH COMP.DELPOP 
+                   COMP.STBIND COMP.STUNBIND)
+              (VARS *NO-SIDE-EFFECT-FNS*)
+              (GLOBALVARS *NO-SIDE-EFFECT-FNS*)
+              (FNS COMP.ARGTYPE COMP.CLEANEXPP COMP.CLEANFNP COMP.CLEANFNOP COMP.GLOBALVARP 
+                   COMP.LINKCALLP COMP.ANONP COMP.NOSIDEEFFECTP)
+              (FNS COMP.CPI COMP.CPI1 COMP.PICOUNT)
+              (PROP BYTEMACRO EVQ)
+              (FNS COMP.EVQ)
+              (PROP BYTEMACRO AND OR)
+              (FNS COMP.BOOL)
+              (FNS COMP.APPLYFNP)
+              (PROP BYTEMACRO AC)
+              (FNS COMP.AC COMP.PUNT)
+              (PROP BYTEMACRO FUNCTION)
+              (FNS COMP.FUNCTION COMP.LAM1 COMP.GENFN)
+              (INITVARS (COMP.GENFN.NUM 0))
+              (GLOBALVARS COMP.GENFN.NUM COMP.UNBOXED.TAG)
+              (PROP BYTEMACRO COND SELECTQ)
+              (FNS COMP.COND COMP.IF COMP.SELECTQ)
+              (PROP BYTEMACRO PROGN PROG1)
+              (PROP BYTEMACRO QUOTE *)
+              (FNS COMP.QUOTE COMP.COMMENT)
+              (PROP BYTEMACRO DECLARE)
+              (FNS COMP.DECLARE COMP.DECLARE1)
+              (PROP (BYTEMACRO CROPS)
+                    * MCROPS)
+              (FNS COMP.CARCDR COMP.STCROP)
+              (PROP BYTEMACRO NOT NULL)
+              (FNS COMP.NOT)
+              (PROP BYTEMACRO SETQ SETN)
+              (FNS COMP.SETQ COMP.SETN)
+              (FNS COMP.LAMBDA)
+              (PROP DMACRO LISP:TAGBODY)
+              (PROP BYTEMACRO PROG GO RETURN LISP:RETURN-FROM)
+              (FNS COMP.PROG COMP.GO COMP.RETURN COMP.BLOCK COMP.RETURN-FROM COMP.TAGBODY)
+              (PROP BYTEMACRO LISP:LABELS)
+              (FNS COMP.LABELS)
+              (VARS COMP.UNBOXED.TAG NUMBERFNS (GLOBALVARFLG T)
+                    (NEWOPTFLG)
+                    (COMPVERSION (DATE)))
+              (OPTIMIZERS IMINUS)
+              (MACROS IPLUS ITIMES LOGOR LOGXOR LOGAND IDIFFERENCE IQUOTIENT IREMAINDER LSH LLSH RSH
+                     LRSH FIX PLUS DIFFERENCE TIMES QUOTIENT FPLUS FDIFFERENCE FTIMES FQUOTIENT FABS
+                     FGREATERP FLESSP FREMAINDER)
+              (FNS COMP.NUMERIC COMP.NUMBERCALL COMP.FIX COMP.STFIX COMP.DELFIX)
+              (PROP BYTEMACRO EQ EQUAL EQP)
+              (FNS COMP.EQ)
+              (PROP BYTEMACRO .TEST.)
+              (FNS COMP.NUMBERTEST)
+              (PROP BYTEMACRO * MAPFNS)
+              (PROP BYTEMACRO .DOCOLLECT. .DOJOIN.)
+              (FNS COMP.MAP)
+              (PROP BYTEMACRO LISPXWATCH)
+              (OPTIMIZERS BLKAPPLY BLKAPPLY*)
+              (OPTIMIZERS ADD1VAR KWOTE FRPLNODE RPLNODE LISTGET1 FRPLNODE2)
+              (PROP BYTEMACRO SUB1VAR)
+              (OPTIMIZERS EQMEMB MKLIST)
+              (COMS 
+                    (* ;; "Pass 1 listing")
+
+                    (FNS COMP.MLLIST COMP.MLL COMP.MLLVAR COMP.MLLFN)
+                    (VARS COPS)
+                    (IFPROP MLSYM * (PROGN COPS)))
+              (COMS 
+                    (* ;; "ARJ --- JUMP LENGTH RESOLVER")
+
+                    (FNS OPT.RESOLVEJUMPS OPT.JLENPASS OPT.JFIXPASS OPT.JSIZE))
+              (COMS 
+                    (* ;; "Utilities used by all files")
+
+                    (FNS OPT.CALLP OPT.JUMPCHECK OPT.DREV OPT.CHLEV OPT.CHECKTAG OPT.NOTJUMP 
+                         OPT.INITHASH OPT.COMPINIT))
+              (P (MOVD? 'NILL 'REFRAME)
+                 (AND (GETD 'OPT.COMPINIT)
+                      (OPT.COMPINIT)))
+              (PROP BYTEMACRO LOADTIMECONSTANT)
+              (PROP BYTEMACRO FRPTQ)
+              (FNS OPT.CFRPTQ)
+              (DECLARE%: EVAL@COMPILE DONTCOPY
+                     (SPECVARS AC ALAMS1 ALLVARS ARGS ARGVARS BLKDEFS BLKFLG CODE COMFN COMFNS 
+                            COMTYPE CONSTS EMFLAG EXP FRAME FREELST FREEVARS LAPFLG LBCNT LEVEL 
+                            LOCALVARS LOCALVARS LSTFIL MACEXP NLAMS1 PIFN COMPILE.CONTEXT PROGCONTEXT
+                            RETURNLABEL SPECVARS SPECVARS SUBFNFREEVARS TAGS TOPFN TOPFRAME TOPLAB 
+                            VARS INTERNALBLKFNS)
+                     (SPECVARS PLVLFILEFLG))
+              (PROP BYTEMACRO IMAX2 IMIN2)
+              (PROP BOX FLOAT)
+              (FNS COMP.AREF COMP.ASET COMP.BOX COMP.LOOKFORDECLARE COMP.DECLARETYPE COMP.FLOATBOX 
+                   COMP.FLOATUNBOX COMP.PREDP COMP.UBFLOAT2 COMP.UNBOX))
+        (ADDVARS (COMPILETYPELST))
+        (COMS                                                (* ; "POST OPTIMIZATION")
+              (FNS OPT.POSTOPT OPT.SETUPOPT OPT.SCANOPT OPT.XVARSCAN OPT.XVARSCAN1 OPT.JUMPOPT 
+                   OPT.JUMPTHRU OPT.LBMERGE OPT.PRDEL OPT.UBDEL OPT.LBDEL OPT.LABELNTHPR OPT.JUMPREV
+                   OPT.COMMONBACK OPT.DELTAGREF OPT.FINDEND OPT.RETOPT OPT.RETFIND OPT.RETPOP 
+                   OPT.RETOPT1 OPT.RETTEST OPT.RETMERGE OPT.CODELEV OPT.CODEFRAME OPT.DEFREFS 
+                   OPT.SETDEFREFS)
+              (FNS OPT.FRAMEOPT OPT.FRAMEMERGE OPT.NONILVAR OPT.MERGEFRAMEP OPT.FRAMELOCAL 
+                   OPT.CLEANFRAME OPT.FRAMEDEL OPT.FRAMEVAR OPT.DELETEFRAMECHECK OPT.ONLYMEMB)
+              (VARS MERGEFRAMETYPES (OPTIMIZATIONSOFF))
+              (FNS OPT.SKIPPUSH OPT.DELCODE OPT.PRATTACH OPT.JUMPCOPYTEST OPT.EQOP OPT.EQVALUE 
+                   OPT.DELCOPYFN)
+              (FNS OPT.DEADSETQP OPT.DS1)
+              (INITVARS (*BC-MACRO-ENVIRONMENT* (COMPILER::MAKE-ENV))
+                     (*BYTECOMPILER-OPTIMIZE-MACROLET* T))
+              (FUNCTIONS LISP:MACROLET)
+              (DECLARE%: EVAL@COMPILE DONTCOPY (SPECVARS *BYTECOMPILER-IS-EXPANDING* 
+                                                      *BC-MACRO-ENVIRONMENT*)
+                     (SPECVARS CODE LEVEL)
+                     (SPECVARS LISP:LABELS PASS ANY CODE FRAME FRAMES)
+                     (GLOBALVARS MERGEFRAMEMAX MERGEFRAMEFLG MERGEFRAMETYPES 
+                            *BYTECOMPILER-OPTIMIZE-MACROLET*)
+                     (SPECVARS VARS ANY FRAME)
+                     (SPECVARS ICNT TAG)
+                     (SPECVARS FRAME LEVEL ANY)
+                     (SPECVARS FRAME LEVEL ANY)
+                     (SPECVARS TAGS ANY)))
+        (COMS                                                (* ; "CONSISTENCY CHECKS")
+              (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS OPT.CCHECK)
+                     (VARS (COMPILECOMPILERCHECKS NIL)))
+              (FNS OPT.COMPILERERROR OPT.OPTCHECK OPT.CCHECK))
+        (GLOBALVARS ALAMS BYTE.EXT BYTEASSEMFN BYTECOMPFLG COMPILERMACROPROPS CIA CLEANFNLIST 
+               COMP.SCRATCH COMPILETYPELST COMPILEUSERFN COMPSTATLST COMPSTATS CONDITIONALS CONST.FNS
+               CONSTOPS DONOTHING FILERDTBL FNA FORSHALLOW FRA HEADERBYTES HOKEYDEFPROP LAMBDANOBIND
+               LAMS LBA LEVELARRAY LINKEDFNS LOADTIMECONSTANT MAXBNILS MAXBVALS MCONSTOPS 
+               MERGEFRAMEFLG MERGEFRAMEMAX MERGEFRAMETYPES MOPARRAY MOPCODES NODARR NOSTATSFLG 
+               NUMBERFNS OPCOPY OPNIL OPPOP OPRETURN PRA SELECTQFMEMB SELECTVARTYPES STATAR STATMAX 
+               STATN SYSSPECVARS UNIQUE#ARRAY VCA VCONDITIONALS VREFFRA COUTFILE XVARFLG 
+               MERGEFRAMEFLG OPTIMIZATIONSOFF NOFREEVARSFNS EQCONSTFN NEWOPTFLG)
+        [P (LISP:PROCLAIM '(LISP:SPECIAL COMPVARMACROHASH]
+        (DECLARE%: DONTCOPY                                  (* ; "for compiling compiler")
+               EVAL@COMPILE
+               (RECORDS CODELST)
+               (PROP MACRO OASSOC)
+               (RECORDS OP JUMP TAG VAR)
+               (RECORDS FRAME COMINFO COMP JD BLOCKSTATUS))
+        (MACROS THETYPE)
+        (PROP FILETYPE BYTECOMPILER)
+        (PROP MAKEFILE-ENVIRONMENT BYTECOMPILER)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML OPT.INITHASH)
+                                                                             (LAMA])
+
+
+
+(* ;;; "THE BYTE LISP COMPILER")
+
+
+(RPAQ? *BYTECOMPILER-IS-EXPANDING* NIL)
+(DEFINEQ
+
+(BYTEBLOCKCOMPILE2
+  [LAMBDA (BLKNAME BLKDEFS ENTRIES)                          (* Pavel "15-Nov-86 16:11")
+    (COND
+       [(EQ BYTECOMPFLG 'NOBLOCK)                            (* ; "use PDP-10 compiler for blocks")
+        (RESETVARS (BYTECOMPFLG)
+                   (RETURN (BLOCKCOMPILE2 BLKNAME BLKDEFS ENTRIES]
+       (T (PROG [(BLKFLG T)
+                 (INTERNALBLKFNS (AND (NEQ BYTECOMPFLG 'RETRY)
+                                      (for X in BLKDEFS
+                                         when (NOT (OR (FMEMB (CAR X)
+                                                                  ENTRIES)
+                                                           (EQ (CAR X)
+                                                               BLKNAME)
+                                                           (FMEMB (CAR X)
+                                                                  RETFNS)
+                                                           (AND (LISTP NOLINKFNS)
+                                                                (FMEMB (CAR X)
+                                                                       NOLINKFNS))
+                                                           (FMEMB (CAR X)
+                                                                  BLKAPPLYFNS)))
+                                         collect (CONS (CAR X)
+                                                           (PACK* '\ BLKNAME '/ (CAR X]
+                                                             (* ; "this is a dummy block compiler")
+                (SETQ COMP.GENFN.NUM 0)
+                (RETURN (MAPCONC BLKDEFS (FUNCTION (LAMBDA (X)
+                                                     (PROG1 (COMP.ATTEMPT.COMPILE
+                                                             (OR (CDR (FASSOC (CAR X)
+                                                                             INTERNALBLKFNS))
+                                                                 (CAR X))
+                                                             (CADDR X)
+                                                             (CAR X))
+
+                                 (* ;; "The FRPLACA allows the function definitions to be reclaimed.  This is written to parallel BLOCKCOMPILE2 which needs the list of BLKDEFS for something.  --- rrb")
+
+                                                         [FRPLACA (CDDR X)
+                                                                (LIST (CAR (CADDR X))
+                                                                      (CADR (CADDR X])])
+
+(BYTECOMPILE2
+  [LAMBDA (FN DEF)                                           (* JonL "17-Dec-83 03:41")
+    (PROG ((BLKFLG NIL))
+          (SETQ COMP.GENFN.NUM 0)
+          (COMP.ATTEMPT.COMPILE FN DEF)
+          (RETURN FN])
+
+(COMP.ATTEMPT.COMPILE
+  [LAMBDA (TOPFN DEF RECNAME)                                (* Pavel "15-Nov-86 16:09")
+    (PROG ((EMFLAG TOPFN)
+           COMFNS FLG SUBFNFREEVARS)                         (* ; "compile attempt")
+          (SETQ FLG (COMP.RETFROM.POINT TOPFN DEF RECNAME))
+          [COND
+             ((NULL EMFLAG)
+              (LISPXPRIN1 '"-----
+" T)
+              (COND
+                 ((NEQ COUTFILE T)
+                  (LISPXPRIN1 '"-----
+" COUTFILE]
+          (COND
+             (FLG                                            (* ; "compile succeed")
+                  (RETURN COMFNS))
+             ((AND (GETD 'COMPILE2)
+                   (NEQ BYTECOMPFLG T))                      (* ; "retry with COMPILE2")
+              (LISPXPRINT (CONS TOPFN '(-- retrying with COMPILE2))
+                     T T)
+              [COND
+                 (BLKFLG (OR (EQ SPECVARS T)
+                             (EVAL (CONS 'SPECVARS LOCALFREEVARS]
+              (RETURN (COMPILE2 TOPFN DEF)))
+             (T (LISPXPRINT [LIST (CONS TOPFN '(not compiled]
+                       T T)
+                (RETURN])
+
+(COMP.RETFROM.POINT
+  [LAMBDA (COMFN DEF RECNAME)                                (* Pavel "15-Nov-86 16:06")
+    (PROG ((LBCNT 0))
+
+     (* ;; "This is the RETFROM point in case of an error while compiling COMFN or any of its generated subfunctions.")
+
+          (FETCH (COMP CLEAR) OF T)
+
+     (* ;; "CLEAR is an accessfn which clears all of the hash tables used by any HASHLINK field in the compiler;  done this way so that the program need not know which hash tables are used")
+
+          (RETURN (PROG1 (COMP.TOPLEVEL.COMPILE COMFN DEF RECNAME)
+                      (FETCH (COMP CLEAR) OF T))])
+
+(COMP.TRANSFORM
+  [LAMBDA (FORM)                                             (* ; "Edited 22-Jun-88 18:18 by TAL")
+
+(* ;;; "FORM is a form whose CAR is guaranteed to have a macro definition or optimizer.  Transform it as much as possible and then compile it appropriately.")
+
+    (* ;; "I'd like to be able to provide an environment, but I don't know how.")
+
+    (PROG ([CONTEXT (COND
+                       ((EQ COMPILE.CONTEXT 'EFFECT)
+                        (COMPILER:MAKE-CONTEXT :VALUES-USED 0))
+                       ((COMP.PREDP COMPILE.CONTEXT)
+                        (SELECTQ (fetch (JUMP OPNAME) of COMPILE.CONTEXT)
+                            ((TJUMP FJUMP) 
+                                 (COMPILER:MAKE-CONTEXT :VALUES-USED 1 :PREDICATE-P T))
+                            ((NTJUMP NFJUMP)                 (* ; 
+                             "We need the value, so make it argument context instead of predicate.")
+                                 (COMPILER:MAKE-CONTEXT :VALUES-USED 1 :PREDICATE-P NIL))
+                            (OPT.COMPILERERROR)))
+                       (T (COMPILER:MAKE-CONTEXT]
+           VAL
+           (*BC-MACRO-ENVIRONMENT* *BC-MACRO-ENVIRONMENT*)
+           (*BYTECOMPILER-IS-EXPANDING* T))                  (* ; "First, try to use an optimizer.")
+          (DECLARE (SPECVARS *BYTECOMPILER-IS-EXPANDING* *BC-MACRO-ENVIRONMENT*))
+          [LISP:MULTIPLE-VALUE-BIND (KIND EXPANDER)
+                 (COMPILER:ENV-FBOUNDP *BC-MACRO-ENVIRONMENT* (CAR FORM)
+                        :LEXICAL-ONLY T)
+                 [for OPT-FN in (AND (NOT KIND)
+                                             (COMPILER:OPTIMIZER-LIST (CAR FORM)))
+                    do (LET ((RESULT (LISP:FUNCALL OPT-FN FORM *BC-MACRO-ENVIRONMENT* CONTEXT)))
+                                (if (AND (NEQ RESULT 'IGNOREMACRO)
+                                             (NEQ RESULT 'COMPILER:PASS)
+                                             (NEQ RESULT FORM))
+                                    then                 (* ; 
+                                                    "An optimization has taken place.  Start over.")
+                                          (SETQ VAL (COMP.EXP1 RESULT))
+                                          (GO OUT]
+                 (if (EQ KIND :MACRO)
+                     then                                (* ; 
+                                                           "We've got a locally-defined macro...")
+                           (RETURN (COMP.EXP1 (LISP:FUNCALL EXPANDER FORM *BC-MACRO-ENVIRONMENT*]
+                                                             (* ; "now try interlisp macro")
+          [LET ((MACROPROP (GETMACROPROP (CAR FORM)
+                                  COMPILERMACROPROPS)))
+               (AND MACROPROP (RETURN (COMP.MACRO FORM MACROPROP]
+                                                             (* ; 
+                                           "Next, look for a DEFMACRO-produced expansion function.")
+          [LET [(EXPN-FN (GET (CAR FORM)
+                              'MACRO-FN]
+               (COND
+                  (EXPN-FN (RETURN (COMP.EXP1 (LISP:FUNCALL EXPN-FN FORM *BC-MACRO-ENVIRONMENT*]
+          [RETURN (COMP.CALL (CAR FORM)
+                         (CDR FORM)
+                         (COMP.ARGTYPE (CAR FORM]
+      OUT (RETURN VAL])
+
+(COMPERROR
+  [LAMBDA (X)                                                (* Pavel "15-Nov-86 16:10")
+
+(* ;;; 
+"Terminal-error handler: Aborts the compilation of this function after issuing the proper message.")
+
+    (AND X (COMPERRM X))
+    (RETFROM 'COMP.RETFROM.POINT NIL])
+
+(COMPPRINT
+  [LAMBDA (X)                                                (* ; "Edited 20-Jan-88 10:54 by jds")
+                                                             (* A separate function so it can be 
+                                                           broken or advised)
+    (PRIN1 X COUTFILE T])
+
+(COMPERRM
+  [LAMBDA (X FL)                                         (* jds " 1-Feb-84 15:34")
+                                                             (* Emit an error message for the 
+                                                           compiler)
+    (AND (NULL FL)
+         (SETQ FL COUTFILE))                                 (* If he specified no file, use the 
+                                                           compiler-message file.)
+    (COND
+       (EMFLAG (LISPXTAB 0 0 FL)
+              (LISPXPRIN1 '"-----In " FL)
+              (LISPXPRIN2 EMFLAG FL T)
+              (LISPXPRINT '%: FL)))
+    [COND
+       (X (LISPXPRIN1 '***** FL T)
+          (PROG ((PLVLFILEFLG T))
+                (RESETFORM (PRINTLEVEL 2 20)
+                       (LISPXPRINT X FL T]
+    (COND
+       ((NEQ FL T)                                           (* so message gets printed in both 
+                                                           places)
+                                                             (* i.e., force the message to go to 
+                                                           the terminal as well.)
+        (COMPERRM X T)))
+    (SETQ EMFLAG NIL])
+)
+(DEFINEQ
+
+(COMP.TOPLEVEL.COMPILE
+  [LAMBDA (COMFN DEF RECNAME OUTER-ALLVARS)                  (* ; "Edited 17-Jul-90 10:28 by jds")
+
+    (* ;; "This function controls the compilation of a single function.")
+
+    (PROG (ALAMS1 NLAMS1 CONSTS ALLVARS ALLDECLS ARGVARS ARGS COMTYPE CODE FREEVARS CI (LEVEL 0)
+                 FRAME PIFN TOPLAB (LOCALVARS LOCALVARS)
+                 (SPECVARS SPECVARS)
+                 (*BC-MACRO-ENVIRONMENT* (COMPILER::COPY-ENV *BC-MACRO-ENVIRONMENT*))
+                 (COMPILER::*ENVIRONMENT* (COMPILER::MAKE-ENV :PARENT T))
+                 TOPFRAME MACEXP AC FRELST (COMPILE.DUNBIND.POP.MERGE.FLG T)
+                 TEMP)
+      RETRY
+          [OR [AND (LISTP DEF)
+                   (LISTP (CDR DEF))
+                   (SETQ COMTYPE (COND
+                                    [(OR (LISTP (SETQ ARGS (CADR DEF)))
+                                         (NULL ARGS))
+                                     (SELECTQ (CAR DEF)
+                                         (NLAMBDA 1)
+                                         ([LAMBDA OPENLAMBDA] 
+                                              0)
+                                         (LISP:LAMBDA (SETQ DEF (\TRANSLATE-CL%:LAMBDA DEF))
+                                                      (GO RETRY))
+                                         (COND
+                                            ((AND COMPILEUSERFN (SETQ DEF (APPLY* COMPILEUSERFN NIL 
+                                                                                 DEF)))
+                                             (GO RETRY]
+                                    (T (COND
+                                          ((AND LAMBDANOBIND (EQ ARGS 'NOBIND))
+                                           (SETQ ARGS NIL)
+                                           2)
+                                          (T (SETQ ARGS (LIST ARGS))
+                                             (SELECTQ (CAR DEF)
+                                                 (LAMBDA 2)
+                                                 (NLAMBDA 3)
+                                                 (COND
+                                                    ((AND COMPILEUSERFN (SETQ DEF
+                                                                         (APPLY* COMPILEUSERFN NIL 
+                                                                                DEF)))
+                                                     (GO RETRY]
+              (COMPERROR (CONS COMFN '(not compilable]
+          (SETQ PIFN (COND
+                        ((EQ PIFN T)                         (* ; "compile as call to self")
+                         0)
+                        ((GETPROP COMFN OPCODEPROP)
+                         0)
+                        ((EQ 0 COMTYPE)
+                         (OR RECNAME COMFN))
+                        (T 0)))
+          (SETQ FRAME (SETQ TOPFRAME (create FRAME
+                                            VARS _ (SETQ ARGVARS (SETQ ALLVARS (COMP.BINDLIST
+                                                                                ARGS)))
+                                            NNILS _ 0)))
+          (COMP.STTAG (SETQ TOPLAB (create TAG)))
+          (COMP.VALN (CDDR DEF)
+                 'RETURN)
+          (COMP.UNBIND.VARS TOPFRAME T)
+          (SETQ CI (create COMINFO
+                          COMTYPE _ COMTYPE
+                          CODE _ (OPT.POSTOPT CODE)
+                          TOPFRAME _ TOPFRAME
+                          ARGS _ ARGVARS))
+          (SETQ FREELST (FOR X IN FREEVARS WHEN (EQ (FETCH OPNAME OF X)
+                                                                'FVAR)
+                           COLLECT (FETCH OPARG OF X)))
+          [SETQ ALAMS1 (SUBSET ALAMS1 (FUNCTION (LAMBDA (X)
+                                                  (NOT (GETPROP X OPCODEPROP]
+
+     (* ;; "Print out the status message for this function, noting the free variable references and calls to unknown functions.  We don't report free variables that are either proclaimed special or bound in a super function of this one.")
+
+          [LET* ((OUTER-VARS (FOR X IN OUTER-ALLVARS COLLECT (FETCH OPARG
+                                                                            OF X)))
+                 (USES-LIST (FOR X IN FREELST UNLESS (OR (VARIABLE-GLOBALLY-SPECIAL-P
+                                                                      X)
+                                                                     (FMEMB X OUTER-VARS))
+                               COLLECT X)))
+                (COMPPRINT (LISP:FORMAT NIL 
+                              "(~S ~A~@[ (uses~{ ~S~})~]~@[ (calls~{ ~S~})~]~@[ (nlams~{ ~S~})~])~%%"
+                                      COMFN (CADR DEF)
+                                      USES-LIST ALAMS1 NLAMS1))
+                                                             (* (COMPPRINT (BQUOTE
+                                                           ((\, COMFN) (\, (CADR DEF))
+                                                           (\,@ (AND USES-LIST
+                                                           (BQUOTE ((:USES (\,@ USES-LIST))))))
+                                                           (\,@ (AND ALAMS1 (BQUOTE
+                                                           ((:CALLS (\,@ ALAMS1))))))
+                                                           (\,@ (AND NLAMS1 (BQUOTE
+                                                           ((:NLAMS (\,@ NLAMS1))))))))))
+                ]
+          (SELECTQ LAPFLG
+              ((1 T) 
+                   (RESETFORM (OUTPUT LSTFIL)
+                          (COMP.MLLIST COMFN CI)))
+              NIL)
+          (APPLY* BYTEASSEMFN COMFN CI)
+          [COND
+             ((NEQ COMFN TOPFN)                              (* ; "generated subfunction")
+              (SETQ SUBFNFREEVARS (APPEND SUBFNFREEVARS FREELST]
+          (SETQ COMFNS (CONS COMFN COMFNS))
+          (RETURN COMFN])
+
+(COMP.BINDLIST
+  [LAMBDA (VARS)                                             (* lmm " 1-Jul-84 17:00")
+    (for VAR in VARS collect (create VAR
+                                                VARNAME _ (COMP.CHECK.VAR VAR T)
+                                                COMP.VARTYPE _ (COMP.VARTYPE VAR])
+
+(COMP.CHECK.VAR
+  [LAMBDA (X BIND)                                           (* lmm " 6-Apr-84 17:49")
+    [COND
+       (BIND [COND
+                    ((NEQ X (COMP.USERFN X))
+                     (COMPERRM (APPEND '(Attempt to bind CONSTANT)
+                                          X]
+              (COND
+                 ((COMP.GLOBALVARP X)
+                  (COMPERRM (CONS X '(- is global]
+    (OR (AND (LITATOM X)
+             (NEQ X T)
+             X)
+        (COMPERROR (CONS X '(is not a legal variable name])
+
+(COMP.BIND.VARS
+  [LAMBDA (ARGS VALS TYPE DECLARATIONS)                      (* Pavel "15-Nov-86 16:39")
+    (PROG (VLV VLN NVALS NNILS DECL X VAR DECLS VAL)
+          (for VARNAME in ARGS
+             do (SETQ VAR (create VAR
+                                     VARNAME _ (COMP.CHECK.VAR VARNAME T)
+                                     COMP.VARTYPE _ (COMP.VARTYPE VARNAME)))
+                   (if (SETQ X (CDR (FASSOC VARNAME DECLARATIONS)))
+                       then                              (* ; 
+                                                          "variable declared to be of a given type")
+                             (COMP.EXPR (SETQ VAL (pop VALS))
+                                    (AND VAL X))
+                             (replace (VAR COMP.VARTYPE) of VAR with 'HVAR)
+                             (push DECLS (CONS VAR X))
+                             (push VLV VAR)
+                     elseif [OR (NULL (SETQ X (pop VALS)))
+                                    (PROGN (COMP.VAL X)
+                                           (COND
+                                              ((EQ (CAR CODE)
+                                                   OPNIL)
+                                               (COMP.DELPUSH)
+                                               T]
+                       then (push VLN VAR)
+                     else (push VLV VAR)))
+          (for X in VALS do (COMP.EFFECT X))
+          (SETQ NNILS (LENGTH VLN))
+          [COND
+             ((IGREATERP (SETQ NVALS (LENGTH VLV))
+                     MAXBVALS)
+              (COMPERROR (CONS EXP '(-- too many variables with values]
+          (RETURN (create FRAME
+                         PARENT _ FRAME
+                         NVALS _ (LENGTH VLV)
+                         VARS _ (OPT.DREV VLV (OPT.DREV VLN))
+                         FRAMETYPE _ TYPE
+                         NNILS _ NNILS
+                         DECLS _ DECLS])
+
+(COMP.UNBIND.VARS
+  [LAMBDA (F TOPFLG)                                         (* lmm "29-Jun-84 09:34")
+    (COND
+       ((NOT (OR TOPFLG (EQ COMPILE.CONTEXT 'RETURN)
+                 (OPT.JUMPCHECK CODE)))
+        (OPT.CCHECK (EQ F FRAME))
+        (COMP.STUNBIND (EQ COMPILE.CONTEXT 'EFFECT))
+        (replace (FRAME PRIMARYRETURN) of (CAR CODE) with T)))
+    'NOVALUE])
+)
+(DEFINEQ
+
+(COMP.VALN
+  [LAMBDA (L COMPILE.CONTEXT)                                (* lmm "29-Jun-84 08:25")
+    (COMP.PROGN L])
+
+(COMP.PROGN
+  [LAMBDA (A)                                                (* lmm "13-Jul-84 21:18")
+    (COND
+       ((NULL (CDR A))
+        (COMP.EXP1 (CAR A)))
+       (T (PROG [(FLG (AND (NOT OPTIMIZATIONSOFF)
+                           (EQ COMPILE.CONTEXT 'RETURN]
+            LP  (COMP.EFFECT (CAR A))
+                (AND FLG (while (EQ (CAR CODE)
+                                        OPPOP) do        (* delete POP in PROGN)
+                                                     (COMP.DELPOP)))
+                (COND
+                   ((OPT.JUMPCHECK CODE))
+                   ((CDR (SETQ A (CDR A)))
+                    (GO LP))
+                   (T (RETURN (COMP.EXP1 (CAR A])
+
+(COMP.PROGLST
+  [LAMBDA (LST N CONTEXT)                                    (* lmm "18-Sep-84 16:28")
+    (PROG (VAL)
+          (while (IGREATERP N 0) do (SETQ VAL (COMP.EXPR (pop LST)
+                                                             (AND (EQ N 1)
+                                                                  CONTEXT)))
+                                           (add N -1))
+          (while (EQ (CAR (LISTP (CAR LST)))
+                         '*) do (pop LST))
+          [if LST
+              then (COMPERRM `(extraneous arguments to %, (CAR EXP)
+                                             %: ., LST))
+                    (SELECTQ CONTEXT
+                        ((NIL EFFECT)                        (* ok NIL)
+                             (MAPC LST (FUNCTION COMP.EFFECT)))
+                        (COMPERRM '(not compiled]
+          (RETURN VAL])
+
+(COMP.EXP1
+  [LAMBDA (E)                                                (* lmm "29-Jun-84 08:25")
+    (COMP.EXPR E COMPILE.CONTEXT])
+
+(COMP.EXPR
+  [LAMBDA (EXP COMPILE.CONTEXT)                              (* ; "Edited 26-Apr-91 13:08 by jds")
+    (DECLARE (SPECVARS *BC-MACRO-ENVIRONMENT*))
+    (PROG (M V)
+          [COND
+             ((NULL FRAME)
+              (COND
+                 [(OPT.JUMPCHECK CODE)
+                  (RETURN (COND
+                             ((COMP.PREDP COMPILE.CONTEXT)
+                              'PREDVALUE)
+                             (T 'NOVALUE]
+                 (T (OPT.COMPILERERROR]
+          (AND (EQ COMPILE.CONTEXT 'EFFECT)
+               (COMP.NOSIDEEFFECTP EXP)
+               (RETURN 'NOVALUE))
+      TOP [SETQ V (COND
+                     [(NLISTP EXP)
+                      (COND
+                         ((LITATOM EXP)
+                          (SELECTQ EXP
+                              ((T NIL) 
+                                   (COMP.CONST EXP))
+                              (COMP.VAR EXP)))
+                         ([OR (NUMBERP EXP)
+                              (PROGN                         (* ; "non-quoted string")
+                                     (OR [NULL (SETQ M (CDR (FASSOC (TYPENAME EXP)
+                                                                   COMPILETYPELST]
+                                         (EQ EXP (SETQ EXP (APPLY* M EXP]
+                          (COMP.CONST EXP))
+                         (T (GO TOP]
+                     [[NOT (LITATOM (SETQ M (CAR EXP]
+                      (SELECTQ (CAR (LISTP M))
+                          ([LAMBDA NLAMBDA OPENLAMBDA] 
+                               (COMP.LAMBDA M (CDR EXP)))
+                          (LISP:LAMBDA                       (* ; 
+                                         "Edited by TT(13-June-90) support convertion of CL:LAMBDA")
+                                       (SETQ EXP (CONS (\TRANSLATE-CL%:LAMBDA M)
+                                                       (CDR EXP)))
+                                       (GO TOP))
+                          (OPCODES (OR (fetch EXTCALL of FRAME)
+                                       (COMP.CLEANFNOP M 'FREEVARS)
+                                       (replace EXTCALL of FRAME with F))
+                                   (COMP.STFN (CAR EXP)
+                                          (for X in (CDR EXP) sum (COMP.VAL X)
+                                                                            1)))
+                          (COND
+                             ((SETQ M (COMP.TRYUSERFN EXP))
+                              (SETQ EXP M)
+                              (GO TOP))
+                             (T (COMPERROR (CONS M '(- non-atomic CAR of form]
+                     ((OR (AND (SETQ V (GETMACROPROP M COMPILERMACROPROPS))
+                               (NEQ V T))
+                          (GET M 'MACRO-FN)
+                          (COMPILER:OPTIMIZER-LIST M)
+                          (EQ (COMPILER:ENV-FBOUNDP *BC-MACRO-ENVIRONMENT* M :LEXICAL-ONLY T)
+                              :MACRO))
+                      (COMP.TRANSFORM EXP))
+                     ((AND (EQ COMPILE.CONTEXT 'RETURN)
+                           (EQ M PIFN))
+                      (COMP.CPI M (CDR EXP)))
+                     ((SETQ V (COMP.ARGTYPE M))
+                      (COMP.CALL M (CDR EXP)
+                             V))
+                     ((SETQ V (COMP.TRYUSERFN EXP))
+                      (SETQ EXP V)
+                      (GO TOP))
+                     (T (COMP.CALL M (CDR EXP]
+          (RETURN (SELECTQ COMPILE.CONTEXT
+                      (NIL NIL)
+                      (EFFECT (OR (EQ V 'NOVALUE)
+                                  (COMP.STPOP))
+                              'NOVALUE)
+                      (RETURN (OR (OPT.JUMPCHECK CODE)
+                                  (COMP.STRETURN))
+                              'NOVALUE)
+                      (COND
+                         ((COMP.PREDP COMPILE.CONTEXT)
+                          (COND
+                             ((NEQ V 'PREDVALUE)             (* ; 
+                                              "in this case, COMPILE.CONTEXT is a jump instruction")
+                              (COMP.STJUMP COMPILE.CONTEXT)))
+                          'PREDVALUE)
+                         ((EQ (CAR (LISTP COMPILE.CONTEXT))
+                              'TYPE)
+                          NIL)
+                         ((EQ (CAR (LISTP COMPILE.CONTEXT))
+                              'UNBOXED)
+                          (OR (EQ V 'UNBOXED)
+                              (COMP.UNBOX (CDR COMPILE.CONTEXT)))
+                          'UNBOXED])
+
+(COMP.TRYUSERFN
+  [LAMBDA (EXP M)
+    (AND COMPILEUSERFN (COND
+                          ((EQ (SETQ M (COMP.USERFN EXP))
+                               'INSTRUCTIONS)
+                           [COMPERRM (CONS EXP '(COMPILEUSERFN returned INSTRUCTIONS]
+                           NIL)
+                          (T M])
+
+(COMP.USERFN
+  [LAMBDA (X)                                                (* ; "Edited  7-Apr-87 13:12 by Pavel")
+    (COND
+       ((LISP:KEYWORDP X)
+        (LIST 'QUOTE X))
+       [(AND (EQ [CAR (LISTP (CAR (LISTP X]
+                 'LISP:LAMBDA)
+             (COND
+                ((INTERSECTION (CADR (CAR X))
+                        LISP:LAMBDA-LIST-KEYWORDS)
+                 (ERROR "Can't cope with lambda keywords in internal LAMBDA lists"))
+                (T `([LAMBDA ,@(CDAR X]
+                     ,@(CDR X]
+       ((LITATOM X)
+        (OR (AND COMPVARMACROHASH (GETHASH X COMPVARMACROHASH))
+            X))
+       (T (LET [(FN TOPFN)
+                (OTHERVARS (FOR X IN ALLVARS COLLECT (FETCH OPARG OF X]
+               (DECLARE (SPECVARS FN OTHERVARS))         (* ; "uses FN DEF ARGS OTHERVARS")
+               (APPLY* COMPILEUSERFN (CDR X)
+                      X])
+
+(COMP.CONST
+  [LAMBDA (X)                                                (* lmm "13-Jul-84 21:18")
+    (COND
+       ((AND (NOT OPTIMIZATIONSOFF)
+             (EQ COMPILE.CONTEXT 'EFFECT))                   (* CONST in (EQ COMPILE.CONTEXT
+                                                           (QUOTE EFFECT)))
+        'NOVALUE)
+       ((AND (NOT OPTIMIZATIONSOFF)
+             (COMP.PREDP COMPILE.CONTEXT))
+        [AND (SELECTQ (fetch OPNAME of COMPILE.CONTEXT)
+                 (TJUMP X)
+                 (NTJUMP (COND
+                            (X (COMP.STCONST X)
+                               T)))
+                 (FJUMP (NOT X))
+                 (NFJUMP (COND
+                            ((NOT X)
+                             (COMP.STCONST X)
+                             T)))
+                 (SHOULDNT))
+             (COMP.STJUMP 'JUMP (CAR (fetch OPARG of COMPILE.CONTEXT))
+                    (CDR (fetch OPARG of COMPILE.CONTEXT]
+        'PREDVALUE)
+       (T (COMP.STCONST X])
+
+(COMP.CALL
+  [LAMBDA (F A TYP)                                          (* ; "Edited  9-Feb-87 18:29 by Pavel")
+    (PROG ((N 0))
+          (OR (fetch EXTCALL of FRAME)
+              (COMP.CLEANFNOP F 'FREEVARS)
+              (replace EXTCALL of FRAME with F))
+          (SELECTQ TYP
+              (3                                             (* ; 
+                                        "call nlambda by applying with entire arglist as first arg")
+                 (pushnew NLAMS1 F)
+                 (COMP.STCONST A)
+                 (RETURN (COMP.STFN F 1)))
+              (1                                             (* ; 
+                                            "call NLAMBDA spread merely by not compiling arguments")
+                 (pushnew NLAMS1 F))
+              (NIL                                           (* ; 
+                                                    "unknown argtype, assume lambda, but warn user")
+                   (pushnew ALAMS1 F))
+              NIL)
+      LP  [COND
+             ((LISTP A)
+              (SELECTQ TYP
+                  (1 (COMP.STCONST (CAR A)))
+                  (COMP.VAL (CAR A)))
+              (SETQ N (ADD1 N))
+              (SETQ A (CDR A))
+              (GO LP))
+             (A (COMPERROR (CONS A '(- unusual tail for argument list]
+          (RETURN (COMP.STFN F N])
+
+(COMP.VAR
+  [LAMBDA (VAR)                                              (* lmm "24-Jan-85 18:40")
+    (COND
+       ((EQ COMPILE.CONTEXT 'EFFECT)                         (* VAR in EFFECT)
+        'NOVALUE)
+       (T (SETQ VAR (COMP.LOOKUPVAR VAR T))
+          (COMP.STVAR VAR)
+          (LET [(DECL (CDR (ASSOC VAR ALLDECLS]
+               (if (EQ (CAR (LISTP DECL))
+                           'UNBOXED)
+                   then (COMP.BOX (CDR DECL])
+
+(COMP.VAL1
+  [LAMBDA (L COMPILE.CONTEXT)                                (* lmm "29-Jun-84 08:25")
+    (COMP.PROG1 L])
+
+(COMP.PROG1
+  [LAMBDA (A)                                                (* lmm "29-Jun-84 08:25")
+    (COND
+       ((NULL (CDR A))
+        (COMP.EXP1 (CAR A)))
+       (T (PROG1 (COMP.EXPR (CAR A)
+                        (COND
+                           ((EQ COMPILE.CONTEXT 'EFFECT)
+                            COMPILE.CONTEXT)))
+              (MAPC (CDR A)
+                    (FUNCTION COMP.EFFECT)))])
+
+(COMP.EFFECT
+  [LAMBDA (E)                                                (* lmm "13-Jul-84 21:18")
+    (PROG ((LV LEVEL))
+          (COND
+             ((OPT.JUMPCHECK CODE)                       (* code for effect eliminated after 
+                                                           JUMP or RETURN)
+              (RETURN))
+             (T (OPT.CCHECK LV)))
+          (RETURN (PROG1 (COMP.EXPR E 'EFFECT)
+                      (OPT.CCHECK (OR AC (EQ LEVEL LV)
+                                          (OPT.JUMPCHECK CODE))))])
+
+(COMP.VAL
+  [LAMBDA (X)                                                (* lmm "13-Jul-84 21:18")
+    (PROG ((LV LEVEL))
+          (COND
+             ((OPT.JUMPCHECK CODE)                       (* code for value eliminated after 
+                                                           JUMP or RETURN)
+              (RETURN)))
+          (RETURN (PROG1 (COMP.EXPR X)
+                      (OPT.CCHECK (OR (EQ (ADD1 LV)
+                                              LEVEL)
+                                          AC
+                                          (OPT.JUMPCHECK CODE))))])
+
+(COMP.MACRO
+  [LAMBDA (EXP MAC)                                          (* ; "Edited 11-May-87 16:25 by amd")
+    (COND
+       [(NLISTP MAC)
+        (SELECTQ MAC
+            (T                                               (* ; 
+                                             "The macro is 'T'.   Compile this as a function-call.")
+               (COMP.CALL (CAR EXP)
+                      (CDR EXP)
+                      (COMP.ARGTYPE (CAR EXP))))
+            (COMP.PUNT (COMP.PUNT))
+            (BLKAPPLY* MAC (CDR EXP]
+       (T (SELECTQ (CAR MAC)
+              (APPLY (APPLY (CADR MAC)
+                            (CDR EXP)))
+              (APPLY* (APPLY (CADR MAC)
+                             (CONS (CDR EXP)
+                                   (CDDR MAC))))
+              (OPENLAMBDA (COMP.LAMBDA MAC (CDR EXP)))
+              (LET* ((*BYTECOMPILER-IS-EXPANDING* T)
+                     (EXPANSION (MACROEXPANSION EXP MAC T COMPILE.CONTEXT)))
+                    (DECLARE (SPECVARS *BYTECOMPILER-IS-EXPANDING*))
+                    (if (EQ EXPANSION EXP)
+                        then                             (* ; 
+                                                          "can't expand, e.g.  returns IGNOREMACRO")
+                              (COMP.CALL (CAR EXP)
+                                     (CDR EXP)
+                                     (COMP.ARGTYPE (CAR EXP)))
+                      else (COMP.EXP1 EXPANSION])
+)
+(DEFINEQ
+
+(COMP.VARTYPE
+  [LAMBDA (VAR)                                              (* lmm "13-MAR-81 09:36")
+    (OPT.CCHECK (AND VAR (LITATOM VAR)))
+    (COND
+       ((COMP.ANONP VAR)
+        'HVAR)
+       (T 'AVAR])
+
+(COMP.LOOKUPVAR
+  [LAMBDA (V FORVALUE)                                   (* jds " 1-Feb-84 15:08")
+    (PROG (X)
+          (COND
+             ((SETQ X (find VAR in ALLVARS suchthat (EQ (fetch VARNAME of VAR)
+                                                                    V)))
+              (RETURN X)))
+          (COND
+             ((SETQ X (find VAR in FREEVARS suchthat (EQ (fetch VARNAME of VAR)
+                                                                     V)))
+              (RETURN X)))
+          [COND
+             ((NEQ V (SETQ X (COMP.USERFN V)))
+              (COND
+                 (FORVALUE (RETAPPLY 'COMP.VAR (FUNCTION COMP.VAL)
+                                  (LIST X)
+                                  T))
+                 (T (COMPERRM (CONS V " - is compile time constant, yet is bound or set."]
+          (SETQ FREEVARS (CONS (SETQ X (create VAR
+                                              COMP.VARTYPE _ (COND
+                                                                ((AND GLOBALVARFLG (COMP.GLOBALVARP
+                                                                                    V))
+                                                                 'GVAR)
+                                                                (T 'FVAR))
+                                              VARNAME _ (COMP.CHECK.VAR V)))
+                               FREEVARS))
+          (RETURN X])
+
+(COMP.LOOKUPCONST
+  [LAMBDA (X)                                                (* lmm "24-JUN-78 22:56")
+    (COND
+       ((NULL X)
+        OPNIL)
+       (T (OR [CAR (SOME CONSTS (FUNCTION (LAMBDA (Y)
+                                            (EQ X (fetch OPARG of Y]
+              (PROG1 (SETQ X (create OP
+                                    OPNAME _ 'CONST
+                                    OPARG _ X))
+                  (SETQ CONSTS (NCONC1 CONSTS X)))])
+)
+(DEFINEQ
+
+(COMP.ST
+  [LAMBDA (X DL)                                             (* lmm "13-Jul-84 21:18")
+    (OPT.CCHECK DL)
+    (COND
+       [(OR LEVEL (EQ DL T))
+        (SETQ CODE (CONS X CODE))
+        (SETQ LEVEL (COND
+                       ((FIXP DL)
+                        (IPLUS LEVEL DL]
+       (T (OPT.CCHECK (OPT.JUMPCHECK CODE))          (* didn't store code after JUMP or 
+                                                           RETURN)
+          NIL])
+
+(COMP.STFN
+  [LAMBDA (FN N)                                             (* lmm "16-APR-82 00:14")
+    (COMP.ST (create OP
+                        OPNAME _ 'FN
+                        OPARG _ (CONS N (OR (AND BLKFLG (LITATOM FN)
+                                                 (CDR (FASSOC FN INTERNALBLKFNS)))
+                                            FN)))
+           (IDIFFERENCE 1 N])
+
+(COMP.STCONST
+  [LAMBDA (X)                                                (* lmm "16-APR-82 00:14")
+    (COMP.ST (COMP.LOOKUPCONST X)
+           1])
+
+(COMP.STVAR
+  [LAMBDA (VREF)                                             (* lmm "16-APR-82 00:14")
+    (COMP.ST VREF 1])
+
+(COMP.STPOP
+  [LAMBDA (N)                                                (* lmm "16-APR-82 00:14")
+    (RPTQ (OR N 1)
+          (COMP.ST OPPOP -1])
+
+(COMP.DELFN
+  [LAMBDA NIL                                                (* lmm%: "22-JUL-77 02:40")
+    [SETQ LEVEL (IPLUS (SUB1 LEVEL)
+                       (CAR (fetch OPARG of (CAR CODE]
+    (SETQ CODE (CDR CODE])
+
+(COMP.STRETURN
+  [LAMBDA NIL                                                (* lmm "16-APR-82 00:13")
+    (COMP.ST OPRETURN T)
+    (SETQ LEVEL (SETQ FRAME])
+
+(COMP.STTAG
+  [LAMBDA (TAG)                                              (* lmm "13-Jul-84 21:18")
+    (PROG ((NLV (fetch (TAG LEVEL) of TAG))
+           (NF (fetch (TAG FRAME) of TAG)))
+          (OR (COND
+                 [(OR NLV NF)
+                  (AND (EQ NLV (OR LEVEL (SETQ LEVEL NLV)))
+                       (EQ NF (OR FRAME (SETQ FRAME NF]
+                 ((OR LEVEL FRAME)
+                  (AND (replace (TAG LEVEL) of TAG with LEVEL)
+                       (replace (TAG FRAME) of TAG with FRAME)))
+                 (T T))
+              (OPT.COMPILERERROR))
+          [COND
+             ((AND (EQ (fetch OPNAME of (CAR CODE))
+                       'JUMP)
+                   (EQ (fetch (JUMP TAG) of (CAR CODE))
+                       TAG))                                 (* delete JUMP to next in COMP.STTAG)
+              (SETQ CODE (CDR CODE]
+          (COMP.ST TAG 0])
+
+(COMP.STJUMP
+  [LAMBDA (OP TAG JT)                                        (* lmm "13-Jul-84 21:18")
+    (COND
+       ((OPT.JUMPCHECK CODE)                             (* JUMP not stored after JUMP or 
+                                                           RETURN)
+        NIL)
+       (T [COND
+             ((NULL TAG)
+
+         (* even if OP is given and in correct format, re-cons it up since OPT.POSTOPT 
+       might smash it)
+
+              (SETQ TAG (CAR (fetch OPARG of OP)))
+              (SETQ JT (CDR (fetch OPARG of OP)))
+              (SETQ OP (fetch OPNAME of OP]
+          (COMP.ST (create JUMP
+                              OPNAME _ OP
+                              TAG _ TAG
+                              JT _ JT)
+                 0)
+          (PROG ((F (fetch FRAME of TAG))
+                 (V (fetch (TAG LEVEL) of TAG))
+                 NV)
+                (COND
+                   (F (OPT.CCHECK (EQ F FRAME)))
+                   (T (replace (TAG FRAME) of TAG with FRAME)))
+                (SETQ NV (SELECTQ OP
+                             (JUMP (PROG1 LEVEL
+                                       (SETQ FRAME (SETQ LEVEL))))
+                             ((FJUMP TJUMP) 
+                                  (SETQ LEVEL (SUB1 LEVEL)))
+                             ((NFJUMP NTJUMP) 
+                                  (PROG1 LEVEL
+                                      (SETQ LEVEL (SUB1 LEVEL))))
+                             (ERRORSET (PROG1 (SUB1 LEVEL)
+                                           (SETQ FRAME JT)
+                                           (SETQ LEVEL 0)))
+                             (OPT.COMPILERERROR)))
+                (OPT.CCHECK (OR (NULL NV)
+                                    (IGEQ NV 0)))
+                (OPT.CCHECK (OR (NULL LEVEL)
+                                    (IGEQ LEVEL 0)))
+                (COND
+                   (V (OPT.CCHECK (EQ V NV)))
+                   (T (replace (TAG LEVEL) of TAG with NV])
+
+(COMP.STSETQ
+  [LAMBDA (VREF)                                             (* lmm "16-APR-82 00:14")
+    (OPT.CCHECK (IGREATERP LEVEL 0))
+    (COMP.ST (create OP
+                        OPNAME _ 'SETQ
+                        OPARG _ VREF)
+           0])
+
+(COMP.STCOPY
+  [LAMBDA NIL                                                (* lmm "16-APR-82 00:14")
+    (OPT.CCHECK (IGREATERP LEVEL 0))
+    (COMP.ST OPCOPY 1])
+
+(COMP.DELPUSH
+  [LAMBDA NIL                                                (* lmm%: " 9-AUG-76 21:50:49")
+    (SUB1VAR LEVEL)
+    (SETQ CODE (CDR CODE])
+
+(COMP.DELPOP
+  [LAMBDA NIL                                                (* lmm "28-OCT-77 15:23")
+    (SETQ LEVEL (ADD1 LEVEL))
+    (SETQ CODE (CDR CODE])
+
+(COMP.STBIND
+  [LAMBDA (F)                                                (* lmm " 1-Jul-84 14:48")
+    [COND
+       ((NULL (fetch PARENT of F))
+        (replace PARENT of F with FRAME))
+       (T (OPT.CCHECK (EQ (fetch PARENT of F)
+                              FRAME]
+    [COND
+       [(NULL (fetch (FRAME LEVEL) of F))
+        (replace (FRAME LEVEL) of F with (IDIFFERENCE LEVEL (fetch NVALS of
+                                                                                         F]
+       (T (OPT.CCHECK (EQ (fetch (FRAME LEVEL) of F)
+                              (IDIFFERENCE LEVEL (fetch NVALS of F]
+    (COND
+       ([EVERY CODE (FUNCTION (LAMBDA (X)
+                                (SELECTQ (fetch OPNAME of X)
+                                    ((TAG HVAR AVAR GVAR CONST) 
+                                         T)
+                                    (FN (OR (NULL (fetch (FRAME VARS) of F))
+                                            (COMP.CLEANFNOP (CDR (fetch OPARG of X))
+                                                   'FREEVARS)))
+                                    NIL]                     (* PROG is first thing in function)
+        (replace CPIOK of F with T)))
+    (COMP.ST (create OP
+                        OPNAME _ 'BIND
+                        OPARG _ (CONS NIL F))
+           0)
+    (SETQ FRAME F)
+    (SETQ LEVEL 0])
+
+(COMP.STUNBIND
+  [LAMBDA (D)                                                (* lmm "16-APR-82 00:14")
+    (COMP.ST (create OP
+                        OPNAME _ (COND
+                                    (D 'DUNBIND)
+                                    (T 'UNBIND))
+                        OPARG _ (CONS LEVEL FRAME))
+           0)
+    [SETQ LEVEL (IPLUS (fetch (FRAME LEVEL) of FRAME)
+                       (COND
+                          (D 0)
+                          (T 1]
+    (SETQ FRAME (fetch PARENT of FRAME])
+)
+
+(RPAQQ *NO-SIDE-EFFECT-FNS*
+       (LISP::%%* LISP::%%+ LISP::%%- LISP::%%/ LISP::%%< LISP::%%= LISP::%%> LISP::%%LLSH1 
+              LISP::%%LLSH8 LISP::%%LOGIOR LISP::%%LRSH1 LISP::%%LRSH8 LISP:* + - / LISP:/= /= 
+              LISP:1+ LISP:1- < <= = > >= ABS LISP:ACOS LISP:ACOSH ADD1 LISP:ADJUSTABLE-ARRAY-P 
+              LISP:ALPHA-CHAR-P LISP:ALPHANUMERICP AND ANTILOG APPEND ARCCOS ARCSIN ARCTAN ARCTAN2 
+              LISP:AREF LISP:ARRAY-ELEMENT-TYPE LISP:ARRAY-HAS-FILL-POINTER-P LISP:ARRAY-RANK 
+              ARRAYORIG LISP:ARRAYP ARRAYP ARRAYSIZE ARRAYTYP LISP:ASH LISP:ASIN LISP:ASINH ASSOC 
+              LISP:ATAN LISP:ATANH LISP:ATOM ATOM LISP:BIT-VECTOR-P BITCLEAR BITSET BITTEST 
+              LISP:BOOLE LISP:BOTH-CASE-P BYTE LISP:BYTE-POSITION BYTE-SIZE BYTEPOSITION BYTESIZE 
+              CAAAAR CAAADR CAAAR CAADAR CAADDR CAADR CAAR CADAAR CADADR CADAR CADDAR CADDDR CADDR 
+              CADR CAR CDAAAR CDAADR CDAAR CDADAR CDADDR CDADR CDAR CDDAAR CDDADR CDDAR CDDDAR CDDDDR
+              CDDDR CDDR CDR LISP:CEILING LISP:CHAR-BIT LISP:CHAR-BITS LISP:CHAR-CODE 
+              LISP:CHAR-DOWNCASE LISP:CHAR-EQUAL LISP:CHAR-FONT LISP:CHAR-GREATERP LISP:CHAR-INT 
+              LISP:CHAR-LESSP LISP:CHAR-NAME LISP:CHAR-NOT-EQUAL LISP:CHAR-NOT-GREATERP 
+              LISP:CHAR-NOT-LESSP LISP:CHAR-UPCASE LISP:CHAR/= LISP:CHAR< LISP:CHAR<= LISP:CHAR= 
+              LISP:CHAR> LISP:CHAR>= LISP:CHARACTER CHARACTER LISP:CHARACTERP LISP:CIS LISP:CODE-CHAR
+              LISP:COMMONP LISP:COMPILED-FUNCTION-P COMPLEX LISP:COMPLEXP LISP:CONJUGATE CONS 
+              LISP:CONSP COPY COPYALL LISP:COS COS LISP:COSH DATEFORMAT LISP:DECODE-FLOAT 
+              LISP:DECODE-UNIVERSAL-TIME LISP:DENOMINATOR LISP:DEPOSIT-FIELD DEPOSITBYTE DIFFERENCE 
+              LISP:DIGIT-CHAR LISP:DIGIT-CHAR-P DPB LISP:EIGHTH ELT ELTD LISP:ENCODE-UNIVERSAL-TIME 
+              LISP:ENDP EQ EQL EQP LISP:EQUAL EQUAL LISP:EQUALP EVENP LISP:EXP LISP:EXPT EXPT FASSOC
+              LISP:FCEILING FCHARACTER FDIFFERENCE FEQP LISP:FFLOOR FGREATERP LISP:FIFTH LISP:FIRST 
+              FIX FIXP FIXR FLESSP FLOAT LISP:FLOAT-DIGITS LISP:FLOAT-PRECISION LISP:FLOAT-RADIX 
+              LISP:FLOAT-SIGN LISP:FLOATP FLOATP LISP:FLOOR FMAX FMEMB FMIN FMINUS LISP:FOURTH FPLUS
+              FPLUS2 FQUOTIENT FREMAINDER LISP:FROUND FTIMES LISP:FTRUNCATE LISP:FUNCTIONP LISP:GCD 
+              GCD GEQ GETHASH GETP GETPROP LISP:GRAPHIC-CHAR-P GREATERP HARRAYP HARRAYSIZE 
+              LISP:HASH-TABLE-P LISP:IDENTITY IDIFFERENCE IEQP IGEQ IGREATERP ILEQ ILESSP 
+              LISP:IMAGPART IMAX IMIN IMINUS IMOD LISP:INPUT-STREAM-P LISP:INT-CHAR 
+              LISP:INTEGER-DECODE-FLOAT LISP:INTEGER-LENGTH INTEGERLENGTH LISP:INTEGERP INTERSECTION
+              IPLUS IQUOTIENT IREMAINDER LISP:ISQRT ITIMES LISP:KEYWORDP KWOTE LAST LISP:LCM LDB 
+              LISP:LDB-TEST LEQ LESSP LIST LISP:LIST-LENGTH LISP:LISTP LISTP LITATOM LLSH LOADBYTE 
+              LOG LISP:LOG LOGAND LISP:LOGANDC1 LISP:LOGANDC2 LISP:LOGBITP LISP:LOGCOUNT LISP:LOGEQV
+              LISP:LOGIOR LISP:LOGNAND LISP:LOGNOR LOGNOT LOGOR LISP:LOGORC1 LISP:LOGORC2 
+              LISP:LOGTEST LOGXOR LISP:LOWER-CASE-P LRSH LSH LISP:MAKE-CHAR LISP:MASK-FIELD MASK.0'S
+              MASK.1'S MAX MEMB MEMBER MIN MINUS MINUSP LISP:MOD LISP:NAME-CHAR NEQ NILL LISP:NINTH 
+              NLISTP NOT LISP:NTH LISP:NTHCDR NTYPX NULL LISP:NUMBERP NUMBERP LISP:NUMERATOR ODDP OR
+              LISP:OUTPUT-STREAM-P LISP:PACKAGEP LISP:PATHNAMEP LISP:PHASE PLUS LISP:PLUSP 
+              POWEROFTWOP PROG1 PROGN QUOTIENT LISP:RANDOM-STATE-P LISP:RATIONAL LISP:RATIONALIZE 
+              LISP:RATIONALP READTABLEP LISP:REALPART RELSTKP LISP:REM REMAINDER LISP:REST ROT ROUND
+              RSH SASSOC LISP:SCALE-FLOAT XCL::SCEILING LISP:SECOND LISP:SET-CHAR-BIT LISP:SEVENTH 
+              XCL::SFLOOR LISP:SIGNUM LISP:SIMPLE-BIT-VECTOR-P LISP:SIMPLE-STRING-P 
+              LISP:SIMPLE-VECTOR-P LISP:SIN SIN LISP:SINH LISP:SIXTH SMALLP LISP:SQRT SQRT 
+              XCL::SROUND STACKP LISP:STANDARD-CHAR-P STKNARGS LISP:STREAM-ELEMENT-TYPE STREAMP 
+              LISP:STRING-CHAR-P STRING-EQUAL LISP:STRING-GREATERP LISP:STRING-LESSP 
+              LISP:STRING-NOT-EQUAL LISP:STRING-NOT-GREATERP LISP:STRING-NOT-LESSP STRING.EQUAL 
+              LISP:STRING/= LISP:STRING< LISP:STRING<= LISP:STRING= LISP:STRING> LISP:STRING>= 
+              LISP:STRINGP STRINGP XCL::STRUNCATE SUB1 LISP:SUBTYPEP LISP:SXHASH LISP:SYMBOLP TAILP 
+              TAN LISP:TAN LISP:TANH LISP:TENTH LISP:THIRD TIMEREXPIRED? TIMES TRUE LISP:TRUNCATE 
+              LISP:TYPE-OF TYPEP UNION LISP:UPPER-CASE-P LISP:VECTORP ZERO LISP:ZEROP ZEROP \ADDBASE
+              \ARG0 \CALLME \GETBASE \GETBASEBYTE \GETBASEFIXP \GETBASEPTR \GETBASESTRING \VAG2 
+              create fetch))
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS *NO-SIDE-EFFECT-FNS*)
+)
+(DEFINEQ
+
+(COMP.ARGTYPE
+  [LAMBDA (FN)                                               (* lmm "25-FEB-82 16:29")
+    (PROG NIL
+          (RETURN (COND
+                     ((NOT (LITATOM FN))
+                      (ARGTYPE FN))
+                     ((FMEMB FN LAMA)
+                      2)
+                     ((FMEMB FN LAMS)
+                      0)
+                     ((FMEMB FN NLAML)
+                      1)
+                     ((FMEMB FN NLAMA)
+                      3)
+                     (T (ARGTYPE (OR [AND BLKFLG (OR (CADDR (FASSOC FN BLKDEFS))
+                                                     (AND (FMEMB FN BLKLIBRARY)
+                                                          (GETP FN 'BLKLIBRARYDEF]
+                                     (GETPROP FN 'BROKEN)
+                                     (AND (GETD FN)
+                                          FN)
+                                     (GETPROP FN 'EXPR)
+                                     (RETURN (COND
+                                                ((FMEMB FN NOFIXFNSLST)
+                                                 2)
+                                                (T NIL])
+
+(COMP.CLEANEXPP
+  [LAMBDA (X TYPE)                                           (* lmm "15-APR-82 23:01")
+    (COND
+       ((NLISTP X))
+       ((COMP.CLEANFNP (CAR X)
+               TYPE)
+        (EVERY (CDR X)
+               (FUNCTION (LAMBDA (X)
+                           (COMP.CLEANEXPP X TYPE])
+
+(COMP.CLEANFNP
+  [LAMBDA (X TYPE)                                           (* lmm "15-APR-82 23:02")
+    (COND
+       ((LITATOM X)
+        (APPLY* CLEANFNTEST X))
+       ((LISTP X)
+        (SELECTQ (CAR X)
+            ([LAMBDA OPENLAMBDA] 
+                 [EVERY (CDDR X)
+                        (FUNCTION (LAMBDA (X)
+                                    (COMP.CLEANEXPP X TYPE])
+            NIL])
+
+(COMP.CLEANFNOP
+  [LAMBDA (FN TYPE)                                          (* lmm "15-APR-82 23:07")
+    (APPLY* CLEANFNTEST FN TYPE])
+
+(COMP.GLOBALVARP
+  [LAMBDA (X)                                                (* lmm%: " 9-AUG-76 20:34:14")
+    (OR (GETP X 'GLOBALVAR)
+        (FMEMB X GLOBALVARS])
+
+(COMP.LINKCALLP
+  [LAMBDA (FN)                                               (* edited (18-NOV-75 . 2341))
+    (COND
+       ((AND (LISTP NOLINKFNS)
+             (FMEMB FN NOLINKFNS))
+        NIL)
+       ((AND BLKFLG (OR (FASSOC FN BLKDEFS)
+                        (FMEMB FN BLKLIBRARY)))
+        T)
+       ((AND (LISTP LINKFNS)
+             (FMEMB FN LINKFNS))
+        T)
+       ((EQ NOLINKFNS T)
+        NIL)
+       ((OR BLKFLG (EQ LINKFNS T))
+        T])
+
+(COMP.ANONP
+  [LAMBDA (E)                                                (* lmm "12-May-86 13:23")
+    (COND
+       ((NEQ LOCALVARS T)
+        (FMEMB E LOCALVARS))
+       (T (NOT (OR (EQ SPECVARS T)
+                   (FMEMB E SPECVARS)
+                   (VARIABLE-GLOBALLY-SPECIAL-P E)
+                   (AND BLKFLG (FMEMB E LOCALFREEVARS])
+
+(COMP.NOSIDEEFFECTP
+  [LAMBDA (EXP)                                              (* ; "Edited 17-May-90 16:47 by nm")
+    (COMP.CLEANEXPP EXP *NO-SIDE-EFFECT-FNS*])
+)
+(DEFINEQ
+
+(COMP.CPI
+  [LAMBDA (FN ARGS)                                          (* Pavel "15-Nov-86 16:22")
+    (PROG ((F FRAME))
+      LP  (COND
+             ((EQ F TOPFRAME)
+              (COMP.CPI1 ARGS ARGVARS (COMP.PICOUNT ARGS))
+              (while (NEQ FRAME TOPFRAME) do         (* ; 
+                                                           "unbind localvar FRAME before recursion")
+                                                    (COMP.STUNBIND T))
+              (COND
+                 ((NEQ LEVEL 0)                              (* ; "pop stack before recursion")
+                  (COMP.STPOP LEVEL)))
+              (COMP.STJUMP 'JUMP TOPLAB)                 (* ; "COMP.CPI succeeds")
+              (RETURN 'NOVALUE))
+             ((SELECTQ (fetch FRAMETYPE of F)
+                  ((PROG LAMBDA) 
+                       [COND
+                          ((OASSOC 'AVAR (fetch VARS of F))
+                           (COND
+                              ((NOT (fetch CPIOK of F))
+                                                             (* ; 
+                                                "can't remove recursion inside frame with SPECVARS")
+                               T)
+                              (T                             (* ; 
+                              "COMP.CPI can succeed because SPECVARS bound first thing in function")
+                                 NIL])
+                  (PROGN                                     (* ; 
+                                                           "can't remove recursion inside ERRORSET")
+                         T))
+              (COMP.CALL FN ARGS 0))
+             ((SETQ F (fetch PARENT of F))
+              (GO LP))
+             (T (OPT.COMPILERERROR])
+
+(COMP.CPI1
+  [LAMBDA (ARGS VARS N)                                      (* lmm "16-APR-82 00:28")
+    (COND
+       [(NULL VARS)
+        (COND
+           ((LISTP ARGS)
+            (COMP.EFFECT (CAR ARGS))
+            (COMP.CPI1 (CDR ARGS)
+                   VARS
+                   (SUB1 N]
+       ([OR (IGREATERP N 0)
+            (NOT (LITATOM (CAR ARGS)))
+            (NEQ (CAR ARGS)
+                 (fetch OPARG of (CAR VARS]
+        (COMP.VAL (CAR ARGS))
+        (COMP.CPI1 (CDR ARGS)
+               (CDR VARS)
+               (SUB1 N))
+        (COMP.STSETQ (CAR VARS))
+        (COMP.STPOP))
+       (T (COMP.CPI1 (CDR ARGS)
+                 (CDR VARS)
+                 (SUB1 N])
+
+(COMP.PICOUNT
+  [LAMBDA (ARGS)                                             (* lmm "27-OCT-81 20:57")
+    (PROG ((N 0)
+           (ND 0)
+           (VARS ARGVARS))
+      LP  (COND
+             (VARS (SETQ N (ADD1 N))
+                   (COND
+                      [(AND (LITATOM (CAR ARGS))
+                            (EQ (CAR ARGS)
+                                (fetch OPARG of (CAR VARS]
+                      ((NOT (COMP.CLEANEXPP (CAR ARGS)
+                                   'COMP.PICOUNT))
+                       (SETQ ND N)))
+                   (SETQ VARS (CDR VARS))
+                   (SETQ ARGS (CDR ARGS))
+                   (GO LP)))
+          (RETURN ND])
+)
+
+(PUTPROPS EVQ BYTEMACRO COMP.EVQ)
+(DEFINEQ
+
+(COMP.EVQ
+  [LAMBDA (X)                                                (* lmm "18-Sep-84 16:06")
+    (RESETVARS (COMPVARMACROHASH)
+               (RETURN (COMP.PROGLST X 1])
+)
+
+(PUTPROPS AND BYTEMACRO (APPLY* COMP.BOOL T))
+
+(PUTPROPS OR BYTEMACRO (APPLY* COMP.BOOL NIL))
+(DEFINEQ
+
+(COMP.BOOL
+  [LAMBDA (A FLAG)                                           (* lmm "29-Apr-85 13:33")
+    (COND
+       ((NULL A)                                             (* (AND/OR))
+        (COMP.CONST FLAG))
+       ((NULL (CDR A))                                       (* (AND/OR expr))
+        (COMP.EXP1 (CAR A)))
+       (T (PROG ((END (create TAG))
+                 P)
+                (SETQ P (create JUMP
+                               OPNAME _ [COND
+                                           ((COMP.PREDP COMPILE.CONTEXT)
+                                                             (* AND/OR in PREDF)
+                                            (SELECTQ (fetch OPNAME of (SETQ P COMPILE.CONTEXT
+                                                                               ))
+                                                ((TJUMP NTJUMP) 
+                                                     (COND
+                                                        (FLAG 'FJUMP)
+                                                        (T (GO LP))))
+                                                ((FJUMP NFJUMP) 
+                                                     (COND
+                                                        (FLAG (GO LP))
+                                                        (T 'TJUMP)))
+                                                (OPT.COMPILERERROR)))
+                                           [(EQ COMPILE.CONTEXT 'EFFECT)
+                                                             (* AND/OR in EFFECT)
+                                            (COND
+                                               (FLAG 'FJUMP)
+                                               (T 'TJUMP]
+                                           (T                (* other AND/OR)
+                                              (COND
+                                                 (FLAG 'NFJUMP)
+                                                 (T 'NTJUMP]
+                               TAG _ END))
+            LP  (COND
+                   ((CDR A)
+                    (COMP.EXPR (CAR A)
+                           P)
+                    (SETQ A (CDR A))
+                    (GO LP)))
+                (RETURN (PROG1 [COMP.EXPR (CAR A)
+                                      (SELECTQ COMPILE.CONTEXT
+                                          ((EFFECT RETURN NIL) 
+                                               COMPILE.CONTEXT)
+                                          (COND
+                                             ((COMP.PREDP COMPILE.CONTEXT)
+                                              COMPILE.CONTEXT)
+                                             (T NIL]
+                               (COMP.STTAG END])
+)
+(DEFINEQ
+
+(COMP.APPLYFNP
+  [LAMBDA (X)                                                (* edited%: "21-MAY-80 09:38")
+    (AND (LISTP X)
+         (SELECTQ (CAR X)
+             ((FUNCTION QUOTE) 
+                  (AND (NULL (CDDR X))
+                       (SELECTQ (COMP.ARGTYPE (CADR X))
+                           (NIL (pushnew ALAMS1 (CADR X))
+                                T)
+                           ((0 1 2) 
+                                T)
+                           NIL)))
+             NIL])
+)
+
+(PUTPROPS AC BYTEMACRO COMP.AC)
+(DEFINEQ
+
+(COMP.AC
+  [LAMBDA NIL                                                (* lmm%: " 1-OCT-76 12:41:01")
+    (OR (EQ (SETQ AC EXP)
+            DONOTHING)
+        (COMP.PUNT))
+    NIL])
+
+(COMP.PUNT
+  [LAMBDA NIL                                                (* lmm "22-OCT-79 12:44")
+    (PROG [(EM (CONS (CAR EXP)
+                     '(-- can't compile]
+          (COMPERROR (COND
+                            [MACEXP (CONS 'Under (CONS (CAR MACEXP)
+                                                       (CONS '- EM]
+                            (T EM])
+)
+
+(PUTPROPS FUNCTION BYTEMACRO COMP.FUNCTION)
+(DEFINEQ
+
+(COMP.FUNCTION
+  [LAMBDA (A)                                                (* lmm "16-APR-82 00:18")
+    (PROG ((FN (CAR A)))
+          [COND
+             ((LISTP FN)
+              (SETQ FN (COMP.LAM1 FN]
+          (RETURN (COND
+                     ((CDR A)
+                      (COMP.CALL 'FUNCTION (CONS FN (CDR A))
+                             1))
+                     (T (COMP.STCONST FN])
+
+(COMP.LAM1
+  [LAMBDA (DEF)                                              (* Pavel "15-Nov-86 16:12")
+    (PROG ((FN (COMP.GENFN)))
+          (COMP.TOPLEVEL.COMPILE FN DEF NIL ALLVARS)
+          (for X in ALLVARS when (AND (NEQ (fetch OPNAME of X)
+                                                       'AVAR)
+                                                  (FMEMB (fetch OPARG of X)
+                                                         SUBFNFREEVARS))
+             do                                          (* ; 
+                                            "change LOCALVAR to SPECVAR because subfn uses it free")
+                   (replace OPNAME of X with 'AVAR))
+          (RETURN FN])
+
+(COMP.GENFN
+  [LAMBDA NIL                                                (* Pavel "28-Oct-86 20:16")
+    (COND
+       ((IGEQ COMP.GENFN.NUM 9999)
+        (SETQ COMP.GENFN.NUM 0)))
+    (LISP:INTERN (LISP:FORMAT NIL "~AA~4,'0D" (STRING COMFN)
+                        (add COMP.GENFN.NUM 1))
+           (LISP:SYMBOL-PACKAGE COMFN])
+)
+
+(RPAQ? COMP.GENFN.NUM 0)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS COMP.GENFN.NUM COMP.UNBOXED.TAG)
+)
+
+(PUTPROPS COND BYTEMACRO COMP.COND)
+
+(PUTPROPS SELECTQ BYTEMACRO COMP.SELECTQ)
+(DEFINEQ
+
+(COMP.COND
+  [LAMBDA (A)                                                (* lmm "12-Mar-85 07:04")
+    (PROG (TEST CLAUSE (END (create TAG))
+                ENDF NEXT [CONTEXT (SELECTQ COMPILE.CONTEXT
+                                       ((EFFECT RETURN NIL) 
+                                            COMPILE.CONTEXT)
+                                       (COND
+                                          ((COMP.PREDP COMPILE.CONTEXT)
+                                           NIL)
+                                          ((EVERY A (FUNCTION CDR))
+                                           COMPILE.CONTEXT)
+                                          (T NIL]
+                COMPVAL)
+      LP  [SETQ TEST (CAR (SETQ CLAUSE (CAR A]
+          (COND
+             [(CDR CLAUSE)                                   (* is there anything after the test?)
+
+         (* * compile the test in a context where, if false, it will jump to NEXT)
+
+              (LET
+               [(MORE (LET ((HERE CODE))
+                           [COMP.EXPR TEST (create JUMP
+                                                      OPNAME _ 'FJUMP
+                                                      TAG _ (SETQ NEXT (create TAG]
+                           (OR OPTIMIZATIONSOFF
+                               (for (X _ CODE) by (CDR X)
+                                  while (AND X (NEQ X HERE))
+                                  do (AND (EQ [CAR (LISTP (fetch OPARG of (CAR X]
+                                                  NEXT)
+                                              (RETURN T]
+               [COND
+                  ((NOT (OPT.JUMPCHECK CODE))            (* it doesn't ALWAYS jump to next)
+                   (SETQ COMPVAL (COMP.VALN (CDR CLAUSE)
+                                        CONTEXT))
+                   (OR (OPT.JUMPCHECK CODE)
+                       (COMP.STJUMP 'JUMP (SETQ ENDF END]
+               (COND
+                  (MORE (COMP.STTAG NEXT))
+                  (T (GO OUT]
+             [(CDR A)                                        (* this is a form (COND
+                                                           (TEST) --) where there is more to 
+                                                           come)
+              (COMP.EXPR TEST (create JUMP
+                                         OPNAME _ (COND
+                                                     ((EQ CONTEXT 'EFFECT)
+                                                      'TJUMP)
+                                                     (T 'NTJUMP))
+                                         TAG _ (SETQ ENDF END]
+             (T                                              (* (COND -- (A)) is equivalent to
+                                                           (COND -- (T A)))
+                (SETQ COMPVAL (COMP.EXPR TEST CONTEXT))
+                (GO OUT)))
+          (COND
+             ((SETQ A (CDR A))
+              (GO LP)))
+          (AND (NEQ CONTEXT 'EFFECT)
+               (COMP.EXPR NIL))
+      OUT (AND ENDF (COMP.STTAG END))
+          (RETURN (COND
+                     ((EQ CONTEXT 'EFFECT)
+                      'NOVALUE)
+                     (T COMPVAL])
+
+(COMP.IF
+  [LAMBDA (A)                                                (* lmm "24-May-86 16:32")
+                                                             (* used by common lisp IF)
+    (DESTRUCTURING-BIND (TEST THEN ELSE)
+           A
+           (PROG (CONDTEST (END (create TAG))
+                        ENDF NEXT (CONTEXT (SELECTQ COMPILE.CONTEXT
+                                               ((EFFECT RETURN NIL) 
+                                                    COMPILE.CONTEXT)
+                                               NIL))
+                        COMPVAL)
+                 [COMP.EXPR TEST (create JUMP
+                                            OPNAME _ 'FJUMP
+                                            TAG _ (SETQ NEXT (create TAG]
+                 [COND
+                    ((NOT (OPT.JUMPCHECK CODE))
+                     (SETQ COMPVAL (COMP.EXPR THEN CONTEXT))
+                     (OR (OPT.JUMPCHECK CODE)
+                         (COMP.STJUMP 'JUMP (SETQ ENDF END]
+                 (COMP.STTAG NEXT)
+                 [COND
+                    ((NOT (OPT.JUMPCHECK CODE))          (* it doesn't ALWAYS jump to next)
+                     (SETQ COMPVAL (COMP.EXPR ELSE CONTEXT]
+                 (AND ENDF (COMP.STTAG END))
+                 (RETURN (COND
+                            ((EQ CONTEXT 'EFFECT)
+                             'NOVALUE)
+                            (T COMPVAL])
+
+(COMP.SELECTQ
+  [LAMBDA (A)                                                (* lmm "13-Jul-84 21:18")
+    (PROG ((END (create TAG))
+           VAR THISLABEL NEXT TEST CLAUSE)                   (* compile SELECTQ)
+          (COMP.VAL (CAR A))
+          (SETQ A (CDR A))
+          (COND
+             ((FMEMB (fetch OPNAME of (CAR CODE))
+                     SELECTVARTYPES)                         (* SELECTQVARTYPES is
+                                                           (AVAR HVAR) for Alto and NIL for 
+                                                           maxc)
+                                                             (* SELECTQ var)
+              (SETQ VAR (CAR CODE))
+              (COMP.DELPUSH))
+             ((AND (EQ (fetch OPNAME of (CAR CODE))
+                       'SETQ)
+                   (FMEMB (fetch OPNAME of (fetch OPARG of (CAR CODE)))
+                          SELECTVARTYPES))                   (* SELECTQ SETQ)
+              (SETQ VAR (fetch OPARG of (CAR CODE)))
+              (COMP.STPOP))
+             [(EQ (fetch OPNAME of (CAR CODE))
+                  'CONST)                                    (* SELECTQ of constant)
+              (RETURN (COMP.PROGN (PROG [(C (fetch OPARG of (CAR CODE]
+                                            (COMP.DELPUSH)
+                                        ALP (COND
+                                               ((NULL (CDR A))
+                                                (RETURN A)))
+                                            [COND
+                                               ((COND
+                                                   ((LISTP (CAAR A))
+                                                    (FMEMB C (CAAR A)))
+                                                   (T (EQ (CAAR A)
+                                                          C)))
+                                                (RETURN (CDAR A]
+                                            (SETQ A (CDR A))
+                                            (GO ALP]
+             (T (SETQ THISLABEL T)))
+      LP  [COND
+             ((NULL (CDR A))
+              (AND THISLABEL (NULL VAR)
+                   (COMP.STPOP))
+              (RETURN (PROG1 (COMP.EXPR (CAR A)
+                                    (COND
+                                       ((COMP.PREDP COMPILE.CONTEXT)
+                                        NIL)
+                                       (T COMPILE.CONTEXT)))
+                          (OR (EQ COMPILE.CONTEXT 'RETURN)
+                              (COMP.STTAG END)))]
+          (SETQ THISLABEL)
+          [COND
+             ([LISTP (SETQ TEST (CAR (SETQ CLAUSE (PROG1 (CAR A)
+                                                      (SETQ A (CDR A)))]
+              (COND
+                 ((NLISTP (CDR TEST))
+                  (SETQ TEST (CAR TEST)))
+                 (SELECTQFMEMB                               (* FMEMB in SELECTQ)
+                        (COND
+                           (VAR (COMP.STVAR VAR))
+                           ((CDR A)
+                            (COMP.STCOPY)))
+                        (COMP.STCONST (APPEND TEST))
+                        (COMP.STFN 'FMEMB 2)
+                        (GO DUN))
+                 (T (SETQ THISLABEL (create TAG))
+                    (MAP TEST (FUNCTION (LAMBDA (Y)
+                                          (COND
+                                             ((CDR Y)
+                                              (COND
+                                                 (VAR (COMP.STVAR VAR))
+                                                 (T (COMP.STCOPY)))
+                                              (COMP.STCONST (CAR Y))
+                                              (COMP.STFN 'EQ 2)
+                                              (COMP.STJUMP 'TJUMP THISLABEL))
+                                             (T (SETQ TEST (CAR Y]
+          (COND
+             (VAR (COMP.STVAR VAR))
+             ((OR THISLABEL (CDR A))
+              (COMP.STCOPY)))
+          (COMP.STCONST TEST)
+          (COMP.STFN 'EQ 2)
+      DUN [COND
+             ((AND (NULL THISLABEL)
+                   (NULL (CDR A))
+                   (NULL (CAR A)))                           (* SELECTQ ends in NIL)
+              (COMP.STJUMP (COND
+                                  ((EQ COMPILE.CONTEXT 'EFFECT)
+                                   'FJUMP)
+                                  (T 'NFJUMP))
+                     END)
+              (RETURN (PROG1 (COMP.VALN (CDR CLAUSE)
+                                    (COND
+                                       ((EQ COMPILE.CONTEXT 'EFFECT)
+                                        COMPILE.CONTEXT)))
+                             (COMP.STTAG END]
+          (COMP.STJUMP 'FJUMP (SETQ NEXT (create TAG)))
+          (COND
+             (THISLABEL (COMP.STTAG THISLABEL)))
+          (COND
+             ((AND (OR THISLABEL (CDR A))
+                   (NULL VAR))
+              (COMP.STPOP)))
+          (COMP.VALN (CDR CLAUSE)
+                 (SELECTQ COMPILE.CONTEXT
+                     ((EFFECT RETURN) 
+                          COMPILE.CONTEXT)
+                     NIL))
+          (OR (EQ COMPILE.CONTEXT 'RETURN)
+              (COMP.STJUMP 'JUMP END))
+          (COMP.STTAG NEXT)
+          (GO LP])
+)
+
+(PUTPROPS PROGN BYTEMACRO COMP.PROGN)
+
+(PUTPROPS PROG1 BYTEMACRO COMP.PROG1)
+
+(PUTPROPS QUOTE BYTEMACRO COMP.QUOTE)
+
+(PUTPROPS * BYTEMACRO COMP.COMMENT)
+(DEFINEQ
+
+(COMP.QUOTE
+  [LAMBDA (A)                                                (* lmm%: " 9-AUG-76 22:04:49")
+    [COND
+       ((CDR A)
+        (COMPERRM (CONS EXP '(- probable parenthesis error]
+    (COMP.CONST (CAR A])
+
+(COMP.COMMENT
+  [LAMBDA (A)                                                (* lmm "29-Jun-84 08:25")
+    (COND
+       ((NOT (EQ COMPILE.CONTEXT 'EFFECT))
+        [COMPERRM (CONS EXP '(- value of comment used?]
+        (COMP.STCONST (CAR A)))
+       (T 'NOVALUE])
+)
+
+(PUTPROPS DECLARE BYTEMACRO COMP.DECLARE)
+(DEFINEQ
+
+(COMP.DECLARE
+  [LAMBDA (A)                                                (* lmm "24-May-86 20:36")
+                                                             (* compile DECLARE)
+    [MAPC A (FUNCTION (LAMBDA (B)
+                        (SELECTQ (CAR B)
+                            (LOCALVARS (COMP.DECLARE1 (CDR B)
+                                              'LOCALVARS
+                                              'SPECVARS SYSSPECVARS))
+                            (SPECVARS (COMP.DECLARE1 (CDR B)
+                                             'SPECVARS
+                                             'LOCALVARS SYSLOCALVARS))
+                            (LISP:SPECIAL [MAPC (fetch VARS of FRAME)
+                                                (FUNCTION (LAMBDA (V VTAG)
+                                                            (COND
+                                                               ((AND (EQ (fetch OPNAME
+                                                                            of V)
+                                                                         'HVAR)
+                                                                     (FMEMB (fetch OPARG
+                                                                               of V)
+                                                                            (CDR B)))
+                                                                (replace OPNAME of V
+                                                                   with 'AVAR])
+                            (IGNORE)
+                            (USEDFREE NIL)
+                            ((ADDTOVAR DEFLIST PUTPROPS CONSTANTS SETQQ USEDFREE GLOBALVARS) 
+                                 (EVAL B))
+                            (UNBOXED (push ALLDECLS COMP.UNBOXED.TAG))
+                            (TYPE                            (* handled elsewhere))
+                            (COMPERRM (CONS B '(- used in DECLARE]
+    (COMP.CONST (CAR A])
+
+(COMP.DECLARE1
+  [LAMBDA (VAL VAR OTHERVAR SYSOTHERVAR)                     (* lmm "31-MAR-78 02:47")
+    (SET VAR (COND
+                ((LISTP VAL)
+                 (COND
+                    ((LISTP (SETQ VAR (EVALV VAR)))
+                     (APPEND VAL VAR))
+                    ((EQ VAR T))
+                    (T VAL)))
+                ((EQ VAL T)
+                 (SET OTHERVAR SYSOTHERVAR)
+                 T)
+                (T VAL)))
+    (MAPC (fetch VARS of FRAME)
+          (FUNCTION (LAMBDA (V VTAG)
+                      (COND
+                         ((NEQ (SETQ VTAG (COMP.VARTYPE (fetch OPARG of V)))
+                               (fetch OPNAME of V))  (* Already made some decision based 
+                                                           on localvars (COMPERRM
+                                                           (CONS EXP (QUOTE (-
+                                                           illegal DECLARE)))))
+                          (replace OPNAME of V with VTAG])
+)
+
+(RPAQQ MCROPS
+       (CAR CDR CAAR CDAR CADR CDDR CAAAR CDAAR CADAR CDDAR CAADR CDADR CADDR CDDDR CAAAAR CDAAAR 
+            CADAAR CDDAAR CAADAR CDADAR CADDAR CDDDAR CAAADR CDAADR CADADR CDDADR CAADDR CDADDR 
+            CADDDR CDDDDR))
+
+(PUTPROPS CAR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CDR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CAAR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CDAR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CADR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CDDR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CAAAR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CDAAR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CADAR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CDDAR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CAADR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CDADR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CADDR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CDDDR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CAAAAR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CDAAAR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CADAAR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CDDAAR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CAADAR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CDADAR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CADDAR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CDDDAR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CAAADR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CDAADR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CADADR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CDDADR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CAADDR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CDADDR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CADDDR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CDDDDR BYTEMACRO COMP.CARCDR)
+
+(PUTPROPS CAR CROPS (A))
+
+(PUTPROPS CDR CROPS (D))
+
+(PUTPROPS CAAR CROPS (A A))
+
+(PUTPROPS CDAR CROPS (A D))
+
+(PUTPROPS CADR CROPS (D A))
+
+(PUTPROPS CDDR CROPS (D D))
+
+(PUTPROPS CAAAR CROPS (A A A))
+
+(PUTPROPS CDAAR CROPS (A A D))
+
+(PUTPROPS CADAR CROPS (A D A))
+
+(PUTPROPS CDDAR CROPS (A D D))
+
+(PUTPROPS CAADR CROPS (D A A))
+
+(PUTPROPS CDADR CROPS (D A D))
+
+(PUTPROPS CADDR CROPS (D D A))
+
+(PUTPROPS CDDDR CROPS (D D D))
+
+(PUTPROPS CAAAAR CROPS (A A A A))
+
+(PUTPROPS CDAAAR CROPS (A A A D))
+
+(PUTPROPS CADAAR CROPS (A A D A))
+
+(PUTPROPS CDDAAR CROPS (A A D D))
+
+(PUTPROPS CAADAR CROPS (A D A A))
+
+(PUTPROPS CDADAR CROPS (A D A D))
+
+(PUTPROPS CADDAR CROPS (A D D A))
+
+(PUTPROPS CDDDAR CROPS (A D D D))
+
+(PUTPROPS CAAADR CROPS (D A A A))
+
+(PUTPROPS CDAADR CROPS (D A A D))
+
+(PUTPROPS CADADR CROPS (D A D A))
+
+(PUTPROPS CDDADR CROPS (D A D D))
+
+(PUTPROPS CAADDR CROPS (D D A A))
+
+(PUTPROPS CDADDR CROPS (D D A D))
+
+(PUTPROPS CADDDR CROPS (D D D A))
+
+(PUTPROPS CDDDDR CROPS (D D D D))
+(DEFINEQ
+
+(COMP.CARCDR
+  [LAMBDA (A)                                                (* lmm "18-Sep-84 16:13")
+                                                             (* Used for compiling CAR/CDR etc)
+    (COND
+       ((EQ COMPILE.CONTEXT 'EFFECT)                         (* CAR/CDR in EFF)
+        (COMP.PROGLST A 1 COMPILE.CONTEXT))
+       (T (COMP.PROGLST A 1)
+          (MAPC (GETPROP (CAR EXP)
+                       'CROPS)
+                (FUNCTION (LAMBDA (X)
+                            (COMP.STFN (SELECTQ X
+                                               (A 'CAR)
+                                               'CDR)
+                                   1])
+
+(COMP.STCROP
+  [LAMBDA (X)                                                (* lmm "16-APR-82 00:16")
+    (COMP.STFN (SELECTQ X
+                       (A 'CAR)
+                       'CDR)
+           1])
+)
+
+(PUTPROPS NOT BYTEMACRO COMP.NOT)
+
+(PUTPROPS NULL BYTEMACRO COMP.NOT)
+(DEFINEQ
+
+(COMP.NOT
+  [LAMBDA (A TMP)                                            (* lmm "18-Sep-84 16:30")
+    (COND
+       ((AND (COMP.PREDP COMPILE.CONTEXT)
+             (SETQ TMP (OPT.NOTJUMP COMPILE.CONTEXT)))
+        (COMP.PROGLST A 1 TMP))
+       (T (COMP.PROGLST A 1)
+          (COMP.STFN 'NULL 1])
+)
+
+(PUTPROPS SETQ BYTEMACRO COMP.SETQ)
+
+(PUTPROPS SETN BYTEMACRO COMP.SETN)
+(DEFINEQ
+
+(COMP.SETQ
+  [LAMBDA (A)                                                (* lmm "29-Oct-84 15:23")
+    (PROG (VAR DECL)
+          (SETQ VAR (COMP.LOOKUPVAR (CAR A)))
+          [SETQ DECL (LISTP (CDR (ASSOC VAR ALLDECLS]
+          (COMP.PROGLST (CDR A)
+                 1 DECL)
+          (COMP.STSETQ VAR)
+          (IF (AND (NEQ COMPILE.CONTEXT 'EFFECT)
+                       (EQ (CAR DECL)
+                           'UNBOXED))
+              THEN (COMP.BOX (CDR DECL])
+
+(COMP.SETN
+  [LAMBDA (A)                                                (* lmm%: "20-OCT-76 01:33:55")
+    [COMPERRM (CONS (CAR A)
+                        '(- warning%: SETN compiled as SETQ]
+    (COMP.SETQ A])
+)
+(DEFINEQ
+
+(COMP.LAMBDA
+  [LAMBDA (FN VALS)                                          (* Pavel "15-Nov-86 16:23")
+    (PROG ((VARS (CADR FN))
+           F
+           (EXPS (CDDR FN))
+           V E (I 0)
+           SUBOLD SUBNEW VAR)
+          [if (EQ (CAR FN)
+                      'OPENLAMBDA)
+              then                                       (* ; "compile OPENLAMBDA expression")
+                    [while VARS do (COMP.VAL (pop VALS))
+                                          (COND
+                                             ((EQ (fetch OPNAME of (CAR CODE))
+                                                  'CONST)
+                                              (push SUBOLD (pop VARS))
+                                              [push SUBNEW (KWOTE (fetch OPARG
+                                                                         of (CAR CODE]
+                                              (COMP.DELPUSH))
+                                             (T (push V (pop VARS]
+                    (for X in VALS do (COMP.EFFECT X))
+                    (while (AND V (SETQ VAR (SELECTQ (fetch OPNAME of (CAR CODE))
+                                                    ((AVAR HVAR FVAR GVAR) 
+                                                         (PROG1 (fetch OPARG of (CAR CODE))
+                                                                (COMP.DELPUSH)))
+                                                    (SETQ (PROG1 (fetch OPARG
+                                                                    of (fetch OPARG
+                                                                              of (CAR CODE)))
+                                                                 (COMP.STPOP)))
+                                                    NIL))) do 
+                                                             (* ; 
+                                                           "substitute for variable in OPENLAMBDA")
+                                                                 (push SUBNEW VAR)
+                                                                 (push SUBOLD (pop V)))
+                    [if (NULL V)
+                        then                             (* ; 
+                                                    "OPENLAMBDA with all variables substituted for")
+                              (RETURN (COMP.PROGN (SUBPAIR SUBOLD SUBNEW EXPS]
+                    (while V do [push SUBNEW (CAR (push VARS (COMP.GENFN]
+                                       (push SUBOLD (pop V))
+                                       (push VALS DONOTHING))
+                    (SETQ EXPS (CONS '(DECLARE (LOCALVARS . T))
+                                     (SUBPAIR SUBOLD SUBNEW EXPS)))
+            else (SELECTQ (ARGTYPE FN)
+                         (0)
+                         (1                                  (* ; "open NLAMBDA nospread")
+                            (SETQ VALS (MAPCAR VALS (FUNCTION KWOTE))))
+                         (2                                  (* ; "open LAMBDA nospread")
+                            (RETURN (COMP.CALL (COMP.LAM1 FN)
+                                           VALS 2)))
+                         (3                                  (* ; "open NLAMBDA spread")
+                            (SETQ VARS (LIST VARS))
+                            (SETQ VALS (LIST (KWOTE VALS))))
+                         (COMPERROR (CONS FN '(- illegal open function]
+          (SETQ F (COMP.BIND.VARS VARS VALS 'LAMBDA (COMP.LOOKFORDECLARE EXPS)))
+          (PROG ((ALLVARS (APPEND (fetch VARS of F)
+                                 ALLVARS))
+                 (ALLDECLS (APPEND (fetch DECLS of F)
+                                  ALLDECLS))
+                 (LOCALVARS LOCALVARS)
+                 (SPECVARS SPECVARS))
+                (COMP.STBIND F)
+                (COMP.VALN EXPS (SELECTQ COMPILE.CONTEXT
+                                        ((EFFECT RETURN) 
+                                             COMPILE.CONTEXT)
+                                        NIL)))
+          (RETURN (COMP.UNBIND.VARS F])
+)
+
+(PUTPROPS LISP:TAGBODY DMACRO COMP.TAGBODY)
+
+(PUTPROPS PROG BYTEMACRO COMP.PROG)
+
+(PUTPROPS GO BYTEMACRO COMP.GO)
+
+(PUTPROPS RETURN BYTEMACRO COMP.RETURN)
+
+(PUTPROPS LISP:RETURN-FROM BYTEMACRO COMP.RETURN-FROM)
+(DEFINEQ
+
+(COMP.PROG
+  [LAMBDA (A)                                                (* lmm "13-Jul-84 21:18")
+    (PROG ([VARS (for X in (CAR A)
+                    collect (COND
+                                   ((LITATOM X)
+                                    X)
+                                   [(NLISTP X)
+                                    (COMPERROR (CONS X '(- bad PROG variable]
+                                   (T (CAR X]
+           [VALS (for X in (CAR A) collect (AND (LISTP X)
+                                                            (COND
+                                                               ((CDDR X)
+                                                                (CONS 'PROG1 (CDR X)))
+                                                               (T (CADR X]
+           F)
+          [SETQ F (COMP.BIND.VARS VARS VALS 'PROG (COMP.LOOKFORDECLARE (SETQ A (CDR A]
+          (PROG ((ALLVARS (APPEND (fetch VARS of F)
+                                 ALLVARS))
+                 (ALLDECLS (APPEND (fetch DECLS of F)
+                                  ALLDECLS))
+                 (LOCALVARS LOCALVARS)
+                 (SPECVARS SPECVARS)
+                 TAGS
+                 (RETURNLABEL (create TAG
+                                     LEVEL _ (COND
+                                                ((EQ COMPILE.CONTEXT 'EFFECT)
+                                                 0)
+                                                (T 1))
+                                     FRAME _ F))
+                 PROGLEVEL
+                 (PROGCONTEXT (SELECTQ COMPILE.CONTEXT
+                                  ((EFFECT RETURN) 
+                                       COMPILE.CONTEXT)
+                                  NIL))
+                 FLG)
+                (COMP.STBIND F)
+                [for X in A
+                   do (COND
+                             ((LISTP X))
+                             [(NOT (LITATOM X))
+                              (COMPERROR (CONS X '(- illegal tag]
+                             [(FASSOC X TAGS)
+                              (COMPERROR (CONS X '(- multiply defined tag]
+                             (T (SETQ TAGS (CONS (CONS X (SETQ X (create TAG
+                                                                        LBNO _ X)))
+                                                 TAGS))
+                                (replace (TAG FRAME) of X with FRAME)
+                                (replace (TAG LEVEL) of X with 0]
+                (replace PROGLABELS of F with TAGS)
+                [SETQ FLG (AND (NOT OPTIMIZATIONSOFF)
+                               (NULL TAGS)
+                               (EQ PROGCONTEXT 'RETURN]      (* Check if can delete extra POP's)
+                [for X in A do (COND
+                                              [(LITATOM X)
+                                               (COMP.STTAG (CDR (FASSOC X TAGS]
+                                              (T (COMP.EFFECT X)
+                                                 (AND FLG (while (EQ (CAR CODE)
+                                                                         OPPOP) do 
+                                                             (* delete POP in PROG)
+                                                                                      (COMP.DELPOP
+                                                                                       ]
+                (COND
+                   ((NOT (OR (EQ COMPILE.CONTEXT 'EFFECT)
+                             (OPT.JUMPCHECK CODE)))      (* PROG dropped off)
+                    (COMP.EXPR NIL)))
+                (OR (EQ COMPILE.CONTEXT 'RETURN)
+                    (COMP.STTAG RETURNLABEL)))
+          (RETURN (COMP.UNBIND.VARS F])
+
+(COMP.GO
+  [LAMBDA (A)                                                (* lmm " 2-Jun-86 23:03")
+    (PROG (D ANYPROG)
+          [COND
+             ((OPT.JUMPCHECK CODE)                       (* UNREACHABLE GO --
+                                                           DON'T COMPILE)
+              (RETURN 'NOVALUE]
+      LP  [SELECTQ (fetch FRAMETYPE of FRAME)
+              ([LAMBDA PROG] 
+                   [COND
+                      ((SETQ D (FASSOC (CAR A)
+                                      (fetch PROGLABELS of FRAME)))
+                       (COND
+                          ((NOT (ZEROP LEVEL))               (* GO needs to POP)
+                           (COMP.STPOP LEVEL)))
+                       (COMP.STJUMP 'JUMP (CDR D))
+                       (RETURN 'NOVALUE])
+              (COMPERROR (CONS (CAR A)
+                                   '(- illegal GO]           (* non local GO)
+          (COMP.STUNBIND T)
+          (GO LP])
+
+(COMP.RETURN
+  [LAMBDA (A)                                                (* lmm "18-Sep-84 16:31")
+    (PROG ((PROGFRAME FRAME))
+          [COND
+             ((NEQ PROGCONTEXT 'RETURN)
+              (COND
+                 ([NOT (OR (EQ PROGCONTEXT 'EFFECT)
+                           (EQ LEVEL 0)
+                           (NEQ (fetch FRAMETYPE of FRAME)
+                                'PROG]                       (* RETURN POPs beforehand)
+                  (COMP.STPOP LEVEL]
+      CHKLP
+          [SELECTQ (fetch FRAMETYPE of PROGFRAME)
+              (PROG)
+              (LAMBDA (SETQ PROGFRAME (fetch PARENT of PROGFRAME))
+                      (GO CHKLP))
+              (COMPERROR (CONS COMFN '(- illegal RETURN]
+          (COMP.PROGLST A 1 PROGCONTEXT)
+          [COND
+             ((OPT.JUMPCHECK CODE)
+              (RETURN 'NOVALUE]
+          (COND
+             ((NEQ PROGCONTEXT 'RETURN)
+              [PROG NIL
+                LP  (SELECTQ (fetch FRAMETYPE of FRAME)
+                        (PROG (OPT.CCHECK (EQ FRAME PROGFRAME)))
+                        (LAMBDA                              (* RETURN inside LAMBDA)
+                                (COMP.STUNBIND (EQ PROGCONTEXT 'EFFECT))
+                                (GO LP))
+                        (COMPERROR (CONS COMFN '(- illegal RETURN]
+              [COND
+                 ((EQ PROGCONTEXT 'EFFECT)
+                  (COMP.STPOP LEVEL))
+                 ((NEQ LEVEL 1)
+                  (OPT.COMPILERERROR '(unimplemented RETURN]
+              (COMP.STJUMP 'JUMP RETURNLABEL)))
+          (RETURN 'NOVALUE])
+
+(COMP.BLOCK
+  [LAMBDA (A)                                                (* lmm " 2-Jun-86 23:05")
+    (if (NULL (CAR A))
+        then (COMP.PROG (CONS NIL A))
+      else (PROG (F)
+                     (SETQ F (COMP.BIND.VARS NIL NIL 'LAMBDA))
+                     (PROG ((BLOCKEND (create TAG
+                                             LEVEL _ (COND
+                                                        ((EQ COMPILE.CONTEXT 'EFFECT)
+                                                         0)
+                                                        (T 1))
+                                             FRAME _ F))
+                            (CTX (SELECTQ COMPILE.CONTEXT
+                                     ((EFFECT RETURN) 
+                                          COMPILE.CONTEXT)
+                                     NIL))
+                            FLG)
+                           (COMP.STBIND F)
+                           [replace PROGLABELS of F
+                              with (LIST (CONS 'COMPILER-BLOCK-DATA
+                                                   (create BLOCKSTATUS
+                                                          BLOCKCONTEXT _ CTX
+                                                          BLOCKTAG _ (CAR A)
+                                                          BLOCKEND _ BLOCKEND]
+                           [COMP.RETURN-FROM (LIST (CAR A)
+                                                       (CONS 'PROGN (CDR A]
+                           (OR (EQ COMPILE.CONTEXT 'RETURN)
+                               (COMP.STTAG BLOCKEND)))
+                     (RETURN (COMP.UNBIND.VARS F])
+
+(COMP.RETURN-FROM
+  [LAMBDA (A)                                                (* lmm " 2-Jun-86 23:10")
+    (if (NULL (CAR A))
+        then (COMP.RETURN (CDR A))
+      else (PROG ((BLOCKFRAME FRAME)
+                      DATA CTX)
+                 CHKLP
+                     [SELECTQ (fetch FRAMETYPE of BLOCKFRAME)
+                         (LAMBDA (if (OR [NOT (SETQ DATA (CDR (FASSOC 'COMPILER-BLOCK-DATA
+                                                                         (fetch PROGLABELS
+                                                                            of BLOCKFRAME]
+                                             (NEQ (CAR A)
+                                                  (fetch BLOCKTAG of DATA)))
+                                     then (SETQ BLOCKFRAME (fetch PARENT of BLOCKFRAME))
+                                           (GO CHKLP)))
+                         (PROG (SETQ BLOCKFRAME (fetch PARENT of BLOCKFRAME))
+                               (GO CHKLP))
+                         (COMPERROR (CONS COMFN '(- illegal RETURN]
+                     (SETQ CTX (fetch BLOCKCONTEXT of DATA))
+                     [COND
+                        ((NEQ CTX 'RETURN)
+                         (COND
+                            ([NOT (OR (EQ CTX 'EFFECT)
+                                      (EQ LEVEL 0)
+                                      (NEQ (fetch FRAMETYPE of FRAME)
+                                           'PROG]            (* RETURN POPs beforehand)
+                             (COMP.STPOP LEVEL]
+                     (COMP.PROGLST (CDR A)
+                            1 CTX)
+                     [COND
+                        ((OPT.JUMPCHECK CODE)
+                         (RETURN 'NOVALUE]
+                     [COND
+                        ((NEQ CTX 'RETURN)
+                         [until (EQ FRAME BLOCKFRAME) do (COMP.STUNBIND
+                                                                  (EQ CTX 'EFFECT]
+                         [COND
+                            ((EQ CTX 'EFFECT)
+                             (COMP.STPOP LEVEL))
+                            ((NEQ LEVEL 1)
+                             (OPT.COMPILERERROR '(unimplemented RETURN]
+                         (COMP.STJUMP 'JUMP (fetch BLOCKEND of DATA]
+                     (RETURN 'NOVALUE])
+
+(COMP.TAGBODY
+  [LAMBDA (A)                                                (* lmm " 2-Jun-86 23:05")
+    (PROG ((VARS NIL)
+           (VALS NIL)
+           F)
+          (SETQ F (COMP.BIND.VARS NIL NIL 'LAMBDA))
+          [PROG (TAGS)
+                (COMP.STBIND F)
+                [for X in A
+                   do (COND
+                             ((LISTP X))
+                             [(NOT (LITATOM X))
+                              (COMPERROR (CONS X '(- illegal tag]
+                             [(FASSOC X TAGS)
+                              (COMPERROR (CONS X '(- multiply defined tag]
+                             (T (SETQ TAGS (CONS (CONS X (SETQ X (create TAG
+                                                                        LBNO _ X)))
+                                                 TAGS))
+                                (replace (TAG FRAME) of X with FRAME)
+                                (replace (TAG LEVEL) of X with 0]
+                (replace PROGLABELS of F with TAGS)
+                                                             (* Check if can delete extra POP's)
+                [for X in A do (COND
+                                              [(LITATOM X)
+                                               (COMP.STTAG (CDR (FASSOC X TAGS]
+                                              (T (COMP.EFFECT X]
+                (COND
+                   ((NOT (OR (EQ COMPILE.CONTEXT 'EFFECT)
+                             (OPT.JUMPCHECK CODE)))      (* PROG dropped off)
+                    (COMP.EXPR NIL]
+          (RETURN (COMP.UNBIND.VARS F])
+)
+
+(PUTPROPS LISP:LABELS BYTEMACRO COMP.LABELS)
+(DEFINEQ
+
+(COMP.LABELS
+  [LAMBDA (DEF)                                              (* ; "Edited  2-Dec-87 12:32 by amd")
+
+(* ;;; "the byte compiler does a better job with LABELS because compiling UNDO needed it (!)")
+
+    (LET
+     [(FUNCTIONS (MAPCAR (CAR DEF)
+                        (FUNCTION (LAMBDA (X)
+                                    (CONS (COMP.GENFN)
+                                          X]                 (* ; 
+                                                           "list of functions to be substituted")
+     (LISP:FLET
+      [(TRANSFORM (FORM CONTEXT)
+              (LISP:IF (NLISTP FORM)
+                  FORM
+                  [COND
+                     ((FMEMB (CAR FORM)
+                             '(FUNCTION LISP:FUNCTION))
+                      (for Z in FUNCTIONS when (EQ (CADR FORM)
+                                                               (CADR Z))
+                         do [RETURN `',(CAR Z] finally (RETURN FORM)))
+                     (T (for Z in FUNCTIONS when (EQ (CAR FORM)
+                                                                 (CADR Z))
+                           do [RETURN `(,(CAR Z)
+                                            ,@(CDR FORM] finally (RETURN FORM])]
+      (FOR Z IN FUNCTIONS
+         DO (COMP.TOPLEVEL.COMPILE
+                 (CAR Z)
+                 [DESTRUCTURING-BIND (FN-NAME FN-ARGLIST &REST FN-BODY)
+                        (CDR Z)
+                        (LISP:MULTIPLE-VALUE-BIND
+                         (BODY DECLS)
+                         (PARSE-BODY FN-BODY NIL T)
+                         `(LAMBDA ,FN-ARGLIST
+                            ,(WALK-FORM `(LISP:LOCALLY ,@DECLS (LISP:BLOCK ,FN-NAME ,@BODY))
+                                    :WALK-FUNCTION
+                                    (FUNCTION TRANSFORM]
+                 NIL ALLVARS))
+      (for X in ALLVARS when (AND (NEQ (fetch OPNAME of X)
+                                                   'AVAR)
+                                              (FMEMB (fetch OPARG of X)
+                                                     SUBFNFREEVARS))
+         do                                              (* ; 
+                                            "change LOCALVAR to SPECVAR because subfn uses it free")
+               (replace OPNAME of X with 'AVAR))
+      (COMP.EXPR (WALK-FORM `(PROGN ,@(CDR DEF))
+                            :WALK-FUNCTION
+                            (FUNCTION TRANSFORM))
+             COMPILE.CONTEXT])
+)
+
+(RPAQQ COMP.UNBOXED.TAG ("I'm on ALLDECLS if FPLUS compiles with unboxed arithmetic"))
+
+(RPAQQ NUMBERFNS (ITIMES2 LOGOR2 LOGXOR2 LOGAND2 LLSH1 LRSH1 LLSH8 LRSH8 IPLUS ITIMES LOGOR 
+                            LOGXOR LOGAND IDIFFERENCE IQUOTIENT IREMAINDER IMINUS LSH LLSH RSH LRSH 
+                            FIX))
+
+(RPAQQ GLOBALVARFLG T)
+
+(RPAQQ NEWOPTFLG NIL)
+
+(RPAQ COMPVERSION (DATE))
+
+(DEFOPTIMIZER IMINUS (X)
+                         `(IDIFFERENCE 0 ,X))
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS IPLUS BYTEMACRO (APPLY* COMP.NUMERIC IPLUS))
+
+(PUTPROPS ITIMES BYTEMACRO (APPLY* COMP.NUMERIC ITIMES FIX 0))
+
+(PUTPROPS LOGOR BYTEMACRO (APPLY* COMP.NUMERIC LOGOR FIX -1))
+
+(PUTPROPS LOGXOR BYTEMACRO (APPLY* COMP.NUMERIC LOGXOR))
+
+(PUTPROPS LOGAND BYTEMACRO (APPLY* COMP.NUMERIC LOGAND FIX 0))
+
+(PUTPROPS IDIFFERENCE BYTEMACRO COMP.NUMBERCALL)
+
+(PUTPROPS IQUOTIENT BYTEMACRO COMP.NUMBERCALL)
+
+(PUTPROPS IREMAINDER BYTEMACRO COMP.NUMBERCALL)
+
+(PUTPROPS LSH BYTEMACRO COMP.NUMBERCALL)
+
+(PUTPROPS LLSH DMACRO COMP.SHIFT)
+
+(PUTPROPS RSH BYTEMACRO COMP.NUMBERCALL)
+
+(PUTPROPS LRSH DMACRO COMP.SHIFT)
+
+(PUTPROPS FIX BYTEMACRO COMP.FIX)
+
+(PUTPROPS PLUS DMACRO [APPLY* COMP.NUMERIC PLUS PLUS NIL ((FLOAT FPLUS (OPCODES UBFLOAT2 0])
+
+(PUTPROPS DIFFERENCE DMACRO [APPLY* COMP.NUMBERCALL PLUS ((FLOAT FDIFFERENCE (OPCODES 
+                                                                                            UBFLOAT2
+                                                                                            1])
+
+(PUTPROPS TIMES DMACRO [APPLY* COMP.NUMERIC TIMES PLUS 0 ((FLOAT FTIMES (OPCODES UBFLOAT2 3])
+
+(PUTPROPS QUOTIENT DMACRO (APPLY* COMP.NUMBERCALL PLUS))
+
+(PUTPROPS FPLUS DMACRO [APPLY* COMP.NUMERIC FPLUS FLOAT NIL ((FLOAT FPLUS (OPCODES UBFLOAT2 0
+                                                                                         ])
+
+(PUTPROPS FDIFFERENCE DMACRO [APPLY* COMP.NUMBERCALL FLOAT ((FLOAT FDIFFERENCE
+                                                                           (OPCODES UBFLOAT2 1])
+
+(PUTPROPS FTIMES DMACRO [APPLY* COMP.NUMERIC FTIMES FLOAT 0 ((FLOAT FTIMES (OPCODES UBFLOAT2
+                                                                                          3])
+
+(PUTPROPS FQUOTIENT DMACRO [APPLY* COMP.NUMBERCALL FLOAT ((FLOAT FQUOTIENT (OPCODES UBFLOAT2
+                                                                                          4])
+
+(PUTPROPS FABS DMACRO [(X)
+                               (\FLOATBOX ((OPCODES UBFLOAT1 2)
+                                           (\FLOATUNBOX X])
+
+(PUTPROPS FGREATERP DMACRO (APPLY* COMP.COMPARENUM FLOAT FGREATERP NIL (OPCODES UBFLOAT2 5)))
+
+[PROGN (PUTPROPS FLESSP MACRO [LAMBDA (X Y)
+                                        (FGREATERP Y X])
+       (PUTPROPS FLESSP DMACRO (APPLY* COMP.COMPARENUM FLOAT FLESSP FGREATERP
+                                              (OPCODES SWAP UBFLOAT2 5)))]
+
+(PUTPROPS FREMAINDER DMACRO [APPLY* COMP.NUMBERCALL FLOAT ((FLOAT FREMAINDER (OPCODES 
+                                                                                            UBFLOAT2
+                                                                                            8])
+)
+(DEFINEQ
+
+(COMP.NUMERIC
+  [LAMBDA (A 2FN TYPE ZERO COERSIONS)                        (* ; "Edited 12-Apr-88 17:03 by amd")
+
+    (* ;; "compile call to number function of arbitrary args.  2FN is holder of opcode.  TYPE is FIX, FLOAT, PLUS (NIL->FIX)")
+
+    (* ;; "ZERO IF GIVEN IS ZERO OF FUNCTION, E.G.  0 FOR TIMES, -1 FOR LOGOR")
+
+    (* ;; "coercions say what to do if compile context is other numeric type")
+
+    (PROG ((N 0)
+           V
+           (FN (CAR EXP))
+           TMP)
+          [COND
+             ((AND (EQ COMPILE.CONTEXT 'EFFECT)
+                   (NOT OPTIMIZATIONSOFF))
+              (RETURN (COMP.PROGN A]
+          (OR 2FN (SETQ 2FN FN))
+          (SELECTQ (CAR (LISTP COMPILE.CONTEXT))
+              (TYPE [COND
+                       ((AND (NEQ (CDR COMPILE.CONTEXT)
+                                  TYPE)
+                             (SETQ TMP (FASSOC (CDR COMPILE.CONTEXT)
+                                              COERSIONS)))
+                        (SETQ TYPE (CAR TMP))
+                        (SETQ 2FN (CADR TMP])
+              (UNBOXED (if (SETQ TMP (CADDR (FASSOC (CDR COMPILE.CONTEXT)
+                                                       COERSIONS)))
+                           then (while A do (COMP.EXPR (pop A)
+                                                               COMPILE.CONTEXT)
+                                                       (SETQ N (ADD1 N)))
+                                 (FRPTQ (SUB1 N)
+                                        (COMP.STFN TMP 2))
+                                 (RETURN 'UNBOXED)))
+              NIL)
+          (if (AND (SETQ TMP (CADDR (FASSOC TYPE COERSIONS)))
+                       (FMEMB COMP.UNBOXED.TAG ALLDECLS))
+              then (while A do (COMP.EXPR (pop A)
+                                                  (CONS 'UNBOXED TYPE))
+                                          (SETQ N (ADD1 N)))
+                    (FRPTQ (SUB1 N)
+                           (COMP.STFN TMP 2))
+                    (RETURN (COMP.FLOATBOX)))
+          [while A do [COMP.EXPR (pop A)
+                                     (CONS 'TYPE (OR TYPE (SETQ TYPE 'FIX]
+                             (SETQ N (ADD1 N))
+                             (COND
+                                ((NOT OPTIMIZATIONSOFF)
+                                 (COMP.DELFIX TYPE)
+                                 (while (OPT.CALLP (CAR CODE)
+                                                   2FN)
+                                    do (SETQ N (IPLUS N (CAR (fetch OPARG of (CAR CODE)))
+                                                          -1)) 
+
+                                          (* ;; "merge nested arithmetic calls")
+
+                                          (COMP.DELFN))
+                                 (COND
+                                    ((AND (EQ (fetch OPNAME of (CAR CODE))
+                                              'CONST)
+                                          (NUMBERP (fetch OPARG of (CAR CODE)))
+                                          (IGREATERP N 0))
+                                     [SETQ V (COND
+                                                [V 
+                                                   (* ;; "combine number args")
+
+                                                   (APPLY* FN V (fetch OPARG of (CAR CODE]
+                                                (T 
+                                                   (* ;; "move number constants to end")
+
+                                                   (APPLY* (OR TYPE (FUNCTION FIX))
+                                                          (fetch OPARG of (CAR CODE]
+                                     (COMP.DELPUSH)
+                                     (SETQ N (SUB1 N]
+          [COND
+             (V (COND
+                   ((EQL (APPLY* FN V)
+                         (APPLY* FN))
+
+                    (* ;; "I.E., IS UNIT OF FUNCTION: 1 FOR TIMES, ETC")
+
+                    )
+                   ((EQL V ZERO)
+                    (FRPTQ N (COMP.STPOP))
+                    (RETURN (COMP.STCONST V)))
+                   ((AND (IGREATERP N 0)
+                         (MINUSP V)
+                         (EQ 2FN 'IPLUS))
+
+                    (* ;; "turn IPLUS of negative to IDIFFERENCE")
+
+                    (COMP.STCONST (IMINUS V))
+                    (COMP.STFN 'IDIFFERENCE 2))
+                   (T (COMP.STCONST V)
+                      (add N 1]
+          (COND
+             ((EQ N 0)
+
+              (* ;; "number function, 0 args")
+
+              (COMP.STCONST (APPLY* FN)))
+             ((EQ N 1)
+
+              (* ;; "number fn, 1 arg")
+
+              (COMP.STFIX TYPE))
+             (T (FRPTQ (SUB1 N)
+                       (COMP.STFN 2FN 2])
+
+(COMP.NUMBERCALL
+  [LAMBDA (A TYPE COERSIONS)                                 (* lmm " 9-Mar-85 14:55")
+    (PROG ((N 0)
+           TMP
+           (2FN (CAR EXP)))
+          [COND
+             ((AND (EQ COMPILE.CONTEXT 'EFFECT)
+                   (NOT OPTIMIZATIONSOFF))
+              (RETURN (COMP.PROGN A]
+          (SELECTQ (CAR (LISTP COMPILE.CONTEXT))
+              (TYPE [COND
+                       ((AND (NEQ (CDR COMPILE.CONTEXT)
+                                  TYPE)
+                             (SETQ TMP (FASSOC (CDR COMPILE.CONTEXT)
+                                              COERSIONS)))
+                        (SETQ TYPE (CAR TMP))
+                        (SETQ 2FN (CADR TMP])
+              (UNBOXED (if (SETQ TMP (CADDR (FASSOC (CDR COMPILE.CONTEXT)
+                                                       COERSIONS)))
+                           then (while A do (COMP.EXPR (pop A)
+                                                               COMPILE.CONTEXT)
+                                                       (SETQ N (ADD1 N)))
+                                 (FRPTQ (SUB1 N)
+                                        (COMP.STFN TMP 2))
+                                 (RETURN 'UNBOXED)))
+              NIL)
+          (if (AND (SETQ TMP (CADDR (FASSOC TYPE COERSIONS)))
+                       (FMEMB COMP.UNBOXED.TAG ALLDECLS))
+              then (while A do (COMP.EXPR (pop A)
+                                                  (CONS 'UNBOXED TYPE))
+                                          (SETQ N (ADD1 N)))
+                    (FRPTQ (SUB1 N)
+                           (COMP.STFN TMP 2))
+                    (RETURN (COMP.FLOATBOX)))
+          (while A do (COMP.VAL (pop A))
+                             [COND
+                                ((NOT OPTIMIZATIONSOFF)
+                                 (COMP.DELFIX TYPE)      (* remove extraneous FIX, FLOAT 
+                                                           calls)
+                                 (COND
+                                    ((AND (NEQ TYPE 'PLUS)
+                                          (EQ (fetch OPNAME of (CAR CODE))
+                                              'CONST))       (* if FIX or FLOAT type and arg is 
+                                                           constant, then coerce.)
+                                     (COMP.STCONST (APPLY* (OR TYPE 'FIX)
+                                                              (PROG1 (fetch OPARG
+                                                                        of (CAR CODE))
+                                                                     (COMP.DELPUSH]
+                             (SETQ N (ADD1 N)))
+          [COND
+             ((AND (NOT OPTIMIZATIONSOFF)
+                   (EQ (fetch OPNAME of (CAR CODE))
+                       'CONST)
+                   (EQ N 2))
+              (COND
+                 ((EQ (fetch OPNAME of (CAR (fetch PREV of CODE)))
+                      'CONST)
+                  (COMP.STCONST (PROG1 (APPLY* (CAR EXP)
+                                                  (fetch OPARG
+                                                     of (CAR (fetch PREV of CODE)))
+                                                  (fetch OPARG of (CAR CODE)))
+                                        (COMP.DELPUSH)
+                                        (COMP.DELPUSH)))
+                  (RETURN (COMP.STFIX TYPE)))
+                 ((FMEMB 2FN (SELECTQ (fetch OPARG of (CAR CODE))
+                                 (0 '(IDIFFERENCE LSH RSH LLSH LRSH))
+                                 (1 '(IQUOTIENT))
+                                 NIL))
+                  (COMP.DELPUSH)
+                  (RETURN (COMP.STFIX TYPE]
+          (RETURN (COMP.STFN 2FN N])
+
+(COMP.FIX
+  [LAMBDA (A)                                                (* lmm "18-APR-80 18:28")
+    (COMP.VAL1 A)
+    (COMP.STFIX])
+
+(COMP.STFIX
+  [LAMBDA (TYPE)                                             (* lmm "13-Jul-84 21:18")
+    (OR TYPE (SETQ TYPE 'FIX))
+    (COND
+       [[AND (EQ (fetch OPNAME of (CAR CODE))
+                 'CONST)
+             (NUMBERP (fetch OPARG of (CAR CODE]     (* COMPILE TIME FIX)
+        (COMP.STCONST (PROG1 (APPLY* TYPE (fetch OPARG of (CAR CODE)))
+                                 (COMP.DELPUSH]
+       ((AND (EQ TYPE 'FIX)
+             (OPT.CALLP (CAR CODE)
+                    NUMBERFNS)))
+       (T (COMP.STFN TYPE 1])
+
+(COMP.DELFIX
+  [LAMBDA (TYPE)                                             (* lmm "16-APR-82 00:19")
+                                                             (* have compiled call to number 
+                                                           function; delete any 
+                                                           coersions-to-TYPE)
+    (while (OPT.CALLP (CAR CODE)
+                      (SELECTQ TYPE
+                          ((FIX NIL) 
+                               '(IPLUS FIX))
+                          (FLOAT 'FLOAT)
+                          'PLUS)
+                      1) do (COMP.DELFN])
+)
+
+(PUTPROPS EQ BYTEMACRO COMP.EQ)
+
+(PUTPROPS EQUAL BYTEMACRO COMP.EQ)
+
+(PUTPROPS EQP BYTEMACRO COMP.EQ)
+(DEFINEQ
+
+(COMP.EQ
+  [LAMBDA (A)                                                (* lmm " 2-Jan-85 00:23")
+    (COND
+       ((EQ COMPILE.CONTEXT 'EFFECT)
+        (COMP.PROGN A))
+       (T (PROG (C)
+                (COMP.VAL (pop A))
+                [COND
+                   ((OR OPTIMIZATIONSOFF (NEQ (fetch OPNAME of (CAR CODE))
+                                              'CONST))
+                    (COMP.PROGLST A 1))
+                   ([NULL (SETQ C (fetch OPARG of (CAR CODE]
+                                                             (* (EQ NIL --))
+                    (COMP.DELPUSH)
+                    (RETURN (COMP.NOT A)))
+                   (T (COMP.DELPUSH)
+                      (COMP.PROGLST A 1)
+                      (COND
+                         [(EQ (fetch OPNAME of (CAR CODE))
+                              'CONST)                        (* (EQ CONST CONST))
+                          (RETURN (COMP.STCONST (PROG1 (APPLY* (CAR EXP)
+                                                                  C
+                                                                  (fetch OPARG
+                                                                     of (CAR CODE)))
+                                                           (COMP.DELPUSH]
+                         (T                                  (* (EQ CONST EXPRESSION))
+                            (COMP.STCONST C]
+                (RETURN (COMP.STFN (COND
+                                          ([AND (EQ (fetch OPNAME of (CAR CODE))
+                                                    'CONST)
+                                                (LITATOM (fetch OPARG of (CAR CODE]
+                                                             (* EQ IFF EQUAL)
+                                           'EQ)
+                                          (T (CAR EXP)))
+                               2])
+)
+
+(PUTPROPS .TEST. BYTEMACRO (APPLY COMP.NUMBERTEST))
+(DEFINEQ
+
+(COMP.NUMBERTEST
+  [LAMBDA (X FORM FLG)                                       (* lmm "13-Jul-84 21:18")
+    (PROG (EXIT (TEST (SUBPAIR '                             (*)
+                             (LIST DONOTHING)
+                             FORM))
+                A)
+          (COMP.EXPR X)
+          (RETURN (SELECTQ (AND (COMP.PREDP COMPILE.CONTEXT)
+                                (fetch OPNAME of COMPILE.CONTEXT))
+                      ((FJUMP TJUMP NFJUMP)                  (* .TEST. in PREDF)
+                           (COMP.EXPR TEST COMPILE.CONTEXT))
+                      (NTJUMP [COND
+                                 ((OR (FMEMB (fetch OPNAME of (SETQ A (CAR CODE)))
+                                             '(AVAR HVAR GVAR FVAR))
+                                      (AND (EQ (fetch OPNAME of A)
+                                               'SETQ)
+                                           (PROGN (SETQ A (fetch OPARG of A))
+                                                  T)))       (* .TEST. VAR in NTJUMP)
+                                  [COMP.EXPR TEST (create JUMP
+                                                             OPNAME _ 'FJUMP
+                                                             TAG _ (SETQ EXIT (create TAG]
+                                  (COMP.STVAR A)
+                                  (COMP.STJUMP 'JUMP (fetch (JUMP TAG) of COMPILE.CONTEXT
+                                                                ))
+                                  (COMP.STTAG EXIT)
+                                  (RETURN 'PREDVALUE))
+                                 (T                          (* .TEST. in NTJUMP PREDF)
+                                    (COMP.STCOPY)
+                                    [COMP.EXPR TEST (create JUMP
+                                                               OPNAME _ 'FJUMP
+                                                               TAG _ (SETQ EXIT (create TAG]
+                                    (COMP.STJUMP 'JUMP (fetch (JUMP TAG) of 
+                                                                                      COMPILE.CONTEXT
+                                                                  ))
+                                    (COMP.STTAG EXIT)
+                                    (COMP.STPOP)
+                                    (RETURN 'PREDVALUE])
+                      (COND
+                         ((OR (FMEMB (fetch OPNAME of (SETQ A (CAR CODE)))
+                                     '(AVAR HVAR GVAR FVAR))
+                              (AND (EQ (fetch OPNAME of A)
+                                       'SETQ)
+                                   (PROGN (SETQ A (fetch OPARG of A))
+                                          T)))               (* .TEST. VAR not in PREDF)
+                          [COMP.EXPR TEST (create JUMP
+                                                     OPNAME _ 'NFJUMP
+                                                     TAG _ (SETQ EXIT (create TAG]
+                          (COMP.STVAR A)
+                          (COMP.STTAG EXIT))
+                         (T                                  (* .TEST. not in PREDF)
+                            (COMP.STCOPY)
+                            [COMP.EXPR TEST (create JUMP
+                                                       OPNAME _ 'TJUMP
+                                                       TAG _ (SETQ EXIT (create TAG]
+                            (COMP.STPOP)
+                            (COMP.STCONST)
+                            (COMP.STTAG EXIT])
+)
+
+(RPAQQ MAPFNS (MAP MAPC MAPLIST MAPCAR MAPCON MAPCONC SUBSET SOME EVERY NOTANY NOTEVERY))
+
+(PUTPROPS MAP BYTEMACRO (APPLY* COMP.MAP))
+
+(PUTPROPS MAPC BYTEMACRO (APPLY* COMP.MAP T))
+
+(PUTPROPS MAPLIST BYTEMACRO (APPLY* COMP.MAP NIL T))
+
+(PUTPROPS MAPCAR BYTEMACRO (APPLY* COMP.MAP T T))
+
+(PUTPROPS MAPCON BYTEMACRO (APPLY* COMP.MAP NIL J))
+
+(PUTPROPS MAPCONC BYTEMACRO (APPLY* COMP.MAP T J))
+
+(PUTPROPS SUBSET BYTEMACRO (APPLY* COMP.MAP T S))
+
+(PUTPROPS SOME BYTEMACRO (APPLY* COMP.MAP BOTH NIL TJUMP))
+
+(PUTPROPS EVERY BYTEMACRO (APPLY* COMP.MAP BOTH NIL FJUMP T))
+
+(PUTPROPS NOTANY BYTEMACRO (APPLY* COMP.MAP BOTH NIL TJUMP T))
+
+(PUTPROPS NOTEVERY BYTEMACRO (APPLY* COMP.MAP BOTH NIL FJUMP NIL))
+
+(PUTPROPS .DOCOLLECT. BYTEMACRO [(VAL TAIL ITEM)
+                                         (COND
+                                            [(NOT TAIL)
+                                             (SETQ TAIL (SETQ VAL (LIST ITEM]
+                                            (T (FRPLACD TAIL (SETQ TAIL (LIST ITEM])
+
+(PUTPROPS .DOJOIN. BYTEMACRO [(VAL TAIL ITEM)
+                                      (AND (LISTP ITEM)
+                                           (COND
+                                              (TAIL (FRPLACD (SETQ TAIL (LAST TAIL))
+                                                           ITEM))
+                                              (T (SETQ TAIL (SETQ VAL ITEM])
+(DEFINEQ
+
+(COMP.MAP
+  [LAMBDA (L CARFLG COLLECT PRED NEG WHILEF)                 (* lmm "18-Sep-84 17:05")
+                                                             (* compile call to mapping function)
+    (PROG [(FROMFORM (CAR L))
+           (DOF (CADR L))
+           (BYF (CADDR L))
+           BOUNDVARS BINDVALS F VAL (XARG '($X]
+          (COMP.PROGLST (CDDDR L)
+                 0)
+          [COND
+             [(COMP.APPLYFNP DOF)
+              (SETQ DOF (CADR DOF))
+              (COND
+                 ((AND (NOT CARFLG)
+                       (EQ (CAR (LISTP DOF))
+                           'LAMBDA))                         (* leave DOF alone)
+                  NIL)
+                 (T (SETQ DOF (LIST 'LAMBDA XARG (CONS DOF
+                                                       (COND
+                                                          ([AND (EQ CARFLG 'BOTH)
+                                                                (NOT (AND (COMP.CLEANFNP
+                                                                           DOF
+                                                                           'NARGS)
+                                                                          (EQ (NARGS DOF)
+                                                                              1]
+                                                           '((CAR $X)
+                                                             $X))
+                                                          [CARFLG '((CAR $X]
+                                                          (T '($X]
+             (T                                              (* map function with computed 
+                                                           functional arg)
+                (SETQ BINDVALS (LIST DOF FROMFORM))
+                [SETQ BOUNDVARS (LIST '$F1 (SETQ FROMFORM '$L]
+                (SETQ DOF (LIST 'LAMBDA XARG (SELECTQ CARFLG
+                                                 (BOTH '(APPLY* $F1 (CAR $X)
+                                                               $X))
+                                                 (NIL '(APPLY* $F1 $X))
+                                                 '(APPLY* $F1 (CAR $X]
+          [COND
+             ((NULL BYF)
+              (SETQ BYF 'CDR))
+             [(COMP.APPLYFNP BYF)                        (* mapping function with BY argument)
+              (OR (EQ [CAR (LISTP (SETQ BYF (CADR BYF]
+                      'LAMBDA)
+                  (SETQ BYF (LIST 'LAMBDA XARG (LIST BYF '$X]
+             (T                                              (* mapping function with computed BY 
+                                                           argument)
+                (SETQ BINDVALS (CONS BYF BINDVALS))
+                (SETQ BOUNDVARS (CONS '$F2 BOUNDVARS))
+                (SETQ BYF '(LAMBDA ($X)
+                             (COND
+                                ((NULL $F2)
+                                 (CDR $X))
+                                (T (APPLY* $F2 $X]
+          [COND
+             ((NULL WHILEF)
+              (SETQ WHILEF 'LISTP))
+             [(COMP.APPLYFNP WHILEF)
+              (OR (EQ [CAR (LISTP (SETQ WHILEF (CADR WHILEF]
+                      'LAMBDA)
+                  (SETQ WHILEF (LIST 'LAMBDA XARG (LIST WHILEF '$X]
+             (T (SETQ BINDVALS (CONS (LIST 'OR WHILEF ''LISTP)
+                                     BINDVALS))
+                (SETQ BOUNDVARS (CONS '$F3 BOUNDVARS))
+                (SETQ WHILEF '(LAMBDA ($X)
+                                (APPLY* $F3 $X]
+          [COND
+             (COLLECT (push BINDVALS NIL NIL NIL NIL)
+                    (push BOUNDVARS (SETQ VAL '$V)
+                           '$Z
+                           '$W
+                           '$X]                              (* bind extra vars)
+          (SETQ F (COMP.BIND.VARS (OPT.DREV BOUNDVARS)
+                         (OPT.DREV BINDVALS)
+                         'MAP))
+          [PROG ((ALLVARS (APPEND (fetch VARS of F)
+                                 ALLVARS))
+                 (SPECVARS SPECVARS)
+                 (LOCALVARS LOCALVARS)
+                 (LP (create TAG))
+                 (ENDLP (create TAG))
+                 (OUT (create TAG))
+                 NXT)
+                (COMP.STBIND F)
+                [COMP.EFFECT '(DECLARE (LOCALVARS $F1 $F2 $X $V $Z $W $F3]
+                (COMP.VAL FROMFORM)
+                (OPT.CCHECK (AND (EQ LEVEL 1)
+                                     (EQ FRAME F)))
+                (COMP.STJUMP 'JUMP ENDLP)
+                (SETQ LEVEL 1)
+                (SETQ FRAME F)
+                (COMP.STTAG LP)
+                (COMP.STCOPY)
+                [COND
+                   (COLLECT (OPT.CCHECK (NOT PRED))
+                          (SELECTQ COLLECT
+                              ((T J)                         (* collect or join)
+                                   (COMP.EFFECT (LIST 'SETQ '$X DONOTHING))
+                                   [COMP.EFFECT (LIST 'SETQ '$W (COND
+                                                                       ((EQ (CADR DOF)
+                                                                            XARG)
+                                                                        (CADDR DOF))
+                                                                       (T (LIST DOF '$X]
+                                   [COMP.EFFECT (SELECTQ COLLECT
+                                                        (J '(.DOJOIN. $V $Z $W))
+                                                        '(.DOCOLLECT. $V $Z $W])
+                              (S                             (* SUBSET)
+                                 [COMP.EXPR (LIST DOF DONOTHING)
+                                        (create JUMP
+                                               OPNAME _ 'FJUMP
+                                               TAG _ (SETQ NXT (create TAG]
+                                 (COMP.STCOPY)
+                                 (COMP.EFFECT (LIST 'SETQ '$W (LIST 'CAR DONOTHING)))
+                                 (COMP.EFFECT '(.DOCOLLECT. $V $Z $W))
+                                 (COMP.STTAG NXT))
+                              (SHOULDNT)))
+                   (PRED (COMP.EXPR (LIST DOF DONOTHING)
+                                (create JUMP
+                                       OPNAME _ PRED
+                                       TAG _ OUT)))
+                   (T (COMP.EFFECT (LIST DOF DONOTHING]
+                (OPT.CCHECK (EQ LEVEL 1))
+                (COMP.EXPR (LIST BYF DONOTHING))         (* get next element)
+                (COMP.STTAG ENDLP)
+                (COMP.EXPR (LIST WHILEF DONOTHING))
+                (COMP.STJUMP 'NTJUMP LP)
+                (COND
+                   [PRED (COND
+                            ((AND (EQ PRED 'TJUMP)
+                                  (NULL NEG))
+                             (COMP.VAL NIL)
+                             (COMP.STTAG OUT))
+                            (T (COMP.VAL NEG)
+                               (COMP.STJUMP 'JUMP (SETQ NXT (create TAG)))
+                               (COMP.STTAG OUT)
+                               (COMP.STPOP)
+                               (COMP.VAL (NULL NEG))
+                               (COMP.STTAG NXT]
+                   (T (COMP.VAL VAL]
+          (RETURN (COMP.UNBIND.VARS F])
+)
+
+(PUTPROPS LISPXWATCH BYTEMACRO T)
+
+(DEFOPTIMIZER BLKAPPLY (&REST ARGS)
+                           (CONS 'APPLY ARGS))
+
+(DEFOPTIMIZER BLKAPPLY* (&REST ARGS)
+                            (CONS 'APPLY* ARGS))
+
+(DEFOPTIMIZER ADD1VAR (X)
+                          `(SETQ ,X (ADD1 ,X)))
+
+(DEFOPTIMIZER KWOTE (&REST ARGS)
+                        (CONS '(OPENLAMBDA (Q)
+                                      (COND
+                                         ((AND Q (NEQ Q T)
+                                               (NOT (NUMBERP Q)))
+                                          (LIST 'QUOTE Q))
+                                         (T Q)))
+                              ARGS))
+
+(DEFOPTIMIZER FRPLNODE (&REST ARGS)
+                           (CONS '(OPENLAMBDA (X A D)
+                                         (FRPLACD (FRPLACA X A)
+                                                D))
+                                 ARGS))
+
+(DEFOPTIMIZER RPLNODE (&REST ARGS)
+                          (CONS '(OPENLAMBDA (X A D)
+                                        (RPLACD (RPLACA X A)
+                                               D))
+                                ARGS))
+
+(DEFOPTIMIZER LISTGET1 (&REST ARGS)
+                           (CONS '(OPENLAMBDA (X Y)
+                                         (CADR (MEMB Y X)))
+                                 ARGS))
+
+(DEFOPTIMIZER FRPLNODE2 (&REST ARGS)
+                            (CONS '(OPENLAMBDA (X Y)
+                                          (FRPLACD (FRPLACA X (CAR Y))
+                                                 (CDR Y)))
+                                  ARGS))
+
+(PUTPROPS SUB1VAR BYTEMACRO ((X)
+                                     (SETQ X (SUB1 X))))
+
+(DEFOPTIMIZER EQMEMB (&REST ARGS)
+                         (CONS '(OPENLAMBDA (X Y)
+                                       (OR (EQ X Y)
+                                           (AND (LISTP Y)
+                                                (FMEMB X Y)
+                                                T)))
+                               ARGS))
+
+(DEFOPTIMIZER MKLIST (&REST ARGS)
+                         (CONS '[OPENLAMBDA (X)
+                                       (OR (LISTP X)
+                                           (AND X (LIST X]
+                               ARGS))
+
+
+
+(* ;; "Pass 1 listing")
+
+(DEFINEQ
+
+(COMP.MLLIST
+  [LAMBDA (FN CC)                                            (* lmm%: "13-NOV-76 06:56:28")
+    (RESETLST
+        (RESETSAVE (RADIX 10))
+        (RESETSAVE (LINELENGTH 72))
+        (PRIN2 FN)
+        (MAPRINT (fetch ARGS of CC)
+               NIL "(" ")" " " (FUNCTION COMP.MLLVAR))
+        (SPACES 5)
+        [PRINT (CDR (FASSOC (fetch COMTYPE of CC)
+                           '((0 . LAMBDA)
+                             (2 . LAMBDA*)
+                             (1 . NLAMBDA)
+                             (2 . NLAMBDA*)
+                             (NIL . ???]
+        (COMP.MLL (fetch CODE of CC)))])
+
+(COMP.MLL
+  [LAMBDA (LL)                                               (* Pavel "15-Nov-86 16:02")
+    [for X in LL
+       do
+       (if (type? TAG X)
+           then (if (NOT (ZEROP (POSITION)))
+                        then (TERPRI))
+                 (PRIN2 (fetch (TAG LBNO) of X))
+                 (PRIN1 '%:)
+         else (PROG ((S (GETPROP (fetch OPNAME of X)
+                                   'MLSYM))
+                         (P (POSITION)))
+                        (if (ILESSP P 5)
+                            then (SPACES (IDIFFERENCE 6 P))
+                          elseif (IGREATERP P 60)
+                            then (TERPRI)
+                                  (SPACES 6)
+                          else (SPACES 1))
+                        (AND (CAR S)
+                             (PRIN1 (CAR S)))
+                        [SELECTQ (CDDR S)
+                            (CONST (PRIN2 (FETCH OPARG OF X)))
+                            (VAR (COMP.MLLVAR X))
+                            (FN                              (* ; "FN and LINKEDFN")
+                                (COMP.MLLFN X))
+                            (VREF                            (* ; "SETQ ARG")
+                                  (COMP.MLLVAR (fetch OPARG of X)))
+                            (JUMP (PRIN2 (fetch (TAG LBNO) of (fetch (JUMP TAG)
+                                                                         of X))))
+                            (BIND (PROG [NN N (F (CDR (FETCH OPARG OF X]
+                                        (SETQ N (SETQ NN (FETCH NVALS OF F)))
+                                        (FOR V IN (FETCH VARS OF F)
+                                           DO (PRIN1 (IF (EQ N NN)
+                                                             THEN 
+                                                             (* ; "1ST one")
+                                                                   ""
+                                                           ELSEIF (ZEROP N)
+                                                             THEN ';
+                                                           ELSE '%,))
+                                                 (SETQ N (IPLUS N -1))
+                                                 (COMP.MLLVAR V))
+                                        (if (ZEROP N)
+                                            then         (* ; "All val-bound")
+                                                  (PRIN1 ";"))))
+                            (UNBIND (PRIN1 (CAR (fetch OPARG of X))))
+                            (PROGN (PRIN1 (fetch OPNAME of X))
+                                   (AND (fetch OPARG of X)
+                                        (PRIN1 (LIST (fetch OPARG of X]
+                        (AND (CADR S)
+                             (PRIN1 (CADR S]
+    (TERPRI)
+    (TERPRI])
+
+(COMP.MLLVAR
+  [LAMBDA (X N)                                              (* Pavel "15-Nov-86 16:02")
+    (SETQ N (FETCH (VAR VARNAME) OF X))
+    (PRIN2 (SELECTQ (FETCH OPNAME OF X)
+               (HVAR (PRIN1 "@")
+                     N)
+               (XVAR 'XVAR)
+               N])
+
+(COMP.MLLFN
+  [LAMBDA (X FN)                                             (* Pavel "15-Nov-86 16:03")
+    [PRIN2 (SETQ FN (CDR (FETCH OPARG OF X]
+    (SETQ X (CAR (FETCH OPARG OF X)))
+    (AND (LITATOM FN)
+         (OR (AND (ZEROP (ARGTYPE FN))
+                  (EQ (NARGS FN)
+                      X))
+             (PROGN (SPACES 1)
+                    (PRIN2 X])
+)
+
+(RPAQQ COPS (BIND UNBIND DUNBIND ERRORSET JUMP TJUMP FJUMP NTJUMP NFJUMP POP COPY RETURN TAG FN 
+                      CONST SETQ AVAR HVAR GVAR FVAR STORE))
+
+(PUTPROPS BIND MLSYM ("BIND[" %] . BIND))
+
+(PUTPROPS UNBIND MLSYM ("UNBIND(" %) . UNBIND))
+
+(PUTPROPS DUNBIND MLSYM ("DUNBIND(" %) . UNBIND))
+
+(PUTPROPS ERRORSET MLSYM ("ERRORSET " %
+ . JUMP))
+
+(PUTPROPS JUMP MLSYM ("JUMP " %
+ . JUMP))
+
+(PUTPROPS TJUMP MLSYM ("TJUMP " %
+ . JUMP))
+
+(PUTPROPS FJUMP MLSYM ("FJUMP " %
+ . JUMP))
+
+(PUTPROPS NTJUMP MLSYM ("NTJUMP " %
+ . JUMP))
+
+(PUTPROPS NFJUMP MLSYM ("NFJUMP " %
+ . JUMP))
+
+(PUTPROPS FN MLSYM (%[ %] . FN))
+
+(PUTPROPS CONST MLSYM ("'" NIL . CONST))
+
+(PUTPROPS SETQ MLSYM ("SETQ<" > . VREF))
+
+(PUTPROPS AVAR MLSYM (< > . VAR))
+
+(PUTPROPS HVAR MLSYM (< > . VAR))
+
+(PUTPROPS GVAR MLSYM (< > . VAR))
+
+(PUTPROPS FVAR MLSYM (< > . VAR))
+
+
+
+(* ;; "ARJ --- JUMP LENGTH RESOLVER")
+
+(DEFINEQ
+
+(OPT.RESOLVEJUMPS
+  [LAMBDA (JL PROP FN)                                       (* lmm "19-JUL-80 10:00")
+    (PROG ((CU 0)
+           Z NEW)
+          [for X in JL do (replace JSN of X with (fetch JMIN of
+                                                                                         X))
+                                     (COND
+                                        [(fetch JPT of X)
+                                                             (* Jump)
+                                         (SETQ Z (CAR (GETPROP (fetch OPNAME
+                                                                  of (CAR (fetch JPT
+                                                                                 of X)))
+                                                             PROP)))
+                                         (replace JML of X with (CAR Z))
+                                         (add CU (replace JU of X
+                                                        with (IDIFFERENCE (CDR Z)
+                                                                        (CAR Z]
+                                        (T                   (* Tag)
+                                           (replace JU of X with CU]
+          (while (LISTP (SETQ NEW (OPT.JLENPASS JL PROP))) do (SETQ JL NEW))
+          (COND
+             (NEW (OPT.JFIXPASS JL FN])
+
+(OPT.JLENPASS
+  [LAMBDA (JL PROP)                                          (* lmm "19-JUL-80 10:08")
+    (PROG ((INC 0)
+           (DEC 0)
+           (CU 0)
+           X U U1 DEF MIN ML SMIN SMAX)
+
+         (* JPT is NIL (for tags) or a pointer into ACODE
+       (for jumps)%. JMIN is the lowest possible location for the instruction or tag.
+       JU is the cumulative uncertainty (for tags) or the length uncertainty
+       (for jumps)%. JML is the minimum length
+       (for jumps)%. JSN is a serial number (the original JMIN) used to decide whether 
+       a jump goes forward or backward.)
+
+         (* In the loop, CU is the cumulative uncertainty, DEC is the cumulative 
+       decrease in uncertainty, and INC is the cumulative increase in minimum 
+       location.)
+
+          [for J in JL do (SETQ X (CAR (fetch JPT of J)))
+                                     (add (fetch JMIN of J)
+                                            INC)
+                                     (COND
+                                        ((NULL X)
+                                         (SETQ DEC (IDIFFERENCE CU (fetch JU of J)))
+                                         (replace JU of J with CU))
+                                        ((NEQ (SETQ U (fetch JU of J))
+                                              0)
+                                         [SETQ DEF (fetch (TAG JD)
+                                                      of (CAR (fetch OPARG of X]
+                                         (SETQ MIN (IDIFFERENCE (fetch JMIN of DEF)
+                                                          (fetch JMIN of J)))
+                                         (SETQ SMAX (OPT.JSIZE X
+                                                           (IPLUS (IDIFFERENCE (fetch JU
+                                                                                  of DEF)
+                                                                         CU)
+                                                                  (COND
+                                                                     ((IGREATERP (fetch JSN
+                                                                                    of DEF)
+                                                                             (fetch JSN
+                                                                                of J))
+                                                                      (IPLUS (SETQ MIN
+                                                                              (IPLUS MIN INC))
+                                                                             DEC))
+                                                                     (T MIN)))
+                                                           PROP))
+                                         (SETQ SMIN (OPT.JSIZE X MIN PROP))
+                                         [COND
+                                            ((NEQ SMIN (SETQ ML (fetch JML of J)))
+                                             (replace JML of J with SMIN)
+                                             (add INC (IDIFFERENCE SMIN ML]
+                                         (COND
+                                            ((NEQ (SETQ U1 (IDIFFERENCE SMAX SMIN))
+                                                  U)
+                                             [COND
+                                                ((ILESSP U1 0)
+                                                 (OPT.COMPILERERROR '(U1 negative]
+                                             (add DEC (IDIFFERENCE U1 U))
+                                             (replace JU of J with U1)))
+                                         (add CU U1]
+          (RETURN (COND
+                     ((AND (NEQ DEC 0)
+                           (NEQ CU 0))
+                      JL)
+                     (T T])
+
+(OPT.JFIXPASS
+  [LAMBDA (JL FN)                                            (* lmm "19-JUL-80 10:23")
+    (PROG (X)
+          (for J in JL
+             do (COND
+                       ([NULL (SETQ X (CAR (fetch JPT of J]
+                        (replace JU of J with 0))
+                       (T (APPLY* FN (fetch JPT of J)
+                                 (IDIFFERENCE [fetch JMIN
+                                                 of (fetch (TAG JD)
+                                                           of (CAR (fetch OPARG of X]
+                                        (fetch JMIN of J])
+
+(OPT.JSIZE
+  [LAMBDA (OP D FN)                                          (* lmm "27-OCT-81 20:28")
+    (PROG [(Z (CDR (GETPROP (fetch OPNAME of OP)
+                          FN]
+      LP  (COND
+             ((NLISTP Z)
+              (RETURN Z))
+             (T [SETQ Z (COND
+                           ((ILESSP D (CAR Z))
+                            (CADR Z))
+                           (T (CDDR Z]
+                (GO LP])
+)
+
+
+
+(* ;; "Utilities used by all files")
+
+(DEFINEQ
+
+(OPT.CALLP
+  [LAMBDA (OP FN N)                                          (* lmm%: "22-JUL-77 02:40")
+    (AND (EQ (fetch OPNAME of OP)
+             'FN)
+         (OR (NULL N)
+             (EQ (CAR (fetch OPARG of OP))
+                 N))
+         (OR (NULL FN)
+             (EQ (CDR (fetch OPARG of OP))
+                 FN)
+             (AND (LISTP FN)
+                  (FMEMB (CDR (fetch OPARG of OP))
+                         FN])
+
+(OPT.JUMPCHECK
+  [LAMBDA (C)                                                (* lmm%: "22-JUL-77 02:39")
+    (SELECTQ (fetch OPNAME of (CAR C))
+        ((JUMP RETURN) 
+             T)
+        NIL])
+
+(OPT.DREV
+  [LAMBDA (L Z)
+    (PROG (Y)
+      R1  (COND
+             ((NLISTP (SETQ Y L))
+              (RETURN Z)))
+          (SETQ L (CDR L))
+          (SETQ Z (FRPLACD Y Z))
+          (GO R1])
+
+(OPT.CHLEV
+  [LAMBDA (N)                                                (* lmm "14-MAR-81 09:54")
+    (COND
+       (LEVEL (PROG1 (add LEVEL N)
+                  (OPT.CCHECK (IGEQ LEVEL 0)))])
+
+(OPT.CHECKTAG
+  [LAMBDA (TAG TAGFLAG)                                      (* lmm "14-MAR-81 09:15")
+    (COND
+       ((NULL LEVEL)
+        (replace (TAG LEVEL) of TAG with NIL))
+       ((NULL (fetch (TAG LEVEL) of TAG))
+        (AND TAGFLAG (SETQ LEVEL NIL)))
+       (T (OPT.CCHECK (EQ LEVEL (fetch (TAG LEVEL) of TAG)))
+          T])
+
+(OPT.NOTJUMP
+  [LAMBDA (X)                                                (* lmm%: "22-JUL-77 03:39")
+    (PROG NIL
+          (RETURN (create OP
+                         OPNAME _ (OR (SELECTQ (fetch OPNAME of X)
+                                          (FJUMP 'TJUMP)
+                                          (TJUMP 'FJUMP)
+                                          NIL)
+                                      (RETURN))
+                         OPARG _ (fetch OPARG of X])
+
+(OPT.INITHASH
+  [NLAMBDA (X)                                               (* ; "Edited  3-Oct-88 16:42 by tal")
+    (DECLARE (LOCALVARS . T))
+    (LET ((H (EVALV X)))
+         (COND
+            [(HARRAYP H)
+             (COND
+                ((NEQ (HARRAYPROP H 'NUMKEYS)
+                      0)
+                 (CLRHASH H]
+            (T (SET X (HASHARRAY 100])
+
+(OPT.COMPINIT
+  [LAMBDA NIL                                                (* lmm%: "22-JUL-77 16:51")
+    [MAPC '((OPRETURN . RETURN)
+            (OPPOP . POP)
+            (OPCOPY . COPY)
+            (OPNIL . CONST))
+          (FUNCTION (LAMBDA (X)
+                      (SET (CAR X)
+                           (create OP
+                                  OPNAME _ (CDR X]
+    (SETQ DONOTHING (LIST 'AC])
+)
+
+(MOVD? 'NILL 'REFRAME)
+
+(AND (GETD 'OPT.COMPINIT)
+     (OPT.COMPINIT))
+
+(PUTPROPS LOADTIMECONSTANT BYTEMACRO (= . DEFERREDCONSTANT))
+
+(PUTPROPS FRPTQ BYTEMACRO OPT.CFRPTQ)
+(DEFINEQ
+
+(OPT.CFRPTQ
+  [LAMBDA (L)                                                (* lmm "29-Jun-84 08:25")
+    (COND
+       ((EQ COMPILE.CONTEXT 'EFFECT)
+        (PROG ((END (create TAG))
+               (ST (create TAG)))
+              (COMP.VAL (CAR L))                         (* counter)
+              (COMP.STTAG ST)
+              (COMP.STCOPY)
+              (COMP.VAL 0)
+              (COMP.STFN 'IGREATERP 2)
+              (COMP.STJUMP 'FJUMP END)
+              (COMP.VALN (CDR L)
+                     'EFFECT)
+              (COMP.VAL 1)
+              (COMP.STFN 'IDIFFERENCE 2)
+              (COMP.STJUMP 'JUMP ST)
+              (COMP.STTAG END)))
+       (T (COMP.EXP1 (CONS 'RPTQ L])
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(SPECVARS AC ALAMS1 ALLVARS ARGS ARGVARS BLKDEFS BLKFLG CODE COMFN COMFNS COMTYPE CONSTS EMFLAG EXP 
+       FRAME FREELST FREEVARS LAPFLG LBCNT LEVEL LOCALVARS LOCALVARS LSTFIL MACEXP NLAMS1 PIFN 
+       COMPILE.CONTEXT PROGCONTEXT RETURNLABEL SPECVARS SPECVARS SUBFNFREEVARS TAGS TOPFN TOPFRAME 
+       TOPLAB VARS INTERNALBLKFNS)
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(SPECVARS PLVLFILEFLG)
+)
+)
+
+(PUTPROPS IMAX2 BYTEMACRO (OPENLAMBDA (X Y)
+                                         (COND
+                                            ((NOT (IGREATERP X Y))
+                                             Y)
+                                            (T X))))
+
+(PUTPROPS IMIN2 BYTEMACRO (OPENLAMBDA (X Y)
+                                         (COND
+                                            ((IGREATERP X Y)
+                                             Y)
+                                            (T X))))
+
+(PUTPROPS FLOAT BOX (\FLOATBOX . \FLOATUNBOX))
+(DEFINEQ
+
+(COMP.AREF
+  [LAMBDA (A)                                                (* raf "18-Jun-85 17:52")
+    (PROG (DECL)
+          [COND
+             ([AND (LITATOM (CAR A))
+                   (EQ [CAR (SETQ DECL (CDR (FASSOC (COMP.LOOKUPVAR (CAR A))
+                                                   ALLDECLS]
+                       'ARRAY)
+                   (EQ (LENGTH (MKLIST (CADDR DECL)))
+                       (LENGTH (CDR A]
+              (COND
+                 ((EQUAL (CADR DECL)
+                         '(BYTE 16))
+                  (RETURN (COMP.EXPR (CONS '\16AREF A)
+                                 COMPILE.CONTEXT)))
+                 ((FMEMB (CADR DECL)
+                         '(FLOATP FLONUM))
+                  (RETURN (COMP.EXPR (CONS '\LAREF A)
+                                 COMPILE.CONTEXT)))
+                 (T (HELP]
+          (MAPC A (FUNCTION COMP.VAL))
+          (COMP.STFN (SELECTQ (LENGTH A)
+                             (2 '\AREF.1)
+                             (3 '\AREF.2)
+                             'LISP:AREF)
+                 (LENGTH A])
+
+(COMP.ASET
+  [LAMBDA (A)                                                (* kbr%: "12-Mar-85 17:08")
+    (PROG (DECL)
+          [COND
+             ([AND (LITATOM (CADR A))
+                   (EQ [CAR (SETQ DECL (CDR (FASSOC (COMP.LOOKUPVAR (CADR A))
+                                                   ALLDECLS]
+                       'ARRAY)
+                   (EQ (LENGTH (MKLIST (CADDR DECL)))
+                       (LENGTH (CDDR A]
+              (COND
+                 ((EQUAL (CADR DECL)
+                         '(BYTE 16))
+                  (RETURN (COMP.EXPR (CONS '\16ASET A)
+                                 COMPILE.CONTEXT)))
+                 ((FMEMB (CADR DECL)
+                         '(FLOATP FLONUM))
+                  (RETURN (COMP.EXPR (CONS '\LASET A)
+                                 COMPILE.CONTEXT)))
+                 (T (HELP]
+          (MAPC A (FUNCTION COMP.VAL))
+          (COMP.STFN (SELECTQ (LENGTH A)
+                             (3 '\ASET.1)
+                             (4 '\ASET.2)
+                             'ASET)
+                 (LENGTH A])
+
+(COMP.BOX
+  [LAMBDA (TYPE)                                             (* lmm " 1-Jul-84 17:45")
+    (PROG [(BOXER (AND (LITATOM TYPE)
+                       (GETPROP TYPE 'BOX]
+          (if BOXER
+              then (if (OPT.CALLP (CAR CODE)
+                                      (CDR BOXER)
+                                      1)
+                           then                          (* top of stack was
+                                                           (unbox value)%, just get rid of BOX)
+                                 (COMP.DELFN)
+                                 (COMP.STFIX TYPE)
+                         else (COMP.STFN (CAR BOXER)
+                                         1])
+
+(COMP.LOOKFORDECLARE
+  [LAMBDA (EXPS)                                             (* lmm " 1-Jul-84 16:54")
+    (while (EQ (CAR (LISTP (CAR EXPS)))
+                   COMMENTFLG) do (pop EXPS))
+    (if (EQ (CAR (LISTP (CAR EXPS)))
+                'DECLARE)
+        then (for Y in (CDAR EXPS) bind DECLS
+                    do (SELECTQ (CAR Y)
+                               (TYPE [for Z in (CDDR Y)
+                                        do (push DECLS (CONS Z (COMP.DECLARETYPE
+                                                                        (CADR Y])
+                               NIL) finally (RETURN DECLS])
+
+(COMP.DECLARETYPE
+  [LAMBDA (X)                                                (* lmm "13-Jul-84 22:19")
+                                                             (* returns a valid compile context, 
+                                                           too)
+    (SELECTQ X
+        ((FLOATING FLOATP FLOAT) 
+
+         (* if you declare a variable to be FLOAT, you are really saying to hold it "unboxed")
+
+             '(UNBOXED . FLOAT))
+        (if (LISTP X)
+            then (SELECTQ (CAR X)
+                         (ARRAY X)
+                         NIL])
+
+(COMP.FLOATBOX
+  [LAMBDA NIL                                                (* lmm "28-Jun-84 15:09")
+    (COND
+       ((OPT.CALLP (CAR CODE)
+               '\FLOATUNBOX 1)
+        (COMP.DELFN))
+       (T (COMP.STFN '\FLOATBOX 1])
+
+(COMP.FLOATUNBOX
+  [LAMBDA NIL                                                (* lmm "28-Jun-84 15:08")
+    (PROGN (COMP.DELFIX 'FLOAT)
+           (COND
+              ((OPT.CALLP (CAR CODE)
+                      '\FLOATBOX 1)
+               (COMP.DELFN))
+              [[AND (EQ (fetch OPNAME of (CAR CODE))
+                        'CONST)
+                    (NUMBERP (fetch OPARG of (CAR CODE]
+               (PROG [(NUM (fetch OPARG of (CAR CODE]
+                     (COMP.DELPUSH)
+                     (if (EQUAL (SETQ NUM (FLOAT NUM))
+                                    0)
+                         then (COMP.STCONST NIL)
+                       else (COMP.EXPR `(\VAG2 %, (fetch (FLOATP HIWORD) of NUM)
+                                                       %,
+                                                       (fetch (FLOATP LOWORD) of NUM]
+              (T (COMP.STFN '\FLOATUNBOX 1])
+
+(COMP.PREDP
+  [LAMBDA (CTX)                                              (* lmm "29-Jun-84 08:30")
+    (AND (LISTP CTX)
+         (FMEMB (CAR CTX)
+                '(TJUMP FJUMP NTJUMP NFJUMP])
+
+(COMP.UBFLOAT2
+  [LAMBDA (A OP)                                             (* lmm "29-Jun-84 09:07")
+    (PROG ((N 0))
+          [COND
+             ((AND (EQ COMPILE.CONTEXT 'EFFECT)
+                   (NOT OPTIMIZATIONSOFF))
+              (RETURN (COMP.PROGN A]
+          (while A do (COMP.VAL (pop A))
+                             (COMP.FLOATUNBOX)
+                             (SETQ N (ADD1 N)))
+          (FRPTQ (SUB1 N)
+                 (COMP.STFN (LIST 'OPCODES 'UBFLOAT2 OP)
+                        1))
+          (COMP.FLOATBOX])
+
+(COMP.UNBOX
+  [LAMBDA (TYPE)                                             (* lmm "29-Dec-84 11:46")
+    (PROG [(BOXER (AND (LITATOM TYPE)
+                       (GETPROP TYPE 'BOX]
+          (if BOXER
+              then (COND
+                          ((OPT.CALLP (CAR CODE)
+                                  (CAR BOXER)
+                                  1)                         (* top of stack was
+                                                           (box value)%, just get rid of BOX)
+                           (COMP.DELFN))
+                          ((EQ TYPE 'FLOAT)
+                           (COMP.FLOATUNBOX))
+                          (T (HELP)
+
+         (* if top of stack is (convert-type value) then get rid of convert-type before 
+       putting in unbox)
+
+                             (COMP.DELFIX TYPE)
+                             (COMP.STFN (CDR BOXER)
+                                    1)))
+            else (HELP "CAN'T UNBOX" TYPE])
+)
+
+(ADDTOVAR COMPILETYPELST )
+
+
+
+(* ; "POST OPTIMIZATION")
+
+(DEFINEQ
+
+(OPT.POSTOPT
+  [LAMBDA (CODE)                                             (* lmm "29-Dec-84 20:48")
+    (COND
+       [OPTIMIZATIONSOFF (while CODE bind C VAL
+                            do (SETQ TAGS NIL)
+                                  (while (EQ (fetch OPNAME of (SETQ C (pop CODE)))
+                                                 'TAG) do (push TAGS C))
+                                  (while (AND (EQ (fetch OPNAME of C)
+                                                      'JUMP)
+                                                  (FMEMB (fetch OPARG of C)
+                                                         TAGS)) do (SETQ C (pop CODE)))
+                                  (for TAG in TAGS do (push VAL TAG))
+                                  (push VAL C) finally (RETURN (CDR VAL]
+       (T (PROG ((FRAME TOPFRAME)
+                 LISP:LABELS ANY (FRAMES (LIST (LIST TOPFRAME)))
+                 (PASS 1)
+                 DELETEDBINDS)
+                (SETQ CODE (CONS NIL (NCONC1 CODE NIL)))
+                (OPT.SETUPOPT)
+            OPTLP
+                (SETQ ANY)                                   (* optimization pass)
+                (AND (OPT.FRAMEOPT (EQ PASS 1))
+                     (SETQ ANY T))
+                (OPT.SCANOPT)
+                (OPT.JUMPOPT)
+                (OPT.RETOPT)
+                (OPT.CCHECK (OPT.OPTCHECK))
+                [COND
+                   ((NOT ANY)
+                    (AND [NOT (OR (AND XVARFLG (PROGN (OPT.XVARSCAN)
+                                                      (OPT.FRAMEOPT T NIL T)))
+                                  (AND MERGEFRAMEFLG (OPT.FRAMEOPT T T XVARFLG]
+                         (RETURN (CDR (OPT.DREV (CDR CODE]
+                (SETQ PASS (ADD1 PASS))
+                (BLOCK)
+                (GO OPTLP])
+
+(OPT.SETUPOPT
+  [LAMBDA NIL                                                (* lmm%: "22-JUL-77 02:59")
+                                                             (* set up code list as doubly linked 
+                                                           list, scan for tags)
+    (PROG ((C CODE)
+           P B)
+      LPC (COND
+             ((NULL C)
+              (RETURN)))
+          (SELECTQ (fetch OPNAME of (CAR C))
+              (TAG [COND
+                      ((SETQ B (FASSOC (CAR C)
+                                      LISP:LABELS))
+                       (FRPLACA (CDR B)
+                              C))
+                      (T (SETQ LISP:LABELS (CONS (LIST (CAR C)
+                                                       C)
+                                                 LISP:LABELS])
+              ((JUMP TJUMP FJUMP NTJUMP NFJUMP ERRORSET) 
+                   [COND
+                      ((SETQ B (FASSOC (fetch (JUMP TAG) of (CAR C))
+                                      LISP:LABELS))
+                       (NCONC1 B C))
+                      (T (SETQ LISP:LABELS (CONS (LIST (fetch (JUMP TAG) of (CAR C))
+                                                       NIL C)
+                                                 LISP:LABELS])
+              NIL)
+          (SELECTQ (fetch OPNAME of (CAR C))
+              ((ERRORSET BIND) 
+                   [COND
+                      ((SETQ B (FASSOC (CDR (fetch OPARG of (CAR C)))
+                                      FRAMES))
+                       (RPLACA (CDR B)
+                              C))
+                      (T (SETQ FRAMES (CONS (LIST (CDR (fetch OPARG of (CAR C)))
+                                                  C)
+                                            FRAMES])
+              ((UNBIND DUNBIND) 
+                   [COND
+                      ((SETQ B (FASSOC (CDR (fetch OPARG of (CAR C)))
+                                      FRAMES))
+                       (NCONC1 B C))
+                      (T (SETQ FRAMES (CONS (LIST (CDR (fetch OPARG of (CAR C)))
+                                                  NIL C)
+                                            FRAMES])
+              NIL)
+          (SETQ B (CDR C))
+          (replace PREV of C with B)
+          (replace NXT of C with P)
+          (SETQ P C)
+          (SETQ C B)
+          (GO LPC])
+
+(OPT.SCANOPT
+  [LAMBDA NIL                                                (* lmm "29-Apr-85 19:26")
+    (PROG ((CD CODE)
+           A B P X Y)
+      LP  (SETQ B (fetch PREV of CD))
+          [AND P (OPT.CCHECK (EQ CD (fetch PREV of P]
+          (SELECTQ (fetch OPNAME of (SETQ A (CAR CD)))
+              (CONST (COND
+                        ((AND (OPT.CALLP (CAR P)
+                                     NIL 1)
+                              (OR (FMEMB [SETQ X (CDR (fetch OPARG of (CAR P]
+                                         CONSTFNS)
+                                  (FMEMB X VCONDITIONALS)
+                                  (FMEMB X CONDITIONALS)))   (* CONST FN.1 -> (FN CONST))
+                         [RPLACA CD (create OP
+                                           OPNAME _ 'CONST
+                                           OPARG _ (APPLY* X (fetch OPARG of A]
+                         (OPT.PRDEL P)
+                         (GO BLP))
+                        ([AND (SETQ A (FASSOC (fetch OPARG of A)
+                                             CONST.FNS))
+                              (SOME (CDR A)
+                                    (FUNCTION (LAMBDA (X)
+                                                (OPT.CALLP (CAR P)
+                                                       (CAR (SETQ A (CDR X)))
+                                                       (CAR X]
+                                                             (* constant + fn -> otherfn)
+                         (OPT.PRDEL CD)
+                         (OPT.PRDEL P)
+                         [MAPC (CDR A)
+                               (FUNCTION (LAMBDA (X)
+                                           (SETQ B (OPT.PRATTACH (create OP
+                                                                            OPNAME _ (CAR X)
+                                                                            OPARG _ (CDR X))
+                                                          B]
+                         (GO BLP)))
+                     (GO CHECKPUSH))
+              (HVAR (GO CHECKPUSH))
+              ((AVAR GVAR FVAR) 
+                   (GO CHECKPUSH))
+              (SETQ (COND
+                       ((EQ (fetch OPARG of A)
+                            (CAR B))                         (* want OPT.EQVALUE B CD execept 
+                                                           OPT.EQVALUE takes the wrong kind of 
+                                                           arg)
+                                                             (* var (setq var) => var)
+                        (OPT.PRDEL CD)
+                        (GO BLP))
+                       ((OPT.DEADSETQP (fetch OPARG of A)
+                               P)                            (* delete dead SETQ)
+                        (OPT.PRDEL CD)
+                        (GO BLP))))
+              (POP (SELECTQ (fetch OPNAME of (CAR B))
+                       ((AVAR HVAR FVAR GVAR COPY CONST)     (* push POP deleted)
+                            (OPT.PRDEL B)
+                            (OPT.PRDEL CD)
+                            (SETQ B P)
+                            (GO BLP))
+                       (FN (COND
+                              ((COMP.CLEANFNOP (CDR (fetch OPARG of (CAR B)))
+                                      'NOSIDE)               (* cleanfn POP deleted)
+                               (RPTQ (PROG1 (CAR (fetch OPARG of (CAR B)))
+                                         (OPT.PRDEL B)
+                                         (OPT.PRDEL CD)
+                                         (SETQ B (fetch PREV of P)))
+                                     (SETQ B (OPT.PRATTACH OPPOP B)))
+                               (GO BLP))))
+                       (SETQ (COND
+                                ([EQUAL (CAR (fetch PREV of B))
+                                        (CONSTANT (create OP
+                                                         OPNAME _ 'COPY]
+                                                             (* COPY SETQ POP -> SETQ)
+                                 (OPT.PRDEL (fetch PREV of B))
+                                 (OPT.PRDEL CD)
+                                 (SETQ B P)
+                                 (GO BLP))))
+                       NIL))
+              (DUNBIND (COND
+                          ((AND COMPILE.DUNBIND.POP.MERGE.FLG (EQ (CAR B)
+                                                                  OPPOP))
+                                                             (* merge pop with DUNBIND)
+                           (OPT.PRDEL B)                 (* (DUNBIND level . frame))
+                           [RPLACA (fetch OPARG of (CAR CD))
+                                  (ADD1 (CAR (fetch OPARG of (CAR CD]
+                           (GO ALP))))
+              (UNBIND (COND
+                         ((SELECTQ (fetch OPNAME of (CAR B))
+                              (CONST                         (* CONST UNBIND)
+                                     (replace OPNAME of A with 'DUNBIND)
+                                                             (* change to DUNBIND)
+                                                             (* level is 1 less)
+                                     [RPLACA (fetch OPARG of A)
+                                            (SUB1 (CAR (fetch OPARG of A])
+                              (FN (COND
+                                     ((AND (EQ (CAR (fetch OPARG of (CAR B)))
+                                               1)
+                                           (COMP.CLEANFNOP (CDR (fetch OPARG
+                                                                       of (CAR B)))
+                                                  'FREEVARS))(* clean FN UNBIND)
+                                      T)))
+                              NIL)
+                          (RPLACA CD (CAR B))
+                          (RPLACA B A)                       (* switch CONST and DUNBIND)
+                          (RPLACA (MEMB CD (CDDR (FASSOC (CDR (fetch OPARG of A))
+                                                        FRAMES)))
+                                 B)
+                          (GO BLP))))
+              NIL)
+      TAG2
+          (COND
+             ((NULL B)
+              (RETURN)))
+          (SETQ P CD)
+          (SETQ CD B)
+          (GO LP)
+      BLP (SETQ CD B)
+      CLP (SETQ P (fetch NXT of CD))
+      ALP (SETQ ANY T)
+          (GO LP)
+      CHECKPUSH
+          (AND NEWOPTFLG (SELECTQ (fetch OPNAME of (CAR B))
+                             (POP (COND
+                                     ((OPT.EQVALUE (fetch PREV of B)
+                                             CD)             (* X POP X)
+                                      (OPT.PRDEL CD)
+                                      (OPT.PRDEL B)
+                                      (SETQ CD (fetch PREV of P))
+                                      (GO ALP))))
+                             NIL))
+          [COND
+             (NEWOPTFLG (COND
+                           ((SETQ X (OPT.JUMPCOPYTEST CD B))
+                                                             (* can insert COPY at X and then 
+                                                           delete CD)
+                            (SETQ X (OPT.DELCOPYFN P X))
+                            (SETQ P (fetch NXT of CD))
+                            [COND
+                               ((EQ X (fetch PREV of CD))
+                                (OPT.PRDEL CD))
+                               (T (FRPLACA CD '(SWAP]
+                            (OPT.PRATTACH OPCOPY X)
+                            (SETQ CD (fetch PREV of P))
+                            (GO ALP)))
+                    (COND
+                       ((AND (SETQ X (OPT.SKIPPUSH B 1 CD T))
+                             (SETQ X (OPT.JUMPCOPYTEST CD X)))
+                        (SETQ X (OPT.DELCOPYFN P X))
+                        (OPT.PRATTACH OPCOPY X)
+                        (FRPLACA CD '(SWAP))
+                        (GO ALP)))
+                    (GO TAG2))
+             (T (COND
+                   ((OPT.EQVALUE B CD)                   (* val val -> val COPY)
+                    (FRPLACA CD OPCOPY))
+                   ((EQ (CAR B)
+                        OPPOP)
+                    (COND
+                       ((OPT.EQVALUE (fetch PREV of B)
+                               CD)                           (* SETQ POP PUSH)
+                        (OPT.PRDEL CD)
+                        [OPT.PRDEL (PROG1 B
+                                           (SETQ CD (fetch PREV of B)))]
+                        (GO ALP]
+          (GO TAG2])
+
+(OPT.XVARSCAN
+  [LAMBDA NIL                                                (* rmk%: " 2-Apr-85 12:44")
+    (PROG ((CD CODE)
+           A)
+          [for X in FRAMES do (replace NOXVAR of (CAR X)
+                                             with (NEQ NIL (OASSOC 'AVAR (fetch VARS
+                                                                                of (CAR X]
+      LP  (SELECTQ (fetch OPNAME of (SETQ A (CAR CD)))
+              (HVAR (AND (NOT (FMEMB A (FETCH VARS OF TOPFRAME)))
+                         (OPT.XVARSCAN1 A CD)))
+              (SETQ (SETQ A (fetch OPARG of A))
+                    (COND
+                       ((EQ (fetch OPNAME of A)
+                            'HVAR)
+                        (OPT.XVARSCAN1 A CD))))
+              ((UNBIND DUNBIND) 
+                   (OR (OPT.CODELEV CD 0)
+                       (replace NOXVAR of (CDR (fetch OPARG of A)) with T)))
+              NIL)
+          (COND
+             ((NULL (SETQ CD (fetch PREV of CD)))
+              (RETURN)))
+          (GO LP])
+
+(OPT.XVARSCAN1
+  [LAMBDA (A CD)                                             (* rmk%: " 2-Apr-85 12:03")
+    (PROG ((FR (OPT.CODEFRAME CD)))
+          (OR FR (OPT.COMPILERERROR))
+          (COND
+             ((FMEMB A (fetch VARS of FR))
+              (RETURN)))
+      LP  (SETQ FR (fetch PARENT of FR))
+          (COND
+             ((FMEMB A (fetch VARS of FR))
+              (replace NOXVAR of FR with T)
+              (RETURN)))
+          (COND
+             ((EQ FR TOPFRAME)                               (* can't find A)
+              (OPT.COMPILERERROR)))
+          (GO LP])
+
+(OPT.JUMPOPT
+  [LAMBDA NIL                                                (* lmm "11-NOV-81 21:17")
+    (MAPC LISP:LABELS (FUNCTION (LAMBDA (X)
+                                  (COND
+                                     ((CADR X)               (* Label defined)
+                                      (COND
+                                         ((OR (OPT.JUMPTHRU (CAR X)
+                                                     (CDR X))
+                                              (OPT.JUMPREV (CAR X)
+                                                     (CDR X)))
+                                          (SETQ ANY T])
+
+(OPT.JUMPTHRU
+  [LAMBDA (TAG OPT.DEFREFS)                                  (* lmm "13-Jul-84 21:18")
+    (PROG ((DR OPT.DEFREFS)
+           P APD ALST ANY INFO Y REF BR END (DEF (CAR OPT.DEFREFS))
+           PD B (FRAME (fetch (TAG FRAME) of TAG))
+           (LEVEL (fetch (TAG LEVEL) of TAG)))
+      LQ  (while [OR [type? TAG (SETQ APD (CAR (fetch PREV of DEF]
+                         (type? TAG (SETQ APD (CAR (SETQ PD (fetch NXT of DEF]
+             do                                          (* two adjacent tags -
+                                                           merge them)
+                   (OPT.LBMERGE TAG APD))
+          [COND
+             ((NULL (CDR DR))                                (* tag which is not reference;
+                                                           delete it)
+              (RETURN (OPT.LBDEL TAG]
+          [COND
+             [(EQ APD OPNIL)                                 (* instruction after the tag is NIL)
+              (SETQQ ALST ((FJUMP NFJUMP . OPNIL]
+             (T (SETQ ALST (SELECTQ (fetch OPNAME of APD)
+                               (JUMP '((JUMP)
+                                       (TJUMP)
+                                       (FJUMP)
+                                       (NTJUMP)
+                                       (NFJUMP)))
+                               (TJUMP '((NTJUMP TJUMP)
+                                        (NFJUMP FJUMP . 1)))
+                               (FJUMP '((NTJUMP TJUMP . 1)
+                                        (NFJUMP FJUMP)))
+                               (NTJUMP '((NTJUMP)
+                                         (NFJUMP FJUMP . 1)))
+                               (NFJUMP '((NTJUMP TJUMP . 1)
+                                         (NFJUMP)))
+                               (POP '((NTJUMP TJUMP . 1)
+                                      (NFJUMP FJUMP . 1)
+                                      (JUMP NIL . JP)))
+                               (RETURN '((JUMP NIL . R)))
+                               ((AVAR GVAR FVAR HVAR) 
+                                    '((FJUMP NFJUMP . L)
+                                      (TJUMP NTJUMP . L)
+                                      (JUMP NIL . LL)))
+                               (RETURN]
+      LP  (COND
+             ((NOT (SETQ INFO (FASSOC [fetch OPNAME of (CAR (SETQ REF (CADR DR]
+                                     ALST)))
+              (GO NX)))
+          (COND
+             ((EQ REF PD)
+              [COMPERRM (CONS COMFN '(-- infinite loop]
+              (GO NX)))
+          (SETQ BR (fetch PREV of REF))
+          (SETQ Y
+           (SELECTQ (CDDR INFO)
+               (NIL                                          (* JUMP to JUMP)
+                    (fetch (JUMP TAG) of APD))
+               (R                                            (* JUMP to RETURN)
+                  (FRPLACA REF OPRETURN)
+                  NIL)
+               (L                                            (* VARIABLE REFERENCE)
+                  (COND
+                     ((OR (OPT.EQVALUE BR PD)
+                          (AND (EQ (fetch OPNAME of (CAR REF))
+                                   'TJUMP)
+                               (OPT.CALLP (CAR BR)
+                                      VCONDITIONALS 1)
+                               (OPT.EQVALUE (fetch PREV of BR)
+                                      PD)))                  (* VAR CJUMP to VAR)
+                      (OPT.LABELNTHPR DEF 1 LEVEL 1))
+                     [(SETQ Y (OPT.JUMPCOPYTEST PD BR))  (* VAR CJUMP |..| VAR -> VAR COPY 
+                                                           CJUMP POP |..| VAR)
+                      (PROG ((N 1)
+                             PDN)
+                            [COND
+                               (NEWOPTFLG (SETQ PDN (fetch NXT of PD))
+                                      (while (AND (OPT.CALLP (CAR (SETQ INFO
+                                                                           (fetch NXT
+                                                                              of Y)))
+                                                             NIL 1)
+                                                      (COMP.CLEANFNOP (CDR (fetch OPARG
+                                                                                  of (CAR INFO)))
+                                                             'NOSIDE)
+                                                      (OPT.EQOP (CAR INFO)
+                                                             (CAR PDN)))
+                                         do (SETQ Y INFO)
+                                               (SETQ PDN (fetch NXT of PDN))
+                                               (add N 1]
+                            (OPT.PRATTACH OPCOPY Y)
+                            (OPT.PRATTACH OPPOP REF)
+                            (SETQ INFO)
+                            (RETURN (OPT.LABELNTHPR DEF N LEVEL 1]
+                     (T (GO NX))))
+               (LL (COND
+                      ((AND (EQ (CAR BR)
+                                OPPOP)
+                            (OPT.EQVALUE (fetch PREV of BR)
+                                   PD))                      (* SETQ var POP JUMP to var)
+                       (OPT.PRDEL BR)
+                       (OPT.LABELNTHPR DEF 1 LEVEL 1))
+                      (T (GO NX))))
+               (1                                            (* NTJUMP to POP)
+                  (OPT.LABELNTHPR DEF 1 LEVEL -1))
+               (OPNIL                                        (* FJUMP to NIL)
+                      (OPT.LABELNTHPR DEF 1 LEVEL 1))
+               (JP (COND
+                      ((SETQ B (OPT.SKIPPUSH BR 1 NIL T))(* JUMP to POP)
+                       [PROG NIL
+                         LPB (SETQ BR (PROG1 (fetch PREV of BR)
+                                             (OPT.PRDEL BR)))
+                             (COND
+                                ((NEQ BR B)
+                                 (GO LPB]
+                       (OPT.LABELNTHPR DEF 1 LEVEL -1))
+                      (T (GO NX))))
+               (OPT.COMPILERERROR)))
+          (COND
+             (Y (replace (JUMP TAG) of (CAR REF) with Y)
+                (NCONC1 (OPT.DEFREFS Y)
+                       REF)))
+          (SETQ ANY T)
+
+         (* Since the jump to this tag was redirected, delete the jump from the REFS for 
+       this tag)
+
+          (FRPLACD DR (CDDR DR))
+          [COND
+             ((CADR INFO)
+              (replace OPNAME of (CAR REF) with (CADR INFO]
+          (GO LX)
+      NX  (SETQ DR (CDR DR))
+      LX  (COND
+             ((CDR DR)
+              (GO LP)))
+          [COND
+             ((NULL (CDR OPT.DEFREFS))
+              (RETURN (OPT.LBDEL TAG]
+          (RETURN ANY])
+
+(OPT.LBMERGE
+  [LAMBDA (TO FROM)                                  (* lmm%: "22-JUL-77 16:03")
+    (PROG [(REFS (CDR (OPT.DEFREFS FROM]
+          [MAPC REFS (FUNCTION (LAMBDA (X)
+                                 (replace (JUMP TAG) of (CAR X) with TO]
+          (NCONC (OPT.DEFREFS TO)
+                 REFS)
+          [OR (fetch (TAG LEVEL) of FROM)
+              (PROGN (replace (TAG LEVEL) of TO with NIL)
+                     (OR (fetch FRAME of FROM)
+                         (replace FRAME of TO with NIL]
+          (RETURN (OPT.LBDEL FROM])
+
+(OPT.PRDEL
+  [LAMBDA (X)                                                (* ; "Edited 10-Jul-90 23:18 by jds")
+
+    (* ;; 
+  "Remove X from the code stream by splicing it out of the doubly-linked list of code elements.")
+
+    (PROG ((B (fetch PREV of X))
+           (P (fetch NXT of X)))
+          (AND B (replace NXT of B with P))
+          (AND P (replace PREV of P with B))
+          (replace NXT of X with NIL])
+
+(OPT.UBDEL
+  [LAMBDA (CD)                                               (* lmm "14-MAR-81 09:16")
+    (DREMOVE CD (OR (FASSOC (CDR (fetch OPARG of (CAR CD)))
+                           FRAMES)
+                    (OPT.COMPILERERROR])
+
+(OPT.LBDEL
+  [LAMBDA (TAG)                                              (* ; "Edited 10-Jul-90 23:19 by jds")
+
+    (* ;; "Deleting a tag from the code stream.  Remove references to the tag.")
+
+    (PROG ((DEF (CAR (OPT.DEFREFS TAG)))
+           B)
+          (SETQ B (fetch PREV of DEF))
+          (OPT.PRDEL DEF)
+          (OPT.SETDEFREFS TAG NIL)
+          (SETQ LISP:LABELS (DREMOVE (FASSOC TAG LISP:LABELS)
+                                   LISP:LABELS))
+          [COND
+             ((OPT.JUMPCHECK B)                          (* ; 
+         "If there's a jump between this tag and any previous tags, delete code before deleted tag")
+              (OPT.DELCODE (fetch NXT of B]
+          (RETURN T])
+
+(OPT.LABELNTHPR
+  [LAMBDA (CODE CNT LEVEL DL)                                (* lmm%: "22-JUL-77 16:12")
+    (PROG ((CD CODE)
+           G)
+          (OPT.CHLEV DL)
+      LP  (SETQ CD (fetch NXT of CD))
+          (COND
+             ((IGREATERP CNT 0)
+              (OR (type? TAG (CAR CD))
+                  (SUB1VAR CNT))
+              (GO LP))
+             (T (RETURN (COND
+                           ((type? TAG (CAR CD))
+                            (OPT.CHECKTAG (CAR CD)
+                                   T)
+                            (CAR CD))
+                           (T (PROG1 (SETQ G (create TAG))
+                                  (replace (TAG FRAME) of G with FRAME)
+                                  (SETQ CD (OPT.PRATTACH G (fetch PREV of CD)))
+                                  (OPT.SETDEFREFS G (LIST CD))
+                                  (replace (TAG LEVEL) of G with LEVEL))])
+
+(OPT.JUMPREV
+  [LAMBDA (TAG OPT.DEFREFS)                                  (* lmm "13-Jul-84 21:18")
+                                                             (* OPT.JUMPREV checks the things 
+                                                           that PRECEDE particular kinds of 
+                                                           jumps)
+    (PROG ((DR OPT.DEFREFS)
+           R
+           (D (CAR OPT.DEFREFS))
+           END ANY LB CD (LEVEL (fetch (TAG LEVEL) of TAG))
+           (FRAME (fetch (TAG FRAME) of TAG))
+           BD ABD FLG BR ABR OABR PR APD OAR TMP)
+      LP  (SETQ R (CADR DR))
+          (SETQ PR (fetch NXT of R))
+          (SETQ BD (fetch PREV of D))
+          (SETQ ABD (CAR BD))
+          (SETQ BR (fetch PREV of R))
+          (SETQ ABR (CAR BR))
+          (SETQ OABR (fetch OPNAME of ABR))
+          (SETQ OAR (fetch OPNAME of (CAR R)))
+
+         (* variable code%: last letter is R for reference {i.e.
+       place of jump}, D for definition {i.e. place where TAG is} -
+       preceding letters%: -
+       A for CAR -
+       O for COP {op code} -
+       P for CPR {next byte} -
+       B for CBR {previous byte})
+
+          (SELECTQ OAR
+              (JUMP [COND
+                       ((EQ R BD)                            (* JUMP to next location deleted)
+                        (OPT.PRDEL R))
+                       [(AND (OPT.EQOP ABD ABR)
+                             (SETQ TMP (OPT.COMMONBACK BD R LEVEL)))
+
+         (* OPT.COMMONBACK returns NIL if does nothing;
+       T if deleted safe code or SAME if it deleted some code that contained a 
+       reference to the label that is now being worked on.)
+                                                             (* merge similar code before JUMP 
+                                                           and TAG)
+                                                             (* IF SAME don't continue with this 
+                                                           label! could have deleted other 
+                                                           references to it)
+                        (COND
+                           ((EQ TMP T)
+                            (SETQ ANY T)
+                            (GO LX))
+                           (T (RETURN T]
+                       [[AND (CAR PR)
+                             (NOT (type? TAG (CAR PR]    (* delete code after JUMP)
+                        (COND
+                           ((OPT.DELCODE PR)             (* returns T if it deleted any jumps
+                                                           (may have deleted a jump for this 
+                                                           tag))
+                            (RETURN))
+                           (T (GO NX]
+                       ([AND (SELECTQ (fetch OPNAME of ABD)
+                                 (RETURN T)
+                                 (JUMP (NOT (FMEMB BD DR)))
+                                 NIL)
+                             (SETQ END (fetch NXT of (OPT.FINDEND D R]
+                                                             (* move jumped-to code in line)
+                        (PROGN (replace NXT of BD with END)
+                               (replace PREV of (PROG1 END
+                                                            (SETQ END (fetch PREV of END)))
+                                  with BD))
+                        (PROGN (replace NXT of BR with D)
+                               (replace PREV of D with BR)
+                               (replace PREV of PR with END)
+                               (replace NXT of END with PR)))
+                       (T (SELECTQ OABR
+                              (CONST                         (* CONST JUMP)
+                                     (SELECTQ (fetch OPNAME of APD)
+                                         ((TJUMP NTJUMP) 
+                                              (SETQ FLG (fetch OPARG of ABR)))
+                                         ((FJUMP NFJUMP) 
+                                              (SETQ FLG (NULL (fetch OPARG of ABR))))
+                                         (GO NX))
+                                     (NCONC1 [OPT.DEFREFS (replace (JUMP TAG)
+                                                                 of (CAR R)
+                                                                 with
+                                                                 (COND
+                                                                    (FLG (SELECTQ (fetch OPNAME
+                                                                                     of APD)
+                                                                             ((TJUMP FJUMP) 
+                                                             (* T JUMP to TJUMP)
+                                                                                  (OPT.PRDEL
+                                                                                   BR))
+                                                                             
+                                                             (* T JUMP to NTJUMP))
+                                                                         (fetch (JUMP TAG)
+                                                                            of APD))
+                                                                    (T 
+                                                             (* T JUMP to NF/FJUMP)
+                                                                       (OPT.PRDEL BR)
+                                                                       (OPT.LABELNTHPR D 1 LEVEL
+                                                                              -1]
+                                            R))
+                              ((TJUMP FJUMP) 
+                                   (COND
+                                      ((EQ (fetch (JUMP TAG) of (CAR R))
+                                           (fetch (JUMP TAG) of ABR))
+                                                             (* TJUMP->TAG JUMP->TAG => POP 
+                                                           JUMP->TAG)
+                                       (OPT.PRDEL R)
+                                       (OPT.PRATTACH OPPOP (fetch PREV of BR))
+                                       (replace OPNAME of ABR with 'JUMP))
+                                      (T (GO NX))))
+                              (GO NX])
+              ((FJUMP TJUMP) 
+                   (COND
+                      ((EQ R BD)                             (* TJUMP to next location)
+                       (FRPLACA R OPPOP))
+                      [(EQ OABR 'CONST)
+                       (COND
+                          ((SELECTQ OAR
+                               (TJUMP (fetch OPARG of ABR))
+                               (NULL (fetch OPARG of ABR)))
+                                                             (* T TJUMP -> JUMP)
+                           (replace OPNAME of (CAR R) with 'JUMP)
+                           (OPT.PRDEL BR)
+                           (SETQ ANY T)                      (* try again)
+                           (GO LP))
+                          (T                                 (* T FJUMP -> NOOP)
+                             (OPT.PRDEL R)
+                             (OPT.PRDEL BR]
+                      ((OPT.CALLP ABR '(NOT NULL)
+                              1)                             (* NULL TJUMP)
+                       (FRPLACA R (OPT.NOTJUMP (CAR R)))
+                       (OPT.PRDEL BR)
+                       (GO REDO))
+                      ((AND (EQ ABR OPCOPY)
+                            (EQ (CAR PR)
+                                OPPOP))                      (* COPY TJUMP POP -> NTJUMP)
+                       (OPT.PRDEL BR)
+                       (OPT.PRDEL PR)
+                       (replace OPNAME of (CAR R) with (SELECTQ OAR
+                                                                       (TJUMP 'NTJUMP)
+                                                                       'NFJUMP))
+                       (GO REDO))
+                      ((AND (EQ (fetch OPNAME of ABD)
+                                'JUMP)
+                            (EQ (fetch PREV of BD)
+                                R))                          (* FJUMP.1 JUMP.2 1%: => TJUMP.2)
+                       (replace OPNAME of ABD with (SELECTQ OAR
+                                                                   (TJUMP 'FJUMP)
+                                                                   'TJUMP))
+                       (OPT.PRDEL R))
+                      ((SETQ CD (OPT.JUMPCOPYTEST PR BR))(* What is before the jump is also 
+                                                           after -
+                                                           e.g. X TJUMP X)
+                       (COND
+                          ((EQ (CAR PR)
+                               (CAR (fetch NXT of D)))
+                                                             (* X TJUMP.1 X |...|
+                                                           1%:X |...| -> X COPY TJUMP.2 |...|
+                                                           1%:X 2%: |...|)
+                           (OPT.PRATTACH OPCOPY CD)
+                           (SETQ LB (OPT.LABELNTHPR D 1 LEVEL 1)))
+                          ((AND (OPT.JUMPCHECK (fetch PREV of D))
+                                (OR (OPT.EQVALUE BR PR)
+                                    (AND (EQ OAR 'FJUMP)
+                                         (OPT.CALLP ABR VCONDITIONALS 1)
+                                         (OPT.EQVALUE (fetch PREV of BR)
+                                                PR)))
+                                (SETQ END (OPT.FINDEND D R)))
+                                                             (* X FJUMP.1 X .a.
+                                                           1%: .b. -> X NTJUMP.2 1%: .b.
+                                                           |...| 2%: .a.)
+                           (PROGN (replace NXT of (fetch PREV of D)
+                                     with (fetch NXT of END))
+                                  (replace PREV of (fetch NXT of END)
+                                     with (fetch PREV of D)))
+                           (PROGN (replace NXT of R with D)
+                                  (replace PREV of D with R)
+                                  (replace PREV of PR with END)
+                                  (replace NXT of END with PR))
+                           (replace OPNAME of (CAR R) with (SELECTQ OAR
+                                                                           (FJUMP 'NTJUMP)
+                                                                           'NFJUMP))
+                           (SETQ LB (OPT.LABELNTHPR PR 0 LEVEL 1)))
+                          (T (GO NX)))
+                       (OPT.PRDEL PR)
+                       (replace (JUMP TAG) of (CAR R) with LB)
+                       (NCONC1 (OPT.DEFREFS LB)
+                              R))
+                      (T (GO NX))))
+              ((NFJUMP NTJUMP) 
+                   (COND
+                      [(EQ OABR 'CONST)
+                       (COND
+                          ((SELECTQ OAR
+                               (NTJUMP (fetch OPARG of ABR))
+                               (NULL (fetch OPARG of ABR)))
+                                                             (* T NTJUMP -> JUMP)
+                           (replace OPNAME of (CAR R) with 'JUMP)
+                           (GO REDO))
+                          (T                                 (* T NFJUMP -> NOOP)
+                             (OPT.PRDEL BR)
+                             (OPT.PRDEL R]
+                      ((OPT.EQVALUE BR PR)               (* X NTJUMP X -> X COPY TJUMP)
+                       (OPT.PRATTACH OPCOPY (fetch PREV of R))
+                       (OPT.PRDEL PR)
+                       (replace OPNAME of (CAR R) with (SELECTQ OAR
+                                                                       (NTJUMP 'TJUMP)
+                                                                       'FJUMP))
+                       (GO REDO))
+                      [(EQ OAR 'NTJUMP)
+                       (COND
+                          [(NOT (OR (OPT.CALLP ABR CONDITIONALS)
+                                    (OPT.CALLP ABR VCONDITIONALS)))
+                           (COND
+                              ((EQ (CAR (fetch NXT of R))
+                                   OPNIL)                    (* NTJUMP NIL -> COPY TJUMP)
+                               (OPT.PRDEL (fetch NXT of R))
+                               (OPT.PRATTACH OPCOPY BR)
+                               (replace OPNAME of (CAR R) with 'TJUMP)
+                               (GO REDO))
+                              (T (GO NX]
+                          [(OPT.CALLP ABR VCONDITIONALS 1)
+                           (COND
+                              ((OPT.EQVALUE (fetch PREV of BR)
+                                      PR)                    (* X LISTP NTJUMP X -> X COPY LISTP 
+                                                           TJUMP)
+                               (OPT.PRATTACH OPCOPY (fetch PREV of BR))
+                               (OPT.PRDEL PR)
+                               (replace OPNAME of (CAR R) with 'TJUMP)
+                               (GO REDO))
+                              (T (GO NX]
+                          (T (GO NX]
+                      (T (GO NX))))
+              (GO NX))
+          (SETQ ANY T)
+          (FRPLACD DR (CDDR DR))
+          (GO LX)
+      NX  (SETQ DR (CDR DR))
+      LX  (COND
+             ((CDR DR)
+              (GO LP)))
+          (RETURN ANY)
+      REDO
+          (SETQ ANY T)
+          (GO LP])
+
+(OPT.COMMONBACK
+  [LAMBDA (BDEF REF LEVEL)                                   (* ; "Edited 10-Jul-90 13:59 by jds")
+
+    (* ;; "When the code preceding a jump is the same as the code preceding the label, can delete the code preceding the jump and move the label back --- BDEF is the code preceding the label and REF is the jump and the code that precedes it")
+
+    (PROG ((BREF (fetch PREV of REF))
+           G FLG TMP (FRAME FRAME))
+      M   (COND
+             ((EQ (fetch OPNAME of (CAR BDEF))
+                  'TAG)
+              (OPT.CHECKTAG (CAR BDEF)
+                     LEVEL)
+              (SETQ BDEF (fetch PREV of BDEF))
+              (GO M)))
+          (COND
+             ((OPT.EQOP (CAR BDEF)
+                     (CAR BREF))
+              [SELECTQ (fetch OPNAME of (CAR BREF))
+                  ((AVAR HVAR GVAR FVAR CONST COPY) 
+                       (OPT.CHLEV -1))
+                  ((SETQ STORE SWAP RETURN))
+                  (POP (COND
+                          ((AND [NOT (OPT.EQOP (CAR (fetch PREV of BREF))
+                                            (CAR (fetch PREV of BDEF]
+                                (EQ (fetch OPNAME of (CAR (fetch PREV of BREF)))
+                                    'SETQ)
+                                (EQ (fetch OPNAME of (CAR (fetch PREV of BDEF)))
+                                    'SETQ))                  (* ; 
+                                                        "no OPT.COMMONBACK for different SETQ pop.")
+                           (GO EXIT)))
+                       (OPT.CHLEV 1))
+                  ((TJUMP FJUMP NTJUMP NFJUMP) 
+                       (OPT.CHLEV 1)
+                       [COND
+                          ((EQ (fetch (JUMP TAG) of (CAR BREF))
+                               (fetch (JUMP TAG) of (CAR REF)))
+                           (SETQ FLG 'SAME]
+                       (OPT.DELTAGREF BREF))
+                  (FN [OPT.CHLEV (SUB1 (CAR (fetch OPARG of (CAR BDEF])
+                  ((UNBIND DUNBIND) 
+                       (OPT.UBDEL BREF)
+                       [SETQ LEVEL (CAR (fetch OPARG of (CAR BREF]
+                       [SETQ FRAME (CDR (fetch OPARG of (CAR BREF])
+                  (OPT.COMPILERERROR '(OPT.COMMONBACK shouldn't get here]
+              (OR FLG (SETQ FLG T))
+              (SETQ BDEF (fetch PREV of BDEF))
+              (SETQ BREF (PROG1 (fetch PREV of BREF)
+                                (OPT.PRDEL BREF)))
+              (GO M)))
+      EXIT
+          (COND
+             (FLG (SETQ G (OPT.LABELNTHPR BDEF 0 LEVEL 0))
+                  (OPT.DELTAGREF REF)
+                  (replace (JUMP TAG) of (CAR REF) with G)
+                  (NCONC1 (OPT.DEFREFS G)
+                         REF)
+                  (RETURN FLG])
+
+(OPT.DELTAGREF
+  [LAMBDA (REF)                                              (* ; "Edited 10-Jul-90 23:01 by jds")
+
+    (* ;; "Delete a reference to a jumnp-target tag.  If the tag has no references, remove it from the list LABELS, so we don't try to optimize the code around it.")
+
+    (LET [(TAG (fetch (JUMP TAG) of (CAR REF]
+         (for X on (OPT.DEFREFS TAG) when (EQ (CADR X)
+                                                              REF)
+            do (RETURN (RPLACD X (CDDR X))) finally (OPT.COMPILERERROR))
+         (COND
+            ((NOT (OPT.DEFREFS TAG))
+
+             (* ;; "No remaining refs to this tag.  Remove it from LABELS, so we don't try to do jump optimization with respect to it.")
+
+             (SETQ LISP:LABELS (DREMOVE (FASSOC TAG LISP:LABELS)
+                                      LISP:LABELS])
+
+(OPT.FINDEND
+  [LAMBDA (C STOP)                                           (* lmm%: "22-JUL-77 03:38")
+    (PROG NIL
+      LP  (COND
+             ((EQ C STOP)
+              (RETURN)))
+          (COND
+             ((OPT.JUMPCHECK C)
+              (RETURN C)))
+          (COND
+             ((SETQ C (fetch NXT of C))
+              (GO LP])
+
+(OPT.RETOPT
+  [LAMBDA NIL                                                (* DD%: "21-FEB-83 17:17")
+                                                             (* optimizations involving RETURN)
+    (PROG ((RL (OPT.RETFIND CODE))
+           TESTL TARGL)
+          [MAPC RL (FUNCTION (LAMBDA (C)
+                               (COND
+                                  ((OPT.RETPOP C)
+                                   (SETQ ANY T)))
+                               (COND
+                                  ((OPT.RETTEST C C)     (* Test if C is a possible test.)
+
+         (* Looking for the case where two identical sequences ending with RETURN one of 
+       which is preceded by a conditional jump;
+       -
+       TJUMP->x stuff RETURN x%: |...| stuff RETURN |...|
+       becomes -
+       FJUMP->y x%: |...| y%: stuff RETURN)
+
+                                   (SETQ TESTL (CONS C TESTL)))
+                                  (T (SETQ TARGL (CONS C TARGL]
+          (OR TESTL (RETURN ANY))
+          [SETQ TESTL (SUBSET TESTL (FUNCTION (LAMBDA (X)
+                                                (NOT (OPT.RETOPT1 X TARGL]
+          [MAP TESTL (FUNCTION (LAMBDA (Z)
+                                 (AND (LISTP Z)
+                                      (OPT.RETOPT1 (CAR Z)
+                                             (CDR Z]
+          (RETURN ANY])
+
+(OPT.RETFIND
+  [LAMBDA (C)                                                (* lmm%: "18-AUG-76 02:12:31")
+                                                             (* returns the list of all RETURN's 
+                                                           in the code)
+    (PROG ((L1 C)
+           R)
+      LP  (COND
+             ((SETQ L1 (FMEMB OPRETURN (CDR L1)))
+              (SETQ R (CONS L1 R))
+              (GO LP)))
+          (RETURN R])
+
+(OPT.RETPOP
+  [LAMBDA (RET)                                              (* rmk%: " 2-Apr-85 12:46")
+                                                             (* can delete any UNBIND's preceding 
+                                                           a RETURN -
+                                                           the RETURN does it automatically)
+    (PROG (ANY TAGS VAL)
+      LP  (SELECTQ [fetch OPNAME of (CAR (SETQ RET (fetch PREV of RET]
+              (UNBIND (SELECTQ (fetch OPNAME of VAL)
+                          ((AVAR HVAR)                       (* don't delete UNBIND when followed 
+                                                           by VAR RETURN)
+                               )
+                          (PROGN                             (* delete UNBIND before RETURN)
+                                 (OPT.UBDEL RET)
+                                 (GO DEL))))
+              (POP (COND
+                      (VAL                                   (* delete POP before VAR RETURN)
+                           (GO DEL))))
+              (DUNBIND (COND
+                          (VAL                               (* delete DUNBIND before VAR RETURN)
+                               (OPT.UBDEL RET)
+                               (GO DEL))))
+              (COPY (COND
+                       ((NOT (fetch OPARG of (CAR RET)))
+                                                             (* delete COPY before RETURN)
+                        (GO DEL))))
+              ((AVAR HVAR FVAR GVAR CONST) 
+                   (COND
+                      ((NULL VAL)
+                       (SETQ VAL (CAR RET))
+                       (GO LP))
+                      (T                                     (* VAR VAR RETURN)
+                         (GO DEL))))
+              (TAG (if [AND XVARFLG (SELECTQ (fetch OPNAME of VAL)
+                                            (CONST NIL)
+                                            (NOT (FMEMB VAL (fetch VARS of TOPFRAME]
+                       then                              (* if have XVARs then TAGs can't be 
+                                                           ambiguous)
+                     else (SETQ TAGS (CONS (CAR RET)
+                                               TAGS))
+                           (GO LP)))
+              NIL)
+          (RETURN ANY)
+      DEL (OPT.PRDEL RET)
+      DOIT
+          (SETQ ANY T)
+          [MAPC TAGS (FUNCTION (LAMBDA (X)
+                                 (replace (TAG LEVEL) of X with NIL]
+          (SETQ TAGS)
+          (GO LP])
+
+(OPT.RETOPT1
+  [LAMBDA (X L)                                              (* lmm%: "13-OCT-76 18:45:46")
+    (PROG (END Y1)
+          (RETURN (COND
+                     ([SETQ Y1 (SOME L (FUNCTION (LAMBDA (Y)
+                                                   (SETQ END (OPT.RETTEST X Y]
+                      (OPT.RETMERGE X END (CAR Y1))
+                      (SETQ ANY T])
+
+(OPT.RETTEST
+  [LAMBDA (TEST TARGET)                                  (* jds "ANOTHER FAKE DATE")
+    (PROG ((L1 TEST)
+           (L2 TARGET)
+           F1 F2 ONLYIFSAMEFRAME)
+          [COND
+             ((EQ L1 L2)
+              (SETQ F1 (SETQ F2 T]
+      LP  (SETQ L1 (fetch PREV of L1))
+          (SETQ L2 (fetch PREV of L2))
+      L1  (COND
+             ((type? TAG (CAR L1))
+              [OR F1 (SETQ F1 (fetch (TAG FRAME) of (CAR L1]
+              (SETQ L1 (fetch PREV of L1))
+              (GO L1)))
+      L2  (COND
+             ((type? TAG (CAR L2))
+              [OR F2 (SETQ F2 (fetch (TAG FRAME) of (CAR L2]
+              (SETQ L2 (fetch PREV of L2))
+              (GO L2)))
+          (SELECTQ (fetch OPNAME of (CAR L1))
+              (RETURN (GO RET))
+              (JUMP (GO RETJ))
+              ((FJUMP TJUMP) 
+                   (COND
+                      ((EQ (fetch (JUMP TAG) of (CAR L1))
+                           (CAR (fetch NXT of TEST)))
+                       (GO RETJ))))
+              (AVAR (COND
+                       ((EQ (CAR L1)
+                            (CAR L2))
+                        (SETQ ONLYIFSAMEFRAME T)
+                        (GO LP))))
+              (HVAR [COND
+                       ((EQ (CAR L1)
+                            (CAR L2))
+                        (COND
+                           ((EQ (OPT.CODEFRAME L1)
+                                (OPT.CODEFRAME L2))
+                            (COND
+                               ((EQ (OPT.CODELEV L1 0)
+                                    (OPT.CODELEV L2 0))
+                                (GO LP)
+
+         (* if NOXVAR would work, we could do this.
+       Unfortunately, NOXVAR is ignored at this point
+       (replace (FRAME NOXVAR) of (OPT.CODEFRAME L1) with T))
+
+                                ])
+              ((UNBIND DUNBIND) 
+                   (COND
+                      ([AND [EQ [CAR (LISTP (fetch OPARG of (LISTP (CAR L1]
+                                (CAR (LISTP (fetch OPARG of (LISTP (CAR L2]
+                            (EQ [CDR (fetch OPARG of (LISTP (CAR L1]
+                                (CDR (fetch OPARG of (LISTP (CAR L2]
+                       (SETQ F1 (SETQ F2 T))                 (* same frame)
+                       (GO LP))))
+              (FN (COND
+                     ((OPT.EQOP (CAR L1)
+                             (CAR L2))
+                      (GO LP))))
+              (BIND                                          (* don't merge binds)
+                    NIL)
+              ((POP CONST FVAR GVAR SWAP) 
+                   (COND
+                      ((EQ (CAR L1)
+                           (CAR L2))
+                       (GO LP))))
+              ((STORE COPY) 
+                   (COND
+                      ((EQUAL (CAR L1)
+                              (CAR L2))
+                       (GO LP))))
+              NIL)
+          (RETURN)
+      RETJ
+          [OR F1 (SETQ F1 (fetch (TAG FRAME) of (fetch (JUMP TAG) of (CAR L1]
+      RET [COND
+             (ONLYIFSAMEFRAME (COND
+                                 ((NEQ (OR F1 (OPT.CODEFRAME L1))
+                                       (OR F2 (OPT.CODEFRAME L2)))
+                                                             (* OPT.RETTEST fail because not same 
+                                                           frame)
+                                  (RETURN]
+          (RETURN L1])
+
+(OPT.RETMERGE
+  [LAMBDA (TEST END TARGET)                                  (* lmm "13-OCT-78 21:25")
+    (PROG ((L1 TEST)
+           (L2 TARGET)
+           G VEQ FEQ LEV)
+          [COND
+             ([AND (SETQ LEV (OPT.CODEFRAME (fetch PREV of TEST)))
+                   (EQ LEV (OPT.CODEFRAME (fetch PREV of TARGET]
+              (SETQ FEQ T)
+              (COND
+                 ((AND (SETQ LEV (OPT.CODELEV (fetch PREV of TEST)
+                                        0))
+                       (EQ LEV (OPT.CODELEV (fetch PREV of TARGET)
+                                      0)))
+                  (SETQ VEQ T]
+      LP  (COND
+             ((EQ L1 END)
+              (SELECTQ (fetch OPNAME of (CAR L1))
+                  ((TJUMP FJUMP) 
+                       [COND
+                          [[NOT (type? TAG (SETQ G (CAR L2]
+                           (SETQ G (create TAG))
+                           [COND
+                              (FEQ [replace (TAG FRAME) of G
+                                      with (fetch (TAG FRAME) of (fetch (JUMP TAG)
+                                                                                of (CAR L1]
+                                   (COND
+                                      (VEQ (replace (TAG LEVEL) of G
+                                              with (fetch (TAG LEVEL)
+                                                          of (fetch (JUMP TAG)
+                                                                    of (CAR L1]
+                           (OPT.SETDEFREFS G (LIST (OPT.PRATTACH G L2]
+                          (T (OR VEQ (replace (TAG LEVEL) of G with NIL))
+                             (OR FEQ (replace (TAG FRAME) of G with NIL]
+                       (FRPLACA L1 (OPT.NOTJUMP (CAR L1)))
+                       [DREMOVE L1 (OPT.DEFREFS (fetch (JUMP TAG) of (CAR L1]
+                       (replace (JUMP TAG) of (CAR L1) with G)
+                       (NCONC1 (OPT.DEFREFS G)
+                              L1))
+                  ((JUMP RETURN))
+                  (OPT.COMPILERERROR))
+              (RETURN)))
+          (COND
+             ((type? TAG (CAR L1))
+              (OR VEQ (replace (TAG LEVEL) of (CAR L1) with NIL))
+              (OR FEQ (replace (TAG FRAME) of (CAR L1) with NIL))
+              (RPLACA (OPT.DEFREFS (CAR L1))
+                     (OPT.PRATTACH (CAR L1)
+                            L2))
+              (SETQ L1 (PROG1 (fetch PREV of L1)
+                              (OPT.PRDEL L1)))
+              (GO LP)))
+      L2  (COND
+             ((type? TAG (CAR L2))
+              (OR VEQ (replace (TAG LEVEL) of (CAR L2) with NIL))
+              (OR FEQ (replace (TAG FRAME) of (CAR L2) with NIL))
+              (SETQ L2 (fetch PREV of L2))
+              (GO L2)))
+          (SELECTQ (fetch OPNAME of (CAR L1))
+              ((UNBIND DUNBIND) 
+                   (OPT.UBDEL L1))
+              ((TJUMP NTJUMP FJUMP NFJUMP JUMP BIND ERRORSET) 
+                   (OPT.COMPILERERROR))
+              NIL)
+          (SETQ L1 (PROG1 (fetch PREV of L1)
+                          (OPT.PRDEL L1)))
+          (SETQ L2 (fetch PREV of L2))
+          (GO LP])
+
+(OPT.CODELEV
+  [LAMBDA (CD LEV)                                       (* jds "THIS IS A FAKE DATE")
+    (PROG NIL
+          (RETURN (IPLUS (SELECTQ (fetch OPNAME of (CAR CD))
+                             (TAG (OR (fetch (TAG LEVEL) of (CAR CD))
+                                      (RETURN)))
+                             ((NTJUMP NFJUMP TJUMP FJUMP) 
+                                  (RETURN (OPT.CODELEV (fetch PREV of CD)
+                                                 (SUB1 LEV))))
+                             ((AVAR HVAR COPY CONST FVAR GVAR) 
+                                  (RETURN (OPT.CODELEV (fetch PREV of CD)
+                                                 (ADD1 LEV))))
+                             (FN [RETURN (OPT.CODELEV (fetch PREV of CD)
+                                                (ADD1 (IDIFFERENCE LEV (CAR (fetch OPARG
+                                                                               of (CAR CD])
+                             (POP (RETURN (OPT.CODELEV (fetch PREV of CD)
+                                                 (SUB1 LEV))))
+                             ((BIND ERRORSET) 
+                                  0)
+                             (DUNBIND [fetch (FRAME LEVEL) of (CDR (fetch OPARG
+                                                                              of (CAR CD])
+                             (UNBIND (ADD1 (OR [fetch (FRAME LEVEL)
+                                                  of (CDR (fetch OPARG of (CAR CD]
+                                               (RETURN))))
+                             ((SETQ STORE SWAP) 
+                                  (RETURN (OPT.CODELEV (fetch PREV of CD)
+                                                 LEV)))
+                             (NIL (OPT.CCHECK (NOT (CDR CD)))
+                                  0)
+                             (OPT.COMPILERERROR (CAR CD)))
+                         LEV])
+
+(OPT.CODEFRAME
+  [LAMBDA (CD)                                               (* rmk%: " 2-Apr-85 12:47")
+    (SELECTQ (fetch OPNAME of (CAR CD))
+        (TAG (OR (fetch (TAG FRAME) of (CAR CD))
+                 (OPT.CODEFRAME (fetch PREV of CD))))
+        ((NTJUMP NFJUMP TJUMP FJUMP) 
+
+         (* can't assume that code of jumped-to is same, because return-merging might 
+       have messed it up)
+
+             (OPT.CODEFRAME (fetch PREV of CD)))
+        ((BIND ERRORSET) 
+             (CDR (fetch OPARG of (CAR CD))))
+        ((UNBIND DUNBIND) 
+             [fetch PARENT of (CDR (fetch OPARG of (CAR CD])
+        (NIL TOPFRAME)
+        ((JUMP RETURN) 
+             NIL)
+        (OPT.CODEFRAME (fetch PREV of CD])
+
+(OPT.DEFREFS
+  [LAMBDA (D)                                                (* ; "Edited 10-Jul-90 23:02 by jds")
+
+    (* ;; "Given a jump-target tag, return a list of the references to that tag.")
+
+    (CDR (FASSOC D LISP:LABELS])
+
+(OPT.SETDEFREFS
+  [LAMBDA (D V)                                              (* lmm%: "22-JUL-77 15:58")
+    (FRPLACD [OR (FASSOC D LISP:LABELS)
+                 (CAR (SETQ LISP:LABELS (CONS (CONS D)
+                                              LISP:LABELS]
+           V])
+)
+(DEFINEQ
+
+(OPT.FRAMEOPT
+  [LAMBDA (TRYLOCAL TRYMERGE TRYXVAR)                        (* lmm "16-DEC-81 17:05")
+    (PROG (ANY)
+          [COND
+             (TRYLOCAL (MAPC FRAMES (FUNCTION (LAMBDA (X)
+                                                (AND (OPT.FRAMELOCAL (CAR X))
+                                                     (SETQ ANY T]
+          [MAPC FRAMES (FUNCTION (LAMBDA (F)
+                                   (AND (CADR F)
+                                        (OPT.FRAMEVAR F)
+                                        (SETQ ANY T]
+          [COND
+             (TRYMERGE (MAPC FRAMES (FUNCTION (LAMBDA (F)
+                                                (AND (CADR F)
+                                                     (OPT.FRAMEMERGE F)
+                                                     (SETQ ANY T]
+          [SETQ FRAMES (SUBSET FRAMES (FUNCTION (LAMBDA (F)
+                                                  (NOT (AND (CADR F)
+                                                            (OPT.FRAMEDEL F TRYXVAR)
+                                                            (SETQ ANY T]
+          (RETURN ANY])
+
+(OPT.FRAMEMERGE
+  [LAMBDA (F)                                                (* lmm "29-Dec-84 10:35")
+    (AND MERGEFRAMEFLG (PROG ((FR (CAR F))
+                              VAR VARS P)
+                             (COND
+                                ((AND (SETQ VARS (fetch VARS of FR))
+                                      (NULL (CDR (FNTH VARS MERGEFRAMEMAX)))
+                                      (SETQ P (fetch PARENT of FR))
+                                      (OPT.MERGEFRAMEP FR P VARS))
+                                 [PROG ((N (fetch NVALS of FR))
+                                        (V VARS)
+                                        (CD (fetch PREV of (CADR F)))
+                                        P2)
+                                   PLP (COND
+                                          ((AND (SETQ P2 (fetch PARENT of P))
+                                                (OPT.MERGEFRAMEP FR P2 VARS))
+                                           (SETQ P P2)
+                                           (GO PLP)))
+                                       (replace VARS of P with (NCONC (fetch VARS
+                                                                                     of P)
+                                                                                  VARS))
+                                       (replace VARS of FR with NIL)
+                                       (replace NNILS of P
+                                          with (IPLUS (fetch NNILS of P)
+                                                          (fetch NNILS of FR)
+                                                          (fetch NVALS of FR)))
+                                       (replace NNILS of FR
+                                          with (replace NVALS of FR with 0))
+                                   LP  (COND
+                                          (V (SETQ VAR (create OP
+                                                              OPNAME _ 'SETQ
+                                                              OPARG _ (CAR V)))
+                                             [COND
+                                                ((IGREATERP N 0)
+                                                 (OPT.PRATTACH OPPOP (OPT.PRATTACH VAR CD)))
+                                                (T [COND
+                                                      ((ZEROP N)
+                                                       (SETQ CD (OPT.PRATTACH OPNIL CD]
+                                                   (OR (OPT.NONILVAR (CAR V)
+                                                              CD P)
+                                                       (SETQ CD (OPT.PRATTACH VAR CD]
+                                             (SETQ N (SUB1 N))
+                                             (SETQ V (CDR V))
+                                             (GO LP)))
+                                       (COND
+                                          ((MINUSP N)
+                                           (OPT.PRATTACH OPPOP CD]
+                                 (RETURN T])
+
+(OPT.NONILVAR
+  [LAMBDA (V CD FR)                                          (* lmm " 8-JAN-82 09:06")
+                                                             (* used by OPT.FRAMEMERGE)
+    (PROG NIL
+          (RETURN (AND (SELECTQ (fetch OPNAME of (CAR CD))
+                           ((CONST POP COPY AVAR HVAR FVAR GVAR TJUMP FJUMP NTJUMP NFJUMP SETQ STORE
+                                   SWAP) 
+                                T)
+                           (NIL NIL)
+                           (FN (COMP.CLEANFNOP (CDR (fetch OPARG of (CAR CD)))
+                                      'FREEVARS))
+                           (BIND (COND
+                                    ([EQ FR (CDR (fetch OPARG of (CAR CD]
+                                     (RETURN T))
+                                    (T T)))
+                           ((TAG RETURN) 
+                                NIL)
+                           ((UNBIND DUNBIND ERRORSET) 
+                                T)
+                           NIL)
+                       (OPT.NONILVAR V (CDR CD)
+                              FR])
+
+(OPT.MERGEFRAMEP
+  [LAMBDA (FR PARENT VARS)                                   (* lmm "29-Dec-84 10:31")
+    (AND (FMEMB (fetch FRAMETYPE of PARENT)
+                MERGEFRAMETYPES)
+         (COND
+            [(OASSOC 'AVAR VARS)
+             (AND (OPT.CLEANFRAME PARENT FR)
+                  (PROG NIL
+                        [for V in VARS
+                           do (if (FMEMB (fetch OPARG of V)
+                                                 SYSSPECVARS)
+                                      then (GO BAD))
+                                 [for F in FRAMES when (NEQ (CAR F)
+                                                                        FR)
+                                    do (for V2 in (fetch VARS of (CAR F))
+                                              do (COND
+                                                        ((EQ (fetch OPARG of V2)
+                                                             (fetch OPARG of V))
+                                                         (GO BAD]
+                                 (for V2 in FREEVARS
+                                    do (COND
+                                              ((EQ (fetch OPARG of V2)
+                                                   (fetch OPARG of V))
+                                               (GO BAD]
+                        (RETURN T)
+                    BAD (RETURN]
+            (T (EQ MERGEFRAMEFLG T])
+
+(OPT.FRAMELOCAL
+  [LAMBDA (F)                                                (* lmm "29-Dec-84 20:45")
+    (PROG (VARS ANY)
+          (COND
+             ((AND (OASSOC 'AVAR (SETQ VARS (fetch (FRAME VARS) of F)))
+                   (OPT.CLEANFRAME F))                   (* make vars local when no external 
+                                                           calls)
+              (for X in VARS when (AND (EQ (fetch OPNAME of X)
+                                                       'AVAR)
+                                                   (NOT (FMEMB (fetch OPARG of X)
+                                                               SYSSPECVARS)))
+                 do (replace OPNAME of X with 'HVAR)
+                       (SETQ ANY T))
+              (RETURN ANY])
+
+(OPT.CLEANFRAME
+  [LAMBDA (FRAME AVOIDING)                                   (* lmm%: " 9-NOV-76 16:20:20")
+    (AND (NOT (fetch EXTCALL of FRAME))
+         (for F in FRAMES when (AND (EQ (fetch PARENT of (CAR F))
+                                                    FRAME)
+                                                (NEQ (CAR F)
+                                                     AVOIDING)) always (OPT.CLEANFRAME
+                                                                            (CAR F)
+                                                                            AVOIDING])
+
+(OPT.FRAMEDEL
+  [LAMBDA (F TRYXVAR)                                        (* lmm "13-Jul-84 21:18")
+    (PROG (VARS (FRM (CAR F))
+                PARENT OP FLV TMP DOXVAR)
+          (SELECTQ (fetch FRAMETYPE of FRM)
+              ((NIL ERRORSET) 
+                   (RETURN))
+              NIL)
+          (SETQ VARS (fetch VARS of FRM))
+          (SETQ FLV (fetch (FRAME LEVEL) of FRM))
+          (SETQ DOXVAR NIL)
+          (COND
+             ([AND [NOT (SOME (CDDR F)
+                              (FUNCTION (LAMBDA (X)
+                                          (AND (EQ (fetch OPNAME of (CAR X))
+                                                   'UNBIND)
+                                               (IGREATERP (CAR (fetch OPARG of (CAR X)))
+                                                      1]
+                   (OR (NULL VARS)
+                       (AND (NOT (OASSOC 'AVAR VARS))
+                            (OR (OPT.DELETEFRAMECHECK VARS F)
+                                (AND TRYXVAR (NOT (fetch NOXVAR of FRM))
+                                     (SETQ DOXVAR T]         (* frame with no specvars, no 
+                                                           UNBIND's with LEVEL gt 1)
+              (OR (SETQ PARENT (fetch PARENT of FRM))
+                  (OPT.COMPILERERROR))
+              [COND
+                 (DOXVAR (add FLV (fetch NNILS of FRM)
+                                (fetch NVALS of FRM]
+              [for VR on VARS
+                 do (for CD on CODE
+                           do (COND
+                                     [(AND (EQ (fetch OPARG of (CAR CD))
+                                               (CAR VR))
+                                           (EQ (fetch OPNAME of (CAR CD))
+                                               'SETQ))
+                                      (COND
+                                         [DOXVAR (OPT.CCHECK (EQ FRM (OPT.CODEFRAME CD)))
+                                                (RPLACA CD (create
+                                                            OP
+                                                            OPNAME _ 'STORE
+                                                            OPARG _ (OR (OPT.CODELEV
+                                                                         CD
+                                                                         (LENGTH (CDR VR)))
+                                                                        (OPT.COMPILERERROR]
+                                         (T (OPT.PRDEL CD)
+                                                             (* delete SETQ in OPT.FRAMEDEL)
+                                            ]
+                                     ((AND DOXVAR (EQ (CAR CD)
+                                                      (CAR VR)))
+                                      (OPT.CCHECK (EQ (OPT.CODEFRAME CD)
+                                                          FRM))
+                                      (RPLACA CD (COND
+                                                    ([ZEROP (SETQ TMP (OPT.CODELEV
+                                                                       (fetch PREV of CD)
+                                                                       (LENGTH (CDR VR]
+                                                     OPCOPY)
+                                                    (T (create OP
+                                                              OPNAME _ 'COPY
+                                                              OPARG _ TMP]
+              [MAPC LISP:LABELS (FUNCTION (LAMBDA (X)
+                                            (COND
+                                               ((EQ (fetch (TAG FRAME) of (CAR X))
+                                                    FRM)
+                                                (replace (TAG FRAME) of (CAR X) with
+                                                                                        PARENT)
+                                                (AND (fetch (TAG LEVEL) of (CAR X))
+                                                     FLV
+                                                     (replace (TAG LEVEL) of (CAR X)
+                                                        with (IPLUS (fetch (TAG LEVEL)
+                                                                           of (CAR X))
+                                                                        FLV]
+              [PROG ((CD (CADR F)))                          (* delete the bind and all of the 
+                                                           var references after)
+                    [MAPC (CONS NIL (AND (NOT DOXVAR)
+                                         VARS))
+                          (FUNCTION (LAMBDA NIL
+                                      (SETQ CD (PROG1 (fetch NXT of CD)
+                                                      (OPT.PRDEL CD]
+                    (FRPTQ (fetch NNILS of FRM)
+                           (OPT.PRATTACH OPNIL (fetch PREV of CD]
+              (COND
+                 ((fetch EXTCALL of FRM)
+                  (replace EXTCALL of PARENT with T)))
+              [MAPC (CDDR F)
+                    (FUNCTION (LAMBDA (CD)                   (* change DUNBIND to POP of LEVEL)
+                                (SELECTQ (PROG1 (fetch OPNAME of (SETQ OP (CAR CD)))
+                                             (SETQ CD (PROG1 (fetch PREV of CD)
+                                                             (OPT.PRDEL CD))))
+                                    (UNBIND [COND
+                                               [DOXVAR (COND
+                                                          ([NOT (ZEROP (SETQ TMP
+                                                                        (IPLUS (CAR (fetch OPARG
+                                                                                       of OP))
+                                                                               (LENGTH VARS)
+                                                                               -1]
+                                                           (SETQ CD (OPT.PRATTACH
+                                                                     (create OP
+                                                                            OPNAME _ 'STORE
+                                                                            OPARG _ TMP)
+                                                                     CD))
+                                                           (FRPTQ TMP (OPT.PRATTACH OPPOP CD]
+                                               (T (OPT.CCHECK (EQ (CAR (fetch OPARG
+                                                                              of OP))
+                                                                      1])
+                                    (DUNBIND (FRPTQ [COND
+                                                       (DOXVAR (IPLUS (CAR (fetch OPARG
+                                                                              of OP))
+                                                                      (fetch NVALS of FRM)
+                                                                      (fetch NNILS of FRM)))
+                                                       (T (CAR (fetch OPARG of OP]
+                                                    (OPT.PRATTACH OPPOP CD)))
+                                    (OPT.COMPILERERROR]
+              [MAPC FRAMES (FUNCTION (LAMBDA (F2)
+                                       (COND
+                                          ((EQ (fetch PARENT of (CAR F2))
+                                               FRM)
+                                           (replace PARENT of (CAR F2) with PARENT)
+                                           (replace (FRAME LEVEL) of (CAR F2)
+                                              with (AND FLV (SETQ TMP (fetch (FRAME LEVEL)
+                                                                             of (CAR F2)))
+                                                            (IPLUS TMP FLV]
+              (RETURN T])
+
+(OPT.FRAMEVAR
+  [LAMBDA (F)                                                (* lmm "13-Jul-84 21:18")
+    (PROG (VARS CD (FR (CAR F))
+                VAL ANY NNILS NVALS)
+          [SETQ VARS (REVERSE (OR (fetch VARS of FR)
+                                  (RETURN]
+          (SETQ NNILS (fetch NNILS of FR))
+          (SETQ NVALS (fetch NVALS of FR))
+          [for V on VARS as I from NNILS to 0 by -1
+             when (NEQ (fetch OPNAME of (CAR V))
+                           'AVAR)
+             do (COND
+                       ((NOT (SETQ CD (FMEMB (CAR V)
+                                             CODE)))
+                        [COND
+                           ((ZEROP I)
+                            (SETQ I 1)
+                            (OPT.PRATTACH OPPOP (fetch PREV of (CADR F)))
+                            (SETQ NVALS (SUB1 NVALS)))
+                           (T (SETQ NNILS (SUB1 NNILS]       (* local var bound but not used)
+                        (PROG ((CD CODE))
+                          LP  (COND
+                                 ((NOT CD)
+                                  (RETURN)))                 (* delete all SETQ's)
+                              (COND
+                                 ((AND (EQ (fetch OPARG of (CAR CD))
+                                           (CAR V))
+                                       (EQ (fetch OPNAME of (CAR CD))
+                                           'SETQ))           (* local var set but never used)
+                                  (OPT.PRDEL CD)))
+                              (SETQ CD (fetch PREV of CD))
+                              (GO LP))
+                        (RPLACA V NIL)
+                        (SETQ ANY T))
+                       ([NOTANY CODE (FUNCTION (LAMBDA (X)
+                                                 (AND (EQ (fetch OPNAME of X)
+                                                          'SETQ)
+                                                      (EQ (fetch OPARG of X)
+                                                          (CAR V]
+                        (COND
+                           ([SETQ VAL (COND
+                                         ((NEQ I 0)          (* NIL var never set)
+                                          (SETQ NNILS (SUB1 NNILS))
+                                          OPNIL)
+                                         ((AND (EQ [fetch OPNAME
+                                                      of (SETQ VAL (CAR (fetch PREV
+                                                                               of (CADR F]
+                                                   'CONST)
+                                               (APPLY* EQCONSTFN (fetch OPARG of VAL)))
+                                          (SETQ I 1)
+                                          (SETQ NVALS (SUB1 NVALS))
+                                                             (* delete this var, can try next)
+                                                             (* var bound to CONST and never set)
+                                          (PROG1 (CAR (fetch PREV of (CADR F)))
+                                              (OPT.PRDEL (fetch PREV of (CADR F))))]
+                            (do (FRPLACA CD VAL) repeatwhile (SETQ CD (FMEMB (CAR V)
+                                                                                     CD)))
+                            (FRPLACA V NIL)
+                            (SETQ ANY T]
+          (COND
+             (ANY [replace VARS of FR with (OPT.DREV (SUBSET VARS
+                                                                            (FUNCTION (LAMBDA (X)
+                                                                                        X]
+                  (replace NNILS of FR with NNILS)
+                  (replace NVALS of FR with NVALS)))
+          (RETURN ANY])
+
+(OPT.DELETEFRAMECHECK
+  [LAMBDA (VARS F)                                           (* lmm%: "22-JUL-77 02:58")
+    (PROG ((CD (OPT.ONLYMEMB (CAR VARS)
+                      CODE)))
+          (OR (AND CD (EQ (fetch PREV of CD)
+                          (CADR F)))
+              (RETURN))
+      LP  (SETQ VARS (CDR VARS))
+          (SETQ CD (fetch NXT of CD))
+          (COND
+             ((NULL VARS)
+              (RETURN T)))
+          (COND
+             ((EQ (OPT.ONLYMEMB (CAR VARS)
+                         CODE)
+                  CD)
+              (GO LP])
+
+(OPT.ONLYMEMB
+  [LAMBDA (X Y)                                              (* lmm%: " 6-OCT-76 15:06:48")
+    (AND (SETQ Y (FMEMB X Y))
+         (NOT (FMEMB X (CDR Y)))
+         Y])
+)
+
+(RPAQQ MERGEFRAMETYPES (PROG LAMBDA MAP))
+
+(RPAQQ OPTIMIZATIONSOFF NIL)
+(DEFINEQ
+
+(OPT.SKIPPUSH
+  [LAMBDA (CD N VL LEVOPFLG)                                 (* lmm "19-JAN-82 22:16")
+    (OR N (SETQ N 1))
+    (COND
+       ((ILESSP N 0)
+        NIL)
+       ((ZEROP N)
+        CD)
+       (T (SELECTQ (fetch OPNAME of (CAR CD))
+              ((AVAR HVAR FVAR GVAR CONST) 
+                   (OPT.SKIPPUSH (fetch PREV of CD)
+                          (SUB1 N)
+                          VL LEVOPFLG))
+              (COPY (AND (NOT (fetch OPARG of (CAR CD)))
+                         (OPT.SKIPPUSH (fetch PREV of CD)
+                                (SUB1 N)
+                                VL LEVOPFLG)))
+              (SWAP (AND (IGEQ N 2)
+                         (OPT.SKIPPUSH (fetch PREV of CD)
+                                N VL LEVOPFLG)))
+              (POP (OPT.SKIPPUSH (fetch PREV of CD)
+                          (ADD1 N)
+                          VL LEVOPFLG))
+              ((FJUMP TJUMP NFJUMP NTJUMP) 
+                   (AND NEWOPTFLG (NOT LEVOPFLG)
+                        (OPT.SKIPPUSH (fetch PREV of CD)
+                               (ADD1 N)
+                               VL LEVOPFLG)))
+              (FN (COND
+                     ((OR (COMP.CLEANFNOP (CDR (fetch OPARG of (CAR CD)))
+                                 'NOSIDE)
+                          (AND NEWOPTFLG (SELECTQ (fetch OPNAME of (CAR VL))
+                                             ((CONST HVAR) 
+                                                  T)
+                                             ((FVAR AVAR GVAR) 
+                                                  (COMP.CLEANFNOP (CDR (fetch OPARG
+                                                                              of (CAR CD)))
+                                                         'FREEVARS))
+                                             NIL)))
+                      (OPT.SKIPPUSH (fetch PREV of CD)
+                             [SUB1 (IPLUS N (CAR (fetch OPARG of (CAR CD]
+                             VL LEVOPFLG))))
+              (SETQ (COND
+                       ([AND NEWOPTFLG VL (NEQ (CAR VL)
+                                               (fetch OPARG of (CAR CD]
+                        (OPT.SKIPPUSH (fetch PREV of CD)
+                               N VL LEVOPFLG))))
+              NIL])
+
+(OPT.DELCODE
+  [LAMBDA (CD)                                               (* ; "Edited 10-Jul-90 23:45 by jds")
+
+    (* ;; "Remove (unreachable) code from the code stream.")
+
+    (PROG (X FLG)
+      LP  (SELECTQ (fetch OPNAME of (SETQ X (CAR CD)))
+              (NIL (RETURN FLG))
+              (TAG (RETURN FLG))
+              ((BIND ERRORSET) 
+                   (RPLACA (CDR (FASSOC (CDR (fetch OPARG of X))
+                                       FRAMES))
+                          NIL)
+                   (for LB in LISP:LABELS when (EQ (fetch (TAG FRAME)
+                                                                  of (CAR LB))
+                                                               (CDR (fetch OPARG of X)))
+                      do (MAPC (CDR LB)
+                                   (FUNCTION OPT.PRDEL))))
+              ((UNBIND DUNBIND) 
+                   (DREMOVE CD (FASSOC (CDR (fetch OPARG of X))
+                                      FRAMES)))
+              ((JUMP FJUMP TJUMP NFJUMP NTJUMP ERRORSET)     (* ; "delete unreachable jump")
+                   (OPT.DELTAGREF CD)
+                   (SETQ FLG T))
+                                                             (* ; "delete unreachable code"))
+          (SETQ ANY T)
+          (SETQ CD (PROG1 (fetch NXT of CD)
+                          (OPT.PRDEL CD)))
+          (GO LP])
+
+(OPT.PRATTACH
+  [LAMBDA (ITEM BEFORE)                                      (* lmm%: "22-JUL-77 02:58")
+    (PROG ((AFTER (fetch NXT of BEFORE))
+           (NEW (CONS)))
+          (replace NXT of NEW with AFTER)
+          (replace PREV of NEW with BEFORE)
+          (FRPLACA NEW ITEM)
+          (replace NXT of BEFORE with NEW)
+          (AND AFTER (replace PREV of AFTER with NEW))
+          (RETURN NEW])
+
+(OPT.JUMPCOPYTEST
+  [LAMBDA (VL CDFROM)                                        (* lmm "15-JAN-82 18:08")
+
+         (* Where can a COPY be inserted such that VL would be on the stack -
+       either returns the code list or NIL -
+       used by transformation -
+       var TJUMP->l var |...| l%: var -
+       => var COPY TJUMP->l2 |...| l%: var l2%:)
+
+    (COND
+       ((OPT.EQVALUE CDFROM VL)
+        CDFROM)
+       ((AND (OPT.CALLP (CAR CDFROM))
+             (OR (EQ (fetch OPNAME of (CAR VL))
+                     'HVAR)
+                 (COMP.CLEANFNP (CDR (fetch OPARG of (CAR CDFROM)))
+                        'FREEVARS))
+             (SETQ CDFROM (OPT.SKIPPUSH (fetch PREV of CDFROM)
+                                 [SUB1 (CAR (fetch OPARG of (CAR CDFROM]
+                                 VL T)))
+        (OPT.JUMPCOPYTEST VL CDFROM])
+
+(OPT.EQOP
+  [LAMBDA (OP1 OP2)                                          (* lmm " 8-JAN-82 09:04")
+    (OR (EQ OP1 OP2)
+        (AND (EQ (fetch OPNAME of OP1)
+                 (fetch OPNAME of OP2))
+             (SELECTQ (fetch OPNAME of OP1)
+                 ((FVAR GVAR CONST COPY STORE) 
+                      (EQ (fetch OPARG of OP1)
+                          (fetch OPARG of OP2)))
+                 ((POP RETURN SWAP) 
+                      [OPT.CCHECK (AND (NOT (fetch OPARG of OP1))
+                                           (NOT (fetch OPARG of OP2]
+                      T)
+                 (FN (EQUAL OP1 OP2))
+                 ((JUMP TJUMP NTJUMP FJUMP NFJUMP BIND ERRORSET UNBIND DUNBIND) 
+                      [AND (EQ (CAR (fetch OPARG of OP1))
+                               (CAR (fetch OPARG of OP2)))
+                           (EQ (CDR (fetch OPARG of OP1))
+                               (CDR (fetch OPARG of OP2])
+                 (SETQ (OPT.EQOP (fetch OPARG of OP1)
+                              (fetch OPARG of OP2)))
+                 NIL])
+
+(OPT.EQVALUE
+  [LAMBDA (CD V)                                             (* lmm "19-JAN-82 22:25")
+    (PROG NIL
+      LP  (RETURN (SELECTQ (fetch OPNAME of (CAR CD))
+                      (COPY (COND
+                               ((NULL (fetch OPARG of (CAR CD)))
+                                (SETQ CD (fetch PREV of CD))
+                                (GO LP))))
+                      (SETQ (COND
+                               ((EQ (fetch OPARG of (CAR CD))
+                                    (CAR V)))
+                               (T (SETQ CD (fetch PREV of CD))
+                                  (GO LP))))
+                      ((HVAR AVAR FVAR GVAR CONST) 
+                           (EQ (CAR CD)
+                               (CAR V)))
+                      ((POP FJUMP TJUMP NFJUMP NTJUMP SWAP) 
+                           (COND
+                              ((SETQ CD (OPT.SKIPPUSH (fetch PREV of CD)
+                                               1 V))
+                               (GO LP))))
+                      NIL])
+
+(OPT.DELCOPYFN
+  [LAMBDA (P X)                                              (* lmm "18-JAN-82 13:17")
+    (while (AND (OPT.CALLP (CAR P)
+                           NIL 1)
+                    (OPT.EQOP (CAR P)
+                           (CAR (fetch NXT of X)))
+                    (COMP.CLEANFNOP (CDR (fetch OPARG of (CAR P)))
+                           'NOSIDE)
+                    (for Z_P by (fetch PREV of Z)
+                       while (AND Z (NEQ Z X))
+                       always (SELECTQ (fetch OPNAME of (CAR Z))
+                                      (FN (COMP.CLEANFNOP (CDR (fetch OPARG
+                                                                      of (CAR Z)))
+                                                 'NOSIDE))
+                                      ((FVAR AVAR HVAR GVAR SETQ) 
+
+         (* SETQ is OK since we have already guaranteed that the value skipped is not 
+       modified by intervening setqs)
+
+                                           T)
+                                      NIL))) do [SETQ P (fetch NXT
+                                                               of (PROG1 (fetch PREV
+                                                                                of P)
+                                                                             (OPT.PRDEL P]
+                                                   (SETQ X (fetch NXT of X)))
+    X])
+)
+(DEFINEQ
+
+(OPT.DEADSETQP
+  [LAMBDA (VAR CD)                                           (* lmm "13-Jul-84 21:18")
+    (DECLARE (SPECVARS ICNT))
+    (SELECTQ (fetch OPNAME of VAR)
+        ((AVAR HVAR) 
+             (PROG (TAGS (ICNT 50))                          (* ICNT is used to limit the nmber 
+                                                           of instructions looked at past the 
+                                                           setq.)
+                                                             (* look for dead SETQ)
+                   (RETURN (OPT.DS1 VAR CD))))
+        NIL])
+
+(OPT.DS1
+  [LAMBDA (VAR CD)                                           (* lmm "13-Jul-84 21:18")
+
+         (* test if VAR is used in CD -- TAGS is a list of tags already visited)
+
+    (PROG (A)
+      LP  [SELECTQ (fetch OPNAME of (SETQ A (CAR CD)))
+              (SETQ (AND (EQ (fetch OPARG of A)
+                             VAR)
+                         (RETURN T)))
+              (FN (AND (EQ (fetch OPNAME of VAR)
+                           'AVAR)
+                       (NOT (COMP.CLEANFNOP (CDR (fetch OPARG of A))
+                                   'FREEVARS))
+                       (RETURN)))
+              ((UNBIND DUNBIND) 
+                   (COND
+                      ([FMEMB VAR (fetch (FRAME VARS) of (CDR (fetch OPARG of A]
+                       (RETURN T))))
+              (RETURN [RETURN (AND (SETQ A (OPT.CODEFRAME (fetch PREV of CD)))
+                                   (never (EQ (fetch FRAMETYPE of A)
+                                                  'ERRORSET) repeatwhile (SETQ A
+                                                                              (fetch PARENT
+                                                                                 of A])
+              (JUMP (OR [SETQ CD (CAR (OPT.DEFREFS (fetch (JUMP TAG) of A]
+                        (RETURN))
+                    (GO LP))
+              ((TJUMP FJUMP NTJUMP NFJUMP ERRORSET) 
+                   (OR [OPT.DS1 VAR (CAR (OPT.DEFREFS (fetch (JUMP TAG) of A]
+                       (RETURN)))
+              (TAG [COND
+                      ((FMEMB A TAGS)
+                       (RETURN T))
+                      (T (SETQ TAGS (CONS A TAGS])
+              (COND
+                 ((EQ A VAR)
+                  (RETURN]
+          (OR (SETQ CD (fetch NXT of CD))
+              (OPT.COMPILERERROR))
+      NX  [COND
+             ((ZEROP ICNT)                                   (* DEADSETP gives up)
+              (RETURN))
+             (T (SETQ ICNT (SUB1 ICNT]
+          (GO LP])
+)
+
+(RPAQ? *BC-MACRO-ENVIRONMENT* (COMPILER::MAKE-ENV))
+
+(RPAQ? *BYTECOMPILER-OPTIMIZE-MACROLET* T)
+
+(DEFMACRO LISP:MACROLET (LISP::MACRODEFS &BODY LISP::BODY &ENVIRONMENT LISP::ENV)
+   (DECLARE (SPECVARS *BYTECOMPILER-IS-EXPANDING*))
+
+   (* ;; "This macro for the old interpreter and compiler only.  The new interpreter has a special-form definition.  When the new compiler is expanding, we simply return a disguised version of the form.")
+
+   (IF (AND *BYTECOMPILER-IS-EXPANDING* *BYTECOMPILER-OPTIMIZE-MACROLET*)
+       THEN (LET ((LISP::NEW-ENV (COMPILER::MAKE-CHILD-ENV LISP::ENV)))
+                     (DECLARE (LISP:SPECIAL *BC-MACRO-ENVIRONMENT*))
+                     [FOR LISP::FN IN LISP::MACRODEFS
+                        DO (COMPILER::ENV-BIND-FUNCTION LISP::NEW-ENV (CAR LISP::FN)
+                                      :MACRO
+                                      (COMPILER::CRACK-DEFMACRO (CONS 'DEFMACRO LISP::FN]
+                     (LISP:SETQ *BC-MACRO-ENVIRONMENT* LISP::NEW-ENV)
+                     (CONS 'LISP:LOCALLY LISP::BODY))
+     ELSEIF (TYPEP LISP::ENV 'COMPILER:ENV)
+       THEN `(SI::%%MACROLET ,LISP::MACRODEFS ,@LISP::BODY)
+     ELSE
+     (LET* ((LISP::NEW-ENV (\MAKE-CHILD-ENVIRONMENT LISP::ENV))
+            (LISP::FUNCTIONS (ENVIRONMENT-FUNCTIONS LISP::NEW-ENV)))
+           (FOR LISP::FN IN LISP::MACRODEFS
+              DO (LISP:SETQ LISP::FUNCTIONS
+                            (LIST* (CAR LISP::FN)
+                                   [CONS :MACRO `(LISP:LAMBDA (SI::$$MACRO-FORM 
+                                                                     SI::$$MACRO-ENVIRONMENT)
+                                                        (LISP:BLOCK ,(CAR LISP::FN)
+                                                            ,(PARSE-DEFMACRO (CADR LISP::FN)
+                                                                    'SI::$$MACRO-FORM
+                                                                    (CDDR LISP::FN)
+                                                                    (CAR LISP::FN)
+                                                                    NIL :ENVIRONMENT 
+                                                                    'SI::$$MACRO-ENVIRONMENT))]
+                                   LISP::FUNCTIONS)))
+           (LISP:SETF (ENVIRONMENT-FUNCTIONS LISP::NEW-ENV)
+                  LISP::FUNCTIONS)
+           (WALK-FORM (CONS 'LISP:LOCALLY LISP::BODY)
+                  :ENVIRONMENT LISP::NEW-ENV))))
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(SPECVARS *BYTECOMPILER-IS-EXPANDING* *BC-MACRO-ENVIRONMENT*)
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(SPECVARS CODE LEVEL)
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(SPECVARS LISP:LABELS PASS ANY CODE FRAME FRAMES)
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS MERGEFRAMEMAX MERGEFRAMEFLG MERGEFRAMETYPES *BYTECOMPILER-OPTIMIZE-MACROLET*)
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(SPECVARS VARS ANY FRAME)
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(SPECVARS ICNT TAG)
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(SPECVARS FRAME LEVEL ANY)
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(SPECVARS FRAME LEVEL ANY)
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(SPECVARS TAGS ANY)
+)
+)
+
+
+
+(* ; "CONSISTENCY CHECKS")
+
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS OPT.CCHECK MACRO [ARGS (COND
+                                            (COMPILECOMPILERCHECKS (LIST 'AND (LIST 'NOT (CAR ARGS))
+                                                                         (LIST 'OPT.COMPILERERROR
+                                                                               (CADR ARGS])
+)
+
+
+(RPAQQ COMPILECOMPILERCHECKS NIL)
+)
+(DEFINEQ
+
+(OPT.COMPILERERROR
+  [LAMBDA (MESS1 MESS2)                                      (* lmm " 1-MAR-78 02:55")
+    (LISPXPRIN1 "Compiler error
+" T)
+    (HELP MESS1 MESS2])
+
+(OPT.OPTCHECK
+  [LAMBDA NIL                                                (* lmm "14-MAR-81 11:03")
+                                                             (* set up code list as doubly linked 
+                                                           list, scan for tags)
+    (PROG ((CD CODE)
+           P B)
+      LPC (COND
+             ((NULL CD)
+              [for X in LISP:LABELS
+                 do (COND
+                           ((CDR X)
+                            [OR (FMEMB (CAR X)
+                                       CODE)
+                                (OPT.COMPILERERROR (CAR X)
+                                       '(not in code]
+                            [MAPC (CDR X)
+                                  (FUNCTION (LAMBDA (Y)
+                                              (OR (TAILP Y CODE)
+                                                  (OPT.COMPILERERROR Y '(NOT CODE TAIL]
+                            [OR (EQ (CAR (CADR X))
+                                    (CAR X))
+                                (OPT.COMPILERERROR X '(TAG wrong]
+                            (EVERY (CDDR X)
+                                   (FUNCTION (LAMBDA (Y)
+                                               (OR (EQ (fetch (JUMP TAG) of (CAR Y))
+                                                       (CAR X))
+                                                   (OPT.COMPILERERROR X '(TAG wrong]
+              [for X in FRAMES
+                 do (COND
+                           [(EQ (CAR X)
+                                TOPFRAME)
+                            (AND (CDR X)
+                                 (OPT.COMPILERERROR (CONS 'TOPFRAME X]
+                           (T [for Y in (CDR X)
+                                 do (OR (TAILP Y CODE)
+                                            (OPT.COMPILERERROR (LIST '(NOT IN CODE)
+                                                                         Y X)))
+                                       (OR (EQ (CDR (fetch OPARG of (CAR Y)))
+                                               (CAR X))
+                                           (OPT.COMPILERERROR (LIST '(WRONG FRAME)
+                                                                        Y X]
+                              (OR (FASSOC (fetch PARENT of (CAR X))
+                                         FRAMES)
+                                  (OPT.COMPILERERROR '(PARENT NOT FRAME)
+                                         X]
+              (RETURN T)))
+          (SELECTQ (fetch OPNAME of (CAR CD))
+              (TAG (OR (SETQ B (FASSOC (CAR CD)
+                                      LISP:LABELS))
+                       (OPT.COMPILERERROR))
+                   (OR (EQ (CAR (CDR B))
+                           CD)
+                       (OPT.COMPILERERROR))
+                   (OR (OR (NULL (fetch (TAG FRAME) of (CAR CD)))
+                           (FASSOC (fetch (TAG FRAME) of (CAR CD))
+                                  FRAMES))
+                       (OPT.COMPILERERROR)))
+              ((BIND ERRORSET) 
+                   (OR (EQ (CADR (FASSOC (CDR (fetch OPARG of (CAR CD)))
+                                        FRAMES))
+                           CD)
+                       (OPT.COMPILERERROR)))
+              ((UNBIND DUNBIND) 
+                   (OR (FMEMB CD (CDDR (FASSOC (CDR (fetch OPARG of (CAR CD)))
+                                              FRAMES)))
+                       (OPT.COMPILERERROR)))
+              ((JUMP TJUMP FJUMP NTJUMP NFJUMP) 
+                   (OR (SETQ B (FASSOC (fetch (JUMP TAG) of (CAR CD))
+                                      LISP:LABELS))
+                       (OPT.COMPILERERROR))
+                   [OR (MEMB CD B)
+                       (OPT.COMPILERERROR CD '(NOT IN JUMP LIST])
+              NIL)
+          (SETQ B (CDR CD))
+          (OR (AND (EQ (fetch PREV of CD)
+                       B)
+                   (EQ (fetch NXT of CD)
+                       P))
+              (OPT.COMPILERERROR))
+          (SETQ P CD)
+          (SETQ CD B)
+          (GO LPC])
+
+(OPT.CCHECK
+  [LAMBDA (X)                                                (* lmm "14-MAR-81 09:18")
+    (OR X (OPT.COMPILERERROR])
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS ALAMS BYTE.EXT BYTEASSEMFN BYTECOMPFLG COMPILERMACROPROPS CIA CLEANFNLIST COMP.SCRATCH 
+       COMPILETYPELST COMPILEUSERFN COMPSTATLST COMPSTATS CONDITIONALS CONST.FNS CONSTOPS DONOTHING 
+       FILERDTBL FNA FORSHALLOW FRA HEADERBYTES HOKEYDEFPROP LAMBDANOBIND LAMS LBA LEVELARRAY 
+       LINKEDFNS LOADTIMECONSTANT MAXBNILS MAXBVALS MCONSTOPS MERGEFRAMEFLG MERGEFRAMEMAX 
+       MERGEFRAMETYPES MOPARRAY MOPCODES NODARR NOSTATSFLG NUMBERFNS OPCOPY OPNIL OPPOP OPRETURN PRA
+       SELECTQFMEMB SELECTVARTYPES STATAR STATMAX STATN SYSSPECVARS UNIQUE#ARRAY VCA VCONDITIONALS 
+       VREFFRA COUTFILE XVARFLG MERGEFRAMEFLG OPTIMIZATIONSOFF NOFREEVARSFNS EQCONSTFN NEWOPTFLG)
+)
+
+(LISP:PROCLAIM '(LISP:SPECIAL COMPVARMACROHASH))
+(DECLARE%: DONTCOPY EVAL@COMPILE 
+(DECLARE%: EVAL@COMPILE
+
+(RECORD CODELST (OP . PREV)
+                    [ACCESSFNS CODELST ((NXT (GETHASH DATUM PRA)
+                                             (PUTHASH DATUM NEWVALUE PRA])
+)
+
+
+(PUTPROPS OASSOC MACRO ((X Y)
+                                (FASSOC X Y)))
+
+(DECLARE%: EVAL@COMPILE
+
+(RECORD OP (OPNAME . OPARG))
+
+(RECORD JUMP (OPNAME TAG . JT)                           (* kind of OP)
+                 )
+
+(TYPERECORD TAG (LBNO . LEVEL)                           (* kind of OP)
+                    LBNO _ (SETQ LBCNT (ADD1 LBCNT))
+                    [ACCESSFNS TAG ((FRAME (GETHASH DATUM FRA)
+                                           (PUTHASH DATUM NEWVALUE FRA))
+                                    (JD (GETHASH DATUM LBA)
+                                        (PUTHASH DATUM NEWVALUE LBA])
+
+(RECORD VAR (COMP.VARTYPE . VARNAME)                     (* A particular kind of OP)
+                )
+)
+
+(DECLARE%: EVAL@COMPILE
+
+(RECORD FRAME (FRAMETYPE (NNILS VARS . DECLS)
+                         LEVEL
+                         (BINDLST NVALS EXTCALL . CPIOK) . PROGLABELS)
+
+         (* FRAMETYPE is one of PROG LAMBDA ERRORSET MAP NIL -
+       VARS are variables bound, NNILS are %# which are bound to NIL -
+       LEVEL is %# of things on stack between this and next higher frame)
+
+                  (ACCESSFNS FRAME ((PARENT (GETHASH DATUM FRA)
+                                           (PUTHASH DATUM NEWVALUE FRA))
+                                    (VREFFROM (GETHASH DATUM VREFFRA)
+                                           (PUTHASH DATUM NEWVALUE VREFFRA))
+                                    (NODBIND (GETHASH DATUM NODARR)
+                                           (PUTHASH DATUM NEWVALUE NODARR))
+                                    (PRIMARYRETURN (GETHASH DATUM BCINFO)
+                                           (PUTHASH DATUM NEWVALUE BCINFO)))
+                                                             (* PARENT is next higher enclosing 
+                                                           frame -
+                                                           shares hash table with TAG.FRAME)
+                         )
+                  (RECORD CPIOK NOXVAR 
+
+         (* Share the CPIOK field used by the compiler pass 1 and the NOXVAR field used 
+       by the maxc assembler)
+)
+                  NNILS _ 0)
+
+(RECORD COMINFO (COMTYPE TOPFRAME CODE ARGS))
+
+(ACCESSFNS COMP (CLEAR (PROGN (OPT.INITHASH FRA)
+                                  (OPT.INITHASH LBA)
+                                  (OPT.INITHASH PRA)
+                                  (OPT.INITHASH VREFFRA)
+                                  (OPT.INITHASH NODARR)
+                                  (OPT.INITHASH BCINFO))))
+
+(RECORD JD (JPT (JMIN . JSN)
+                    JU . JML)
+
+         (* JPT is NIL (for tags) or a pointer into ACODE
+       (for jumps)%. JMIN is the lowest possible location for the instruction or tag.
+       JU is the cumulative uncertainty (for tags) or the length uncertainty
+       (for jumps)%. JML is the minimum length
+       (for jumps)%. JSN is a serial number (the original JMIN) used to decide whether 
+       a jump goes forward or backward.)
+
+               )
+
+(RECORD BLOCKSTATUS (BLOCKCONTEXT BLOCKTAG BLOCKEND))
+)
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS THETYPE MACRO [(THETYPE . FORMS)
+                                 ([LAMBDA (THEVALUE)
+                                    (DECLARE (LOCALVARS THEVALUE)
+                                           (TYPE THETYPE THEVALUE))
+                                    THEVALUE] . FORMS])
+)
+
+(PUTPROPS BYTECOMPILER FILETYPE LISP:COMPILE-FILE)
+
+(PUTPROPS BYTECOMPILER MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP"))
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML OPT.INITHASH)
+
+(ADDTOVAR LAMA )
+)
+(PUTPROPS BYTECOMPILER COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1900 
+1988 1989 1990 1991 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (9294 19279 (BYTEBLOCKCOMPILE2 9304 . 11928) (BYTECOMPILE2 11930 . 12165) (
+COMP.ATTEMPT.COMPILE 12167 . 13307) (COMP.RETFROM.POINT 13309 . 13944) (COMP.TRANSFORM 13946 . 17417) 
+(COMPERROR 17419 . 17713) (COMPPRINT 17715 . 18042) (COMPERRM 18044 . 19277)) (19280 28777 (
+COMP.TOPLEVEL.COMPILE 19290 . 25402) (COMP.BINDLIST 25404 . 25742) (COMP.CHECK.VAR 25744 . 26297) (
+COMP.BIND.VARS 26299 . 28369) (COMP.UNBIND.VARS 28371 . 28775)) (28778 42929 (COMP.VALN 28788 . 28917)
+ (COMP.PROGN 28919 . 29646) (COMP.PROGLST 29648 . 30576) (COMP.EXP1 30578 . 30722) (COMP.EXPR 30724 . 
+35456) (COMP.TRYUSERFN 35458 . 35787) (COMP.USERFN 35789 . 36708) (COMP.CONST 36710 . 37765) (
+COMP.CALL 37767 . 39196) (COMP.VAR 39198 . 39677) (COMP.VAL1 39679 . 39808) (COMP.PROG1 39810 . 40231)
+ (COMP.EFFECT 40233 . 40804) (COMP.VAL 40806 . 41423) (COMP.MACRO 41425 . 42927)) (42930 45145 (
+COMP.VARTYPE 42940 . 43165) (COMP.LOOKUPVAR 43167 . 44659) (COMP.LOOKUPCONST 44661 . 45143)) (45146 
+52803 (COMP.ST 45156 . 45645) (COMP.STFN 45647 . 46053) (COMP.STCONST 46055 . 46220) (COMP.STVAR 46222
+ . 46354) (COMP.STPOP 46356 . 46515) (COMP.DELFN 46517 . 46751) (COMP.STRETURN 46753 . 46921) (
+COMP.STTAG 46923 . 47889) (COMP.STJUMP 47891 . 49974) (COMP.STSETQ 49976 . 50248) (COMP.STCOPY 50250
+ . 50426) (COMP.DELPUSH 50428 . 50588) (COMP.DELPOP 50590 . 50754) (COMP.STBIND 50756 . 52251) (
+COMP.STUNBIND 52253 . 52801)) (57681 60903 (COMP.ARGTYPE 57691 . 58856) (COMP.CLEANEXPP 58858 . 59170)
+ (COMP.CLEANFNP 59172 . 59582) (COMP.CLEANFNOP 59584 . 59728) (COMP.GLOBALVARP 59730 . 59904) (
+COMP.LINKCALLP 59906 . 60370) (COMP.ANONP 60372 . 60723) (COMP.NOSIDEEFFECTP 60725 . 60901)) (60904 
+64182 (COMP.CPI 60914 . 62761) (COMP.CPI1 62763 . 63488) (COMP.PICOUNT 63490 . 64180)) (64226 64423 (
+COMP.EVQ 64236 . 64421)) (64535 67343 (COMP.BOOL 64545 . 67341)) (67344 67868 (COMP.APPLYFNP 67354 . 
+67866)) (67910 68496 (COMP.AC 67920 . 68112) (COMP.PUNT 68114 . 68494)) (68550 70086 (COMP.FUNCTION 
+68560 . 68976) (COMP.LAM1 68978 . 69742) (COMP.GENFN 69744 . 70084)) (70296 80564 (COMP.COND 70306 . 
+73588) (COMP.IF 73590 . 75063) (COMP.SELECTQ 75065 . 80562)) (80751 81273 (COMP.QUOTE 80761 . 80991) (
+COMP.COMMENT 80993 . 81271)) (81325 84468 (COMP.DECLARE 81335 . 83392) (COMP.DECLARE1 83394 . 84466)) 
+(87384 88299 (COMP.CARCDR 87394 . 88082) (COMP.STCROP 88084 . 88297)) (88387 88722 (COMP.NOT 88397 . 
+88720)) (88813 89554 (COMP.SETQ 88823 . 89324) (COMP.SETN 89326 . 89552)) (89555 93919 (COMP.LAMBDA 
+89565 . 93917)) (94172 106619 (COMP.PROG 94182 . 98097) (COMP.GO 98099 . 99107) (COMP.RETURN 99109 . 
+100782) (COMP.BLOCK 100784 . 102482) (COMP.RETURN-FROM 102484 . 104925) (COMP.TAGBODY 104927 . 106617)
+) (106674 109297 (COMP.LABELS 106684 . 109295)) (112744 123062 (COMP.NUMERIC 112754 . 117700) (
+COMP.NUMBERCALL 117702 . 121669) (COMP.FIX 121671 . 121819) (COMP.STFIX 121821 . 122402) (COMP.DELFIX 
+122404 . 123060)) (123190 125193 (COMP.EQ 123200 . 125191)) (125255 129039 (COMP.NUMBERTEST 125265 . 
+129037)) (130542 138157 (COMP.MAP 130552 . 138155)) (140530 144973 (COMP.MLLIST 140540 . 141194) (
+COMP.MLL 141196 . 144270) (COMP.MLLVAR 144272 . 144581) (COMP.MLLFN 144583 . 144971)) (145990 152697 (
+OPT.RESOLVEJUMPS 146000 . 147488) (OPT.JLENPASS 147490 . 151579) (OPT.JFIXPASS 151581 . 152255) (
+OPT.JSIZE 152257 . 152695)) (152743 155531 (OPT.CALLP 152753 . 153227) (OPT.JUMPCHECK 153229 . 153441)
+ (OPT.DREV 153443 . 153642) (OPT.CHLEV 153644 . 153851) (OPT.CHECKTAG 153853 . 154228) (OPT.NOTJUMP 
+154230 . 154731) (OPT.INITHASH 154733 . 155110) (OPT.COMPINIT 155112 . 155529)) (155725 156488 (
+OPT.CFRPTQ 155735 . 156486)) (157543 164842 (COMP.AREF 157553 . 158654) (COMP.ASET 158656 . 159757) (
+COMP.BOX 159759 . 160512) (COMP.LOOKFORDECLARE 160514 . 161203) (COMP.DECLARETYPE 161205 . 161800) (
+COMP.FLOATBOX 161802 . 162052) (COMP.FLOATUNBOX 162054 . 163040) (COMP.PREDP 163042 . 163241) (
+COMP.UBFLOAT2 163243 . 163820) (COMP.UNBOX 163822 . 164840)) (164909 225464 (OPT.POSTOPT 164919 . 
+166853) (OPT.SETUPOPT 166855 . 169300) (OPT.SCANOPT 169302 . 178415) (OPT.XVARSCAN 178417 . 179554) (
+OPT.XVARSCAN1 179556 . 180195) (OPT.JUMPOPT 180197 . 180839) (OPT.JUMPTHRU 180841 . 187961) (
+OPT.LBMERGE 187963 . 188589) (OPT.PRDEL 188591 . 189073) (OPT.UBDEL 189075 . 189328) (OPT.LBDEL 189330
+ . 190090) (OPT.LABELNTHPR 190092 . 191068) (OPT.JUMPREV 191070 . 205829) (OPT.COMMONBACK 205831 . 
+208798) (OPT.DELTAGREF 208800 . 209686) (OPT.FINDEND 209688 . 210044) (OPT.RETOPT 210046 . 211456) (
+OPT.RETFIND 211458 . 211927) (OPT.RETPOP 211929 . 214625) (OPT.RETOPT1 214627 . 215018) (OPT.RETTEST 
+215020 . 218612) (OPT.RETMERGE 218614 . 222074) (OPT.CODELEV 222076 . 224126) (OPT.CODEFRAME 224128 . 
+224936) (OPT.DEFREFS 224938 . 225179) (OPT.SETDEFREFS 225181 . 225462)) (225465 247507 (OPT.FRAMEOPT 
+225475 . 226622) (OPT.FRAMEMERGE 226624 . 229907) (OPT.NONILVAR 229909 . 231048) (OPT.MERGEFRAMEP 
+231050 . 232595) (OPT.FRAMELOCAL 232597 . 233443) (OPT.CLEANFRAME 233445 . 234080) (OPT.FRAMEDEL 
+234082 . 242633) (OPT.FRAMEVAR 242635 . 246719) (OPT.DELETEFRAMECHECK 246721 . 247314) (OPT.ONLYMEMB 
+247316 . 247505)) (247589 256683 (OPT.SKIPPUSH 247599 . 250022) (OPT.DELCODE 250024 . 251474) (
+OPT.PRATTACH 251476 . 251945) (OPT.JUMPCOPYTEST 251947 . 252868) (OPT.EQOP 252870 . 254053) (
+OPT.EQVALUE 254055 . 255158) (OPT.DELCOPYFN 255160 . 256681)) (256684 259444 (OPT.DEADSETQP 256694 . 
+257325) (OPT.DS1 257327 . 259442)) (263196 267779 (OPT.COMPILERERROR 263206 . 263380) (OPT.OPTCHECK 
+263382 . 267634) (OPT.CCHECK 267636 . 267777)))))
+STOP
diff --git a/CLTL2/BYTECOMPILER.LCOM b/CLTL2/BYTECOMPILER.LCOM
new file mode 100644
index 00000000..8faeda30
Binary files /dev/null and b/CLTL2/BYTECOMPILER.LCOM differ
diff --git a/CLTL2/CL-ERROR b/CLTL2/CL-ERROR
new file mode 100644
index 00000000..f3874391
--- /dev/null
+++ b/CLTL2/CL-ERROR
@@ -0,0 +1,1053 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
+(IL:FILECREATED "13-Oct-93 18:50:03" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CL-ERROR.;2" 64863  
+
+      IL:|previous| IL:|date:| "28-Feb-92 11:46:47" 
+"{Pele:mv:envos}<LispCore>Sources>CLTL2>CL-ERROR.;1")
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CL-ERRORCOMS)
+
+(IL:RPAQQ IL:CL-ERRORCOMS
+          ((IL:COMS 
+
+                  (IL:* IL:|;;| "Internal stuff. ")
+
+                  (IL:FUNCTIONS CONDITIONS::EXPAND-WITH-COLLECTION-SITES 
+                         CONDITIONS::WITH-COLLECTION-SITES)
+                  (IL:FUNCTIONS DEFAULT-PROCEED-REPORT CONDITIONS::DEFAULT-RESTART-REPORT)
+                  (IL:FUNCTIONS IL:WITH-GENSYMS IL:WITH-ERR-LOOP-VARS IL:STRIP-KEYWORDS 
+                         IL:MAKE-REPORT-FUNCTION CONDITIONS::NORMALIZE-SLOT-DESCRIPTION 
+                         IL:CHECK-*CASE-SELECTOR IL:COLLECT-CASE-SELECTORS IL:%SUFFIX-SYMBOL 
+                         IL:PROCEED-ARG-COLLECTOR SI::EXPAND-CONDITION-CASE 
+                         SI::PROCESS-PROCEED-KEYWORDS SI::SPLIT-PROCEED-CLAUSES 
+                         SI::EXPAND-PROCEED-CASE CONDITIONS::PARSE-RESTART-CASE 
+                         CONDITIONS::CONVERT-RESTART-CASES CONDITIONS::EXPAND-RESTART-CASE 
+                         CONDITIONS::EXPAND-WCS))
+           (OPTIMIZERS CONDITION-CASE CATCH-ABORT PROCEED-CASE RESTART-CASE WITH-CONDITION-RESTARTS)
+           (IL:COMS (IL:FUNCTIONS DEFINE-CONDITION CHECK-TYPE ETYPECASE CTYPECASE ECASE CCASE ASSERT
+                           HANDLER-BIND CONDITION-BIND CONDITION-CASE HANDLER-CASE IGNORE-ERRORS 
+                           PROCEED-CASE RESTART-CASE RESTART-BIND WITH-SIMPLE-RESTART 
+                           DEFINE-PROCEED-FUNCTION CATCH-ABORT WITH-CONDITION-RESTARTS))
+           
+           (IL:* IL:|;;| "Conversion functions for translating old code")
+
+           (IL:FUNCTIONS CONDITIONS::CONVERT-CONDITION-CASE CONDITIONS::CONVERT-OLD-DEFINE-CONDITION)
+           (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                  IL:CL-ERROR)
+           (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS
+                                                                                         (IL:NLAMA)
+                                                                                         (IL:NLAML)
+                                                                                         (IL:LAMA)))))
+
+
+
+(IL:* IL:|;;| "Internal stuff. ")
+
+
+(DEFUN CONDITIONS::EXPAND-WITH-COLLECTION-SITES (CONDITIONS::NEW-SITES CONDITIONS::BODY 
+                                                           CONDITIONS::OLD-SITES)
+   (LET ((CONDITIONS::NEW-SITES-AND-TAILS NIL))
+        `(LET ,(MAPCAN #'(LAMBDA (CONDITIONS::SITE)
+                                (UNLESS (GETF CONDITIONS::OLD-SITES CONDITIONS::SITE)
+                                    `((,(CAR (PUSH (IL:GENSYM)
+                                                   CONDITIONS::OLD-SITES))
+                                       (LAST ,(CAR (PUSH CONDITIONS::SITE CONDITIONS::OLD-SITES))))))
+                                )
+                      CONDITIONS::NEW-SITES)
+              (MACROLET ((CONDITIONS::WITH-COLLECTION-SITES ((&REST CONDITIONS::SITES)
+                                                                 &BODY CONDITIONS::BODY)
+                                (CONDITIONS::EXPAND-WITH-COLLECTION-SITES CONDITIONS::SITES 
+                                       CONDITIONS::BODY ',CONDITIONS::OLD-SITES))
+                         (CONDITIONS::COLLECT-INTO
+                          (CONDITIONS::SITE CONDITIONS::FORM)
+
+                          (IL:* IL:|;;| "written in this way to take advantage of RPLCONS. The FORM is evaluated first so that COLLECT-INTO nests properly, i.e., the test to determine if this is the first value collected should be done after the value itself is generated in case it does collection as well.")
+
+                          (LET ((CONDITIONS::TAIL (GETF ',CONDITIONS::OLD-SITES CONDITIONS::SITE)))
+                               (WHEN (NULL CONDITIONS::TAIL)
+                                   (ERROR "~S is not a valid site for ~S." CONDITIONS::SITE
+                                          'CONDITIONS::COLLECT-INTO))
+                               `(LET ((SI::$WITH-COLLECTION-VALUE$ ,CONDITIONS::FORM))
+                                     (IF ,CONDITIONS::SITE
+                                         (RPLACD ,CONDITIONS::TAIL (SETQ ,CONDITIONS::TAIL
+                                                                         (LIST 
+                                                                          SI::$WITH-COLLECTION-VALUE$
+                                                                               )))
+                                         (SETQ ,CONDITIONS::SITE (SETQ ,CONDITIONS::TAIL (LIST 
+                                                                          SI::$WITH-COLLECTION-VALUE$
+                                                                                               ))))
+                                     SI::$WITH-COLLECTION-VALUE$))))
+                     ,@CONDITIONS::BODY))))
+
+(DEFMACRO CONDITIONS::WITH-COLLECTION-SITES ((&REST CONDITIONS::SITES)
+                                                 &BODY CONDITIONS::BODY)
+   (CONDITIONS::EXPAND-WITH-COLLECTION-SITES CONDITIONS::SITES CONDITIONS::BODY NIL))
+
+(DEFMACRO DEFAULT-PROCEED-REPORT (PROCEED-TYPE)
+   `(GET ,PROCEED-TYPE 'IL:%DEFAULT-PROCEED-REPORT 'IL:DEFAULT-PROCEED-REPORTER))
+
+(DEFMACRO CONDITIONS::DEFAULT-RESTART-REPORT (CONDITIONS::RESTART-TYPE)
+   `(GET ,CONDITIONS::RESTART-TYPE 'IL:%DEFAULT-PROCEED-REPORT))
+
+(DEFMACRO IL:WITH-GENSYMS (IL:VARS IL:PREFIX &BODY IL:BODY)
+   `(LET ,(IL:MAPCAR IL:VARS (IL:FUNCTION (LAMBDA (IL:VAR)
+                                                 `(,IL:VAR (IL:GENSYM ,IL:PREFIX)))))
+         ,@IL:BODY))
+
+(DEFMACRO IL:WITH-ERR-LOOP-VARS (IL:PREFIX &BODY IL:BODY)
+   `(IL:WITH-GENSYMS (IL:VAL IL:BLOCK-NAME IL:AGAIN)
+           ,IL:PREFIX
+           ,@IL:BODY))
+
+(DEFUN IL:STRIP-KEYWORDS (IL:ARGS)
+   (VALUES (IL:FOR IL:OLD IL:ARGS IL:ON IL:ARGS IL:BY CDDR
+              IL:WHILE (KEYWORDP (FIRST IL:ARGS)) IL:COLLECT (LIST (FIRST IL:ARGS)
+                                                                           (SECOND IL:ARGS)))
+          IL:ARGS))
+
+(DEFUN IL:MAKE-REPORT-FUNCTION (IL:DATUM IL:BOUND-VAR &OPTIONAL IL:TYPE-NAME)
+   (ETYPECASE IL:DATUM
+       (STRING IL:DATUM)
+       (LIST `(LAMBDA (,IL:BOUND-VAR *STANDARD-OUTPUT*)
+                     ,(IF IL:TYPE-NAME
+                          `(IL:WITH ,IL:TYPE-NAME ,IL:BOUND-VAR ,IL:DATUM)
+                          IL:DATUM)))))
+
+(DEFUN CONDITIONS::NORMALIZE-SLOT-DESCRIPTION (CONDITIONS::SLOT-DESC)
+   (ETYPECASE CONDITIONS::SLOT-DESC
+       (CONS `(,(FIRST CONDITIONS::SLOT-DESC)
+               ,(SECOND CONDITIONS::SLOT-DESC)
+               :READ-ONLY T))
+       (SYMBOL `(,CONDITIONS::SLOT-DESC NIL :READ-ONLY T))))
+
+(DEFUN IL:CHECK-*CASE-SELECTOR (IL:SELECTOR IL:NAME)
+   (IF (OR (EQ IL:SELECTOR 'T)
+           (EQ IL:SELECTOR 'OTHERWISE))
+       (ERROR "~A not allowed in the ~A form." IL:SELECTOR IL:NAME)
+       IL:SELECTOR))
+
+(DEFUN IL:COLLECT-CASE-SELECTORS (IL:CLAUSES IL:NAME)
+   (IL:MAPCONC IL:CLAUSES (IL:FUNCTION (LAMBDA (IL:CLAUSE)
+                                              (IL:IF (AND (CONSP (CAR IL:CLAUSE))
+                                                              (IL:FMEMB IL:NAME '(ECASE CCASE)))
+                                                  IL:THEN (COPY-LIST (CAR IL:CLAUSE))
+                                                IL:ELSE (LIST (IL:CHECK-*CASE-SELECTOR
+                                                                   (CAR IL:CLAUSE)
+                                                                   IL:NAME)))))))
+
+(DEFUN IL:%SUFFIX-SYMBOL (IL:SYMBOL IL:SUFFIX PACKAGE)
+   (INTERN (CONCATENATE 'STRING (SYMBOL-NAME IL:SYMBOL)
+                  IL:SUFFIX)
+          PACKAGE))
+
+(DEFMACRO IL:PROCEED-ARG-COLLECTOR (IL:NAME)
+   "Function that collects user-specified optional args (excluding the condition) for a named proceed case."
+   `(GET ,IL:NAME 'IL:%PROCEED-ARG-COLLECTOR))
+
+(DEFUN SI::EXPAND-CONDITION-CASE (SI::FORM SI::CLAUSES SI::ENV SI::CTX SI::OPTIMIZE?)
+   (MACROLET
+    ((SI::BOUND-TYPES (SI::CLAUSE)
+            `(FIRST ,SI::CLAUSE)))
+    (IF (NULL SI::CLAUSES)
+        SI::FORM
+
+        (IL:* IL:|;;| "First, precompute the handler for this condition-case. We can use a constant catch tag because of the nice dynamic nesting properties of CONDITION-CASE.")
+
+        (LET*
+         ((SI::VALUE-SLOT (IF IL:*BYTECOMPILER-IS-EXPANDING*
+                              (IL:GENSYM)
+                              'SI::CONDITION-CASE-VALUES))
+          (SI::NO-ERROR-CLAUSE (ASSOC ':NO-ERROR SI::CLAUSES :TEST 'EQ))
+          (SI::ONLY-ONE-VALUE? (AND (NULL SI::NO-ERROR-CLAUSE)
+                                    SI::OPTIMIZE? SI::CTX (EQL (COMPILER:CONTEXT-VALUES-USED SI::CTX)
+                                                               1))))
+         (DECLARE (SPECIAL IL:*BYTECOMPILER-IS-EXPANDING*))
+         (FLET
+          ((SI::CONSTRUCT-NO-ERROR-CODE
+            (SI::VALUE-FORM)
+            (DESTRUCTURING-BIND
+             (SI::SELECTOR SI::BOUND-VARS &REST SI::BODY)
+             SI::NO-ERROR-CLAUSE
+             (DECLARE (IGNORE SI::SELECTOR))
+             (MACROLET ((SI::VALUE-IS-VALUES-LIST NIL '(AND (CONSP SI::VALUE-FORM)
+                                                            (EQ (FIRST SI::VALUE-FORM)
+                                                                'VALUES-LIST))))
+                    (COND
+                       ((NULL SI::BOUND-VARS)
+                        `(PROGN ,SI::VALUE-FORM ,@(CDDR SI::NO-ERROR-CLAUSE)))
+                       ((NULL (REST SI::BOUND-VARS))
+
+                        (IL:* IL:|;;| "One bound var...")
+
+                        `(LET (,(FIRST SI::BOUND-VARS)
+                               ,(IF (SI::VALUE-IS-VALUES-LIST)
+                                    `(FIRST ,(SECOND SI::VALUE-FORM))
+                                    SI::VALUE-FORM))
+                              ,@SI::BODY))
+                       (T 
+                          (IL:* IL:|;;| "Several bound vars, need to capture them all")
+
+                          (IF (SI::VALUE-IS-VALUES-LIST)
+                              `(DESTRUCTURING-BIND ,SI::BOUND-VARS ,(SECOND SI::VALUE-FORM)
+                                      ,@SI::BODY)
+                              `(MULTIPLE-VALUE-BIND ,SI::BOUND-VARS ,SI::VALUE-FORM ,@SI::BODY)))))))
+           )
+          (WHEN (AND SI::NO-ERROR-CLAUSE (NULL (REST SI::CLAUSES)))
+
+              (IL:* IL:|;;| "Degenerate case: only has a :NO-ERROR clause")
+
+              (RETURN-FROM SI::EXPAND-CONDITION-CASE (SI::CONSTRUCT-NO-ERROR-CODE SI::FORM)))
+          `(LET*
+            ((SI::CONDITION-CASE-LITERALS
+              (IL:LOADTIMECONSTANT
+               (SI::CREATE-CONDITION-CASE-LITERALS
+                ',(LET ((SI::TYPE-BINDINGS (WITH-COLLECTION (DOLIST (SI::CLAUSE SI::CLAUSES)
+                                                                (UNLESS (EQ (SI::BOUND-TYPES 
+                                                                                   SI::CLAUSE)
+                                                                            :NO-ERROR)
+                                                                    (COLLECT (SI::BOUND-TYPES 
+                                                                                    SI::CLAUSE)))))))
+                       (IF (NULL (REST SI::TYPE-BINDINGS))
+                           (FIRST SI::TYPE-BINDINGS)
+                           (CONS 'OR SI::TYPE-BINDINGS))))))
+             ,SI::VALUE-SLOT
+             (SI::CONDITION-CASE-SELECTOR
+              (CATCH (CAR SI::CONDITION-CASE-LITERALS)
+                  (LET ((IL:*CONDITION-HANDLER-BINDINGS* (CONS (CDR SI::CONDITION-CASE-LITERALS)
+                                                               IL:*CONDITION-HANDLER-BINDINGS*)))
+                       (SETF ,SI::VALUE-SLOT ,(IF SI::ONLY-ONE-VALUE?
+                                                  SI::FORM
+                                                  `(MULTIPLE-VALUE-LIST ,SI::FORM)))
+                       :NORMAL))))
+            (DECLARE (IL:LOCALVARS SI::CONDITION-CASE-SELECTOR))
+            (COND
+               ((EQ SI::CONDITION-CASE-SELECTOR :NORMAL)
+                ,(COND
+                    (SI::NO-ERROR-CLAUSE (SI::CONSTRUCT-NO-ERROR-CODE `(VALUES-LIST ,SI::VALUE-SLOT))
+                           )
+                    (SI::ONLY-ONE-VALUE? SI::VALUE-SLOT)
+                    (T `(VALUES-LIST ,SI::VALUE-SLOT))))
+               ,@(MAPCAN
+                  #'(LAMBDA
+                     (SI::CLAUSE)
+                     (DESTRUCTURING-BIND
+                      (SI::SELECTOR SI::BOUND-VAR-LIST &REST SI::BODY)
+                      SI::CLAUSE
+                      (AND (NOT (EQ SI::SELECTOR :NO-ERROR))
+                           `(((TYPEP SI::CONDITION-CASE-SELECTOR ',SI::SELECTOR)
+                              ,@(IF (NULL SI::BOUND-VAR-LIST)
+                                    (OR SI::BODY '(NIL))
+                                    `(((LAMBDA ,SI::BOUND-VAR-LIST ,@(OR SI::BODY '(NIL)))
+                                       SI::CONDITION-CASE-SELECTOR))))))))
+                  SI::CLAUSES)
+               (T (SI::CONDITION-CASE-ERROR SI::CONDITION-CASE-SELECTOR (CADR 
+                                                                          SI::CONDITION-CASE-LITERALS
+                                                                              ))))))))))
+
+(DEFUN SI::PROCESS-PROCEED-KEYWORDS (SI::NAME SI::ARG PACKAGE)
+   (LET (SI::FILTER SI::REPORT)
+        (MULTIPLE-VALUE-BIND
+         (SI::KEYS SI::TAIL)
+         (IL:STRIP-KEYWORDS SI::ARG)
+         (IL:|for| SI::PAIR IL:|in| SI::KEYS
+            IL:|do| (DESTRUCTURING-BIND
+                         (SI::KEY SI::VALUE)
+                         SI::PAIR
+                         (CASE SI::KEY
+                             (:FILTER-FUNCTION 
+                                (IF SI::FILTER (ERROR 
+                                                    "Duplicate filter specified for proceed type ~S."
+                                                      SI::NAME))
+                                (SETF SI::FILTER SI::VALUE))
+                             (:FILTER 
+                                (IF SI::FILTER (ERROR 
+                                                    "Duplicate filter specified for proceed type ~S."
+                                                      SI::NAME))
+                                (SETF SI::FILTER `(LAMBDA NIL ,SI::VALUE)))
+                             (:CONDITION 
+                                (IF SI::FILTER (ERROR 
+                                                 "Duplicate test form specified for proceed type ~S."
+                                                      SI::NAME))
+                                (SETF SI::FILTER 
+
+                                      (IL:* IL:|;;| "consider using a closure here.")
+
+                                      `(LAMBDA NIL (TYPEP *CURRENT-CONDITION* ',SI::VALUE))))
+                             (:REPORT-FUNCTION 
+                                (IF SI::REPORT (ERROR 
+                                               "Duplicate report form specified for proceed type ~S."
+                                                      SI::NAME))
+                                (SETF SI::REPORT SI::VALUE))
+                             (:REPORT 
+                                (IF SI::REPORT (ERROR 
+                                               "Duplicate report form specified for proceed type ~S."
+                                                      SI::NAME))
+                                (SETF SI::REPORT (ETYPECASE SI::VALUE
+                                                     (STRING SI::VALUE)
+                                                     (LIST `(LAMBDA (*STANDARD-OUTPUT*)
+                                                                   ,SI::VALUE)))))
+                             (OTHERWISE (CERROR "Ignore key/value pair" 
+                                               "Illegal keyword ~S in proceed case ~S." SI::KEY 
+                                               SI::NAME)))))
+         (VALUES SI::FILTER SI::REPORT SI::TAIL))))
+
+(DEFUN SI::SPLIT-PROCEED-CLAUSES (SI::CLAUSES SI::ENV SI::OPTIMIZE?)
+   (LET
+    (SI::CASES SI::BODIES)
+    (IL:FOR SI::CLAUSE IL:IN SI::CLAUSES IL:AS SI::SELECTOR IL:FROM 0
+       IL:DO
+       (DESTRUCTURING-BIND
+        (SI::NAME SI::VARS)
+        SI::CLAUSE
+        (MULTIPLE-VALUE-BIND
+         (SI::FILTER SI::REPORT SI::TAIL)
+         (SI::PROCESS-PROCEED-KEYWORDS SI::NAME (CDDR SI::CLAUSE)
+                *PACKAGE*)
+         (IF (NULL SI::NAME)
+             (UNLESS SI::REPORT (ERROR "Unnamed proceed cases must have a report method: ~S" 
+                                       SI::CLAUSE)))
+         (MACROLET ((SI::CONSTANT-PROCEED-CASE?
+                     NIL
+                     '(AND (OR (NULL SI::FILTER)
+                               (AND (SYMBOLP SI::FILTER)
+                                    (OR (NULL SI::ENV)
+                                        (NOT (COMPILER:ENV-FBOUNDP SI::ENV SI::FILTER)))))
+                           (OR (NULL SI::REPORT)
+                               (STRINGP SI::REPORT)
+                               (AND (SYMBOLP SI::REPORT)
+                                    (OR (NULL SI::ENV)
+                                        (NOT (COMPILER:ENV-FBOUNDP SI::ENV NIL))))))))
+                (PUSH (IF (AND SI::OPTIMIZE? (SI::CONSTANT-PROCEED-CASE?))
+                          (IL:MAKE-PROCEED-CASE :NAME SI::NAME :SELECTOR SI::SELECTOR :TEST 
+                                 SI::FILTER :REPORT SI::REPORT)
+                          `(IL:MAKE-PROCEED-CASE :NAME ',SI::NAME :SELECTOR ,SI::SELECTOR :TEST
+                                  ,(AND SI::FILTER `#',SI::FILTER)
+                                  :REPORT
+                                  ,(AND SI::REPORT (IF (STRINGP SI::REPORT)
+                                                       SI::REPORT
+                                                       `#',SI::REPORT))))
+                      SI::CASES))
+         (PUSH (LIST* SI::SELECTOR SI::VARS SI::TAIL)
+               SI::BODIES))))
+    (VALUES (FLET ((SI::MAYBE-QUOTE (SI::X)
+                          (IF (IL:PROCEED-CASE-P SI::X)
+                              (IL:KWOTE SI::X)
+                              SI::X)))
+                  (COND
+                     ((EQL (IL:LENGTH SI::CASES)
+                           1)
+                      (SI::MAYBE-QUOTE (FIRST SI::CASES)))
+                     ((EVERY 'IL:PROCEED-CASE-P SI::CASES)
+                      (IL:KWOTE (NREVERSE SI::CASES)))
+                     (T `(LIST ,@(MAPCAR #'SI::MAYBE-QUOTE (NREVERSE SI::CASES))))))
+           (REVERSE SI::BODIES))))
+
+(DEFUN SI::EXPAND-PROCEED-CASE (SI::FORM SI::CLAUSES SI::ENV SI::CTX SI::OPTIMIZE?)
+   (LET
+    ((SI::VALUE-SLOT (IF IL:*BYTECOMPILER-IS-EXPANDING*
+                         (IL:GENSYM)
+                         'SI::PROCEED-CASE-NORMAL-VALUES))
+     (SI::ONLY-ONE-VALUE? (AND SI::OPTIMIZE? SI::CTX (EQL (COMPILER:CONTEXT-VALUES-USED SI::CTX)
+                                                          1))))
+    (DECLARE (SPECIAL IL:*BYTECOMPILER-IS-EXPANDING*))
+    (MULTIPLE-VALUE-BIND
+     (SI::CASES SI::BODIES)
+     (SI::SPLIT-PROCEED-CLAUSES SI::CLAUSES SI::ENV SI::OPTIMIZE?)
+     (IF (NULL SI::CASES)
+         SI::FORM
+         `(LET* (,SI::VALUE-SLOT (SI::PROCEED-CASE-SELECTOR-AND-VALUES
+                                  (LET ((IL:*PROCEED-CASES* (CONS ,SI::CASES IL:*PROCEED-CASES*)))
+                                       (CATCH IL:*PROCEED-CASES*
+                                           (SETF ,SI::VALUE-SLOT
+                                                 ,(IF SI::ONLY-ONE-VALUE?
+                                                      SI::FORM
+                                                      `(MULTIPLE-VALUE-LIST ,SI::FORM)))
+                                           :NORMAL))))
+                (IF (EQ SI::PROCEED-CASE-SELECTOR-AND-VALUES :NORMAL)
+                    ,(IF SI::ONLY-ONE-VALUE?
+                         SI::VALUE-SLOT
+                         `(VALUES-LIST ,SI::VALUE-SLOT))
+                    ,(FLET ((SI::CREATE-A-CASE (SI::X)
+                                   (DESTRUCTURING-BIND (CASE SI::ARGS
+                                                           &REST
+                                                           SI::BODY)
+                                          SI::X
+                                          (IF (NULL SI::ARGS)
+                                              `(,CASE ,@SI::BODY)
+                                              `(,CASE (DESTRUCTURING-BIND (&OPTIONAL ,@SI::ARGS)
+                                                             SI::PROCEED-CASE-VALUES
+                                                             ,@SI::BODY))))))
+                           (IF (EVERY #'(LAMBDA (SI::X)
+                                               (NULL (SECOND SI::X)))
+                                      SI::BODIES)
+                               `(CASE (CAR SI::PROCEED-CASE-SELECTOR-AND-VALUES)
+                                    (IL:\\\,@ (MAPCAR #'SI::CREATE-A-CASE SI::BODIES)))
+                               `((LAMBDA (SI::PROCEED-CASE-SELECTOR SI::PROCEED-CASE-VALUES)
+                                        (CASE SI::PROCEED-CASE-SELECTOR
+                                            (IL:\\\,@ (MAPCAR #'SI::CREATE-A-CASE SI::BODIES))))
+                                 (CAR SI::PROCEED-CASE-SELECTOR-AND-VALUES)
+                                 (CDR SI::PROCEED-CASE-SELECTOR-AND-VALUES))))))))))
+
+(DEFUN CONDITIONS::PARSE-RESTART-CASE (CONDITIONS::NAME CONDITIONS::CLAUSE)
+                                                             (IL:* IL:\; 
+                                                           "Edited 24-Feb-92 11:49 by jrb:")
+   (LET (CONDITIONS::FILTER CONDITIONS::REPORT CONDITIONS::INTERACTIVE)
+        (IL:WHILE (KEYWORDP (FIRST CONDITIONS::CLAUSE))
+           IL:DO (LET* ((CONDITIONS::KEY (POP CONDITIONS::CLAUSE))
+                            (CONDITIONS::VALUE (POP CONDITIONS::CLAUSE)))
+                           (CASE CONDITIONS::KEY
+                               (:FILTER (UNLESS CONDITIONS::FILTER (SETF CONDITIONS::FILTER 
+                                                                         CONDITIONS::VALUE)))
+                               (:TEST 
+
+                                 (IL:* IL:|;;| "This is actually not too bad as a back-patch goes; the compiler will correctly unroll (FUNCALL (FUNCTION <drek>) <args>) into as direct a call to <drek> as possible")
+
+                                  (UNLESS CONDITIONS::FILTER
+                                      (SETF CONDITIONS::FILTER
+                                            `(LAMBDA NIL (FUNCALL #',CONDITIONS::VALUE 
+                                                                *CURRENT-CONDITION*)))))
+                               (:CONDITION (UNLESS CONDITIONS::FILTER
+                                               (SETF CONDITIONS::FILTER
+                                                     `(LAMBDA NIL (TYPEP *CURRENT-CONDITION*
+                                                                         ',CONDITIONS::VALUE)))))
+                               (:REPORT (UNLESS CONDITIONS::REPORT (SETF CONDITIONS::REPORT 
+                                                                         CONDITIONS::VALUE)))
+                               (:INTERACTIVE (UNLESS CONDITIONS::INTERACTIVE (SETF 
+                                                                              CONDITIONS::INTERACTIVE
+                                                                                   CONDITIONS::VALUE)
+                                                    ))
+                               (OTHERWISE (CERROR "Ignore key/value pair" 
+                                                 "Illegal keyword ~S in restart named ~S." 
+                                                 CONDITIONS::KEY CONDITIONS::NAME)))))
+        (VALUES CONDITIONS::FILTER CONDITIONS::REPORT CONDITIONS::INTERACTIVE CONDITIONS::CLAUSE)))
+
+(DEFUN CONDITIONS::CONVERT-RESTART-CASES (CONDITIONS::CLAUSES CONDITIONS::ENV 
+                                                    CONDITIONS::OPTIMIZE?)
+   (LET
+    (CONDITIONS::CASES CONDITIONS::BODIES CONDITIONS::ANY-ARGLISTS? (CONDITIONS::ALL-CONSTANT? T))
+    (CONDITIONS::WITH-COLLECTION-SITES
+     (CONDITIONS::CASES CONDITIONS::BODIES)
+     (IL:FOR CONDITIONS::CLAUSE IL:IN CONDITIONS::CLAUSES IL:AS CONDITIONS::SELECTOR
+        IL:FROM 0
+        IL:DO
+        (LET*
+         ((CONDITIONS::NAME (POP CONDITIONS::CLAUSE))
+          (CONDITIONS::ARGLIST (POP CONDITIONS::CLAUSE)))
+         (WHEN CONDITIONS::ARGLIST (SETF CONDITIONS::ANY-ARGLISTS? T))
+         (MULTIPLE-VALUE-BIND
+          (CONDITIONS::FILTER CONDITIONS::REPORT CONDITIONS::INTERACTIVE CONDITIONS::CODE)
+          (CONDITIONS::PARSE-RESTART-CASE CONDITIONS::NAME CONDITIONS::CLAUSE)
+          (MACROLET
+           ((CONDITIONS::CONSTANT-RESTART? NIL
+                   '(AND (OR (NULL CONDITIONS::FILTER)
+                             (AND (SYMBOLP CONDITIONS::FILTER)
+                                  (OR (NULL CONDITIONS::ENV)
+                                      (NOT (COMPILER:ENV-FBOUNDP CONDITIONS::ENV CONDITIONS::FILTER))
+                                      )))
+                         (OR (NULL CONDITIONS::REPORT)
+                             (STRINGP CONDITIONS::REPORT)
+                             (AND (SYMBOLP CONDITIONS::REPORT)
+                                  (OR (NULL CONDITIONS::ENV)
+                                      (NOT (COMPILER:ENV-FBOUNDP CONDITIONS::ENV CONDITIONS::REPORT))
+                                      )))
+                         (OR (NULL CONDITIONS::INTERACTIVE)
+                             (AND (SYMBOLP CONDITIONS::INTERACTIVE)
+                                  (OR (NULL CONDITIONS::ENV)
+                                      (NOT (COMPILER:ENV-FBOUNDP CONDITIONS::ENV 
+                                                  CONDITIONS::INTERACTIVE))))))))
+           (CONDITIONS::COLLECT-INTO
+            CONDITIONS::CASES
+            (IF (AND CONDITIONS::OPTIMIZE? (CONDITIONS::CONSTANT-RESTART?))
+                (CONDITIONS::MAKE-RESTART :NAME CONDITIONS::NAME :SELECTOR CONDITIONS::SELECTOR :TEST
+                       CONDITIONS::FILTER :REPORT CONDITIONS::REPORT :INTERACTIVE-FN 
+                       CONDITIONS::INTERACTIVE)
+                (PROGN (SETF CONDITIONS::ALL-CONSTANT? NIL)
+                       `(CONDITIONS::MAKE-RESTART :NAME ',CONDITIONS::NAME :SELECTOR 
+                               ,CONDITIONS::SELECTOR :TEST ,(AND CONDITIONS::FILTER
+                                                                 `#',CONDITIONS::FILTER)
+                               :REPORT
+                               ,(AND CONDITIONS::REPORT (IF (STRINGP CONDITIONS::REPORT)
+                                                            CONDITIONS::REPORT
+                                                            `#',CONDITIONS::REPORT))
+                               :INTERACTIVE-FN
+                               ,(AND CONDITIONS::INTERACTIVE `#',CONDITIONS::INTERACTIVE))))))
+          (CONDITIONS::COLLECT-INTO CONDITIONS::BODIES (IF (NULL CONDITIONS::ARGLIST)
+                                                           `(,CONDITIONS::SELECTOR 
+                                                                   ,@CONDITIONS::CODE)
+                                                           `(,CONDITIONS::SELECTOR
+                                                             (DESTRUCTURING-BIND (
+                                                                                  ,@
+                                                                                  CONDITIONS::ARGLIST
+                                                                                  )
+                                                                    SI::PROCEED-CASE-VALUES
+                                                                    ,@CONDITIONS::CODE))))))))
+    (VALUES (COND
+               ((NULL (REST CONDITIONS::CASES))
+                (FIRST CONDITIONS::CASES))
+               (CONDITIONS::ALL-CONSTANT? `',CONDITIONS::CASES)
+               (T (CONS 'LIST CONDITIONS::CASES)))
+           CONDITIONS::BODIES CONDITIONS::ANY-ARGLISTS?)))
+
+(DEFUN CONDITIONS::EXPAND-RESTART-CASE (CONDITIONS::FORM CONDITIONS::CLAUSES CONDITIONS::ENV 
+                                                  CONDITIONS::CTX CONDITIONS::OPTIMIZE?)
+   (WHEN (NULL CONDITIONS::CLAUSES)
+         (RETURN-FROM CONDITIONS::EXPAND-RESTART-CASE CONDITIONS::FORM))
+   (LET ((CONDITIONS::VALUE-SLOT (IF IL:*BYTECOMPILER-IS-EXPANDING*
+                                     (IL:GENSYM)
+                                     'SI::PROCEED-CASE-NORMAL-VALUES))
+         (CONDITIONS::ONLY-ONE-VALUE? (AND CONDITIONS::OPTIMIZE? CONDITIONS::CTX (EQL (
+                                                                         COMPILER:CONTEXT-VALUES-USED
+                                                                                       
+                                                                                      CONDITIONS::CTX
+                                                                                       )
+                                                                                      1))))
+        (DECLARE (SPECIAL IL:*BYTECOMPILER-IS-EXPANDING*))
+        (MULTIPLE-VALUE-BIND
+         (CONDITIONS::CASES CONDITIONS::BODIES CONDITIONS::ANY-ARGLISTS?)
+         (CONDITIONS::CONVERT-RESTART-CASES CONDITIONS::CLAUSES CONDITIONS::ENV 
+                CONDITIONS::OPTIMIZE?)
+         `(LET* (,CONDITIONS::VALUE-SLOT
+                 (SI::PROCEED-CASE-SELECTOR-AND-VALUES
+                  (LET ((IL:*PROCEED-CASES* (CONS ,CONDITIONS::CASES IL:*PROCEED-CASES*)))
+                       (CATCH IL:*PROCEED-CASES*
+                           (SETF ,CONDITIONS::VALUE-SLOT ,(IF CONDITIONS::ONLY-ONE-VALUE?
+                                                              CONDITIONS::FORM
+                                                              `(MULTIPLE-VALUE-LIST 
+                                                                      ,CONDITIONS::FORM)))
+                           :NORMAL))))
+                (IF (EQ SI::PROCEED-CASE-SELECTOR-AND-VALUES :NORMAL)
+                    ,(IF CONDITIONS::ONLY-ONE-VALUE?
+                         CONDITIONS::VALUE-SLOT
+                         `(VALUES-LIST ,CONDITIONS::VALUE-SLOT))
+                    ,(IF CONDITIONS::ANY-ARGLISTS?
+                         `((LAMBDA (SI::PROCEED-CASE-SELECTOR SI::PROCEED-CASE-VALUES)
+                                  (CASE SI::PROCEED-CASE-SELECTOR
+                                      (IL:\\\,@ CONDITIONS::BODIES)))
+                           (CAR SI::PROCEED-CASE-SELECTOR-AND-VALUES)
+                           (CDR SI::PROCEED-CASE-SELECTOR-AND-VALUES))
+
+                         (IL:* IL:|;;| "Slightly simpler if no arglists to deal with...")
+
+                         `(CASE (CAR SI::PROCEED-CASE-SELECTOR-AND-VALUES)
+                              (IL:\\\,@ CONDITIONS::BODIES))))))))
+
+(DEFUN CONDITIONS::EXPAND-WCS (CONDITIONS::CONDITION-FORM CONDITIONS::RESTARTS-FORM 
+                                         CONDITIONS::BODY CONDITIONS::ENV CONDITIONS::CTX 
+                                         CONDITIONS::OPTIMIZE?)
+                                                             (IL:* IL:\; 
+                                                           "Edited 26-Feb-92 15:56 by jrb:")
+   (SETQ CONDITIONS::BODY `(LET NIL ,@CONDITIONS::BODY))
+   (WHEN (NULL CONDITIONS::RESTARTS-FORM)
+       (RETURN-FROM CONDITIONS::EXPAND-WCS `(PROGN ,CONDITIONS::CONDITION-FORM 
+                                                   ,CONDITIONS::RESTARTS-FORM ,CONDITIONS::BODY)))
+   (LET
+    ((CONDITIONS::VALUE-SLOT (IF IL:*BYTECOMPILER-IS-EXPANDING*
+                                 (IL:GENSYM)
+                                 'SI::PROCEED-CASE-NORMAL-VALUES))
+     (CONDITIONS::ONLY-ONE-VALUE? (AND CONDITIONS::OPTIMIZE? CONDITIONS::CTX (EQL (
+                                                                         COMPILER:CONTEXT-VALUES-USED
+                                                                                   CONDITIONS::CTX)
+                                                                                  1)))
+     (CONDITIONS::COND-BINDING (GENSYM))
+     (CONDITIONS::RESTARTS-BINDING (GENSYM)))
+    (DECLARE (SPECIAL IL:*BYTECOMPILER-IS-EXPANDING*))
+
+    (IL:* IL:|;;| "This is way weird, but I think it should work.  The idea is we bind copies of the restarts which have their filter tests munged to insure that they only will respond to the appropriate condition object.  I have NO idea why anyone would want this level of control over the system, but it's here now.")
+
+    `(LET
+      ((,CONDITIONS::COND-BINDING ,CONDITIONS::CONDITION-FORM))
+      (DECLARE (SPECIAL ,CONDITIONS::COND-BINDING))
+      (LET*
+       ((,CONDITIONS::RESTARTS-BINDING
+         (MAPCAR
+          #'(LAMBDA (CONDITIONS::R)
+                   (LET ((CONDITIONS::NEWRS (CONDITIONS::COPY-RESTART CONDITIONS::R)))
+                        (SETF (CONDITIONS::RESTART-TEST CONDITIONS::NEWRS)
+                              (IF (CONDITIONS::RESTART-TEST CONDITIONS::R)
+                                  `(LAMBDA NIL (AND (EQ *CURRENT-CONDITION*
+                                                        ',,CONDITIONS::COND-BINDING)
+                                                    (FUNCALL ',(CONDITIONS::RESTART-TEST 
+                                                                      CONDITIONS::R))))
+                                  `(LAMBDA NIL (EQ *CURRENT-CONDITION* ',,CONDITIONS::COND-BINDING)))
+                              )
+                        CONDITIONS::NEWRS))
+          ,CONDITIONS::RESTARTS-FORM))
+        ,CONDITIONS::VALUE-SLOT
+        (SI::PROCEED-CASE-SELECTOR-AND-VALUES
+         (LET ((IL:*PROCEED-CASES* (CONS ,CONDITIONS::RESTARTS-BINDING IL:*PROCEED-CASES*)))
+              (CATCH IL:*PROCEED-CASES*
+                  (SETF ,CONDITIONS::VALUE-SLOT ,(IF CONDITIONS::ONLY-ONE-VALUE?
+                                                     CONDITIONS::BODY
+                                                     `(MULTIPLE-VALUE-LIST ,CONDITIONS::BODY)))
+                  :NORMAL))))
+       (IF (EQ SI::PROCEED-CASE-SELECTOR-AND-VALUES :NORMAL)
+           ,(IF CONDITIONS::ONLY-ONE-VALUE?
+                CONDITIONS::VALUE-SLOT
+                `(VALUES-LIST ,CONDITIONS::VALUE-SLOT))
+           (APPLY (CONDITIONS::RESTART-FUNCTION (NTH (CAR SI::PROCEED-CASE-SELECTOR-AND-VALUES)
+                                                     ,CONDITIONS::RESTARTS-BINDING))
+                  (CDR SI::PROCEED-CASE-SELECTOR-AND-VALUES)))))))
+
+(DEFOPTIMIZER CONDITION-CASE (FORM &REST CLAUSES &ENVIRONMENT ENV &CONTEXT CTX)
+                                 (SI::EXPAND-CONDITION-CASE FORM CLAUSES ENV CTX T))
+
+(DEFOPTIMIZER CATCH-ABORT (PRINT-FORM &BODY FORMS &ENVIRONMENT ENV &CONTEXT CTX)
+                              (IF (AND CTX (EQL (COMPILER:CONTEXT-VALUES-USED CTX)
+                                                1))
+                                  `(PROCEED-CASE (PROGN ,@FORMS)
+                                          (ABORT NIL :REPORT ,PRINT-FORM NIL))
+                                  'COMPILER:PASS))
+
+(DEFOPTIMIZER PROCEED-CASE (FORM &REST CLAUSES &ENVIRONMENT ENV &CONTEXT CTX)
+                               (SI::EXPAND-PROCEED-CASE FORM CLAUSES ENV CTX T))
+
+(DEFOPTIMIZER RESTART-CASE (CONDITIONS::FORM &REST CONDITIONS::CLAUSES &ENVIRONMENT 
+                                      CONDITIONS::ENV &CONTEXT CONDITIONS::CTX)
+                               (CONDITIONS::EXPAND-RESTART-CASE CONDITIONS::FORM 
+                                      CONDITIONS::CLAUSES CONDITIONS::ENV CONDITIONS::CTX T))
+
+(DEFOPTIMIZER WITH-CONDITION-RESTARTS (CONDITIONS::CONDITION-FORM CONDITIONS::RESTARTS-FORM &REST
+                                                 CONDITIONS::BODY &ENVIRONMENT CONDITIONS::ENV 
+                                                 &CONTEXT CONDITIONS::CTX)
+                                          (CONDITIONS::EXPAND-WCS CONDITIONS::CONDITION-FORM 
+                                                 CONDITIONS::RESTARTS-FORM CONDITIONS::BODY 
+                                                 CONDITIONS::ENV CONDITIONS::CTX T))
+
+(DEFDEFINER DEFINE-CONDITION IL:STRUCTURES (CONDITIONS::NAME (CONDITIONS::PARENT-TYPE)
+                                                      &OPTIONAL CONDITIONS::SLOTS &REST 
+                                                      CONDITIONS::OPTIONS)
+   (LET ((CONDITIONS::PARENT-SLOTS (AND CONDITIONS::PARENT-TYPE (LISP::STRUCTURE-SLOT-NAMES 
+                                                                       CONDITIONS::PARENT-TYPE T)))
+         CONDITIONS::REPORTER CONDITIONS::HANDLER CONDITIONS::SLOT-DESCRIPTIONS 
+         CONDITIONS::SHADOWED-SLOT-DESCRIPTIONS CONDITIONS::CLASS-OPTIONS CONDITIONS::DOC)
+        (SETQ CONDITIONS::SLOT-DESCRIPTIONS (WITH-COLLECTION (DOLIST (CONDITIONS::SLOT 
+                                                                            CONDITIONS::SLOTS)
+                                                                 (SETQ CONDITIONS::SLOT (
+                                                             CONDITIONS::NORMALIZE-SLOT-DESCRIPTION
+                                                                                         
+                                                                                     CONDITIONS::SLOT
+                                                                                         ))
+                                                                 (IF (MEMBER (FIRST CONDITIONS::SLOT)
+                                                                            CONDITIONS::PARENT-SLOTS
+                                                                            :TEST 'EQ)
+                                                                     (PUSH CONDITIONS::SLOT 
+                                                               CONDITIONS::SHADOWED-SLOT-DESCRIPTIONS
+                                                                           )
+                                                                     (COLLECT CONDITIONS::SLOT)))))
+        (SETQ CONDITIONS::CLASS-OPTIONS (WITH-COLLECTION
+                                         (DOLIST (CONDITIONS::OPTION CONDITIONS::OPTIONS)
+                                             (MACROLET ((CONDITIONS::MULTIPLE-OPTION-ERROR
+                                                         NIL
+                                                         '(CERROR "Ignore the later ~*~S option" 
+                                                                "~S is a duplicate ~S option for ~S."
+                                                                 CONDITIONS::OPTION (FIRST 
+                                                                                   CONDITIONS::OPTION
+                                                                                           )
+                                                                 'DEFINE-CONDITION)))
+                                                    (ECASE (FIRST CONDITIONS::OPTION)
+                                                        ((:CONC-NAME :INLINE) (COLLECT 
+                                                                                   CONDITIONS::OPTION
+                                                                                     ))
+                                                        (:DOCUMENTATION (AND CONDITIONS::DOC
+                                                                             (SETQ CONDITIONS::DOC
+                                                                                   (SECOND 
+                                                                                   CONDITIONS::OPTION
+                                                                                          ))))
+                                                        (:REPORT (IF (NULL CONDITIONS::REPORTER)
+                                                                     (SETQ CONDITIONS::REPORTER
+                                                                           (SECOND CONDITIONS::OPTION
+                                                                                  ))
+                                                                     (
+                                                                    CONDITIONS::MULTIPLE-OPTION-ERROR
+                                                                      )))
+                                                        (:HANDLE (IF (NULL CONDITIONS::HANDLER)
+                                                                     (SETQ CONDITIONS::HANDLER
+                                                                           (SECOND CONDITIONS::OPTION
+                                                                                  ))
+                                                                     (
+                                                                    CONDITIONS::MULTIPLE-OPTION-ERROR
+                                                                      ))))))))
+        `(PROGN (DEFSTRUCT (,CONDITIONS::NAME ,@(AND CONDITIONS::PARENT-TYPE 
+                                                             (IL:* IL:\; "hook for CONDITION")
+                                                     `((:INCLUDE ,CONDITIONS::PARENT-TYPE
+                                                              ,.(NREVERSE 
+                                                               CONDITIONS::SHADOWED-SLOT-DESCRIPTIONS
+                                                                       ))))
+                                  ,.CONDITIONS::CLASS-OPTIONS
+                                  (:PRINT-FUNCTION IL:%PRINT-CONDITION)
+                                  (:CONSTRUCTOR ,(IL:%SUFFIX-SYMBOL CONDITIONS::NAME 
+                                                        " constructor" (SYMBOL-PACKAGE 
+                                                                              CONDITIONS::NAME)))
+                                  (:COPIER NIL)
+                                  (:PREDICATE NIL))
+                   ,.CONDITIONS::SLOT-DESCRIPTIONS)
+                (EVAL-WHEN (LOAD EVAL)
+                       ,@(AND CONDITIONS::DOC `((SETF (DOCUMENTATION ',CONDITIONS::NAME 'TYPE)
+                                                      ',CONDITIONS::DOC)))
+                       ,@(IF (CONSP CONDITIONS::REPORTER)
+                             (LET ((CONDITIONS::REPORTER-NAME (IL:%SUFFIX-SYMBOL CONDITIONS::NAME
+                                                                     " report method" (SYMBOL-PACKAGE
+                                                                                       
+                                                                                     CONDITIONS::NAME
+                                                                                       ))))
+                                  (PROG1 `((SETF (SYMBOL-FUNCTION ',CONDITIONS::REPORTER-NAME)
+                                                 #',CONDITIONS::REPORTER))
+                                         (SETQ CONDITIONS::REPORTER CONDITIONS::REPORTER-NAME))))
+                       (SETF (CONDITION-REPORTER ',CONDITIONS::NAME)
+                             ,(TYPECASE CONDITIONS::REPORTER
+                                  (NULL NIL)
+                                  (STRING CONDITIONS::REPORTER)
+                                  (T `#',CONDITIONS::REPORTER)))
+                       ,@(IF (CONSP CONDITIONS::HANDLER)
+                             (LET ((CONDITIONS::HANDLER-NAME (IL:%SUFFIX-SYMBOL CONDITIONS::NAME
+                                                                    " default handler" (
+                                                                                       SYMBOL-PACKAGE
+                                                                                        
+                                                                                     CONDITIONS::NAME
+                                                                                        ))))
+                                  (PROG1 `((SETF (SYMBOL-FUNCTION ',CONDITIONS::HANDLER-NAME)
+                                                 #',CONDITIONS::HANDLER))
+                                         (SETQ CONDITIONS::HANDLER CONDITIONS::HANDLER-NAME))))
+                       (SETF (CONDITION-HANDLER ',CONDITIONS::NAME)
+                             ,(AND CONDITIONS::HANDLER `#',CONDITIONS::HANDLER))))))
+
+(DEFMACRO CHECK-TYPE (LISP::PLACE LISP::TYPESPEC &OPTIONAL STRING)
+   (IL:WITH-ERR-LOOP-VARS "CHECK-TYPE"
+          `(BLOCK ,IL:BLOCK-NAME
+               (TAGBODY ,IL:AGAIN (LET ((,IL:VAL ,LISP::PLACE))
+                                       (WHEN (TYPEP ,IL:VAL ',LISP::TYPESPEC)
+                                           (RETURN-FROM ,IL:BLOCK-NAME))
+                                       (SETF ,LISP::PLACE (IL:CHECK-TYPE-FAIL T ',LISP::PLACE
+                                                                 ,IL:VAL
+                                                                 ',LISP::TYPESPEC
+                                                                 ,STRING))
+                                       (GO ,IL:AGAIN))))))
+
+(DEFMACRO ETYPECASE (LISP::KEYFORM &BODY LISP::CLAUSES)
+   (IL:WITH-GENSYMS (LISP::VALUE)
+          "ETYPECASE"
+          (LET ((LISP::CASE-SELECTORS (CONS 'OR (IL:COLLECT-CASE-SELECTORS LISP::CLAUSES
+                                                       'ETYPECASE))))
+               `(LET ((,LISP::VALUE ,LISP::KEYFORM))
+                     (TYPECASE ,LISP::VALUE
+                         (IL:\\\,@ LISP::CLAUSES)
+                         (T (IL:CHECK-TYPE-FAIL NIL ',LISP::KEYFORM ,LISP::VALUE '
+                                                                                  ,
+                                                                                 LISP::CASE-SELECTORS
+                                   NIL)))))))
+
+(DEFMACRO CTYPECASE (LISP::KEYPLACE &BODY LISP::CLAUSES)
+   (LET ((LISP::CASE-SELECTORS (CONS 'OR (IL:COLLECT-CASE-SELECTORS LISP::CLAUSES 'CTYPECASE))))
+        (IL:WITH-ERR-LOOP-VARS
+         "CTYPECASE"
+         `(BLOCK ,IL:BLOCK-NAME
+              (TAGBODY ,IL:AGAIN (LET ((,IL:VAL ,LISP::KEYPLACE))
+                                      (RETURN-FROM ,IL:BLOCK-NAME
+                                             (TYPECASE ,IL:VAL
+                                                 (IL:\\\,@ LISP::CLAUSES)
+                                                 (T (SETF ,LISP::KEYPLACE (IL:CHECK-TYPE-FAIL
+                                                                           T
+                                                                           ',LISP::KEYPLACE
+                                                                           ,IL:VAL
+                                                                           ',LISP::CASE-SELECTORS NIL
+                                                                           ))
+                                                    (GO ,IL:AGAIN))))))))))
+
+(DEFMACRO ECASE (LISP::KEYFORM &REST LISP::CLAUSES)
+   (IL:WITH-GENSYMS (LISP::VALUE)
+          "ECASE"
+          (LET ((LISP::CASE-SELECTORS (IL:COLLECT-CASE-SELECTORS LISP::CLAUSES 'ECASE)))
+               (IF LISP::CASE-SELECTORS
+                   `(LET ((,LISP::VALUE ,LISP::KEYFORM))
+                         (CASE ,LISP::VALUE
+                             (IL:\\\,@ LISP::CLAUSES)
+                             (T (IL:ECASE-FAIL NIL ',LISP::KEYFORM ,LISP::VALUE '
+                                                                                 ,
+                                                                                 LISP::CASE-SELECTORS
+                                       ))))
+                   (ERROR "Empty case statement.")))))
+
+(DEFMACRO CCASE (LISP::KEYFORM &BODY LISP::CLAUSES)
+   (LET ((LISP::CASE-SELECTORS (IL:COLLECT-CASE-SELECTORS LISP::CLAUSES 'CCASE)))
+        (UNLESS LISP::CASE-SELECTORS (ERROR "Empty CCASE."))
+        (IL:WITH-ERR-LOOP-VARS
+         "CCASE"
+         `(BLOCK ,IL:BLOCK-NAME
+              (TAGBODY ,IL:AGAIN (LET ((,IL:VAL ,LISP::KEYFORM))
+                                      (RETURN-FROM ,IL:BLOCK-NAME
+                                             (CASE ,IL:VAL
+                                                 (IL:\\\,@ LISP::CLAUSES)
+                                                 (T (SETF ,LISP::KEYFORM (IL:ECASE-FAIL
+                                                                          T
+                                                                          ',LISP::KEYFORM
+                                                                          ,IL:VAL
+                                                                          ',LISP::CASE-SELECTORS))
+                                                    (GO ,IL:AGAIN))))))))))
+
+(DEFMACRO ASSERT (LISP::TEST-FORM &OPTIONAL LISP::PLACES LISP::DATUM &REST LISP::ARGS)
+   (UNLESS (LISTP LISP::PLACES)
+          (ERROR "~S should be a list of places." LISP::PLACES))
+   (IL:WITH-ERR-LOOP-VARS "ASSERT" `(BLOCK ,IL:BLOCK-NAME
+                                            (TAGBODY ,IL:AGAIN (WHEN ,LISP::TEST-FORM
+                                                                   (RETURN-FROM ,IL:BLOCK-NAME NIL))
+                                                   (IL:ASSERT-FAIL ,LISP::DATUM ,@LISP::ARGS)
+                                                   (GO ,IL:AGAIN)))))
+
+(DEFMACRO HANDLER-BIND (BINDINGS &REST FORMS)
+   "Eval forms under temporary new condition handlers."
+   (IF (NULL BINDINGS)
+       `(PROGN ,@FORMS)
+       `(LET
+         ((IL:*CONDITION-HANDLER-BINDINGS*
+           (CONS
+            ,(IF (NULL (REST BINDINGS))
+                 `(CONS ',(FIRST (FIRST BINDINGS))
+                        ,(SECOND (FIRST BINDINGS)))
+                 `(LIST :MULTIPLE-HANDLER-BINDINGS
+                        ,.(WITH-COLLECTION (DOLIST (BINDING BINDINGS)
+                                               (COLLECT `',(FIRST BINDING))
+                                               (COLLECT (SECOND BINDING))))))
+            IL:*CONDITION-HANDLER-BINDINGS*)))
+         ,@FORMS)))
+
+(DEFMACRO CONDITION-BIND (BINDINGS &REST FORMS)
+   "Eval forms under temporary new condition handlers; synonym for HANDLER-BIND"
+   `(HANDLER-BIND ,BINDINGS ,@FORMS))
+
+(DEFMACRO CONDITION-CASE (FORM &REST CLAUSES)
+   "Eval form under condition handlers that provide alternate continuations."
+   (SI::EXPAND-CONDITION-CASE FORM CLAUSES NIL NIL NIL))
+
+(DEFMACRO HANDLER-CASE (CONDITIONS::FORM &REST CONDITIONS::CLAUSES)
+   "Eval form under condition handlers that provide alternate continuations."
+   (SI::EXPAND-CONDITION-CASE CONDITIONS::FORM CONDITIONS::CLAUSES NIL NIL NIL)
+   `(CONDITION-CASE ,CONDITIONS::FORM ,@CONDITIONS::CLAUSES))
+
+(DEFMACRO IGNORE-ERRORS (&BODY IL:FORMS)
+   "Eval forms with handler for any condition of type ERROR."
+   `(CONDITION-CASE (PROGN ,@IL:FORMS)
+           (ERROR (CONDITION)
+                  (VALUES NIL CONDITION))))
+
+(DEFMACRO PROCEED-CASE (FORM &REST CLAUSES &ENVIRONMENT ENV)
+   "Eval forms, establishing a place to proceed from errors."
+   (SI::EXPAND-PROCEED-CASE FORM CLAUSES ENV NIL NIL))
+
+(DEFMACRO RESTART-CASE (CONDITIONS::FORM &REST CONDITIONS::CLAUSES &ENVIRONMENT CONDITIONS::ENV)
+   (CONDITIONS::EXPAND-RESTART-CASE CONDITIONS::FORM CONDITIONS::CLAUSES CONDITIONS::ENV NIL NIL))
+
+(DEFMACRO RESTART-BIND (CONDITIONS::BINDINGS &BODY CONDITIONS::BODY)
+
+   (IL:* IL:|;;| "This should also be optimized along the lines of RESTART-BIND. Not as important since this one will be rare.")
+
+   (IF (NULL CONDITIONS::BINDINGS)
+       `(PROGN ,@CONDITIONS::BODY)
+       (LET ((CONDITIONS::CASES (MAPCAR #'(LAMBDA (CONDITIONS::BINDING)
+                                                 (DESTRUCTURING-BIND
+                                                  (CONDITIONS::NAME FUNCTION &KEY 
+                                                         CONDITIONS::INTERACTIVE-FUNCTION 
+                                                         CONDITIONS::REPORT-FUNCTION 
+                                                         CONDITIONS::FILTER-FUNCTION)
+                                                  CONDITIONS::BINDING
+                                                  `(CONDITIONS::MAKE-RESTART :NAME
+                                                          ',CONDITIONS::NAME :SELECTOR 
+                                                          'SI::COMPLEX-RESTART-MARKER :FUNCTION
+                                                          ,FUNCTION :INTERACTIVE-FN 
+                                                          ,CONDITIONS::INTERACTIVE-FUNCTION :REPORT
+                                                          ,CONDITIONS::REPORT-FUNCTION :TEST
+                                                          ,CONDITIONS::FILTER-FUNCTION)))
+                                       CONDITIONS::BINDINGS)))
+            `(LET ((IL:*PROCEED-CASES* (CONS ,(IF (NULL (REST CONDITIONS::CASES))
+                                                  (FIRST CONDITIONS::CASES)
+                                                  `(LIST ,@CONDITIONS::CASES))
+                                             IL:*PROCEED-CASES*)))
+                  ,@CONDITIONS::BODY))))
+
+(DEFMACRO WITH-SIMPLE-RESTART ((RESTART-NAME CONDITIONS::FORMAT-STRING &REST 
+                                          CONDITIONS::FORMAT-ARGS)
+                                   &BODY CONDITIONS::BODY)
+   `(RESTART-CASE (PROGN ,@CONDITIONS::BODY)
+           (,RESTART-NAME NIL :REPORT (LAMBDA (STREAM)
+                                             (FORMAT STREAM ,CONDITIONS::FORMAT-STRING 
+                                                    ,@CONDITIONS::FORMAT-ARGS))
+                  (VALUES NIL T))))
+
+(DEFDEFINER DEFINE-PROCEED-FUNCTION IL:FUNCTIONS (NAME &REST TAIL)
+   (MULTIPLE-VALUE-BIND
+    (FILTER REPORT ARGLIST)
+    (SI::PROCESS-PROCEED-KEYWORDS NAME TAIL (SYMBOL-PACKAGE NAME))
+    (LET ((VARS (IL:MAPCAR ARGLIST (IL:FUNCTION (IL:LAMBDA (X)
+                                                  (IF (SYMBOLP X)
+                                                      X
+                                                      (CAR X)))))))
+         (UNLESS REPORT
+             (SETF REPORT 'IL:DEFAULT-PROCEED-REPORTER))
+         `(PROGN ,@(IF (CONSP FILTER)
+                       (LET ((FILTER-FUNCTION (IL:%SUFFIX-SYMBOL NAME 
+                                                     " proceed case default test" (SYMBOL-PACKAGE
+                                                                                   NAME))))
+                            (PROG1 `((SETF (SYMBOL-FUNCTION ',FILTER-FUNCTION)
+                                           #',FILTER))
+                                   (SETF FILTER FILTER-FUNCTION))))
+                 (SETF (DEFAULT-PROCEED-TEST ',NAME)
+                       ,(AND FILTER `#',FILTER))
+                 ,@(IF (CONSP REPORT)
+                       (LET ((REPORTER (IL:%SUFFIX-SYMBOL NAME 
+                                              " proceed case default report method" (SYMBOL-PACKAGE
+                                                                                     NAME))))
+                            (PROG1 `((SETF (SYMBOL-FUNCTION ',REPORTER)
+                                           #',REPORT))
+                                   (SETF REPORT REPORTER))))
+                 (SETF (DEFAULT-PROCEED-REPORT ',NAME)
+                       ,(IF (STRINGP REPORT)
+                            REPORT
+                            `#',REPORT))
+                 (DEFUN ,NAME (&OPTIONAL ,@ARGLIST)
+                    (LET ((RESTART (FIND-RESTART ',NAME)))
+                         (WHEN RESTART
+                             (INVOKE-RESTART RESTART ,@VARS))))))))
+
+(DEFMACRO CATCH-ABORT (PRINT-FORM &BODY FORMS)
+   `(PROCEED-CASE (PROGN ,@FORMS)
+           (ABORT (CONDITION)
+                  :REPORT
+                  ,PRINT-FORM
+                  (VALUES NIL CONDITION))))
+
+(DEFMACRO WITH-CONDITION-RESTARTS (CONDITIONS::CONDITION-FORM CONDITIONS::RESTARTS-FORM &REST 
+                                             CONDITIONS::BODY &ENVIRONMENT CONDITIONS::ENV)
+   (CONDITIONS::EXPAND-WCS CONDITIONS::CONDITION-FORM CONDITIONS::RESTARTS-FORM CONDITIONS::BODY
+          CONDITIONS::ENV NIL NIL))
+
+
+
+(IL:* IL:|;;| "Conversion functions for translating old code")
+
+
+(DEFUN CONDITIONS::CONVERT-CONDITION-CASE (CONDITIONS::WHOLE)
+   (DESTRUCTURING-BIND
+    (CONDITIONS::FN CONDITIONS::FORM &REST CONDITIONS::CLAUSES)
+    CONDITIONS::WHOLE
+    (DECLARE (IGNORE CONDITIONS::FN))
+    `(HANDLER-CASE ,CONDITIONS::FORM
+            ,@(MAPCAR #'(LAMBDA (CONDITIONS::CLAUSE)
+                               (IF (LISTP (FIRST CONDITIONS::CLAUSE))
+                                   `((OR ,@(FIRST CONDITIONS::CLAUSE))
+                                     ,@(REST CONDITIONS::CLAUSE))
+                                   CONDITIONS::CLAUSE))
+                     CONDITIONS::CLAUSES))))
+
+(DEFUN CONDITIONS::CONVERT-OLD-DEFINE-CONDITION (CONDITIONS::FORM)
+   (DESTRUCTURING-BIND
+    (CONDITIONS::FN CONDITIONS::NAME CONDITIONS::PARENT-TYPE &REST CONDITIONS::ARGS)
+    (REMOVE-COMMENTS CONDITIONS::FORM)
+    (UNLESS (EQ CONDITIONS::FN 'DEFINE-CONDITION)
+        (PRINT *ERROR-OUTPUT* "Not a define-condition form")
+        (RETURN-FROM CONDITIONS::CONVERT-OLD-DEFINE-CONDITION CONDITIONS::FORM))
+    (FLET
+     ((CONDITIONS::STRIP-KEYWORDS (CONDITIONS::ARGS)
+             (VALUES (IL:FOR IL:OLD CONDITIONS::ARGS IL:ON CONDITIONS::ARGS IL:BY
+                                                                                        CDDR
+                        IL:WHILE (KEYWORDP (FIRST CONDITIONS::ARGS))
+                        IL:COLLECT (LIST (FIRST CONDITIONS::ARGS)
+                                             (SECOND CONDITIONS::ARGS)))
+                    CONDITIONS::ARGS)))
+     (MULTIPLE-VALUE-BIND
+      (CONDITIONS::KEYS CONDITIONS::SLOTS)
+      (CONDITIONS::STRIP-KEYWORDS CONDITIONS::ARGS)
+      (LET
+       ((CONDITIONS::OPTIONS
+         (WITH-COLLECTION
+          (DOLIST (CONDITIONS::PAIR CONDITIONS::KEYS)
+              (DESTRUCTURING-BIND
+               (CONDITIONS::KEY CONDITIONS::VALUE)
+               CONDITIONS::PAIR
+               (CCASE
+                CONDITIONS::KEY
+                ((:INLINE :CONC-NAME)
+                 (COLLECT CONDITIONS::PAIR))
+                (:REPORT-FUNCTION (COLLECT `(:REPORT ,CONDITIONS::VALUE)))
+                (:REPORT
+                 (COLLECT
+                  (ETYPECASE CONDITIONS::VALUE
+                      (STRING `(:REPORT ,CONDITIONS::VALUE))
+                      (LIST 
+                         `(:REPORT
+                           ,(LET
+                             ((CONDITION (INTERN "CONDITION" *PACKAGE*))
+                              (CONDITIONS::ALL-SLOTS (APPEND (LISP::STRUCTURE-SLOT-NAMES 
+                                                                    CONDITIONS::PARENT-TYPE T)
+                                                            (MAPCAR #'(LAMBDA (CONDITIONS::X)
+                                                                             (IF (CONSP CONDITIONS::X
+                                                                                        )
+                                                                                 (CAR CONDITIONS::X)
+                                                                                 CONDITIONS::X))
+                                                                   CONDITIONS::SLOTS))))
+                             `(LAMBDA
+                               (,CONDITION *STANDARD-OUTPUT*)
+                               ,(WALK-FORM
+                                 CONDITIONS::VALUE :WALK-FUNCTION
+                                 #'(LAMBDA (CONDITIONS::FORM CONDITIONS::CONTEXT)
+                                          (IF (AND (SYMBOLP CONDITIONS::FORM)
+                                                   (MEMBER CONDITIONS::FORM CONDITIONS::ALL-SLOTS))
+                                              (VALUES (LIST (IL:%SUFFIX-SYMBOL
+                                                             CONDITIONS::NAME
+                                                             (CONCATENATE 'STRING "-" (SYMBOL-NAME
+                                                                                       
+                                                                                     CONDITIONS::FORM
+                                                                                       ))
+                                                             *PACKAGE*)
+                                                            CONDITION)
+                                                     T)
+                                              CONDITIONS::FORM))
+                                 :COPY T :LEXICAL-VARIABLES (LIST CONDITION)))))))))
+                (:HANDLER-FUNCTION (COLLECT `(:HANDLE ,CONDITIONS::VALUE)))
+                (:HANDLE
+                 (COLLECT
+                  `(:HANDLE
+                    ,(LET
+                      ((CONDITION (INTERN "CONDITION" *PACKAGE*))
+                       (CONDITIONS::ALL-SLOTS (APPEND (LISP::STRUCTURE-SLOT-NAMES 
+                                                             CONDITIONS::PARENT-TYPE T)
+                                                     (MAPCAR #'(LAMBDA (CONDITIONS::X)
+                                                                      (IF (CONSP CONDITIONS::X)
+                                                                          (CAR CONDITIONS::X)
+                                                                          CONDITIONS::X))
+                                                            CONDITIONS::SLOTS))))
+                      `(LAMBDA
+                        (,CONDITION)
+                        ,(WALK-FORM CONDITIONS::VALUE :WALK-FUNCTION
+                                #'(LAMBDA (CONDITIONS::FORM CONDITIONS::CONTEXT)
+                                         (IF (AND (SYMBOLP CONDITIONS::FORM)
+                                                  (MEMBER CONDITIONS::FORM CONDITIONS::ALL-SLOTS))
+                                             (VALUES (LIST (IL:%SUFFIX-SYMBOL CONDITIONS::NAME
+                                                                  (CONCATENATE 'STRING "-"
+                                                                         (SYMBOL-NAME 
+                                                                                CONDITIONS::FORM))
+                                                                  *PACKAGE*)
+                                                           CONDITION)
+                                                    T)
+                                             CONDITIONS::FORM))
+                                :COPY T :LEXICAL-VARIABLES (LIST CONDITION)))))))))))))
+       `(DEFINE-CONDITION ,CONDITIONS::NAME (,CONDITIONS::PARENT-TYPE)
+           (,@CONDITIONS::SLOTS)
+           ,@CONDITIONS::OPTIONS))))))
+
+(IL:PUTPROPS IL:CL-ERROR IL:FILETYPE :COMPILE-FILE)
+
+(IL:PUTPROPS IL:CL-ERROR IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL"))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA )
+
+(IL:ADDTOVAR IL:NLAML )
+
+(IL:ADDTOVAR IL:LAMA )
+)
+(IL:PUTPROPS IL:CL-ERROR IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 1993)
+)
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/CL-ERROR.DFASL b/CLTL2/CL-ERROR.DFASL
new file mode 100644
index 00000000..0c91a9cc
Binary files /dev/null and b/CLTL2/CL-ERROR.DFASL differ
diff --git a/CLTL2/CLSTREAMS b/CLTL2/CLSTREAMS
new file mode 100644
index 00000000..75365829
--- /dev/null
+++ b/CLTL2/CLSTREAMS
@@ -0,0 +1,1313 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+(FILECREATED "18-Oct-93 10:05:08" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CLSTREAMS.;2" 60585  
+
+      |previous| |date:| "13-Apr-92 16:18:18" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CLSTREAMS.;1"
+)
+
+
+; Copyright (c) 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT CLSTREAMSCOMS)
+
+(RPAQQ CLSTREAMSCOMS
+       (
+
+(* |;;;| "Implements a number of stream functions from CommonLisp.  See CLtL chapter 21")
+
+        (COMS 
+              (* |;;| "documented functions and macros")
+
+              (FUNCTIONS OPEN LISP:CLOSE LISP:STREAM-EXTERNAL-FORMAT)
+              (FUNCTIONS LISP:STREAM-ELEMENT-TYPE LISP:INPUT-STREAM-P LISP:OUTPUT-STREAM-P 
+                     LISP:OPEN-STREAM-P)
+              (COMS (FUNCTIONS FILE-STREAM-POSITION)
+                    (SETFS FILE-STREAM-POSITION))
+              
+              (* |;;| "Random support for stream types (types defined in CMLTYPES)")
+
+              (FUNCTIONS XCL:STRING-STREAM-P LISP::FILE-STREAM-P)
+              (FUNCTIONS LISP:MAKE-SYNONYM-STREAM XCL:SYNONYM-STREAM-P LISP:SYNONYM-STREAM-SYMBOL 
+                     XCL:FOLLOW-SYNONYM-STREAMS)
+              (FUNCTIONS LISP:MAKE-BROADCAST-STREAM XCL:BROADCAST-STREAM-P 
+                     LISP:BROADCAST-STREAM-STREAMS)
+              (FUNCTIONS LISP:MAKE-CONCATENATED-STREAM XCL:CONCATENATED-STREAM-P 
+                     LISP:CONCATENATED-STREAM-STREAMS)
+              (FUNCTIONS LISP:MAKE-TWO-WAY-STREAM XCL:TWO-WAY-STREAM-P 
+                     LISP:TWO-WAY-STREAM-OUTPUT-STREAM LISP:TWO-WAY-STREAM-INPUT-STREAM)
+              (FUNCTIONS LISP:MAKE-ECHO-STREAM XCL:ECHO-STREAM-P LISP:ECHO-STREAM-INPUT-STREAM 
+                     LISP:ECHO-STREAM-OUTPUT-STREAM)
+              (FUNCTIONS LISP:MAKE-STRING-INPUT-STREAM MAKE-CONCATENATED-STRING-INPUT-STREAM)
+              (FUNCTIONS %MAKE-INITIAL-STRING-STREAM-CONTENTS)
+              (FUNCTIONS LISP:WITH-OPEN-STREAM LISP:WITH-INPUT-FROM-STRING LISP:WITH-OUTPUT-TO-STRING
+                     LISP:WITH-OPEN-FILE)
+              (FUNCTIONS LISP:MAKE-STRING-OUTPUT-STREAM MAKE-FILL-POINTER-OUTPUT-STREAM 
+                     LISP:GET-OUTPUT-STREAM-STRING \\STRING-STREAM-OUTCHARFN 
+                     \\ADJUSTABLE-STRING-STREAM-OUTCHARFN))
+        (COMS 
+              (* |;;| "helpers")
+
+              (FUNCTIONS %NEW-FILE PREDICT-NAME)
+              (DECLARE\: EVAL@COMPILE DONTCOPY (FUNCTIONS INTERLISP-ACCESS)))
+        (COMS 
+              (* |;;| "methods for the special devices")
+
+              (FNS %BROADCAST-STREAM-DEVICE-BOUT %BROADCAST-STREAM-DEVICE-OUTCHARFN 
+                   %BROADCAST-STREAM-DEVICE-CLOSEFILE %BROADCAST-STREAM-DEVICE-FORCEOUTPUT)
+              (FUNCTIONS %BROADCAST-STREAM-DEVICE-CHARSETFN)
+              (FNS %CONCATENATED-STREAM-DEVICE-BIN %CONCATENATED-STREAM-DEVICE-CLOSEFILE 
+                   %CONCATENATED-STREAM-DEVICE-EOFP %CONCATENATED-STREAM-DEVICE-PEEKBIN 
+                   %CONCATENATED-STREAM-DEVICE-BACKFILEPTR)
+              (FUNCTIONS %CONCATENATED-STREAM-DEVICE-CHARSETFN)
+              (FNS %ECHO-STREAM-DEVICE-BIN)
+              (FUNCTIONS %SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM)
+              (FNS %SYNONYM-STREAM-DEVICE-BIN %SYNONYM-STREAM-DEVICE-BOUT 
+                   %SYNONYM-STREAM-DEVICE-OUTCHARFN %SYNONYM-STREAM-DEVICE-CLOSEFILE 
+                   %SYNONYM-STREAM-DEVICE-EOFP %SYNONYM-STREAM-DEVICE-FORCEOUTPUT 
+                   %SYNONYM-STREAM-DEVICE-GETFILEINFO %SYNONYM-STREAM-DEVICE-PEEKBIN 
+                   %SYNONYM-STREAM-DEVICE-READP %SYNONYM-STREAM-DEVICE-BACKFILEPTR 
+                   %SYNONYM-STREAM-DEVICE-SETFILEINFO %SYNONYM-STREAM-DEVICE-CHARSETFN)
+              (FNS %TWO-WAY-STREAM-DEVICE-BIN %TWO-WAY-STREAM-DEVICE-INPUTSTREAM 
+                   %TWO-WAY-STREAM-DEVICE-BOUT %TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM 
+                   %TWO-WAY-STREAM-DEVICE-OUTCHARFN %TWO-WAY-STREAM-DEVICE-CLOSEFILE 
+                   %TWO-WAY-STREAM-DEVICE-EOFP %TWO-WAY-STREAM-DEVICE-READP 
+                   %TWO-WAY-STREAM-DEVICE-BACKFILEPTR %TWO-WAY-STREAM-DEVICE-FORCEOUTPUT 
+                   %TWO-WAY-STREAM-DEVICE-PEEKBIN %TWO-WAY-STREAM-DEVICE-CHARSETFN)
+              (FUNCTIONS %FILL-POINTER-STREAM-DEVICE-CLOSEFILE %FILL-POINTER-STREAM-DEVICE-GETFILEPTR
+                     )
+              (GLOBALVARS %SYNONYM-STREAM-DEVICE %BROADCAST-STREAM-DEVICE %CONCATENATED-STREAM-DEVICE
+                     %TWO-WAY-STREAM-DEVICE %ECHO-STREAM-DEVICE \\FILL-POINTER-STREAM-DEVICE))
+        (COMS 
+              (* |;;| "helper stuff")
+
+              (FNS %SYNONYM-STREAM-DEVICE-GET-STREAM))
+        (COMS 
+              (* |;;| "module initialization")
+
+              (VARIABLES *DEBUG-IO* *QUERY-IO* *TERMINAL-IO* *ERROR-OUTPUT* *STANDARD-OUTPUT* 
+                     *STANDARD-INPUT*)
+              (FUNCTIONS %INITIALIZE-STANDARD-STREAMS)
+              (FNS %INITIALIZE-CLSTREAM-TYPES)
+              (DECLARE\: DONTEVAL@LOAD DOCOPY                (* \; "initialization")
+                     (P (%INITIALIZE-CLSTREAM-TYPES)
+                        (%INITIALIZE-STANDARD-STREAMS))))
+        (PROP FILETYPE CLSTREAMS)))
+
+
+
+(* |;;;| "Implements a number of stream functions from CommonLisp.  See CLtL chapter 21")
+
+
+
+
+(* |;;| "documented functions and macros")
+
+
+(LISP:DEFUN OPEN (FILENAME &KEY (DIRECTION :INPUT)
+                            (ELEMENT-TYPE 'LISP:STRING-CHAR)
+                            (IF-EXISTS NIL EXISTS-P)
+                            (IF-DOES-NOT-EXIST NIL DOES-NOT-EXIST-P)
+                            (EXTERNAL-FORMAT :DEFAULT))
+
+(* |;;;| "Return a stream which reads from or writes to Filename.  Defined keywords: :direction (one of :input, :output or :probe :element-type), Type of object to read or write, default String-Char, :if-exists (one of :error, :new-version, :overwrite, :append or nil), :if-does-not-exist (one of :error, :create or nil). :external-format (one of :DEFAULT, :EUC, :JIS, :W-MS, :MS or :XCCS).  The specification of :external-format is based on the JEIDA proposal.  See the manual for details.")
+
+   (LISP:UNLESS (MEMQ DIRECTION '(:INPUT :OUTPUT :IO :PROBE))
+          (LISP:ERROR "~S isn't a valid direction for open." DIRECTION))
+   (LISP:UNLESS (LISP:MEMBER ELEMENT-TYPE '(LISP:STRING-CHAR LISP:SIGNED-BYTE LISP:UNSIGNED-BYTE
+                                                  (LISP:UNSIGNED-BYTE 8)
+                                                  (LISP:SIGNED-BYTE 8)
+                                                  LISP:CHARACTER :DEFAULT)
+                       :TEST
+                       'LISP:EQUAL)
+          (LISP:ERROR "~S isn't an implemented element-type for open." ELEMENT-TYPE))
+   (LET
+    ((PATHNAME (LISP:IF (LISP::LOGICAL-PATHNAME-P FILENAME)
+                   (LISP:TRANSLATE-LOGICAL-PATHNAME FILENAME)
+                   (PATHNAME FILENAME)))
+     (FOR-INPUT (MEMQ DIRECTION '(:IO :INPUT)))
+     (FOR-OUTPUT (MEMQ DIRECTION '(:IO :OUTPUT)))
+     (ACCESS (INTERLISP-ACCESS DIRECTION))
+     (FILE-TYPE (IF (LISP:MEMBER ELEMENT-TYPE '(LISP:UNSIGNED-BYTE LISP:SIGNED-BYTE (
+                                                                                   LISP:UNSIGNED-BYTE
+                                                                                         8)
+                                                          (LISP:SIGNED-BYTE 8))
+                               :TEST
+                               'LISP:EQUAL)
+                    THEN 'BINARY
+                  ELSE 'TEXT))
+     (STREAM NIL))
+
+(* |;;;| "Do hairy defaulting of :if-exists and :if-does-not-exist keywords.")
+
+    (LISP:UNLESS EXISTS-P
+        (SETQ IF-EXISTS (LISP:IF (EQ (LISP:PATHNAME-VERSION PATHNAME)
+                                     :NEWEST)
+                            :NEW-VERSION
+                            :ERROR)))                        (* \; 
+                            "If the file does not exist, it is OK to have :if-exists :overwrite.  ")
+    (LISP:UNLESS DOES-NOT-EXIST-P
+        (SETQ IF-DOES-NOT-EXIST (COND
+                                   ((OR (EQ IF-EXISTS :APPEND)
+                                        (EQ DIRECTION :INPUT))
+                                    :ERROR)
+                                   ((EQ DIRECTION :PROBE)
+                                    NIL)
+                                   (T :CREATE))))
+    (LISP:LOOP                                               (* \; 
+                                      "See if the file exists and handle the existential keywords.")
+     (LET* ((NAME (PREDICT-NAME PATHNAME))
+            (LISP:NAMESTRING (MKSTRING NAME)))
+           (IF NAME
+               THEN                                      (* \; "file exists")
+                     (IF FOR-OUTPUT
+                         THEN 
+
+                               (* |;;| "open for output/both")
+
+                               (CASE IF-EXISTS
+                                   (:ERROR 
+                                      (LISP:CERROR "write it anyway." "File ~A already exists." 
+                                             LISP:NAMESTRING)
+                                      (SETQ STREAM (OPENSTREAM LISP:NAMESTRING ACCESS NIL
+                                                          `((TYPE ,FILE-TYPE)
+                                                            (EXTERNALFORMAT ,EXTERNAL-FORMAT))))
+                                      (RETURN NIL))
+                                   ((:NEW-VERSION :SUPERSEDE :RENAME :RENAME-AND-DELETE) 
+                                      (SETQ STREAM (OPENSTREAM PATHNAME ACCESS 'NEW
+                                                          `((TYPE ,FILE-TYPE)
+                                                            (EXTERNALFORMAT ,EXTERNAL-FORMAT))))
+                                      (RETURN NIL))
+                                   (:OVERWRITE 
+                                      (SETQ STREAM (OPENSTREAM LISP:NAMESTRING ACCESS 'OLD
+                                                          `((TYPE ,FILE-TYPE)
+                                                            (EXTERNALFORMAT ,EXTERNAL-FORMAT))))
+                                      (RETURN NIL))
+                                   (:APPEND 
+                                      (IF (EQ DIRECTION :OUTPUT)
+                                          THEN           (* \; 
+                                    "if the direction is output it is the same as interlisp append")
+                                                (SETQ STREAM (OPENSTREAM LISP:NAMESTRING 'APPEND
+                                                                    'OLD
+                                                                    `((TYPE ,FILE-TYPE)
+                                                                      (EXTERNALFORMAT 
+                                                                             ,EXTERNAL-FORMAT))))
+                                        ELSE             (* \; 
+                    "if direction is io it opens the file for both and goes to the end of the file")
+                                              (SETQ STREAM (OPENSTREAM LISP:NAMESTRING 'BOTH
+                                                                  'OLD
+                                                                  `((TYPE ,FILE-TYPE)
+                                                                    (EXTERNALFORMAT ,EXTERNAL-FORMAT)
+                                                                    )))
+                                              (SETFILEPTR STREAM -1))
+                                      (RETURN NIL))
+                                   ((NIL) (LISP:RETURN-FROM OPEN NIL))
+                                   (T (LISP:ERROR "~S is not a valid value for :if-exists." IF-EXISTS
+                                             )))
+                       |elseif| FOR-INPUT
+                         |then| 
+
+                               (* |;;| "open for input/both")
+
+                               (SETQ STREAM (OPENSTREAM LISP:NAMESTRING ACCESS 'OLD
+                                                   `((TYPE ,FILE-TYPE)
+                                                     (EXTERNALFORMAT ,EXTERNAL-FORMAT))))
+                               (RETURN NIL)
+                       |else| 
+
+                             (* |;;| "open for probe")
+
+                             (SETQ STREAM (|create| STREAM
+                                                 FULLFILENAME _ (FULLNAME LISP:NAMESTRING)))
+                             (RETURN NIL))
+             |else| 
+
+                   (* |;;| "file does not exist")
+
+                   (|if| FOR-OUTPUT
+                       |then| (CASE IF-DOES-NOT-EXIST
+                                      (:ERROR 
+                                         (LISP:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND 
+                                                :PATHNAME PATHNAME)
+                                         (LISP:FORMAT *QUERY-IO* "~&New file name: ")
+                                         (SETQ PATHNAME (PATHNAME (LISP:READ-LINE *QUERY-IO*))))
+                                      (:CREATE 
+                                         (SETQ STREAM (OPENSTREAM PATHNAME ACCESS 'NEW
+                                                             `((TYPE ,FILE-TYPE)
+                                                               (EXTERNALFORMAT ,EXTERNAL-FORMAT))))
+                                         (RETURN NIL))
+                                      ((NIL) (LISP:RETURN-FROM OPEN NIL))
+                                      (T (LISP:ERROR 
+                                                "~S is not a valid value for :if-does-not-exist." 
+                                                IF-DOES-NOT-EXIST)))
+                     |elseif| FOR-INPUT
+                       |then| (CASE IF-DOES-NOT-EXIST
+                                      (:ERROR 
+                                         (LISP:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND 
+                                                :PATHNAME PATHNAME)
+                                         (LISP:FORMAT *QUERY-IO* "~&New file name: ")
+                                         (SETQ PATHNAME (PATHNAME (LISP:READ-LINE *QUERY-IO*))))
+                                      (:CREATE (%NEW-FILE PATHNAME))
+                                      ((NIL) (LISP:RETURN-FROM OPEN NIL))
+                                      (T (LISP:ERROR 
+                                                "~S is not a valid value for :if-does-not-exist." 
+                                                IF-DOES-NOT-EXIST)))
+                     |else|                              (* \; "Open for probe.")
+                           (RETURN NIL)))))
+    (STREAMPROP STREAM :FILE-STREAM-P T)
+    STREAM))
+
+(LISP:DEFUN LISP:CLOSE (STREAM &KEY ABORT)
+
+(* |;;;| "Close a stream.  If ABORT, then don't keep the file")
+
+   (|if| (STREAMP STREAM)
+       |then| (|if| (OPENP STREAM)
+                      |then| 
+
+                            (* |;;| 
+               "determine 'deletability' of stream's file before closing, as that trashes the info")
+
+                            (LET ((ABORTABLE (AND (DIRTYABLE STREAM)
+                                                  (NOT (APPENDONLY STREAM)))))
+                                 (CLOSEF STREAM)
+                                 (|if| (AND ABORT ABORTABLE)
+                                     |then|              (* \; 
+     "eventually we will change device CLOSEF methods to take an ABORT arg.  For now, simulate it.")
+                                           (DELFILE (LISP:NAMESTRING STREAM)))))
+     |else| (ERROR "Closing a non-stream" STREAM))
+   T)
+
+(LISP:DEFUN LISP:STREAM-EXTERNAL-FORMAT (STREAM)
+   (\\EXTERNALFORMAT STREAM))
+
+(LISP:DEFUN LISP:STREAM-ELEMENT-TYPE (STREAM)
+   'LISP:UNSIGNED-BYTE)
+
+(LISP:DEFUN LISP:INPUT-STREAM-P (STREAM)
+   (LISP:WHEN (NOT (STREAMP STREAM))
+          (\\ILLEGAL.ARG STREAM))
+
+   (* |;;| "we return T instead of the stream because Symbolics does")
+
+   (AND (\\IOMODEP STREAM 'INPUT T)
+        T))
+
+(LISP:DEFUN LISP:OUTPUT-STREAM-P (STREAM)
+   (LISP:WHEN (NOT (STREAMP STREAM))
+          (\\ILLEGAL.ARG STREAM))
+
+   (* |;;| "we return T instead of the stream because Symbolics does")
+
+   (AND (\\IOMODEP STREAM 'OUTPUT T)
+        T))
+
+(LISP:DEFUN LISP:OPEN-STREAM-P (STREAM)
+
+   (* |;;| "is stream an open stream?")
+
+   (AND (STREAMP STREAM)
+        (OPENED STREAM)))
+
+(LISP:DEFUN FILE-STREAM-POSITION (STREAM)
+   (GETFILEPTR STREAM))
+
+(LISP:DEFSETF FILE-STREAM-POSITION SETFILEPTR)
+
+
+
+(* |;;| "Random support for stream types (types defined in CMLTYPES)")
+
+
+(LISP:DEFUN XCL:STRING-STREAM-P (STREAM)                 (* \; "Edited 14-Feb-92 12:43 by jrb:")
+   (STREAMPROP STREAM 'XCL:STRING-STREAM-P))
+
+(LISP:DEFUN LISP::FILE-STREAM-P (STREAM)                 (* \; "Edited 14-Feb-92 12:42 by jrb:")
+   (FETCH (STREAM FULLFILENAME) OF STREAM))
+
+(LISP:DEFUN LISP:MAKE-SYNONYM-STREAM (LISP:SYMBOL)
+
+   (* |;;| "A CommonLisp function for shadowing a stream.  See CLtL p.  329")
+
+   (LET ((STREAM (|create| STREAM
+                        DEVICE _ %SYNONYM-STREAM-DEVICE
+                        ACCESS _ 'BOTH
+                        F1 _ LISP:SYMBOL
+                        LINELENGTH _ (|fetch| (STREAM LINELENGTH) |of| (LISP:SYMBOL-VALUE
+                                                                                LISP:SYMBOL))
+                        OUTCHARFN _ (FUNCTION %SYNONYM-STREAM-DEVICE-OUTCHARFN))))
+        (STREAMPROP STREAM 'XCL:SYNONYM-STREAM-P T)
+
+        (* |;;| "save the synonym stream in the OPENFILELST field of %SYNONYM-STREAM-DEVICE")
+
+        (|replace| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE
+           |with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE)))
+        STREAM))
+
+(LISP:DEFUN XCL:SYNONYM-STREAM-P (STREAM)
+   (STREAMPROP STREAM 'XCL:SYNONYM-STREAM-P))
+
+(LISP:DEFUN LISP:SYNONYM-STREAM-SYMBOL (STREAM)
+   (AND (XCL:SYNONYM-STREAM-P STREAM)
+        (FETCH (STREAM F1) OF STREAM)))
+
+(LISP:DEFUN XCL:FOLLOW-SYNONYM-STREAMS (STREAM)
+
+(* |;;;| "Return the non-synonym stream at the heart of STREAM.")
+
+   (LISP:IF (XCL:SYNONYM-STREAM-P STREAM)
+       (XCL:FOLLOW-SYNONYM-STREAMS (LISP:SYMBOL-VALUE (LISP:SYNONYM-STREAM-SYMBOL STREAM)))
+       STREAM))
+
+(LISP:DEFUN LISP:MAKE-BROADCAST-STREAM (&REST STREAMS)
+
+   (* |;;| "CommonLisp function that makes a broadcast stream.  See CLtL p329")
+
+   (IF (FOR STREAM? IN STREAMS ALWAYS (STREAMP STREAM?))
+       THEN (LET ((STREAM (|create| STREAM
+                                     DEVICE _ %BROADCAST-STREAM-DEVICE
+                                     ACCESS _ 'OUTPUT
+                                     F1 _ STREAMS
+                                     OUTCHARFN _ (FUNCTION %BROADCAST-STREAM-DEVICE-OUTCHARFN))))
+                     (STREAMPROP STREAM 'XCL:BROADCAST-STREAM-P T)
+                     STREAM)
+     ELSE (\\ILLEGAL.ARG (FOR STREAM? IN STREAMS WHEN (NOT (STREAMP STREAM?))
+                                DO (RETURN STREAM?)))))
+
+(LISP:DEFUN XCL:BROADCAST-STREAM-P (STREAM)
+
+   (* |;;| "is stream a broadcast stream?")
+
+   (STREAMPROP STREAM 'XCL:BROADCAST-STREAM-P))
+
+(LISP:DEFUN LISP:BROADCAST-STREAM-STREAMS (STREAM)
+
+   (* |;;| "return all of the streams that STREAM broadcasts to")
+
+   (AND (XCL:BROADCAST-STREAM-P STREAM)
+        (FETCH (STREAM F1) OF STREAM)))
+
+(LISP:DEFUN LISP:MAKE-CONCATENATED-STREAM (&REST STREAMS)
+
+   (* |;;| "CommonLisp function that creates a  concatenated stream.  See CLtL p.  329")
+
+   (IF (FOR STREAM? IN STREAMS ALWAYS (STREAMP STREAM?))
+       THEN (LET ((STREAM (|create| STREAM
+                                     DEVICE _ %CONCATENATED-STREAM-DEVICE
+                                     ACCESS _ 'INPUT
+                                     F1 _ STREAMS)))
+                     (STREAMPROP STREAM 'XCL:CONCATENATED-STREAM-P T)
+                     STREAM)
+     ELSE (\\ILLEGAL.ARG (FOR STREAM? IN STREAMS WHEN (NOT (STREAMP STREAM?))
+                                DO (RETURN STREAM?)))))
+
+(LISP:DEFUN XCL:CONCATENATED-STREAM-P (STREAM)
+   (STREAMPROP STREAM 'XCL:CONCATENATED-STREAM-P))
+
+(LISP:DEFUN LISP:CONCATENATED-STREAM-STREAMS (STREAM)
+
+   (* |;;| "return all of STREAM's concatenated streams")
+
+   (AND (XCL:CONCATENATED-STREAM-P STREAM)
+        (FETCH (STREAM F1) OF STREAM)))
+
+(LISP:DEFUN LISP:MAKE-TWO-WAY-STREAM (LISP::INPUT-STREAM LISP::OUTPUT-STREAM)
+
+   (* |;;| "A CommonLisp function for splicing together two streams.  See CLtL p.  329")
+
+   (LISP:UNLESS (STREAMP LISP::INPUT-STREAM)
+          (\\ILLEGAL.ARG LISP::INPUT-STREAM))
+   (LISP:UNLESS (STREAMP LISP::OUTPUT-STREAM)
+          (\\ILLEGAL.ARG LISP::OUTPUT-STREAM))
+   (LET ((STREAM (|create| STREAM
+                        DEVICE _ %TWO-WAY-STREAM-DEVICE
+                        ACCESS _ 'BOTH
+                        F1 _ LISP::INPUT-STREAM
+                        F2 _ LISP::OUTPUT-STREAM
+                        LINELENGTH _ (|fetch| (STREAM LINELENGTH) |of| LISP::OUTPUT-STREAM)
+                        OUTCHARFN _ (FUNCTION %TWO-WAY-STREAM-DEVICE-OUTCHARFN))))
+        (STREAMPROP STREAM 'XCL:TWO-WAY-STREAM-P T)
+
+        (* |;;| "save STREAM  in the OPENFILELST field of %TWO-WAY-STREAM-DEVICE")
+
+        (|replace| (FDEV OPENFILELST) |of| %TWO-WAY-STREAM-DEVICE
+           |with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %TWO-WAY-STREAM-DEVICE)))
+        STREAM))
+
+(LISP:DEFUN XCL:TWO-WAY-STREAM-P (STREAM)
+
+   (* |;;| "is STREAM a two-way stream?")
+
+   (STREAMPROP STREAM 'XCL:TWO-WAY-STREAM-P))
+
+(LISP:DEFUN LISP:TWO-WAY-STREAM-OUTPUT-STREAM (STREAM)
+   (AND (XCL:TWO-WAY-STREAM-P STREAM)
+        (FETCH (STREAM F2) OF STREAM)))
+
+(LISP:DEFUN LISP:TWO-WAY-STREAM-INPUT-STREAM (STREAM)
+   (AND (XCL:TWO-WAY-STREAM-P STREAM)
+        (FETCH (STREAM F1) OF STREAM)))
+
+(LISP:DEFUN LISP:MAKE-ECHO-STREAM (LISP::INPUT-STREAM LISP::OUTPUT-STREAM)
+
+   (* |;;| "A CommonLisp function for making an echo  stream.  See CLtL p.  329")
+
+   (LISP:UNLESS (STREAMP LISP::INPUT-STREAM)
+          (\\ILLEGAL.ARG LISP::INPUT-STREAM))
+   (LISP:UNLESS (STREAMP LISP::OUTPUT-STREAM)
+          (\\ILLEGAL.ARG LISP::OUTPUT-STREAM))
+   (LET ((STREAM (|create| STREAM
+                        DEVICE _ %ECHO-STREAM-DEVICE
+                        ACCESS _ 'BOTH
+                        F1 _ LISP::INPUT-STREAM
+                        F2 _ LISP::OUTPUT-STREAM
+                        LINELENGTH _ (|fetch| (STREAM LINELENGTH) |of| LISP::OUTPUT-STREAM)
+                        OUTCHARFN _ (FUNCTION %TWO-WAY-STREAM-DEVICE-OUTCHARFN))))
+        (STREAMPROP STREAM 'XCL:ECHO-STREAM-P T)
+
+        (* |;;| "save STREAM  in the OPENFILELST field of %ECHO-STREAM-DEVICE")
+
+        (|replace| (FDEV OPENFILELST) |of| %ECHO-STREAM-DEVICE
+           |with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %ECHO-STREAM-DEVICE)))
+        STREAM))
+
+(LISP:DEFUN XCL:ECHO-STREAM-P (STREAM)
+
+   (* |;;| "is stream an echo stream?")
+
+   (STREAMPROP STREAM 'XCL:ECHO-STREAM-P))
+
+(LISP:DEFUN LISP:ECHO-STREAM-INPUT-STREAM (STREAM)
+   (AND (XCL:ECHO-STREAM-P STREAM)
+        (FETCH (STREAM F1) OF STREAM)))
+
+(LISP:DEFUN LISP:ECHO-STREAM-OUTPUT-STREAM (STREAM)
+   (AND (XCL:ECHO-STREAM-P STREAM)
+        (FETCH (STREAM F2) OF STREAM)))
+
+(LISP:DEFUN LISP:MAKE-STRING-INPUT-STREAM (STRING &OPTIONAL (LISP::START 0)
+                                                     (LISP::END NIL))
+                                                             (* \; "Edited 14-Feb-92 12:36 by jrb:")
+
+(* |;;;| "A CommonLisp function for producing a stream from a string.  See CLtL p.  330")
+
+   (LET ((STREAM (OPENSTRINGSTREAM (|if| (OR (NOT (LISP:ZEROP LISP::START))
+                                                 (NOT (NULL LISP::END)))
+                                       |then| 
+
+                                      (* |;;| "A displaced array is ok here because the stream's uses GETBASEBYTE directly and doesn't go through the array code at all. ")
+
+                                             (SUBSTRING STRING (LISP:1+ LISP::START)
+                                                    LISP::END)
+                                     |else| STRING)
+                        'INPUT)))
+        (STREAMPROP STREAM 'XCL:STRING-STREAM-P T)
+        STREAM))
+
+(LISP:DEFUN MAKE-CONCATENATED-STRING-INPUT-STREAM (STRINGS)
+   (COND
+      ((NULL STRINGS)
+       NIL)
+      ((NULL (LISP:REST STRINGS))
+       (LISP:MAKE-STRING-INPUT-STREAM (LISP:FIRST STRINGS)))
+      (T (LISP:APPLY 'LISP:MAKE-CONCATENATED-STREAM (FOR STRING IN STRINGS
+                                                       COLLECT (LISP:MAKE-STRING-INPUT-STREAM
+                                                                    STRING))))))
+
+(LISP:DEFUN %MAKE-INITIAL-STRING-STREAM-CONTENTS (&OPTIONAL (ELEMENT-TYPE 'LISP:STRING-CHAR))
+                                                             (* \; "Edited 24-Mar-92 12:55 by jrb:")
+   (LISP:MAKE-ARRAY '(256)
+          :ELEMENT-TYPE ELEMENT-TYPE :EXTENDABLE T :FILL-POINTER 0))
+
+(DEFMACRO LISP:WITH-OPEN-STREAM ((VAR STREAM)
+                                     &BODY
+                                     (BODY DECLS))
+   (LET ((ABORTP (GENSYM)))
+        `(LET ((,VAR ,STREAM)
+               (,ABORTP T))
+              ,@DECLS
+              (LISP:UNWIND-PROTECT
+                  (LISP:MULTIPLE-VALUE-PROG1 (PROGN ,@BODY)
+                         (SETQ ,ABORTP NIL))
+                  (LISP:CLOSE ,VAR :ABORT ,ABORTP)))))
+
+(DEFMACRO LISP:WITH-INPUT-FROM-STRING ((LISP::VAR STRING &KEY (LISP::INDEX NIL LISP::INDEXP)
+                                                  (LISP::START 0 LISP::STARTP)
+                                                  (LISP::END NIL LISP:ENDP))
+                                           &BODY
+                                           (LISP::BODY LISP::DECLS))
+   `(LET* ((LISP::$STRING$ ,STRING)
+           (LISP::$START$ ,LISP::START))
+          (DECLARE (LOCALVARS LISP::$STRING$ LISP::$START$))
+          (LISP:WITH-OPEN-STREAM (,LISP::VAR (LISP:MAKE-STRING-INPUT-STREAM LISP::$STRING$ 
+                                                        LISP::$START$ ,LISP::END))
+                 ,@LISP::DECLS
+                 ,@(LISP:IF LISP::INDEXP
+
+                       (* |;;| "This exists as a fudge for the fat string problem.  It WILL GO AWAY when STRINGSTREAMS HAVE THEIR OWN DEVICE.")
+
+                       `((LISP:MULTIPLE-VALUE-PROG1 (PROGN ,@LISP::BODY)
+
+                                (* |;;| "(IF (FASL::FAT-STRING-P $STRING$) (SETF ,INDEX (+ $START$ (IL:IQUOTIENT (IL:GETFILEPTR ,VAR) 2))) (SETF ,INDEX (+ $START$ (IL:GETFILEPTR ,VAR))))")
+
+                                (LISP:SETF ,LISP::INDEX (+ LISP::$START$ (GETFILEPTR ,LISP::VAR)))))
+                       LISP::BODY))))
+
+(DEFMACRO LISP:WITH-OUTPUT-TO-STRING ((LISP::VAR &OPTIONAL (STRING NIL LISP::ST-P)
+                                                 &KEY LISP::ELEMENT-TYPE)
+                                          &BODY
+                                          (LISP::FORMS LISP::DECLS))
+   (COND
+      (STRING `(LISP:WITH-OPEN-STREAM (,LISP::VAR (MAKE-FILL-POINTER-OUTPUT-STREAM
+                                                       ,STRING))
+                      ,@LISP::DECLS
+                      ,@LISP::FORMS))
+      (LISP::ELEMENT-TYPE `(LISP:WITH-OPEN-STREAM (,LISP::VAR (LISP:MAKE-STRING-OUTPUT-STREAM
+                                                                   :ELEMENT-TYPE
+                                                                   ,LISP::ELEMENT-TYPE))
+                                  ,@LISP::DECLS
+                                  (PROGN ,@LISP::FORMS (LISP:GET-OUTPUT-STREAM-STRING
+                                                        ,LISP::VAR))))
+      (T `(LISP:WITH-OPEN-STREAM (,LISP::VAR (LISP:MAKE-STRING-OUTPUT-STREAM))
+                 ,@LISP::DECLS
+                 (PROGN ,@LISP::FORMS (LISP:GET-OUTPUT-STREAM-STRING ,LISP::VAR))))))
+
+(DEFMACRO LISP:WITH-OPEN-FILE ((VAR &REST OPEN-ARGS)
+                                   &BODY
+                                   (FORMS DECLS))
+
+(* |;;;| "The file whose name is File-Name is opened using the OPEN-ARGS and bound to the variable VAR. The Forms are executed, and when they terminate, normally or otherwise, the file is closed.")
+
+   (LET ((ABORTP (GENSYM)))
+        `(LET ((,VAR (OPEN ,@OPEN-ARGS))
+               (,ABORTP T))
+              ,@DECLS
+              (LISP:UNWIND-PROTECT
+                  (LISP:MULTIPLE-VALUE-PROG1 (PROGN ,@FORMS)
+                         (SETQ ,ABORTP NIL))
+                  (LISP:CLOSE ,VAR :ABORT ,ABORTP)))))
+
+(DEFINLINE LISP:MAKE-STRING-OUTPUT-STREAM (&KEY (LISP::ELEMENT-TYPE 'LISP:STRING-CHAR))
+
+(* |;;;| "A function for producing a string stream. See also the function get-output-stream-string.  Also, see CLtL p.  330")
+
+   (LET ((STREAM (MAKE-FILL-POINTER-OUTPUT-STREAM LISP::ELEMENT-TYPE)))
+        STREAM))
+
+(LISP:DEFUN MAKE-FILL-POINTER-OUTPUT-STREAM (&OPTIONAL (STRING (
+                                                               %MAKE-INITIAL-STRING-STREAM-CONTENTS
+                                                                    )))
+                                                             (* \; "Edited 24-Mar-92 12:54 by jrb:")
+   (DECLARE (GLOBALVARS \\FILL-POINTER-STREAM-DEVICE))
+
+   (* |;;| "HACK: STRING may also be a type; catch that here and fix it")
+
+   (LISP:UNLESS (STRINGP STRING)
+       (SETQ STRING (%MAKE-INITIAL-STRING-STREAM-CONTENTS STRING)))
+   (|if| (NOT (LISP:ARRAY-HAS-FILL-POINTER-P STRING))
+       |then| (\\ILLEGAL.ARG STRING)
+     |else| (LET ((STREAM (|create| STREAM
+                                     DEVICE _ \\FILL-POINTER-STREAM-DEVICE
+                                     F1 _ STRING
+                                     ACCESS _ 'OUTPUT
+                                     OTHERPROPS _ '(STRING-OUTPUT-STREAM T XCL:STRING-STREAM-P T))))
+                                                             (* \; 
+                                             "give it a canned property list to save some consing.")
+                     (|replace| (STREAM OUTCHARFN) |of| STREAM
+                        |with| (|if| (EXTENDABLE-ARRAY-P STRING)
+                                       |then| (FUNCTION \\ADJUSTABLE-STRING-STREAM-OUTCHARFN)
+                                     |else| (FUNCTION \\STRING-STREAM-OUTCHARFN)))
+                     (|replace| (STREAM STRMBOUTFN) |of| STREAM |with|
+                                                                        (FUNCTION \\OUTCHAR))
+                     STREAM)))
+
+(LISP:DEFUN LISP:GET-OUTPUT-STREAM-STRING (STRING-OUTPUT-STREAM)
+
+(* |;;;| "A CommonLisp function for getting the contents of the buffer created by a call to make-string-output-stream.  See CLtL p.  330")
+
+   (|if| (NOT (STREAMPROP STRING-OUTPUT-STREAM 'STRING-OUTPUT-STREAM))
+       |then| (ERROR "Stream not a string-output-stream" STRING-OUTPUT-STREAM)
+     |else| (PROG1 (|fetch| (STREAM F1) |of| STRING-OUTPUT-STREAM)
+                    (|replace| (STREAM F1) |of| STRING-OUTPUT-STREAM |with| (
+                                                               %MAKE-INITIAL-STRING-STREAM-CONTENTS
+                                                                                         )))))
+
+(LISP:DEFUN \\STRING-STREAM-OUTCHARFN (STREAM CHAR)
+   (IF (OR (IEQP (FETCH (STREAM CHARPOSITION) OF STREAM)
+                     (FETCH (STREAM LINELENGTH) OF STREAM))
+               (EQ CHAR (CHARCODE EOL)))
+       THEN (REPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
+     ELSE (ADD (FETCH (STREAM CHARPOSITION) OF STREAM)
+                     1))
+   (LISP:VECTOR-PUSH (LISP:CHARACTER CHAR)
+          (FETCH (STREAM F1) OF STREAM)))
+
+(LISP:DEFUN \\ADJUSTABLE-STRING-STREAM-OUTCHARFN (STREAM CHAR)
+   (LET ((STRING (FETCH (STREAM F1) OF STREAM))
+         (CH (LISP:CHARACTER CHAR)))
+        (IF (OR (IEQP (FETCH (STREAM CHARPOSITION) OF STREAM)
+                          (FETCH (STREAM LINELENGTH) OF STREAM))
+                    (EQ CHAR (CHARCODE EOL)))
+            THEN (REPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
+          ELSE (ADD (FETCH (STREAM CHARPOSITION) OF STREAM)
+                          1))
+
+        (* |;;| "Do the equivalent of VECTOR-PUSH-EXTEND inline to save the significant! overhead of calculating the new length at each character.")
+
+        (LISP:UNLESS (LISP:VECTOR-PUSH CH STRING)
+            (LET ((CURRENT-LENGTH (LISP:ARRAY-TOTAL-SIZE STRING)))
+                 (IF (>= CURRENT-LENGTH (LISP:1- LISP:ARRAY-TOTAL-SIZE-LIMIT))
+                     THEN (PROCEED-CASE (LISP:ERROR 'END-OF-FILE :STREAM STREAM)
+                                     (SI::RETRY-OUTCHAR NIL :REPORT 
+                                            "VECTOR-PUSH the character anyway" :CONDITION END-OF-FILE
+                                            (LISP:VECTOR-PUSH CH (FETCH (STREAM F1) OF STREAM
+                                                                        ))))
+                   ELSE (LISP:ADJUST-ARRAY STRING (MIN (LISP:1- LISP:ARRAY-TOTAL-SIZE-LIMIT)
+                                                           (+ CURRENT-LENGTH (MAX (LRSH 
+                                                                                       CURRENT-LENGTH
+                                                                                        1)
+                                                                                  
+                                                                        *DEFAULT-PUSH-EXTENSION-SIZE*
+                                                                                  ))))
+                         (LISP:VECTOR-PUSH CH STRING))))))
+
+
+
+(* |;;| "helpers")
+
+
+(LISP:DEFUN %NEW-FILE (FILENAME)
+   (CLOSEF (OPENSTREAM FILENAME 'OUTPUT 'NEW)))
+
+(LISP:DEFUN PREDICT-NAME (PATHNAME)
+   (LET ((PATH (LISP:PROBE-FILE PATHNAME)))
+        (IF PATH
+            THEN (LISP:NAMESTRING PATH))))
+(DECLARE\: EVAL@COMPILE DONTCOPY 
+
+(DEFMACRO INTERLISP-ACCESS (DIRECTION)
+   `(CASE ,DIRECTION
+        (:INPUT 'INPUT)
+        (:OUTPUT 'OUTPUT)
+        (:IO 'BOTH)
+        (T NIL)))
+)
+
+
+
+(* |;;| "methods for the special devices")
+
+(DEFINEQ
+
+(%BROADCAST-STREAM-DEVICE-BOUT
+  (LAMBDA (STREAM BYTE)                                      (* \; "Edited 13-Jan-87 14:45 by hdj")
+
+    (* |;;| "The BOUT method for the broadcast-stream device")
+
+    (|for| S |in| (|fetch| F1 |of| STREAM) |do| (\\BOUT S BYTE))
+    BYTE))
+
+(%BROADCAST-STREAM-DEVICE-OUTCHARFN
+  (LAMBDA (STREAM CHARCODE)                                  (* \; "Edited 18-Mar-87 11:00 by lal")
+
+    (* |;;| "outcharfn for broadcast streams")
+
+    (* |;;| "Using the charposition from the first stream in the broadcast stream list")
+
+    (|for| S |in| (|fetch| (STREAM F1) |of| STREAM) |do| (\\OUTCHAR S CHARCODE))
+    (|replace| (STREAM CHARPOSITION) |of| STREAM |with| (|fetch| (STREAM CHARPOSITION
+                                                                                        )
+                                                                       |of|
+                                                                       (CAR (|fetch| (STREAM
+                                                                                          F1)
+                                                                               |of| STREAM))))
+    CHARCODE))
+
+(%BROADCAST-STREAM-DEVICE-CLOSEFILE
+  (LAMBDA (STREAM)                                           (* |hdj| "26-Mar-86 16:28")
+
+(* |;;;| "The CLOSEFILE method for the broadcast-stream device")
+
+    (|replace| ACCESS |of| STREAM |with| NIL)
+    (|replace| F1 |of| STREAM |with| NIL)
+    STREAM))
+
+(%BROADCAST-STREAM-DEVICE-FORCEOUTPUT
+  (LAMBDA (|stream| |waitForFinish?|)                        (* |smL| "14-Aug-85 15:55")
+
+(* |;;;| "The FORCEOUTPUT method for the broadcast-stream device")
+
+    (|for| S |in| (|fetch| F1 |of| |stream|) |do| (FORCEOUTPUT S |waitForFinish?|
+                                                                             ))))
+)
+
+(LISP:DEFUN %BROADCAST-STREAM-DEVICE-CHARSETFN (STREAM NEWVALUE)
+
+   (* |;;| "charset function for broadcast streams.  Not clear what the value should be, so we arbitrarily return the value of the last stream.")
+
+   (FOR S IN (FETCH (STREAM F1) OF STREAM) DO (SETQ $$VAL (ACCESS-CHARSET S 
+                                                                                     NEWVALUE))))
+(DEFINEQ
+
+(%CONCATENATED-STREAM-DEVICE-BIN
+  (LAMBDA (STREAM)                                           (* \; "Edited 13-Jan-87 14:52 by hdj")
+
+    (* |;;| "The BIN method for the concatenated-stream device")
+
+    (WHILE (FETCH (STREAM F1) OF STREAM)
+       DO (IF (EOFP (CAR (FETCH (STREAM F1) OF STREAM)))
+                  THEN (CLOSEF (POP (FETCH (STREAM F1) OF STREAM)))
+                ELSE (RETURN (\\BIN (CAR (FETCH (STREAM F1) OF STREAM)))))
+       FINALLY                                           (* \; "the EOF case")
+             (\\EOF.ACTION STREAM))))
+
+(%CONCATENATED-STREAM-DEVICE-CLOSEFILE
+  (LAMBDA (|stream|)                                         (* |smL| "14-Aug-85 16:53")
+
+(* |;;;| "The CLOSEFILE method for the concatenated-stream device")
+
+    (|replace| ACCESS |of| |stream| |with| NIL)
+    (|for| S |in| (|fetch| F1 |of| |stream|) |do| (CLOSEF S))
+    (|replace| F1 |of| |stream| |with| NIL)
+    |stream|))
+
+(%CONCATENATED-STREAM-DEVICE-EOFP
+  (LAMBDA (|stream|)                                         (* \; "Edited 17-Mar-87 09:20 by lal")
+
+(* |;;;| "The EOFP method for the concatenated-stream device")
+
+    (|while| (|fetch| F1 |of| |stream|)
+       |do| (|if| (EOFP (CAR (|fetch| F1 |of| |stream|)))
+                    |then| (CLOSEF (|pop| (|fetch| F1 |of| |stream|)))
+                  |else| (RETURN NIL)) |finally|   (* \; "the EOF case")
+                                                   (RETURN T))))
+
+(%CONCATENATED-STREAM-DEVICE-PEEKBIN
+  (LAMBDA (|stream| |noErrorFlg?|)                           (* |smL| "14-Aug-85 16:53")
+
+(* |;;;| "The PEEKBIN method for the concatenated-stream device")
+
+    (|while| (|fetch| F1 |of| |stream|)
+       |do| (|if| (EOFP (CAR (|fetch| F1 |of| |stream|)))
+                    |then| (CLOSEF (|pop| (|fetch| F1 |of| |stream|)))
+                  |else| (RETURN (\\PEEKBIN (CAR (|fetch| F1 |of| |stream|)))))
+       |finally|                                         (* \; "the EOF case")
+             (|if| |noErrorFlg?|
+                 |then| (RETURN NIL)
+               |else| (\\EOF.ACTION |stream|)))))
+
+(%CONCATENATED-STREAM-DEVICE-BACKFILEPTR
+  (LAMBDA (|stream|)                                         (* \; "Edited 24-Mar-87 10:47 by lal")
+
+    (* |;;| "concatenated streams are read sequentially and a list of them are kept in F1.  as they are read, the used stream is removed from the list.  \\backfileptr will work because 1) when a file is stream is used up the new one is read, at least one character's worth and 2) \\backfileptr only needs to back up one character")
+
+    (\\BACKFILEPTR (CAR (|fetch| F1 |of| |stream|)))))
+)
+
+(LISP:DEFUN %CONCATENATED-STREAM-DEVICE-CHARSETFN (STREAM NEWVALUE)
+
+   (* |;;| "the charset method for concatenated stream devices")
+
+   (LET ((STREAMS (FETCH (STREAM F1) OF STREAM)))
+        (IF STREAMS
+            THEN (ACCESS-CHARSET (CAR STREAMS)
+                            NEWVALUE)
+          ELSE 0)))
+(DEFINEQ
+
+(%ECHO-STREAM-DEVICE-BIN
+  (LAMBDA (STREAM)                                           (* |hdj| "21-Apr-86 18:33")
+
+(* |;;;| "The BIN method for the echo-stream device")
+
+    (LET ((BYTE (%TWO-WAY-STREAM-DEVICE-BIN STREAM)))
+         (\\BOUT STREAM BYTE)
+         BYTE)))
+)
+
+(LISP:DEFUN %SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM (SYNONYM-STREAM)
+
+   (* |;;| "given a synonym-stream, find out what it is currently tracking")
+
+   (LISP:SYMBOL-VALUE (LISP:SYNONYM-STREAM-SYMBOL SYNONYM-STREAM)))
+(DEFINEQ
+
+(%SYNONYM-STREAM-DEVICE-BIN
+  (LAMBDA (STREAM)                                           (* |hdj| "19-Mar-86 17:19")
+
+(* |;;;| "The BIN method for the synonym-stream device.")
+
+    (\\BIN (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM))))
+
+(%SYNONYM-STREAM-DEVICE-BOUT
+  (LAMBDA (STREAM BYTE)                                      (* |hdj| "19-Mar-86 17:20")
+
+(* |;;;| "The BOUT method for the synonym-stream device.")
+
+    (\\BOUT (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM)
+           BYTE)))
+
+(%SYNONYM-STREAM-DEVICE-OUTCHARFN
+  (LAMBDA (STREAM CHARCODE)                                  (* \; "Edited  3-Jan-90 15:25 by jds")
+
+    (* |;;| " OUTCHARFN for synonym streams")
+
+    (LET ((OTHER-STREAM (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM)))
+         (\\OUTCHAR OTHER-STREAM CHARCODE)
+         (|freplace| (STREAM CHARPOSITION) |of| STREAM |with| (|ffetch| (STREAM
+                                                                                         CHARPOSITION
+                                                                                         )
+                                                                             |of| OTHER-STREAM)))
+    ))
+
+(%SYNONYM-STREAM-DEVICE-CLOSEFILE
+  (LAMBDA (STREAM)                                           (* \; "Edited 18-Dec-87 12:17 by sye")
+
+(* |;;;| "the CLOSEFILE method for the synonym-stream device")
+
+    (|replace| F1 |of| STREAM |with| NIL)
+
+    (* |;;| "remove the synonym stream STREAM from the OPENFILELST field of %SYNONYM-STREAM-DEVICE")
+
+    (|replace| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE
+       |with| (DREMOVE STREAM (|fetch| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE)))
+    STREAM))
+
+(%SYNONYM-STREAM-DEVICE-EOFP
+  (LAMBDA (STREAM)                                           (* |hdj| "19-Mar-86 17:20")
+
+(* |;;;| "The EOFP method for the synonym-stream device.")
+
+    (\\EOFP (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM))))
+
+(%SYNONYM-STREAM-DEVICE-FORCEOUTPUT
+  (LAMBDA (STREAM WAITFORFINISH)                             (* |hdj| "19-Mar-86 17:09")
+
+(* |;;;| "The FORCEOUTPUT method for the synonym-stream device.")
+
+    (FORCEOUTPUT (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM)
+           WAITFORFINISH)))
+
+(%SYNONYM-STREAM-DEVICE-GETFILEINFO
+  (LAMBDA (STREAM ATTRIBUTE DEVICE)                          (* |hdj| "19-Mar-86 17:10")
+
+(* |;;;| "The GETFILEINFO method for the synonym-stream device.")
+
+    (GETFILEINFO (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM)
+           ATTRIBUTE)))
+
+(%SYNONYM-STREAM-DEVICE-PEEKBIN
+  (LAMBDA (STREAM NOERRORFLG?)                               (* |hdj| "19-Mar-86 17:12")
+
+(* |;;;| "The PEEKBIN method for the synonym-stream device")
+
+    (\\PEEKBIN (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM)
+           NOERRORFLG?)))
+
+(%SYNONYM-STREAM-DEVICE-READP
+  (LAMBDA (STREAM FLG)
+    (READP (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM)
+           FLG)))
+
+(%SYNONYM-STREAM-DEVICE-BACKFILEPTR
+  (LAMBDA (STREAM)                                           (* |hdj| "26-Aug-86 17:35")
+    (\\BACKFILEPTR (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM))))
+
+(%SYNONYM-STREAM-DEVICE-SETFILEINFO
+  (LAMBDA (STREAM ATTRIBUTE VALUE DEVICE)                    (* |hdj| "19-Mar-86 17:17")
+
+(* |;;;| "The SETFILEINFO method for the synonym-stream device.")
+
+    (SETFILEINFO (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM)
+           ATTRIBUTE VALUE)))
+
+(%SYNONYM-STREAM-DEVICE-CHARSETFN
+  (LAMBDA (STREAM NEWVALUE)                                  (* \; "Edited 11-Sep-87 16:01 by bvm:")
+
+    (* |;;| "The charset method for the synonym-stream device.")
+
+    (ACCESS-CHARSET (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM)
+           NEWVALUE)))
+)
+(DEFINEQ
+
+(%TWO-WAY-STREAM-DEVICE-BIN
+  (LAMBDA (|stream|)                                         (* |smL| "14-Aug-85 16:44")
+
+(* |;;;| "The BIN method for the two-way-stream device")
+
+    (\\BIN (|fetch| F1 |of| |stream|))))
+
+(%TWO-WAY-STREAM-DEVICE-INPUTSTREAM
+  (LAMBDA (|stream|)                                         (* \; "Edited 14-Apr-87 16:59 by bvm:")
+
+(* |;;;| "Fetch the real input for the two-way-stream device")
+
+    (|fetch| F1 |of| |stream|)))
+
+(%TWO-WAY-STREAM-DEVICE-BOUT
+  (LAMBDA (STREAM BYTE)                                      (* |hdj| "17-Sep-86 15:28")
+
+    (* |;;| " the BOUT method for two-way streams")
+
+    (\\BOUT (|fetch| F2 |of| STREAM)
+           BYTE)))
+
+(%TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM
+  (LAMBDA (STREAM BYTE)                                      (* \; "Edited 14-Apr-87 16:59 by bvm:")
+
+    (* |;;| "Fetch the real output stream for two-way streams")
+
+    (|fetch| F2 |of| STREAM)))
+
+(%TWO-WAY-STREAM-DEVICE-OUTCHARFN
+  (LAMBDA (STREAM CHARCODE)                                  (* \; "Edited  3-Jan-90 15:26 by jds")
+
+    (* |;;| "outcharfn for two-way streams")
+
+    (\\OUTCHAR (|fetch| (STREAM F2) |of| STREAM)
+           CHARCODE)
+    (|freplace| (STREAM CHARPOSITION) |of| STREAM |with| (|ffetch| (STREAM 
+                                                                                         CHARPOSITION
+                                                                                          )
+                                                                        |of| (|ffetch|
+                                                                                  (STREAM F2)
+                                                                                    |of| STREAM))
+           )))
+
+(%TWO-WAY-STREAM-DEVICE-CLOSEFILE
+  (LAMBDA (|stream|)                                         (* \; "Edited 18-Dec-87 12:32 by sye")
+
+(* |;;;| "The CLOSEFILE method for the two-way-stream device and echo-stream device")
+
+    (LET ((STREAMDEVICE (|if| (XCL:TWO-WAY-STREAM-P |stream|)
+                            |then| %TWO-WAY-STREAM-DEVICE
+                          |else| %ECHO-STREAM-DEVICE)))
+         (|replace| ACCESS |of| |stream| |with| NIL)
+         (CLOSEF? (|fetch| F1 |of| |stream|))
+         (|replace| F1 |of| |stream| |with| NIL)
+         (CLOSEF? (|fetch| F2 |of| |stream|))
+         (|replace| F2 |of| |stream| |with| NIL)
+
+         (* |;;| 
+      "remove  STREAM from the OPENFILELST field of %TWO-WAY-STREAM-DEVICE  or %ECHO-STREAM-DEVICE")
+
+         (|replace| (FDEV OPENFILELST) |of| STREAMDEVICE |with|
+                                                                 (DREMOVE |stream|
+                                                                        (|fetch| (FDEV 
+                                                                                          OPENFILELST
+                                                                                           )
+                                                                           |of| STREAMDEVICE)))
+         |stream|)))
+
+(%TWO-WAY-STREAM-DEVICE-EOFP
+  (LAMBDA (|stream|)                                         (* |smL| "14-Aug-85 16:47")
+
+(* |;;;| "The EOFP method for the two-way-stream device")
+
+    (\\EOFP (|fetch| F1 |of| |stream|))))
+
+(%TWO-WAY-STREAM-DEVICE-READP
+  (LAMBDA (STREAM FLG)                                       (* \; "Edited 14-Apr-87 17:01 by bvm:")
+
+(* |;;;| "The READP method for the two-way-stream device")
+
+    (READP (|fetch| F1 |of| STREAM)
+           FLG)))
+
+(%TWO-WAY-STREAM-DEVICE-BACKFILEPTR
+  (LAMBDA (STREAM)                                           (* |hdj| "15-Sep-86 15:02")
+    (\\BACKFILEPTR (|fetch| (STREAM F1) |of| STREAM))))
+
+(%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT
+  (LAMBDA (|stream| |waitForFinish?|)                        (* |smL| "14-Aug-85 16:49")
+
+(* |;;;| "the FORCEOUTPUT method for the two-way-stream device")
+
+    (FORCEOUTPUT (|fetch| F2 |of| |stream|)
+           |waitForFinish?|)))
+
+(%TWO-WAY-STREAM-DEVICE-PEEKBIN
+  (LAMBDA (|stream| |noErrorFlg?|)                           (* |smL| "14-Aug-85 16:46")
+
+(* |;;;| "The PEEKBIN method for the two-way-stream device")
+
+    (\\PEEKBIN (|fetch| F1 |of| |stream|)
+           |noErrorFlg?|)))
+
+(%TWO-WAY-STREAM-DEVICE-CHARSETFN
+  (LAMBDA (STREAM NEWVALUE)                                  (* \; "Edited 11-Sep-87 16:00 by bvm:")
+
+    (* |;;| "The charset method for two-way streams.  Unclear what this is supposed to mean--let's apply it only to the input side (in which case newvalue is senseless)")
+
+    (ACCESS-CHARSET (|fetch| (STREAM F1) |of| STREAM)
+           NEWVALUE)))
+)
+
+(LISP:DEFUN %FILL-POINTER-STREAM-DEVICE-CLOSEFILE (STREAM &OPTIONAL ABORTFLAG)
+
+(* |;;;| "the CLOSEFILE method for the fill-pointer-string-stream device")
+
+   (|replace| F1 |of| STREAM |with| NIL)
+   STREAM)
+
+(LISP:DEFUN %FILL-POINTER-STREAM-DEVICE-GETFILEPTR (STREAM)
+   (LISP:LENGTH (|fetch| (STREAM F1) |of| STREAM)))
+(DECLARE\: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS %SYNONYM-STREAM-DEVICE %BROADCAST-STREAM-DEVICE %CONCATENATED-STREAM-DEVICE 
+       %TWO-WAY-STREAM-DEVICE %ECHO-STREAM-DEVICE \\FILL-POINTER-STREAM-DEVICE)
+)
+
+
+
+(* |;;| "helper stuff")
+
+(DEFINEQ
+
+(%SYNONYM-STREAM-DEVICE-GET-STREAM
+  (LAMBDA (|stream|)                                         (* \; "Edited 12-Jan-87 14:46 by hdj")
+
+    (* |;;| "given a synonym-stream, find out what it is currently tracking")
+
+    (LISP:SYMBOL-VALUE (|fetch| (STREAM F1) |of| |stream|))))
+)
+
+
+
+(* |;;| "module initialization")
+
+
+(LISP:DEFVAR *DEBUG-IO*)
+
+(LISP:DEFVAR *QUERY-IO*)
+
+(LISP:DEFVAR *TERMINAL-IO*)
+
+(LISP:DEFVAR *ERROR-OUTPUT*)
+
+(LISP:DEFVAR *STANDARD-OUTPUT*)
+
+(LISP:DEFVAR *STANDARD-INPUT*)
+
+(LISP:DEFUN %INITIALIZE-STANDARD-STREAMS ()
+
+   (* |;;| 
+ "Called when CLSTREAMS is loaded.  Almost everything is same as *TERMINAL-IO* to start with.")
+
+   (LISP:SETQ *QUERY-IO* (LISP:MAKE-TWO-WAY-STREAM (LISP:MAKE-SYNONYM-STREAM '\\LINEBUF.OFD)
+                                (LISP:MAKE-SYNONYM-STREAM '\\TERM.OFD)))
+   (LISP:SETQ *DEBUG-IO* *QUERY-IO*)
+   (LISP:SETQ *TERMINAL-IO* *QUERY-IO*)
+   (LISP:SETQ *ERROR-OUTPUT* (LISP:MAKE-SYNONYM-STREAM '\\TERM.OFD)))
+(DEFINEQ
+
+(%INITIALIZE-CLSTREAM-TYPES
+  (LAMBDA NIL                                              (* \; "Edited 14-Apr-87 17:08 by bvm:")
+
+    (* |;;| "Initialize the CLSTREAMS package.  This sets up some file devices for the functions make-two-way-stream-device, etc.  See CLtL chapter 21")
+
+    (SETQ %BROADCAST-STREAM-DEVICE
+     (|create| FDEV
+            DEVICENAME _ 'BROADCAST-STREAM-DEVICE
+            RESETABLE _ NIL
+            RANDOMACCESSP _ NIL
+            NODIRECTORIES _ T
+            BUFFERED _ NIL
+            PAGEMAPPED _ NIL
+            FDBINABLE _ NIL
+            FDBOUTABLE _ NIL
+            FDEXTENDABLE _ NIL
+            DEVICEINFO _ NIL
+            HOSTNAMEP _ (FUNCTION NILL)
+            EVENTFN _ (FUNCTION NILL)
+            DIRECTORYNAMEP _ (FUNCTION NILL)
+            REOPENFILE _ (FUNCTION NILL)
+            CLOSEFILE _ (FUNCTION %BROADCAST-STREAM-DEVICE-CLOSEFILE)
+            GETFILENAME _ (FUNCTION NILL)
+            DELETEFILE _ (FUNCTION NILL)
+            GENERATEFILES _ (FUNCTION \\GENERATENOFILES)
+            RENAMEFILE _ (FUNCTION NILL)
+            BIN _ (FUNCTION NILL)
+            BOUT _ (FUNCTION %BROADCAST-STREAM-DEVICE-BOUT)
+            PEEKBIN _ (FUNCTION NILL)
+            READP _ (FUNCTION NILL)
+            EOFP _ (FUNCTION TRUE)
+            BLOCKIN _ (FUNCTION \\GENERIC.BINS)
+            BLOCKOUT _ (FUNCTION NILL)
+            FORCEOUTPUT _ (FUNCTION %BROADCAST-STREAM-DEVICE-FORCEOUTPUT)
+            GETFILEINFO _ (FUNCTION NILL)
+            SETFILEINFO _ (FUNCTION NILL)
+            CHARSETFN _ (FUNCTION %BROADCAST-STREAM-DEVICE-CHARSETFN)))
+    (SETQ %CONCATENATED-STREAM-DEVICE
+     (|create| FDEV
+            DEVICENAME _ 'CONCATENATED-STREAM-DEVICE
+            RESETABLE _ NIL
+            RANDOMACCESSP _ NIL
+            NODIRECTORIES _ T
+            BUFFERED _ NIL
+            PAGEMAPPED _ NIL
+            FDBINABLE _ NIL
+            FDBOUTABLE _ NIL
+            FDEXTENDABLE _ NIL
+            DEVICEINFO _ NIL
+            HOSTNAMEP _ (FUNCTION NILL)
+            EVENTFN _ (FUNCTION NILL)
+            DIRECTORYNAMEP _ (FUNCTION NILL)
+            REOPENFILE _ (FUNCTION NILL)
+            CLOSEFILE _ (FUNCTION %CONCATENATED-STREAM-DEVICE-CLOSEFILE)
+            GETFILENAME _ (FUNCTION NILL)
+            DELETEFILE _ (FUNCTION NILL)
+            GENERATEFILES _ (FUNCTION \\GENERATENOFILES)
+            RENAMEFILE _ (FUNCTION NILL)
+            BIN _ (FUNCTION %CONCATENATED-STREAM-DEVICE-BIN)
+            BOUT _ (FUNCTION NILL)
+            PEEKBIN _ (FUNCTION %CONCATENATED-STREAM-DEVICE-PEEKBIN)
+            READP _ (FUNCTION \\GENERIC.READP)
+            BACKFILEPTR _ (FUNCTION %CONCATENATED-STREAM-DEVICE-BACKFILEPTR)
+            EOFP _ (FUNCTION %CONCATENATED-STREAM-DEVICE-EOFP)
+            BLOCKIN _ (FUNCTION \\GENERIC.BINS)
+            BLOCKOUT _ (FUNCTION NILL)
+            FORCEOUTPUT _ (FUNCTION NILL)
+            GETFILEINFO _ (FUNCTION NILL)
+            SETFILEINFO _ (FUNCTION NILL)
+            CHARSETFN _ (FUNCTION %CONCATENATED-STREAM-DEVICE-CHARSETFN)))
+    (SETQ %TWO-WAY-STREAM-DEVICE
+     (|create| FDEV
+            DEVICENAME _ 'TWO-WAY-STREAM-DEVICE
+            RESETABLE _ NIL
+            RANDOMACCESSP _ NIL
+            NODIRECTORIES _ T
+            BUFFERED _ NIL
+            PAGEMAPPED _ NIL
+            FDBINABLE _ NIL
+            FDBOUTABLE _ NIL
+            FDEXTENDABLE _ NIL
+            INPUT-INDIRECTED _ T
+            OUTPUT-INDIRECTED _ T
+            DEVICEINFO _ NIL
+            HOSTNAMEP _ (FUNCTION NILL)
+            EVENTFN _ (FUNCTION NILL)
+            DIRECTORYNAMEP _ (FUNCTION NILL)
+            REOPENFILE _ (FUNCTION NILL)
+            CLOSEFILE _ (FUNCTION %TWO-WAY-STREAM-DEVICE-CLOSEFILE)
+            GETFILENAME _ (FUNCTION NILL)
+            DELETEFILE _ (FUNCTION NILL)
+            GENERATEFILES _ (FUNCTION \\GENERATENOFILES)
+            RENAMEFILE _ (FUNCTION NILL)
+            BIN _ (FUNCTION %TWO-WAY-STREAM-DEVICE-BIN)
+            BOUT _ (FUNCTION %TWO-WAY-STREAM-DEVICE-BOUT)
+            PEEKBIN _ (FUNCTION %TWO-WAY-STREAM-DEVICE-PEEKBIN)
+            READP _ (FUNCTION %TWO-WAY-STREAM-DEVICE-READP)
+            BACKFILEPTR _ (FUNCTION %TWO-WAY-STREAM-DEVICE-BACKFILEPTR)
+            EOFP _ (FUNCTION %TWO-WAY-STREAM-DEVICE-EOFP)
+            BLOCKIN _ (FUNCTION \\GENERIC.BINS)
+            BLOCKOUT _ (FUNCTION \\GENERIC.BOUTS)
+            FORCEOUTPUT _ (FUNCTION %TWO-WAY-STREAM-DEVICE-FORCEOUTPUT)
+            GETFILEINFO _ (FUNCTION NILL)
+            SETFILEINFO _ (FUNCTION NILL)
+            CHARSETFN _ (FUNCTION %TWO-WAY-STREAM-DEVICE-CHARSETFN)
+            INPUTSTREAM _ (FUNCTION %TWO-WAY-STREAM-DEVICE-INPUTSTREAM)
+            OUTPUTSTREAM _ (FUNCTION %TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM)))
+    (SETQ %ECHO-STREAM-DEVICE (|create| FDEV |using| %TWO-WAY-STREAM-DEVICE DEVICENAME _
+                                                       'ECHO-STREAM-DEVICE BIN _
+                                                       (FUNCTION %ECHO-STREAM-DEVICE-BIN)))
+    (SETQ %SYNONYM-STREAM-DEVICE
+     (|create| FDEV
+            DEVICENAME _ 'SYNONYM-STREAM-DEVICE
+            RESETABLE _ NIL
+            RANDOMACCESSP _ NIL
+            NODIRECTORIES _ T
+            BUFFERED _ NIL
+            PAGEMAPPED _ NIL
+            FDBINABLE _ NIL
+            FDBOUTABLE _ NIL
+            FDEXTENDABLE _ NIL
+            DEVICEINFO _ NIL
+            INPUT-INDIRECTED _ T
+            OUTPUT-INDIRECTED _ T
+            HOSTNAMEP _ (FUNCTION NILL)
+            EVENTFN _ (FUNCTION NILL)
+            DIRECTORYNAMEP _ (FUNCTION NILL)
+            REOPENFILE _ (FUNCTION NILL)
+            CLOSEFILE _ (FUNCTION %SYNONYM-STREAM-DEVICE-CLOSEFILE)
+            GETFILENAME _ (FUNCTION NILL)
+            DELETEFILE _ (FUNCTION NILL)
+            GENERATEFILES _ (FUNCTION \\GENERATENOFILES)
+            RENAMEFILE _ (FUNCTION NILL)
+            BIN _ (FUNCTION %SYNONYM-STREAM-DEVICE-BIN)
+            BOUT _ (FUNCTION %SYNONYM-STREAM-DEVICE-BOUT)
+            PEEKBIN _ (FUNCTION %SYNONYM-STREAM-DEVICE-PEEKBIN)
+            READP _ (FUNCTION %SYNONYM-STREAM-DEVICE-READP)
+            BACKFILEPTR _ (FUNCTION %SYNONYM-STREAM-DEVICE-BACKFILEPTR)
+            EOFP _ (FUNCTION %SYNONYM-STREAM-DEVICE-EOFP)
+            BLOCKIN _ (FUNCTION \\GENERIC.BINS)
+            BLOCKOUT _ (FUNCTION \\GENERIC.BOUTS)
+            FORCEOUTPUT _ (FUNCTION %SYNONYM-STREAM-DEVICE-FORCEOUTPUT)
+            GETFILEINFO _ (FUNCTION %SYNONYM-STREAM-DEVICE-GETFILEINFO)
+            SETFILEINFO _ (FUNCTION %SYNONYM-STREAM-DEVICE-SETFILEINFO)
+            INPUTSTREAM _ (FUNCTION %SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM)
+            OUTPUTSTREAM _ (FUNCTION %SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM)
+            CHARSETFN _ (FUNCTION %SYNONYM-STREAM-DEVICE-CHARSETFN)))
+    (SETQ \\FILL-POINTER-STREAM-DEVICE
+     (|create| FDEV
+            DEVICENAME _ 'FILL-POINTER-STREAM-DEVICE
+            RESETABLE _ NIL
+            RANDOMACCESSP _ NIL
+            NODIRECTORIES _ T
+            BUFFERED _ NIL
+            PAGEMAPPED _ NIL
+            FDBINABLE _ NIL
+            FDBOUTABLE _ NIL
+            FDEXTENDABLE _ NIL
+            DEVICEINFO _ NIL
+            HOSTNAMEP _ (FUNCTION NILL)
+            EVENTFN _ (FUNCTION NILL)
+            DIRECTORYNAMEP _ (FUNCTION NILL)
+            OPENFILE _ (FUNCTION NILL)
+            REOPENFILE _ (FUNCTION NILL)
+            CLOSEFILE _ (FUNCTION %FILL-POINTER-STREAM-DEVICE-CLOSEFILE)
+            GETFILENAME _ (FUNCTION NILL)
+            DELETEFILE _ (FUNCTION NILL)
+            GENERATEFILES _ (FUNCTION \\GENERATENOFILES)
+            RENAMEFILE _ (FUNCTION NILL)
+            BIN _ (FUNCTION \\ILLEGAL.DEVICEOP)
+            BOUT _ (FUNCTION NILL)
+            PEEKBIN _ (FUNCTION \\ILLEGAL.DEVICEOP)
+            READP _ (FUNCTION \\ILLEGAL.DEVICEOP)
+            EOFP _ (FUNCTION NILL)
+            BLOCKIN _ (FUNCTION \\ILLEGAL.DEVICEOP)
+            BLOCKOUT _ (FUNCTION \\GENERIC.BOUTS)
+            FORCEOUTPUT _ (FUNCTION NILL)
+            GETFILEPTR _ (FUNCTION %FILL-POINTER-STREAM-DEVICE-GETFILEPTR)
+            SETFILEINFO _ (FUNCTION \\ILLEGAL.DEVICEOP)))))
+)
+(DECLARE\: DONTEVAL@LOAD DOCOPY 
+
+(%INITIALIZE-CLSTREAM-TYPES)
+
+(%INITIALIZE-STANDARD-STREAMS)
+)
+
+(PUTPROPS CLSTREAMS FILETYPE LISP:COMPILE-FILE)
+(PUTPROPS CLSTREAMS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991 1992 1993))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (35395 37407 (%BROADCAST-STREAM-DEVICE-BOUT 35405 . 35708) (
+%BROADCAST-STREAM-DEVICE-OUTCHARFN 35710 . 36678) (%BROADCAST-STREAM-DEVICE-CLOSEFILE 36680 . 37012) (
+%BROADCAST-STREAM-DEVICE-FORCEOUTPUT 37014 . 37405)) (37825 40759 (%CONCATENATED-STREAM-DEVICE-BIN 
+37835 . 38468) (%CONCATENATED-STREAM-DEVICE-CLOSEFILE 38470 . 38896) (%CONCATENATED-STREAM-DEVICE-EOFP
+ 38898 . 39473) (%CONCATENATED-STREAM-DEVICE-PEEKBIN 39475 . 40206) (
+%CONCATENATED-STREAM-DEVICE-BACKFILEPTR 40208 . 40757)) (41099 41397 (%ECHO-STREAM-DEVICE-BIN 41109 . 
+41395)) (41630 45502 (%SYNONYM-STREAM-DEVICE-BIN 41640 . 41889) (%SYNONYM-STREAM-DEVICE-BOUT 41891 . 
+42159) (%SYNONYM-STREAM-DEVICE-OUTCHARFN 42161 . 42868) (%SYNONYM-STREAM-DEVICE-CLOSEFILE 42870 . 
+43427) (%SYNONYM-STREAM-DEVICE-EOFP 43429 . 43681) (%SYNONYM-STREAM-DEVICE-FORCEOUTPUT 43683 . 43979) 
+(%SYNONYM-STREAM-DEVICE-GETFILEINFO 43981 . 44273) (%SYNONYM-STREAM-DEVICE-PEEKBIN 44275 . 44558) (
+%SYNONYM-STREAM-DEVICE-READP 44560 . 44692) (%SYNONYM-STREAM-DEVICE-BACKFILEPTR 44694 . 44895) (
+%SYNONYM-STREAM-DEVICE-SETFILEINFO 44897 . 45195) (%SYNONYM-STREAM-DEVICE-CHARSETFN 45197 . 45500)) (
+45503 50475 (%TWO-WAY-STREAM-DEVICE-BIN 45513 . 45749) (%TWO-WAY-STREAM-DEVICE-INPUTSTREAM 45751 . 
+46005) (%TWO-WAY-STREAM-DEVICE-BOUT 46007 . 46254) (%TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM 46256 . 46510)
+ (%TWO-WAY-STREAM-DEVICE-OUTCHARFN 46512 . 47374) (%TWO-WAY-STREAM-DEVICE-CLOSEFILE 47376 . 48798) (
+%TWO-WAY-STREAM-DEVICE-EOFP 48800 . 49039) (%TWO-WAY-STREAM-DEVICE-READP 49041 . 49306) (
+%TWO-WAY-STREAM-DEVICE-BACKFILEPTR 49308 . 49504) (%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT 49506 . 49792) (
+%TWO-WAY-STREAM-DEVICE-PEEKBIN 49794 . 50067) (%TWO-WAY-STREAM-DEVICE-CHARSETFN 50069 . 50473)) (51071
+ 51379 (%SYNONYM-STREAM-DEVICE-GET-STREAM 51081 . 51377)) (52117 60299 (%INITIALIZE-CLSTREAM-TYPES 
+52127 . 60297)))))
+STOP
diff --git a/CLTL2/CLSTREAMS.LCOM b/CLTL2/CLSTREAMS.LCOM
new file mode 100644
index 00000000..fcc52623
Binary files /dev/null and b/CLTL2/CLSTREAMS.LCOM differ
diff --git a/CLTL2/CMLARITH b/CLTL2/CMLARITH
new file mode 100644
index 00000000..cf4b3f43
--- /dev/null
+++ b/CLTL2/CMLARITH
@@ -0,0 +1,944 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
+(IL:FILECREATED "24-Mar-92 14:23:15" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLARITH.;2| 68401  
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:CMLARITHCOMS) (IL:FUNCTIONS CL:UPGRADED-COMPLEX-PART-TYPE) (IL:FNS LCM)
+
+      IL:|previous| IL:|date:| "16-May-90 12:46:36" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>CMLARITH.;1|)
+
+
+; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CMLARITHCOMS)
+
+(IL:RPAQQ IL:CMLARITHCOMS ((IL:* IL:|;;;| "Common Lisp Arithmetic ") (IL:COMS (IL:* IL:|;;| "Error utilities") (IL:FUNCTIONS %NOT-NUMBER-ERROR %NOT-NONCOMPLEX-NUMBER-ERROR %NOT-INTEGER-ERROR %NOT-RATIONAL-ERROR %NOT-FLOAT-ERROR)) (IL:COMS (IL:* IL:|;;;| "Section 2.1.2 Ratios. ") (IL:COMS (IL:STRUCTURES RATIO) (IL:* IL:|;;| "The following makes NUMBERP true on ratios") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:\\SETTYPEMASK (IL:\\TYPENUMBERFROMNAME (QUOTE RATIO)) (IL:LOGOR IL:\\TT.NUMBERP IL:\\TT.ATOM))))) (IL:FUNCTIONS DENOMINATOR NUMERATOR RATIONALP %RATIO-PRINT %BUILD-RATIO RATIONAL RATIONALIZE) (IL:FUNCTIONS %RATIO-PLUS %RATIO-TIMES)) (IL:COMS (IL:* IL:|;;;| "Section 2.1.4 Complex Numbers.") (IL:COMS (IL:STRUCTURES COMPLEX) (IL:* IL:|;;| "So we don't inherit the deftype from defstruct") (IL:TYPES COMPLEX) (IL:* IL:|;;| "Make Complex  NUMBERP") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:\\SETTYPEMASK (IL:\\TYPENUMBERFROMNAME (QUOTE COMPLEX)) (IL:LOGOR IL:\\TT.NUMBERP IL:\\TT.ATOM))))) (IL:FUNCTIONS COMPLEX REALPART IMAGPART CONJUGATE PHASE CL:UPGRADED-COMPLEX-PART-TYPE %COMPLEX-PRINT %COMPLEX-+ %COMPLEX-- %COMPLEX-* %COMPLEX-/ %COMPLEX-ABS)) (IL:COMS (IL:* IL:|;;;| "Datatype predicates") (IL:* IL:|;;| "cl:integerp is defined in cmlpred (has an optimizer)") (IL:* IL:|;;| "cl:floatp is defined in cmltypes (has an optimizer). il:floatp is defined on llbasic") (IL:* IL:|;;| "cl:complexp is a defstruct predicate (compiles in line)") (IL:* IL:|;;| "cl:numberp is defined in cmltypes (has an optimizer). il:numberp is defined on llbasic")) (IL:COMS (IL:* IL:|;;;| "Section 12.2 Predicates on Numbers (generic).") (IL:* IL:|;;| "cl:zerop  is not shared with il:zerop, although they are equivalent. There is no il;plusp ") (IL:COMS (IL:FUNCTIONS ZEROP PLUSP) (XCL:OPTIMIZERS ZEROP PLUSP)) (IL:* IL:|;;| "cl:minusp is shared with il:minusp, but must be redefined to work with ratios. Old version resides in llarith") (IL:COMS (IL:FUNCTIONS MINUSP) (XCL:OPTIMIZERS MINUSP)) (IL:* IL:|;;| "Both cl:evenp and cl:oddp are shared with il:. The functions are extended by allowing a second optional modulus argument. Another version of il:oddp exists on llarith, but the definition of il:evenp has disappeared") (IL:COMS (IL:FUNCTIONS EVENP ODDP) (XCL:OPTIMIZERS EVENP ODDP))) (IL:COMS (IL:* IL:|;;;| "Section 12.3 Comparisons on Numbers. (generic)") (IL:COMS (IL:FUNCTIONS %= %/= %> %< %>= %<=) (IL:PROP IL:DOPVAL %= %> %<) (IL:* IL:\; "For the byte compiler") (IL:PROP IL:DMACRO %> %< %>= %<=) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:* IL:|;;| "Backward compatibility") (IL:* IL:\; " il:%= is listed as the punt function for the = opcode") (IL:MOVD (QUOTE %=) (QUOTE IL:%=)) (IL:* IL:\; "Greaterp is the UFN for the greaterp opcode. Effectively redefines the opcode") (IL:MOVD (QUOTE %>) (QUOTE IL:GREATERP)) (IL:* IL:\; "Interlisp Greaterp and Lessp are defined in llarith") (IL:MOVD (QUOTE %<) (QUOTE IL:LESSP))))) (IL:* IL:|;;| "=, <, >, <=, and >= are shared with il:, but cl:/= is NOT shared (?!)") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %COMPARISON-MACRO)) (IL:FNS = /= < > <= >=) (IL:FUNCTIONS %COMPARISON-OPTIMIZER) (XCL:OPTIMIZERS = /= < > <= >=)) (IL:* IL:|;;| "Note: the related predicates EQL, EQUAL, and EQUALP should be consulted if any of the above change. EQL is on LLNEW (?), EQUAL and EQUALP on CMLTYPES.") (IL:* IL:|;;| "cl:min and cl:max are shared with il: (defined in llarith). They  are written in terms of GREATERP and hence work on ratios. Note (min) returns #.max.integer , which is an extension on the CLtl spec. We only optimize the case of two args") (XCL:OPTIMIZERS MIN MAX)) (IL:COMS (IL:* IL:|;;;| "Section 12.4 Arithmetic Operations (generic). ") (IL:COMS (IL:FUNCTIONS %+ %- %* %/) (IL:* IL:\; "NOTE: %/ cannot compile out to the existinq quotient opcode because it produces ratios rather than truncating") (IL:PROP IL:DOPVAL %+ %- %*) (IL:* IL:\; "For the byte compiler") (IL:PROP IL:DMACRO %+ %- %*) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:* IL:|;;| "Backward compatibility") (IL:MOVD (QUOTE %/) (QUOTE IL:%/)) (IL:* IL:|;;| "Redefine UFNs for generic plus, difference, and times. Old UFN defined in llarith.") (IL:MOVD (QUOTE %+) (QUOTE IL:\\SLOWPLUS2)) (IL:MOVD (QUOTE %-) (QUOTE IL:\\SLOWDIFFERENCE)) (IL:MOVD (QUOTE %*) (QUOTE IL:\\SLOWTIMES2))))) (IL:COMS (IL:FNS + - * /) (IL:FUNCTIONS 1+ 1- %RECIPROCOL) (XCL:OPTIMIZERS + - * / 1+ 1-) (IL:* IL:\; "For the byte compiler") (IL:PROP IL:DMACRO + *) (IL:* IL:|;;| "Redefine Interlisp generic arithmetic to work with ratios") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:MOVD (QUOTE +) (QUOTE IL:PLUS)) (IL:* IL:|;;| "Don't need to redefine difference since it is defined in terms of the difference opcode (redefined above)") (IL:MOVD (QUOTE *) (QUOTE IL:TIMES)) (IL:* IL:|;;| "So Interlisp quotient will do something reasonable with ratios") (IL:* (IL:MOVD (QUOTE IL:NEW-QUOTIENT) (QUOTE IL:QUOTIENT))) (IL:* IL:|;;| "because QUOTIENT is already defined in LLARITH to do something useful with ratios. AR 8062.")))) (IL:* IL:|;;| "INCF and DECF implemented by CMLSETF.") (IL:FUNCTIONS %GCD %LCM) (IL:FNS GCD LCM)) (IL:COMS (IL:* IL:|;;| "Optimizers for Interlisp functions, so that they compile open with the PavCompiler.") (IL:* IL:|;;| "optimizer of IL:minus") (XCL:OPTIMIZERS IL:MINUS) (XCL:OPTIMIZERS IL:PLUS IL:IPLUS IL:FPLUS IL:TIMES IL:ITIMES IL:FTIMES IL:RSH) (IL:PROP IL:DOPVAL IL:PLUS2 IL:IPLUS2 IL:FPLUS2 IL:TIMES2 IL:ITIMES2 IL:FTIMES2)) (IL:COMS (IL:* IL:|;;;| "Section 12.5 Irrational and Transcendental functions. Most of these will be found on cmlfloat.") (IL:FUNCTIONS ISQRT) (IL:* IL:|;;| "Abs is shared with il: abs ia also defined in llarith.") (IL:FUNCTIONS ABS %ABS) (IL:FUNCTIONS SIGNUM %SIGNUM)) (IL:COMS (IL:* IL:|;;;| "Section 12.6 Type Conversions and Component Extractions on Numbers.") (IL:* IL:|;;| "Float implemented in cmlfloat  ") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:UNBOXEDOPS)) (IL:* IL:\; "These should be exported from xcl") (IL:COMS (IL:FUNCTIONS XCL::STRUNCATE XCL::SFLOOR XCL::SCEILING XCL::SROUND) (XCL:OPTIMIZERS XCL::STRUNCATE XCL::SROUND)) (IL:* IL:\; "Round is shared with il: (?!)") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %INTEGER-COERCE-MACRO)) (IL:FUNCTIONS TRUNCATE FLOOR CEILING ROUND) (IL:FUNCTIONS %INTEGER-COERCE-OPTIMIZER) (XCL:OPTIMIZERS TRUNCATE FLOOR CEILING ROUND)) (IL:COMS (IL:FUNCTIONS FTRUNCATE FFLOOR FCEILING FROUND) (XCL:OPTIMIZERS FTRUNCATE FFLOOR FCEILING FROUND)) (IL:COMS (IL:FUNCTIONS MOD REM)) (IL:* IL:|;;| "Should IL:remainder be equivalent to cl:rem?. Thereis no IL:mod in the IRM, although it has a macro which makes it equivalent to imod.") (IL:* IL:|;;| "See cmlfloat for ffloor and friends, decode-float and friends")) (IL:COMS (IL:* IL:|;;;| "Section 12.7 Logical Operations on Numbers.") (IL:* IL:|;;| "LOGXOR and LOGAND are shared with IL. (definitions in llarith)") (IL:COMS (IL:FUNCTIONS %LOGICAL-OPTIMIZER) (XCL:OPTIMIZERS LOGXOR LOGAND)) (IL:COMS (IL:FUNCTIONS %LOGIOR %LOGEQV) (IL:PROP IL:DOPVAL %LOGIOR) (IL:* IL:\; "for the byte compiler") (IL:PROP IL:DMACRO %LOGIOR)) (IL:COMS (IL:FNS LOGIOR LOGEQV) (XCL:OPTIMIZERS LOGIOR LOGEQV)) (IL:COMS (IL:FUNCTIONS LOGNAND LOGNOR LOGANDC1 LOGANDC2 LOGORC1 LOGORC2) (XCL:OPTIMIZERS LOGNAND LOGNOR LOGANDC1 LOGANDC2 LOGORC1 LOGORC2)) (IL:COMS (IL:VARIABLES BOOLE-CLR BOOLE-SET BOOLE-1 BOOLE-2 BOOLE-C1 BOOLE-C2 BOOLE-AND BOOLE-IOR BOOLE-XOR BOOLE-EQV BOOLE-NAND BOOLE-NOR BOOLE-ANDC1 BOOLE-ANDC2 BOOLE-ORC1 BOOLE-ORC2) (IL:FUNCTIONS BOOLE)) (IL:* IL:|;;| "Lognot is shared with IL.(in addarith) ") (IL:COMS (IL:FUNCTIONS LOGTEST LOGBITP) (XCL:OPTIMIZERS LOGTEST)) (IL:COMS (IL:FUNCTIONS ASH) (IL:PROP IL:DOPVAL ASH) (IL:* IL:\; "For the byte compiler") (IL:PROP IL:DMACRO ASH)) (IL:COMS (IL:FUNCTIONS LOGCOUNT %LOGCOUNT) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES (IL:LOADCOMP) IL:LLBIGNUM)) (IL:* IL:\; "Should be in llbignum") (IL:FUNCTIONS %BIGNUM-LOGCOUNT)) (IL:FUNCTIONS INTEGER-LENGTH) (IL:* IL:|;;| "OPTIMIZERS FOR IL:LLSH AND IL:LRSH") (IL:COMS (IL:FUNCTIONS %LLSH8 %LLSH1 %LRSH8 %LRSH1) (IL:PROP IL:DOPVAL %LLSH8 %LLSH1 %LRSH8 %LRSH1) (XCL:OPTIMIZERS IL:LLSH IL:LRSH))) (IL:COMS (IL:* IL:|;;;| "Section 12.8 Byte Manipulations Functions.") (IL:COMS (IL:FUNCTIONS BYTE BYTE-SIZE BYTE-POSITION) (IL:* IL:|;;| "Byte doesn't need an optimizer since the side-effects data-base will do constant folding, but the byte-compiler can profit from an optimizer") (IL:FUNCTIONS OPTIMIZE-BYTE) (IL:PROP IL:DMACRO BYTE)) (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %MAKE-BYTE-MASK-1 %MAKE-BYTE-MASK-0)) (IL:FUNCTIONS LDB DPB MASK-FIELD DEPOSIT-FIELD) (IL:FUNCTIONS %CONSTANT-BYTESPEC-P) (XCL:OPTIMIZERS LDB DPB MASK-FIELD DEPOSIT-FIELD)) (IL:COMS (IL:FUNCTIONS LDB-TEST) (XCL:OPTIMIZERS LDB-TEST))) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:LOCALVARS . T)) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:CMLARITH) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA LOGEQV LOGIOR LCM GCD / * - + >= <= > < /= =)))))
+
+
+
+(IL:* IL:|;;;| "Common Lisp Arithmetic ")
+
+
+
+
+(IL:* IL:|;;| "Error utilities")
+
+
+(DEFUN %NOT-NUMBER-ERROR (OBJECT) (ERROR (QUOTE XCL:TYPE-MISMATCH) :EXPECTED-TYPE (QUOTE NUMBER) :NAME OBJECT :VALUE OBJECT))
+
+(DEFUN %NOT-NONCOMPLEX-NUMBER-ERROR (OBJECT) (IF (NOT (NUMBERP OBJECT)) (ERROR (QUOTE XCL:TYPE-MISMATCH) :EXPECTED-TYPE (QUOTE NUMBER) :NAME OBJECT :VALUE OBJECT) (ERROR "Arg a complex number~%~s" OBJECT)))
+
+(DEFUN %NOT-INTEGER-ERROR (OBJECT) (ERROR (QUOTE XCL:TYPE-MISMATCH) :EXPECTED-TYPE (QUOTE INTEGER) :NAME OBJECT :VALUE OBJECT))
+
+(DEFUN %NOT-RATIONAL-ERROR (OBJECT) (ERROR (QUOTE XCL:TYPE-MISMATCH) :EXPECTED-TYPE (QUOTE RATIONAL) :VALUE OBJECT :NAME OBJECT))
+
+(DEFUN %NOT-FLOAT-ERROR (OBJECT) (ERROR (QUOTE XCL:TYPE-MISMATCH) :EXPECTED-TYPE (QUOTE FLOAT) :NAME OBJECT :VALUE OBJECT))
+
+
+
+(IL:* IL:|;;;| "Section 2.1.2 Ratios. ")
+
+
+(DEFSTRUCT (RATIO (:CONSTRUCTOR %MAKE-RATIO (NUMERATOR DENOMINATOR)) (:PREDICATE %RATIO-P) (:COPIER NIL) (:PRINT-FUNCTION %RATIO-PRINT)) (NUMERATOR :READ-ONLY) (DENOMINATOR :READ-ONLY))
+
+
+
+(IL:* IL:|;;| "The following makes NUMBERP true on ratios")
+
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY 
+
+(IL:\\SETTYPEMASK (IL:\\TYPENUMBERFROMNAME (QUOTE RATIO)) (IL:LOGOR IL:\\TT.NUMBERP IL:\\TT.ATOM))
+)
+
+(DEFUN DENOMINATOR (RATIONAL) (IL:* IL:|;;| "Returns the denominator of a rational.  ") (TYPECASE RATIONAL (RATIO (RATIO-DENOMINATOR RATIONAL)) (INTEGER 1) (T (%NOT-RATIONAL-ERROR RATIONAL))))
+
+(DEFUN NUMERATOR (RATIONAL) (IL:* IL:|;;| "Returns the numerator of a rational.") (TYPECASE RATIONAL (RATIO (RATIO-NUMERATOR RATIONAL)) (INTEGER RATIONAL) (T (%NOT-RATIONAL-ERROR RATIONAL))))
+
+(XCL:DEFINLINE RATIONALP (NUMBER) (OR (INTEGERP NUMBER) (%RATIO-P NUMBER)))
+
+(DEFUN %RATIO-PRINT (NUMBER STREAM) (LET ((TOP (RATIO-NUMERATOR NUMBER)) (BOTTOM (RATIO-DENOMINATOR NUMBER)) PR) (COND ((NOT (IL:|fetch| (READTABLEP IL:COMMONNUMSYNTAX) IL:|of| *READTABLE*)) (IL:* IL:\; "Can't print nice ratios to old read tables") (IL:PRIN1 "|." STREAM) (IL:\\PRINDATUM (LIST (QUOTE /) TOP BOTTOM) STREAM)) (T (IL:* IL:|;;| "If *PRINT-RADIX* is true, need to print radix prefix.  Of course, want it on whole ratio and not components, so we rebind to NIL inside here.") (IF *PRINT-RADIX* (SETQ PR (CONCATENATE (QUOTE STRING) (STRING (CODE-CHAR (IL:|fetch| (READTABLEP IL:HASHMACROCHAR) IL:|of| *READTABLE*))) (CASE *PRINT-BASE* (2 (IL:* IL:\; "Binary") "b") (8 "o") (16 "x") (T (IL:* IL:\; "generalized radix prefix, even for decimal!") (CONCATENATE (QUOTE STRING) (LET* ((X *PRINT-BASE*) (*PRINT-BASE* 10) (*PRINT-RADIX* NIL)) (PRINC-TO-STRING X)) "r")))))) (IL:.SPACECHECK. STREAM (+ 1 (IL:NCHARS TOP) (IL:NCHARS BOTTOM) (IF PR (IL:NCHARS PR) 0))) (LET ((IL:\\THISFILELINELENGTH NIL) (*PRINT-RADIX* NIL)) (DECLARE (IL:SPECVARS IL:\\THISFILELINELENGTH)) (IL:* IL:\; "Turn off linelength check just in case the NCHARS count is off because of radices") (IF PR (IL:\\SOUT PR STREAM)) (IL:\\PRINDATUM TOP STREAM) (IL:\\SOUT "/" STREAM) (IL:\\PRINDATUM BOTTOM STREAM))))))
+
+(DEFUN %BUILD-RATIO (X Y) (IL:* IL:|;;| "%BUILD-RATIO takes two integer arguments and builds the rational number which is their quotient.  ") (LET ((REM (IL:IREMAINDER X Y))) (IF (EQ 0 REM) (IL:IQUOTIENT X Y) (LET ((GCD (%GCD X Y))) (WHEN (NOT (EQ GCD 1)) (SETQ X (IL:IQUOTIENT X GCD)) (SETQ Y (IL:IQUOTIENT Y GCD))) (IF (MINUSP Y) (%MAKE-RATIO (- X) (- Y)) (%MAKE-RATIO X Y))))))
+
+(DEFUN RATIONAL (NUMBER) (IL:* IL:|;;| "Rational produces a rational number for any numeric argument.  Rational assumed that the floating point is completely accurate.  ") (TYPECASE NUMBER (RATIONAL NUMBER) (FLOAT (%RATIONAL-FLOAT NUMBER)) (COMPLEX (%MAKE-COMPLEX (RATIONAL (COMPLEX-REALPART NUMBER)) (RATIONAL (COMPLEX-IMAGPART NUMBER)))) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER))))
+
+(DEFUN RATIONALIZE (NUMBER) (IL:* IL:|;;| "Rationalize does a rational, but it assumes that floats are only accurate to their precision, and generates a good rational aproximation of them.  ") (TYPECASE NUMBER (RATIONAL NUMBER) (FLOAT (%RATIONALIZE-FLOAT NUMBER)) (COMPLEX (%MAKE-COMPLEX (RATIONALIZE (COMPLEX-REALPART NUMBER)) (RATIONALIZE (COMPLEX-IMAGPART NUMBER)))) (T (%NOT-NUMBER-ERROR NUMBER))))
+
+(DEFUN %RATIO-PLUS (NUMERATOR-1 DENOMINATOR-1 NUMERATOR-2 DENOMINATOR-2) (LET ((GCD-D (%GCD DENOMINATOR-1 DENOMINATOR-2))) (IF (EQ GCD-D 1) (%MAKE-RATIO (+ (* NUMERATOR-1 DENOMINATOR-2) (* NUMERATOR-2 DENOMINATOR-1)) (* DENOMINATOR-1 DENOMINATOR-2)) (LET* ((D1/GCD-D (IL:IQUOTIENT DENOMINATOR-1 GCD-D)) (TOP (+ (* NUMERATOR-1 (IL:IQUOTIENT DENOMINATOR-2 GCD-D)) (* NUMERATOR-2 D1/GCD-D))) (GCD-TOP (%GCD TOP GCD-D)) (D2/GCD-TOP DENOMINATOR-2)) (UNLESS (EQ GCD-TOP 1) (SETQ D2/GCD-TOP (IL:IQUOTIENT DENOMINATOR-2 GCD-TOP)) (SETQ TOP (IL:IQUOTIENT TOP GCD-TOP))) (IF (AND (EQ 1 D2/GCD-TOP) (EQ 1 D1/GCD-D)) TOP (%MAKE-RATIO TOP (* D1/GCD-D D2/GCD-TOP)))))))
+
+(DEFUN %RATIO-TIMES (NUMERATOR-1 DENOMINATOR-1 NUMERATOR-2 DENOMINATOR-2) (LET ((GCD-1-2 (%GCD NUMERATOR-1 DENOMINATOR-2)) (GCD-2-1 (%GCD NUMERATOR-2 DENOMINATOR-1))) (UNLESS (EQ GCD-1-2 1) (SETQ NUMERATOR-1 (IL:IQUOTIENT NUMERATOR-1 GCD-1-2)) (SETQ DENOMINATOR-2 (IL:IQUOTIENT DENOMINATOR-2 GCD-1-2))) (UNLESS (EQ GCD-2-1 1) (SETQ NUMERATOR-2 (IL:IQUOTIENT NUMERATOR-2 GCD-2-1)) (SETQ DENOMINATOR-1 (IL:IQUOTIENT DENOMINATOR-1 GCD-2-1)))) (LET ((H (* NUMERATOR-1 NUMERATOR-2)) (K (* DENOMINATOR-1 DENOMINATOR-2))) (IF (EQ K 1) H (IF (MINUSP K) (%MAKE-RATIO (- H) (- K)) (%MAKE-RATIO H K)))))
+
+
+
+(IL:* IL:|;;;| "Section 2.1.4 Complex Numbers.")
+
+
+(DEFSTRUCT (COMPLEX (:CONSTRUCTOR %MAKE-COMPLEX (REALPART IMAGPART)) (:PREDICATE COMPLEXP) (:COPIER NIL) (:PRINT-FUNCTION %COMPLEX-PRINT)) (REALPART :READ-ONLY) (IMAGPART :READ-ONLY))
+
+
+
+(IL:* IL:|;;| "So we don't inherit the deftype from defstruct")
+
+
+(DEFTYPE COMPLEX (&OPTIONAL TYPE) (IF (EQ TYPE (QUOTE *)) (QUOTE (:DATATYPE COMPLEX)) (IL:BQUOTE (AND COMPLEX (SATISFIES (IL:LAMBDA (IL:X) (AND (TYPEP (COMPLEX-REALPART IL:X) (QUOTE (IL:\\\, TYPE))) (TYPEP (COMPLEX-IMAGPART IL:X) (QUOTE (IL:\\\, TYPE))))))))))
+
+
+
+(IL:* IL:|;;| "Make Complex  NUMBERP")
+
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY 
+
+(IL:\\SETTYPEMASK (IL:\\TYPENUMBERFROMNAME (QUOTE COMPLEX)) (IL:LOGOR IL:\\TT.NUMBERP IL:\\TT.ATOM))
+)
+
+(DEFUN COMPLEX (REALPART &OPTIONAL (IMAGPART 0)) (IL:* IL:|;;| "Builds a complex number from the specified components.  Note: IMAGPART = 0.0 or floating REALPART implies that we must build a complex not a real according to the manual while IMAGPART = 0 and rational REALPART implies that we build a real.   ") (TYPECASE REALPART (RATIONAL (TYPECASE IMAGPART (RATIONAL (IF (EQ 0 IMAGPART) REALPART (%MAKE-COMPLEX REALPART IMAGPART))) (FLOAT (%MAKE-COMPLEX (FLOAT REALPART) IMAGPART)) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR IMAGPART)))) (FLOAT (%MAKE-COMPLEX REALPART (FLOAT IMAGPART))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR REALPART))))
+
+(DEFUN REALPART (NUMBER) (TYPECASE NUMBER (COMPLEX (COMPLEX-REALPART NUMBER)) (NUMBER NUMBER) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER))))
+
+(DEFUN IMAGPART (NUMBER) (TYPECASE NUMBER (COMPLEX (COMPLEX-IMAGPART NUMBER)) (FLOAT 0.0) (NUMBER 0) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER))))
+
+(DEFUN CONJUGATE (NUMBER) (TYPECASE NUMBER (COMPLEX (%MAKE-COMPLEX (COMPLEX-REALPART NUMBER) (- (COMPLEX-IMAGPART NUMBER)))) (NUMBER NUMBER) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER))))
+
+(DEFUN PHASE (NUMBER) (COND ((= NUMBER 0) (IL:* IL:|;;| "The phase of zero is arbitrarily defined to be zero.") 0.0) ((COMPLEXP NUMBER) (ATAN (COMPLEX-IMAGPART NUMBER) (COMPLEX-REALPART NUMBER))) ((MINUSP NUMBER) PI) (T (IL:* IL:|;;| "Page 206 of the silver book: The phase of a positive non-complex number is zero. ... The result is a floating-point number.") 0.0)))
+
+(DEFUN CL:UPGRADED-COMPLEX-PART-TYPE (TYPE) (IL:* IL:\; "Edited 19-Mar-92 15:27 by jrb:") (IF (SUBTYPEP TYPE (QUOTE NUMBER)) (QUOTE NUMBER) (ERROR "Type ~s can't be part of a complex number" TYPE)))
+
+(DEFUN %COMPLEX-PRINT (NUMBER STREAM) (LET ((REALPART (COMPLEX-REALPART NUMBER)) (IMAGPART (COMPLEX-IMAGPART NUMBER))) (IL:.SPACECHECK. STREAM (+ 5 (IL:NCHARS REALPART) (IL:NCHARS IMAGPART))) (IL:\\OUTCHAR STREAM (IL:FETCH (READTABLEP IL:HASHMACROCHAR) IL:OF *READTABLE*)) (IL:\\SOUT "C" STREAM) (IL:\\SOUT "(" STREAM) (IL:\\PRINDATUM REALPART STREAM) (IL:\\SOUT " " STREAM) (IL:\\PRINDATUM IMAGPART STREAM) (IL:\\SOUT ")" STREAM)))
+
+(DEFUN %COMPLEX-+ (REAL-1 IMAG-1 REAL-2 IMAG-2) (COND ((= IMAG-1 0) (COMPLEX (+ REAL-1 REAL-2) IMAG-2)) ((= IMAG-2 0) (COMPLEX (+ REAL-1 REAL-2) IMAG-1)) (T (COMPLEX (+ REAL-1 REAL-2) (+ IMAG-1 IMAG-2)))))
+
+(DEFUN %COMPLEX-- (REAL-1 IMAG-1 REAL-2 IMAG-2) (COND ((= IMAG-1 0) (COMPLEX (- REAL-1 REAL-2) (- IMAG-2))) ((= IMAG-2 0) (COMPLEX (- REAL-1 REAL-2) IMAG-1)) (T (COMPLEX (- REAL-1 REAL-2) (- IMAG-1 IMAG-2)))))
+
+(DEFUN %COMPLEX-* (REAL-1 IMAG-1 REAL-2 IMAG-2) (COND ((= IMAG-1 0) (COMPLEX (* REAL-1 REAL-2) (* REAL-1 IMAG-2))) ((= IMAG-2 0) (COMPLEX (* REAL-1 REAL-2) (* IMAG-1 REAL-2))) (T (COMPLEX (- (* REAL-1 REAL-2) (* IMAG-1 IMAG-2)) (+ (* IMAG-1 REAL-2) (* REAL-1 IMAG-2))))))
+
+(DEFUN %COMPLEX-/ (REAL-1 IMAG-1 REAL-2 IMAG-2) (COND ((= 0 IMAG-1) (LET ((MODULUS (+ (* REAL-2 REAL-2) (* IMAG-2 IMAG-2)))) (COMPLEX (/ (* REAL-1 REAL-2) MODULUS) (/ (- (* REAL-1 IMAG-2)) MODULUS)))) ((= 0 IMAG-2) (COMPLEX (/ REAL-1 REAL-2) (/ IMAG-1 REAL-2))) (T (LET ((MODULUS (+ (* REAL-2 REAL-2) (* IMAG-2 IMAG-2)))) (COMPLEX (/ (+ (* REAL-1 REAL-2) (* IMAG-1 IMAG-2)) MODULUS) (/ (- (* IMAG-1 REAL-2) (* REAL-1 IMAG-2)) MODULUS))))))
+
+(DEFUN %COMPLEX-ABS (Z) (LET ((X (FLOAT (COMPLEX-REALPART Z))) (Y (FLOAT (COMPLEX-IMAGPART Z)))) (DECLARE (TYPE FLOAT X Y)) (IL:* IL:|;;| "Might want to use a BLUE algorithm here") (SQRT (SETQ X (+ (* X X) (* Y Y))))))
+
+
+
+(IL:* IL:|;;;| "Datatype predicates")
+
+
+
+
+(IL:* IL:|;;| "cl:integerp is defined in cmlpred (has an optimizer)")
+
+
+
+
+(IL:* IL:|;;| "cl:floatp is defined in cmltypes (has an optimizer). il:floatp is defined on llbasic"
+)
+
+
+
+
+(IL:* IL:|;;| "cl:complexp is a defstruct predicate (compiles in line)")
+
+
+
+
+(IL:* IL:|;;| 
+"cl:numberp is defined in cmltypes (has an optimizer). il:numberp is defined on llbasic")
+
+
+
+
+(IL:* IL:|;;;| "Section 12.2 Predicates on Numbers (generic).")
+
+
+
+
+(IL:* IL:|;;| 
+"cl:zerop  is not shared with il:zerop, although they are equivalent. There is no il;plusp ")
+
+
+(DEFUN ZEROP (NUMBER) (= 0 NUMBER))
+
+(DEFUN PLUSP (NUMBER) (> NUMBER 0))
+
+(XCL:DEFOPTIMIZER ZEROP (NUMBER) (IL:BQUOTE (= 0 (IL:\\\, NUMBER))))
+
+(XCL:DEFOPTIMIZER PLUSP (NUMBER) (IL:BQUOTE (> (IL:\\\, NUMBER) 0)))
+
+
+
+(IL:* IL:|;;| 
+"cl:minusp is shared with il:minusp, but must be redefined to work with ratios. Old version resides in llarith"
+)
+
+
+(DEFUN MINUSP (NUMBER) (< NUMBER 0))
+
+(XCL:DEFOPTIMIZER MINUSP (NUMBER) (IL:BQUOTE (< (IL:\\\, NUMBER) 0)))
+
+
+
+(IL:* IL:|;;| 
+"Both cl:evenp and cl:oddp are shared with il:. The functions are extended by allowing a second optional modulus argument. Another version of il:oddp exists on llarith, but the definition of il:evenp has disappeared"
+)
+
+
+(DEFUN EVENP (INTEGER &OPTIONAL MODULUS) (IF (NULL MODULUS) (EQ (LOGAND INTEGER 1) 0) (ZEROP (MOD INTEGER MODULUS))))
+
+(DEFUN ODDP (INTEGER &OPTIONAL MODULUS) (IF (NULL MODULUS) (EQ (LOGAND INTEGER 1) 1) (NOT (ZEROP (MOD INTEGER MODULUS)))))
+
+(XCL:DEFOPTIMIZER EVENP (INTEGER &OPTIONAL (MODULUS NIL MODULUS-P)) (IF (NULL MODULUS-P) (IL:BQUOTE (EQ (LOGAND (IL:\\\, INTEGER) 1) 0)) (QUOTE COMPILER:PASS)))
+
+(XCL:DEFOPTIMIZER ODDP (INTEGER &OPTIONAL (MODULUS NIL MODULUS-P)) (IF (NULL MODULUS-P) (IL:BQUOTE (EQ (LOGAND (IL:\\\, INTEGER) 1) 1)) (QUOTE COMPILER:PASS)))
+
+
+
+(IL:* IL:|;;;| "Section 12.3 Comparisons on Numbers. (generic)")
+
+
+(DEFUN %= (X Y) (IL:* IL:|;;| "%= does coercion when checking numbers for equality.  Page 196 of silver book.") (IL:* IL:|;;| "Punt function for opcode =(decimal 255) -- actually the UFN is IL:%=") (IL:\\CALLME (QUOTE =)) (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IL:IEQP X Y)) (FLOAT (IL:FEQP X Y)) (RATIO NIL) (COMPLEX (AND (= X (COMPLEX-REALPART Y)) (= 0 (COMPLEX-IMAGPART Y)))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT RATIO) (IL:FEQP X Y)) (COMPLEX (AND (= X (COMPLEX-REALPART Y)) (= 0 (COMPLEX-IMAGPART Y)))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER NIL) (RATIO (AND (EQL (RATIO-NUMERATOR X) (RATIO-NUMERATOR Y)) (EQL (RATIO-DENOMINATOR X) (RATIO-DENOMINATOR Y)))) (FLOAT (IL:FEQP X Y)) (COMPLEX (AND (= X (COMPLEX-REALPART Y)) (= 0 (COMPLEX-IMAGPART Y)))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (COMPLEX (TYPECASE Y (COMPLEX (AND (= (COMPLEX-REALPART X) (COMPLEX-REALPART Y)) (= (COMPLEX-IMAGPART X) (COMPLEX-IMAGPART Y)))) (NUMBER (AND (= Y (COMPLEX-REALPART X)) (= 0 (COMPLEX-IMAGPART X)))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NUMBER-ERROR X))))
+
+(DEFMACRO %/= (X Y) (IL:BQUOTE (NOT (%= (IL:\\\, X) (IL:\\\, Y)))))
+
+(DEFUN %> (X Y) (IL:* IL:|;;| "See page 196 of CLtl") (IL:* IL:|;;| "Compiles out to greaterp opcode") (IL:* IL:\; "So we appear as > in a frame backtrace") (IL:\\CALLME (QUOTE >)) (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IL:IGREATERP X Y)) (FLOAT (IL:FGREATERP X Y)) (RATIO (IL:IGREATERP (* (RATIO-DENOMINATOR Y) X) (RATIO-NUMERATOR Y))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT) (IL:FGREATERP X Y)) (RATIO (IL:FGREATERP (* (RATIO-DENOMINATOR Y) X) (RATIO-NUMERATOR Y))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER (IL:IGREATERP (RATIO-NUMERATOR X) (* (RATIO-DENOMINATOR X) Y))) (FLOAT (IL:FGREATERP (RATIO-NUMERATOR X) (* (RATIO-DENOMINATOR X) Y))) (RATIO (IL:IGREATERP (* (RATIO-NUMERATOR X) (RATIO-DENOMINATOR Y)) (* (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR X)))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR X))))
+
+(DEFUN %< (X Y) (%> Y X))
+
+(DEFMACRO %>= (X Y) (IL:BQUOTE (NOT (%< (IL:\\\, X) (IL:\\\, Y)))))
+
+(DEFMACRO %<= (X Y) (IL:BQUOTE (NOT (%> (IL:\\\, X) (IL:\\\, Y)))))
+
+(IL:PUTPROPS %= IL:DOPVAL (2 =))
+
+(IL:PUTPROPS %> IL:DOPVAL (2 IL:GREATERP))
+
+(IL:PUTPROPS %< IL:DOPVAL (2 IL:SWAP IL:GREATERP))
+
+
+
+(IL:* IL:\; "For the byte compiler")
+
+
+(IL:PUTPROPS %> IL:DMACRO (= . IL:GREATERP))
+
+(IL:PUTPROPS %< IL:DMACRO (= . IL:LESSP))
+
+(IL:PUTPROPS %>= IL:DMACRO (= . IL:GEQ))
+
+(IL:PUTPROPS %<= IL:DMACRO (= . IL:LEQ))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY 
+
+(IL:* IL:|;;| "Backward compatibility")
+
+(IL:* IL:\; " il:%= is listed as the punt function for the = opcode")
+
+(IL:MOVD (QUOTE %=) (QUOTE IL:%=))
+
+(IL:* IL:\; "Greaterp is the UFN for the greaterp opcode. Effectively redefines the opcode")
+
+(IL:MOVD (QUOTE %>) (QUOTE IL:GREATERP))
+
+(IL:* IL:\; "Interlisp Greaterp and Lessp are defined in llarith")
+
+(IL:MOVD (QUOTE %<) (QUOTE IL:LESSP))
+)
+
+
+
+(IL:* IL:|;;| "=, <, >, <=, and >= are shared with il:, but cl:/= is NOT shared (?!)")
+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFMACRO %COMPARISON-MACRO (PREDICATE ARGS) (IL:BQUOTE (PROGN (IF (%< (IL:\\\, ARGS) 1) (ERROR (IL:\\\, (CONCATENATE (QUOTE STRING) (SUBSEQ (STRING PREDICATE) 1) " requires at least one argument")))) (LET ((LAST-ARG (IL:ARG (IL:\\\, ARGS) 1)) (I 2) CURRENT-ARG) (IF (OR (NOT (NUMBERP LAST-ARG)) (COMPLEXP LAST-ARG)) (%NOT-NUMBER-ERROR LAST-ARG)) (LOOP (IF (%> I (IL:\\\, ARGS)) (RETURN T)) (SETQ CURRENT-ARG (IL:ARG (IL:\\\, ARGS) I)) (IF (NOT ((IL:\\\, PREDICATE) LAST-ARG CURRENT-ARG)) (RETURN NIL)) (SETQ LAST-ARG CURRENT-ARG) (SETQ I (1+ I)))))))
+)
+(IL:DEFINEQ
+
+(=
+  (il:lambda args                                       (il:* il:\; "Edited  8-Apr-87 14:40 by jop")
+    (if (%< args 1)
+        (error "= requires at least one argument"))
+    (let ((first-arg (il:arg args 1))
+          (i 2))
+         (if (not (numberp first-arg))
+             (%not-number-error first-arg))
+         (loop (if (%> i args)
+                   (return t))
+               (if (%/= first-arg (il:arg args i))
+                   (return nil))
+               (setq i (1+ i))))))
+
+(/=
+  (il:lambda args                                       (il:* il:\; "Edited  8-Feb-87 14:01 by jop")
+    (if (%< args 1)
+        (error "/= requires at least one argument"))
+    (let ((i 1)
+          current-arg j)
+         (loop (if (%> i args)
+                   (return t))
+               (setq current-arg (il:arg args i))
+               (setq j (1+ i))
+               (if (null (loop (if (%> j args)
+                                   (return t))
+                               (if (%= current-arg (il:arg args j))
+                                   (return nil))
+                               (setq j (1+ j))))
+                   (return nil))
+               (setq i (1+ i))))))
+
+(<
+  (il:lambda args                                       (il:* il:\; "Edited  8-Feb-87 14:17 by jop")
+    (%comparison-macro %< args)))
+
+(>
+  (il:lambda args                                       (il:* il:\; "Edited  8-Feb-87 14:17 by jop")
+    (%comparison-macro %> args)))
+
+(<=
+  (il:lambda args                                       (il:* il:\; "Edited  8-Feb-87 14:16 by jop")
+    (%comparison-macro %<= args)))
+
+(>=
+  (il:lambda args                                       (il:* il:\; "Edited  8-Feb-87 14:18 by jop")
+    (%comparison-macro %>= args)))
+)
+
+(DEFUN %COMPARISON-OPTIMIZER (PREDICATE FIRST-NUMBER SECOND-NUMBER THIRD-NUMBER) (COND ((NULL SECOND-NUMBER) (QUOTE COMPILER:PASS)) ((NULL THIRD-NUMBER) (IL:BQUOTE ((IL:\\\, PREDICATE) (IL:\\\, FIRST-NUMBER) (IL:\\\, SECOND-NUMBER)))) (T (IL:BQUOTE ((IL:OPENLAMBDA (SI::%$$COMPARISON-FIRST-NUMBER SI::%$$COMPARISON-MIDDLE-NUMBER) (AND ((IL:\\\, PREDICATE) SI::%$$COMPARISON-FIRST-NUMBER SI::%$$COMPARISON-MIDDLE-NUMBER) ((IL:\\\, PREDICATE) SI::%$$COMPARISON-MIDDLE-NUMBER (IL:\\\, THIRD-NUMBER)))) (IL:\\\, FIRST-NUMBER) (IL:\\\, SECOND-NUMBER))))))
+
+(XCL:DEFOPTIMIZER = (FIRST-NUMBER &OPTIONAL (SECOND-NUMBER NIL SECOND-NUMBER-P) &REST MORE-NUMBERS) (COND ((NULL SECOND-NUMBER-P) (QUOTE COMPILER:PASS)) ((NULL MORE-NUMBERS) (IL:BQUOTE (%= (IL:\\\, FIRST-NUMBER) (IL:\\\, SECOND-NUMBER)))) (T (SETQ MORE-NUMBERS (CONS SECOND-NUMBER MORE-NUMBERS)) (IL:BQUOTE ((IL:OPENLAMBDA (SI::%$$=FIRST-NUMBER) (AND (IL:\\\,@ (LET ((RESULT NIL) (RESULT-TAIL NIL)) (DOLIST (NUMBER MORE-NUMBERS RESULT) (%LIST-COLLECT RESULT RESULT-TAIL (LIST (IL:BQUOTE (%= SI::%$$=FIRST-NUMBER (IL:\\\, NUMBER)))))))))) (IL:\\\, FIRST-NUMBER))))))
+
+(XCL:DEFOPTIMIZER /= (FIRST-NUMBER &OPTIONAL (SECOND-NUMBER NIL SECOND-NUMBER-P) &REST MORE-NUMBERS) (COND ((NULL SECOND-NUMBER-P) (QUOTE COMPILER:PASS)) ((NULL MORE-NUMBERS) (IL:BQUOTE (%/= (IL:\\\, FIRST-NUMBER) (IL:\\\, SECOND-NUMBER)))) (T (QUOTE COMPILER:PASS))))
+
+(XCL:DEFOPTIMIZER < (FIRST-NUMBER &OPTIONAL SECOND-NUMBER THIRD-NUMBER &REST MORE-NUMBERS) (IF (NULL MORE-NUMBERS) (%COMPARISON-OPTIMIZER (QUOTE %<) FIRST-NUMBER SECOND-NUMBER THIRD-NUMBER) (QUOTE COMPILER:PASS)))
+
+(XCL:DEFOPTIMIZER > (FIRST-NUMBER &OPTIONAL SECOND-NUMBER THIRD-NUMBER &REST MORE-NUMBERS) (IF (NULL MORE-NUMBERS) (%COMPARISON-OPTIMIZER (QUOTE %>) FIRST-NUMBER SECOND-NUMBER THIRD-NUMBER) (QUOTE COMPILER:PASS)))
+
+(XCL:DEFOPTIMIZER <= (FIRST-NUMBER &OPTIONAL SECOND-NUMBER THIRD-NUMBER &REST MORE-NUMBERS) (IF (NULL MORE-NUMBERS) (%COMPARISON-OPTIMIZER (QUOTE %<=) FIRST-NUMBER SECOND-NUMBER THIRD-NUMBER) (QUOTE COMPILER:PASS)))
+
+(XCL:DEFOPTIMIZER >= (FIRST-NUMBER &OPTIONAL SECOND-NUMBER THIRD-NUMBER &REST MORE-NUMBERS) (IF (NULL MORE-NUMBERS) (%COMPARISON-OPTIMIZER (QUOTE %>=) FIRST-NUMBER SECOND-NUMBER THIRD-NUMBER) (QUOTE COMPILER:PASS)))
+
+
+
+(IL:* IL:|;;| 
+"Note: the related predicates EQL, EQUAL, and EQUALP should be consulted if any of the above change. EQL is on LLNEW (?), EQUAL and EQUALP on CMLTYPES."
+)
+
+
+
+
+(IL:* IL:|;;| 
+"cl:min and cl:max are shared with il: (defined in llarith). They  are written in terms of GREATERP and hence work on ratios. Note (min) returns #.max.integer , which is an extension on the CLtl spec. We only optimize the case of two args"
+)
+
+
+(XCL:DEFOPTIMIZER MIN (&OPTIONAL (X NIL X-P) (Y NIL Y-P) &REST OTHER-NUMBERS) (IF (AND (NULL OTHER-NUMBERS) X-P Y-P) (IL:BQUOTE ((IL:OPENLAMBDA (SI::%$$MIN-X SI::%$$MIN-Y) (IF (< SI::%$$MIN-X SI::%$$MIN-Y) SI::%$$MIN-X SI::%$$MIN-Y)) (IL:\\\, X) (IL:\\\, Y))) (QUOTE COMPILER:PASS)))
+
+(XCL:DEFOPTIMIZER MAX (&OPTIONAL (X NIL X-P) (Y NIL Y-P) &REST OTHER-NUMBERS) (IF (AND (NULL OTHER-NUMBERS) X-P Y-P) (IL:BQUOTE ((IL:OPENLAMBDA (SI::%$$MAX-X SI::%$$MAX-Y) (IF (> SI::%$$MAX-X SI::%$$MAX-Y) SI::%$$MAX-X SI::%$$MAX-Y)) (IL:\\\, X) (IL:\\\, Y))) (QUOTE COMPILER:PASS)))
+
+
+
+(IL:* IL:|;;;| "Section 12.4 Arithmetic Operations (generic). ")
+
+
+(DEFUN %+ (X Y) (IL:\\CALLME (QUOTE +)) (IL:* IL:|;;| "Simple case for the sum of two numbers. Is the ufn for the plus2 opcode") (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IL:IPLUS X Y)) (FLOAT (IL:FPLUS X Y)) (RATIO (%RATIO-PLUS X 1 (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-+ X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT) (IL:FPLUS X Y)) (RATIO (IL:FPLUS X (IL:FQUOTIENT (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y)))) (COMPLEX (%COMPLEX-+ X 0.0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER (%RATIO-PLUS (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) Y 1)) (FLOAT (IL:FPLUS (IL:FQUOTIENT (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X)) Y)) (RATIO (%RATIO-PLUS (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-+ X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (COMPLEX (TYPECASE Y ((OR INTEGER RATIO) (%COMPLEX-+ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0)) (FLOAT (%COMPLEX-+ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0.0)) (COMPLEX (%COMPLEX-+ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NUMBER-ERROR X))))
+
+(DEFUN %- (X Y) (IL:* IL:|;;| "UFN for opcode difference.  ") (IL:\\CALLME (QUOTE -)) (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IL:IDIFFERENCE X Y)) (FLOAT (IL:FDIFFERENCE X Y)) (RATIO (%RATIO-PLUS X 1 (- (RATIO-NUMERATOR Y)) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-- X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT) (IL:FDIFFERENCE X Y)) (RATIO (IL:FDIFFERENCE X (IL:FQUOTIENT (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y)))) (COMPLEX (%COMPLEX-- X 0.0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER (%RATIO-PLUS (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) (- Y) 1)) (FLOAT (IL:FDIFFERENCE (IL:FQUOTIENT (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X)) Y)) (RATIO (%RATIO-PLUS (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) (- (RATIO-NUMERATOR Y)) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-- X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (COMPLEX (TYPECASE Y ((OR INTEGER RATIO) (%COMPLEX-- (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0)) (FLOAT (%COMPLEX-- (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0.0)) (COMPLEX (%COMPLEX-- (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NUMBER-ERROR X))))
+
+(DEFUN %* (X Y) (IL:* IL:|;;| "UFN for opcode times2. ") (IL:\\CALLME (QUOTE *)) (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IL:ITIMES X Y)) (FLOAT (IL:FTIMES X Y)) (RATIO (%RATIO-TIMES X 1 (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-* X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT) (IL:FTIMES X Y)) (RATIO (IL:FTIMES X (IL:FQUOTIENT (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y)))) (COMPLEX (%COMPLEX-* X 0.0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER (%RATIO-TIMES (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) Y 1)) (FLOAT (IL:FTIMES (IL:FQUOTIENT (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X)) Y)) (RATIO (%RATIO-TIMES (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-* X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (COMPLEX (TYPECASE Y ((OR INTEGER RATIO) (%COMPLEX-* (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0)) (FLOAT (%COMPLEX-* (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0.0)) (COMPLEX (%COMPLEX-* (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NUMBER-ERROR X))))
+
+(DEFUN %/ (X Y) (IL:* IL:|;;| "The quotient of two numbers. Has no corresponding opcode.") (IL:\\CALLME (QUOTE /)) (IF (AND (IL:SMALLP X) (IL:SMALLP Y) (EQ 0 (IL:IREMAINDER X Y))) (IL:* IL:|;;| "See if we can do the straight-forward thing") (IL:IQUOTIENT X Y) (IL:* IL:|;;| "More exotic cases") (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IF (OR (EQ X IL:MIN.INTEGER) (EQ X IL:MAX.INTEGER) (EQ Y IL:MIN.INTEGER) (EQ Y IL:MAX.INTEGER)) (IL:IQUOTIENT X Y) (%BUILD-RATIO X Y))) (FLOAT (IL:FQUOTIENT X Y)) (RATIO (%RATIO-TIMES X 1 (RATIO-DENOMINATOR Y) (RATIO-NUMERATOR Y))) (COMPLEX (%COMPLEX-/ X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT) (IL:FQUOTIENT X Y)) (RATIO (IL:FQUOTIENT (* (RATIO-DENOMINATOR Y) X) (RATIO-NUMERATOR Y))) (COMPLEX (%COMPLEX-/ X 0.0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER (%RATIO-TIMES (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) 1 Y)) (FLOAT (IL:FQUOTIENT (RATIO-NUMERATOR X) (* (RATIO-DENOMINATOR X) Y))) (RATIO (%RATIO-TIMES (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) (RATIO-DENOMINATOR Y) (RATIO-NUMERATOR Y))) (COMPLEX (%COMPLEX-/ X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (COMPLEX (TYPECASE Y ((OR INTEGER RATIO) (%COMPLEX-/ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0)) (FLOAT (%COMPLEX-/ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0.0)) (COMPLEX (%COMPLEX-/ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NUMBER-ERROR X)))))
+
+
+
+(IL:* IL:\; 
+"NOTE: %/ cannot compile out to the existinq quotient opcode because it produces ratios rather than truncating"
+)
+
+
+(IL:PUTPROPS %+ IL:DOPVAL (2 IL:PLUS2))
+
+(IL:PUTPROPS %- IL:DOPVAL (2 IL:DIFFERENCE))
+
+(IL:PUTPROPS %* IL:DOPVAL (2 IL:TIMES2))
+
+
+
+(IL:* IL:\; "For the byte compiler")
+
+
+(IL:PUTPROPS %+ IL:DMACRO (= . IL:PLUS))
+
+(IL:PUTPROPS %- IL:DMACRO (= . IL:DIFFERENCE))
+
+(IL:PUTPROPS %* IL:DMACRO (= . IL:TIMES))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY 
+
+(IL:* IL:|;;| "Backward compatibility")
+
+(IL:MOVD (QUOTE %/) (QUOTE IL:%/))
+
+(IL:* IL:|;;| "Redefine UFNs for generic plus, difference, and times. Old UFN defined in llarith.")
+
+(IL:MOVD (QUOTE %+) (QUOTE IL:\\SLOWPLUS2))
+
+(IL:MOVD (QUOTE %-) (QUOTE IL:\\SLOWDIFFERENCE))
+
+(IL:MOVD (QUOTE %*) (QUOTE IL:\\SLOWTIMES2))
+)
+(IL:DEFINEQ
+
+(+
+  (il:lambda args                                       (il:* il:\; "Edited  8-Apr-87 14:41 by jop")
+    (if (eq args 0)
+        0
+        (let ((accumulator (il:arg args 1))
+              (i 2))
+             (if (not (numberp accumulator))
+                 (%not-number-error accumulator))
+             (loop (if (%> i args)
+                       (return accumulator))
+                   (setq accumulator (%+ accumulator (il:arg args i)))
+                   (setq i (1+ i)))))))
+
+(-
+  (il:lambda args                                       (il:* il:\; "Edited  9-Feb-87 20:57 by jop")
+    (cond
+       ((eq args 0)
+        (error "- requires at least one argument"))
+       ((eq args 1)
+          
+          (il:* il:|;;| "Negate the argument")
+
+        (- 0 (il:arg args 1)))
+       (t (let ((accumulator (il:arg args 1))
+                (i 2))
+               (loop (if (%> i args)
+                         (return accumulator))
+                     (setq accumulator (%- accumulator (il:arg args i)))
+                     (setq i (1+ i))))))))
+
+(*
+  (il:lambda args                                       (il:* il:\; "Edited  8-Apr-87 14:41 by jop")
+    (if (eq args 0)
+        1
+        (let ((accumulator (il:arg args 1))
+              (i 2))
+             (if (not (numberp accumulator))
+                 (%not-number-error accumulator))
+             (loop (if (%> i args)
+                       (return accumulator))
+                   (setq accumulator (%* accumulator (il:arg args i)))
+                   (setq i (1+ i)))))))
+
+(/
+  (il:lambda args                                       (il:* il:\; "Edited  8-Feb-87 19:15 by jop")
+    (cond
+       ((eq args 0)
+        (error "/ requires at least one argument"))
+       ((eq args 1)
+        (%reciprocol (il:arg args 1)))
+       (t (let ((accumulator (il:arg args 1))
+                (i 2))
+               (loop (if (%> i args)
+                         (return accumulator))
+                     (setq accumulator (%/ accumulator (il:arg args i)))
+                     (setq i (1+ i))))))))
+)
+
+(DEFUN 1+ (NUMBER) (+ NUMBER 1))
+
+(DEFUN 1- (NUMBER) (- NUMBER 1))
+
+(DEFUN %RECIPROCOL (NUMBER) (IF (FLOATP NUMBER) (IL:FQUOTIENT 1.0 NUMBER) (/ 1 NUMBER)))
+
+(XCL:DEFOPTIMIZER + (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM (IL:BQUOTE (%+ (IL:\\\, FORM) (IL:\\\, NUM))))))))
+
+(XCL:DEFOPTIMIZER - (NUMBER &REST NUMBERS) (IF (NULL NUMBERS) (IL:BQUOTE (%- 0 (IL:\\\, NUMBER))) (LET ((FORM NUMBER)) (DOLIST (NUM NUMBERS FORM) (SETQ FORM (IL:BQUOTE (%- (IL:\\\, FORM) (IL:\\\, NUM))))))))
+
+(XCL:DEFOPTIMIZER * (&REST NUMBERS) (IF (NULL NUMBERS) 1 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM (IL:BQUOTE (%* (IL:\\\, FORM) (IL:\\\, NUM))))))))
+
+(XCL:DEFOPTIMIZER / (NUMBER &REST NUMBERS) (IF (NULL NUMBERS) (IL:BQUOTE (%RECIPROCOL (IL:\\\, NUMBER))) (LET ((FORM NUMBER)) (DOLIST (NUM NUMBERS FORM) (SETQ FORM (IL:BQUOTE (%/ (IL:\\\, FORM) (IL:\\\, NUM))))))))
+
+(XCL:DEFOPTIMIZER 1+ (NUMBER) (IL:BQUOTE (+ (IL:\\\, NUMBER) 1)))
+
+(XCL:DEFOPTIMIZER 1- (NUMBER) (IL:BQUOTE (- (IL:\\\, NUMBER) 1)))
+
+
+
+(IL:* IL:\; "For the byte compiler")
+
+
+(IL:PUTPROPS + IL:DMACRO (IL:ARGS (IL:|if| (IL:GREATERP (IL:LENGTH IL:ARGS) 1) IL:|then| (IL:BQUOTE (IL:PLUS (IL:\\\,@ IL:ARGS))) IL:|else| (QUOTE IL:IGNOREMACRO))))
+
+(IL:PUTPROPS * IL:DMACRO (IL:ARGS (IL:|if| (IL:GREATERP (IL:LENGTH IL:ARGS) 1) IL:|then| (IL:BQUOTE (IL:TIMES (IL:\\\,@ IL:ARGS))) IL:|else| (QUOTE IL:IGNOREMACRO))))
+
+
+
+(IL:* IL:|;;| "Redefine Interlisp generic arithmetic to work with ratios")
+
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY 
+
+(IL:MOVD (QUOTE +) (QUOTE IL:PLUS))
+
+(IL:* IL:|;;| "Don't need to redefine difference since it is defined in terms of the difference opcode (redefined above)")
+
+(IL:MOVD (QUOTE *) (QUOTE IL:TIMES))
+
+(IL:* IL:|;;| "So Interlisp quotient will do something reasonable with ratios")
+
+(IL:* (IL:MOVD (QUOTE IL:NEW-QUOTIENT) (QUOTE IL:QUOTIENT)))
+
+(IL:* IL:|;;| "because QUOTIENT is already defined in LLARITH to do something useful with ratios. AR 8062.")
+)
+
+
+
+(IL:* IL:|;;| "INCF and DECF implemented by CMLSETF.")
+
+
+(DEFUN %GCD (X Y) (IL:* IL:|;;| "%GCD -- Gcd of two integers, no type checking. ") (SETQ X (%ABS X)) (SETQ Y (%ABS Y)) (COND ((EQ X 0) Y) ((EQ Y 0) X) ((OR (EQL 1 Y) (EQL 1 X)) 1) (T (LET ((K (IL:* IL:\; "Factor out powers of two") (DO ((K 0 (1+ K))) ((OR (ODDP X) (ODDP Y)) K) (SETQ X (ASH X -1)) (SETQ Y (ASH Y -1))))) (DO ((J (IF (ODDP X) (- Y) (ASH X -1)) (- X Y))) ((EQ J 0)) (LOOP (IF (ODDP J) (RETURN NIL)) (SETQ J (ASH J -1))) (IF (PLUSP J) (SETQ X J) (SETQ Y (- J)))) (ASH X K)))))
+
+(DEFUN %LCM (X Y) (COND ((EQ X 1) Y) ((EQ Y 1) X) ((OR (EQ X 0) (EQ Y 0)) 0) (T (SETQ X (%ABS X)) (SETQ Y (%ABS Y)) (LET ((GCD (%GCD X Y))) (IF (EQ GCD 1) (* X Y) (* (IL:IQUOTIENT X GCD) Y))))))
+(IL:DEFINEQ
+
+(gcd
+  (il:lambda args                                       (il:* il:\; "Edited 10-Feb-87 11:14 by jop")
+          
+          (il:* il:|;;| "GCD -- gcd of an arbitrary number of integers.  Since the probability is >.6 that the GCD of two numbers is 1, it is worth to time to check for GCD = 1 and quit if so.  ")
+
+    (cond
+       ((eq args 0)
+        0)
+       ((eq args 1)
+        (%abs (il:arg args 1)))
+       (t (let ((result (%gcd (il:arg args 1)
+                              (il:arg args 2)))
+                (i 3))
+               (loop (if (or (> i args)
+                             (eq result 1))
+                         (return result))
+                     (setq result (%gcd result (il:arg args i)))
+                     (setq i (1+ i))))))))
+
+(LCM
+(IL:LAMBDA ARGS (IL:* IL:\; "Edited 25-Feb-87 12:20 by jop") (IL:* IL:|;;| "LCM -- least common multiple.  At least one argument is required.    ") (COND ((EQ ARGS 0) 1) ((EQ ARGS 1) (%ABS (IL:ARG ARGS 1))) (T (LET ((RESULT (%LCM (IL:ARG ARGS 1) (IL:ARG ARGS 2))) (I 3)) (LOOP (IF (OR (> I ARGS) (EQ RESULT 0)) (RETURN RESULT)) (SETQ RESULT (%LCM RESULT (IL:ARG ARGS I))) (SETQ I (1+ I)))))))
+)
+)
+
+
+
+(IL:* IL:|;;| "Optimizers for Interlisp functions, so that they compile open with the PavCompiler.")
+
+
+
+
+(IL:* IL:|;;| "optimizer of IL:minus")
+
+
+(XCL:DEFOPTIMIZER IL:MINUS (IL:X) (IL:BQUOTE (- 0 (IL:\\\, IL:X))))
+
+(XCL:DEFOPTIMIZER IL:PLUS (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM (IL:BQUOTE (IL:PLUS2 (IL:\\\, FORM) (IL:\\\, NUM))))))))
+
+(XCL:DEFOPTIMIZER IL:IPLUS (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (COND ((CDR NUMBERS) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM (IL:BQUOTE (IL:IPLUS2 (IL:\\\, FORM) (IL:\\\, NUM)))))) (T (IL:BQUOTE (IL:IPLUS2 (IL:\\\, FORM) 0)))))))
+
+(XCL:DEFOPTIMIZER IL:FPLUS (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM (IL:BQUOTE (IL:FPLUS2 (IL:\\\, FORM) (IL:\\\, NUM))))))))
+
+(XCL:DEFOPTIMIZER IL:TIMES (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM (IL:BQUOTE (IL:TIMES2 (IL:\\\, FORM) (IL:\\\, NUM))))))))
+
+(XCL:DEFOPTIMIZER IL:ITIMES (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM (IL:BQUOTE (IL:ITIMES2 (IL:\\\, FORM) (IL:\\\, NUM))))))))
+
+(XCL:DEFOPTIMIZER IL:FTIMES (&REST NUMBERS) (IF (NULL NUMBERS) 1.0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM (IL:BQUOTE (IL:FTIMES2 (IL:\\\, FORM) (IL:\\\, NUM))))))))
+
+(XCL:DEFOPTIMIZER IL:RSH (IL:VALUE IL:SHIFT-AMOUNT) (IL:BQUOTE (IL:LSH (IL:\\\, IL:VALUE) (IL:IMINUS (IL:\\\, IL:SHIFT-AMOUNT)))))
+
+(IL:PUTPROPS IL:PLUS2 IL:DOPVAL (2 IL:PLUS2))
+
+(IL:PUTPROPS IL:IPLUS2 IL:DOPVAL (2 IL:IPLUS2))
+
+(IL:PUTPROPS IL:FPLUS2 IL:DOPVAL (2 IL:FPLUS2))
+
+(IL:PUTPROPS IL:TIMES2 IL:DOPVAL (2 IL:TIMES2))
+
+(IL:PUTPROPS IL:ITIMES2 IL:DOPVAL (2 IL:ITIMES2))
+
+(IL:PUTPROPS IL:FTIMES2 IL:DOPVAL (2 IL:FTIMES2))
+
+
+
+(IL:* IL:|;;;| 
+"Section 12.5 Irrational and Transcendental functions. Most of these will be found on cmlfloat.")
+
+
+(DEFUN ISQRT (INTEGER) (IL:* IL:|;;| "ISQRT: Integer square root --- isqrt (n) **2 <= n.  Upper and lower bounds on the result are estimated using integer-length.  On each iteration, one of the bounds is replaced by their mean.  The lower bound is returned when the bounds meet or differ by only 1. Initial bounds guarantee that lg (sqrt (n)) = lg (n) /2 iterations suffice.") (IF (NOT (AND (INTEGERP INTEGER) (>= INTEGER 0))) (ERROR (QUOTE XCL:TYPE-MISMATCH) :EXPECTED-TYPE (QUOTE (INTEGER 0)) :NAME INTEGER :VALUE INTEGER :MESSAGE "a nonnegative integer")) (LET* ((ILENGTH (INTEGER-LENGTH INTEGER)) (LOW (ASH 1 (ASH (1- ILENGTH) -1))) (HIGH (+ LOW (ASH LOW (IF (ODDP ILENGTH) -1 0))))) (DO ((MID (ASH (+ LOW HIGH) -1) (ASH (+ LOW HIGH) -1))) ((<= (1- HIGH) LOW) LOW) (IF (<= (* MID MID) INTEGER) (SETQ LOW MID) (SETQ HIGH MID)))))
+
+
+
+(IL:* IL:|;;| "Abs is shared with il: abs ia also defined in llarith.")
+
+
+(DEFUN ABS (NUMBER) (TYPECASE NUMBER (INTEGER (IF (< NUMBER 0) (- 0 NUMBER) NUMBER)) (FLOAT (IF (< NUMBER 0.0) (- 0.0 NUMBER) NUMBER)) (RATIO (IF (< (RATIO-NUMERATOR NUMBER) 0) (%MAKE-RATIO (- 0 (RATIO-NUMERATOR NUMBER)) (RATIO-DENOMINATOR NUMBER)) NUMBER)) (COMPLEX (%COMPLEX-ABS NUMBER)) (T (%NOT-NUMBER-ERROR NUMBER))))
+
+(DEFMACRO %ABS (INTEGER) (IL:* IL:|;;| "Integer version of abs") (IL:BQUOTE ((IL:OPENLAMBDA (X) (IF (< X 0) (- 0 X) X)) (IL:\\\, INTEGER))))
+
+(DEFUN SIGNUM (NUMBER) (IL:* IL:|;;| "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER)).") (IF (ZEROP NUMBER) NUMBER (TYPECASE NUMBER (RATIONAL (IF (PLUSP NUMBER) 1 -1)) (FLOAT (IF (PLUSP NUMBER) 1.0 -1.0)) (COMPLEX (/ NUMBER (ABS NUMBER))) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER)))))
+
+(DEFMACRO %SIGNUM (INTEGER) (IL:* IL:|;;| "Integer version of signum") (IL:BQUOTE ((IL:OPENLAMBDA (X) (COND ((EQ X 0) 0) ((PLUSP X) 1) (T -1))) (IL:\\\, INTEGER))))
+
+
+
+(IL:* IL:|;;;| "Section 12.6 Type Conversions and Component Extractions on Numbers.")
+
+
+
+
+(IL:* IL:|;;| "Float implemented in cmlfloat  ")
+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(IL:FILESLOAD IL:UNBOXEDOPS)
+)
+
+
+
+(IL:* IL:\; "These should be exported from xcl")
+
+
+(DEFUN XCL::STRUNCATE (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward 0.0 ") (IF (NULL DIVISOR) (TYPECASE NUMBER (FLOAT (IL:* IL:|;;| "Could be (IL:FIX NUMBER), but this is slightly faster") (IL:\\FIXP.FROM.FLOATP NUMBER)) (RATIO (IL:IQUOTIENT (RATIO-NUMERATOR NUMBER) (RATIO-DENOMINATOR NUMBER))) (INTEGER NUMBER) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR NUMBER))) (TYPECASE DIVISOR (INTEGER (IL:IQUOTIENT NUMBER DIVISOR)) (FLOAT (LET ((FX (FLOAT NUMBER)) (FY (FLOAT DIVISOR))) (DECLARE (TYPE FLOAT FX FY)) (IL:UFIX (IL:FQUOTIENT FX FY)))) (RATIO (XCL::STRUNCATE (/ NUMBER DIVISOR))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR DIVISOR)))))
+
+(DEFUN XCL::SFLOOR (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns the greatest integer not greater than number, or number/divisor. ") (IF (NULL DIVISOR) (LET ((RESULT (XCL::STRUNCATE NUMBER))) (COND ((= RESULT NUMBER) RESULT) ((< NUMBER 0) (1- RESULT)) (T RESULT))) (LET ((RESULT (XCL::STRUNCATE NUMBER DIVISOR))) (IF (= (REM NUMBER DIVISOR) 0) RESULT (IF (< NUMBER 0) (IF (< DIVISOR 0) RESULT (1- RESULT)) (IF (< DIVISOR 0) (1- RESULT) RESULT))))))
+
+(DEFUN XCL::SCEILING (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns the least integer not less than number, or number/divisor. ") (IF (NULL DIVISOR) (LET ((RESULT (XCL::STRUNCATE NUMBER))) (COND ((= RESULT NUMBER) RESULT) ((< NUMBER 0) RESULT) (T (1+ RESULT)))) (LET ((RESULT (XCL::STRUNCATE NUMBER DIVISOR))) (IF (= (REM NUMBER DIVISOR) 0) RESULT (IF (< NUMBER 0) (IF (< DIVISOR 0) (1+ RESULT) RESULT) (IF (< DIVISOR 0) RESULT (1+ RESULT)))))))
+
+(DEFUN XCL::SROUND (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward 0.0 ") (IF (NULL DIVISOR) (IL:FIXR NUMBER) (IF (OR (FLOATP NUMBER) (FLOATP DIVISOR)) (IL:FIXR (IL:FQUOTIENT NUMBER DIVISOR)) (IL:FIXR (/ NUMBER DIVISOR)))))
+
+(XCL:DEFOPTIMIZER XCL::STRUNCATE (NUMBER &OPTIONAL DIVISOR) (IF (INTEGERP DIVISOR) (IL:BQUOTE (IL:IQUOTIENT (IL:\\\, NUMBER) (IL:\\\, DIVISOR))) (QUOTE COMPILER:PASS)))
+
+(XCL:DEFOPTIMIZER XCL::SROUND (NUMBER &OPTIONAL (DIVISOR NIL DIVISOR-P)) (IF (NULL DIVISOR-P) (IL:BQUOTE (IL:FIXR (IL:\\\, NUMBER))) (QUOTE COMPILER:PASS)))
+
+
+
+(IL:* IL:\; "Round is shared with il: (?!)")
+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFMACRO %INTEGER-COERCE-MACRO (SINGLE-VALUE-FN NUMBER DIVISOR &OPTIONAL FLOAT-RESULT) (IL:BQUOTE (LET* ((RESULT (IF (NULL (IL:\\\, DIVISOR)) ((IL:\\\, SINGLE-VALUE-FN) (IL:\\\, NUMBER)) ((IL:\\\, SINGLE-VALUE-FN) (IL:\\\, NUMBER) (IL:\\\, DIVISOR)))) (REMAINDER (IF (NULL (IL:\\\, DIVISOR)) (- (IL:\\\, NUMBER) RESULT) (- (IL:\\\, NUMBER) (* (IL:\\\, DIVISOR) RESULT))))) (VALUES (IL:\\\, (IF FLOAT-RESULT (QUOTE (FLOAT RESULT)) (QUOTE RESULT))) REMAINDER))))
+)
+
+(DEFUN TRUNCATE (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward 0.0 The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::STRUNCATE NUMBER DIVISOR))
+
+(DEFUN FLOOR (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward - infinity. The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::SFLOOR NUMBER DIVISOR))
+
+(DEFUN CEILING (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward + infinity. The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::SCEILING NUMBER DIVISOR))
+
+(DEFUN ROUND (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward nearest integer. The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::SROUND NUMBER DIVISOR))
+
+(DEFUN %INTEGER-COERCE-OPTIMIZER (SINGLE-VALUE-FN NUMBER DIVISOR CONTEXT &OPTIONAL FLOAT-RESULT) (IF (EQ 1 (COMPILER:CONTEXT-VALUES-USED CONTEXT)) (LET ((FORM (IL:BQUOTE ((IL:\\\, SINGLE-VALUE-FN) (IL:\\\, NUMBER) (IL:\\\,@ (IF DIVISOR (LIST DIVISOR))))))) (IF FLOAT-RESULT (IL:BQUOTE (FLOAT (IL:\\\, FORM))) FORM)) (QUOTE COMPILER:PASS)))
+
+(XCL:DEFOPTIMIZER TRUNCATE (NUMBER &OPTIONAL DIVISOR CL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER (QUOTE XCL::STRUNCATE) NUMBER DIVISOR CONTEXT))
+
+(XCL:DEFOPTIMIZER FLOOR (NUMBER &OPTIONAL DIVISOR CL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER (QUOTE XCL::SFLOOR) NUMBER DIVISOR CONTEXT))
+
+(XCL:DEFOPTIMIZER CEILING (NUMBER &OPTIONAL DIVISOR CL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER (QUOTE XCL::SCEILING) NUMBER DIVISOR CONTEXT))
+
+(XCL:DEFOPTIMIZER ROUND (NUMBER &OPTIONAL DIVISOR CL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER (QUOTE XCL::SROUND) NUMBER DIVISOR CONTEXT))
+
+(DEFUN FTRUNCATE (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward 0.0 The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::STRUNCATE NUMBER DIVISOR T))
+
+(DEFUN FFLOOR (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Like floor, but returns the first result as a float ") (%INTEGER-COERCE-MACRO XCL::SFLOOR NUMBER DIVISOR T))
+
+(DEFUN FCEILING (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward + infinity. The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::SCEILING NUMBER DIVISOR T))
+
+(DEFUN FROUND (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward nearest integer. The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::SROUND NUMBER DIVISOR T))
+
+(XCL:DEFOPTIMIZER FTRUNCATE (NUMBER &OPTIONAL DIVISOR CL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER (QUOTE XCL::STRUNCATE) NUMBER DIVISOR CONTEXT T))
+
+(XCL:DEFOPTIMIZER FFLOOR (NUMBER &OPTIONAL DIVISOR CL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER (QUOTE XCL::SFLOOR) NUMBER DIVISOR CONTEXT T))
+
+(XCL:DEFOPTIMIZER FCEILING (NUMBER &OPTIONAL DIVISOR CL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER (QUOTE XCL::SCEILING) NUMBER DIVISOR CONTEXT T))
+
+(XCL:DEFOPTIMIZER FROUND (NUMBER &OPTIONAL DIVISOR CL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER (QUOTE XCL::SROUND) NUMBER DIVISOR CONTEXT T))
+
+(DEFUN MOD (NUMBER DIVISOR) (IL:* IL:|;;| "Returns second result of FLOOR.") (IF (OR (FLOATP NUMBER) (FLOATP DIVISOR)) (LET ((FX (FLOAT NUMBER)) (FY (FLOAT DIVISOR)) REM) (DECLARE (TYPE FLOAT FX FY REM)) (SETQ REM (- FX (* (FLOAT (IL:UFIX (IL:FQUOTIENT FX FY))) FY))) (IF (IL:UFEQP REM 0.0) 0.0 (IF (IF (IL:UFGREATERP 0.0 FY) (IL:UFGREATERP FX 0.0) (IL:UFGREATERP 0.0 FX)) (SETQ REM (+ REM FY)))) REM) (LET ((REM (REM NUMBER DIVISOR))) (IF (AND (NOT (ZEROP REM)) (IF (MINUSP DIVISOR) (PLUSP NUMBER) (MINUSP NUMBER))) (+ REM DIVISOR) REM))))
+
+(DEFUN REM (NUMBER DIVISOR) (IL:* IL:|;;| "Returns the second value of truncate") (COND ((AND (INTEGERP NUMBER) (INTEGERP DIVISOR)) (IL:IREMAINDER NUMBER DIVISOR)) ((OR (FLOATP NUMBER) (FLOATP DIVISOR)) (LET ((FX (FLOAT NUMBER)) (FY (FLOAT DIVISOR))) (DECLARE (TYPE FLOAT FX FY)) (SETQ FX (- FX (* (FLOAT (IL:UFIX (IL:FQUOTIENT FX FY))) FY))))) (T (- NUMBER (* DIVISOR (XCL::STRUNCATE NUMBER DIVISOR))))))
+
+
+
+(IL:* IL:|;;| 
+"Should IL:remainder be equivalent to cl:rem?. Thereis no IL:mod in the IRM, although it has a macro which makes it equivalent to imod."
+)
+
+
+
+
+(IL:* IL:|;;| "See cmlfloat for ffloor and friends, decode-float and friends")
+
+
+
+
+(IL:* IL:|;;;| "Section 12.7 Logical Operations on Numbers.")
+
+
+
+
+(IL:* IL:|;;| "LOGXOR and LOGAND are shared with IL. (definitions in llarith)")
+
+
+(DEFUN %LOGICAL-OPTIMIZER (BINARY-LOGICAL-FN IDENTITY FIRST-INTEGER SECOND-INTEGER MORE-INTEGERS) (COND ((NULL FIRST-INTEGER) IDENTITY) ((NULL SECOND-INTEGER) FIRST-INTEGER) ((NULL MORE-INTEGERS) (IL:BQUOTE ((IL:\\\, BINARY-LOGICAL-FN) (IL:\\\, FIRST-INTEGER) (IL:\\\, SECOND-INTEGER)))) (T (LET ((FORM (IL:BQUOTE ((IL:\\\, BINARY-LOGICAL-FN) (IL:\\\, FIRST-INTEGER) (IL:\\\, SECOND-INTEGER))))) (DOLIST (INTEGER MORE-INTEGERS FORM) (SETQ FORM (IL:BQUOTE ((IL:\\\, BINARY-LOGICAL-FN) (IL:\\\, FORM) (IL:\\\, INTEGER)))))))))
+
+(XCL:DEFOPTIMIZER LOGXOR (FIRST-INTEGER SECOND-INTEGER &REST MORE-INTEGERS) (IF (AND COMPILER::*NEW-COMPILER-IS-EXPANDING* MORE-INTEGERS) (%LOGICAL-OPTIMIZER (QUOTE LOGXOR) 0 FIRST-INTEGER SECOND-INTEGER MORE-INTEGERS) (QUOTE COMPILER:PASS)))
+
+(XCL:DEFOPTIMIZER LOGAND (FIRST-INTEGER SECOND-INTEGER &REST MORE-INTEGERS) (IF (AND COMPILER::*NEW-COMPILER-IS-EXPANDING* MORE-INTEGERS) (%LOGICAL-OPTIMIZER (QUOTE LOGAND) -1 FIRST-INTEGER SECOND-INTEGER MORE-INTEGERS) (QUOTE COMPILER:PASS)))
+
+(DEFUN %LOGIOR (X Y) (IL:LOGOR X Y))
+
+(DEFMACRO %LOGEQV (X Y) (IL:BQUOTE (LOGNOT (LOGXOR (IL:\\\, X) (IL:\\\, Y)))))
+
+(IL:PUTPROPS %LOGIOR IL:DOPVAL (2 IL:LOGOR2))
+
+
+
+(IL:* IL:\; "for the byte compiler")
+
+
+(IL:PUTPROPS %LOGIOR IL:DMACRO (= . IL:LOGOR))
+(IL:DEFINEQ
+
+(logior
+  (il:lambda args                                       (il:* il:\; "Edited 11-Feb-87 11:22 by jop")
+          
+          (il:* il:|;;| "Cannot be called interpreted. This defn relies on fact that the compiler turns class to %LOGIOR calls into  a sequence of opcodes")
+
+    (cond
+       ((eq args 0)
+        0)
+       ((eq args 1)
+        (il:arg args 1))
+       ((eq args 2)
+        (%logior (il:arg args 1)
+               (il:arg args 2)))
+       (t (let ((result (%logior (il:arg args 1)
+                               (il:arg args 2)))
+                (i 3))
+               (loop (if (%> i args)
+                         (return result))
+                     (setq result (%logior result (il:arg args i)))
+                     (setq i (1+ i))))))))
+
+(logeqv
+  (il:lambda args                                       (il:* il:\; "Edited 11-Feb-87 13:20 by jop")
+          
+          (il:* il:|;;| "Cannot be called interpreted. This defn relies on fact that the compiler turns class to %LOGIOR calls into  a sequence of opcodes")
+
+    (cond
+       ((eq args 0)
+        -1)
+       ((eq args 1)
+        (il:arg args 1))
+       ((eq args 2)
+        (%logeqv (il:arg args 1)
+               (il:arg args 2)))
+       (t (let ((result (%logeqv (il:arg args 1)
+                               (il:arg args 2)))
+                (i 3))
+               (loop (if (%> i args)
+                         (return result))
+                     (setq result (%logeqv result (il:arg args i)))
+                     (setq i (1+ i))))))))
+)
+
+(XCL:DEFOPTIMIZER LOGIOR (FIRST-INTEGER SECOND-INTEGER &REST MORE-INTEGERS) (%LOGICAL-OPTIMIZER (QUOTE %LOGIOR) 0 FIRST-INTEGER SECOND-INTEGER MORE-INTEGERS))
+
+(XCL:DEFOPTIMIZER LOGEQV (FIRST-INTEGER SECOND-INTEGER &REST MORE-INTEGERS) (%LOGICAL-OPTIMIZER (QUOTE %LOGEQV) -1 FIRST-INTEGER SECOND-INTEGER MORE-INTEGERS))
+
+(DEFUN LOGNAND (INTEGER1 INTEGER2) (LOGNOT (LOGAND INTEGER1 INTEGER2)))
+
+(DEFUN LOGNOR (INTEGER1 INTEGER2) (LOGNOT (LOGIOR INTEGER1 INTEGER2)))
+
+(DEFUN LOGANDC1 (INTEGER1 INTEGER2) (LOGAND (LOGNOT INTEGER1) INTEGER2))
+
+(DEFUN LOGANDC2 (INTEGER1 INTEGER2) (LOGAND INTEGER1 (LOGNOT INTEGER2)))
+
+(DEFUN LOGORC1 (INTEGER1 INTEGER2) (LOGIOR (LOGNOT INTEGER1) INTEGER2))
+
+(DEFUN LOGORC2 (INTEGER1 INTEGER2) (LOGIOR INTEGER1 (LOGNOT INTEGER2)))
+
+(XCL:DEFOPTIMIZER LOGNAND (INTEGER1 INTEGER2) (IL:BQUOTE (LOGNOT (LOGAND (IL:\\\, INTEGER1) (IL:\\\, INTEGER2)))))
+
+(XCL:DEFOPTIMIZER LOGNOR (INTEGER1 INTEGER2) (IL:BQUOTE (LOGNOT (LOGIOR (IL:\\\, INTEGER1) (IL:\\\, INTEGER2)))))
+
+(XCL:DEFOPTIMIZER LOGANDC1 (INTEGER1 INTEGER2) (IL:BQUOTE (LOGAND (LOGNOT (IL:\\\, INTEGER1)) (IL:\\\, INTEGER2))))
+
+(XCL:DEFOPTIMIZER LOGANDC2 (INTEGER1 INTEGER2) (IL:BQUOTE (LOGAND (IL:\\\, INTEGER1) (LOGNOT (IL:\\\, INTEGER2)))))
+
+(XCL:DEFOPTIMIZER LOGORC1 (INTEGER1 INTEGER2) (IL:BQUOTE (LOGIOR (LOGNOT (IL:\\\, INTEGER1)) (IL:\\\, INTEGER2))))
+
+(XCL:DEFOPTIMIZER LOGORC2 (INTEGER1 INTEGER2) (IL:BQUOTE (LOGIOR (IL:\\\, INTEGER1) (LOGNOT (IL:\\\, INTEGER2)))))
+
+(DEFCONSTANT BOOLE-CLR 0)
+
+(DEFCONSTANT BOOLE-SET 1)
+
+(DEFCONSTANT BOOLE-1 2)
+
+(DEFCONSTANT BOOLE-2 3)
+
+(DEFCONSTANT BOOLE-C1 4)
+
+(DEFCONSTANT BOOLE-C2 5)
+
+(DEFCONSTANT BOOLE-AND 6)
+
+(DEFCONSTANT BOOLE-IOR 7)
+
+(DEFCONSTANT BOOLE-XOR 8)
+
+(DEFCONSTANT BOOLE-EQV 9)
+
+(DEFCONSTANT BOOLE-NAND 10)
+
+(DEFCONSTANT BOOLE-NOR 11)
+
+(DEFCONSTANT BOOLE-ANDC1 12)
+
+(DEFCONSTANT BOOLE-ANDC2 13)
+
+(DEFCONSTANT BOOLE-ORC1 14)
+
+(DEFCONSTANT BOOLE-ORC2 15)
+
+(DEFUN BOOLE (OP INTEGER1 INTEGER2) (COND ((EQ OP BOOLE-CLR) 0) ((EQ OP BOOLE-SET) -1) ((EQ OP BOOLE-1) INTEGER1) ((EQ OP BOOLE-2) INTEGER2) ((EQ OP BOOLE-C1) (LOGNOT INTEGER1)) ((EQ OP BOOLE-C2) (LOGNOT INTEGER2)) ((EQ OP BOOLE-AND) (LOGAND INTEGER1 INTEGER2)) ((EQ OP BOOLE-IOR) (LOGIOR INTEGER1 INTEGER2)) ((EQ OP BOOLE-XOR) (LOGXOR INTEGER1 INTEGER2)) ((EQ OP BOOLE-EQV) (LOGEQV INTEGER1 INTEGER2)) ((EQ OP BOOLE-NAND) (LOGNAND INTEGER1 INTEGER2)) ((EQ OP BOOLE-NOR) (LOGNOR INTEGER1 INTEGER2)) ((EQ OP BOOLE-ANDC1) (LOGANDC1 INTEGER1 INTEGER2)) ((EQ OP BOOLE-ANDC2) (LOGANDC2 INTEGER1 INTEGER2)) ((EQ OP BOOLE-ORC1) (LOGORC1 INTEGER1 INTEGER2)) ((EQ OP BOOLE-ORC2) (LOGORC2 INTEGER1 INTEGER2)) (T (ERROR "Not a valid op: ~s" OP))))
+
+
+
+(IL:* IL:|;;| "Lognot is shared with IL.(in addarith) ")
+
+
+(DEFUN LOGTEST (INTEGER1 INTEGER2) (NOT (EQ 0 (LOGAND INTEGER1 INTEGER2))))
+
+(XCL:DEFINLINE LOGBITP (INDEX INTEGER) (EQ 1 (LOGAND 1 (ASH INTEGER (- INDEX)))))
+
+(XCL:DEFOPTIMIZER LOGTEST (INTEGER1 INTEGER2) (IL:BQUOTE (NOT (EQ 0 (LOGAND (IL:\\\, INTEGER1) (IL:\\\, INTEGER2))))))
+
+(DEFUN ASH (INTEGER COUNT) (IL:LSH INTEGER COUNT))
+
+(IL:PUTPROPS ASH IL:DOPVAL (2 IL:LSH))
+
+
+
+(IL:* IL:\; "For the byte compiler")
+
+
+(IL:PUTPROPS ASH IL:DMACRO (= . IL:LSH))
+
+(DEFUN LOGCOUNT (INTEGER) (IL:* IL:|;;| "Logcount returns the number of bits that are the complement of the sign in the integer argument x.  ") (IL:* IL:|;;| "If INTEGER is negative, then the number of 0 bits is returned, otherwise number of 1 bits is returned.  ") (IF (MINUSP INTEGER) (SETQ INTEGER (LOGNOT INTEGER))) (IF (NOT (IL:TYPENAMEP INTEGER (QUOTE BIGNUM))) (%LOGCOUNT INTEGER) (%BIGNUM-LOGCOUNT INTEGER)))
+
+(DEFUN %LOGCOUNT (POSITIVE-INTEGER) (IL:* IL:|;;| "Returns number of 1 bits in nonnegative integer N.  ") (LET ((CNT 0)) (IL:* IL:\; "This loop uses a LOGAND trick to reduce the number of iterations.  ") (LOOP (IF (EQ 0 POSITIVE-INTEGER) (RETURN CNT)) (IL:* IL:\; "Change rightmost 1 bit of N to a 0 bit.  ") (SETQ CNT (1+ CNT)) (SETQ POSITIVE-INTEGER (LOGAND POSITIVE-INTEGER (1- POSITIVE-INTEGER))))))
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(IL:FILESLOAD (IL:LOADCOMP) IL:LLBIGNUM)
+)
+
+
+
+(IL:* IL:\; "Should be in llbignum")
+
+
+(DEFUN %BIGNUM-LOGCOUNT (BIGNUM) (LET ((ELEMENTS (IL:|fetch| (BIGNUM IL:ELEMENTS) IL:|of| BIGNUM)) (CNT 0)) (DOLIST (ELEMENT ELEMENTS CNT) (SETQ CNT (+ CNT (%LOGCOUNT ELEMENT))))))
+
+(DEFUN INTEGER-LENGTH (INTEGER) (COND ((< INTEGER 0) (SETQ INTEGER (- -1 INTEGER)))) (IL:* IL:|;;| "This algorithm is basicly a binary search") (MACROLET ((BITS-OR-LESS-P (INTEGER N) (IL:BQUOTE (< (IL:\\\, INTEGER) (IL:\\\, (ASH 1 N)))))) (IF (BITS-OR-LESS-P INTEGER 16) (COND ((BITS-OR-LESS-P INTEGER 8) (COND ((BITS-OR-LESS-P INTEGER 4) (COND ((BITS-OR-LESS-P INTEGER 2) (IF (BITS-OR-LESS-P INTEGER 1) INTEGER 2)) ((BITS-OR-LESS-P INTEGER 3) 3) (T 4))) ((BITS-OR-LESS-P INTEGER 6) (IF (BITS-OR-LESS-P INTEGER 5) 5 6)) ((BITS-OR-LESS-P INTEGER 7) 7) (T 8))) ((BITS-OR-LESS-P INTEGER 12) (COND ((BITS-OR-LESS-P INTEGER 10) (IF (BITS-OR-LESS-P INTEGER 9) 9 10)) ((BITS-OR-LESS-P INTEGER 11) 11) (T 12))) ((BITS-OR-LESS-P INTEGER 14) (IF (BITS-OR-LESS-P INTEGER 13) 13 14)) ((BITS-OR-LESS-P INTEGER 15) 15) (T 16)) (+ 16 (INTEGER-LENGTH (ASH INTEGER -16))))))
+
+
+
+(IL:* IL:|;;| "OPTIMIZERS FOR IL:LLSH AND IL:LRSH")
+
+
+(DEFUN %LLSH8 (X) (IL:LLSH X 8))
+
+(DEFUN %LLSH1 (X) (IL:LLSH X 1))
+
+(DEFUN %LRSH8 (X) (IL:LRSH X 8))
+
+(DEFUN %LRSH1 (X) (IL:LRSH X 1))
+
+(IL:PUTPROPS %LLSH8 IL:DOPVAL (1 IL:LLSH8))
+
+(IL:PUTPROPS %LLSH1 IL:DOPVAL (1 IL:LLSH1))
+
+(IL:PUTPROPS %LRSH8 IL:DOPVAL (1 IL:LRSH8))
+
+(IL:PUTPROPS %LRSH1 IL:DOPVAL (1 IL:LRSH1))
+
+(XCL:DEFOPTIMIZER IL:LLSH (X N) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (LET ((M (AND (CONSTANTP N) (EVAL N)))) (IF (TYPEP M (QUOTE (INTEGER 0))) (LET ((FORM X)) (LOOP (IF (< M 8) (RETURN NIL)) (SETQ FORM (IL:BQUOTE (%LLSH8 (IL:\\\, FORM)))) (DECF M 8)) (LOOP (IF (<= M 0) (RETURN NIL)) (SETQ FORM (IL:BQUOTE (%LLSH1 (IL:\\\, FORM)))) (DECF M 1)) FORM) (QUOTE COMPILER:PASS))) (QUOTE COMPILER:PASS)))
+
+(XCL:DEFOPTIMIZER IL:LRSH (X N) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (LET ((M (AND (CONSTANTP N) (EVAL N)))) (IF (TYPEP M (QUOTE (INTEGER 0))) (LET ((FORM X)) (LOOP (IF (< M 8) (RETURN NIL)) (SETQ FORM (IL:BQUOTE (%LRSH8 (IL:\\\, FORM)))) (DECF M 8)) (LOOP (IF (<= M 0) (RETURN NIL)) (SETQ FORM (IL:BQUOTE (%LRSH1 (IL:\\\, FORM)))) (DECF M 1)) FORM) (QUOTE COMPILER:PASS))) (QUOTE COMPILER:PASS)))
+
+
+
+(IL:* IL:|;;;| "Section 12.8 Byte Manipulations Functions.")
+
+
+(DEFUN BYTE (SIZE POSITION) (IF (OR (< SIZE 0) (< POSITION 0)) (ERROR "Not a valid bytespec: ~s ~s" SIZE POSITION) (IF (AND (< SIZE 256) (< POSITION 256)) (+ (ASH SIZE 8) POSITION) (CONS SIZE POSITION))))
+
+(XCL:DEFINLINE BYTE-SIZE (BYTESPEC) (IF (TYPEP BYTESPEC (QUOTE FIXNUM)) (ASH BYTESPEC -8) (CAR BYTESPEC)))
+
+(XCL:DEFINLINE BYTE-POSITION (BYTESPEC) (IF (TYPEP BYTESPEC (QUOTE FIXNUM)) (LOGAND BYTESPEC 255) (CDR BYTESPEC)))
+
+
+
+(IL:* IL:|;;| 
+"Byte doesn't need an optimizer since the side-effects data-base will do constant folding, but the byte-compiler can profit from an optimizer"
+)
+
+
+(DEFUN OPTIMIZE-BYTE (SIZE POSITION) (IF (AND (TYPEP SIZE (QUOTE (INTEGER 0 255))) (TYPEP POSITION (QUOTE (INTEGER 0 255)))) (+ (ASH SIZE 8) POSITION) (QUOTE COMPILER:PASS)))
+
+(IL:PUTPROPS BYTE IL:DMACRO (IL:ARGS (OPTIMIZE-BYTE (CAR IL:ARGS) (CADR IL:ARGS))))
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFMACRO %MAKE-BYTE-MASK-1 (SIZE POSITION) (IF (EQ POSITION 0) (IL:BQUOTE (1- (ASH 1 (IL:\\\, SIZE)))) (IL:BQUOTE (ASH (1- (ASH 1 (IL:\\\, SIZE))) (IL:\\\, POSITION)))))
+
+(DEFMACRO %MAKE-BYTE-MASK-0 (SIZE POSITION) (IL:BQUOTE (LOGNOT (%MAKE-BYTE-MASK-1 (IL:\\\, SIZE) (IL:\\\, POSITION)))))
+)
+
+(DEFUN LDB (BYTESPEC INTEGER) (LET ((SIZE (BYTE-SIZE BYTESPEC)) (POSITION (BYTE-POSITION BYTESPEC))) (LOGAND (ASH INTEGER (- POSITION)) (%MAKE-BYTE-MASK-1 SIZE 0))))
+
+(DEFUN DPB (NEWBYTE BYTESPEC INTEGER) (LET ((SIZE (BYTE-SIZE BYTESPEC)) (POSITION (BYTE-POSITION BYTESPEC))) (LOGIOR (ASH (LOGAND NEWBYTE (%MAKE-BYTE-MASK-1 SIZE 0)) POSITION) (LOGAND INTEGER (%MAKE-BYTE-MASK-0 SIZE POSITION)))))
+
+(DEFUN MASK-FIELD (BYTESPEC INTEGER) (LET ((SIZE (BYTE-SIZE BYTESPEC)) (POSITION (BYTE-POSITION BYTESPEC))) (LOGAND INTEGER (%MAKE-BYTE-MASK-1 SIZE POSITION))))
+
+(DEFUN DEPOSIT-FIELD (NEWBYTE BYTESPEC INTEGER) (LET* ((SIZE (BYTE-SIZE BYTESPEC)) (POSITION (BYTE-POSITION BYTESPEC)) (MASK (%MAKE-BYTE-MASK-1 SIZE POSITION))) (LOGIOR (LOGAND NEWBYTE MASK) (LOGAND INTEGER (LOGNOT MASK)))))
+
+(DEFUN %CONSTANT-BYTESPEC-P (BYTESPEC) (COND ((TYPEP BYTESPEC (QUOTE FIXNUM)) BYTESPEC) ((AND (CONSP BYTESPEC) (EQ (CAR BYTESPEC) (QUOTE BYTE)) (INTEGERP (CADR BYTESPEC)) (INTEGERP (CADDR BYTESPEC))) (EVAL BYTESPEC)) (T NIL)))
+
+(XCL:DEFOPTIMIZER LDB (BYTESPEC INTEGER) (LET ((CONSTANT-BYTE (%CONSTANT-BYTESPEC-P BYTESPEC))) (IF CONSTANT-BYTE (LET ((SIZE (BYTE-SIZE CONSTANT-BYTE)) (POSITION (BYTE-POSITION CONSTANT-BYTE))) (IF (ZEROP POSITION) (IL:BQUOTE (LOGAND (IL:\\\, INTEGER) (IL:\\\, (%MAKE-BYTE-MASK-1 SIZE 0)))) (IL:BQUOTE (LOGAND (ASH (IL:\\\, INTEGER) (IL:\\\, (- POSITION))) (IL:\\\, (%MAKE-BYTE-MASK-1 SIZE 0)))))) (QUOTE COMPILER:PASS))))
+
+(XCL:DEFOPTIMIZER DPB (NEWBYTE BYTESPEC INTEGER) (LET ((CONSTANT-BYTE (%CONSTANT-BYTESPEC-P BYTESPEC))) (IF CONSTANT-BYTE (LET ((SIZE (BYTE-SIZE CONSTANT-BYTE)) (POSITION (BYTE-POSITION CONSTANT-BYTE))) (IF (ZEROP POSITION) (IL:BQUOTE (LOGIOR (LOGAND (IL:\\\, NEWBYTE) (IL:\\\, (%MAKE-BYTE-MASK-1 SIZE 0))) (LOGAND (IL:\\\, INTEGER) (IL:\\\, (%MAKE-BYTE-MASK-0 SIZE 0))))) (IL:BQUOTE (LOGIOR (ASH (LOGAND (IL:\\\, NEWBYTE) (IL:\\\, (%MAKE-BYTE-MASK-1 SIZE 0))) (IL:\\\, POSITION)) (LOGAND (IL:\\\, INTEGER) (IL:\\\, (%MAKE-BYTE-MASK-0 SIZE POSITION))))))) (QUOTE COMPILER:PASS))))
+
+(XCL:DEFOPTIMIZER MASK-FIELD (BYTESPEC INTEGER) (LET ((CONSTANT-BYTE (%CONSTANT-BYTESPEC-P BYTESPEC))) (IF CONSTANT-BYTE (LET ((SIZE (BYTE-SIZE CONSTANT-BYTE)) (POSITION (BYTE-POSITION CONSTANT-BYTE))) (IL:BQUOTE (LOGAND (IL:\\\, INTEGER) (IL:\\\, (%MAKE-BYTE-MASK-1 SIZE POSITION))))) (QUOTE COMPILER:PASS))))
+
+(XCL:DEFOPTIMIZER DEPOSIT-FIELD (NEWBYTE BYTESPEC INTEGER) (LET ((CONSTANT-BYTE (%CONSTANT-BYTESPEC-P BYTESPEC))) (IF CONSTANT-BYTE (LET* ((SIZE (BYTE-SIZE CONSTANT-BYTE)) (POSITION (BYTE-POSITION CONSTANT-BYTE)) (MASK (%MAKE-BYTE-MASK-1 SIZE POSITION))) (IL:BQUOTE (LOGIOR (LOGAND (IL:\\\, NEWBYTE) (IL:\\\, MASK)) (LOGAND (IL:\\\, INTEGER) (IL:\\\, (LOGNOT MASK)))))) (QUOTE COMPILER:PASS))))
+
+(DEFUN LDB-TEST (BYTESPEC INTEGER) (NOT (EQ 0 (LDB BYTESPEC INTEGER))))
+
+(XCL:DEFOPTIMIZER LDB-TEST (BYTESPEC INTEGER) (IL:BQUOTE (NOT (EQ 0 (LDB (IL:\\\, BYTESPEC) (IL:\\\, INTEGER))))))
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
+
+(IL:LOCALVARS . T)
+)
+)
+
+(IL:PUTPROPS IL:CMLARITH IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
+
+(IL:PUTPROPS IL:CMLARITH IL:FILETYPE COMPILE-FILE)
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA)
+
+(IL:ADDTOVAR IL:NLAML)
+
+(IL:ADDTOVAR IL:LAMA LOGEQV LOGIOR LCM GCD / * - + >= <= > < /= =)
+)
+(IL:PUTPROPS IL:CMLARITH IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1989 1990 1992)
+)
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL (25091 26923 (= 25104 . 25610) (/= 25612 . 26313) (< 26315 . 26464) (> 26466 . 26615)
+ (<= 26617 . 26768) (>= 26770 . 26921)) (36716 38838 (+ 36729 . 37225) (- 37227 . 37811) (* 37813 . 
+38309) (/ 38311 . 38836)) (41628 42826 (GCD 41641 . 42419) (LCM 42421 . 42824)) (55724 57294 (LOGIOR 
+55737 . 56513) (LOGEQV 56515 . 57292)))))
+IL:STOP
diff --git a/CLTL2/CMLARITH.LCOM b/CLTL2/CMLARITH.LCOM
new file mode 100644
index 00000000..e27415d8
--- /dev/null
+++ b/CLTL2/CMLARITH.LCOM
@@ -0,0 +1,92 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
(IL:FILECREATED "29-Oct-93 09:31:20" ("compiled on " 
IL:|{DSK}<king>export>lispcore>sources>CLTL2>CMLARITH.;1|) "19-Feb-93 17:03:08" "COMPILE-FILEd" IL:|in|
 "Medley 19-Feb-93 ..." IL:|dated| "19-Feb-93 18:20:42")
(IL:FILECREATED "24-Mar-92 14:23:15" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLARITH.;2| 68401 
IL:|changes| IL:|to:| (IL:VARS IL:CMLARITHCOMS) (IL:FUNCTIONS UPGRADED-COMPLEX-PART-TYPE) (IL:FNS LCM)
 IL:|previous| IL:|date:| "16-May-90 12:46:36" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLARITH.;1|)
(IL:RPAQQ IL:CMLARITHCOMS ((IL:* IL:|;;;| "Common Lisp Arithmetic ") (IL:COMS (IL:* IL:|;;| 
"Error utilities") (IL:FUNCTIONS %NOT-NUMBER-ERROR %NOT-NONCOMPLEX-NUMBER-ERROR %NOT-INTEGER-ERROR 
%NOT-RATIONAL-ERROR %NOT-FLOAT-ERROR)) (IL:COMS (IL:* IL:|;;;| "Section 2.1.2 Ratios. ") (IL:COMS (
IL:STRUCTURES RATIO) (IL:* IL:|;;| "The following makes NUMBERP true on ratios") (IL:DECLARE\: 
IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:\\SETTYPEMASK (IL:\\TYPENUMBERFROMNAME (QUOTE RATIO)) (IL:LOGOR 
IL:\\TT.NUMBERP IL:\\TT.ATOM))))) (IL:FUNCTIONS DENOMINATOR NUMERATOR RATIONALP %RATIO-PRINT 
%BUILD-RATIO RATIONAL RATIONALIZE) (IL:FUNCTIONS %RATIO-PLUS %RATIO-TIMES)) (IL:COMS (IL:* IL:|;;;| 
"Section 2.1.4 Complex Numbers.") (IL:COMS (IL:STRUCTURES COMPLEX) (IL:* IL:|;;| 
"So we don't inherit the deftype from defstruct") (IL:TYPES COMPLEX) (IL:* IL:|;;| 
"Make Complex  NUMBERP") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:\\SETTYPEMASK (
IL:\\TYPENUMBERFROMNAME (QUOTE COMPLEX)) (IL:LOGOR IL:\\TT.NUMBERP IL:\\TT.ATOM))))) (IL:FUNCTIONS 
COMPLEX REALPART IMAGPART CONJUGATE PHASE UPGRADED-COMPLEX-PART-TYPE %COMPLEX-PRINT %COMPLEX-+ 
%COMPLEX-- %COMPLEX-* %COMPLEX-/ %COMPLEX-ABS)) (IL:COMS (IL:* IL:|;;;| "Datatype predicates") (IL:* 
IL:|;;| "cl:integerp is defined in cmlpred (has an optimizer)") (IL:* IL:|;;| 
"cl:floatp is defined in cmltypes (has an optimizer). il:floatp is defined on llbasic") (IL:* IL:|;;| 
"cl:complexp is a defstruct predicate (compiles in line)") (IL:* IL:|;;| 
"cl:numberp is defined in cmltypes (has an optimizer). il:numberp is defined on llbasic")) (IL:COMS (
IL:* IL:|;;;| "Section 12.2 Predicates on Numbers (generic).") (IL:* IL:|;;| 
"cl:zerop  is not shared with il:zerop, although they are equivalent. There is no il;plusp ") (IL:COMS
 (IL:FUNCTIONS ZEROP PLUSP) (XCL:OPTIMIZERS ZEROP PLUSP)) (IL:* IL:|;;| 
"cl:minusp is shared with il:minusp, but must be redefined to work with ratios. Old version resides in llarith"
) (IL:COMS (IL:FUNCTIONS MINUSP) (XCL:OPTIMIZERS MINUSP)) (IL:* IL:|;;| 
"Both cl:evenp and cl:oddp are shared with il:. The functions are extended by allowing a second optional modulus argument. Another version of il:oddp exists on llarith, but the definition of il:evenp has disappeared"
) (IL:COMS (IL:FUNCTIONS EVENP ODDP) (XCL:OPTIMIZERS EVENP ODDP))) (IL:COMS (IL:* IL:|;;;| 
"Section 12.3 Comparisons on Numbers. (generic)") (IL:COMS (IL:FUNCTIONS %= %/= %> %< %>= %<=) (IL:PROP
 IL:DOPVAL %= %> %<) (IL:* IL:\; "For the byte compiler") (IL:PROP IL:DMACRO %> %< %>= %<=) (
IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:* IL:|;;| "Backward compatibility") (IL:* IL:\; 
" il:%= is listed as the punt function for the = opcode") (IL:MOVD (QUOTE %=) (QUOTE IL:%=)) (IL:* IL:\;
 "Greaterp is the UFN for the greaterp opcode. Effectively redefines the opcode") (IL:MOVD (QUOTE %>) 
(QUOTE IL:GREATERP)) (IL:* IL:\; "Interlisp Greaterp and Lessp are defined in llarith") (IL:MOVD (
QUOTE %<) (QUOTE IL:LESSP))))) (IL:* IL:|;;| 
"=, <, >, <=, and >= are shared with il:, but cl:/= is NOT shared (?!)") (IL:COMS (IL:DECLARE\: 
IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %COMPARISON-MACRO)) (IL:FNS = /= < > <= >=) (IL:FUNCTIONS 
%COMPARISON-OPTIMIZER) (XCL:OPTIMIZERS = /= < > <= >=)) (IL:* IL:|;;| 
"Note: the related predicates EQL, EQUAL, and EQUALP should be consulted if any of the above change. EQL is on LLNEW (?), EQUAL and EQUALP on CMLTYPES."
) (IL:* IL:|;;| 
"cl:min and cl:max are shared with il: (defined in llarith). They  are written in terms of GREATERP and hence work on ratios. Note (min) returns #.max.integer , which is an extension on the CLtl spec. We only optimize the case of two args"
) (XCL:OPTIMIZERS MIN MAX)) (IL:COMS (IL:* IL:|;;;| "Section 12.4 Arithmetic Operations (generic). ") 
(IL:COMS (IL:FUNCTIONS %+ %- %* %/) (IL:* IL:\; 
"NOTE: %/ cannot compile out to the existinq quotient opcode because it produces ratios rather than truncating"
) (IL:PROP IL:DOPVAL %+ %- %*) (IL:* IL:\; "For the byte compiler") (IL:PROP IL:DMACRO %+ %- %*) (
IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:* IL:|;;| "Backward compatibility") (IL:MOVD (QUOTE 
%/) (QUOTE IL:%/)) (IL:* IL:|;;| 
"Redefine UFNs for generic plus, difference, and times. Old UFN defined in llarith.") (IL:MOVD (QUOTE 
%+) (QUOTE IL:\\SLOWPLUS2)) (IL:MOVD (QUOTE %-) (QUOTE IL:\\SLOWDIFFERENCE)) (IL:MOVD (QUOTE %*) (
QUOTE IL:\\SLOWTIMES2))))) (IL:COMS (IL:FNS + - * /) (IL:FUNCTIONS 1+ 1- %RECIPROCOL) (XCL:OPTIMIZERS 
+ - * / 1+ 1-) (IL:* IL:\; "For the byte compiler") (IL:PROP IL:DMACRO + *) (IL:* IL:|;;| 
"Redefine Interlisp generic arithmetic to work with ratios") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY 
(IL:P (IL:MOVD (QUOTE +) (QUOTE IL:PLUS)) (IL:* IL:|;;| 
"Don't need to redefine difference since it is defined in terms of the difference opcode (redefined above)"
) (IL:MOVD (QUOTE *) (QUOTE IL:TIMES)) (IL:* IL:|;;| 
"So Interlisp quotient will do something reasonable with ratios") (IL:* (IL:MOVD (QUOTE IL:NEW-QUOTIENT
) (QUOTE IL:QUOTIENT))) (IL:* IL:|;;| 
"because QUOTIENT is already defined in LLARITH to do something useful with ratios. AR 8062.")))) (IL:*
 IL:|;;| "INCF and DECF implemented by CMLSETF.") (IL:FUNCTIONS %GCD %LCM) (IL:FNS GCD LCM)) (IL:COMS 
(IL:* IL:|;;| "Optimizers for Interlisp functions, so that they compile open with the PavCompiler.") (
IL:* IL:|;;| "optimizer of IL:minus") (XCL:OPTIMIZERS IL:MINUS) (XCL:OPTIMIZERS IL:PLUS IL:IPLUS 
IL:FPLUS IL:TIMES IL:ITIMES IL:FTIMES IL:RSH) (IL:PROP IL:DOPVAL IL:PLUS2 IL:IPLUS2 IL:FPLUS2 IL:TIMES2
 IL:ITIMES2 IL:FTIMES2)) (IL:COMS (IL:* IL:|;;;| 
"Section 12.5 Irrational and Transcendental functions. Most of these will be found on cmlfloat.") (
IL:FUNCTIONS ISQRT) (IL:* IL:|;;| "Abs is shared with il: abs ia also defined in llarith.") (
IL:FUNCTIONS ABS %ABS) (IL:FUNCTIONS SIGNUM %SIGNUM)) (IL:COMS (IL:* IL:|;;;| 
"Section 12.6 Type Conversions and Component Extractions on Numbers.") (IL:* IL:|;;| 
"Float implemented in cmlfloat  ") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:UNBOXEDOPS
)) (IL:* IL:\; "These should be exported from xcl") (IL:COMS (IL:FUNCTIONS XCL::STRUNCATE XCL::SFLOOR 
XCL::SCEILING XCL::SROUND) (XCL:OPTIMIZERS XCL::STRUNCATE XCL::SROUND)) (IL:* IL:\; 
"Round is shared with il: (?!)") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS 
%INTEGER-COERCE-MACRO)) (IL:FUNCTIONS TRUNCATE FLOOR CEILING ROUND) (IL:FUNCTIONS 
%INTEGER-COERCE-OPTIMIZER) (XCL:OPTIMIZERS TRUNCATE FLOOR CEILING ROUND)) (IL:COMS (IL:FUNCTIONS 
FTRUNCATE FFLOOR FCEILING FROUND) (XCL:OPTIMIZERS FTRUNCATE FFLOOR FCEILING FROUND)) (IL:COMS (
IL:FUNCTIONS MOD REM)) (IL:* IL:|;;| 
"Should IL:remainder be equivalent to cl:rem?. Thereis no IL:mod in the IRM, although it has a macro which makes it equivalent to imod."
) (IL:* IL:|;;| "See cmlfloat for ffloor and friends, decode-float and friends")) (IL:COMS (IL:* 
IL:|;;;| "Section 12.7 Logical Operations on Numbers.") (IL:* IL:|;;| 
"LOGXOR and LOGAND are shared with IL. (definitions in llarith)") (IL:COMS (IL:FUNCTIONS 
%LOGICAL-OPTIMIZER) (XCL:OPTIMIZERS LOGXOR LOGAND)) (IL:COMS (IL:FUNCTIONS %LOGIOR %LOGEQV) (IL:PROP 
IL:DOPVAL %LOGIOR) (IL:* IL:\; "for the byte compiler") (IL:PROP IL:DMACRO %LOGIOR)) (IL:COMS (IL:FNS 
LOGIOR LOGEQV) (XCL:OPTIMIZERS LOGIOR LOGEQV)) (IL:COMS (IL:FUNCTIONS LOGNAND LOGNOR LOGANDC1 LOGANDC2
 LOGORC1 LOGORC2) (XCL:OPTIMIZERS LOGNAND LOGNOR LOGANDC1 LOGANDC2 LOGORC1 LOGORC2)) (IL:COMS (
IL:VARIABLES BOOLE-CLR BOOLE-SET BOOLE-1 BOOLE-2 BOOLE-C1 BOOLE-C2 BOOLE-AND BOOLE-IOR BOOLE-XOR 
BOOLE-EQV BOOLE-NAND BOOLE-NOR BOOLE-ANDC1 BOOLE-ANDC2 BOOLE-ORC1 BOOLE-ORC2) (IL:FUNCTIONS BOOLE)) (
IL:* IL:|;;| "Lognot is shared with IL.(in addarith) ") (IL:COMS (IL:FUNCTIONS LOGTEST LOGBITP) (
XCL:OPTIMIZERS LOGTEST)) (IL:COMS (IL:FUNCTIONS ASH) (IL:PROP IL:DOPVAL ASH) (IL:* IL:\; 
"For the byte compiler") (IL:PROP IL:DMACRO ASH)) (IL:COMS (IL:FUNCTIONS LOGCOUNT %LOGCOUNT) (
IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES (IL:LOADCOMP) IL:LLBIGNUM)) (IL:* IL:\; 
"Should be in llbignum") (IL:FUNCTIONS %BIGNUM-LOGCOUNT)) (IL:FUNCTIONS INTEGER-LENGTH) (IL:* IL:|;;| 
"OPTIMIZERS FOR IL:LLSH AND IL:LRSH") (IL:COMS (IL:FUNCTIONS %LLSH8 %LLSH1 %LRSH8 %LRSH1) (IL:PROP 
IL:DOPVAL %LLSH8 %LLSH1 %LRSH8 %LRSH1) (XCL:OPTIMIZERS IL:LLSH IL:LRSH))) (IL:COMS (IL:* IL:|;;;| 
"Section 12.8 Byte Manipulations Functions.") (IL:COMS (IL:FUNCTIONS BYTE BYTE-SIZE BYTE-POSITION) (IL:*
 IL:|;;| 
"Byte doesn't need an optimizer since the side-effects data-base will do constant folding, but the byte-compiler can profit from an optimizer"
) (IL:FUNCTIONS OPTIMIZE-BYTE) (IL:PROP IL:DMACRO BYTE)) (IL:COMS (IL:DECLARE\: IL:DONTCOPY 
IL:DOEVAL@COMPILE (IL:FUNCTIONS %MAKE-BYTE-MASK-1 %MAKE-BYTE-MASK-0)) (IL:FUNCTIONS LDB DPB MASK-FIELD
 DEPOSIT-FIELD) (IL:FUNCTIONS %CONSTANT-BYTESPEC-P) (XCL:OPTIMIZERS LDB DPB MASK-FIELD DEPOSIT-FIELD))
 (IL:COMS (IL:FUNCTIONS LDB-TEST) (XCL:OPTIMIZERS LDB-TEST))) (IL:DECLARE\: IL:DONTCOPY 
IL:DOEVAL@COMPILE (IL:LOCALVARS . T)) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:CMLARITH) (
IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (
IL:NLAML) (IL:LAMA LOGEQV LOGIOR LCM GCD / * - + >= <= > < /= =)))))
%NOT-NUMBER-ERROR :D8
(IL:L (0 OBJECT)) #gggg@g@
(32 ERROR)
(25 :VALUE 19 :NAME 14 NUMBER 9 :EXPECTED-TYPE 4 XCL:TYPE-MISMATCH)
()
%NOT-NONCOMPLEX-NUMBER-ERROR :D8
(IL:L (0 OBJECT)) 3@3�o@
+gggg@g@
(48 ERROR 14 ERROR)
(41 :VALUE 35 :NAME 30 NUMBER 25 :EXPECTED-TYPE 20 XCL:TYPE-MISMATCH)
( 8 "Arg a complex number~%~s")
%NOT-INTEGER-ERROR :D8
(IL:L (0 OBJECT)) #gggg@g@
(32 ERROR)
(25 :VALUE 19 :NAME 14 INTEGER 9 :EXPECTED-TYPE 4 XCL:TYPE-MISMATCH)
()
%NOT-RATIONAL-ERROR :D8
(IL:L (0 OBJECT)) #gggg@g@
(32 ERROR)
(25 :NAME 19 :VALUE 14 RATIONAL 9 :EXPECTED-TYPE 4 XCL:TYPE-MISMATCH)
()
%NOT-FLOAT-ERROR :D8
(IL:L (0 OBJECT)) #gggg@g@
(32 ERROR)
(25 :VALUE 19 :NAME 14 FLOAT 9 :EXPECTED-TYPE 4 XCL:TYPE-MISMATCH)
()
(SET-PARSED-STRUCTURE (QUOTE RATIO) T (QUOTE (PS RATIO NIL (NUMERATOR DENOMINATOR) DATATYPE NIL NIL 
"RATIO-" ((%MAKE-RATIO (NUMERATOR DENOMINATOR))) %RATIO-P %RATIO-PRINT NIL NIL 0 NIL ((NUMERATOR 
:READ-ONLY T NIL (RATIO 0 IL:POINTER) RATIO-NUMERATOR) (DENOMINATOR :READ-ONLY T NIL (RATIO 2 IL:POINTER
) RATIO-DENOMINATOR)) NIL NIL (IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL)))
(SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE RATIO) (QUOTE (IL:POINTER IL:POINTER)) (QUOTE ((RATIO 0 
IL:POINTER) (RATIO 2 IL:POINTER))) 4 (QUOTE STRUCTURE-OBJECT))
(IL:PUTPROP (QUOTE RATIO) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE))
%RATIO-P :D8
(IL:L (0 OBJECT)) @�NIL
(5 RATIO)
()
(ESTABLISH-PREDICATE (QUOTE RATIO))
RATIO-NUMERATOR :D8
(IL:L (0 RATIO)) 
+@�NIL
(5 RATIO)
()
RATIO-DENOMINATOR :D8
(IL:L (0 RATIO)) 
+@�NIL
(5 RATIO)
()
(ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE RATIO))
%MAKE-RATIO :D8
(IL:L (1 DENOMINATOR 0 NUMERATOR)) lH@HAHNIL
NIL
()
(IL:\\SETTYPEMASK (IL:\\TYPENUMBERFROMNAME (QUOTE RATIO)) (IL:LOGOR IL:\\TT.NUMBERP IL:\\TT.ATOM))
DENOMINATOR :D8
(IL:L (0 RATIONAL)) @d���@�3 �k@	(28 %NOT-RATIONAL-ERROR)
(14 RATIO 6 RATIO)
()
NUMERATOR :D8
(IL:L (0 RATIONAL)) @d���@�3 �@@	(28 %NOT-RATIONAL-ERROR)
(14 RATIO 6 RATIO)
()
RATIONALP :D8
(IL:L (0 NUMBER)) @d3 �i�NIL
(11 RATIO)
()
|definline-RATIONALP| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) @oHNIL
NIL
( 9 (LAMBDA (NUMBER) (BLOCK RATIONALP (OR (INTEGERP NUMBER) (%RATIO-P NUMBER)))))
(IL:PUTPROP (QUOTE RATIONALP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-RATIONALP|) (
GET (QUOTE RATIONALP) (QUOTE COMPILER:OPTIMIZER-LIST))))
%RATIO-PRINT :D8
(IL:L (1 STREAM 0 NUMBER) IL:P 8 *PRINT-RADIX* IL:P 7 IL:\\THISFILELINELENGTH IL:P 6 *PRINT-RADIX* IL:P 5 *PRINT-BASE* IL:F 9 *PRINT-BASE* IL:F 10 *READTABLE* IL:F 11 IL:\\THISFILELINELENGTH IL:F 12 *PRINT-RADIX*) 	@�@�2W�j�oA
+gHIhA
+W�{gW�[�l�Kl��l��h�lK�	Wdl�o�<l�o�1Wl�o�$gW�l
+L	o�W�*kH	�I	�J�Aj�A��W�A	� J�HA
+oA
+IA
+A
+���	��(276 IL:NCHARS 268 IL:\\SOUT 261 IL:\\PRINDATUM 254 IL:\\SOUT 243 IL:\\PRINDATUM 229 IL:FRESHLINE 204 IL:NCHARS 197 IL:NCHARS 185 CONCATENATE 180 CONCATENATE 168 PRINC-TO-STRING 107 STRING 60 IL:\\PRINDATUM 43 IL:PRIN1)
(216 STREAM 151 STRING 77 READTABLEP 70 STRING 48 / 25 READTABLEP 13 RATIO 5 RATIO)
( 248 "/" 175 "r" 144 "x" 131 "o" 120 "b" 37 "|.")
%BUILD-RATIO :D8
(IL:L (1 Y 0 X)) <@dA�j�A�A
+Hk�@H�b�AH�b�jA�j@�jA�
+@A
+(57 %MAKE-RATIO 49 %MAKE-RATIO 15 %GCD)
NIL
()
RATIONAL :D8
(IL:L (0 NUMBER)) Q@HY��I3 �@Hd���@	��"@�	@�	
+@	(78 %NOT-NUMBER-ERROR 71 %MAKE-COMPLEX 66 RATIONAL 53 RATIONAL 32 %RATIONAL-FLOAT)
(59 COMPLEX 46 COMPLEX 38 COMPLEX 24 IL:FLOATP 10 RATIO)
()
RATIONALIZE :D8
(IL:L (0 NUMBER)) Q@HY��I3 �@Hd���@	��"@�	@�	
+@	(78 %NOT-NUMBER-ERROR 71 %MAKE-COMPLEX 66 RATIONALIZE 53 RATIONALIZE 32 %RATIONALIZE-FLOAT)
(59 COMPLEX 46 COMPLEX 38 COMPLEX 24 IL:FLOATP 10 RATIO)
()
%RATIO-PLUS :D8
(IL:L (3 DENOMINATOR-2 2 NUMERATOR-2 1 DENOMINATOR-1 0 NUMERATOR-1)) VAC
+AHk�@C�BA��AC�
+AH۹@CH��BI��ZH
+�C�Kk�CKۼJKۺLk�Ik�JJIL�
+(83 %MAKE-RATIO 49 %GCD 28 %MAKE-RATIO 6 %GCD)
NIL
()
%RATIO-TIMES :D8
(IL:L (3 DENOMINATOR-2 2 NUMERATOR-2 1 DENOMINATOR-1 0 NUMERATOR-1)) Z@C
+BA
+Hk�@H�b�CH�b�Ik�BI�b�AI�b�@B�AC�Ik�HjI�jH�jI�
+HI
+(87 %MAKE-RATIO 79 %MAKE-RATIO 13 %GCD 6 %GCD)
NIL
()
(SET-PARSED-STRUCTURE (QUOTE COMPLEX) T (QUOTE (PS COMPLEX NIL (REALPART IMAGPART) DATATYPE NIL NIL 
"COMPLEX-" ((%MAKE-COMPLEX (REALPART IMAGPART))) COMPLEXP %COMPLEX-PRINT NIL NIL 0 NIL ((REALPART 
:READ-ONLY T NIL (COMPLEX 0 IL:POINTER) COMPLEX-REALPART) (IMAGPART :READ-ONLY T NIL (COMPLEX 2 
IL:POINTER) COMPLEX-IMAGPART)) NIL NIL (IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL)
))
(SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE COMPLEX) (QUOTE (IL:POINTER IL:POINTER)) (QUOTE ((COMPLEX 0 
IL:POINTER) (COMPLEX 2 IL:POINTER))) 4 (QUOTE STRUCTURE-OBJECT))
(IL:PUTPROP (QUOTE COMPLEX) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE))
COMPLEXP :D8
(IL:L (0 OBJECT)) @�NIL
(5 COMPLEX)
()
(ESTABLISH-PREDICATE (QUOTE COMPLEX))
COMPLEX-REALPART :D8
(IL:L (0 COMPLEX)) 
+@�NIL
(5 COMPLEX)
()
COMPLEX-IMAGPART :D8
(IL:L (0 COMPLEX)) 
+@�NIL
(5 COMPLEX)
()
(ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE COMPLEX))
%MAKE-COMPLEX :D8
(IL:L (1 IMAGPART 0 REALPART)) lH@HAHNIL
NIL
()
|type-expand-COMPLEX| :D8
(IL:L (0 SI::%$$TYPE-FORM)) z@�gHg�o��ggggoggogHhhgogHhhhhhhNIL
(96 QUOTE 86 TYPEP 73 QUOTE 63 TYPEP 58 AND 48 IL:LAMBDA 43 SATISFIES 38 COMPLEX 33 AND 17 * 8 *)
( 91 (COMPLEX-IMAGPART IL:X) 68 (COMPLEX-REALPART IL:X) 53 (IL:X) 24 (:DATATYPE COMPLEX))
(IL:PUTPROP (QUOTE COMPLEX) (QUOTE :TYPE-EXPANDER) (QUOTE |type-expand-COMPLEX|))
(IL:\\SETTYPEMASK (IL:\\TYPENUMBERFROMNAME (QUOTE COMPLEX)) (IL:LOGOR IL:\\TT.NUMBERP IL:\\TT.ATOM))
COMPLEX :D8
(IL:L (0 IL:|-args-|)) vekaQlH�j�la�I[\��L3 �:J]^d���N3 �Jj�IIJ
+M��IJ
+J	K��IJ
+I	(115 %NOT-NONCOMPLEX-NUMBER-ERROR 108 %MAKE-COMPLEX 88 %NOT-NONCOMPLEX-NUMBER-ERROR 81 %MAKE-COMPLEX 61 %MAKE-COMPLEX)
(103 IL:FLOATP 95 IL:FLOATP 75 IL:FLOATP 68 IL:FLOATP 42 RATIO 27 RATIO)
()
REALPART :D8
(IL:L (0 NUMBER)) @d���@�3�@@	(28 %NOT-NUMBER-ERROR)
(14 COMPLEX 6 COMPLEX)
()
IMAGPART :D8
(IL:L (0 NUMBER)) ,@d���@�d��o3�j@	(41 %NOT-NUMBER-ERROR)
(23 IL:FLOATP 14 COMPLEX 6 COMPLEX)
( 29 0.0)
CONJUGATE :D8
(IL:L (0 NUMBER)) /@d���@�j@��
+3�@@	(44 %NOT-NUMBER-ERROR 32 %MAKE-COMPLEX)
(24 COMPLEX 15 COMPLEX 6 COMPLEX)
()
PHASE :D8
(IL:L (0 NUMBER)) 9@dj��o��@�@�
+j@�oo(38 ATAN)
(31 COMPLEX 23 COMPLEX 15 COMPLEX)
( 54 0.0 48 3.1415927 9 0.0)
UPGRADED-COMPLEX-PART-TYPE :D8
(IL:L (0 TYPE)) @g
+�go@
+(28 ERROR 10 SUBTYPEP)
(16 NUMBER 5 NUMBER)
( 22 "Type ~s can't be part of a complex number")
%COMPLEX-PRINT :D8
(IL:L (1 STREAM 0 NUMBER) IL:F 5 IL:\\THISFILELINELENGTH IL:F 6 *READTABLE*) �@�@�2U�%lH	�I	�A��U�A	�AV��[�(�KLlJ�oA
+oA
+HA
+oA
+IA
+oA
+(141 IL:\\SOUT 130 IL:\\PRINDATUM 123 IL:\\SOUT 112 IL:\\PRINDATUM 105 IL:\\SOUT 94 IL:\\SOUT 55 IL:FRESHLINE 36 IL:NCHARS 29 IL:NCHARS)
(73 STREAM 63 READTABLEP 43 STREAM 13 COMPLEX 5 COMPLEX)
( 135 ")" 117 " " 99 "(" 88 "C")
%COMPLEX-+ :D8
(IL:L (3 IMAG-2 2 REAL-2 1 IMAG-1 0 REAL-1)) )Aj��@B�C
+Cj��@B�A
+@B�AC�
+(38 COMPLEX 26 COMPLEX 12 COMPLEX)
NIL
()
%COMPLEX-- :D8
(IL:L (3 IMAG-2 2 REAL-2 1 IMAG-1 0 REAL-1)) +Aj��@B�jC�
+Cj��@B�A
+@B�AC�
+(40 COMPLEX 28 COMPLEX 14 COMPLEX)
NIL
()
%COMPLEX-* :D8
(IL:L (3 IMAG-2 2 REAL-2 1 IMAG-1 0 REAL-1)) 5Aj��@B�@C�
+Cj��@B�AB�
+@B�AC��AB�@C��
+(50 COMPLEX 30 COMPLEX 14 COMPLEX)
NIL
()
%COMPLEX-/ :D8
(IL:L (3 IMAG-2 2 REAL-2 1 IMAG-1 0 REAL-1)) mjA��&Bd�Cd��@B�H
+j@C��H
+
+jC��@B
+AB
+
+Bd�Cd��@B�AC��H
+AB�@C��H
+
+(106 COMPLEX 101 %/ 88 %/ 64 COMPLEX 59 %/ 52 %/ 39 COMPLEX 34 %/ 23 %/)
NIL
()
%COMPLEX-ABS :D8
(IL:L (0 Z)) 1@��@��H�H��I�I�����	(46 SQRT)
(15 COMPLEX 5 COMPLEX)
()
ZEROP :D8
(IL:L (0 NUMBER)) j@�NIL
NIL
()
PLUSP :D8
(IL:L (0 NUMBER)) @j�NIL
NIL
()
|optimize-ZEROP| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) @gjHhNIL
(10 =)
()
(IL:PUTPROP (QUOTE ZEROP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ZEROP|) (GET (QUOTE
 ZEROP) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-PLUSP| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) @gHoNIL
(10 >)
( 16 (0))
(IL:PUTPROP (QUOTE PLUSP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-PLUSP|) (GET (QUOTE
 PLUSP) (QUOTE COMPILER:OPTIMIZER-LIST))))
MINUSP :D8
(IL:L (0 NUMBER)) j@�NIL
NIL
()
|optimize-MINUSP| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) @gHoNIL
(10 <)
( 16 (0))
(IL:PUTPROP (QUOTE MINUSP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MINUSP|) (GET (
QUOTE MINUSP) (QUOTE COMPILER:OPTIMIZER-LIST))))
EVENP :D8
(IL:L (1 MODULUS 0 INTEGER)) A�@k�j�j@A
+�(15 MOD)
NIL
()
ODDP :D8
(IL:L (1 MODULUS 0 INTEGER)) A�@k�k�j@A
+�h�(15 MOD)
NIL
()
|optimize-EVENP| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) 0@!H�HZ�J�ggIoogNIL
(45 COMPILER:PASS 24 LOGAND 19 EQ)
( 37 (0) 30 (1))
(IL:PUTPROP (QUOTE EVENP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-EVENP|) (GET (QUOTE
 EVENP) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-ODDP| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) 0@!H�HZ�J�ggIoogNIL
(45 COMPILER:PASS 24 LOGAND 19 EQ)
( 37 (1) 30 (1))
(IL:PUTPROP (QUOTE ODDP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ODDP|) (GET (QUOTE 
ODDP) (QUOTE COMPILER:OPTIMIZER-LIST))))
%= :D8
(IL:NAME = IL:L (1 Y 0 X)) i@1Hd3 �Q�AYd3 ��@A�j���@A
+Id��h��@A�����jA��A	��>AZ[d3 ��i����K���J���@A������jA��Hd��k�Ad3 ��d��,�@�A�:����@�A�:d���@A
+����^@A���_jA����NAd��(�@�A���0@�A��3���A@���j@��@	(358 %NOT-NUMBER-ERROR 236 IL:FEQP 87 %NOT-NUMBER-ERROR 36 IL:FEQP)
(348 COMPLEX 336 COMPLEX 319 COMPLEX 311 COMPLEX 300 COMPLEX 292 COMPLEX 283 COMPLEX 274 COMPLEX 265 COMPLEX 253 COMPLEX 242 COMPLEX 227 IL:FLOATP 217 RATIO 209 RATIO 194 RATIO 186 RATIO 177 RATIO 162 RATIO 151 COMPLEX 135 COMPLEX 126 COMPLEX 118 RATIO 110 IL:FLOATP 93 IL:FLOATP 77 COMPLEX 61 COMPLEX 52 COMPLEX 44 RATIO 28 IL:FLOATP)
()
|expand-%/=| :D8
(IL:L (1 SI::$$MACRO-ENVIRONMENT 0 SI::$$MACRO-FORM)) !@!H�H�ggIJhhNIL
(21 %= 16 NOT)
()
(IL:SETF-MACRO-FUNCTION (QUOTE %/=) (QUOTE |expand-%/=|))
%> :D8
(IL:NAME > IL:L (1 Y 0 X)) �@1Hd3 �;�AYd3 ��@A���@A�I��A�@�A��A	��.AZd3 ��i����J���A�@�A��H��eA[d3 ��@�@�A����@�@�A��K���@�A��A�@���@	(230 %NOT-NONCOMPLEX-NUMBER-ERROR 65 %NOT-NONCOMPLEX-NUMBER-ERROR)
(219 RATIO 211 RATIO 202 RATIO 194 RATIO 186 RATIO 174 RATIO 166 RATIO 158 IL:FLOATP 147 RATIO 139 RATIO 123 RATIO 113 RATIO 103 RATIO 95 RATIO 87 IL:FLOATP 71 IL:FLOATP 55 RATIO 45 RATIO 37 RATIO 26 IL:FLOATP)
()
%< :D8
(IL:L (1 Y 0 X)) A@�NIL
NIL
()
|expand-%>=| :D8
(IL:L (1 SI::$$MACRO-ENVIRONMENT 0 SI::$$MACRO-FORM)) !@!H�H�ggIJhhNIL
(21 %< 16 NOT)
()
(IL:SETF-MACRO-FUNCTION (QUOTE %>=) (QUOTE |expand-%>=|))
|expand-%<=| :D8
(IL:L (1 SI::$$MACRO-ENVIRONMENT 0 SI::$$MACRO-FORM)) !@!H�H�ggIJhhNIL
(21 %> 16 NOT)
()
(IL:SETF-MACRO-FUNCTION (QUOTE %<=) (QUOTE |expand-%<=|))
(IL:PUTPROPS %= IL:DOPVAL (2 =))
(IL:PUTPROPS %> IL:DOPVAL (2 IL:GREATERP))
(IL:PUTPROPS %< IL:DOPVAL (2 IL:SWAP IL:GREATERP))
(IL:PUTPROPS %> IL:DMACRO (= . IL:GREATERP))
(IL:PUTPROPS %< IL:DMACRO (= . IL:LESSP))
(IL:PUTPROPS %>= IL:DMACRO (= . IL:GEQ))
(IL:PUTPROPS %<= IL:DMACRO (= . IL:LEQ))
(IL:MOVD (QUOTE %=) (QUOTE IL:%=))
(IL:MOVD (QUOTE %>) (QUOTE IL:GREATERP))
(IL:MOVD (QUOTE %<) (QUOTE IL:LESSP))
= :D8
(IL:L (0 ARGS)) 9ekH�o	�kalId3�	�JH�iIJa��hJk�Z��(35 %NOT-NUMBER-ERROR 17 ERROR)
NIL
( 12 "= requires at least one argument")
/= :D8
(IL:L (0 ARGS)) <ekH�o	�k!IdH�ia�Ik�[H�i�JKa��h�hK��Ik�Y��(17 ERROR)
NIL
( 12 "/= requires at least one argument")
< :D8
(IL:L (0 ARGS)) BekH�o	�kalId3���I	�JH�iJadI�h�Jk�Z��(42 %NOT-NUMBER-ERROR 17 ERROR)
(35 COMPLEX)
( 12 "< requires at least one argument")
> :D8
(IL:L (0 ARGS)) DekH�o	�kalId3���I	�JH�iJa�IK�hK�Jk�Z��(42 %NOT-NUMBER-ERROR 17 ERROR)
(35 COMPLEX)
( 12 "> requires at least one argument")
<= :D8
(IL:L (0 ARGS)) DekH�o	�kalId3���I	�JH�iJa�IK�hK�Jk�Z��(42 %NOT-NUMBER-ERROR 17 ERROR)
(35 COMPLEX)
( 12 "<= requires at least one argument")
>= :D8
(IL:L (0 ARGS)) BekH�o	�kalId3���I	�JH�iJadI�h�Jk�Z��(42 %NOT-NUMBER-ERROR 17 ERROR)
(35 COMPLEX)
( 12 ">= requires at least one argument")
%COMPARISON-OPTIMIZER :D8
(IL:L (3 THIRD-NUMBER 2 SECOND-NUMBER 1 FIRST-NUMBER 0 PREDICATE)) CB�gC�@ABhgog@o@gChhhABhNIL
(45 SI::%$$COMPARISON-MIDDLE-NUMBER 32 AND 22 IL:OPENLAMBDA 6 COMPILER:PASS)
( 38 (SI::%$$COMPARISON-FIRST-NUMBER SI::%$$COMPARISON-MIDDLE-NUMBER) 27 (SI::%$$COMPARISON-FIRST-NUMBER SI::%$$COMPARISON-MIDDLE-NUMBER))
|optimize-=| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) �
+@�	H�HZd��Jh�h�J�L�gM�gIKhKM]gogh__�M^�OhIh_�O�OggOh&_��ggOhh__�N��NIL
(128 SI::%$$=FIRST-NUMBER 123 %= 106 SI::%$$=FIRST-NUMBER 101 %= 64 AND 54 IL:OPENLAMBDA 38 %= 30 COMPILER:PASS)
( 59 (SI::%$$=FIRST-NUMBER))
(IL:PUTPROP (QUOTE =) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-=|) (GET (QUOTE =) (
QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-/=| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) 0@QH�HZd��Jh�h�J�L�gM��gIKhNIL
(39 %/= 30 COMPILER:PASS)
()
(IL:PUTPROP (QUOTE /=) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-/=|) (GET (QUOTE /=) (
QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-<| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) .@QH�HZd��J\d��L�gIKMg(37 %COMPARISON-OPTIMIZER)
(43 COMPILER:PASS 29 %<)
()
(IL:PUTPROP (QUOTE <) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-<|) (GET (QUOTE <) (
QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize->| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) .@QH�HZd��J\d��L�gIKMg(37 %COMPARISON-OPTIMIZER)
(43 COMPILER:PASS 29 %>)
()
(IL:PUTPROP (QUOTE >) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize->|) (GET (QUOTE >) (
QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-<=| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) .@QH�HZd��J\d��L�gIKMg(37 %COMPARISON-OPTIMIZER)
(43 COMPILER:PASS 29 %<=)
()
(IL:PUTPROP (QUOTE <=) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-<=|) (GET (QUOTE <=) (
QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize->=| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) .@QH�HZd��J\d��L�gIKMg(37 %COMPARISON-OPTIMIZER)
(43 COMPILER:PASS 29 %>=)
()
(IL:PUTPROP (QUOTE >=) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize->=|) (GET (QUOTE >=) (
QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-MIN| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) 7@QHd��Hh�h�H[d��Kh�h�K�J�M�oILhgNIL
(52 COMPILER:PASS)
( 40 (IL:OPENLAMBDA (SI::%$$MIN-X SI::%$$MIN-Y) (IF (< SI::%$$MIN-X SI::%$$MIN-Y) SI::%$$MIN-X SI::%$$MIN-Y)))
(IL:PUTPROP (QUOTE MIN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MIN|) (GET (QUOTE MIN
) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-MAX| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) 7@QHd��Hh�h�H[d��Kh�h�K�J�M�oILhgNIL
(52 COMPILER:PASS)
( 40 (IL:OPENLAMBDA (SI::%$$MAX-X SI::%$$MAX-Y) (IF (> SI::%$$MAX-X SI::%$$MAX-Y) SI::%$$MAX-X SI::%$$MAX-Y)))
(IL:PUTPROP (QUOTE MAX) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAX|) (GET (QUOTE MAX
) (QUOTE COMPILER:OPTIMIZER-LIST))))
%+ :D8
(IL:NAME + IL:L (1 Y 0 X)) �@AHd3 �J�AYd3 ��@A���@A�Id���@kA�A�����A	��SAZd3 ��i����Jd���@A�A������@oA�A�Hd�����A[d3 ��@�@�Ak��@�@��A�Kd��)�@�@�A�A�����$@jA�A�����A\d3 ��i���@�@�AjLd���@�@�Ao�����@�@�A�A�@	(461 %NOT-NUMBER-ERROR 454 %COMPLEX-+ 407 %COMPLEX-+ 369 %COMPLEX-+ 320 %COMPLEX-+ 287 %RATIO-PLUS 212 %RATIO-PLUS 168 %COMPLEX-+ 80 %NOT-NUMBER-ERROR 64 %RATIO-PLUS)
(447 COMPLEX 439 COMPLEX 431 COMPLEX 423 COMPLEX 413 COMPLEX 394 COMPLEX 386 COMPLEX 377 IL:FLOATP 360 COMPLEX 352 COMPLEX 344 RATIO 326 COMPLEX 313 COMPLEX 305 COMPLEX 293 COMPLEX 280 RATIO 272 RATIO 264 RATIO 256 RATIO 247 RATIO 234 RATIO 226 RATIO 218 IL:FLOATP 203 RATIO 195 RATIO 176 RATIO 161 COMPLEX 153 COMPLEX 139 COMPLEX 129 RATIO 121 RATIO 111 RATIO 102 IL:FLOATP 86 IL:FLOATP 70 COMPLEX 57 RATIO 49 RATIO 38 RATIO 26 IL:FLOATP)
( 402 0.0 147 0.0)
%- :D8
(IL:NAME - IL:L (1 Y 0 X)) �@AHd3 �L�AYd3 ��@A���@A�Id���@kjA��A�����A	��SAZd3 ��i����Jd���@A�A������@oA�A�Hd�����A[d3 ��@�@�jA�k��@�@��A�Kd��+�@�@�jA��A����� @jA�A�����A\d3 ��i���@�@�AjLd���@�@�Ao�����@�@�A�A�@	(467 %NOT-NUMBER-ERROR 460 %COMPLEX-- 413 %COMPLEX-- 375 %COMPLEX-- 326 %COMPLEX-- 293 %RATIO-PLUS 216 %RATIO-PLUS 170 %COMPLEX-- 82 %NOT-NUMBER-ERROR 66 %RATIO-PLUS)
(453 COMPLEX 445 COMPLEX 437 COMPLEX 429 COMPLEX 419 COMPLEX 400 COMPLEX 392 COMPLEX 383 IL:FLOATP 366 COMPLEX 358 COMPLEX 350 RATIO 332 COMPLEX 319 COMPLEX 311 COMPLEX 299 COMPLEX 286 RATIO 277 RATIO 268 RATIO 260 RATIO 251 RATIO 238 RATIO 230 RATIO 222 IL:FLOATP 205 RATIO 197 RATIO 178 RATIO 163 COMPLEX 155 COMPLEX 141 COMPLEX 131 RATIO 123 RATIO 113 RATIO 104 IL:FLOATP 88 IL:FLOATP 72 COMPLEX 59 RATIO 50 RATIO 38 RATIO 26 IL:FLOATP)
( 408 0.0 149 0.0)
%* :D8
(IL:NAME * IL:L (1 Y 0 X)) �@AHd3 �J�AYd3 ��@A���@A�Id���@kA�A�����A	��SAZd3 ��i����Jd���@A�A������@oA�A�Hd�����A[d3 ��@�@�Ak��@�@��A�Kd��)�@�@�A�A�����$@jA�A�����A\d3 ��i���@�@�AjLd���@�@�Ao�����@�@�A�A�@	(461 %NOT-NUMBER-ERROR 454 %COMPLEX-* 407 %COMPLEX-* 369 %COMPLEX-* 320 %COMPLEX-* 287 %RATIO-TIMES 212 %RATIO-TIMES 168 %COMPLEX-* 80 %NOT-NUMBER-ERROR 64 %RATIO-TIMES)
(447 COMPLEX 439 COMPLEX 431 COMPLEX 423 COMPLEX 413 COMPLEX 394 COMPLEX 386 COMPLEX 377 IL:FLOATP 360 COMPLEX 352 COMPLEX 344 RATIO 326 COMPLEX 313 COMPLEX 305 COMPLEX 293 COMPLEX 280 RATIO 272 RATIO 264 RATIO 256 RATIO 247 RATIO 234 RATIO 226 RATIO 218 IL:FLOATP 203 RATIO 195 RATIO 176 RATIO 161 COMPLEX 153 COMPLEX 139 COMPLEX 129 RATIO 121 RATIO 111 RATIO 102 IL:FLOATP 86 IL:FLOATP 70 COMPLEX 57 RATIO 49 RATIO 38 RATIO 26 IL:FLOATP)
( 402 0.0 147 0.0)
%/ :D8
(IL:NAME / IL:L (1 Y 0 X)) @d��A�@dA�j�A�@AHd3 �w�AYd3 �3�@d`�d`��A`�A`�@A�@A
+��@A�Id���@kA�A�����A	��SAZd3 ��i����Jd���A�@�A�����@oA�A�Hd�����A[d3 ��@�@�kA��@�@�A��Kd��)�@�@�A�A�����$@jA�A�����A\d3 ��i���@�@�AjLd���@�@�Ao�����@�@�A�A�@	(526 %NOT-NUMBER-ERROR 519 %COMPLEX-/ 472 %COMPLEX-/ 434 %COMPLEX-/ 385 %COMPLEX-/ 352 %RATIO-TIMES 277 %RATIO-TIMES 233 %COMPLEX-/ 145 %NOT-NUMBER-ERROR 129 %RATIO-TIMES 85 %BUILD-RATIO)
(512 COMPLEX 504 COMPLEX 496 COMPLEX 488 COMPLEX 478 COMPLEX 459 COMPLEX 451 COMPLEX 442 IL:FLOATP 425 COMPLEX 417 COMPLEX 409 RATIO 391 COMPLEX 378 COMPLEX 370 COMPLEX 358 COMPLEX 345 RATIO 337 RATIO 329 RATIO 321 RATIO 312 RATIO 299 RATIO 291 RATIO 283 IL:FLOATP 268 RATIO 260 RATIO 241 RATIO 226 COMPLEX 218 COMPLEX 204 COMPLEX 195 RATIO 185 RATIO 176 RATIO 167 IL:FLOATP 151 IL:FLOATP 135 COMPLEX 122 RATIO 114 RATIO 103 RATIO 91 IL:FLOATP 72 IL:MAX.INTEGER 64 IL:MIN.INTEGER 54 IL:MAX.INTEGER 45 IL:MIN.INTEGER)
( 467 0.0 212 0.0)
(IL:PUTPROPS %+ IL:DOPVAL (2 IL:PLUS2))
(IL:PUTPROPS %- IL:DOPVAL (2 IL:DIFFERENCE))
(IL:PUTPROPS %* IL:DOPVAL (2 IL:TIMES2))
(IL:PUTPROPS %+ IL:DMACRO (= . IL:PLUS))
(IL:PUTPROPS %- IL:DMACRO (= . IL:DIFFERENCE))
(IL:PUTPROPS %* IL:DMACRO (= . IL:TIMES))
(IL:MOVD (QUOTE %/) (QUOTE IL:%/))
(IL:MOVD (QUOTE %+) (QUOTE IL:\\SLOWPLUS2))
(IL:MOVD (QUOTE %-) (QUOTE IL:\\SLOWDIFFERENCE))
(IL:MOVD (QUOTE %*) (QUOTE IL:\\SLOWTIMES2))
+ :D8
(IL:L (0 ARGS)) .eHj�jkalId3�	�JH�IIJaԹJk�Z��(26 %NOT-NUMBER-ERROR)
NIL
()
- :D8
(IL:L (0 ARGS)) 6eHdj�o	k�jka�kalJH�IIJaչJk�Z��(19 ERROR)
NIL
( 14 "- requires at least one argument")
* :D8
(IL:L (0 ARGS)) .eHj�kkalId3�	�JH�IIJaֹJk�Z��(26 %NOT-NUMBER-ERROR)
NIL
()
/ :D8
(IL:L (0 ARGS)) =eHdj�o	k�ka	kalJH�IIJa
+�Jk�Z��(52 %/ 30 %RECIPROCOL 19 ERROR)
NIL
( 14 "/ requires at least one argument")
1+ :D8
(IL:L (0 NUMBER)) @k�NIL
NIL
()
1- :D8
(IL:L (0 NUMBER)) @k�NIL
NIL
()
%RECIPROCOL :D8
(IL:L (0 NUMBER)) @�o@�k@
+(18 %/)
NIL
( 8 1.0)
|optimize-+| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) %@1H�j�HZ�I�gIKh�J��NIL
(25 %+)
()
(IL:PUTPROP (QUOTE +) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-+|) (GET (QUOTE +) (
QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize--| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) 3@QH�HZ�gjIhI�J\�K�gKMh�L��NIL
(38 %- 16 %-)
()
(IL:PUTPROP (QUOTE -) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize--|) (GET (QUOTE -) (
QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-*| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) %@1H�k�HZ�I�gIKh�J��NIL
(25 %*)
()
(IL:PUTPROP (QUOTE *) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-*|) (GET (QUOTE *) (
QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-/| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) 1@QH�HZ�gIhI�J\�K�gKMh�L��NIL
(36 %/ 16 %RECIPROCOL)
()
(IL:PUTPROP (QUOTE /) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-/|) (GET (QUOTE /) (
QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-1+| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) @gHoNIL
(10 +)
( 16 (1))
(IL:PUTPROP (QUOTE 1+) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-1+|) (GET (QUOTE 1+) (
QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-1-| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) @gHoNIL
(10 -)
( 16 (1))
(IL:PUTPROP (QUOTE 1-) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-1-|) (GET (QUOTE 1-) (
QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROPS + IL:DMACRO (IL:ARGS (IL:|if| (IL:GREATERP (IL:LENGTH IL:ARGS) 1) IL:|then| (IL:BQUOTE (
IL:PLUS (IL:\\\,@ IL:ARGS))) IL:|else| (QUOTE IL:IGNOREMACRO))))
(IL:PUTPROPS * IL:DMACRO (IL:ARGS (IL:|if| (IL:GREATERP (IL:LENGTH IL:ARGS) 1) IL:|then| (IL:BQUOTE (
IL:TIMES (IL:\\\,@ IL:ARGS))) IL:|else| (QUOTE IL:IGNOREMACRO))))
(IL:MOVD (QUOTE +) (QUOTE IL:PLUS))
(IL:MOVD (QUOTE *) (QUOTE IL:TIMES))
%GCD :D8
(IL:L (1 Y 0 X)) �j@�j@Հ@bjA�jAՀAb@j�Adj�@k�@k�kj@k�k�Ak�k�H@dk�k��jAհ@m��b�Am��b�HkԸ��m��Ydj�@H�k�k�Im��Y��Ij�Ib�jI�b�@Aհ�NIL
NIL
()
%LCM :D8
(IL:L (1 Y 0 X)) E@k�AAk�@@j�Aj�jj@�j@Հ@bjA�jAՀAb@A
+Hk�@A�@H�A�(50 %GCD)
NIL
()
GCD :D8
(IL:L (0 ARGS)) FeHdj�jk�kajI�jI�Ikala
+lJH�Idk�IJa
+�Jk�Z��(61 %GCD 38 %GCD)
NIL
()
LCM :D8
(IL:L (0 ARGS)) FeHdj�kk�kajI�jI�Ikala
+lJH�Idj�IJa
+�Jk�Z��(61 %LCM 38 %LCM)
NIL
()
IL:|optimize-MINUS| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) @gjHhNIL
(10 -)
()
(IL:PUTPROP (QUOTE IL:MINUS) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MINUS|) (GET 
(QUOTE IL:MINUS) (QUOTE COMPILER:OPTIMIZER-LIST))))
IL:|optimize-PLUS| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) %@1H�j�HZ�I�gIKh�J��NIL
(25 IL:PLUS2)
()
(IL:PUTPROP (QUOTE IL:PLUS) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-PLUS|) (GET (
QUOTE IL:PLUS) (QUOTE COMPILER:OPTIMIZER-LIST))))
IL:|optimize-IPLUS| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) 7@1H�j�H�HZ�I�gIKh�J��gIoNIL
(44 IL:IPLUS2 29 IL:IPLUS2)
( 50 (0))
(IL:PUTPROP (QUOTE IL:IPLUS) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-IPLUS|) (GET 
(QUOTE IL:IPLUS) (QUOTE COMPILER:OPTIMIZER-LIST))))
IL:|optimize-FPLUS| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) %@1H�j�HZ�I�gIKh�J��NIL
(25 IL:FPLUS2)
()
(IL:PUTPROP (QUOTE IL:FPLUS) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-FPLUS|) (GET 
(QUOTE IL:FPLUS) (QUOTE COMPILER:OPTIMIZER-LIST))))
IL:|optimize-TIMES| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) %@1H�j�HZ�I�gIKh�J��NIL
(25 IL:TIMES2)
()
(IL:PUTPROP (QUOTE IL:TIMES) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-TIMES|) (GET 
(QUOTE IL:TIMES) (QUOTE COMPILER:OPTIMIZER-LIST))))
IL:|optimize-ITIMES| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) %@1H�j�HZ�I�gIKh�J��NIL
(25 IL:ITIMES2)
()
(IL:PUTPROP (QUOTE IL:ITIMES) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-ITIMES|) (
GET (QUOTE IL:ITIMES) (QUOTE COMPILER:OPTIMIZER-LIST))))
IL:|optimize-FTIMES| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) )@1H�o�HZ�I�gIKh�J��NIL
(29 IL:FTIMES2)
( 12 1.0)
(IL:PUTPROP (QUOTE IL:FTIMES) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-FTIMES|) (
GET (QUOTE IL:FTIMES) (QUOTE COMPILER:OPTIMIZER-LIST))))
IL:|optimize-RSH| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) !@!H�H�gIgJhhNIL
(22 IL:IMINUS 16 IL:LSH)
()
(IL:PUTPROP (QUOTE IL:RSH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-RSH|) (GET (
QUOTE IL:RSH) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROPS IL:PLUS2 IL:DOPVAL (2 IL:PLUS2))
(IL:PUTPROPS IL:IPLUS2 IL:DOPVAL (2 IL:IPLUS2))
(IL:PUTPROPS IL:FPLUS2 IL:DOPVAL (2 IL:FPLUS2))
(IL:PUTPROPS IL:TIMES2 IL:DOPVAL (2 IL:TIMES2))
(IL:PUTPROPS IL:ITIMES2 IL:DOPVAL (2 IL:ITIMES2))
(IL:PUTPROPS IL:FTIMES2 IL:DOPVAL (2 IL:FTIMES2))
ISQRT :D8
(IL:L (0 INTEGER)) r@3 �j@�.ggog@g@go
	�@	1kHk�m���YdHk�k�m��j�ԺIJ�m��Jk�I�IKdd�@��KY��(58 INTEGER-LENGTH 51 ERROR)
(40 :MESSAGE 34 :VALUE 28 :NAME 18 :EXPECTED-TYPE 13 XCL:TYPE-MISMATCH)
( 45 "a nonnegative integer" 23 (INTEGER 0))
ABS :D8
(IL:L (0 NUMBER)) o@Hd3 ��j@�j@�@��o@��o@�Hd��'�j@���j@��@�
+��@	@	(108 %NOT-NUMBER-ERROR 101 %COMPLEX-ABS 88 %MAKE-RATIO)
(94 COMPLEX 81 RATIO 72 RATIO 60 RATIO 50 RATIO 24 IL:FLOATP)
( 40 0.0 31 0.0)
|expand-%ABS| :D8
(IL:L (1 SI::$$MACRO-ENVIRONMENT 0 SI::$$MACRO-FORM)) @oHhNIL
NIL
( 10 (IL:OPENLAMBDA (X) (IF (< X 0) (- 0 X) X)))
(IL:SETF-MACRO-FUNCTION (QUOTE %ABS) (QUOTE |expand-%ABS|))
SIGNUM :D8
(IL:L (0 NUMBER)) Tj@��@@HY��I3 �@j�km�Hd���@j�oo��@d	
+@	(81 %NOT-NUMBER-ERROR 74 %/ 69 ABS)
(61 COMPLEX 37 IL:FLOATP 16 RATIO)
( 55 -1.0 49 1.0)
|expand-%SIGNUM| :D8
(IL:L (1 SI::$$MACRO-ENVIRONMENT 0 SI::$$MACRO-FORM)) @oHhNIL
NIL
( 10 (IL:OPENLAMBDA (X) (COND ((EQ X 0) 0) ((PLUSP X) 1) (T -1))))
(IL:SETF-MACRO-FUNCTION (QUOTE %SIGNUM) (QUOTE |expand-%SIGNUM|))
XCL::STRUNCATE :D8
(IL:L (1 DIVISOR 0 NUMBER)) tA�9@d���@	d���@�@��3 �@@	Hd3 ��@A���@�A���H��@A
+	A	(113 %NOT-NONCOMPLEX-NUMBER-ERROR 106 XCL::STRUNCATE 101 %/ 56 %NOT-NONCOMPLEX-NUMBER-ERROR 17 IL:\\FIXP.FROM.FLOATP)
(93 RATIO 75 IL:FLOATP 41 RATIO 33 RATIO 24 RATIO 9 IL:FLOATP)
()
XCL::SFLOOR :D8
(IL:L (1 DIVISOR 0 NUMBER)) GA�@	H@��Hj@��Hk�@A
+@A
+j��Hjd@�A��Hk�A��Hk�(43 REM 33 XCL::STRUNCATE 8 XCL::STRUNCATE)
NIL
()
XCL::SCEILING :D8
(IL:L (1 DIVISOR 0 NUMBER)) BA�@	H@��Hj@��Hk�@A
+@A
+j��jd@�A�Hk�A��H(43 REM 33 XCL::STRUNCATE 8 XCL::STRUNCATE)
NIL
()
XCL::SROUND :D8
(IL:L (1 DIVISOR 0 NUMBER)) )A�@	@�A�@A�	@A
+	(38 IL:FIXR 33 %/ 25 IL:FIXR 7 IL:FIXR)
NIL
()
XCL::|optimize-STRUNCATE| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) $@!H�Hd�Z3 �gIJhgNIL
(33 COMPILER:PASS 21 IL:IQUOTIENT)
()
(IL:PUTPROP (QUOTE XCL::STRUNCATE) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
XCL::|optimize-STRUNCATE|) (GET (QUOTE XCL::STRUNCATE) (QUOTE COMPILER:OPTIMIZER-LIST))))
XCL::|optimize-SROUND| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) @!H�HZ�J�gIhgNIL
(28 COMPILER:PASS 18 IL:FIXR)
()
(IL:PUTPROP (QUOTE XCL::SROUND) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE XCL::|optimize-SROUND|)
 (GET (QUOTE XCL::SROUND) (QUOTE COMPILER:OPTIMIZER-LIST))))
TRUNCATE :D8
(IL:L (1 DIVISOR 0 NUMBER)) %A�@	�@A
+A�@H�@AH�չHI$(15 XCL::STRUNCATE 7 XCL::STRUNCATE)
NIL
()
FLOOR :D8
(IL:L (1 DIVISOR 0 NUMBER)) %A�@	�@A
+A�@H�@AH�չHI$(15 XCL::SFLOOR 7 XCL::SFLOOR)
NIL
()
CEILING :D8
(IL:L (1 DIVISOR 0 NUMBER)) %A�@	�@A
+A�@H�@AH�չHI$(15 XCL::SCEILING 7 XCL::SCEILING)
NIL
()
ROUND :D8
(IL:L (1 DIVISOR 0 NUMBER)) %A�@	�@A
+A�@H�@AH�չHI$(15 XCL::SROUND 7 IL:FIXR)
NIL
()
%INTEGER-COERCE-OPTIMIZER :D8
(IL:L (4 FLOAT-RESULT 3 CONTEXT 2 DIVISOR 1 NUMBER 0 SINGLE-VALUE-FN)) -C�k�@ABd�hD�gHhHgNIL
(42 COMPILER:PASS 30 FLOAT 5 COMPILER:CONTEXT)
()
|optimize-TRUNCATE| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) (@QH�HZd��J\�L�gIKM(37 %INTEGER-COERCE-OPTIMIZER)
(29 XCL::STRUNCATE)
()
(IL:PUTPROP (QUOTE TRUNCATE) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-TRUNCATE|) (GET 
(QUOTE TRUNCATE) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-FLOOR| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) (@QH�HZd��J\�L�gIKM(37 %INTEGER-COERCE-OPTIMIZER)
(29 XCL::SFLOOR)
()
(IL:PUTPROP (QUOTE FLOOR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-FLOOR|) (GET (QUOTE
 FLOOR) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-CEILING| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) (@QH�HZd��J\�L�gIKM(37 %INTEGER-COERCE-OPTIMIZER)
(29 XCL::SCEILING)
()
(IL:PUTPROP (QUOTE CEILING) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-CEILING|) (GET (
QUOTE CEILING) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-ROUND| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) (@QH�HZd��J\�L�gIKM(37 %INTEGER-COERCE-OPTIMIZER)
(29 XCL::SROUND)
()
(IL:PUTPROP (QUOTE ROUND) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ROUND|) (GET (QUOTE
 ROUND) (QUOTE COMPILER:OPTIMIZER-LIST))))
FTRUNCATE :D8
(IL:L (1 DIVISOR 0 NUMBER)) *A�@	�@A
+A�@H�@AH�չHI$(15 XCL::STRUNCATE 7 XCL::STRUNCATE)
(35 IL:FLOATP)
()
FFLOOR :D8
(IL:L (1 DIVISOR 0 NUMBER)) *A�@	�@A
+A�@H�@AH�չHI$(15 XCL::SFLOOR 7 XCL::SFLOOR)
(35 IL:FLOATP)
()
FCEILING :D8
(IL:L (1 DIVISOR 0 NUMBER)) *A�@	�@A
+A�@H�@AH�չHI$(15 XCL::SCEILING 7 XCL::SCEILING)
(35 IL:FLOATP)
()
FROUND :D8
(IL:L (1 DIVISOR 0 NUMBER)) *A�@	�@A
+A�@H�@AH�չHI$(15 XCL::SROUND 7 IL:FIXR)
(35 IL:FLOATP)
()
|optimize-FTRUNCATE| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) *@QH�HZd��J\�L�gIKMi
(39 %INTEGER-COERCE-OPTIMIZER)
(29 XCL::STRUNCATE)
()
(IL:PUTPROP (QUOTE FTRUNCATE) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-FTRUNCATE|) (
GET (QUOTE FTRUNCATE) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-FFLOOR| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) *@QH�HZd��J\�L�gIKMi
(39 %INTEGER-COERCE-OPTIMIZER)
(29 XCL::SFLOOR)
()
(IL:PUTPROP (QUOTE FFLOOR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-FFLOOR|) (GET (
QUOTE FFLOOR) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-FCEILING| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) *@QH�HZd��J\�L�gIKMi
(39 %INTEGER-COERCE-OPTIMIZER)
(29 XCL::SCEILING)
()
(IL:PUTPROP (QUOTE FCEILING) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-FCEILING|) (GET 
(QUOTE FCEILING) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-FROUND| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) *@QH�HZd��J\�L�gIKMi
(39 %INTEGER-COERCE-OPTIMIZER)
(29 XCL::SROUND)
()
(IL:PUTPROP (QUOTE FROUND) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-FROUND|) (GET (
QUOTE FROUND) (QUOTE COMPILER:OPTIMIZER-LIST))))
MOD :D8
(IL:L (1 DIVISOR 0 NUMBER)) l@�A�D@�A�hHdI��I����Zddh���hI��Hh�H��J�I����J�@A
+jH��jA�@j�j@�HA�H(82 REM)
(31 IL:FLOATP)
()
REM :D8
(IL:L (1 DIVISOR 0 NUMBER)) D@d3 ��A3 �@A�@�A�"@�A�HdI��I�����@A@A
+��(63 XCL::STRUNCATE)
(43 IL:FLOATP)
()
%LOGICAL-OPTIMIZER :D8
(IL:L (4 MORE-INTEGERS 3 SECOND-INTEGER 2 FIRST-INTEGER 1 IDENTITY 0 BINARY-LOGICAL-FN)) 1B�AC�BD�@BCh@BCh!DY�H�@HJh�I��NIL
NIL
()
|optimize-LOGXOR| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE) IL:F 5 COMPILER::*NEW-COMPILER-IS-EXPANDING*) ,@AH�HZ�J�U�L�gjIKL
g(35 %LOGICAL-OPTIMIZER)
(41 COMPILER:PASS 25 LOGXOR)
()
(IL:PUTPROP (QUOTE LOGXOR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-LOGXOR|) (GET (
QUOTE LOGXOR) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-LOGAND| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE) IL:F 5 COMPILER::*NEW-COMPILER-IS-EXPANDING*) .@AH�HZ�J�U�L�gm�IKL
g(37 %LOGICAL-OPTIMIZER)
(43 COMPILER:PASS 26 LOGAND)
()
(IL:PUTPROP (QUOTE LOGAND) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-LOGAND|) (GET (
QUOTE LOGAND) (QUOTE COMPILER:OPTIMIZER-LIST))))
%LOGIOR :D8
(IL:L (1 Y 0 X)) @A�NIL
NIL
()
|expand-%LOGEQV| :D8
(IL:L (1 SI::$$MACRO-ENVIRONMENT 0 SI::$$MACRO-FORM)) !@!H�H�ggIJhhNIL
(21 LOGXOR 16 LOGNOT)
()
(IL:SETF-MACRO-FUNCTION (QUOTE %LOGEQV) (QUOTE |expand-%LOGEQV|))
(IL:PUTPROPS %LOGIOR IL:DOPVAL (2 IL:LOGOR2))
(IL:PUTPROPS %LOGIOR IL:DMACRO (= . IL:LOGOR))
LOGIOR :D8
(IL:L (0 ARGS)) ;eHdj�jdk�kal�kala�kala�lJH�IIJa�Jk�Z��NIL
NIL
()
LOGEQV :D8
(IL:L (0 ARGS)) EeHdj�m�dk�kal�kalam���kalam���lJH�IIJam���Jk�Z��NIL
NIL
()
|optimize-LOGIOR| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) !@AH�HZ�J�gjIKL
(30 %LOGICAL-OPTIMIZER)
(20 %LOGIOR)
()
(IL:PUTPROP (QUOTE LOGIOR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-LOGIOR|) (GET (
QUOTE LOGIOR) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-LOGEQV| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) "@AH�HZ�J�gm�IKL
(31 %LOGICAL-OPTIMIZER)
(20 %LOGEQV)
()
(IL:PUTPROP (QUOTE LOGEQV) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-LOGEQV|) (GET (
QUOTE LOGEQV) (QUOTE COMPILER:OPTIMIZER-LIST))))
LOGNAND :D8
(IL:L (1 INTEGER2 0 INTEGER1)) @A�m��NIL
NIL
()
LOGNOR :D8
(IL:L (1 INTEGER2 0 INTEGER1)) @A�m��NIL
NIL
()
LOGANDC1 :D8
(IL:L (1 INTEGER2 0 INTEGER1)) @m��A�NIL
NIL
()
LOGANDC2 :D8
(IL:L (1 INTEGER2 0 INTEGER1)) @Am���NIL
NIL
()
LOGORC1 :D8
(IL:L (1 INTEGER2 0 INTEGER1)) @m��A�NIL
NIL
()
LOGORC2 :D8
(IL:L (1 INTEGER2 0 INTEGER1)) @Am���NIL
NIL
()
|optimize-LOGNAND| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) !@!H�H�ggIJhhNIL
(21 LOGAND 16 LOGNOT)
()
(IL:PUTPROP (QUOTE LOGNAND) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-LOGNAND|) (GET (
QUOTE LOGNAND) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-LOGNOR| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) !@!H�H�ggIJhhNIL
(21 LOGIOR 16 LOGNOT)
()
(IL:PUTPROP (QUOTE LOGNOR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-LOGNOR|) (GET (
QUOTE LOGNOR) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-LOGANDC1| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) !@!H�H�ggIhJhNIL
(21 LOGNOT 16 LOGAND)
()
(IL:PUTPROP (QUOTE LOGANDC1) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-LOGANDC1|) (GET 
(QUOTE LOGANDC1) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-LOGANDC2| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) !@!H�H�gIgJhhNIL
(22 LOGNOT 16 LOGAND)
()
(IL:PUTPROP (QUOTE LOGANDC2) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-LOGANDC2|) (GET 
(QUOTE LOGANDC2) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-LOGORC1| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) !@!H�H�ggIhJhNIL
(21 LOGNOT 16 LOGIOR)
()
(IL:PUTPROP (QUOTE LOGORC1) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-LOGORC1|) (GET (
QUOTE LOGORC1) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-LOGORC2| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) !@!H�H�gIgJhhNIL
(22 LOGNOT 16 LOGIOR)
()
(IL:PUTPROP (QUOTE LOGORC2) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-LOGORC2|) (GET (
QUOTE LOGORC2) (QUOTE COMPILER:OPTIMIZER-LIST))))
(XCL::SET-CONSTANTP (QUOTE BOOLE-CLR) NIL)
(IL:SETQ BOOLE-CLR 0)
(PROCLAIM (QUOTE (SI::CONSTANT BOOLE-CLR)))
(XCL::SET-CONSTANTP (QUOTE BOOLE-SET) NIL)
(IL:SETQ BOOLE-SET 1)
(PROCLAIM (QUOTE (SI::CONSTANT BOOLE-SET)))
(XCL::SET-CONSTANTP (QUOTE BOOLE-1) NIL)
(IL:SETQ BOOLE-1 2)
(PROCLAIM (QUOTE (SI::CONSTANT BOOLE-1)))
(XCL::SET-CONSTANTP (QUOTE BOOLE-2) NIL)
(IL:SETQ BOOLE-2 3)
(PROCLAIM (QUOTE (SI::CONSTANT BOOLE-2)))
(XCL::SET-CONSTANTP (QUOTE BOOLE-C1) NIL)
(IL:SETQ BOOLE-C1 4)
(PROCLAIM (QUOTE (SI::CONSTANT BOOLE-C1)))
(XCL::SET-CONSTANTP (QUOTE BOOLE-C2) NIL)
(IL:SETQ BOOLE-C2 5)
(PROCLAIM (QUOTE (SI::CONSTANT BOOLE-C2)))
(XCL::SET-CONSTANTP (QUOTE BOOLE-AND) NIL)
(IL:SETQ BOOLE-AND 6)
(PROCLAIM (QUOTE (SI::CONSTANT BOOLE-AND)))
(XCL::SET-CONSTANTP (QUOTE BOOLE-IOR) NIL)
(IL:SETQ BOOLE-IOR 7)
(PROCLAIM (QUOTE (SI::CONSTANT BOOLE-IOR)))
(XCL::SET-CONSTANTP (QUOTE BOOLE-XOR) NIL)
(IL:SETQ BOOLE-XOR 8)
(PROCLAIM (QUOTE (SI::CONSTANT BOOLE-XOR)))
(XCL::SET-CONSTANTP (QUOTE BOOLE-EQV) NIL)
(IL:SETQ BOOLE-EQV 9)
(PROCLAIM (QUOTE (SI::CONSTANT BOOLE-EQV)))
(XCL::SET-CONSTANTP (QUOTE BOOLE-NAND) NIL)
(IL:SETQ BOOLE-NAND 10)
(PROCLAIM (QUOTE (SI::CONSTANT BOOLE-NAND)))
(XCL::SET-CONSTANTP (QUOTE BOOLE-NOR) NIL)
(IL:SETQ BOOLE-NOR 11)
(PROCLAIM (QUOTE (SI::CONSTANT BOOLE-NOR)))
(XCL::SET-CONSTANTP (QUOTE BOOLE-ANDC1) NIL)
(IL:SETQ BOOLE-ANDC1 12)
(PROCLAIM (QUOTE (SI::CONSTANT BOOLE-ANDC1)))
(XCL::SET-CONSTANTP (QUOTE BOOLE-ANDC2) NIL)
(IL:SETQ BOOLE-ANDC2 13)
(PROCLAIM (QUOTE (SI::CONSTANT BOOLE-ANDC2)))
(XCL::SET-CONSTANTP (QUOTE BOOLE-ORC1) NIL)
(IL:SETQ BOOLE-ORC1 14)
(PROCLAIM (QUOTE (SI::CONSTANT BOOLE-ORC1)))
(XCL::SET-CONSTANTP (QUOTE BOOLE-ORC2) NIL)
(IL:SETQ BOOLE-ORC2 15)
(PROCLAIM (QUOTE (SI::CONSTANT BOOLE-ORC2)))
BOOLE :D8
(IL:L (2 INTEGER2 1 INTEGER1 0 OP)) �@dj�jdk�m�l�A@dl�Bl�Am��@dl�Bm��l�AB�@dl�AB�l�AB�@dl	�ABm���l
+�AB�m��@dl�AB�m��l�Am��B�@dl
�ABm���l�Am��B�@l�ABm���o@
+(173 ERROR)
NIL
( 167 "Not a valid op: ~s")
LOGTEST :D8
(IL:L (1 INTEGER2 0 INTEGER1)) 	@A�j�h�NIL
NIL
()
LOGBITP :D8
(IL:L (1 INTEGER 0 INDEX)) Aj@��k�k�NIL
NIL
()
|definline-LOGBITP| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) @oHNIL
NIL
( 9 (LAMBDA (INDEX INTEGER) (BLOCK LOGBITP (EQ 1 (LOGAND 1 (ASH INTEGER (- INDEX)))))))
(IL:PUTPROP (QUOTE LOGBITP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-LOGBITP|) (GET (
QUOTE LOGBITP) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-LOGTEST| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) +@!H�H�ggjgIJhhhNIL
(27 LOGAND 21 EQ 16 NOT)
()
(IL:PUTPROP (QUOTE LOGTEST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-LOGTEST|) (GET (
QUOTE LOGTEST) (QUOTE COMPILER:OPTIMIZER-LIST))))
ASH :D8
(IL:L (1 COUNT 0 INTEGER)) @A�NIL
NIL
()
(IL:PUTPROPS ASH IL:DOPVAL (2 IL:LSH))
(IL:PUTPROPS ASH IL:DMACRO (= . IL:LSH))
LOGCOUNT :D8
(IL:L (0 INTEGER)) !j@�@m��b�@��@	@	(30 %BIGNUM-LOGCOUNT 23 %LOGCOUNT)
(16 BIGNUM)
()
%LOGCOUNT :D8
(IL:L (0 POSITIVE-INTEGER)) j@j�HHkԸ@dk��b��NIL
NIL
()
%BIGNUM-LOGCOUNT :D8
(IL:L (0 BIGNUM)) "@�j"HZ�I�IK	ԹJ��(26 %LOGCOUNT)
(5 BIGNUM)
()
INTEGER-LENGTH :D8
(IL:L (0 INTEGER)) �j@�m�@�b�o@��n@�=l@�l@�l@�@ll@�lll@@�l @�lll�@�lln@� n@�n@�l	l
+n@�lln@@�n @�l
ln�@�lll@m��	�(165 INTEGER-LENGTH)
NIL
( 15 65536)
%LLSH8 :D8
(IL:L (0 X)) @�NIL
NIL
()
%LLSH1 :D8
(IL:L (0 X)) @�NIL
NIL
()
%LRSH8 :D8
(IL:L (0 X)) @�NIL
NIL
()
%LRSH1 :D8
(IL:L (0 X)) @�NIL
NIL
()
(IL:PUTPROPS %LLSH8 IL:DOPVAL (1 IL:LLSH8))
(IL:PUTPROPS %LLSH1 IL:DOPVAL (1 IL:LLSH1))
(IL:PUTPROPS %LRSH8 IL:DOPVAL (1 IL:LRSH8))
(IL:PUTPROPS %LRSH1 IL:DOPVAL (1 IL:LRSH1))
IL:|optimize-LLSH| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE) IL:F 6 COMPILER::*NEW-COMPILER-IS-EXPANDING*) ^@QH�H�V�J	�J	[3 �g�jL��I�lK�gMh�Klջ��Kj�gMh�Kk�[��M(28 EVAL 20 CONSTANTP)
(79 %LLSH1 58 %LLSH8 38 COMPILER:PASS)
()
(IL:PUTPROP (QUOTE IL:LLSH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-LLSH|) (GET (
QUOTE IL:LLSH) (QUOTE COMPILER:OPTIMIZER-LIST))))
IL:|optimize-LRSH| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE) IL:F 6 COMPILER::*NEW-COMPILER-IS-EXPANDING*) ^@QH�H�V�J	�J	[3 �g�jL��I�lK�gMh�Klջ��Kj�gMh�Kk�[��M(28 EVAL 20 CONSTANTP)
(79 %LRSH1 58 %LRSH8 38 COMPILER:PASS)
()
(IL:PUTPROP (QUOTE IL:LRSH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-LRSH|) (GET (
QUOTE IL:LRSH) (QUOTE COMPILER:OPTIMIZER-LIST))))
BYTE :D8
(IL:L (1 POSITION 0 SIZE)) -j@�jA�o@An@�nA�@l�A�@A(19 ERROR)
NIL
( 12 "Not a valid bytespec: ~s ~s")
BYTE-SIZE :D8
(IL:L (0 BYTESPEC)) @d�m��NIL
NIL
()
|definline-BYTE-SIZE| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) @oHNIL
NIL
( 9 (LAMBDA (BYTESPEC) (BLOCK BYTE-SIZE (IF (TYPEP BYTESPEC (QUOTE FIXNUM)) (ASH BYTESPEC -8) (CAR BYTESPEC)))))
(IL:PUTPROP (QUOTE BYTE-SIZE) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-BYTE-SIZE|) (
GET (QUOTE BYTE-SIZE) (QUOTE COMPILER:OPTIMIZER-LIST))))
BYTE-POSITION :D8
(IL:L (0 BYTESPEC)) @d�l��NIL
NIL
()
|definline-BYTE-POSITION| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) @oHNIL
NIL
( 9 (LAMBDA (BYTESPEC) (BLOCK BYTE-POSITION (IF (TYPEP BYTESPEC (QUOTE FIXNUM)) (LOGAND BYTESPEC 255) (CDR BYTESPEC)))))
(IL:PUTPROP (QUOTE BYTE-POSITION) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|definline-BYTE-POSITION|) (GET (QUOTE BYTE-POSITION) (QUOTE COMPILER:OPTIMIZER-LIST))))
OPTIMIZE-BYTE :D8
(IL:L (1 POSITION 0 SIZE)) C@H�H�jI�h�Il��h��#AH�H�jI�h�Il��h��@l�A�gNIL
(64 COMPILER:PASS)
()
(IL:PUTPROPS BYTE IL:DMACRO (IL:ARGS (OPTIMIZE-BYTE (CAR IL:ARGS) (CADR IL:ARGS))))
LDB :D8
(IL:L (1 INTEGER 0 BYTESPEC)) $@d�m��@d�l��AjI��kH�k��NIL
NIL
()
DPB :D8
(IL:L (2 INTEGER 1 BYTESPEC 0 NEWBYTE)) /Ad�m��Ad�l��@kH�k��I�BkH�k�I�m����NIL
NIL
()
MASK-FIELD :D8
(IL:L (1 INTEGER 0 BYTESPEC)) "@d�m��@d�l��AkH�k�I��NIL
NIL
()
DEPOSIT-FIELD :D8
(IL:L (2 INTEGER 1 BYTESPEC 0 NEWBYTE)) ,Ad�m��!Ad�l���kH�k�I�@J�BJm����NIL
NIL
()
%CONSTANT-BYTESPEC-P :D8
(IL:L (0 BYTESPEC)) *@d�$�!@g�@3 �@3 �@	(39 EVAL)
(15 BYTE)
()
|optimize-LDB| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) a@QH�H�I	[�gd�m��Kd�l����jM��gJkL�k�hggJjM�hkL�k�h(17 %CONSTANT-BYTESPEC-P)
(77 ASH 72 LOGAND 56 LOGAND 25 COMPILER:PASS)
()
(IL:PUTPROP (QUOTE LDB) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-LDB|) (GET (QUOTE LDB
) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-DPB| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) �@qH�HZ�J�K	]�gd�m��Md�l��_��jO��-ggIkN�k�hgLkN�k�m��hhgggIkN�k�hOhgLkN�k�O�m��hh(22 %CONSTANT-BYTESPEC-P)
(139 LOGAND 118 LOGAND 113 ASH 108 LOGIOR 85 LOGAND 70 LOGAND 65 LOGIOR 30 COMPILER:PASS)
()
(IL:PUTPROP (QUOTE DPB) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-DPB|) (GET (QUOTE DPB
) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-MASK-FIELD| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) C@QH�H�I	[�gd�m��Kd�l����gJkL�k�M�h(17 %CONSTANT-BYTESPEC-P)
(52 LOGAND 25 COMPILER:PASS)
()
(IL:PUTPROP (QUOTE MASK-FIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MASK-FIELD|) (
GET (QUOTE MASK-FIELD) (QUOTE COMPILER:OPTIMIZER-LIST))))
|optimize-DEPOSIT-FIELD| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) h	@�H�HZ�J�K	]�gd�m���Md�l��_�kN�k�O�_�ggIOhgLOm��hh(22 %CONSTANT-BYTESPEC-P)
(87 LOGAND 75 LOGAND 70 LOGIOR 30 COMPILER:PASS)
()
(IL:PUTPROP (QUOTE DEPOSIT-FIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|optimize-DEPOSIT-FIELD|) (GET (QUOTE DEPOSIT-FIELD) (QUOTE COMPILER:OPTIMIZER-LIST))))
LDB-TEST :D8
(IL:L (1 INTEGER 0 BYTESPEC)) 
@A
+j�h�(6 LDB)
NIL
()
|optimize-LDB-TEST| :D8
(IL:L (2 IL:$$CTX 1 IL:$$ENV 0 IL:$$WHOLE)) +@!H�H�ggjgIJhhhNIL
(27 LDB 21 EQ 16 NOT)
()
(IL:PUTPROP (QUOTE LDB-TEST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-LDB-TEST|) (GET 
(QUOTE LDB-TEST) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROPS IL:CMLARITH IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
(IL:PUTPROPS IL:CMLARITH IL:FILETYPE COMPILE-FILE)
(IL:PUTPROPS IL:CMLARITH IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1989 1990 1992)
)
NIL
\ No newline at end of file
diff --git a/CLTL2/CMLARRAY b/CLTL2/CMLARRAY
new file mode 100644
index 00000000..6dc46996
--- /dev/null
+++ b/CLTL2/CMLARRAY
@@ -0,0 +1,2434 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+(FILECREATED "18-Oct-93 10:11:11" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLARRAY.;2" 114839 
+
+      |previous| |date:| "12-Oct-93 16:35:09" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLARRAY.;1")
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT CMLARRAYCOMS)
+
+(RPAQQ CMLARRAYCOMS
+       (
+        (* |;;| "Contains table driven macros")
+
+        (DECLARE\: DONTCOPY EVAL@COMPILE (EXPORT (FILES (SYSLOAD FROM VALUEOF DIRECTORIES)
+                                                        CMLARRAY-SUPPORT)))
+        
+        (* |;;| "User entry points")
+
+        (FUNCTIONS LISP:ADJUST-ARRAY LISP:ADJUSTABLE-ARRAY-P LISP:ARRAY-DIMENSION 
+               LISP:ARRAY-DIMENSIONS LISP:ARRAY-ELEMENT-TYPE LISP:ARRAY-HAS-FILL-POINTER-P 
+               ARRAY-NEEDS-INDIRECTION-P LISP:ARRAY-RANK LISP:ARRAY-TOTAL-SIZE BIT LISP:BIT-AND 
+               LISP:BIT-ANDC1 LISP:BIT-ANDC2 BIT-ARRAY-P LISP:BIT-EQV LISP:BIT-IOR LISP:BIT-NAND 
+               LISP:BIT-NOR LISP:BIT-NOT LISP:BIT-ORC1 LISP:BIT-ORC2 LISP:BIT-VECTOR-P LISP:BIT-XOR 
+               LISP:CHAR LISP:ARRAYP LISP:STRINGP COPY-ARRAY COPY-VECTOR DISPLACED-ARRAY-P 
+               EQUAL-DIMENSIONS-P EXTENDABLE-ARRAY-P FILL-ARRAY LISP:FILL-POINTER FILL-VECTOR 
+               LISP:MAKE-ARRAY MAKE-VECTOR READ-ONLY-ARRAY-P LISP:SBIT LISP:SCHAR SET-FILL-POINTER 
+               SIMPLE-ARRAY-P LISP:SIMPLE-BIT-VECTOR-P LISP:SIMPLE-STRING-P LISP:SIMPLE-VECTOR-P 
+               STRING-ARRAY-P LISP:SVREF LISP::UPGRADED-ARRAY-ELEMENT-TYPE VECTOR-LENGTH 
+               LISP:VECTOR-POP LISP:VECTOR-PUSH LISP:VECTOR-PUSH-EXTEND LISP:VECTORP)
+        (FNS LISP:AREF LISP:ARRAY-IN-BOUNDS-P LISP:ARRAY-ROW-MAJOR-INDEX ASET LISP:VECTOR)
+        
+        (* |;;| "New CLtL array functions")
+
+        (COMS (FNS LISP::ROW-MAJOR-AREF LISP::ROW-MAJOR-ASET)
+              (SETFS LISP::ROW-MAJOR-AREF))
+        
+        (* |;;| "Setfs")
+
+        (SETFS LISP:AREF BIT LISP:CHAR LISP:FILL-POINTER LISP:SBIT LISP:SCHAR LISP:SVREF)
+        
+        (* |;;| "Optimizers")
+
+        (FUNCTIONS %AREF-EXPANDER %ASET-EXPANDER)
+        (OPTIMIZERS LISP:AREF ASET BIT LISP:CHAR LISP:SBIT LISP:SCHAR LISP:SVREF)
+        
+        (* |;;| "Vars etc")
+
+                                                             (* \; 
+                                                           "*PRINT-ARRAY* is defined in APRINT")
+        (VARIABLES LISP:ARRAY-RANK-LIMIT LISP:ARRAY-TOTAL-SIZE-LIMIT LISP:ARRAY-DIMENSION-LIMIT 
+               *DEFAULT-PUSH-EXTENSION-SIZE*)
+        
+        (* |;;| "Run-time support")
+
+        (FNS %ALTER-AS-DISPLACED-ARRAY %ALTER-AS-DISPLACED-TO-BASE-ARRAY %AREF0 %AREF1 %AREF2 
+             %ARRAY-BASE %ARRAY-CONTENT-INITIALIZE %ARRAY-ELEMENT-INITIALIZE %ARRAY-OFFSET 
+             %ARRAY-TYPE-NUMBER %ASET0 %ASET1 %ASET2 %CHECK-SEQUENCE-DIMENSIONS %COPY-TO-NEW-ARRAY 
+             %DO-LOGICAL-OP %EXTEND-ARRAY %FAST-COPY-BASE %FAT-STRING-ARRAY-P 
+             %FILL-ARRAY-FROM-SEQUENCE %FLATTEN-ARRAY %MAKE-ARRAY-WRITEABLE %MAKE-DISPLACED-ARRAY 
+             %MAKE-GENERAL-ARRAY %MAKE-ONED-ARRAY %MAKE-STRING-ARRAY-FAT %MAKE-TWOD-ARRAY %TOTAL-SIZE
+             SHRINK-VECTOR)
+                                                             (* \; "For Interlisp string hack")
+        (FNS %SET-ARRAY-OFFSET %SET-ARRAY-TYPE-NUMBER)
+                                                             (* \; "Low level predicates")
+        (FNS %ONED-ARRAY-P %TWOD-ARRAY-P %GENERAL-ARRAY-P %THIN-STRING-ARRAY-P)
+        (OPTIMIZERS %ONED-ARRAY-P %TWOD-ARRAY-P %GENERAL-ARRAY-P)
+                                                             (* \; 
+                                                           "Real record def's on cmlarray-support")
+        (INITRECORDS GENERAL-ARRAY ONED-ARRAY TWOD-ARRAY)
+        (SYSRECORDS GENERAL-ARRAY ONED-ARRAY TWOD-ARRAY)
+        (PROP DOPVAL %AREF1 %AREF2 %ASET1 %ASET2)
+        
+        (* |;;| "I/O")
+
+        (FNS %DEFPRINT-ARRAY %DEFPRINT-BITVECTOR %DEFPRINT-GENERIC-ARRAY %DEFPRINT-VECTOR 
+             %DEFPRINT-STRING %PRINT-ARRAY-CONTENTS)
+        (P (DEFPRINT 'ONED-ARRAY '%DEFPRINT-VECTOR)
+           (DEFPRINT 'TWOD-ARRAY '%DEFPRINT-ARRAY)
+           (DEFPRINT 'GENERAL-ARRAY '%DEFPRINT-ARRAY))
+        
+        (* |;;| "Needed at run time. low level functions for accessing, setting, and allocating raw storage. also includes cml type to typenumber converters")
+
+        (FNS %ARRAY-READ %ARRAY-WRITE %CML-TYPE-TO-TYPENUMBER %GET-CANONICAL-CML-TYPE 
+             %GET-ENCLOSING-SIGNED-BYTE %GET-ENCLOSING-UNSIGNED-BYTE %MAKE-ARRAY-STORAGE 
+             %REDUCE-INTEGER %REDUCE-MOD %SLOW-ARRAY-READ %SLOW-ARRAY-WRITE)
+        (OPTIMIZERS %ARRAY-READ %ARRAY-WRITE)
+        
+        (* |;;| "Compiler options")
+
+        (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
+        (PROP FILETYPE CMLARRAY)
+        (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML)
+                      (LAMA LISP:VECTOR ASET LISP:ARRAY-ROW-MAJOR-INDEX LISP:ARRAY-IN-BOUNDS-P 
+                            LISP:AREF)))))
+
+
+
+(* |;;| "Contains table driven macros")
+
+(DECLARE\: DONTCOPY EVAL@COMPILE 
+(* "FOLLOWING DEFINITIONS EXPORTED")
+(FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES)
+       CMLARRAY-SUPPORT)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+
+
+
+(* |;;| "User entry points")
+
+
+(LISP:DEFUN LISP:ADJUST-ARRAY (ADJUSTABLE-ARRAY DIMENSIONS &KEY (ELEMENT-TYPE NIL 
+                                                                           ELEMENT-TYPE-P)
+                                         (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P)
+                                         (INITIAL-CONTENTS NIL INITIAL-CONTENTS-P)
+                                         (DISPLACED-TO NIL DISPLACED-TO-P)
+                                         (DISPLACED-TO-BASE NIL DISPLACED-TO-BASE-P)
+                                         (DISPLACED-INDEX-OFFSET 0 DISPLACED-INDEX-OFFSET-P)
+                                         (FILL-POINTER NIL FILL-POINTER-P)
+                                         FATP)
+
+   (* |;;| "Do something wonderfull")
+
+   (LISP:IF (NOT (EXTENDABLE-ARRAY-P ADJUSTABLE-ARRAY))
+          (LISP:ERROR "Not an adjustable or extendable array: ~S" ADJUSTABLE-ARRAY))
+   (LISP:IF (NOT (LISP:LISTP DIMENSIONS))
+       (SETQ DIMENSIONS (LIST DIMENSIONS)))
+   (LISP:IF (LISP:DOLIST (DIM DIMENSIONS NIL)
+                (LISP:IF (OR (< DIM 0)
+                             (>= DIM LISP:ARRAY-DIMENSION-LIMIT))
+                       (RETURN T)))
+          (LISP:ERROR "Dimensions out of bounds ~S" DIMENSIONS))
+   (LET ((ADJUSTABLE-ARRAY-ELEMENT-TYPE (LISP:ARRAY-ELEMENT-TYPE ADJUSTABLE-ARRAY))
+         (NELTS (%TOTAL-SIZE DIMENSIONS))
+         (RANK (LENGTH DIMENSIONS))
+         (EXTENDABLE-P (NOT (LISP:ADJUSTABLE-ARRAY-P ADJUSTABLE-ARRAY))))
+
+        (* |;;| "Consistency checks")
+
+        (LISP:IF (>= RANK LISP:ARRAY-RANK-LIMIT)
+               (LISP:ERROR "Too many dimensions: ~A" RANK))
+        (LISP:IF (>= NELTS LISP:ARRAY-TOTAL-SIZE-LIMIT)
+               (LISP:ERROR "Too many elements: ~A" NELTS))
+        (LISP:IF (NOT (EQ RANK (LISP:ARRAY-RANK ADJUSTABLE-ARRAY)))
+               (LISP:ERROR "Rank mismatch: ~S" DIMENSIONS))
+        (LISP:IF ELEMENT-TYPE-P
+            (LISP:IF (NOT (EQUAL ELEMENT-TYPE ADJUSTABLE-ARRAY-ELEMENT-TYPE))
+                   (LISP:ERROR "ADJUSTABLE-ARRAY not of specified element-type: ~A" ELEMENT-TYPE))
+            (SETQ ELEMENT-TYPE ADJUSTABLE-ARRAY-ELEMENT-TYPE))
+        (LISP:IF (AND FILL-POINTER-P (NULL FILL-POINTER)
+                      (LISP:ARRAY-HAS-FILL-POINTER-P ADJUSTABLE-ARRAY))
+               (LISP:ERROR "ADJUSTABLE-ARRAY has fill pointer"))
+        (LISP:IF (OR (AND DISPLACED-TO-P (OR INITIAL-ELEMENT-P INITIAL-CONTENTS-P DISPLACED-TO-BASE-P
+                                             ))
+                     (AND DISPLACED-TO-BASE-P (OR INITIAL-ELEMENT-P INITIAL-CONTENTS-P DISPLACED-TO-P
+                                                  ))
+                     (AND FILL-POINTER-P FILL-POINTER (NOT (LISP:ARRAY-HAS-FILL-POINTER-P 
+                                                                  ADJUSTABLE-ARRAY)))
+                     (AND DISPLACED-INDEX-OFFSET-P (NOT (OR DISPLACED-TO-P DISPLACED-TO-BASE-P)))
+                     (AND INITIAL-ELEMENT-P INITIAL-CONTENTS-P))
+               (LISP:ERROR "Inconsistent options to adjust-array"))
+        (LISP:IF DISPLACED-TO-P
+            (COND
+               ((NOT (%ARRAYP DISPLACED-TO))
+                (LISP:ERROR "Not displaced to an array: ~S" DISPLACED-TO))
+               ((NOT (EQUAL ADJUSTABLE-ARRAY-ELEMENT-TYPE (LISP:ARRAY-ELEMENT-TYPE DISPLACED-TO))
+                     )
+                (LISP:ERROR "Not displaced to an array of the same element-type:"))
+               ((> (+ DISPLACED-INDEX-OFFSET NELTS)
+                   (LISP:ARRAY-TOTAL-SIZE DISPLACED-TO))
+                (LISP:ERROR "More elements than displaced-to array"))))
+        (LISP:IF FILL-POINTER
+            (COND
+               ((EQ FILL-POINTER T)
+                (SETQ FILL-POINTER NELTS))
+               ((NOT (<= 0 FILL-POINTER NELTS))
+                (LISP:ERROR "Fill pointer out of bounds: ~A" FILL-POINTER)))
+            (LISP:IF (LISP:ARRAY-HAS-FILL-POINTER-P ADJUSTABLE-ARRAY)
+                (SETQ FILL-POINTER (MIN (LISP:FILL-POINTER ADJUSTABLE-ARRAY)
+                                        NELTS))))
+        (LISP:IF EXTENDABLE-P
+            (COND
+               ((OR DISPLACED-TO-P DISPLACED-TO-BASE-P)
+                (LISP:ERROR "Cannot adjust an extendable array to be displaced"))
+               ((< NELTS (LISP:ARRAY-TOTAL-SIZE ADJUSTABLE-ARRAY))
+                (LISP:ERROR "Cannot extend an extendable array to have fewer elements"))))
+
+        (* |;;| "Specs ready, do the surgury")
+
+        (COND
+           (DISPLACED-TO-P (%ALTER-AS-DISPLACED-ARRAY ADJUSTABLE-ARRAY DIMENSIONS DISPLACED-TO 
+                                  DISPLACED-INDEX-OFFSET FILL-POINTER))
+           (DISPLACED-TO-BASE-P (%ALTER-AS-DISPLACED-TO-BASE-ARRAY ADJUSTABLE-ARRAY DIMENSIONS 
+                                       ELEMENT-TYPE DISPLACED-TO-BASE DISPLACED-INDEX-OFFSET 
+                                       FILL-POINTER FATP))
+           (T (LISP:IF (EQUAL (LISP:ARRAY-DIMENSIONS ADJUSTABLE-ARRAY)
+                              DIMENSIONS)
+                  (LISP:IF FILL-POINTER (SET-FILL-POINTER ADJUSTABLE-ARRAY FILL-POINTER))
+                  (LET ((NEW-ARRAY (LISP:MAKE-ARRAY DIMENSIONS :ELEMENT-TYPE ELEMENT-TYPE :FATP
+                                          (%FAT-STRING-ARRAY-P ADJUSTABLE-ARRAY))))
+                       (COND
+                          (INITIAL-CONTENTS-P (%ARRAY-CONTENT-INITIALIZE NEW-ARRAY 
+                                                     INITIAL-CONTENTS))
+                          (T (LISP:IF INITIAL-ELEMENT-P (%ARRAY-ELEMENT-INITIALIZE NEW-ARRAY 
+                                                               INITIAL-ELEMENT))
+                             (%COPY-TO-NEW-ARRAY (LISP:ARRAY-DIMENSIONS ADJUSTABLE-ARRAY)
+                                    (%FLATTEN-ARRAY ADJUSTABLE-ARRAY)
+                                    0 DIMENSIONS (%FLATTEN-ARRAY NEW-ARRAY)
+                                    0)))
+                       (%EXTEND-ARRAY ADJUSTABLE-ARRAY NEW-ARRAY DIMENSIONS FILL-POINTER)))))
+
+        (* |;;| "Return the adjusted array")
+
+        ADJUSTABLE-ARRAY))
+
+(LISP:DEFUN LISP:ADJUSTABLE-ARRAY-P (ARRAY)
+   (LISP:IF (%ARRAYP ARRAY)
+       (|fetch| (ARRAY-HEADER ADJUSTABLE-P) |of| ARRAY)
+       (LISP:ERROR "Not an array: ~S" ARRAY)))
+
+(LISP:DEFUN LISP:ARRAY-DIMENSION (ARRAY DIMENSION)
+   (COND
+      ((%ONED-ARRAY-P ARRAY)
+       (LISP:IF (EQ 0 DIMENSION)
+           (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY)
+           (LISP:ERROR "Dimension out of bounds: ~A" DIMENSION)))
+      ((%TWOD-ARRAY-P ARRAY)
+       (CASE DIMENSION
+           (0 (|ffetch| (TWOD-ARRAY BOUND0) |of| ARRAY))
+           (1 (|ffetch| (TWOD-ARRAY BOUND1) |of| ARRAY))
+           (T (LISP:ERROR "Dimension out of bounds: ~A" DIMENSION))))
+      ((%GENERAL-ARRAY-P ARRAY)
+       (LET* ((DIMS (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY))
+              (RANK (LENGTH DIMS)))
+             (LISP:IF (NOT (< -1 DIMENSION RANK))
+                    (LISP:ERROR "Dimension out of bounds: ~A" DIMENSION))
+             (LISP:IF (EQ RANK 1)
+                 (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY)
+                 (LISP:NTH DIMENSION DIMS))))
+      (T (LISP:ERROR "Not an array: ~S" ARRAY))))
+
+(LISP:DEFUN LISP:ARRAY-DIMENSIONS (ARRAY)
+   (COND
+      ((%ONED-ARRAY-P ARRAY)
+       (LIST (|ffetch| (ONED-ARRAY TOTAL-SIZE) |of| ARRAY)))
+      ((%TWOD-ARRAY-P ARRAY)
+       (LIST (|ffetch| (TWOD-ARRAY BOUND0) |of| ARRAY)
+             (|ffetch| (TWOD-ARRAY BOUND1) |of| ARRAY)))
+      ((%GENERAL-ARRAY-P ARRAY)
+       (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY))
+      (T (LISP:ERROR "Not an array: ~S" ARRAY))))
+
+(LISP:DEFUN LISP:ARRAY-ELEMENT-TYPE (ARRAY)
+   (LISP:IF (%ARRAYP ARRAY)
+       (%TYPENUMBER-TO-CML-TYPE (%ARRAY-TYPE-NUMBER ARRAY))
+       (LISP:ERROR "Not an array: ~S" ARRAY)))
+
+(LISP:DEFUN LISP:ARRAY-HAS-FILL-POINTER-P (ARRAY)
+   (LISP:IF (%ARRAYP ARRAY)
+       (|fetch| (ARRAY-HEADER FILL-POINTER-P) |of| ARRAY)
+       (LISP:ERROR "Not an array: ~S" ARRAY)))
+
+(LISP:DEFUN ARRAY-NEEDS-INDIRECTION-P (ARRAY)
+   (COND
+      ((OR (%ONED-ARRAY-P ARRAY)
+           (%TWOD-ARRAY-P ARRAY))
+       NIL)
+      ((%GENERAL-ARRAY-P ARRAY)
+       (|fetch| (ARRAY-HEADER INDIRECT-P) |of| ARRAY))
+      (T (LISP:ERROR "Not an array: ~S" ARRAY))))
+
+(LISP:DEFUN LISP:ARRAY-RANK (ARRAY)
+   (COND
+      ((%ONED-ARRAY-P ARRAY)
+       1)
+      ((%TWOD-ARRAY-P ARRAY)
+       2)
+      ((%GENERAL-ARRAY-P ARRAY)
+       (LENGTH (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY)))
+      (T (LISP:ERROR "Not an array: ~S" ARRAY))))
+
+(LISP:DEFUN LISP:ARRAY-TOTAL-SIZE (ARRAY)
+   (LISP:IF (%ARRAYP ARRAY)
+       (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY)
+       (LISP:ERROR "Not an array: ~S" ARRAY)))
+
+(LISP:DEFUN BIT (BIT-ARRAY &REST INDICES)
+   (LISP:ASSERT (TYPEP BIT-ARRAY '(LISP:ARRAY BIT))
+          (BIT-ARRAY)
+          "Not a bit-array: ~S" BIT-ARRAY)
+   (LISP:APPLY #'LISP:AREF BIT-ARRAY INDICES))
+
+(LISP:DEFUN LISP:BIT-AND (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
+   (%EXPAND-BIT-OP AND BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))
+
+(LISP:DEFUN LISP:BIT-ANDC1 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
+   (%EXPAND-BIT-OP ANDC1 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))
+
+(LISP:DEFUN LISP:BIT-ANDC2 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
+   (%EXPAND-BIT-OP ANDC2 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))
+
+(LISP:DEFUN BIT-ARRAY-P (ARRAY)
+   (AND (%ARRAYP ARRAY)
+        (|fetch| (ARRAY-HEADER BIT-P) |of| ARRAY)))
+
+(LISP:DEFUN LISP:BIT-EQV (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
+   (%EXPAND-BIT-OP EQV BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))
+
+(LISP:DEFUN LISP:BIT-IOR (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
+   (%EXPAND-BIT-OP IOR BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))
+
+(LISP:DEFUN LISP:BIT-NAND (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
+   (%EXPAND-BIT-OP NAND BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))
+
+(LISP:DEFUN LISP:BIT-NOR (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
+   (%EXPAND-BIT-OP NOR BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))
+
+(LISP:DEFUN LISP:BIT-NOT (BIT-ARRAY &OPTIONAL RESULT-BIT-ARRAY)
+   (LISP:IF (NOT (BIT-ARRAY-P BIT-ARRAY))
+          (LISP:ERROR "BIT-ARRAY not a bit array"))
+   (COND
+      ((NULL RESULT-BIT-ARRAY)
+       (SETQ RESULT-BIT-ARRAY (LISP:MAKE-ARRAY (LISP:ARRAY-DIMENSIONS BIT-ARRAY)
+                                     :ELEMENT-TYPE
+                                     'BIT)))
+      ((EQ RESULT-BIT-ARRAY T)
+       (SETQ RESULT-BIT-ARRAY BIT-ARRAY))
+      ((NOT (AND (BIT-ARRAY-P RESULT-BIT-ARRAY)
+                 (EQUAL-DIMENSIONS-P BIT-ARRAY RESULT-BIT-ARRAY)))
+       (LISP:ERROR "Illegal result array")))
+   (%DO-LOGICAL-OP 'NOT BIT-ARRAY RESULT-BIT-ARRAY)
+   RESULT-BIT-ARRAY)
+
+(LISP:DEFUN LISP:BIT-ORC1 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
+   (%EXPAND-BIT-OP ORC1 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))
+
+(LISP:DEFUN LISP:BIT-ORC2 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
+   (%EXPAND-BIT-OP ORC2 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))
+
+(LISP:DEFUN LISP:BIT-VECTOR-P (VECTOR)
+   (AND (%VECTORP VECTOR)
+        (|fetch| (ARRAY-HEADER BIT-P) |of| VECTOR)))
+
+(LISP:DEFUN LISP:BIT-XOR (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
+   (%EXPAND-BIT-OP XOR BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))
+
+(LISP:DEFUN LISP:CHAR (STRING INDEX)
+   (LISP:ASSERT (TYPEP STRING 'STRING)
+          (STRING)
+          "Not a string: ~S" STRING)
+   (LISP:AREF STRING INDEX))
+
+(LISP:DEFUN LISP:ARRAYP (ARRAY)
+   (%ARRAYP ARRAY))
+
+(LISP:DEFUN LISP:STRINGP (STRING)
+   (%STRINGP STRING))
+
+(LISP:DEFUN COPY-ARRAY (FROM-ARRAY &OPTIONAL TO-ARRAY)
+   (LISP:IF (NOT (%ARRAYP FROM-ARRAY))
+          (LISP:ERROR "Not an array: ~S" FROM-ARRAY))
+   (COND
+      ((NULL TO-ARRAY)
+       (SETQ TO-ARRAY (LISP:MAKE-ARRAY (LISP:ARRAY-DIMENSIONS FROM-ARRAY)
+                             :ELEMENT-TYPE
+                             (LISP:ARRAY-ELEMENT-TYPE FROM-ARRAY)
+                             :FATP
+                             (%FAT-STRING-ARRAY-P FROM-ARRAY))))
+      ((NOT (EQUAL-DIMENSIONS-P FROM-ARRAY TO-ARRAY))
+       (LISP:ERROR "Dimensionality mismatch")))
+   (LISP:IF (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| TO-ARRAY)
+          (%MAKE-ARRAY-WRITEABLE TO-ARRAY))
+   (LET ((FROM-TYPE-NUMBER (%ARRAY-TYPE-NUMBER FROM-ARRAY))
+         (TO-TYPE-NUMBER (%ARRAY-TYPE-NUMBER TO-ARRAY)))
+        (LISP:WHEN (AND (%FAT-CHAR-TYPE-P FROM-TYPE-NUMBER)
+                        (%THIN-CHAR-TYPE-P TO-TYPE-NUMBER))
+            (%MAKE-STRING-ARRAY-FAT TO-ARRAY)
+            (SETQ TO-TYPE-NUMBER (%ARRAY-TYPE-NUMBER TO-ARRAY)))
+        (%FAST-COPY-BASE (%ARRAY-BASE FROM-ARRAY)
+               (%ARRAY-OFFSET FROM-ARRAY)
+               FROM-TYPE-NUMBER
+               (%ARRAY-BASE TO-ARRAY)
+               (%ARRAY-OFFSET TO-ARRAY)
+               TO-TYPE-NUMBER
+               (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| FROM-ARRAY))
+        TO-ARRAY))
+
+(LISP:DEFUN COPY-VECTOR (FROM-VECTOR TO-VECTOR &KEY (START1 0)
+                                   END1
+                                   (START2 0)
+                                   END2)
+   (LET ((FROM-LENGTH (VECTOR-LENGTH FROM-VECTOR))
+         (TO-LENGTH (VECTOR-LENGTH TO-VECTOR)))
+        (LISP:IF (NULL END1)
+               (SETQ END1 FROM-LENGTH))
+        (LISP:IF (NULL END2)
+               (SETQ END2 TO-LENGTH))
+        (LISP:IF (NOT (<= 0 START1 END1 FROM-LENGTH))
+               (LISP:ERROR "Bad subsequence for FROM-VECTOR"))
+        (LISP:IF (NOT (<= 0 START2 END2 TO-LENGTH))
+               (LISP:ERROR "Bad subsequence for TO-VECTOR"))
+        (LISP:IF (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| TO-VECTOR)
+               (%MAKE-ARRAY-WRITEABLE TO-VECTOR))
+        (LET ((SUBLEN1 (- END1 START1))
+              (SUBLEN2 (- END2 START2))
+              (FROM-TYPE-NUMBER (%ARRAY-TYPE-NUMBER FROM-VECTOR))
+              (TO-TYPE-NUMBER (%ARRAY-TYPE-NUMBER TO-VECTOR)))
+             (LISP:WHEN (AND (%FAT-CHAR-TYPE-P FROM-TYPE-NUMBER)
+                             (%THIN-CHAR-TYPE-P TO-TYPE-NUMBER))
+                 (%MAKE-STRING-ARRAY-FAT TO-VECTOR)
+                 (SETQ TO-TYPE-NUMBER (%ARRAY-TYPE-NUMBER TO-VECTOR)))
+             (%FAST-COPY-BASE (%ARRAY-BASE FROM-VECTOR)
+                    (+ START1 (%ARRAY-OFFSET FROM-VECTOR))
+                    FROM-TYPE-NUMBER
+                    (%ARRAY-BASE TO-VECTOR)
+                    (+ START2 (%ARRAY-OFFSET TO-VECTOR))
+                    TO-TYPE-NUMBER
+                    (MIN SUBLEN1 SUBLEN2))
+             TO-VECTOR)))
+
+(LISP:DEFUN DISPLACED-ARRAY-P (ARRAY)
+   (LISP:IF (%ARRAYP ARRAY)
+       (|fetch| (ARRAY-HEADER DISPLACED-P) |of| ARRAY)
+       (LISP:ERROR "Not an array: ~S" ARRAY)))
+
+(LISP:DEFUN EQUAL-DIMENSIONS-P (ARRAY-1 ARRAY-2)
+   (COND
+      ((%ONED-ARRAY-P ARRAY-1)
+       (COND
+          ((%ONED-ARRAY-P ARRAY-2)
+           (EQ (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY-1)
+               (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY-2)))
+          ((%TWOD-ARRAY-P ARRAY-2)
+           NIL)
+          ((%GENERAL-ARRAY-P ARRAY-2)
+           (AND (EQ 1 (LENGTH (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY-2)))
+                (EQ (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY-1)
+                    (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY-2))))
+          (T NIL)))
+      ((%TWOD-ARRAY-P ARRAY-1)
+       (COND
+          ((%ONED-ARRAY-P ARRAY-2)
+           NIL)
+          ((%TWOD-ARRAY-P ARRAY-2)
+           (AND (EQ (|ffetch| (TWOD-ARRAY BOUND0) |of| ARRAY-1)
+                    (|ffetch| (TWOD-ARRAY BOUND0) |of| ARRAY-2))
+                (EQ (|ffetch| (TWOD-ARRAY BOUND1) |of| ARRAY-1)
+                    (|ffetch| (TWOD-ARRAY BOUND1) |of| ARRAY-2))))
+          ((%GENERAL-ARRAY-P ARRAY-2)
+           (LET ((DIMS (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY-2)))
+                (AND (EQ 2 (LENGTH DIMS))
+                     (AND (EQ (|ffetch| (TWOD-ARRAY BOUND0) |of| ARRAY-1)
+                              (CAR DIMS))
+                          (EQ (|ffetch| (TWOD-ARRAY BOUND1) |of| ARRAY-1)
+                              (CADR DIMS))))))
+          (T NIL)))
+      ((%GENERAL-ARRAY-P ARRAY-1)
+       (LET ((DIMS (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY-1)))
+            (COND
+               ((%ONED-ARRAY-P ARRAY-2)
+                (AND (EQ 1 (LENGTH DIMS))
+                     (EQ (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY-1)
+                         (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY-2))))
+               ((%TWOD-ARRAY-P ARRAY-2)
+                (AND (EQ 2 (LENGTH DIMS))
+                     (AND (EQ (CAR DIMS)
+                              (|ffetch| (TWOD-ARRAY BOUND0) |of| ARRAY-2))
+                          (EQ (CADR DIMS)
+                              (|ffetch| (TWOD-ARRAY BOUND1) |of| ARRAY-2)))))
+               ((%GENERAL-ARRAY-P ARRAY-2)
+                (EQUAL DIMS (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY-2)))
+               (T NIL))))
+      (T NIL)))
+
+(LISP:DEFUN EXTENDABLE-ARRAY-P (ARRAY)
+   
+         (* *)
+
+   (COND
+      ((%ARRAYP ARRAY)
+       (|fetch| (ARRAY-HEADER EXTENDABLE-P) |of| ARRAY))
+      ((STRINGP ARRAY)
+       NIL)
+      (T (LISP:ERROR "Not an array ~S" ARRAY))))
+
+(LISP:DEFUN FILL-ARRAY (ARRAY VALUE)
+   (LISP:IF (NOT (%ARRAYP ARRAY))
+          (LISP:ERROR "Not an array: ~S" ARRAY))
+   (LET ((TOTAL-SIZE (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY))
+         (TYPE-NUMBER (%ARRAY-TYPE-NUMBER ARRAY)))
+        (LISP:IF (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| ARRAY)
+               (%MAKE-ARRAY-WRITEABLE ARRAY))
+        (LISP:WHEN (> TOTAL-SIZE 0)
+            (LISP:WHEN (AND (%THIN-CHAR-TYPE-P TYPE-NUMBER)
+                            (%FAT-STRING-CHAR-P VALUE))
+                (%MAKE-STRING-ARRAY-FAT ARRAY)
+                (SETQ TYPE-NUMBER (%ARRAY-TYPE-NUMBER ARRAY)))
+            (LISP:IF (NOT (%LLARRAY-TYPEP TYPE-NUMBER VALUE))
+                   (LISP:ERROR "Value of incorrect type for this array: ~S" VALUE))
+            (LET ((BASE (%ARRAY-BASE ARRAY))
+                  (OFFSET (%ARRAY-OFFSET ARRAY)))        (* \; "Start things off")
+                 (%ARRAY-WRITE VALUE BASE TYPE-NUMBER OFFSET)
+                                                             (* \; "An overlapping blt")
+                 (%FAST-COPY-BASE BASE OFFSET TYPE-NUMBER BASE (LISP:1+ OFFSET)
+                        TYPE-NUMBER
+                        (LISP:1- TOTAL-SIZE))))
+        ARRAY))
+
+(LISP:DEFUN LISP:FILL-POINTER (VECTOR)
+   (COND
+      ((AND (OR (%ONED-ARRAY-P VECTOR)
+                (%GENERAL-ARRAY-P VECTOR))
+            (|fetch| (ARRAY-HEADER FILL-POINTER-P) |of| VECTOR))
+       (|fetch| (ARRAY-HEADER FILL-POINTER) |of| VECTOR))
+      ((%VECTORP VECTOR)
+       (LISP:ERROR "vector has no fill pointer"))
+      (T (LISP:ERROR "Not a vector: ~S" VECTOR))))
+
+(LISP:DEFUN FILL-VECTOR (VECTOR VALUE &KEY (START 0)
+                                   END)
+   (LISP:IF (NOT (%VECTORP VECTOR))
+          (LISP:ERROR "Not a vector: ~S" VECTOR))
+   (LET ((TOTAL-SIZE (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| VECTOR)))
+        (LISP:IF (NULL END)
+               (SETQ END TOTAL-SIZE))
+        (LISP:IF (NOT (<= START END TOTAL-SIZE))
+               (LISP:ERROR "Invalid subsequence" END))
+        (LET ((CNT (- END START))
+              (TYPE-NUMBER (%ARRAY-TYPE-NUMBER VECTOR)))
+             (LISP:IF (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| VECTOR)
+                    (%MAKE-ARRAY-WRITEABLE VECTOR))
+             (LISP:WHEN (> CNT 0)
+                 (LISP:WHEN (AND (%THIN-CHAR-TYPE-P TYPE-NUMBER)
+                                 (%FAT-STRING-CHAR-P VALUE))
+                     (%MAKE-STRING-ARRAY-FAT VECTOR)
+                     (SETQ TYPE-NUMBER (%ARRAY-TYPE-NUMBER VECTOR)))
+                 (LISP:IF (NOT (%LLARRAY-TYPEP TYPE-NUMBER VALUE))
+                        (LISP:ERROR "Value of incorrect type for this array: ~S" VALUE))
+                 (LET ((BASE (%ARRAY-BASE VECTOR))
+                       (OFFSET (+ START (%ARRAY-OFFSET VECTOR))))
+                                                             (* \; "Start things off")
+                      (%ARRAY-WRITE VALUE BASE TYPE-NUMBER OFFSET)
+                                                             (* \; "An overlapping blt")
+                      (%FAST-COPY-BASE BASE OFFSET TYPE-NUMBER BASE (LISP:1+ OFFSET)
+                             TYPE-NUMBER
+                             (LISP:1- CNT))))
+             VECTOR)))
+
+(LISP:DEFUN LISP:MAKE-ARRAY (DIMENSIONS &KEY (ELEMENT-TYPE T)
+                                       (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P)
+                                       (INITIAL-CONTENTS NIL INITIAL-CONTENTS-P)
+                                       (DISPLACED-TO NIL DISPLACED-TO-P)
+                                       (DISPLACED-TO-BASE NIL DISPLACED-TO-BASE-P)
+                                       (DISPLACED-INDEX-OFFSET 0 DISPLACED-INDEX-OFFSET-P)
+                                       FILL-POINTER ADJUSTABLE EXTENDABLE FATP READ-ONLY-P)
+
+   (* |;;| "String are by default thin unless FATP is T. DISPLACED-TO-BASE indicates displacement to a raw storage block. READ-ONLY-P indicates a read only array")
+
+   (LISP:IF (NOT (LISP:LISTP DIMENSIONS))
+       (SETQ DIMENSIONS (LIST DIMENSIONS)))
+   (LISP:IF (LISP:DOLIST (DIM DIMENSIONS NIL)
+                (LISP:IF (OR (< DIM 0)
+                             (>= DIM LISP:ARRAY-DIMENSION-LIMIT))
+                       (RETURN T)))
+          (LISP:ERROR "Dimensions out of bounds: ~S" DIMENSIONS))
+   (LET ((RANK (LENGTH DIMENSIONS))
+         (NELTS (%TOTAL-SIZE DIMENSIONS))
+         ARRAY)
+
+        (* |;;| "Consistency checks")
+
+        (LISP:IF (>= RANK LISP:ARRAY-RANK-LIMIT)
+               (LISP:ERROR "Too many dimensions: ~A" RANK))
+        (LISP:IF (>= NELTS LISP:ARRAY-TOTAL-SIZE-LIMIT)
+               (LISP:ERROR "Too many elements: ~A" NELTS))
+        (LISP:IF (OR (AND DISPLACED-TO-P (OR INITIAL-ELEMENT-P INITIAL-CONTENTS-P DISPLACED-TO-BASE-P
+                                             ))
+                     (AND DISPLACED-TO-BASE-P (OR INITIAL-ELEMENT-P INITIAL-CONTENTS-P DISPLACED-TO-P
+                                                  ))
+                     (AND FILL-POINTER (NOT (EQ RANK 1)))
+                     (AND DISPLACED-INDEX-OFFSET-P (NOT (OR DISPLACED-TO-P DISPLACED-TO-BASE-P)))
+                     (AND INITIAL-ELEMENT-P INITIAL-CONTENTS-P)
+                     (AND ADJUSTABLE EXTENDABLE)
+                     (AND READ-ONLY-P (OR EXTENDABLE ADJUSTABLE)))
+               (LISP:ERROR "Inconsistent options to make-array"))
+        (LISP:IF DISPLACED-TO-P
+            (COND
+               ((NOT (%ARRAYP DISPLACED-TO))
+                (LISP:ERROR "Not displaced to an array: ~s" DISPLACED-TO))
+               ((NOT (EQUAL (%GET-CANONICAL-CML-TYPE ELEMENT-TYPE)
+                            (LISP:ARRAY-ELEMENT-TYPE DISPLACED-TO)))
+                (LISP:ERROR "Not displaced to an array of the same element-type"))
+               ((> (+ DISPLACED-INDEX-OFFSET NELTS)
+                   (LISP:ARRAY-TOTAL-SIZE DISPLACED-TO))
+                (LISP:ERROR "Displaced array out of bounds"))))
+        (LISP:IF FILL-POINTER
+            (COND
+               ((EQ FILL-POINTER T)
+                (SETQ FILL-POINTER NELTS))
+               ((NOT (AND (>= FILL-POINTER 0)
+                          (<= FILL-POINTER NELTS)))
+                (LISP:ERROR "Fill pointer out of bounds ~A" FILL-POINTER))))
+
+        (* |;;| "Specs ready, make the array by case")
+
+        (SETQ ARRAY (COND
+                       (DISPLACED-TO-P (%MAKE-DISPLACED-ARRAY NELTS DIMENSIONS ELEMENT-TYPE 
+                                              DISPLACED-TO DISPLACED-INDEX-OFFSET FILL-POINTER 
+                                              READ-ONLY-P ADJUSTABLE EXTENDABLE))
+                       (DISPLACED-TO-BASE (LISP:IF (OR (> RANK 1)
+                                                       ADJUSTABLE)
+                                              (%MAKE-GENERAL-ARRAY NELTS DIMENSIONS ELEMENT-TYPE
+                                                     FILL-POINTER FATP READ-ONLY-P ADJUSTABLE 
+                                                     EXTENDABLE DISPLACED-TO-BASE 
+                                                     DISPLACED-INDEX-OFFSET)
+                                              (%MAKE-ONED-ARRAY NELTS ELEMENT-TYPE FILL-POINTER 
+                                                     FATP READ-ONLY-P EXTENDABLE DISPLACED-TO-BASE 
+                                                     DISPLACED-INDEX-OFFSET)))
+                       ((AND (EQ RANK 1)
+                             (NOT ADJUSTABLE))
+                        (%MAKE-ONED-ARRAY NELTS ELEMENT-TYPE FILL-POINTER FATP READ-ONLY-P 
+                               EXTENDABLE))
+                       ((AND (EQ RANK 2)
+                             (NOT ADJUSTABLE))
+                        (%MAKE-TWOD-ARRAY NELTS DIMENSIONS ELEMENT-TYPE FATP READ-ONLY-P 
+                               EXTENDABLE))
+                       (T (%MAKE-GENERAL-ARRAY NELTS DIMENSIONS ELEMENT-TYPE FILL-POINTER FATP 
+                                 READ-ONLY-P ADJUSTABLE EXTENDABLE))))
+
+        (* |;;| "Initialize the storage")
+
+        (COND
+           (INITIAL-CONTENTS-P (%ARRAY-CONTENT-INITIALIZE ARRAY INITIAL-CONTENTS))
+           (INITIAL-ELEMENT-P (%ARRAY-ELEMENT-INITIALIZE ARRAY INITIAL-ELEMENT)))
+
+        (* |;;| "Return the array")
+
+        ARRAY))
+
+(LISP:DEFUN MAKE-VECTOR (SIZE &KEY (ELEMENT-TYPE T)
+                                  (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P)
+                                  FATP)
+   (LISP:IF (OR (< SIZE 0)
+                (>= SIZE LISP:ARRAY-TOTAL-SIZE-LIMIT))
+          (LISP:ERROR "Size out of bounds: ~s" SIZE))
+   (LET ((VECTOR (%MAKE-ONED-ARRAY SIZE ELEMENT-TYPE NIL FATP)))
+        (LISP:IF INITIAL-ELEMENT-P (FILL-ARRAY VECTOR INITIAL-ELEMENT))
+        VECTOR))
+
+(LISP:DEFUN READ-ONLY-ARRAY-P (ARRAY)
+   (LISP:IF (%ARRAYP ARRAY)
+       (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| ARRAY)
+       (LISP:ERROR "Not an array: ~S" ARRAY)))
+
+(LISP:DEFUN LISP:SBIT (SIMPLE-BIT-ARRAY &REST INDICES)
+   (LISP:ASSERT (TYPEP SIMPLE-BIT-ARRAY '(LISP:SIMPLE-ARRAY BIT))
+          (SIMPLE-BIT-ARRAY)
+          "Not a bit-array: ~S" SIMPLE-BIT-ARRAY)
+   (LISP:APPLY #'LISP:AREF SIMPLE-BIT-ARRAY INDICES))
+
+(LISP:DEFUN LISP:SCHAR (SIMPLE-STRING INDEX)
+   (LISP:ASSERT (TYPEP SIMPLE-STRING 'LISP:SIMPLE-STRING)
+          (SIMPLE-STRING)
+          "Not a simple-string: ~S" SIMPLE-STRING)
+   (LISP:AREF SIMPLE-STRING INDEX))
+
+(LISP:DEFUN SET-FILL-POINTER (VECTOR NEWVALUE)
+   (COND
+      ((AND (OR (%ONED-ARRAY-P VECTOR)
+                (%GENERAL-ARRAY-P VECTOR))
+            (|fetch| (ARRAY-HEADER FILL-POINTER-P) |of| VECTOR))
+       (LISP:IF (NOT (<= 0 NEWVALUE (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| VECTOR)))
+              (LISP:ERROR "Fill pointer out of bounds: ~S" NEWVALUE))
+       (|replace| (ARRAY-HEADER FILL-POINTER) |of| VECTOR |with| NEWVALUE)
+       NEWVALUE)
+      ((%VECTORP VECTOR)
+       (LISP:ERROR "Vector has no fill pointer"))
+      (T (LISP:ERROR "Not a vector: ~S" VECTOR))))
+
+(LISP:DEFUN SIMPLE-ARRAY-P (ARRAY)
+   (%SIMPLE-ARRAY-P ARRAY))
+
+(LISP:DEFUN LISP:SIMPLE-BIT-VECTOR-P (VECTOR)
+   (AND (%ONED-ARRAY-P VECTOR)
+        (|fetch| (ARRAY-HEADER SIMPLE-P) |of| VECTOR)
+        (|fetch| (ARRAY-HEADER BIT-P) |of| VECTOR)))
+
+(LISP:DEFUN LISP:SIMPLE-STRING-P (STRING)
+   (%SIMPLE-STRING-P STRING))
+
+(LISP:DEFUN LISP:SIMPLE-VECTOR-P (VECTOR)
+   (AND (%ONED-ARRAY-P VECTOR)
+        (|fetch| (ARRAY-HEADER SIMPLE-P) |of| VECTOR)
+        (EQ (LISP:ARRAY-ELEMENT-TYPE VECTOR)
+            T)))
+
+(LISP:DEFUN STRING-ARRAY-P (ARRAY)
+   (%CHAR-TYPE-P (%ARRAY-TYPE-NUMBER ARRAY)))
+
+(LISP:DEFUN LISP:SVREF (LISP:SIMPLE-VECTOR INDEX)
+   (LISP:ASSERT (TYPEP LISP:SIMPLE-VECTOR 'LISP:SIMPLE-VECTOR)
+          (LISP:SIMPLE-VECTOR)
+          "Not a simple-vector: ~S" LISP:SIMPLE-VECTOR)
+   (LISP:AREF LISP:SIMPLE-VECTOR INDEX))
+
+(LISP:DEFUN LISP::UPGRADED-ARRAY-ELEMENT-TYPE (TYPE)
+   (%GET-CANONICAL-CML-TYPE TYPE))
+
+(LISP:DEFUN VECTOR-LENGTH (VECTOR)
+   (LISP:IF (%VECTORP VECTOR)
+       (|fetch| (ARRAY-HEADER FILL-POINTER) |of| VECTOR)
+       (LISP:ERROR "Not a vector: ~s" VECTOR)))
+
+(LISP:DEFUN LISP:VECTOR-POP (VECTOR)
+   (COND
+      ((AND (OR (%ONED-ARRAY-P VECTOR)
+                (%GENERAL-ARRAY-P VECTOR))
+            (|fetch| (ARRAY-HEADER FILL-POINTER-P) |of| VECTOR))
+       (LET ((FILL-POINTER (|fetch| (ARRAY-HEADER FILL-POINTER) |of| VECTOR)))
+            (LISP:IF (<= FILL-POINTER 0)
+                   (LISP:ERROR "Can't pop from zero fill pointer"))
+            (SETQ FILL-POINTER (LISP:1- FILL-POINTER))
+            (|replace| (ARRAY-HEADER FILL-POINTER) |of| VECTOR |with| FILL-POINTER)
+            (LISP:AREF VECTOR FILL-POINTER)))
+      ((%VECTORP VECTOR)
+       (LISP:ERROR "Vector has no fill pointer"))
+      (T (LISP:ERROR "Not a vector: ~S" VECTOR))))
+
+(LISP:DEFUN LISP:VECTOR-PUSH (NEW-ELEMENT VECTOR)
+   (COND
+      ((AND (OR (%ONED-ARRAY-P VECTOR)
+                (%GENERAL-ARRAY-P VECTOR))
+            (|fetch| (ARRAY-HEADER FILL-POINTER-P) |of| VECTOR))
+       (LET ((FILL-POINTER (|fetch| (ARRAY-HEADER FILL-POINTER) |of| VECTOR)))
+            (LISP:WHEN (< FILL-POINTER (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| VECTOR))
+                (ASET NEW-ELEMENT VECTOR FILL-POINTER)
+                (|replace| (ARRAY-HEADER FILL-POINTER) |of| VECTOR |with| (LISP:1+ 
+                                                                                         FILL-POINTER
+                                                                                             ))
+                FILL-POINTER)))
+      ((%VECTORP VECTOR)
+       (LISP:ERROR "Vector has no fill pointer"))
+      (T (LISP:ERROR "Not a vector: ~S" VECTOR))))
+
+(LISP:DEFUN LISP:VECTOR-PUSH-EXTEND (NEW-ELEMENT VECTOR &OPTIONAL (EXTENSION-SIZE 
+                                                                        *DEFAULT-PUSH-EXTENSION-SIZE*
+                                                                             ))
+
+   (* |;;| "Like VECTOR-PUSH except if VECTOR is adjustable -- in which case a push beyond (array-total-size VECTOR ) will call adjust-array")
+
+   (LET ((NEW-INDEX (LISP:VECTOR-PUSH NEW-ELEMENT VECTOR)))
+        (LISP:IF (NULL NEW-INDEX)
+            (COND
+               ((> EXTENSION-SIZE 0)
+                (LISP:ADJUST-ARRAY VECTOR (+ (LISP:ARRAY-TOTAL-SIZE VECTOR)
+                                                 EXTENSION-SIZE))
+                (LISP:VECTOR-PUSH NEW-ELEMENT VECTOR))
+               (T (LISP:ERROR "Extension-size not greater than zero")))
+            NEW-INDEX)))
+
+(LISP:DEFUN LISP:VECTORP (VECTOR)
+   (%VECTORP VECTOR))
+(DEFINEQ
+
+(LISP:AREF
+  (LAMBDA ARGS                                               (* \; "Edited 11-Dec-87 15:32 by jop")
+    (LISP:IF (< ARGS 1)
+           (LISP:ERROR "Aref takes at least one arg"))
+    (LET ((ARRAY (ARG ARGS 1)))
+         (CASE ARGS
+             (1 (%AREF0 ARRAY))
+             (2 (%AREF1 ARRAY (ARG ARGS 2)))
+             (3 (%AREF2 ARRAY (ARG ARGS 2)
+                       (ARG ARGS 3)))
+             (T (COND
+                   ((NOT (EQ (LISP:ARRAY-RANK ARRAY)
+                             (LISP:1- ARGS)))
+                    (LISP:ERROR "Rank mismatch"))
+                   (T 
+                      (* |;;| "If we've gotten this far ARRAY must be a general array")
+                                                             (* \; "Check indices in bounds")
+                      (LISP:DO ((I 2 (LISP:1+ I))
+                                (DIMLIST (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY)
+                                       (CDR DIMLIST))
+                                INDEX)
+                               ((> I ARGS))
+                          (SETQ INDEX (ARG ARGS I))
+                          (LISP:IF (NOT (< -1 INDEX (CAR DIMLIST)))
+                                 (LISP:ERROR "Index out of bounds: ~s" INDEX)))
+                                                             (* \; 
+                                                           "Now proceed to extract the element")
+                      (LET ((ROW-MAJOR-INDEX (LISP:DO ((I 2 (LISP:1+ I))
+                                                       (DIMLIST (CDR (|ffetch| (GENERAL-ARRAY
+                                                                                    DIMS)
+                                                                        |of| ARRAY))
+                                                              (CDR DIMLIST))
+                                                       (TOTAL 0))
+                                                      ((EQ I ARGS)
+                                                       (+ TOTAL (ARG ARGS ARGS)))
+                                                 (SETQ TOTAL (LISP:* (CAR DIMLIST)
+                                                                    (+ TOTAL (ARG ARGS I))))))
+                            (BASE-ARRAY ARRAY))
+                           (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX)
+                           (%ARRAY-READ (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY)
+                                  (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY)
+                                  (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
+                                     ROW-MAJOR-INDEX))))))))))
+
+(LISP:ARRAY-IN-BOUNDS-P
+  (LAMBDA ARGS                                               (* \; "Edited 11-Dec-87 15:32 by jop")
+    (LISP:IF (< ARGS 1)
+           (LISP:ERROR "Array-in-bounds-p takes at least one arg"))
+    (LET ((ARRAY (ARG ARGS 1)))
+         (LISP:IF (EQ (LISP:ARRAY-RANK ARRAY)
+                      (LISP:1- ARGS))
+             (%CHECK-INDICES ARRAY 2 ARGS)
+             (LISP:ERROR "Rank mismatch")))))
+
+(LISP:ARRAY-ROW-MAJOR-INDEX
+  (LAMBDA ARGS                                               (* \; "Edited 11-Dec-87 15:32 by jop")
+    (LISP:IF (< ARGS 1)
+           (LISP:ERROR "Array-row-major-index takes at least one arg"))
+    (LET ((ARRAY (ARG ARGS 1)))
+         (COND
+            ((NOT (EQ (LISP:ARRAY-RANK ARRAY)
+                      (LISP:1- ARGS)))
+             (LISP:ERROR "Rank mismatch"))
+            ((NOT (%CHECK-INDICES ARRAY 2 ARGS))
+             (LISP:ERROR "Index out of bounds"))
+            (T (LISP:DO ((I 2 (LISP:1+ I))
+                         (TOTAL 0))
+                        ((EQ I ARGS)
+                         (+ TOTAL (ARG ARGS ARGS)))
+                   (SETQ TOTAL (LISP:* (LISP:ARRAY-DIMENSION ARRAY (LISP:1- I))
+                                      (+ TOTAL (ARG ARGS I))))))))))
+
+(ASET
+  (LAMBDA ARGS                                               (* \; "Edited 11-Dec-87 15:33 by jop")
+    (LISP:IF (< ARGS 2)
+           (LISP:ERROR "Aset takes at least two args"))
+    (LET ((NEWVALUE (ARG ARGS 1))
+          (ARRAY (ARG ARGS 2)))
+         (CASE ARGS
+             (2 (%ASET0 NEWVALUE ARRAY))
+             (3 (%ASET1 NEWVALUE ARRAY (ARG ARGS 3)))
+             (4 (%ASET2 NEWVALUE ARRAY (ARG ARGS 3)
+                       (ARG ARGS 4)))
+             (T (COND
+                   ((NOT (EQ (LISP:ARRAY-RANK ARRAY)
+                             (- ARGS 2)))
+                    (LISP:ERROR "Rank mismatch"))
+                   (T                                        (* \; 
+                                           "If we've gotten this far array must be a general array")
+
+                      (* |;;| "Check indices")
+
+                      (LISP:DO ((I 3 (LISP:1+ I))
+                                (DIMLIST (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY)
+                                       (CDR DIMLIST))
+                                INDEX)
+                               ((> I ARGS))
+                          (SETQ INDEX (ARG ARGS I))
+                          (LISP:IF (NOT (< -1 INDEX (CAR DIMLIST)))
+                                 (LISP:ERROR "Index out of bounds: ~s" INDEX)))
+
+                      (* |;;| "Now proceed to extract the element")
+
+                      (LET ((ROW-MAJOR-INDEX (LISP:DO ((I 3 (LISP:1+ I))
+                                                       (DIMLIST (CDR (|ffetch| (GENERAL-ARRAY
+                                                                                    DIMS)
+                                                                        |of| ARRAY))
+                                                              (CDR DIMLIST))
+                                                       (TOTAL 0))
+                                                      ((EQ I ARGS)
+                                                       (+ TOTAL (ARG ARGS ARGS)))
+                                                 (SETQ TOTAL (LISP:* (CAR DIMLIST)
+                                                                    (+ TOTAL (ARG ARGS I))))))
+                            (BASE-ARRAY ARRAY))
+                           (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX)
+                           (LET ((TYPE-NUMBER (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| 
+                                                                                           BASE-ARRAY
+                                                     )))
+                                (LISP:IF (%CHECK-NOT-WRITEABLE ARRAY TYPE-NUMBER NEWVALUE)
+                                    (LISP:APPLY 'ASET NEWVALUE ARRAY (LISP:DO ((I ARGS (LISP:1-
+                                                                                        I))
+                                                                               LST)
+                                                                              ((< I 1)
+                                                                               LST)
+                                                                         (SETQ LST
+                                                                          (CONS (ARG ARGS I)
+                                                                                LST))))
+                                    (%ARRAY-WRITE NEWVALUE (|fetch| (ARRAY-HEADER BASE)
+                                                                  |of| BASE-ARRAY)
+                                           TYPE-NUMBER
+                                           (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
+                                              ROW-MAJOR-INDEX))))))))))))
+
+(LISP:VECTOR
+  (LAMBDA ARGS                                               (* \; "Edited 18-Dec-86 18:09 by jop")
+    (LET ((VECTOR (%MAKE-ONED-ARRAY ARGS T)))
+         (LISP:DOTIMES (I ARGS)
+             (ASET (ARG ARGS (LISP:1+ I))
+                    VECTOR I))
+         VECTOR)))
+)
+
+
+
+(* |;;| "New CLtL array functions")
+
+(DEFINEQ
+
+
+(LISP::ROW-MAJOR-ASET
+  (LAMBDA (ARRAY INDEX NEWVALUE)                             (* \; "Edited 11-Dec-87 15:54 by jop")
+    (LISP:IF (NOT (AND (>= INDEX 0)
+                       (< INDEX (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY))))
+        (LISP:ERROR "Index out of bounds: ~s" INDEX)
+        (LET ((ROW-MAJOR-INDEX INDEX)
+              (BASE-ARRAY ARRAY))
+
+             (* |;;| "Now proceed to extract the element")
+
+             (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX)
+             (LET ((TYPE-NUMBER (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY)))
+                  (LISP:IF (%CHECK-NOT-WRITEABLE ARRAY TYPE-NUMBER NEWVALUE)
+                      (LISP::ROW-MAJOR-ASET ARRAY INDEX NEWVALUE)
+                      (%ARRAY-WRITE NEWVALUE (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY
+                                                        )
+                             TYPE-NUMBER
+                             (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
+                                ROW-MAJOR-INDEX))))))))
+)
+
+(LISP:DEFSETF LISP::ROW-MAJOR-AREF LISP::ROW-MAJOR-ASET)
+
+
+
+(* |;;| "Setfs")
+
+
+(LISP:DEFSETF LISP:AREF (ARRAY &REST INDICES) (NEWVALUE)
+   `(ASET ,NEWVALUE ,ARRAY ,@INDICES))
+
+(LISP:DEFSETF BIT (ARRAY &REST INDICES) (NEWVALUE)
+   `(ASET ,NEWVALUE ,ARRAY ,@INDICES))
+
+(LISP:DEFSETF LISP:CHAR (ARRAY INDEX) (NEWVALUE)
+   `(ASET ,NEWVALUE ,ARRAY ,INDEX))
+
+(LISP:DEFSETF LISP:FILL-POINTER SET-FILL-POINTER)
+
+(LISP:DEFSETF LISP:SBIT (ARRAY &REST INDICES) (NEWVALUE)
+   `(ASET ,NEWVALUE ,ARRAY ,@INDICES))
+
+(LISP:DEFSETF LISP:SCHAR (ARRAY INDEX) (NEWVALUE)
+   `(ASET ,NEWVALUE ,ARRAY ,INDEX))
+
+(LISP:DEFSETF LISP:SVREF (ARRAY INDEX) (NEWVALUE)
+   `(ASET ,NEWVALUE ,ARRAY ,INDEX))
+
+
+
+(* |;;| "Optimizers")
+
+
+(LISP:DEFUN %AREF-EXPANDER (ARRAY INDICES)
+   (CASE (LENGTH INDICES)
+       (1 `(%AREF1 ,ARRAY ,@INDICES))
+       (2 `(%AREF2 ,ARRAY ,@INDICES))
+       (T 'COMPILER:PASS)))
+
+(LISP:DEFUN %ASET-EXPANDER (NEWVALUE ARRAY INDICES)
+   (CASE (LENGTH INDICES)
+       (1 `(%ASET1 ,NEWVALUE ,ARRAY ,@INDICES))
+       (2 `(%ASET2 ,NEWVALUE ,ARRAY ,@INDICES))
+       (T 'COMPILER:PASS)))
+
+(DEFOPTIMIZER LISP:AREF (ARRAY &REST INDICES)
+                            (%AREF-EXPANDER ARRAY INDICES))
+
+(DEFOPTIMIZER ASET (NEWVALUE ARRAY &REST INDICES)
+                       (%ASET-EXPANDER NEWVALUE ARRAY INDICES))
+
+(DEFOPTIMIZER BIT (ARRAY &REST INDICES)
+                      (%AREF-EXPANDER ARRAY INDICES))
+
+(DEFOPTIMIZER LISP:CHAR (STRING INDEX)
+                            `(%AREF1 ,STRING ,INDEX))
+
+(DEFOPTIMIZER LISP:SBIT (ARRAY &REST INDICES)
+                            (%AREF-EXPANDER ARRAY INDICES))
+
+(DEFOPTIMIZER LISP:SCHAR (STRING INDEX)
+                             `(%AREF1 ,STRING ,INDEX))
+
+(DEFOPTIMIZER LISP:SVREF (LISP:SIMPLE-VECTOR INDEX)
+                             `(%AREF1 ,LISP:SIMPLE-VECTOR ,INDEX))
+
+
+
+(* |;;| "Vars etc")
+
+
+
+
+(* \; "*PRINT-ARRAY* is defined in APRINT")
+
+
+(LISP:DEFCONSTANT LISP:ARRAY-RANK-LIMIT (EXPT 2 7))
+
+(LISP:DEFCONSTANT LISP:ARRAY-TOTAL-SIZE-LIMIT 65534)
+
+(LISP:DEFCONSTANT LISP:ARRAY-DIMENSION-LIMIT LISP:ARRAY-TOTAL-SIZE-LIMIT)
+
+(LISP:DEFPARAMETER *DEFAULT-PUSH-EXTENSION-SIZE* 20)
+
+
+
+(* |;;| "Run-time support")
+
+(DEFINEQ
+
+(%ALTER-AS-DISPLACED-ARRAY
+  (LAMBDA (ADJUSTABLE-ARRAY DIMENSIONS DISPLACED-TO DISPLACED-INDEX-OFFSET FILL-POINTER)
+                                                             (* \; "Edited 18-Dec-86 17:11 by jop")
+
+    (* |;;| 
+ "Alter ADJUSTABLE-ARRAY to be displaced to displaced-to. ADJUSTABLE-ARRAY must be a general array")
+
+    (LISP:IF (NULL DISPLACED-INDEX-OFFSET)
+           (SETQ DISPLACED-INDEX-OFFSET 0))
+    (LET ((DISPLACED-TO-READ-ONLY-P (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| DISPLACED-TO))
+          (TOTAL-SIZE (%TOTAL-SIZE DIMENSIONS))
+          (OFFSET (OR DISPLACED-INDEX-OFFSET 0))
+          BASE NEED-INDIRECTION-P)
+         (COND
+            ((OR (%THIN-CHAR-TYPE-P (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| DISPLACED-TO))
+                 (|fetch| (ARRAY-HEADER EXTENDABLE-P) |of| DISPLACED-TO)
+                 (|fetch| (ARRAY-HEADER ADJUSTABLE-P) |of| DISPLACED-TO)
+                 (AND DISPLACED-TO-READ-ONLY-P (NOT (|fetch| (ARRAY-HEADER INDIRECT-P)
+                                                       |of| DISPLACED-TO))))
+                                                             (* \; "Provide for indirection")
+             (SETQ BASE DISPLACED-TO)
+             (SETQ NEED-INDIRECTION-P T))
+            (T                                               (* \; 
+                                                  "Fold double displacement to single displacement")
+               (SETQ BASE (|fetch| (ARRAY-HEADER BASE) |of| DISPLACED-TO))
+               (SETQ OFFSET (+ OFFSET (%GET-ARRAY-OFFSET DISPLACED-TO)))
+               (LISP:IF (|fetch| (ARRAY-HEADER INDIRECT-P) |of| DISPLACED-TO)
+                      (SETQ NEED-INDIRECTION-P T))))         (* \; 
+                                        "Don't need to touch the type-number since it can't change")
+         (UNINTERRUPTABLY
+             (|freplace| (GENERAL-ARRAY STORAGE) |of| ADJUSTABLE-ARRAY |with| BASE)
+             (|freplace| (GENERAL-ARRAY READ-ONLY-P) |of| ADJUSTABLE-ARRAY |with| 
+                                                                             DISPLACED-TO-READ-ONLY-P
+                    )
+             (|freplace| (GENERAL-ARRAY INDIRECT-P) |of| ADJUSTABLE-ARRAY |with| 
+                                                                                   NEED-INDIRECTION-P
+                    )
+             (|freplace| (GENERAL-ARRAY DISPLACED-P) |of| ADJUSTABLE-ARRAY |with| T)
+             (|freplace| (GENERAL-ARRAY FILL-POINTER-P) |of| ADJUSTABLE-ARRAY |with|
+                                                                                      FILL-POINTER)
+             (|freplace| (GENERAL-ARRAY OFFSET) |of| ADJUSTABLE-ARRAY |with| OFFSET)
+             (|freplace| (GENERAL-ARRAY FILL-POINTER) |of| ADJUSTABLE-ARRAY
+                |with| (OR FILL-POINTER TOTAL-SIZE))
+             (|freplace| (GENERAL-ARRAY TOTAL-SIZE) |of| ADJUSTABLE-ARRAY |with| 
+                                                                                        TOTAL-SIZE)
+             (|freplace| (GENERAL-ARRAY DIMS) |of| ADJUSTABLE-ARRAY |with| DIMENSIONS))
+         ADJUSTABLE-ARRAY)))
+
+(%ALTER-AS-DISPLACED-TO-BASE-ARRAY
+  (LAMBDA (ADJUSTABLE-ARRAY DIMENSIONS ELEMENT-TYPE DISPLACED-TO-BASE DISPLACED-INDEX-OFFSET 
+                 FILL-POINTER FATP)                          (* \; "Edited 18-Dec-86 17:12 by jop")
+
+    (* |;;| "Alter adjustable-array to be displaced to displaced-to-base ")
+
+    (LET ((TOTAL-SIZE (%TOTAL-SIZE DIMENSIONS))
+          (TYPE-NUMBER (%CML-TYPE-TO-TYPENUMBER ELEMENT-TYPE FATP)))
+         (UNINTERRUPTABLY
+             (|freplace| (GENERAL-ARRAY STORAGE) |of| ADJUSTABLE-ARRAY |with| 
+                                                                                    DISPLACED-TO-BASE
+                    )
+             (|freplace| (GENERAL-ARRAY INDIRECT-P) |of| ADJUSTABLE-ARRAY |with| NIL)
+             (|freplace| (GENERAL-ARRAY DISPLACED-P) |of| ADJUSTABLE-ARRAY |with| T)
+             (|freplace| (GENERAL-ARRAY FILL-POINTER-P) |of| ADJUSTABLE-ARRAY |with|
+                                                                                      FILL-POINTER)
+             (|freplace| (GENERAL-ARRAY TYPE-NUMBER) |of| ADJUSTABLE-ARRAY |with| 
+                                                                                         TYPE-NUMBER)
+             (|freplace| (GENERAL-ARRAY OFFSET) |of| ADJUSTABLE-ARRAY |with| (OR 
+                                                                               DISPLACED-INDEX-OFFSET
+                                                                                             0))
+             (|freplace| (GENERAL-ARRAY FILL-POINTER) |of| ADJUSTABLE-ARRAY
+                |with| (OR FILL-POINTER TOTAL-SIZE))
+             (|freplace| (GENERAL-ARRAY TOTAL-SIZE) |of| ADJUSTABLE-ARRAY |with| 
+                                                                                        TOTAL-SIZE)
+             (|freplace| (GENERAL-ARRAY DIMS) |of| ADJUSTABLE-ARRAY |with| DIMENSIONS))
+         ADJUSTABLE-ARRAY)))
+
+(%AREF0
+  (LAMBDA (ARRAY)                                            (* \; "Edited 11-Dec-87 15:33 by jop")
+
+    (* |;;| "Special aref for the zero dimensional case")
+
+    (LISP:IF (EQ (LISP:ARRAY-RANK ARRAY)
+                 0)
+        (LET ((INDEX 0)
+              (BASE-ARRAY ARRAY))
+
+             (* |;;| "Must be a general array")
+
+             (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY INDEX)
+             (%ARRAY-READ (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY)
+                    (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY)
+                    (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
+                       INDEX)))
+        (LISP:ERROR "Rank mismatch"))))
+
+(%AREF1
+  (LAMBDA (ARRAY INDEX)                                      (* \; "Edited 11-Dec-87 15:50 by jop")
+
+    (* |;;| "specialized aref for the one-d case. Also the punt function for the aref1 opcode.")
+
+    (COND
+       ((NOT (EQ (LISP:ARRAY-RANK ARRAY)
+                 1))
+        (LISP:ERROR "Rank mismatch"))
+       ((NOT (AND (>= INDEX 0)
+                  (< INDEX (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY))))
+        (LISP:ERROR "Index out of bounds: ~A" INDEX))
+       (T 
+          (* |;;| "Now proceed to extract the element")
+
+          (LET ((BASE-ARRAY ARRAY))
+               (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY INDEX)
+               (%ARRAY-READ (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY)
+                      (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY)
+                      (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
+                         INDEX)))))))
+
+(%AREF2
+  (LAMBDA (ARRAY I J)                                        (* \; "Edited 11-Dec-87 15:33 by jop")
+
+    (* |;;| "Specialized aref for the two-d case. Also the punt function for the aref 2 opcode.")
+
+    (LISP:IF (EQ (LISP:ARRAY-RANK ARRAY)
+                 2)
+        (LET (BOUND0 BOUND1 OFFSET)                          (* \; 
+                                                           " ARRAY must be two-d or general")
+
+             (* |;;| "Get bounds and offset")
+
+             (COND
+                ((%TWOD-ARRAY-P ARRAY)                   (* \; "Twod array case")
+                 (SETQ BOUND0 (|ffetch| (TWOD-ARRAY BOUND0) |of| ARRAY))
+                 (SETQ BOUND1 (|ffetch| (TWOD-ARRAY BOUND1) |of| ARRAY))
+                 (SETQ OFFSET 0))
+                (T                                           (* \; "General array case")
+                   (SETQ BOUND0 (CAR (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY)))
+                   (SETQ BOUND1 (CADR (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY)))
+                   (SETQ OFFSET (|ffetch| (GENERAL-ARRAY OFFSET) |of| ARRAY))))
+                                                             (* \; "Check indices")
+             (COND
+                ((NOT (< -1 I BOUND0))
+                 (LISP:ERROR "Index out of bounds: ~A" I))
+                ((NOT (< -1 J BOUND1))
+                 (LISP:ERROR "Index out of bounds: ~A" J)))  (* \; "Extract the element")
+             (LET ((ROW-MAJOR-INDEX (+ J (LISP:* BOUND1 I)))
+                   (BASE-ARRAY ARRAY))
+                  (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX)
+                  (%ARRAY-READ (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY)
+                         (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY)
+                         (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
+                            ROW-MAJOR-INDEX))))
+        (LISP:ERROR "Rank mismatch"))))
+
+(%ARRAY-BASE
+  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 17:20 by jop")
+    (COND
+       ((OR (%ONED-ARRAY-P ARRAY)
+            (%TWOD-ARRAY-P ARRAY))
+        (|fetch| (ARRAY-HEADER BASE) |of| ARRAY))
+       ((%GENERAL-ARRAY-P ARRAY)
+        (|fetch| (ARRAY-HEADER BASE) |of| (LISP:LOOP (LISP:IF (NOT (|fetch| (ARRAY-HEADER
+                                                                                         INDIRECT-P)
+                                                                              |of| ARRAY))
+                                                                    (RETURN ARRAY))
+                                                         (SETQ ARRAY (|fetch| (ARRAY-HEADER
+                                                                                   BASE) |of|
+                                                                                         ARRAY)))))
+       (T (LISP:ERROR "Not an array: ~S" ARRAY)))))
+
+(%ARRAY-CONTENT-INITIALIZE
+  (LAMBDA (ARRAY INITIAL-CONTENTS)                           (* \; "Edited 11-Dec-87 15:33 by jop")
+    (LISP:IF (EQ 0 (LISP:ARRAY-RANK ARRAY))
+        (%ARRAY-ELEMENT-INITIALIZE ARRAY INITIAL-CONTENTS)
+        (LET ((DIMS (LISP:ARRAY-DIMENSIONS ARRAY)))
+             (LISP:IF (%CHECK-SEQUENCE-DIMENSIONS DIMS INITIAL-CONTENTS)
+                 (%FILL-ARRAY-FROM-SEQUENCE DIMS INITIAL-CONTENTS (%FLATTEN-ARRAY ARRAY)
+                        0)
+                 (LISP:ERROR "Dimensionality mismatch for Initial-contents"))))))
+
+(%ARRAY-ELEMENT-INITIALIZE
+  (LAMBDA (ARRAY INITIAL-ELEMENT)                            (* \; "Edited 11-Dec-87 15:33 by jop")
+
+    (* |;;| "Initialize an array with a value")
+
+    (LISP:UNLESS (EQ INITIAL-ELEMENT (%TYPENUMBER-TO-DEFAULT-VALUE (%ARRAY-TYPE-NUMBER ARRAY)))
+           (FILL-ARRAY ARRAY INITIAL-ELEMENT))))
+
+(%ARRAY-OFFSET
+  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 17:22 by jop")
+
+    (* |;;| "Get the true offset for ARRAY")
+
+    (COND
+       ((%ONED-ARRAY-P ARRAY)
+        (|fetch| (ARRAY-HEADER OFFSET) |of| ARRAY))
+       ((%TWOD-ARRAY-P ARRAY)
+        0)
+       ((%GENERAL-ARRAY-P ARRAY)
+        (LISP:DO ((OFFSET (|fetch| (ARRAY-HEADER OFFSET) |of| ARRAY)
+                         (+ OFFSET (%GET-ARRAY-OFFSET ARRAY))))
+                 ((NOT (|fetch| (ARRAY-HEADER INDIRECT-P) |of| ARRAY))
+                  OFFSET)
+            (SETQ ARRAY (|fetch| (ARRAY-HEADER BASE) |of| ARRAY))))
+       (T (LISP:ERROR "Not an array: ~S" ARRAY)))))
+
+(%ARRAY-TYPE-NUMBER
+  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 17:23 by jop")
+
+    (* |;;| "Get the true array-typenumber for ARRAY")
+
+    (COND
+       ((OR (%ONED-ARRAY-P ARRAY)
+            (%TWOD-ARRAY-P ARRAY))
+        (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| ARRAY))
+       ((%GENERAL-ARRAY-P ARRAY)
+        (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| (LISP:LOOP (LISP:IF
+                                                                     (NOT (|fetch| (ARRAY-HEADER
+                                                                                        INDIRECT-P)
+                                                                             |of| ARRAY))
+                                                                     (RETURN ARRAY))
+                                                                (SETQ ARRAY (|fetch| (
+                                                                                         ARRAY-HEADER
+                                                                                          BASE)
+                                                                               |of| ARRAY)))))
+       (T (LISP:ERROR "Not an array: ~S" ARRAY)))))
+
+(%ASET0
+  (LAMBDA (NEWVALUE ARRAY)                                   (* \; "Edited 11-Dec-87 15:33 by jop")
+
+    (* |;;| "Specialized aset for the zero-d case.")
+
+    (LISP:IF (EQ (LISP:ARRAY-RANK ARRAY)
+                 0)
+        (LET ((INDEX 0)
+              (BASE-ARRAY ARRAY))
+
+             (* |;;| "Must be a general array")
+
+             (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY INDEX)
+             (LET ((TYPE-NUMBER (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY)))
+                  (LISP:IF (%CHECK-NOT-WRITEABLE ARRAY TYPE-NUMBER NEWVALUE)
+                      (%ASET0 NEWVALUE ARRAY)
+                      (%ARRAY-WRITE NEWVALUE (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY
+                                                        )
+                             TYPE-NUMBER
+                             (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
+                                INDEX)))))
+        (LISP:ERROR "Rank mismatch"))))
+
+(%ASET1
+  (LAMBDA (NEWVALUE ARRAY INDEX)                             (* \; "Edited 11-Dec-87 15:34 by jop")
+
+    (* |;;| "Specialized aset for the one-d case. Also the punt for the aset1 opcode.")
+
+    (COND
+       ((NOT (EQ (LISP:ARRAY-RANK ARRAY)
+                 1))
+        (LISP:ERROR "Rank mismatch"))
+       ((NOT (AND (>= INDEX 0)
+                  (< INDEX (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY))))
+        (LISP:ERROR "Index out of bounds: ~s" INDEX))
+       (T 
+          (* |;;| "Now proceed to extract the element")
+
+          (LET ((ROW-MAJOR-INDEX INDEX)
+                (BASE-ARRAY ARRAY))
+               (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX)
+               (LET ((TYPE-NUMBER (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY)))
+                    (LISP:IF (%CHECK-NOT-WRITEABLE ARRAY TYPE-NUMBER NEWVALUE)
+                        (%ASET1 NEWVALUE ARRAY INDEX)
+                        (%ARRAY-WRITE NEWVALUE (|fetch| (ARRAY-HEADER BASE) |of| 
+                                                                                          BASE-ARRAY)
+                               TYPE-NUMBER
+                               (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
+                                  ROW-MAJOR-INDEX)))))))))
+
+(%ASET2
+  (LAMBDA (NEWVALUE ARRAY I J)                               (* \; "Edited 11-Dec-87 15:34 by jop")
+
+    (* |;;| "Specialized aset for the two-d case. Also the punt function for the aset2 opcode.")
+
+    (LISP:IF (EQ (LISP:ARRAY-RANK ARRAY)
+                 2)
+        (LET (BOUND0 BOUND1 OFFSET)
+
+             (* |;;| "Get bounds and offset")
+
+             (COND
+                ((%TWOD-ARRAY-P ARRAY)                   (* \; "Twod case")
+                 (SETQ BOUND0 (|ffetch| (TWOD-ARRAY BOUND0) |of| ARRAY))
+                 (SETQ BOUND1 (|ffetch| (TWOD-ARRAY BOUND1) |of| ARRAY))
+                 (SETQ OFFSET 0))
+                (T                                           (* \; "General Case")
+                   (SETQ BOUND0 (CAR (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY)))
+                   (SETQ BOUND1 (CADR (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY)))
+                   (SETQ OFFSET (|ffetch| (GENERAL-ARRAY OFFSET) |of| ARRAY))))
+
+             (* |;;| "Check indices")
+
+             (COND
+                ((NOT (< -1 I BOUND0))
+                 (LISP:ERROR "Index out of bounds ~s" I))
+                ((NOT (< -1 J BOUND1))
+                 (LISP:ERROR "Index out of bounds ~s" J)))
+
+             (* |;;| "Set element")
+
+             (LET ((ROW-MAJOR-INDEX (+ J (LISP:* BOUND1 I)))
+                   (BASE-ARRAY ARRAY))
+                  (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX)
+                  (LET ((TYPE-NUMBER (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY)))
+                       (LISP:IF (%CHECK-NOT-WRITEABLE ARRAY TYPE-NUMBER NEWVALUE)
+                           (%ASET2 NEWVALUE ARRAY I J)
+                           (%ARRAY-WRITE NEWVALUE (|fetch| (ARRAY-HEADER BASE) |of|
+                                                                                       BASE-ARRAY)
+                                  TYPE-NUMBER
+                                  (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
+                                     ROW-MAJOR-INDEX))))))
+        (LISP:ERROR "Rank mismatch"))))
+
+(%CHECK-SEQUENCE-DIMENSIONS
+  (LAMBDA (DIM-LST SEQUENCE)                                 (* \; "Edited 11-Dec-87 15:34 by jop")
+
+    (* |;;| "Returns NIL if there is a mismatch")
+
+    (LISP:IF (EQ (CAR DIM-LST)
+                 (LISP:LENGTH SEQUENCE))
+        (OR (NULL (CDR DIM-LST))
+            (LISP:DOTIMES (I (CAR DIM-LST)
+                             T)
+                (LISP:IF (NOT (%CHECK-SEQUENCE-DIMENSIONS (CDR DIM-LST)
+                                     (LISP:ELT SEQUENCE I)))
+                       (RETURN NIL)))))))
+
+(%COPY-TO-NEW-ARRAY
+  (LAMBDA (OLD-DIMS OLD-ARRAY OLD-OFFSET NEW-DIMS NEW-ARRAY NEW-OFFSET)
+                                                             (* \; "Edited 13-Feb-87 15:52 by jop")
+
+    (* |;;| "It is assumed that OLD-ARRAY and NEW-ARRAY are of the same rank")
+
+    (LET ((SIZE (MIN (CAR OLD-DIMS)
+                     (CAR NEW-DIMS))))
+         (LISP:IF (CDR OLD-DIMS)
+             (LISP:DOTIMES (I SIZE)
+                 (%COPY-TO-NEW-ARRAY (CDR OLD-DIMS)
+                        OLD-ARRAY
+                        (LISP:* (CADR OLD-DIMS)
+                               (+ OLD-OFFSET I))
+                        (CDR NEW-DIMS)
+                        NEW-ARRAY
+                        (LISP:* (CADR NEW-DIMS)
+                               (+ NEW-OFFSET I))))
+             (%FAST-COPY-BASE (%ARRAY-BASE OLD-ARRAY)
+                    (+ (%ARRAY-OFFSET OLD-ARRAY)
+                       OLD-OFFSET)
+                    (%ARRAY-TYPE-NUMBER OLD-ARRAY)
+                    (%ARRAY-BASE NEW-ARRAY)
+                    (+ (%ARRAY-OFFSET NEW-ARRAY)
+                       NEW-OFFSET)
+                    (%ARRAY-TYPE-NUMBER NEW-ARRAY)
+                    SIZE)))))
+
+(%DO-LOGICAL-OP
+  (LAMBDA (OP SOURCE DEST)                                   (* \; "Edited 18-Dec-86 17:43 by jop")
+    (LET ((SOURCE-BASE (%ARRAY-BASE SOURCE))
+          (SOURCE-OFFSET (%ARRAY-OFFSET SOURCE))
+          (SOURCE-SIZE (LISP:ARRAY-TOTAL-SIZE SOURCE))
+          (DEST-BASE (%ARRAY-BASE DEST))
+          (DEST-OFFSET (%ARRAY-OFFSET DEST))
+          (GBBT (DEFERREDCONSTANT (|create| PILOTBBT
+                                         PBTHEIGHT _ 1
+                                         PBTDISJOINT _ T)))
+          SOURCE-OP LOG-OP)
+         (UNINTERRUPTABLY
+             (|replace| (PILOTBBT PBTSOURCE) |of| GBBT |with| SOURCE-BASE)
+             (|replace| (PILOTBBT PBTSOURCEBIT) |of| GBBT |with| SOURCE-OFFSET)
+             (|replace| (PILOTBBT PBTDEST) |of| GBBT |with| DEST-BASE)
+             (|replace| (PILOTBBT PBTDESTBIT) |of| GBBT |with| DEST-OFFSET)
+             (|replace| (PILOTBBT PBTDESTBPL) |of| GBBT |with| SOURCE-SIZE)
+             (|replace| (PILOTBBT PBTSOURCEBPL) |of| GBBT |with| SOURCE-SIZE)
+             (|replace| (PILOTBBT PBTWIDTH) |of| GBBT |with| SOURCE-SIZE)
+             (CASE OP
+                 (COPY 
+                    (SETQ SOURCE-OP 0)
+                    (SETQ LOG-OP 0))
+                 (NOT 
+                    (SETQ SOURCE-OP 1)
+                    (SETQ LOG-OP 0))
+                 (AND 
+                    (SETQ SOURCE-OP 0)
+                    (SETQ LOG-OP 1))
+                 (CAND 
+                    (SETQ SOURCE-OP 1)
+                    (SETQ LOG-OP 1))
+                 (OR 
+                    (SETQ SOURCE-OP 0)
+                    (SETQ LOG-OP 2))
+                 (COR 
+                    (SETQ SOURCE-OP 1)
+                    (SETQ LOG-OP 2))
+                 (XOR 
+                    (SETQ SOURCE-OP 0)
+                    (SETQ LOG-OP 3))
+                 (CXOR 
+                    (SETQ SOURCE-OP 1)
+                    (SETQ LOG-OP 3)))
+             (|replace| (PILOTBBT PBTSOURCETYPE) |of| GBBT |with| SOURCE-OP)
+             (|replace| (PILOTBBT PBTOPERATION) |of| GBBT |with| LOG-OP)
+                                                             (* \; "Execute the BLT")
+             (\\PILOTBITBLT GBBT 0)
+             DEST))))
+
+(%EXTEND-ARRAY
+  (LAMBDA (EXTENDABLE-ARRAY NEW-ARRAY DIMENSIONS FILL-POINTER)
+                                                             (* \; "Edited 18-Dec-86 17:43 by jop")
+
+    (* |;;| "Extend ADJUSTABLE-ARRAY, using the base provided by NEW-ARRAY ")
+
+    (LET ((TYPE-NUMBER (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| NEW-ARRAY))
+          (TOTAL-SIZE (%TOTAL-SIZE DIMENSIONS))
+          (BASE (|fetch| (ARRAY-HEADER BASE) |of| NEW-ARRAY)))
+         (UNINTERRUPTABLY
+             (|replace| (ARRAY-HEADER BASE) |of| EXTENDABLE-ARRAY |with| BASE)
+             (|replace| (ARRAY-HEADER READ-ONLY-P) |of| EXTENDABLE-ARRAY |with| NIL)
+             (|replace| (ARRAY-HEADER TYPE-NUMBER) |of| EXTENDABLE-ARRAY |with| 
+                                                                                       TYPE-NUMBER)
+             (|replace| (ARRAY-HEADER TOTAL-SIZE) |of| EXTENDABLE-ARRAY |with| TOTAL-SIZE
+                    )
+             (COND
+                ((%TWOD-ARRAY-P EXTENDABLE-ARRAY)
+                 (|freplace| (TWOD-ARRAY BOUND0) |of| EXTENDABLE-ARRAY |with|
+                                                                               (CAR DIMENSIONS))
+                 (|freplace| (TWOD-ARRAY BOUND1) |of| EXTENDABLE-ARRAY |with|
+                                                                               (CADR DIMENSIONS)))
+                (T                                           (* \; "must be oned or general")
+                   (|replace| (ARRAY-HEADER DISPLACED-P) |of| EXTENDABLE-ARRAY |with|
+                                                                                       NIL)
+                   (|replace| (ARRAY-HEADER FILL-POINTER-P) |of| EXTENDABLE-ARRAY
+                      |with| FILL-POINTER)
+                   (|replace| (ARRAY-HEADER OFFSET) |of| EXTENDABLE-ARRAY |with| 0)
+                   (|replace| (ARRAY-HEADER FILL-POINTER) |of| EXTENDABLE-ARRAY
+                      |with| (OR FILL-POINTER TOTAL-SIZE))
+                   (LISP:WHEN (%GENERAL-ARRAY-P EXTENDABLE-ARRAY)
+                       (|freplace| (GENERAL-ARRAY INDIRECT-P) |of| EXTENDABLE-ARRAY
+                          |with| NIL)
+                       (|freplace| (GENERAL-ARRAY DIMS) |of| EXTENDABLE-ARRAY |with|
+                                                                                      DIMENSIONS)))))
+         EXTENDABLE-ARRAY)))
+
+(%FAST-COPY-BASE
+  (LAMBDA (FROM-BASE FROM-OFFSET FROM-TYPENUMBER TO-BASE TO-OFFSET TO-TYPENUMBER CNT)
+                                                             (* \; "Edited 11-Dec-87 15:34 by jop")
+
+    (* |;;| "Blts one array into another of the same element-type")
+
+    (LISP:IF (OR (NOT (EQ FROM-TYPENUMBER TO-TYPENUMBER))
+                 (EQ (%TYPENUMBER-TO-GC-TYPE TO-TYPENUMBER)
+                     PTRBLOCK.GCT))
+        (LISP:DO ((I FROM-OFFSET (LISP:1+ I))
+                  (LIMIT (+ FROM-OFFSET CNT))
+                  (J TO-OFFSET (LISP:1+ J)))
+                 ((EQ I LIMIT))
+            (%ARRAY-WRITE (%ARRAY-READ FROM-BASE FROM-TYPENUMBER I)
+                   TO-BASE TO-TYPENUMBER J))
+        (LET ((BITS-PER-ELEMENT (%TYPENUMBER-TO-BITS-PER-ELEMENT TO-TYPENUMBER))
+              (PBBT (DEFERREDCONSTANT (|create| PILOTBBT
+                                             PBTDISJOINT _ T
+                                             PBTSOURCETYPE _ 0
+                                             PBTOPERATION _ 0))))
+
+             (* |;;| "Uses \\PILOTBITBLT instead of \\BLT because offsets might not be word aligned, and BITS-PER-ELEMENT may be greater than BITSPERWORD (16). ")
+
+             (UNINTERRUPTABLY
+                 (|freplace| (PILOTBBT PBTSOURCE) |of| PBBT |with| FROM-BASE)
+                 (|freplace| (PILOTBBT PBTSOURCEBIT) |of| PBBT |with| (LISP:* 
+                                                                                     BITS-PER-ELEMENT
+                                                                                         FROM-OFFSET)
+                        )
+                 (|freplace| (PILOTBBT PBTDEST) |of| PBBT |with| TO-BASE)
+                 (|freplace| (PILOTBBT PBTDESTBIT) |of| PBBT |with| (LISP:* 
+                                                                                     BITS-PER-ELEMENT
+                                                                                       TO-OFFSET))
+                 (|freplace| (PILOTBBT PBTDESTBPL) |of| PBBT |with| BITS-PER-ELEMENT)
+                 (|freplace| (PILOTBBT PBTSOURCEBPL) |of| PBBT |with| BITS-PER-ELEMENT)
+                 (|freplace| (PILOTBBT PBTWIDTH) |of| PBBT |with| BITS-PER-ELEMENT)
+                 (|freplace| (PILOTBBT PBTHEIGHT) |of| PBBT |with| CNT)
+                 (\\PILOTBITBLT PBBT 0))
+             NIL))))
+
+(%FAT-STRING-ARRAY-P
+  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 17:44 by jop")
+    (%FAT-CHAR-TYPE-P (%ARRAY-TYPE-NUMBER ARRAY))))
+
+(%FILL-ARRAY-FROM-SEQUENCE
+  (LAMBDA (DIMS SEQUENCE FLATTENED-ARRAY OFFSET)             (* \; "Edited 11-Dec-87 15:34 by jop")
+    (LISP:IF (CDR DIMS)
+        (LISP:DOTIMES (I (CAR DIMS))
+            (%FILL-ARRAY-FROM-SEQUENCE (CDR DIMS)
+                   (LISP:ELT SEQUENCE I)
+                   FLATTENED-ARRAY
+                   (LISP:* (CADR DIMS)
+                          (+ OFFSET I))))
+        (LISP:DO ((I 0 (LISP:1+ I))
+                  (J OFFSET (LISP:1+ J))
+                  (LIMIT (CAR DIMS)))
+                 ((EQ I LIMIT))
+            (ASET (LISP:ELT SEQUENCE I)
+                   FLATTENED-ARRAY J)))))
+
+(%FLATTEN-ARRAY
+  (LAMBDA (ARRAY)                                            (* \; "Edited 11-Dec-87 15:34 by jop")
+
+    (* |;;| 
+  "Make a oned-array that shares storage with array.  If array is already oned then return array")
+
+    (LISP:IF (EQ 1 (LISP:ARRAY-RANK ARRAY))
+        ARRAY
+        (LISP:MAKE-ARRAY (LISP:ARRAY-TOTAL-SIZE ARRAY)
+               :ELEMENT-TYPE
+               (LISP:ARRAY-ELEMENT-TYPE ARRAY)
+               :DISPLACED-TO ARRAY))))
+
+(%MAKE-ARRAY-WRITEABLE
+  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 18:40 by jop")
+    (LISP:IF (NOT (%ARRAYP ARRAY))
+           (LISP:ERROR "Not an array: ~S" ARRAY))
+    (LET ((BASE-ARRAY ARRAY)
+          NEW-BASE OFFSET TOTAL-SIZE TYPE-NUMBER)
+
+         (* |;;| "Find the base array")
+
+         (LISP:IF (|fetch| (ARRAY-HEADER INDIRECT-P) |of| ARRAY)
+             (LISP:LOOP (LISP:IF (|fetch| (ARRAY-HEADER INDIRECT-P) |of| BASE-ARRAY)
+                            (SETQ BASE-ARRAY (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY))
+                            (RETURN NIL))))
+         (LISP:WHEN (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| BASE-ARRAY)
+
+             (* |;;| "Allocate the new storage")
+                                                             (* \; "Be careful about offsets")
+             (SETQ TOTAL-SIZE (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| BASE-ARRAY))
+             (SETQ OFFSET (%GET-ARRAY-OFFSET BASE-ARRAY))
+             (SETQ TYPE-NUMBER (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY))
+             (SETQ NEW-BASE (%MAKE-ARRAY-STORAGE (+ TOTAL-SIZE OFFSET)
+                                   TYPE-NUMBER))
+
+             (* |;;| "Initialize it")
+
+             (%FAST-COPY-BASE (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY)
+                    OFFSET TYPE-NUMBER NEW-BASE OFFSET TYPE-NUMBER TOTAL-SIZE)
+
+             (* |;;| "Smash the new base into the array-header")
+
+             (UNINTERRUPTABLY
+                 (|replace| (ARRAY-HEADER BASE) |of| BASE-ARRAY |with| NEW-BASE)
+                 (|replace| (ARRAY-HEADER READ-ONLY-P) |of| BASE-ARRAY |with| NIL)))
+
+         (* |;;| "Declare the array (and all arrays on its access chain) readable")
+
+         (UNINTERRUPTABLY
+             (LISP:DO ((NEXT-ARRAY ARRAY (|fetch| (ARRAY-HEADER BASE) |of| NEXT-ARRAY)))
+                      ((NOT (|fetch| (ARRAY-HEADER INDIRECT-P) |of| NEXT-ARRAY)))
+                 (|replace| (ARRAY-HEADER READ-ONLY-P) |of| NEXT-ARRAY |with| NIL)))
+
+         (* |;;| "return the original array")
+
+         ARRAY)))
+
+(%MAKE-DISPLACED-ARRAY
+  (LAMBDA (TOTALSIZE DIMENSIONS ELEMENT-TYPE DISPLACED-TO DISPLACED-INDEX-OFFSET FILL-POINTER 
+                 READ-ONLY-P ADJUSTABLE EXTENDABLE)          (* \; "Edited 18-Dec-86 17:48 by jop")
+
+    (* |;;| "Make a displaced array")
+
+    (LET ((DISPLACED-TO-TYPENUMBER (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| DISPLACED-TO))
+          (DISPLACE-TO-READ-ONLY-P (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| DISPLACED-TO))
+          (OFFSET (OR DISPLACED-INDEX-OFFSET 0))
+          BASE NEED-INDIRECTION-P)
+         (COND
+            ((OR (%THIN-CHAR-TYPE-P DISPLACED-TO-TYPENUMBER)
+                 (|fetch| (ARRAY-HEADER EXTENDABLE-P) |of| DISPLACED-TO)
+                 (|fetch| (ARRAY-HEADER ADJUSTABLE-P) |of| DISPLACED-TO)
+                 (AND DISPLACE-TO-READ-ONLY-P (NOT (|fetch| (ARRAY-HEADER INDIRECT-P)
+                                                      |of| DISPLACED-TO))))
+                                                             (* \; "Provide for indirection")
+             (SETQ BASE DISPLACED-TO)
+             (SETQ NEED-INDIRECTION-P T))
+            (T                                               (* \; 
+                                                  "Fold double displacement to single displacement")
+               (SETQ BASE (|fetch| (ARRAY-HEADER BASE) |of| DISPLACED-TO))
+               (SETQ OFFSET (+ OFFSET (%GET-ARRAY-OFFSET DISPLACED-TO)))
+               (LISP:IF (|fetch| (ARRAY-HEADER INDIRECT-P) |of| DISPLACED-TO)
+                      (SETQ NEED-INDIRECTION-P T))))
+         (COND
+            ((OR NEED-INDIRECTION-P ADJUSTABLE (> (LENGTH DIMENSIONS)
+                                                  1))        (* \; 
+                                                "Indirect strings always have %FAT-CHAR-TYPENUMBER")
+             (%MAKE-GENERAL-ARRAY TOTALSIZE DIMENSIONS ELEMENT-TYPE FILL-POINTER (%CHAR-TYPE-P
+                                                                                      
+                                                                              DISPLACED-TO-TYPENUMBER
+                                                                                      )
+                    (OR READ-ONLY-P DISPLACE-TO-READ-ONLY-P)
+                    ADJUSTABLE EXTENDABLE BASE OFFSET))
+            (T (%MAKE-ONED-ARRAY TOTALSIZE ELEMENT-TYPE FILL-POINTER (%FAT-CHAR-TYPE-P 
+                                                                              DISPLACED-TO-TYPENUMBER
+                                                                                )
+                      (OR READ-ONLY-P DISPLACE-TO-READ-ONLY-P)
+                      EXTENDABLE BASE OFFSET))))))
+
+(%MAKE-GENERAL-ARRAY
+  (LAMBDA (TOTAL-SIZE DIMENSIONS ELEMENT-TYPE FILL-POINTER FATP READ-ONLY-P ADJUSTABLE-P EXTENDABLE-P
+                 DISPLACED-TO DISPLACED-INDEX-OFFSET)        (* \; "Edited 11-Dec-87 15:35 by jop")
+
+    (* |;;| "General arrays cover all make-array cases, including those requiring indirection.")
+
+    (LET ((TYPE-NUMBER (%CML-TYPE-TO-TYPENUMBER ELEMENT-TYPE FATP)))
+         (|create| GENERAL-ARRAY
+                STORAGE _ (OR DISPLACED-TO (%MAKE-ARRAY-STORAGE TOTAL-SIZE TYPE-NUMBER))
+                READ-ONLY-P _ READ-ONLY-P
+                INDIRECT-P _ (%ARRAYP DISPLACED-TO)
+                BIT-P _ (%BIT-TYPE-P TYPE-NUMBER)
+                STRING-P _ (AND (%CHAR-TYPE-P TYPE-NUMBER)
+                                (EQ 1 (LENGTH DIMENSIONS)))
+                ADJUSTABLE-P _ ADJUSTABLE-P
+                DISPLACED-P _ DISPLACED-TO
+                FILL-POINTER-P _ FILL-POINTER
+                EXTENDABLE-P _ (OR EXTENDABLE-P ADJUSTABLE-P)
+                TYPE-NUMBER _ TYPE-NUMBER
+                OFFSET _ (OR DISPLACED-INDEX-OFFSET 0)
+                FILL-POINTER _ (OR FILL-POINTER TOTAL-SIZE)
+                TOTAL-SIZE _ TOTAL-SIZE
+                DIMS _ DIMENSIONS))))
+
+(%MAKE-ONED-ARRAY
+  (LAMBDA (TOTAL-SIZE ELEMENT-TYPE FILL-POINTER FATP READ-ONLY-P EXTENDABLE-P DISPLACED-TO 
+                 DISPLACED-INDEX-OFFSET)                     (* \; "Edited 18-Dec-86 17:48 by jop")
+
+    (* |;;| "Oned-arrays cover all one dimensional cases, except adjustable and displaced-to when indirection is necessary")
+
+    (LET ((TYPE-NUMBER (%CML-TYPE-TO-TYPENUMBER ELEMENT-TYPE FATP)))
+         (|create| ONED-ARRAY
+                BASE _ (OR DISPLACED-TO (%MAKE-ARRAY-STORAGE TOTAL-SIZE TYPE-NUMBER))
+                READ-ONLY-P _ READ-ONLY-P
+                BIT-P _ (%BIT-TYPE-P TYPE-NUMBER)
+                STRING-P _ (%CHAR-TYPE-P TYPE-NUMBER)
+                DISPLACED-P _ DISPLACED-TO
+                FILL-POINTER-P _ FILL-POINTER
+                EXTENDABLE-P _ EXTENDABLE-P
+                TYPE-NUMBER _ TYPE-NUMBER
+                OFFSET _ (OR DISPLACED-INDEX-OFFSET 0)
+                FILL-POINTER _ (OR FILL-POINTER TOTAL-SIZE)
+                TOTAL-SIZE _ TOTAL-SIZE))))
+
+(%MAKE-STRING-ARRAY-FAT
+  (LAMBDA (ARRAY)                                            (* \; "Edited 11-Dec-87 15:35 by jop")
+
+    (* |;;| "Like Adjust-array for the special case of Thin-string arrays")
+
+    (LISP:IF (NOT (%ARRAYP ARRAY))
+           (LISP:ERROR "Not an array" ARRAY))
+    (LET ((BASE-ARRAY ARRAY)
+          NEW-BASE OFFSET LIMIT)
+
+         (* |;;| "Find the base array")
+
+         (LISP:IF (|fetch| (ARRAY-HEADER INDIRECT-P) |of| ARRAY)
+             (LISP:LOOP (LISP:IF (|fetch| (ARRAY-HEADER INDIRECT-P) |of| BASE-ARRAY)
+                            (SETQ BASE-ARRAY (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY))
+                            (RETURN NIL))))
+
+         (* |;;| "Consistency check")
+
+         (LISP:IF (NOT (%THIN-CHAR-TYPE-P (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY
+                                                 )))
+                (LISP:ERROR "Not a thin string-char array: ~S" BASE-ARRAY))
+
+         (* |;;| "Allocate the new storage")
+                                                             (* \; "Be careful about offsets")
+         (SETQ OFFSET (%GET-ARRAY-OFFSET BASE-ARRAY))
+         (SETQ LIMIT (+ (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| BASE-ARRAY)
+                        OFFSET))
+         (SETQ NEW-BASE (%MAKE-ARRAY-STORAGE LIMIT %FAT-CHAR-TYPENUMBER))
+
+         (* |;;| "Initialize it")
+                                                             (* \; 
+                                  "Can't use %fast-copy-base because of the differing type numbers")
+         (LISP:DO ((I OFFSET (LISP:1+ I))
+                   (BASE-ARRAY-BASE (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY)))
+                  ((EQ I LIMIT))
+             (%ARRAY-WRITE (%ARRAY-READ BASE-ARRAY-BASE %THIN-CHAR-TYPENUMBER I)
+                    NEW-BASE %FAT-CHAR-TYPENUMBER I))
+
+         (* |;;| "Smash the new base into the array-header")
+
+         (UNINTERRUPTABLY
+             (|replace| (ARRAY-HEADER BASE) |of| BASE-ARRAY |with| NEW-BASE)
+             (|replace| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY |with| 
+                                                                                 %FAT-CHAR-TYPENUMBER
+                    ))
+
+         (* |;;| "return the original array")
+
+         ARRAY)))
+
+(%MAKE-TWOD-ARRAY
+  (LAMBDA (TOTAL-SIZE DIMENSIONS ELEMENT-TYPE FATP READ-ONLY-P EXTENDABLE-P)
+                                                             (* \; "Edited 18-Dec-86 17:49 by jop")
+
+    (* |;;| "Two-d arrays are only simple or extendable twod-arrays")
+
+    (LET ((BOUND0 (CAR DIMENSIONS))
+          (BOUND1 (CADR DIMENSIONS))
+          (TYPE-NUMBER (%CML-TYPE-TO-TYPENUMBER ELEMENT-TYPE FATP)))
+         (|create| TWOD-ARRAY
+                BASE _ (%MAKE-ARRAY-STORAGE TOTAL-SIZE TYPE-NUMBER)
+                READ-ONLY-P _ READ-ONLY-P
+                BIT-P _ (%BIT-TYPE-P TYPE-NUMBER)
+                EXTENDABLE-P _ EXTENDABLE-P
+                TYPE-NUMBER _ TYPE-NUMBER
+                BOUND0 _ BOUND0
+                BOUND1 _ BOUND1
+                TOTAL-SIZE _ TOTAL-SIZE))))
+
+(%TOTAL-SIZE
+  (LAMBDA (DIMS)                                             (* \; "Edited 18-Dec-86 17:53 by jop")
+    (LISP:DO ((DIM DIMS (CDR DIM))
+              (PROD 1))
+             ((NULL DIM)
+              PROD)
+        (SETQ PROD (LISP:* (CAR DIM)
+                          PROD)))))
+
+(SHRINK-VECTOR
+  (LAMBDA (VECTOR NEW-SIZE)                                  (* \; "Edited 18-Dec-86 18:08 by jop")
+    (COND
+       ((%VECTORP VECTOR)
+        (LISP:IF (OR (< NEW-SIZE 0)
+                     (> NEW-SIZE (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| VECTOR)))
+               (LISP:ERROR "Trying to shrink array ~s to bad size ~s" VECTOR NEW-SIZE))
+        (|replace| (ARRAY-HEADER FILL-POINTER-P) |of| VECTOR |with| T)
+        (|replace| (ARRAY-HEADER FILL-POINTER) |of| VECTOR |with| NEW-SIZE)
+        VECTOR)
+       (T (LISP:ERROR "Not a vector: ~S" VECTOR)))))
+)
+
+
+
+(* \; "For Interlisp string hack")
+
+(DEFINEQ
+
+(%SET-ARRAY-OFFSET
+  (LAMBDA (ARRAY NEWVALUE)                                   (* \; "Edited 18-Dec-86 17:51 by jop")
+
+    (* |;;| "Set the true offset for ARRAY")
+
+    (COND
+       ((%ONED-ARRAY-P ARRAY)
+        (|replace| (ARRAY-HEADER OFFSET) |of| ARRAY |with| NEWVALUE))
+       ((%TWOD-ARRAY-P ARRAY)
+        (LISP:ERROR "Twod-arrays have no offset"))
+       ((%GENERAL-ARRAY-P ARRAY)
+        (|replace| (ARRAY-HEADER OFFSET) |of| ARRAY
+           |with| (- NEWVALUE (LISP:DO* ((BASE-ARRAY ARRAY (|fetch| (ARRAY-HEADER BASE)
+                                                                  |of| BASE-ARRAY))
+                                             (OFFSET 0 (+ OFFSET (%GET-ARRAY-OFFSET BASE-ARRAY))))
+                                            ((NOT (|fetch| (ARRAY-HEADER INDIRECT-P) |of|
+                                                                                         BASE-ARRAY))
+                                             OFFSET)))))
+       (T (LISP:ERROR "Not an array: ~S" ARRAY)))
+    NEWVALUE))
+
+(%SET-ARRAY-TYPE-NUMBER
+  (LAMBDA (ARRAY NEWVALUE)                                   (* \; "Edited 18-Dec-86 17:52 by jop")
+
+    (* |;;| "Set the true type-number for array")
+
+    (COND
+       ((OR (%ONED-ARRAY-P ARRAY)
+            (%TWOD-ARRAY-P ARRAY))
+        (|replace| (ARRAY-HEADER TYPE-NUMBER) |of| ARRAY |with| NEWVALUE))
+       ((%GENERAL-ARRAY-P ARRAY)
+        (LISP:DO ((BASE-ARRAY ARRAY (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY)))
+                 ((NOT (|fetch| (ARRAY-HEADER INDIRECT-P) |of| BASE-ARRAY))
+                  (|replace| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY |with| NEWVALUE)))
+        )
+       (T (LISP:ERROR "Not an array ~S" ARRAY)))
+    NEWVALUE))
+)
+
+
+
+(* \; "Low level predicates")
+
+(DEFINEQ
+
+(%ONED-ARRAY-P
+  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 17:49 by jop")
+    (EQ (NTYPX ARRAY)
+        %ONED-ARRAY)))
+
+(%TWOD-ARRAY-P
+  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 17:53 by jop")
+    (EQ (NTYPX ARRAY)
+        %TWOD-ARRAY)))
+
+(%GENERAL-ARRAY-P
+  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 17:44 by jop")
+    (EQ (NTYPX ARRAY)
+        %GENERAL-ARRAY)))
+
+(%THIN-STRING-ARRAY-P
+  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 17:53 by jop")
+    (%THIN-CHAR-TYPE-P (%ARRAY-TYPE-NUMBER ARRAY))))
+)
+
+(DEFOPTIMIZER %ONED-ARRAY-P (ARRAY)
+                                `(AND ((OPCODES TYPEP 14)
+                                       ,ARRAY)
+                                      T))
+
+(DEFOPTIMIZER %TWOD-ARRAY-P (ARRAY)
+                                `(AND ((OPCODES TYPEP 15)
+                                       ,ARRAY)
+                                      T))
+
+(DEFOPTIMIZER %GENERAL-ARRAY-P (ARRAY)
+                                   `(AND ((OPCODES TYPEP 16)
+                                          ,ARRAY)
+                                         T))
+
+
+
+(* \; "Real record def's on cmlarray-support")
+
+
+(/DECLAREDATATYPE 'GENERAL-ARRAY '((BITS 8)
+                                   POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8)
+                                   WORD WORD WORD POINTER)
+       '((GENERAL-ARRAY 0 (BITS . 7))
+         (GENERAL-ARRAY 0 POINTER)
+         (GENERAL-ARRAY 2 (FLAGBITS . 0))
+         (GENERAL-ARRAY 2 (FLAGBITS . 16))
+         (GENERAL-ARRAY 2 (FLAGBITS . 32))
+         (GENERAL-ARRAY 2 (FLAGBITS . 48))
+         (GENERAL-ARRAY 2 (FLAGBITS . 64))
+         (GENERAL-ARRAY 2 (FLAGBITS . 80))
+         (GENERAL-ARRAY 2 (FLAGBITS . 96))
+         (GENERAL-ARRAY 2 (FLAGBITS . 112))
+         (GENERAL-ARRAY 2 (BITS . 135))
+         (GENERAL-ARRAY 3 (BITS . 15))
+         (GENERAL-ARRAY 4 (BITS . 15))
+         (GENERAL-ARRAY 5 (BITS . 15))
+         (GENERAL-ARRAY 6 POINTER))
+       '8)
+
+(/DECLAREDATATYPE 'ONED-ARRAY '((BITS 8)
+                                POINTER FLAG (BITS 1)
+                                FLAG FLAG (BITS 1)
+                                FLAG FLAG FLAG (BITS 8)
+                                WORD WORD WORD)
+       '((ONED-ARRAY 0 (BITS . 7))
+         (ONED-ARRAY 0 POINTER)
+         (ONED-ARRAY 2 (FLAGBITS . 0))
+         (ONED-ARRAY 2 (BITS . 16))
+         (ONED-ARRAY 2 (FLAGBITS . 32))
+         (ONED-ARRAY 2 (FLAGBITS . 48))
+         (ONED-ARRAY 2 (BITS . 64))
+         (ONED-ARRAY 2 (FLAGBITS . 80))
+         (ONED-ARRAY 2 (FLAGBITS . 96))
+         (ONED-ARRAY 2 (FLAGBITS . 112))
+         (ONED-ARRAY 2 (BITS . 135))
+         (ONED-ARRAY 3 (BITS . 15))
+         (ONED-ARRAY 4 (BITS . 15))
+         (ONED-ARRAY 5 (BITS . 15)))
+       '6)
+
+(/DECLAREDATATYPE 'TWOD-ARRAY '((BITS 8)
+                                POINTER FLAG (BITS 1)
+                                FLAG
+                                (BITS 4)
+                                FLAG
+                                (BITS 8)
+                                WORD WORD WORD)
+       '((TWOD-ARRAY 0 (BITS . 7))
+         (TWOD-ARRAY 0 POINTER)
+         (TWOD-ARRAY 2 (FLAGBITS . 0))
+         (TWOD-ARRAY 2 (BITS . 16))
+         (TWOD-ARRAY 2 (FLAGBITS . 32))
+         (TWOD-ARRAY 2 (BITS . 51))
+         (TWOD-ARRAY 2 (FLAGBITS . 112))
+         (TWOD-ARRAY 2 (BITS . 135))
+         (TWOD-ARRAY 3 (BITS . 15))
+         (TWOD-ARRAY 4 (BITS . 15))
+         (TWOD-ARRAY 5 (BITS . 15)))
+       '6)
+(ADDTOVAR SYSTEMRECLST
+
+(DATATYPE GENERAL-ARRAY ((NIL BITS 8)
+                             (STORAGE POINTER)
+                             (READ-ONLY-P FLAG)
+                             (INDIRECT-P FLAG)
+                             (BIT-P FLAG)
+                             (STRING-P FLAG)
+                             (ADJUSTABLE-P FLAG)
+                             (DISPLACED-P FLAG)
+                             (FILL-POINTER-P FLAG)
+                             (EXTENDABLE-P FLAG)
+                             (TYPE-NUMBER BITS 8)
+                             (OFFSET WORD)
+                             (FILL-POINTER WORD)
+                             (TOTAL-SIZE WORD)
+                             (DIMS POINTER)))
+
+(DATATYPE ONED-ARRAY ((NIL BITS 8)
+                          (BASE POINTER)
+                          (READ-ONLY-P FLAG)
+                          (NIL BITS 1)
+                          (BIT-P FLAG)
+                          (STRING-P FLAG)
+                          (NIL BITS 1)
+                          (DISPLACED-P FLAG)
+                          (FILL-POINTER-P FLAG)
+                          (EXTENDABLE-P FLAG)
+                          (TYPE-NUMBER BITS 8)
+                          (OFFSET WORD)
+                          (FILL-POINTER WORD)
+                          (TOTAL-SIZE WORD)))
+
+(DATATYPE TWOD-ARRAY ((NIL BITS 8)
+                          (BASE POINTER)
+                          (READ-ONLY-P FLAG)
+                          (NIL BITS 1)
+                          (BIT-P FLAG)
+                          (NIL BITS 4)
+                          (EXTENDABLE-P FLAG)
+                          (TYPE-NUMBER BITS 8)
+                          (BOUND0 WORD)
+                          (BOUND1 WORD)
+                          (TOTAL-SIZE WORD)))
+)
+
+(PUTPROPS %AREF1 DOPVAL (2 AREF1))
+
+(PUTPROPS %AREF2 DOPVAL (3 AREF2))
+
+(PUTPROPS %ASET1 DOPVAL (3 ASET1))
+
+(PUTPROPS %ASET2 DOPVAL (4 ASET2))
+
+
+
+(* |;;| "I/O")
+
+(DEFINEQ
+
+(%DEFPRINT-ARRAY
+  (LAMBDA (ARRAY STREAM)                                     (* \; "Edited  5-Feb-88 10:10 by jop")
+
+    (* |;;| "This is the defprint for the array type")
+
+    (COND
+       ((%VECTORP ARRAY)
+        (%DEFPRINT-VECTOR ARRAY STREAM))
+       ((NOT *PRINT-ARRAY*)
+        (%DEFPRINT-GENERIC-ARRAY ARRAY STREAM))
+       ((AND *PRINT-LEVEL* (<= *PRINT-LEVEL* 0))
+        (\\ELIDE.PRINT.ELEMENT STREAM)
+        T)
+       (T (LET ((HASH (LISP:CODE-CHAR (|fetch| (READTABLEP HASHMACROCHAR) |of| *READTABLE*)))
+                (RANK (LISP:ARRAY-RANK ARRAY))
+                RANKSTR)
+               (%CHECK-CIRCLE-PRINT ARRAY STREAM (SETQ RANKSTR (LISP:PRINC-TO-STRING RANK))
+                                                             (* \; "Make sure we have room for #na")
+                      (.SPACECHECK. STREAM (+ (VECTOR-LENGTH RANKSTR)
+                                              2))
+                      (LISP:WRITE-CHAR HASH STREAM)
+                      (LISP:WRITE-STRING RANKSTR STREAM)
+                      (LISP:WRITE-CHAR (CONSTANT #\A)
+                             STREAM)
+                      (LISP:IF (EQ RANK 0)
+                          (\\PRINDATUM (LISP:AREF ARRAY)
+                                 STREAM 0)
+                          (%PRINT-ARRAY-CONTENTS (%FLATTEN-ARRAY ARRAY)
+                                 0
+                                 (LISP:ARRAY-DIMENSIONS ARRAY)
+                                 STREAM)))
+               T)))))
+
+(%DEFPRINT-BITVECTOR
+  (LAMBDA (LISP:BIT-VECTOR STREAM)                           (* \; "Edited 11-Dec-87 15:35 by jop")
+
+    (* |;;| "*Print-level* is handled in %defprint-vector")
+
+    (LET ((HASH (LISP:CODE-CHAR (|fetch| (READTABLEP HASHMACROCHAR) |of| *READTABLE*)))
+          (SIZE (VECTOR-LENGTH LISP:BIT-VECTOR))
+          END.INDEX FINAL.INDEX ELIDED SIZESTR)
+         (SETQ END.INDEX (LISP:1- SIZE))
+         (%CHECK-CIRCLE-PRINT LISP:BIT-VECTOR STREAM
+                (LISP:UNLESS (EQ SIZE 0)
+                    (LISP:DO ((I (LISP:1- END.INDEX)
+                                 (LISP:1- I))
+                              (LAST.VALUE (LISP:AREF LISP:BIT-VECTOR END.INDEX)))
+                             ((OR (< I 0)
+                                  (NOT (EQL (LISP:AREF LISP:BIT-VECTOR I)
+                                            LAST.VALUE))))
+                        (SETQ END.INDEX I)))
+                (SETQ FINAL.INDEX (COND
+                                     ((AND *PRINT-LENGTH* (>= END.INDEX *PRINT-LENGTH*))
+                                      (SETQ ELIDED T)
+                                      (LISP:1- *PRINT-LENGTH*))
+                                     (T END.INDEX)))
+                (LISP:IF (NOT (EQ (LISP:1- SIZE)
+                                  END.INDEX))
+                    (SETQ SIZESTR (LISP:PRINC-TO-STRING SIZE)))
+                (.SPACECHECK. STREAM (+ (PROGN               (* \; 
+                                  "#* Plus 1 for final.index being 1 less than number bits printed")
+                                               3)
+                                        (LISP:IF SIZESTR
+                                            (VECTOR-LENGTH SIZESTR)
+                                            0)
+                                        FINAL.INDEX
+                                        (LISP:IF ELIDED
+                                            (PROGN           (* \; "Space for ...")
+                                                   3)
+                                            0)))
+                (LISP:WRITE-CHAR HASH STREAM)
+                (LISP:IF SIZESTR (LISP:WRITE-STRING SIZESTR STREAM))
+                (LISP:WRITE-CHAR (CONSTANT #\*)
+                       STREAM)
+                (LISP:DO ((I 0 (LISP:1+ I)))
+                         ((> I FINAL.INDEX))
+                    (\\OUTCHAR STREAM (+ (BIT LISP:BIT-VECTOR I)
+                                         (CONSTANT (LISP:CHAR-CODE #\0)))))
+                (LISP:IF ELIDED (\\ELIDE.PRINT.TAIL STREAM)))
+         T)))
+
+(%DEFPRINT-GENERIC-ARRAY
+  (LAMBDA (ARRAY STREAM)                                     (* \; "Edited 18-Dec-86 17:40 by jop")
+
+    (* |;;| "Invoked when *PRINT-ARRAY* is NIL")
+
+    (LET ((HASH (LISP:CODE-CHAR (|fetch| (READTABLEP HASHMACROCHAR) |of| *READTABLE*))))
+         (%CHECK-CIRCLE-PRINT ARRAY STREAM                   (* \; "Make sure we have room for #<")
+                (.SPACECHECK. STREAM 2)
+                (LISP:WRITE-CHAR HASH STREAM)
+                (LISP:WRITE-CHAR (CONSTANT #\<)
+                       STREAM)
+                (LISP:WRITE-STRING (LISP:PRINC-TO-STRING 'LISP:ARRAY)
+                       STREAM)
+                (LISP:WRITE-CHAR (CONSTANT #\Space)
+                       STREAM)
+                (LISP:WRITE-STRING (LISP:PRINC-TO-STRING (LISP:ARRAY-ELEMENT-TYPE ARRAY))
+                       STREAM)
+                (LISP:WRITE-CHAR (CONSTANT #\Space)
+                       STREAM)
+                (LISP:WRITE-STRING (LISP:PRINC-TO-STRING (LISP:ARRAY-DIMENSIONS ARRAY))
+                       STREAM)
+                (LISP:WRITE-CHAR (CONSTANT #\Space)
+                       STREAM)
+                (LISP:WRITE-CHAR (CONSTANT #\@)
+                       STREAM)
+                (LISP:WRITE-CHAR (CONSTANT #\Space)
+                       STREAM)
+                (\\PRINTADDR ARRAY STREAM)
+                (LISP:WRITE-CHAR (CONSTANT #\>)
+                       STREAM))
+         T)))
+
+(%DEFPRINT-VECTOR
+  (LAMBDA (VECTOR STREAM)                                    (* \; "Edited  5-Feb-88 10:11 by jop")
+
+    (* |;;| "Defprint for the oned-array type")
+
+    (COND
+       ((LISP:STRINGP VECTOR)
+        (%DEFPRINT-STRING VECTOR STREAM))
+       ((NOT *PRINT-ARRAY*)
+        (%DEFPRINT-GENERIC-ARRAY VECTOR STREAM))
+       ((AND *PRINT-LEVEL* (<= *PRINT-LEVEL* 0))
+        (\\ELIDE.PRINT.ELEMENT STREAM)
+        T)
+       ((LISP:BIT-VECTOR-P VECTOR)
+        (%DEFPRINT-BITVECTOR VECTOR STREAM))
+       (T (LET ((HASH (LISP:CODE-CHAR (|fetch| (READTABLEP HASHMACROCHAR) |of| *READTABLE*)))
+                (SIZE (VECTOR-LENGTH VECTOR))
+                END.INDEX FINAL.INDEX ELIDED SIZESTR)
+               (SETQ END.INDEX (LISP:1- SIZE))
+               (%CHECK-CIRCLE-PRINT VECTOR STREAM
+                      (LISP:UNLESS (EQ SIZE 0)
+                          (LISP:DO ((I (LISP:1- END.INDEX)
+                                       (LISP:1- I))
+                                    (LAST.VALUE (LISP:AREF VECTOR END.INDEX)))
+                                   ((OR (< I 0)
+                                        (NOT (EQL (LISP:AREF VECTOR I)
+                                                  LAST.VALUE))))
+                              (SETQ END.INDEX I)))
+                      (SETQ FINAL.INDEX (COND
+                                           ((AND *PRINT-LENGTH* (>= END.INDEX *PRINT-LENGTH*))
+                                            (SETQ ELIDED T)
+                                            (LISP:1- *PRINT-LENGTH*))
+                                           (T END.INDEX)))
+                      (LISP:IF (NOT (EQ (LISP:1- SIZE)
+                                        END.INDEX))
+                          (SETQ SIZESTR (LISP:PRINC-TO-STRING SIZE)))
+                      (.SPACECHECK. STREAM (+ (LISP:IF SIZESTR
+                                                  (VECTOR-LENGTH SIZESTR)
+                                                  0)
+                                              2))
+                      (LISP:WRITE-CHAR HASH STREAM)
+                      (LISP:IF SIZESTR (LISP:WRITE-STRING SIZESTR STREAM))
+                      (LISP:WRITE-CHAR (CONSTANT #\()
+                             STREAM)
+                      (LET ((*PRINT-LEVEL* (AND *PRINT-LEVEL* (LISP:1- *PRINT-LEVEL*))))
+                           (LISP:DO ((I 0 (LISP:1+ I)))
+                                    ((> I FINAL.INDEX))
+                               (LISP:IF (> I 0)
+                                   (LISP:WRITE-CHAR (CONSTANT #\Space)
+                                          STREAM))
+                               (\\PRINDATUM (LISP:AREF VECTOR I)
+                                      STREAM 0)))
+                      (LISP:IF ELIDED (\\ELIDE.PRINT.TAIL STREAM))
+                      (LISP:WRITE-CHAR (CONSTANT #\))
+                             STREAM))
+               T)))))
+
+(%DEFPRINT-STRING
+  (LAMBDA (STRING STREAM)                                    (* \; "Edited 11-Dec-87 15:36 by jop")
+
+    (* |;;| "May never get called since (IL:typename (make-string 10)) returns IL:stringp")
+
+    (LET ((ESCAPECHAR (|fetch| (READTABLEP ESCAPECHAR) |of| *READTABLE*))
+          (CLP (|fetch| (READTABLEP COMMONLISP) |of| *READTABLE*))
+          (SIZE (VECTOR-LENGTH STRING)))
+         (%CHECK-CIRCLE-PRINT STRING STREAM (.SPACECHECK. STREAM (LISP:IF CLP
+                                                                     2
+                                                                     (+ 2 SIZE)))
+                (LISP:WHEN *PRINT-ESCAPE*
+                    (\\OUTCHAR STREAM (CONSTANT (LISP:CHAR-CODE #\"))))
+                (LISP:DO ((I 0 (LISP:1+ I))
+                          CH)
+                         ((EQ I SIZE))
+                    (SETQ CH (LISP:CHAR-CODE (LISP:CHAR STRING I)))
+                    (LISP:WHEN (AND *PRINT-ESCAPE* (OR (EQ CH (CONSTANT (LISP:CHAR-CODE #\")))
+                                                       (EQ CH ESCAPECHAR)))
+                           (\\OUTCHAR STREAM ESCAPECHAR))
+                    (\\OUTCHAR STREAM CH))
+                (LISP:WHEN *PRINT-ESCAPE*
+                    (\\OUTCHAR STREAM (CONSTANT (LISP:CHAR-CODE #\")))))
+         T)))
+
+(%PRINT-ARRAY-CONTENTS
+  (LAMBDA (FLAT-ARRAY OFFSET DIMENSIONS STREAM)              (* \; "Edited  5-Feb-88 10:11 by jop")
+    (LET ((NELTS (CAR DIMENSIONS))
+          FINAL.INDEX ELIDED)
+         (COND
+            ((AND *PRINT-LENGTH* (> NELTS *PRINT-LENGTH*))
+             (SETQ ELIDED T)
+             (SETQ FINAL.INDEX (LISP:1- *PRINT-LENGTH*)))
+            (T (SETQ FINAL.INDEX (LISP:1- NELTS))))
+         (LISP:WRITE-CHAR (CONSTANT #\()
+                STREAM)
+         (COND
+            ((NULL (CDR DIMENSIONS))                         (* \; 
+                                                         "Down to bottom level, print the elements")
+             (LISP:DO ((I OFFSET (LISP:1+ I))
+                       (END-INDEX (+ OFFSET FINAL.INDEX)))
+                      ((> I END-INDEX))
+                 (LISP:IF (> I OFFSET)
+                     (LISP:WRITE-CHAR (CONSTANT #\Space)
+                            STREAM))
+                 (\\PRINDATUM (LISP:AREF FLAT-ARRAY I)
+                        STREAM 0)))
+            ((EQ *PRINT-LEVEL* 1)                            (* \; "Elide at this level")
+             (LISP:DO ((I 0 (LISP:1+ I)))
+                      ((> I FINAL.INDEX))
+                 (LISP:IF (> I OFFSET)
+                     (LISP:WRITE-CHAR (CONSTANT #\Space)
+                            STREAM))
+                 (\\ELIDE.PRINT.ELEMENT STREAM)))
+            (T (LET ((*PRINT-LEVEL* (AND *PRINT-LEVEL* (LISP:1- *PRINT-LEVEL*))))
+                    (LISP:DO ((I 0 (LISP:1+ I)))
+                             ((> I FINAL.INDEX))
+                        (LISP:IF (> I 0)
+                            (LISP:WRITE-CHAR (CONSTANT #\Space)
+                                   STREAM))
+                        (%PRINT-ARRAY-CONTENTS FLAT-ARRAY (LISP:* (CADR DIMENSIONS)
+                                                                     (+ OFFSET I))
+                               (CDR DIMENSIONS)
+                               STREAM)))))
+         (LISP:IF ELIDED (\\ELIDE.PRINT.TAIL STREAM))
+         (LISP:WRITE-CHAR (CONSTANT #\))
+                STREAM))))
+)
+
+(DEFPRINT 'ONED-ARRAY '%DEFPRINT-VECTOR)
+
+(DEFPRINT 'TWOD-ARRAY '%DEFPRINT-ARRAY)
+
+(DEFPRINT 'GENERAL-ARRAY '%DEFPRINT-ARRAY)
+
+
+
+(* |;;| 
+"Needed at run time. low level functions for accessing, setting, and allocating raw storage. also includes cml type to typenumber converters"
+)
+
+(DEFINEQ
+
+(%ARRAY-READ
+  (LAMBDA (BASE TYPE-NUMBER INDEX)
+    (%SLOW-ARRAY-READ BASE TYPE-NUMBER INDEX)))
+
+(%ARRAY-WRITE
+  (LAMBDA (NEWVALUE BASE TYPE-NUMBER INDEX)                  (* \; "Edited 18-Dec-86 17:23 by jop")
+    (%SLOW-ARRAY-WRITE NEWVALUE BASE TYPE-NUMBER INDEX)))
+
+(%CML-TYPE-TO-TYPENUMBER
+  (LAMBDA (ELEMENT-TYPE FATP)                                (* \; "Edited 18-Dec-86 17:30 by jop")
+    (LET ((CANONICAL-TYPE (%GET-CANONICAL-CML-TYPE ELEMENT-TYPE)))
+         (LISP:IF (AND FATP (EQ CANONICAL-TYPE 'LISP:BASE-CHARACTER))
+             %FAT-CHAR-TYPENUMBER
+             (%CML-TYPE-TO-TYPENUMBER-EXPANDER CANONICAL-TYPE)))))
+
+(%GET-CANONICAL-CML-TYPE
+  (LAMBDA (ELEMENT-TYPE)                                     (* \; "Edited 18-Dec-86 17:46 by jop")
+
+    (* |;;| "Returns the enclosing specialized array type")
+
+    (LISP:IF (LISP:CONSP ELEMENT-TYPE)
+        (CASE (CAR ELEMENT-TYPE)
+            (LISP:UNSIGNED-BYTE (%GET-ENCLOSING-UNSIGNED-BYTE ELEMENT-TYPE))
+            (LISP:SIGNED-BYTE (%GET-ENCLOSING-SIGNED-BYTE ELEMENT-TYPE))
+            (LISP:MOD (%REDUCE-MOD ELEMENT-TYPE))
+            (INTEGER (%REDUCE-INTEGER ELEMENT-TYPE))
+            (T (LET ((EXPANDER (TYPE-EXPANDER (CAR ELEMENT-TYPE))))
+                    (LISP:IF EXPANDER
+                        (%GET-CANONICAL-CML-TYPE (TYPE-EXPAND ELEMENT-TYPE EXPANDER))
+                        T))))
+        (CASE ELEMENT-TYPE
+            ((T XPOINTER LISP:SINGLE-FLOAT LISP:BASE-CHARACTER LISP:EXTENDED-CHARACTER) ELEMENT-TYPE)
+            (POINTER T)
+            (FLOAT 'LISP:SINGLE-FLOAT)
+            (LISP:FIXNUM '(LISP:SIGNED-BYTE 32))
+            ((LISP:STRING-CHAR LISP:CHARACTER LISP:STANDARD-CHAR) 'LISP:BASE-CHARACTER)
+            (BIT '(LISP:UNSIGNED-BYTE 1))
+            (T (LET ((EXPANDER (TYPE-EXPANDER ELEMENT-TYPE)))
+                    (LISP:IF EXPANDER
+                        (%GET-CANONICAL-CML-TYPE (TYPE-EXPAND ELEMENT-TYPE EXPANDER))
+                        T)))))))
+
+(%GET-ENCLOSING-SIGNED-BYTE
+  (LAMBDA (ELEMENT-TYPE)                                     (* \; "Edited  8-May-88 15:21 by jop")
+    (LET ((NBITS (CADR ELEMENT-TYPE)))
+         (LISP:IF (LISP:INTEGERP NBITS)
+             (COND
+                ((<= NBITS 16)
+                 '(LISP:SIGNED-BYTE 16))
+                ((<= NBITS 32)
+                 '(LISP:SIGNED-BYTE 32))
+                (T T))
+             T))))
+
+(%GET-ENCLOSING-UNSIGNED-BYTE
+  (LAMBDA (ELEMENT-TYPE)                                     (* \; "Edited  8-May-88 15:21 by jop")
+    (LET ((NBITS (CADR ELEMENT-TYPE)))
+         (LISP:IF (LISP:INTEGERP NBITS)
+             (COND
+                ((<= NBITS 1)
+                 '(LISP:UNSIGNED-BYTE 1))
+                ((<= NBITS 8)
+                 '(LISP:UNSIGNED-BYTE 8))
+                ((<= NBITS 16)
+                 '(LISP:UNSIGNED-BYTE 16))
+                (T T))
+             T))))
+
+(%MAKE-ARRAY-STORAGE
+  (LAMBDA (NELTS TYPENUMBER INIT-ON-PAGE ALIGNMENT)          (* \; "Edited 18-Dec-86 17:47 by jop")
+
+    (* |;;| "Allocates a raw storage block for an array of NELTS elements, of type TYPENUMBER")
+
+    (LET ((BITS-PER-ELEMENT (%TYPENUMBER-TO-BITS-PER-ELEMENT TYPENUMBER))
+          (GC-TYPE (%TYPENUMBER-TO-GC-TYPE TYPENUMBER)))
+         (\\ALLOCBLOCK (FOLDHI (LISP:* NELTS BITS-PER-ELEMENT)
+                              BITSPERCELL)
+                GC-TYPE INIT-ON-PAGE ALIGNMENT))))
+
+(%REDUCE-INTEGER
+  (LAMBDA (ELEMENT-TYPE)                                     (* \; "Edited  8-May-88 15:27 by jop")
+    (LET ((LOW (CADR ELEMENT-TYPE))
+          (HIGH (CADDR ELEMENT-TYPE)))
+         (LISP:IF (LISP:CONSP LOW)
+             (SETQ LOW (LISP:1+ (CAR LOW))))
+         (LISP:IF (LISP:CONSP HIGH)
+             (SETQ HIGH (LISP:1- (CAR HIGH))))
+         (LISP:IF (AND (LISP:INTEGERP LOW)
+                       (LISP:INTEGERP HIGH))
+             (LISP:IF (>= LOW 0)
+                 (COND
+                    ((< HIGH 2)
+                     '(LISP:UNSIGNED-BYTE 1))
+                    ((< HIGH 256)
+                     '(LISP:UNSIGNED-BYTE 8))
+                    ((< HIGH 65536)
+                     '(LISP:UNSIGNED-BYTE 16))
+                    (T T))
+                 (LET ((BOUND (MAX (- LOW)
+                                   HIGH)))
+                      (COND
+                         ((< BOUND 32768)
+                          '(LISP:SIGNED-BYTE 16))
+                         ((<= BOUND MAX.FIXP)
+                          '(LISP:SIGNED-BYTE 32))
+                         (T T))))
+             T))))
+
+(%REDUCE-MOD
+  (LAMBDA (ELEMENT-TYPE)                                     (* \; "Edited  8-May-88 15:22 by jop")
+    (LET ((MODNUM (CADR ELEMENT-TYPE)))
+         (LISP:IF (LISP:INTEGERP MODNUM)
+             (COND
+                ((<= MODNUM 2)
+                 '(LISP:UNSIGNED-BYTE 1))
+                ((<= MODNUM 256)
+                 '(LISP:UNSIGNED-BYTE 8))
+                ((<= MODNUM 65536)
+                 '(LISP:UNSIGNED-BYTE 16))
+                (T T))
+             T))))
+
+(%SLOW-ARRAY-READ
+  (LAMBDA (BASE TYPENUMBER ROW-MAJOR-INDEX)                  (* \; "Edited 18-Dec-86 17:52 by jop")
+
+    (* |;;| "Punt function for opcode arrayread")
+
+    (%LLARRAY-TYPED-GET BASE TYPENUMBER ROW-MAJOR-INDEX)))
+
+(%SLOW-ARRAY-WRITE
+  (LAMBDA (NEWVALUE BASE TYPENUMBER ROW-MAJOR-INDEX)         (* \; "Edited 18-Dec-86 17:53 by jop")
+
+    (* |;;| "Punt function for opcode arraywrite")
+
+    (LISP:IF (NOT (%LLARRAY-TYPEP TYPENUMBER NEWVALUE))
+        (LISP:ERROR "Illegal value: ~S" NEWVALUE)
+        (%LLARRAY-TYPED-PUT BASE TYPENUMBER ROW-MAJOR-INDEX NEWVALUE))
+    NEWVALUE))
+)
+
+(DEFOPTIMIZER %ARRAY-READ (BASE TYPENUMBER INDEX)
+                              `((OPCODES MISC3 9)
+                                ,BASE
+                                ,TYPENUMBER
+                                ,INDEX))
+
+(DEFOPTIMIZER %ARRAY-WRITE (NEWVALUE BASE TYPENUMBER INDEX)
+                               `((OPCODES MISC4 7)
+                                 ,NEWVALUE
+                                 ,BASE
+                                 ,TYPENUMBER
+                                 ,INDEX))
+
+
+
+(* |;;| "Compiler options")
+
+(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 
+(DECLARE\: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+
+(PUTPROPS CMLARRAY FILETYPE LISP:COMPILE-FILE)
+(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA LISP:VECTOR ASET LISP:ARRAY-ROW-MAJOR-INDEX LISP:ARRAY-IN-BOUNDS-P LISP:AREF)
+)
+(PUTPROPS CMLARRAY COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 1993))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (37276 45412 (LISP:AREF 37286 . 40020) (LISP:ARRAY-IN-BOUNDS-P 40022 . 40454) (
+LISP:ARRAY-ROW-MAJOR-INDEX 40456 . 41285) (ASET 41287 . 45110) (LISP:VECTOR 45112 . 45410)) (45457 
+46546 (LISP::ROW-MAJOR-ASET 45468 . 46544)) (48871 88151 (%ALTER-AS-DISPLACED-ARRAY 48881 . 52188) (
+%ALTER-AS-DISPLACED-TO-BASE-ARRAY 52190 . 54222) (%AREF0 54224 . 54930) (%AREF1 54932 . 55866) (%AREF2
+ 55868 . 57875) (%ARRAY-BASE 57877 . 58907) (%ARRAY-CONTENT-INITIALIZE 58909 . 59493) (
+%ARRAY-ELEMENT-INITIALIZE 59495 . 59836) (%ARRAY-OFFSET 59838 . 60571) (%ARRAY-TYPE-NUMBER 60573 . 
+61847) (%ASET0 61849 . 62828) (%ASET1 62830 . 64139) (%ASET2 64141 . 66290) (
+%CHECK-SEQUENCE-DIMENSIONS 66292 . 66844) (%COPY-TO-NEW-ARRAY 66846 . 68059) (%DO-LOGICAL-OP 68061 . 
+70418) (%EXTEND-ARRAY 70420 . 72986) (%FAST-COPY-BASE 72988 . 75476) (%FAT-STRING-ARRAY-P 75478 . 
+75662) (%FILL-ARRAY-FROM-SEQUENCE 75664 . 76303) (%FLATTEN-ARRAY 76305 . 76794) (%MAKE-ARRAY-WRITEABLE
+ 76796 . 79024) (%MAKE-DISPLACED-ARRAY 79026 . 81780) (%MAKE-GENERAL-ARRAY 81782 . 83011) (
+%MAKE-ONED-ARRAY 83013 . 84038) (%MAKE-STRING-ARRAY-FAT 84040 . 86417) (%MAKE-TWOD-ARRAY 86419 . 87235
+) (%TOTAL-SIZE 87237 . 87534) (SHRINK-VECTOR 87536 . 88149)) (88195 90050 (%SET-ARRAY-OFFSET 88205 . 
+89295) (%SET-ARRAY-TYPE-NUMBER 89297 . 90048)) (90089 90800 (%ONED-ARRAY-P 90099 . 90266) (
+%TWOD-ARRAY-P 90268 . 90435) (%GENERAL-ARRAY-P 90437 . 90610) (%THIN-STRING-ARRAY-P 90612 . 90798)) (
+95759 107797 (%DEFPRINT-ARRAY 95769 . 97306) (%DEFPRINT-BITVECTOR 97308 . 99909) (
+%DEFPRINT-GENERIC-ARRAY 99911 . 101361) (%DEFPRINT-VECTOR 101363 . 104323) (%DEFPRINT-STRING 104325 . 
+105681) (%PRINT-ARRAY-CONTENTS 105683 . 107795)) (108086 113801 (%ARRAY-READ 108096 . 108199) (
+%ARRAY-WRITE 108201 . 108384) (%CML-TYPE-TO-TYPENUMBER 108386 . 108760) (%GET-CANONICAL-CML-TYPE 
+108762 . 110121) (%GET-ENCLOSING-SIGNED-BYTE 110123 . 110542) (%GET-ENCLOSING-UNSIGNED-BYTE 110544 . 
+111039) (%MAKE-ARRAY-STORAGE 111041 . 111559) (%REDUCE-INTEGER 111561 . 112690) (%REDUCE-MOD 112692 . 
+113180) (%SLOW-ARRAY-READ 113182 . 113422) (%SLOW-ARRAY-WRITE 113424 . 113799)))))
+STOP
diff --git a/CLTL2/CMLARRAY-SUPPORT b/CLTL2/CMLARRAY-SUPPORT
new file mode 100644
index 00000000..97889a9e
--- /dev/null
+++ b/CLTL2/CMLARRAY-SUPPORT
@@ -0,0 +1,727 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+(FILECREATED "18-Oct-93 10:31:44" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLARRAY-SUPPORT.;2" 32489  
+
+      |previous| |date:| "12-Oct-93 16:33:46" 
+"{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLARRAY-SUPPORT.;1")
+
+
+; Copyright (c) 1986, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT CMLARRAY-SUPPORTCOMS)
+
+(RPAQQ CMLARRAY-SUPPORTCOMS
+       (
+        (* |;;| "Record def's")
+
+        (RECORDS ARRAY-HEADER GENERAL-ARRAY ONED-ARRAY TWOD-ARRAY)
+        
+        (* |;;| "Cmlarray support macros and functions")
+
+                                                             (* \; "Fast predicates")
+        (FUNCTIONS %ARRAYP %SIMPLE-ARRAY-P %SIMPLE-STRING-P %STRINGP %VECTORP)
+        (FUNCTIONS %CHECK-CIRCLE-PRINT %CHECK-INDICES %CHECK-NOT-WRITEABLE %EXPAND-BIT-OP 
+               %GENERAL-ARRAY-ADJUST-BASE %GET-ARRAY-OFFSET %GET-BASE-ARRAY)
+        (FUNCTIONS %BIT-TYPE-P %CHAR-TYPE-P %CML-TYPE-TO-TYPENUMBER-EXPANDER %FAT-CHAR-TYPE-P 
+               %FAT-STRING-CHAR-P %GET-TYPE-TABLE-ENTRY %LIT-SIZE-TO-SIZE %LIT-TYPE-TO-TYPE 
+               %LLARRAY-MAKE-ACCESSOR-EXPR %LLARRAY-MAKE-SETTOR-EXPR %LLARRAY-TYPED-GET 
+               %LLARRAY-TYPED-PUT %LLARRAY-TYPEP %MAKE-ARRAY-TYPE-TABLE %MAKE-CML-TYPE-TABLE 
+               %PACK-TYPENUMBER %SMALLFIXP-SMALLPOSP %SMALLPOSP-SMALLFIXP %THIN-CHAR-TYPE-P 
+               %THIN-STRING-CHAR-P %TYPE-SIZE-TO-TYPENUMBER %TYPENUMBER-TO-BITS-PER-ELEMENT 
+               %TYPENUMBER-TO-CML-TYPE %TYPENUMBER-TO-DEFAULT-VALUE %TYPENUMBER-TO-GC-TYPE 
+               %TYPENUMBER-TO-SIZE %TYPENUMBER-TO-TYPE \\GETBASESMALL-FIXP \\GETBASESTRING-CHAR 
+               \\GETBASETHINSTRING-CHAR \\PUTBASESMALL-FIXP \\PUTBASESTRING-CHAR 
+               \\PUTBASETHINSTRING-CHAR)
+        
+
+(* |;;;| "Describes each entry of \\ARRAY-TYPE-TABLE")
+
+        (STRUCTURES ARRAY-TABLE-ENTRY)
+        
+
+(* |;;;| "These vars contain all the necessary info for typed arrays")
+
+        (VARIABLES %LIT-ARRAY-SIZES %LIT-ARRAY-TABLE %LIT-ARRAY-TYPES)
+        
+
+(* |;;;| "Tables that drives various macros")
+
+        (VARIABLES %ARRAY-TYPE-TABLE %CANONICAL-CML-TYPES)
+        
+
+(* |;;;| "Constants for (SIGNED-BYTE 16)")
+
+        (VARIABLES MAX.SMALLFIXP MIN.SMALLFIXP)
+        
+
+(* |;;;| "Constants for STRING-CHARS")
+
+        (VARIABLES %CHAR-TYPE %BIT-TYPE %THIN-CHAR-TYPENUMBER %FAT-CHAR-TYPENUMBER %MAXTHINCHAR)
+        
+
+(* |;;;| "Array data-type numbers")
+
+        (VARIABLES %GENERAL-ARRAY %ONED-ARRAY %TWOD-ARRAY)
+        
+
+(* |;;;| "Compiler options")
+
+        (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
+        (PROP FILETYPE CMLARRAY-SUPPORT)))
+
+
+
+(* |;;| "Record def's")
+
+(DECLARE\: EVAL@COMPILE
+
+(BLOCKRECORD ARRAY-HEADER (
+
+(* |;;;| "Describes common slots of all array headers")
+
+                               (NIL BITS 4)                (* \; "First 8 bits are unused")
+                               (BASE POINTER)                (* \; 
+      "24 bits of pointer. Points at raw storage or, in the indirect case, at another array header")
+                                                             (* \; "8 bits of flags")
+                               (READ-ONLY-P FLAG)            (* \; 
+                                                      "Used for headers pointing at symbols pnames")
+                               (INDIRECT-P FLAG)             (* \; 
+                                        "Points at an array header rather than a raw storage block")
+                               (BIT-P FLAG)                  (* \; "Is a bit array")
+                               (STRING-P FLAG)               (* \; 
+                                                           "Is a string (implies is a vector)")
+                                                             (* \; 
+                                   "If any of the following flags are set, the array in non-simple")
+                               (ADJUSTABLE-P FLAG)
+                               (DISPLACED-P FLAG)
+                               (FILL-POINTER-P FLAG)
+                               (EXTENDABLE-P FLAG)
+                               (TYPE-NUMBER BITS 8)          (* \; "8 bits of type + size")
+                               (OFFSET WORD)                 (* \; "For oned and general arrays")
+                               (FILL-POINTER FIXP)           (* \; "For oned and general arrays")
+                               (TOTAL-SIZE FIXP))
+                              (BLOCKRECORD ARRAY-HEADER ((NIL POINTER)
+                                                         (FLAGS BITS 8)
+                                                         (TYPE BITS 4)
+                                                         (SIZE BITS 4)))
+                              (ACCESSFNS (SIMPLE-P (EQ 0 (LOGAND (|fetch| (ARRAY-HEADER FLAGS)
+                                                                    |of| DATUM)
+                                                                15))))
+                              (SYSTEM))
+
+(DATATYPE GENERAL-ARRAY ((NIL BITS 4)                  (* \; "For alignment")
+                             (STORAGE POINTER)               (* \; "24 bits of pointer")
+                             (READ-ONLY-P FLAG)              (* \; "8 bits of flags")
+                             (INDIRECT-P FLAG)
+                             (BIT-P FLAG)
+                             (STRING-P FLAG)
+                             (ADJUSTABLE-P FLAG)
+                             (DISPLACED-P FLAG)
+                             (FILL-POINTER-P FLAG)
+                             (EXTENDABLE-P FLAG)
+                             (TYPE-NUMBER BITS 8)            (* \; "8 bits of typenumber")
+                             (OFFSET WORD)
+                             (FILL-POINTER FIXP)             (* \; 
+                                                           "As of 2.1, these 2 fields are fixp's.")
+                             (TOTAL-SIZE FIXP)
+                             (DIMS POINTER)))
+
+(DATATYPE ONED-ARRAY ((NIL BITS 4)                     (* \; "Don't use high 8 bits")
+                          (BASE POINTER)                     (* \; "The raw storage base")
+                          (READ-ONLY-P FLAG)                 (* \; "8 bits worth of flags")
+                          (NIL BITS 1)                     (* \; 
+                                                           "Oned array's cann't be indirect")
+                          (BIT-P FLAG)
+                          (STRING-P FLAG)
+                          (NIL BITS 1)                     (* \; 
+                                                           "Oned-array's cann't be adjustable")
+                          (DISPLACED-P FLAG)
+                          (FILL-POINTER-P FLAG)
+                          (EXTENDABLE-P FLAG)
+                          (TYPE-NUMBER BITS 8)               (* \; 
+                                                           "4 bits of type and 4 bits of size")
+                          (OFFSET WORD)                      (* \; "For displaced arrays")
+                          (FILL-POINTER FIXP)                (* \; "For filled arrays")
+                          (TOTAL-SIZE FIXP)                  (* \; "Total number of elements")
+                          ))
+
+(DATATYPE TWOD-ARRAY ((NIL BITS 4)                     (* \; "For alignmnet")
+                          (BASE POINTER)                     (* \; "Raw storage pointer")
+                          (READ-ONLY-P FLAG)                 (* \; "8 bits of flags")
+                          (NIL BITS 1)                     (* \; "Twod arrays cann't be indirect")
+                          (BIT-P FLAG)
+                          (NIL BITS 4)                     (* \; 
+      "Twod arrays cann't be strings, nor can they be adjustable, displaced, or have fill pointers")
+                          (EXTENDABLE-P FLAG)
+                          (TYPE-NUMBER BITS 8)
+                          (BOUND0 FIXP)                      (* \; "Zero dimension bound")
+                          (BOUND1 FIXP)                      (* \; "One dimension bound")
+                          (TOTAL-SIZE FIXP)))
+)
+
+(/DECLAREDATATYPE 'GENERAL-ARRAY '((BITS 4)
+                                   POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8)
+                                   WORD FIXP FIXP POINTER)
+       '((GENERAL-ARRAY 0 (BITS . 3))
+         (GENERAL-ARRAY 0 POINTER)
+         (GENERAL-ARRAY 2 (FLAGBITS . 0))
+         (GENERAL-ARRAY 2 (FLAGBITS . 16))
+         (GENERAL-ARRAY 2 (FLAGBITS . 32))
+         (GENERAL-ARRAY 2 (FLAGBITS . 48))
+         (GENERAL-ARRAY 2 (FLAGBITS . 64))
+         (GENERAL-ARRAY 2 (FLAGBITS . 80))
+         (GENERAL-ARRAY 2 (FLAGBITS . 96))
+         (GENERAL-ARRAY 2 (FLAGBITS . 112))
+         (GENERAL-ARRAY 2 (BITS . 135))
+         (GENERAL-ARRAY 3 (BITS . 15))
+         (GENERAL-ARRAY 4 FIXP)
+         (GENERAL-ARRAY 6 FIXP)
+         (GENERAL-ARRAY 8 POINTER))
+       '10)
+
+(/DECLAREDATATYPE 'ONED-ARRAY '((BITS 4)
+                                POINTER FLAG (BITS 1)
+                                FLAG FLAG (BITS 1)
+                                FLAG FLAG FLAG (BITS 8)
+                                WORD FIXP FIXP)
+       '((ONED-ARRAY 0 (BITS . 3))
+         (ONED-ARRAY 0 POINTER)
+         (ONED-ARRAY 2 (FLAGBITS . 0))
+         (ONED-ARRAY 2 (BITS . 16))
+         (ONED-ARRAY 2 (FLAGBITS . 32))
+         (ONED-ARRAY 2 (FLAGBITS . 48))
+         (ONED-ARRAY 2 (BITS . 64))
+         (ONED-ARRAY 2 (FLAGBITS . 80))
+         (ONED-ARRAY 2 (FLAGBITS . 96))
+         (ONED-ARRAY 2 (FLAGBITS . 112))
+         (ONED-ARRAY 2 (BITS . 135))
+         (ONED-ARRAY 3 (BITS . 15))
+         (ONED-ARRAY 4 FIXP)
+         (ONED-ARRAY 6 FIXP))
+       '8)
+
+(/DECLAREDATATYPE 'TWOD-ARRAY '((BITS 4)
+                                POINTER FLAG (BITS 1)
+                                FLAG
+                                (BITS 4)
+                                FLAG
+                                (BITS 8)
+                                FIXP FIXP FIXP)
+       '((TWOD-ARRAY 0 (BITS . 3))
+         (TWOD-ARRAY 0 POINTER)
+         (TWOD-ARRAY 2 (FLAGBITS . 0))
+         (TWOD-ARRAY 2 (BITS . 16))
+         (TWOD-ARRAY 2 (FLAGBITS . 32))
+         (TWOD-ARRAY 2 (BITS . 51))
+         (TWOD-ARRAY 2 (FLAGBITS . 112))
+         (TWOD-ARRAY 2 (BITS . 135))
+         (TWOD-ARRAY 3 FIXP)
+         (TWOD-ARRAY 5 FIXP)
+         (TWOD-ARRAY 7 FIXP))
+       '10)
+
+
+
+(* |;;| "Cmlarray support macros and functions")
+
+
+
+
+(* \; "Fast predicates")
+
+
+(DEFMACRO %ARRAYP (ARRAY)
+   (LISP:IF (LISP:SYMBOLP ARRAY)
+       `(OR (%ONED-ARRAY-P ,ARRAY)
+            (%TWOD-ARRAY-P ,ARRAY)
+            (%GENERAL-ARRAY-P ,ARRAY))
+       (LET ((SYM (GENSYM)))
+            `(LET ((,SYM ,ARRAY))
+                  (OR (%ONED-ARRAY-P ,SYM)
+                      (%TWOD-ARRAY-P ,SYM)
+                      (%GENERAL-ARRAY-P ,SYM))))))
+
+(DEFMACRO %SIMPLE-ARRAY-P (ARRAY)
+   (LISP:IF (LISP:SYMBOLP ARRAY)
+       `(AND (%ARRAYP ,ARRAY)
+             (|fetch| (ARRAY-HEADER SIMPLE-P) |of| ,ARRAY))
+       (LET ((SYM (GENSYM)))
+            `(LET ((,SYM ,ARRAY))
+                  (AND (%ARRAYP ,SYM)
+                       (|fetch| (ARRAY-HEADER SIMPLE-P) |of| ,SYM))))))
+
+(DEFMACRO %SIMPLE-STRING-P (STRING)
+   (LISP:IF (LISP:SYMBOLP STRING)
+       `(AND (%ONED-ARRAY-P ,STRING)
+             (|fetch| (ARRAY-HEADER SIMPLE-P) |of| ,STRING)
+             (|fetch| (ARRAY-HEADER STRING-P) |of| ,STRING))
+       (LET ((SYM (GENSYM)))
+            `(LET ((,SYM ,STRING))
+                  (AND (%ONED-ARRAY-P ,SYM)
+                       (|fetch| (ARRAY-HEADER SIMPLE-P) |of| ,SYM)
+                       (|fetch| (ARRAY-HEADER STRING-P) |of| ,SYM))))))
+
+(DEFMACRO %STRINGP (STRING)
+   (LISP:IF (LISP:SYMBOLP STRING)
+       `(AND (OR (%ONED-ARRAY-P ,STRING)
+                 (%GENERAL-ARRAY-P ,STRING))
+             (|fetch| (ARRAY-HEADER STRING-P) |of| ,STRING))
+       (LET ((SYM (GENSYM)))
+            `(LET ((,SYM ,STRING))
+                  (AND (OR (%ONED-ARRAY-P ,SYM)
+                           (%GENERAL-ARRAY-P ,SYM))
+                       (|fetch| (ARRAY-HEADER STRING-P) |of| ,SYM))))))
+
+(DEFMACRO %VECTORP (VECTOR)
+   (LISP:IF (LISP:SYMBOLP VECTOR)
+       `(OR (%ONED-ARRAY-P ,VECTOR)
+            (AND (%GENERAL-ARRAY-P ,VECTOR)
+                 (EQL 1 (LENGTH (|ffetch| (GENERAL-ARRAY DIMS) |of| ,VECTOR)))))
+       (LET ((SYM (GENSYM)))
+            `(LET ((,SYM ,VECTOR))
+                  (OR (%ONED-ARRAY-P ,SYM)
+                      (AND (%GENERAL-ARRAY-P ,SYM)
+                           (EQL 1 (LENGTH (|ffetch| (GENERAL-ARRAY DIMS) |of| ,SYM)))))))))
+
+(DEFMACRO %CHECK-CIRCLE-PRINT (OBJECT STREAM &REST PRINT-FORMS)
+
+   (* |;;| "If A has a circle label, print it. If it's not the first time or it has no label, print the contents")
+
+   `(LET (CIRCLELABEL FIRSTTIME)
+         (AND *PRINT-CIRCLE-HASHTABLE* (LISP:MULTIPLE-VALUE-SETQ (CIRCLELABEL FIRSTTIME)
+                                              (PRINT-CIRCLE-LOOKUP ,OBJECT)))
+         (LISP:WHEN CIRCLELABEL
+             (.SPACECHECK. ,STREAM (VECTOR-LENGTH CIRCLELABEL))
+             (LET (*PRINT-CIRCLE-HASHTABLE*)
+                  (DECLARE (LISP:SPECIAL *PRINT-CIRCLE-HASHTABLE*))
+                                                             (* \; 
+                                "No need to print-circle this string (dangerous if we do, in fact)")
+                  (LISP:WRITE-STRING CIRCLELABEL ,STREAM))
+             (LISP:WHEN FIRSTTIME
+                 (.SPACECHECK. ,STREAM 1)
+                 (LISP:WRITE-CHAR #\Space ,STREAM)))
+         (LISP:WHEN (OR (NOT CIRCLELABEL)
+                        FIRSTTIME)
+                ,@PRINT-FORMS)))
+
+(DEFMACRO %CHECK-INDICES (ARRAY START-ARG ARGS)
+   `(LISP:DO ((I ,START-ARG (LISP:1+ I))
+              (DIM 0 (LISP:1+ DIM))
+              INDEX)
+             ((> I ,ARGS)
+              T)
+        (SETQ INDEX (ARG ,ARGS I))
+        (LISP:IF (OR (< INDEX 0)
+                     (>= INDEX (LISP:ARRAY-DIMENSION ,ARRAY DIM)))
+               (RETURN NIL))))
+
+(DEFMACRO %CHECK-NOT-WRITEABLE (ARRAY TYPE-NUMBER NEWVALUE)
+   `(COND
+       ((|fetch| (ARRAY-HEADER READ-ONLY-P) |of| ,ARRAY)
+        (%MAKE-ARRAY-WRITEABLE ,ARRAY))
+       ((AND (%THIN-CHAR-TYPE-P ,TYPE-NUMBER)
+             (%FAT-STRING-CHAR-P ,NEWVALUE))
+        (%MAKE-STRING-ARRAY-FAT ,ARRAY))))
+
+(DEFMACRO %EXPAND-BIT-OP (OP BIT-ARRAY1 BIT-ARRAY2 RESULT-BIT-ARRAY)
+   `(PROGN (LISP:IF (NOT (BIT-ARRAY-P ,BIT-ARRAY1))
+               (LISP:ERROR "BIT-ARRAY1 not a bit array: ~S" ,BIT-ARRAY1))
+           (LISP:IF (NOT (BIT-ARRAY-P ,BIT-ARRAY2))
+               (LISP:ERROR "BIT-ARRAY2 not a bit array: ~S" ,BIT-ARRAY2))
+           (LISP:IF (NOT (EQUAL-DIMENSIONS-P ,BIT-ARRAY1 ,BIT-ARRAY2))
+                  (LISP:ERROR "Bit-arrays not of same dimensions"))
+           (COND
+              ((NULL ,RESULT-BIT-ARRAY)
+               (SETQ ,RESULT-BIT-ARRAY (LISP:MAKE-ARRAY (LISP:ARRAY-DIMENSIONS ,BIT-ARRAY1)
+                                              :ELEMENT-TYPE
+                                              'BIT)))
+              ((EQ ,RESULT-BIT-ARRAY T)
+               (SETQ ,RESULT-BIT-ARRAY ,BIT-ARRAY1))
+              ((NOT (AND (BIT-ARRAY-P ,RESULT-BIT-ARRAY)
+                         (EQUAL-DIMENSIONS-P ,BIT-ARRAY1 ,RESULT-BIT-ARRAY)))
+               (LISP:ERROR "Illegal result array")))
+           ,(LISP:ECASE OP
+                ((AND IOR XOR ANDC2 ORC2) `(OR (EQ ,BIT-ARRAY1 ,RESULT-BIT-ARRAY)
+                                               (%DO-LOGICAL-OP 'COPY ,BIT-ARRAY1 ,RESULT-BIT-ARRAY)))
+                ((EQV NAND NOR ANDC1 ORC1) `(%DO-LOGICAL-OP 'NOT ,BIT-ARRAY1 ,RESULT-BIT-ARRAY)))
+           ,(LISP:ECASE OP
+                (AND `(%DO-LOGICAL-OP 'AND ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (IOR `(%DO-LOGICAL-OP 'OR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (XOR `(%DO-LOGICAL-OP 'XOR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (EQV `(%DO-LOGICAL-OP 'XOR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (NAND `(%DO-LOGICAL-OP 'COR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (NOR `(%DO-LOGICAL-OP 'CAND ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (ANDC1 `(%DO-LOGICAL-OP 'AND ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (ANDC2 `(%DO-LOGICAL-OP 'CAND ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (ORC1 `(%DO-LOGICAL-OP 'OR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (ORC2 `(%DO-LOGICAL-OP 'COR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY)))
+           ,RESULT-BIT-ARRAY))
+
+(DEFMACRO %GENERAL-ARRAY-ADJUST-BASE (ARRAY ROW-MAJOR-INDEX)
+   `(LISP:IF (|ffetch| (GENERAL-ARRAY INDIRECT-P) |of| ,ARRAY)
+        (LET ((%OFFSET 0))
+             (SETQ ,ARRAY (%GET-BASE-ARRAY ,ARRAY %OFFSET))
+             (SETQ ,ROW-MAJOR-INDEX (+ ,ROW-MAJOR-INDEX %OFFSET))
+             (LISP:IF (NOT (< ,ROW-MAJOR-INDEX (|fetch| (ARRAY-HEADER TOTAL-SIZE)
+                                                  |of| ,ARRAY)))
+                    (LISP:ERROR "Row-major-index out of bounds (displaced to adjustable?)")))))
+
+(DEFMACRO %GET-ARRAY-OFFSET (ARRAY)
+   `(COND
+       ((OR (%ONED-ARRAY-P ,ARRAY)
+            (%GENERAL-ARRAY-P ,ARRAY))
+        (|fetch| (ARRAY-HEADER OFFSET) |of| ,ARRAY))
+       ((%TWOD-ARRAY-P ,ARRAY)
+        0)))
+
+(DEFMACRO %GET-BASE-ARRAY (ARRAY OFFSET)
+   `(LISP:DO ((%BASE-ARRAY ,ARRAY (|fetch| (ARRAY-HEADER BASE) |of| %BASE-ARRAY)))
+             ((NOT (|fetch| (ARRAY-HEADER INDIRECT-P) |of| %BASE-ARRAY))
+              %BASE-ARRAY)
+        (SETQ ,OFFSET (+ ,OFFSET (%GET-ARRAY-OFFSET %BASE-ARRAY)))))
+
+(DEFMACRO %BIT-TYPE-P (TYPE-NUMBER)
+   `(EQ ,TYPE-NUMBER %BIT-TYPE))
+
+(DEFMACRO %CHAR-TYPE-P (TYPE-NUMBER)
+   `(EQ (%TYPENUMBER-TO-TYPE ,TYPE-NUMBER)
+        %CHAR-TYPE))
+
+(DEFMACRO %CML-TYPE-TO-TYPENUMBER-EXPANDER (CML-TYPE)
+   
+         (* *)
+
+   (LET
+    ((SIMPLE-TYPES (REMOVE T (LISP:MAPCAN #'(LISP:LAMBDA (ENTRY)
+                                                   (LISP:IF (NOT (LISTP (CAR ENTRY)))
+                                                       (LIST (CAR ENTRY))))
+                                    %CANONICAL-CML-TYPES)))
+     (COMPOUND-TYPES (LISP:REMOVE-DUPLICATES (LISP:MAPCAN #'(LISP:LAMBDA (ENTRY)
+                                                                   (LISP:IF (LISTP (CAR ENTRY))
+                                                                       (LIST (CAAR ENTRY))))
+                                                    %CANONICAL-CML-TYPES))))
+    `(LISP:IF (EQ ,CML-TYPE T)
+         ,(CADR (LISP:ASSOC T %CANONICAL-CML-TYPES))
+         (LISP:IF (LISTP ,CML-TYPE)
+             (LISP:ECASE (CAR ,CML-TYPE)
+                 (\\\,@ 
+                    (LISP:MAPCAR
+                     #'(LISP:LAMBDA
+                        (TYPE)
+                        `(,TYPE (LISP:ECASE (CADR ,CML-TYPE)
+                                    (\\\,@ (LISP:MAPCAN
+                                            #'(LISP:LAMBDA (ENTRY)
+                                                     (LISP:IF (AND (LISTP (CAR ENTRY))
+                                                                   (EQ (CAAR ENTRY)
+                                                                       TYPE))
+                                                         (LIST (LIST (CADAR ENTRY)
+                                                                     (CADR ENTRY)))))
+                                            %CANONICAL-CML-TYPES)))))
+                     COMPOUND-TYPES)))
+             (LISP:ECASE ,CML-TYPE
+                 (\\\,@ (LISP:MAPCAR #'(LISP:LAMBDA (TYPE)
+                                              (LISP:ASSOC TYPE %CANONICAL-CML-TYPES))
+                               SIMPLE-TYPES)))))))
+
+(DEFMACRO %FAT-CHAR-TYPE-P (TYPE-NUMBER)
+   `(EQ ,TYPE-NUMBER %FAT-CHAR-TYPENUMBER))
+
+(DEFMACRO %FAT-STRING-CHAR-P (OBJECT)
+   `(> (LISP:CHAR-CODE ,OBJECT)
+       %MAXTHINCHAR))
+
+(LISP:DEFUN %GET-TYPE-TABLE-ENTRY (TYPENUMBER)
+   (CADR (LISP:ASSOC TYPENUMBER %ARRAY-TYPE-TABLE)))
+
+(LISP:DEFUN %LIT-SIZE-TO-SIZE (LIT-SIZE)
+   (CADR (LISP:ASSOC LIT-SIZE %LIT-ARRAY-SIZES)))
+
+(LISP:DEFUN %LIT-TYPE-TO-TYPE (LIT-TYPE)
+   (CADR (LISP:ASSOC LIT-TYPE %LIT-ARRAY-TYPES)))
+
+(LISP:DEFUN %LLARRAY-MAKE-ACCESSOR-EXPR (TYPENUMBER BASE OFFSET)
+   (LET* ((ENTRY (%GET-TYPE-TABLE-ENTRY TYPENUMBER))
+          (ACCESSOR (ARRAY-TABLE-ENTRY-ACCESSOR ENTRY))
+          (BITS-PER-ELEMENT (ARRAY-TABLE-ENTRY-BITS-PER-ELEMENT ENTRY))
+          (NEEDS-SHIFT-P (ARRAY-TABLE-ENTRY-NEEDS-SHIFT-P ENTRY)))
+         `(,ACCESSOR ,BASE ,(LISP:IF NEEDS-SHIFT-P
+                                `(LLSH ,OFFSET ,NEEDS-SHIFT-P)
+                                OFFSET))))
+
+(LISP:DEFUN %LLARRAY-MAKE-SETTOR-EXPR (TYPENUMBER BASE OFFSET NEWVALUE)
+   (LET* ((ENTRY (%GET-TYPE-TABLE-ENTRY TYPENUMBER))
+          (SETTOR (ARRAY-TABLE-ENTRY-SETTOR ENTRY))
+          (BITS-PER-ELEMENT (ARRAY-TABLE-ENTRY-BITS-PER-ELEMENT ENTRY))
+          (NEEDS-SHIFT-P (ARRAY-TABLE-ENTRY-NEEDS-SHIFT-P ENTRY)))
+         `(,SETTOR ,BASE ,(LISP:IF NEEDS-SHIFT-P
+                              `(LLSH ,OFFSET ,NEEDS-SHIFT-P)
+                              OFFSET)
+                 ,NEWVALUE)))
+
+(DEFMACRO %LLARRAY-TYPED-GET (BASE TYPENUMBER OFFSET)
+   `(LISP:ECASE ,TYPENUMBER
+        (\\\,@ (LISP:MAPCAR #'(LISP:LAMBDA (TYPEENTRY)
+                                     `(,(CAR TYPEENTRY)
+                                       ,(%LLARRAY-MAKE-ACCESSOR-EXPR (CAR TYPEENTRY)
+                                               BASE OFFSET)))
+                      %ARRAY-TYPE-TABLE))))
+
+(DEFMACRO %LLARRAY-TYPED-PUT (BASE TYPENUMBER OFFSET NEWVALUE)
+   `(LISP:ECASE ,TYPENUMBER
+        (\\\,@ (LISP:MAPCAR #'(LISP:LAMBDA (TYPEENTRY)
+                                     `(,(CAR TYPEENTRY)
+                                       ,(%LLARRAY-MAKE-SETTOR-EXPR (CAR TYPEENTRY)
+                                               BASE OFFSET NEWVALUE)))
+                      %ARRAY-TYPE-TABLE))))
+
+(DEFMACRO %LLARRAY-TYPEP (TYPENUMBER VALUE)
+   `(LISP:ECASE ,TYPENUMBER
+        (\\\,@ (LISP:MAPCAR #'(LISP:LAMBDA (TYPEENTRY)
+                                     `(,(CAR TYPEENTRY)
+                                       (,(ARRAY-TABLE-ENTRY-TYPE-TEST (CADR TYPEENTRY))
+                                        ,VALUE)))
+                      %ARRAY-TYPE-TABLE))))
+
+(LISP:DEFUN %MAKE-ARRAY-TYPE-TABLE (LIT-TABLE TYPES SIZES)
+   (LISP:MAPCAN #'(LISP:LAMBDA (TYPE-ENTRY)
+                         (LET ((LIT-TYPE (CAR TYPE-ENTRY)))
+                              (LISP:MAPCAR #'(LISP:LAMBDA (SIZE-ENTRY)
+                                                    (LIST (%TYPE-SIZE-TO-TYPENUMBER LIT-TYPE
+                                                                 (CAR SIZE-ENTRY))
+                                                          (CADR SIZE-ENTRY)))
+                                     (CADR TYPE-ENTRY))))
+          LIT-TABLE))
+
+(LISP:DEFUN %MAKE-CML-TYPE-TABLE (ARRAY-TABLE)
+   (LISP:MAPCAR #'(LISP:LAMBDA (TYPE-ENTRY)
+                         (LET ((CMLTYPE (ARRAY-TABLE-ENTRY-CML-TYPE (CADR TYPE-ENTRY))))
+                              (LIST CMLTYPE (CAR TYPE-ENTRY))))
+          ARRAY-TABLE))
+
+(DEFMACRO %PACK-TYPENUMBER (ELTTYPE ELTSIZE)
+   `(\\ADDBASE (LLSH ,ELTTYPE 4)
+           ,ELTSIZE))
+
+(DEFMACRO %SMALLFIXP-SMALLPOSP (NUM)
+   `(\\LOLOC ,NUM))
+
+(DEFMACRO %SMALLPOSP-SMALLFIXP (NUM)
+   (LET ((SYM (GENSYM)))
+        `(LET ((,SYM ,NUM))
+              (LISP:IF (> ,SYM MAX.SMALLFIXP)
+                  (\\VAG2 |\\SmallNegHi| ,SYM)
+                  ,SYM))))
+
+(DEFMACRO %THIN-CHAR-TYPE-P (TYPE-NUMBER)
+   `(EQ ,TYPE-NUMBER %THIN-CHAR-TYPENUMBER))
+
+(DEFMACRO %THIN-STRING-CHAR-P (OBJECT)
+   `(<= (LISP:CHAR-CODE ,OBJECT)
+        %MAXTHINCHAR))
+
+(LISP:DEFUN %TYPE-SIZE-TO-TYPENUMBER (LIT-TYPE LIT-SIZE)
+   (LET ((TYPE (CADR (LISP:ASSOC LIT-TYPE %LIT-ARRAY-TYPES)))
+         (SIZE (CADR (LISP:ASSOC LIT-SIZE %LIT-ARRAY-SIZES))))
+        (%PACK-TYPENUMBER TYPE SIZE)))
+
+(DEFMACRO %TYPENUMBER-TO-BITS-PER-ELEMENT (TYPE-NUMBER)
+   `(LISP:ECASE ,TYPE-NUMBER
+        (\\\,@ (LISP:MAPCAR #'(LISP:LAMBDA (TYPEENTRY)
+                                     `(,(CAR TYPEENTRY)
+                                       ,(ARRAY-TABLE-ENTRY-BITS-PER-ELEMENT (CADR TYPEENTRY))))
+                      %ARRAY-TYPE-TABLE))))
+
+(DEFMACRO %TYPENUMBER-TO-CML-TYPE (TYPE-NUMBER)
+   `(LISP:ECASE ,TYPE-NUMBER
+        (\\\,@ (LISP:MAPCAR #'(LISP:LAMBDA (TYPEENTRY)
+                                     `(,(CAR TYPEENTRY)
+                                       ',(ARRAY-TABLE-ENTRY-CML-TYPE (CADR TYPEENTRY))))
+                      %ARRAY-TYPE-TABLE))))
+
+(DEFMACRO %TYPENUMBER-TO-DEFAULT-VALUE (TYPE-NUMBER)
+   `(LISP:ECASE ,TYPE-NUMBER
+        (\\\,@ (LISP:MAPCAR #'(LISP:LAMBDA (TYPEENTRY)
+                                     `(,(CAR TYPEENTRY)
+                                       ,(ARRAY-TABLE-ENTRY-DEFAULT-VALUE (CADR TYPEENTRY))))
+                      %ARRAY-TYPE-TABLE))))
+
+(DEFMACRO %TYPENUMBER-TO-GC-TYPE (TYPE-NUMBER)
+   `(LISP:ECASE ,TYPE-NUMBER
+        (\\\,@ (LISP:MAPCAR #'(LISP:LAMBDA (TYPEENTRY)
+                                     `(,(CAR TYPEENTRY)
+                                       ,(ARRAY-TABLE-ENTRY-GC-TYPE (CADR TYPEENTRY))))
+                      %ARRAY-TYPE-TABLE))))
+
+(DEFMACRO %TYPENUMBER-TO-SIZE (TYPE-NUMBER)
+   `(LOGAND ,TYPE-NUMBER 15))
+
+(DEFMACRO %TYPENUMBER-TO-TYPE (TYPE-NUMBER)
+   `(LRSH ,TYPE-NUMBER 4))
+
+(DEFMACRO \\GETBASESMALL-FIXP (BASE OFFSET)
+   `(%SMALLPOSP-SMALLFIXP (\\GETBASE ,BASE ,OFFSET)))
+
+(DEFMACRO \\GETBASESTRING-CHAR (PTR DISP)
+   `(LISP:CODE-CHAR (\\GETBASE ,PTR ,DISP)))
+
+(DEFMACRO \\GETBASETHINSTRING-CHAR (PTR DISP)
+   `(LISP:CODE-CHAR (\\GETBASEBYTE ,PTR ,DISP)))
+
+(DEFMACRO \\PUTBASESMALL-FIXP (BASE OFFSET VALUE)
+   `(\\PUTBASE ,BASE ,OFFSET (%SMALLFIXP-SMALLPOSP ,VALUE)))
+
+(DEFMACRO \\PUTBASESTRING-CHAR (PTR DISP CHAR)
+   `(\\PUTBASE ,PTR ,DISP (LISP:CHAR-CODE ,CHAR)))
+
+(DEFMACRO \\PUTBASETHINSTRING-CHAR (PTR DISP CHAR)
+   `(\\PUTBASEBYTE ,PTR ,DISP (LISP:CHAR-CODE ,CHAR)))
+
+
+
+(* |;;;| "Describes each entry of \\ARRAY-TYPE-TABLE")
+
+
+(LISP:DEFSTRUCT (ARRAY-TABLE-ENTRY (:TYPE LIST)
+                                       (:CONSTRUCTOR NIL)
+                                       (:COPIER NIL)
+                                       (:PREDICATE NIL))
+   CML-TYPE
+   ACCESSOR
+   SETTOR
+   BITS-PER-ELEMENT
+   GC-TYPE
+   DEFAULT-VALUE
+   NEEDS-SHIFT-P
+   TYPE-TEST)
+
+
+
+(* |;;;| "These vars contain all the necessary info for typed arrays")
+
+
+(LISP:DEFPARAMETER %LIT-ARRAY-SIZES '((1BIT 0)
+                                          (8BIT 3)
+                                          (16BIT 4)
+                                          (32BIT 6))
+                                        "Size codes")
+
+(LISP:DEFPARAMETER %LIT-ARRAY-TABLE
+   '((LISP:BASE-CHARACTER ((8BIT (LISP:BASE-CHARACTER \\GETBASETHINSTRING-CHAR 
+                                        \\PUTBASETHINSTRING-CHAR 8 UNBOXEDBLOCK.GCT #\Null NIL
+                                        (LISP:LAMBDA (OBJECT)
+                                               (%THIN-STRING-CHAR-P OBJECT))))))
+     (LISP:EXTENDED-CHARACTER ((16BIT (LISP:EXTENDED-CHARACTER \\GETBASESTRING-CHAR 
+                                             \\PUTBASESTRING-CHAR 16 UNBOXEDBLOCK.GCT #\Null NIL
+                                             (LISP:LAMBDA (OBJECT)
+                                                    (LISP:STRING-CHAR-P OBJECT))))))
+     (T ((32BIT (T \\GETBASEPTR \\RPLPTR 32 PTRBLOCK.GCT NIL 1 (LISP:LAMBDA (OBJECT)
+                                                                        T)))))
+     (XPOINTER ((32BIT (XPOINTER \\GETBASEPTR \\PUTBASEPTR 32 UNBOXEDBLOCK.GCT NIL 1 (LISP:LAMBDA
+                                                                                        (OBJECT)
+                                                                                        T)))))
+     (LISP:SINGLE-FLOAT ((32BIT (LISP:SINGLE-FLOAT \\GETBASEFLOATP \\PUTBASEFLOATP 32 
+                                       UNBOXEDBLOCK.GCT 0.0 1 (LISP:LAMBDA (OBJECT)
+                                                                     (FLOATP OBJECT))))))
+     (LISP:UNSIGNED-BYTE ((1BIT ((LISP:UNSIGNED-BYTE 1)
+                                 \\GETBASEBIT \\PUTBASEBIT 1 UNBOXEDBLOCK.GCT 0 NIL
+                                 (LISP:LAMBDA (OBJECT)
+                                        (AND (>= OBJECT 0)
+                                             (<= OBJECT 1)))))
+                          (8BIT ((LISP:UNSIGNED-BYTE 8)
+                                 \\GETBASEBYTE \\PUTBASEBYTE 8 UNBOXEDBLOCK.GCT 0 NIL
+                                 (LISP:LAMBDA (OBJECT)
+                                        (AND (>= OBJECT 0)
+                                             (< OBJECT 256)))))
+                          (16BIT ((LISP:UNSIGNED-BYTE 16)
+                                  \\GETBASE \\PUTBASE 16 UNBOXEDBLOCK.GCT 0 NIL (LISP:LAMBDA
+                                                                                   (OBJECT)
+                                                                                   (SMALLPOSP OBJECT)
+                                                                                   )))))
+     (LISP:SIGNED-BYTE ((16BIT ((LISP:SIGNED-BYTE 16)
+                                \\GETBASESMALL-FIXP \\PUTBASESMALL-FIXP 16 UNBOXEDBLOCK.GCT 0 NIL
+                                (LISP:LAMBDA (OBJECT)
+                                       (AND (>= OBJECT MIN.SMALLFIXP)
+                                            (<= OBJECT MAX.SMALLFIXP)))))
+                        (32BIT ((LISP:SIGNED-BYTE 32)
+                                \\GETBASEFIXP \\PUTBASEFIXP 32 UNBOXEDBLOCK.GCT 0 1
+                                (LISP:LAMBDA (OBJECT)
+                                       (AND (>= OBJECT MIN.FIXP)
+                                            (<= OBJECT MAX.FIXP))))))))
+   "Fields described by record ARRAY-TYPE-TABLE-ENTRY")
+
+(LISP:DEFPARAMETER %LIT-ARRAY-TYPES
+   '((LISP:UNSIGNED-BYTE 0)
+     (LISP:SIGNED-BYTE 1)
+     (T 2)
+     (LISP:SINGLE-FLOAT 3)
+     (LISP:BASE-CHARACTER 4)
+     (LISP:EXTENDED-CHARACTER 4)
+     (XPOINTER 5))
+   "Type codes")
+
+
+
+(* |;;;| "Tables that drives various macros")
+
+
+(LISP:DEFPARAMETER %ARRAY-TYPE-TABLE (%MAKE-ARRAY-TYPE-TABLE %LIT-ARRAY-TABLE 
+                                                %LIT-ARRAY-TYPES %LIT-ARRAY-SIZES)
+                                         "Drives various macros")
+
+(LISP:DEFPARAMETER %CANONICAL-CML-TYPES (%MAKE-CML-TYPE-TABLE %ARRAY-TYPE-TABLE))
+
+
+
+(* |;;;| "Constants for (SIGNED-BYTE 16)")
+
+
+(LISP:DEFCONSTANT MAX.SMALLFIXP (LISP:1- (EXPT 2 15)))
+
+(LISP:DEFCONSTANT MIN.SMALLFIXP (- (EXPT 2 15)))
+
+
+
+(* |;;;| "Constants for STRING-CHARS")
+
+
+(LISP:DEFCONSTANT %CHAR-TYPE (%LIT-TYPE-TO-TYPE 'LISP:BASE-CHARACTER))
+
+(LISP:DEFCONSTANT %BIT-TYPE (%TYPE-SIZE-TO-TYPENUMBER 'LISP:UNSIGNED-BYTE '1BIT))
+
+(LISP:DEFCONSTANT %THIN-CHAR-TYPENUMBER (%TYPE-SIZE-TO-TYPENUMBER 'LISP:BASE-CHARACTER
+                                                   '8BIT))
+
+(LISP:DEFCONSTANT %FAT-CHAR-TYPENUMBER (%TYPE-SIZE-TO-TYPENUMBER 'LISP:BASE-CHARACTER
+                                                  '16BIT))
+
+(LISP:DEFCONSTANT %MAXTHINCHAR (LISP:1- (EXPT 2 8)))
+
+
+
+(* |;;;| "Array data-type numbers")
+
+
+(LISP:DEFCONSTANT %GENERAL-ARRAY 16
+   "General-array-type-number")
+
+(LISP:DEFCONSTANT %ONED-ARRAY 14
+   "ONED-ARRAY type number")
+
+(LISP:DEFCONSTANT %TWOD-ARRAY 15
+   "TWOD-ARRAY type number")
+
+
+
+(* |;;;| "Compiler options")
+
+(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 
+(DECLARE\: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+
+(PUTPROPS CMLARRAY-SUPPORT FILETYPE LISP:COMPILE-FILE)
+(PUTPROPS CMLARRAY-SUPPORT COPYRIGHT ("Venue & Xerox Corporation" 1986 1990 1991 1992 1993))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/CLTL2/CMLARRAY-SUPPORT.LCOM b/CLTL2/CMLARRAY-SUPPORT.LCOM
new file mode 100644
index 00000000..a03fb592
Binary files /dev/null and b/CLTL2/CMLARRAY-SUPPORT.LCOM differ
diff --git a/CLTL2/CMLARRAY.LCOM b/CLTL2/CMLARRAY.LCOM
new file mode 100644
index 00000000..f4fa03ad
Binary files /dev/null and b/CLTL2/CMLARRAY.LCOM differ
diff --git a/CLTL2/CMLCHARACTER b/CLTL2/CMLCHARACTER
new file mode 100644
index 00000000..f38f6a62
--- /dev/null
+++ b/CLTL2/CMLCHARACTER
@@ -0,0 +1,901 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 10:35:22" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLCHARACTER.;2" 39407  
+
+      previous date%: "24-Mar-92 14:42:50" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLCHARACTER.;1"
+)
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1987, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLCHARACTERCOMS)
+
+(RPAQQ CMLCHARACTERCOMS
+       [(COMS                                                (* ; 
+                                         "Interlisp CHARCODE; Some is here, the rest is in LLREAD.")
+              (FNS CHARCODE CHARCODE.UNDECODE)
+              (PROP MACRO SELCHARQ ALPHACHARP DIGITCHARP UCASECODE)
+              (OPTIMIZERS CHARCODE)
+              (ALISTS (DWIMEQUIVLST SELCHARQ)
+                     (PRETTYEQUIVLST SELCHARQ)))
+        (COMS                                                (* ; "Common Lisp CHARACTER type")
+              (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CHARACTER))
+              (VARIABLES \CHARHI)
+              (VARIABLES LISP:CHAR-BITS-LIMIT LISP:CHAR-CODE-LIMIT LISP:CHAR-CONTROL-BIT 
+                     LISP:CHAR-FONT-LIMIT LISP:CHAR-HYPER-BIT LISP:CHAR-META-BIT LISP:CHAR-SUPER-BIT)
+              )
+        (COMS                                                (* ; "Basic character fns")
+              (FNS LISP:CHAR-CODE LISP:CHAR-INT LISP:INT-CHAR)
+              (FUNCTIONS LISP:CODE-CHAR)
+              (OPTIMIZERS LISP:CHAR-CODE LISP:CHAR-INT LISP:CODE-CHAR LISP:INT-CHAR))
+        [COMS                                                (* ; 
+                                                        "I/O; Some is here, the rest is in LLREAD.")
+              (FNS CHARACTER.PRINT)
+              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (SETTOPVAL (\TYPEGLOBALVARIABLE 'CHARACTER T)
+                                                        (NTYPX (LISP:CODE-CHAR 0 0 0)))
+                                                 (DEFPRINT 'CHARACTER 'CHARACTER.PRINT]
+        (COMS 
+              (* ;; "Common lisp character functions")
+
+              (FNS LISP:CHAR-BIT LISP:CHAR-BITS LISP:CHAR-DOWNCASE LISP:CHAR-FONT LISP:CHAR-NAME 
+                   LISP:CHAR-UPCASE LISP:CHARACTER LISP:NAME-CHAR LISP:SET-CHAR-BIT)
+              (FUNCTIONS LISP:DIGIT-CHAR LISP:MAKE-CHAR LISP::BASE-CHARACTER-P 
+                     LISP::EXTENDED-CHARACTER-P)
+              (OPTIMIZERS LISP:CHAR-UPCASE LISP:CHAR-DOWNCASE LISP:MAKE-CHAR))
+        (COMS 
+              (* ;; "Predicates")
+
+              (FNS LISP:ALPHA-CHAR-P LISP:ALPHANUMERICP LISP:BOTH-CASE-P LISP:CHARACTERP 
+                   LISP:GRAPHIC-CHAR-P LISP:LOWER-CASE-P LISP:STANDARD-CHAR-P LISP:STRING-CHAR-P 
+                   LISP:UPPER-CASE-P)
+              (FNS LISP:CHAR-EQUAL LISP:CHAR-GREATERP LISP:CHAR-LESSP LISP:CHAR-NOT-EQUAL 
+                   LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-LESSP LISP:CHAR/= LISP:CHAR< LISP:CHAR<= 
+                   LISP:CHAR= LISP:CHAR> LISP:CHAR>=)
+              (FUNCTIONS LISP:DIGIT-CHAR-P)
+              (OPTIMIZERS LISP:CHAR-EQUAL LISP:CHAR-GREATERP LISP:CHAR-LESSP LISP:CHAR-NOT-EQUAL 
+                     LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-LESSP LISP:CHAR/= LISP:CHAR< LISP:CHAR<= 
+                     LISP:CHAR= LISP:CHAR> LISP:CHAR>= LISP:CHARACTERP LISP:LOWER-CASE-P 
+                     LISP:STRING-CHAR-P LISP:UPPER-CASE-P))
+        (COMS 
+              (* ;; "Internals")
+
+              (FUNCTIONS %%CHAR-DOWNCASE-CODE %%CHAR-UPCASE-CODE %%CODE-CHAR))
+        (COMS 
+              (* ;; "Compiler options")
+
+              (PROP FILETYPE CMLCHARACTER)
+              (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)))
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML)
+                      (LAMA LISP:CHAR>= LISP:CHAR> LISP:CHAR= LISP:CHAR<= LISP:CHAR< LISP:CHAR/= 
+                            LISP:CHAR-NOT-LESSP LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-EQUAL 
+                            LISP:CHAR-LESSP LISP:CHAR-GREATERP LISP:CHAR-EQUAL])
+
+
+
+(* ; "Interlisp CHARCODE; Some is here, the rest is in LLREAD.")
+
+(DEFINEQ
+
+(CHARCODE
+  [NLAMBDA (CHAR)
+    (CHARCODE.DECODE CHAR])
+
+(CHARCODE.UNDECODE
+  [LAMBDA (CODE)                                             (* jop%: "26-Aug-86 14:27")
+    (LET [(NAME (LISP:CHAR-NAME (LISP:CODE-CHAR CODE]
+         (AND NAME (MKSTRING NAME])
+)
+
+(PUTPROPS SELCHARQ MACRO [F (CONS 'SELECTQ (CONS (CAR F)
+                                                         (MAPLIST (CDR F)
+                                                                (FUNCTION (LAMBDA (I)
+                                                                            (COND
+                                                                               ((CDR I)
+                                                                                (CONS
+                                                                                 (CHARCODE.DECODE
+                                                                                  (CAAR I))
+                                                                                 (CDAR I)))
+                                                                               (T (CAR I])
+
+(PUTPROPS ALPHACHARP MACRO ((CHAR)
+                                    ([LAMBDA (UCHAR)
+                                       (DECLARE (LOCALVARS UCHAR))
+                                       (AND (IGEQ UCHAR (CHARCODE A))
+                                            (ILEQ UCHAR (CHARCODE Z]
+                                     (LOGAND CHAR 95))))
+
+(PUTPROPS DIGITCHARP MACRO [LAMBDA (CHAR)
+                                     (AND (IGEQ CHAR (CHARCODE 0))
+                                          (ILEQ CHAR (CHARCODE 9])
+
+(PUTPROPS UCASECODE MACRO (OPENLAMBDA (CHAR)
+                                         (COND
+                                            ((AND (IGEQ CHAR (CHARCODE a))
+                                                  (ILEQ CHAR (CHARCODE z)))
+                                             (LOGAND CHAR 95))
+                                            (T CHAR))))
+
+(DEFOPTIMIZER CHARCODE (C)
+                           (KWOTE (CHARCODE.DECODE C T)))
+
+(ADDTOVAR DWIMEQUIVLST (SELCHARQ . SELECTQ))
+
+(ADDTOVAR PRETTYEQUIVLST (SELCHARQ . SELECTQ))
+
+
+
+(* ; "Common Lisp CHARACTER type")
+
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: EVAL@COMPILE
+
+(ACCESSFNS CHARACTER [(CODE (\LOLOC (\DTEST DATUM 'CHARACTER]
+                         (CREATE (\VAG2 \CHARHI CODE)))
+)
+)
+
+(LISP:DEFCONSTANT \CHARHI 7)
+
+(LISP:DEFCONSTANT LISP:CHAR-BITS-LIMIT 1)
+
+(LISP:DEFCONSTANT LISP:CHAR-CODE-LIMIT 65536)
+
+(LISP:DEFCONSTANT LISP:CHAR-CONTROL-BIT 0)
+
+(LISP:DEFCONSTANT LISP:CHAR-FONT-LIMIT 1)
+
+(LISP:DEFCONSTANT LISP:CHAR-HYPER-BIT 0)
+
+(LISP:DEFCONSTANT LISP:CHAR-META-BIT 0)
+
+(LISP:DEFCONSTANT LISP:CHAR-SUPER-BIT 0)
+
+
+
+(* ; "Basic character fns")
+
+(DEFINEQ
+
+(LISP:CHAR-CODE
+  [LAMBDA (CHAR)                                             (* jop%: "25-Aug-86 17:30")
+    (\LOLOC (\DTEST CHAR 'CHARACTER])
+
+(LISP:CHAR-INT
+  [LAMBDA (CHAR)
+    (LISP:CHAR-CODE CHAR])
+
+(LISP:INT-CHAR
+  [LAMBDA (INTEGER)                                          (* lmm " 7-Jul-85 16:50")
+    (LISP:CODE-CHAR INTEGER])
+)
+
+(LISP:DEFUN LISP:CODE-CHAR (CODE &OPTIONAL (BITS 0)
+                                     (FONT 0))
+   (LISP:IF (AND (EQ BITS 0)
+                 (EQ FONT 0)
+
+                 (* ;; "This checks for smallposp")
+
+                 (EQ (\HILOC CODE)
+                     \SmallPosHi)
+
+                 (* ;; "Character 255 is undefined in all char sets")
+
+                 (NOT (EQ (LDB (BYTE 8 0)
+                               CODE)
+                          255)))
+          (%%CODE-CHAR CODE)))
+
+(DEFOPTIMIZER LISP:CHAR-CODE (CHAR)
+                                 [LET [(CONSTANT-CHAR (AND (LISP:CONSTANTP CHAR)
+                                                           (LISP:EVAL CHAR]
+                                      (LISP:IF (LISP:CHARACTERP CONSTANT-CHAR)
+                                          (\LOLOC CONSTANT-CHAR)
+                                          `(\LOLOC (\DTEST ,CHAR 'CHARACTER)))])
+
+(DEFOPTIMIZER LISP:CHAR-INT (CHAR)
+                                `(LISP:CHAR-CODE ,CHAR))
+
+(DEFOPTIMIZER LISP:CODE-CHAR (CODE &OPTIONAL (BITS 0)
+                                       (FONT 0))
+                                 (LISP:IF (AND (EQ BITS 0)
+                                               (EQ FONT 0))
+                                     [LET
+                                      [(CONSTANT-CODE (AND (LISP:CONSTANTP CODE)
+                                                           (LISP:EVAL CODE]
+                                      (LISP:IF (EQ (\HILOC CONSTANT-CODE)
+                                                   \SmallPosHi)
+                                          (LISP:IF (NOT (EQ (LDB (BYTE 8 0)
+                                                                 CONSTANT-CODE)
+                                                            255))
+                                                 (%%CODE-CHAR CONSTANT-CODE))
+                                          `(LET ((%%CODE ,CODE))
+                                                (AND (EQ (\HILOC %%CODE)
+                                                         ,\SmallPosHi)
+                                                     (NOT (EQ (LDB (BYTE 8 0)
+                                                                   %%CODE)
+                                                              255))
+                                                     (%%CODE-CHAR %%CODE))))]
+                                     'COMPILER:PASS))
+
+(DEFOPTIMIZER LISP:INT-CHAR (INTEGER)
+                                `(LISP:CODE-CHAR ,INTEGER))
+
+
+
+(* ; "I/O; Some is here, the rest is in LLREAD.")
+
+(DEFINEQ
+
+(CHARACTER.PRINT
+  [LAMBDA (CHAR STREAM)                                      (* ; "Edited 23-Sep-91 21:09 by jrb:")
+    [COND
+       [*PRINT-ESCAPE*                                       (* ; "Name that can be read back")
+              (LET ((PNAME (LISP:CHAR-NAME CHAR))
+                    LPN)
+                   [.SPACECHECK. STREAM (+ 2 (COND
+                                                (PNAME (SETQ LPN (LISP:LENGTH PNAME)))
+                                                (T 1]        (* ; 
+                                                           "Print as #\ followed by charcter name")
+                   (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))
+                   (\OUTCHAR STREAM (CHARCODE "\"))
+                   (COND
+                      (PNAME (WRITE-STRING* PNAME STREAM 0 LPN))
+                      (T (\OUTCHAR STREAM (LISP:CHAR-CODE CHAR]
+       (T                                                    (* ; "Character as character")
+          (\OUTCHAR STREAM (LISP:CHAR-CODE CHAR]
+    T])
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(SETTOPVAL (\TYPEGLOBALVARIABLE 'CHARACTER T)
+       (NTYPX (LISP:CODE-CHAR 0 0 0)))
+
+(DEFPRINT 'CHARACTER 'CHARACTER.PRINT)
+)
+
+
+
+(* ;; "Common lisp character functions")
+
+(DEFINEQ
+
+(LISP:CHAR-BIT
+  [LAMBDA (CHAR NAME)                                        (* jop%: "26-Aug-86 15:01")
+    (LISP:ERROR "Bit ~A not supported" NAME])
+
+(LISP:CHAR-BITS
+  [LAMBDA (CHAR)                                             (* jop%: "25-Aug-86 17:35")
+    (AND (LISP:CHARACTERP CHAR)
+         0])
+
+(LISP:CHAR-DOWNCASE
+  [LAMBDA (CHAR)                                             (* jop%: "25-Aug-86 18:01")
+    (%%CODE-CHAR (%%CHAR-DOWNCASE-CODE (LISP:CHAR-CODE CHAR])
+
+(LISP:CHAR-FONT
+  [LAMBDA (CHAR)                                             (* jop%: "25-Aug-86 17:35")
+    (AND (LISP:CHARACTERP CHAR)
+         0])
+
+(LISP:CHAR-NAME
+  [LAMBDA (CHAR)                                             (* ; "Edited 19-Mar-87 15:49 by bvm:")
+    (DECLARE (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES))
+    (COND
+       ((EQ CHAR #\Space)                                    (* ; 
+                                            "Space is special because it is graphic but has a name")
+        "Space")
+       ((LISP:GRAPHIC-CHAR-P CHAR)                       (* ; "graphics have no special names")
+        NIL)
+       (T (LET ((CODE (LISP:CHAR-CODE CHAR))
+                CSET)
+               (COND
+                  [(for X in CHARACTERNAMES when (EQ (CADR X)
+                                                                 CODE)
+                      do (RETURN (CAR X]
+                  (T (SETQ CSET (LRSH CODE 8))
+                     (SETQ CODE (LOGAND CODE 255))
+                     (COND
+                        [(AND (EQ CSET 0)
+                              (<= CODE (CHARCODE "^Z"))) (* ; 
+                                                           "represent ascii control chars nicely")
+                         (CONCAT "^" (LISP:CODE-CHAR (LOGOR CODE (- (CHARCODE "A")
+                                                                        (CHARCODE "^A"]
+                        (T                                   (* ; "Else charset-charcode")
+                           (CONCAT (for X in CHARACTERSETNAMES
+                                      when (EQ (CADR X)
+                                                   CSET) do (RETURN (CAR X))
+                                      finally (RETURN (OCTALSTRING CSET)))
+                                  "-"
+                                  (OCTALSTRING CODE])
+
+(LISP:CHAR-UPCASE
+  [LAMBDA (CHAR)                                             (* jop%: "25-Aug-86 18:01")
+    (%%CODE-CHAR (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE CHAR])
+
+(LISP:CHARACTER
+  [LAMBDA (OBJECT)                                           (* jop%: "14-Nov-86 16:22")
+    (COND
+       ((TYPEP OBJECT 'LISP:CHARACTER)
+        OBJECT)
+       ((AND (NOT *CLTL2-PEDANTIC*)
+             (TYPEP OBJECT 'LISP:FIXNUM))
+        (LISP:INT-CHAR OBJECT))
+       ([AND (OR (TYPEP OBJECT 'STRING)
+                 (TYPEP OBJECT 'LISP:SYMBOL))
+             (EQL 1 (LISP:LENGTH (SETQ OBJECT (STRING OBJECT]
+        (LISP:CHAR OBJECT 0))
+       (T (LISP:ERROR "Object cannot be coerced to a character: ~S" OBJECT])
+
+(LISP:NAME-CHAR
+  [LAMBDA (NAME)                                             (* ; "Edited 18-Feb-87 22:05 by bvm:")
+    (LET ((CODE (CHARCODE.DECODE (STRING NAME)
+                       T)))
+         (AND CODE (LISP:CODE-CHAR CODE])
+
+(LISP:SET-CHAR-BIT
+  [LAMBDA (CHAR NAME NEWVALUE)                               (* jop%: "26-Aug-86 15:02")
+    (LISP:ERROR "Bit ~A not supported" NAME])
+)
+
+(LISP:DEFUN LISP:DIGIT-CHAR (WEIGHT &OPTIONAL (RADIX 10)
+                                       (FONT 0))
+   [AND (EQ FONT 0)
+        (< -1 WEIGHT RADIX 37)
+        (LISP:IF (< WEIGHT 10)
+            (%%CODE-CHAR (+ (CONSTANT (LISP:CHAR-CODE #\0))
+                                WEIGHT))
+            (%%CODE-CHAR (+ (CONSTANT (LISP:CHAR-CODE #\A))
+                                (- WEIGHT 10))))])
+
+(LISP:DEFUN LISP:MAKE-CHAR (CHAR &OPTIONAL (BITS 0)
+                                     (FONT 0))
+   (LISP:IF (AND (EQL BITS 0)
+                 (EQL FONT 0))
+          CHAR))
+
+(LISP:DEFUN LISP::BASE-CHARACTER-P (LISP::OBJECT)        (* ; "Edited 13-Feb-92 19:51 by jrb:")
+   (AND (LISP:CHARACTERP LISP::OBJECT)
+
+        (* ;; "Same as (NOT (%%%%FAT-STRING-CHAR-P object))")
+
+        (ILEQ (\LOLOC LISP::OBJECT)
+              %%MAXTHINCHAR)))
+
+(LISP:DEFUN LISP::EXTENDED-CHARACTER-P (LISP::OBJECT)    (* ; "Edited 13-Feb-92 20:18 by jrb:")
+   (AND (LISP:CHARACTERP LISP::OBJECT)
+
+        (* ;; "Same as (%%%%FAT-STRING-CHAR-P object)")
+
+        (IGREATERP (\LOLOC LISP::OBJECT)
+               %%MAXTHINCHAR)))
+
+(DEFOPTIMIZER LISP:CHAR-UPCASE (CHAR)
+                                   `[%%CODE-CHAR (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE
+                                                                              ,CHAR])
+
+(DEFOPTIMIZER LISP:CHAR-DOWNCASE (CHAR)
+                                     `[%%CODE-CHAR (%%CHAR-DOWNCASE-CODE (LISP:CHAR-CODE
+                                                                                  ,CHAR])
+
+(DEFOPTIMIZER LISP:MAKE-CHAR (CHAR &OPTIONAL BITS FONT)
+                                 (LISP:IF (AND (OR (NULL BITS)
+                                                   (EQL BITS 0))
+                                               (OR (NULL FONT)
+                                                   (EQL FONT 0)))
+                                     CHAR
+                                     'COMPILER:PASS))
+
+
+
+(* ;; "Predicates")
+
+(DEFINEQ
+
+(LISP:ALPHA-CHAR-P
+  [LAMBDA (CHAR)                                             (* raf "23-Oct-85 15:03")
+    (LET ((CODE (LISP:CHAR-CODE CHAR)))                  (* ; 
+                                           "Might want to make this true for Greek char sets, etc.")
+         (OR (<= (CONSTANT (LISP:CHAR-CODE #\A))
+                 CODE
+                 (CONSTANT (LISP:CHAR-CODE #\Z)))
+             (<= (CONSTANT (LISP:CHAR-CODE #\a))
+                 CODE
+                 (CONSTANT (LISP:CHAR-CODE #\z])
+
+(LISP:ALPHANUMERICP
+  [LAMBDA (CHAR)                                             (* lmm "28-Oct-85 20:40")
+    (OR (LISP:ALPHA-CHAR-P CHAR)
+        (NOT (NULL (LISP:DIGIT-CHAR-P CHAR])
+
+(LISP:BOTH-CASE-P
+  [LAMBDA (CHAR)
+    (OR (LISP:UPPER-CASE-P CHAR)
+        (LISP:LOWER-CASE-P CHAR])
+
+(LISP:CHARACTERP
+  [LAMBDA (OBJECT)                                           (* lmm " 1-Aug-85 22:45")
+    (TYPENAMEP OBJECT 'CHARACTER])
+
+(LISP:GRAPHIC-CHAR-P
+  [LAMBDA (CHAR)                                             (* bvm%: "14-May-86 16:19")
+
+(* ;;; 
+"True if CHAR represents a graphic (printing) character.  Definition follows NS character standard")
+
+    (LET* ((CODE (LISP:CHAR-CODE CHAR))
+           (CSET (LRSH CODE 8)))
+          (AND [PROGN                                        (* ; 
+                                             "Graphic charsets are zero, 41 thru 176, 241 thru 276")
+                      (OR (EQ CSET 0)
+                          (AND (> (SETQ CSET (LOGAND CSET 127))
+                                  32)
+                               (NOT (EQ CSET 127]
+               (PROGN                                        (* ; 
+                        "Printing chars within a character set are SPACE thru 176 and 241 thru 276")
+                      (OR (EQ (SETQ CODE (LOGAND CODE 255))
+                              (CONSTANT (LISP:CHAR-CODE #\Space)))
+                          (AND (> (SETQ CODE (LOGAND CODE 127))
+                                  32)
+                               (NOT (EQ CODE 127])
+
+(LISP:LOWER-CASE-P
+  [LAMBDA (CHAR)
+    (<= (CONSTANT (LISP:CHAR-CODE #\a))
+        (LISP:CHAR-CODE CHAR)
+        (CONSTANT (LISP:CHAR-CODE #\z])
+
+(LISP:STANDARD-CHAR-P
+  [LAMBDA (CHAR)                                             (* ; "Edited  7-Jan-87 11:42 by jop")
+    (AND (LISP:MEMBER CHAR
+                '(#\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
+                      #\6 #\7 #\8 #\9 #\: #\; #\< #\= #\> #\? #\@ #\A #\B #\C #\D #\E #\F #\G #\H #\I
+                      #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\[ #\\ #\]
+                      #\^ #\_ #\` #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q
+                      #\r #\s #\t #\u #\v #\w #\x #\y #\z #\{ #\| #\} #\~ #\Space #\Newline))
+         T])
+
+(LISP:STRING-CHAR-P
+  [LAMBDA (CHAR)
+    (\DTEST CHAR 'CHARACTER])
+
+(LISP:UPPER-CASE-P
+  [LAMBDA (CHAR)
+    (<= (CONSTANT (LISP:CHAR-CODE #\A))
+        (LISP:CHAR-CODE CHAR)
+        (CONSTANT (LISP:CHAR-CODE #\Z])
+)
+(DEFINEQ
+
+(LISP:CHAR-EQUAL
+  [LAMBDA N                                                  (* jop%: "25-Aug-86 16:03")
+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR-EQUAL takes at least one arg"))
+    (LISP:DO ((TEST (LISP:CHAR-UPCASE (ARG N 1)))
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        (LISP:IF [NOT (EQ TEST (LISP:CHAR-UPCASE (ARG N I]
+               (RETURN NIL)))])
+
+(LISP:CHAR-GREATERP
+  [LAMBDA N                                                  (* jop%: "25-Aug-86 17:15")
+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR-LESSP takes at least one arg"))
+    (LISP:DO ([LAST (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE (ARG N 1]
+              NEXT
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        [SETQ NEXT (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE (ARG N I]
+        (LISP:IF (NOT (> LAST NEXT))
+            (RETURN NIL)
+            (SETQ LAST NEXT)))])
+
+(LISP:CHAR-LESSP
+  [LAMBDA N                                                  (* jop%: "25-Aug-86 17:17")
+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR-LESSP takes at least one arg"))
+    (LISP:DO ([LAST (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE (ARG N 1]
+              NEXT
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        [SETQ NEXT (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE (ARG N I]
+        (LISP:IF (NOT (< LAST NEXT))
+            (RETURN NIL)
+            (SETQ LAST NEXT)))])
+
+(LISP:CHAR-NOT-EQUAL
+  [LAMBDA N                                                  (* jop%: "25-Aug-86 16:02")
+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR-NOT-EQUAL takes at least one arg"))
+    (LISP:DO ((I 1 (LISP:1+ I))
+              TEST)
+             ((> I N)
+              T)
+        (SETQ TEST (LISP:CHAR-UPCASE (ARG N I)))
+        (LISP:IF (LISP:DO ((J (LISP:1+ I)
+                              (LISP:1+ J)))
+                          ((> J N)
+                           NIL)
+                     (LISP:IF (EQ TEST (LISP:CHAR-UPCASE (ARG N J)))
+                            (RETURN T)))
+               (RETURN NIL)))])
+
+(LISP:CHAR-NOT-GREATERP
+  [LAMBDA N                                                  (* jop%: "25-Aug-86 17:18")
+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR-LESSP takes at least one arg"))
+    (LISP:DO ([LAST (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE (ARG N 1]
+              NEXT
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        [SETQ NEXT (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE (ARG N I]
+        (LISP:IF (NOT (<= LAST NEXT))
+            (RETURN NIL)
+            (SETQ LAST NEXT)))])
+
+(LISP:CHAR-NOT-LESSP
+  [LAMBDA N                                                  (* jop%: "25-Aug-86 17:19")
+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR-LESSP takes at least one arg"))
+    (LISP:DO ([LAST (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE (ARG N 1]
+              NEXT
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        [SETQ NEXT (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE (ARG N I]
+        (LISP:IF (NOT (>= LAST NEXT))
+            (RETURN NIL)
+            (SETQ LAST NEXT)))])
+
+(LISP:CHAR/=
+  [LAMBDA N                                                  (* jop%: "25-Aug-86 17:07")
+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR/= takes at least one arg"))
+    (LISP:DO ((I 1 (LISP:1+ I))
+              TEST)
+             ((> I N)
+              T)
+        (SETQ TEST (LISP:CHAR-CODE (ARG N I)))
+        (LISP:IF (LISP:DO ((J (LISP:1+ I)
+                              (LISP:1+ J)))
+                          ((> J N)
+                           NIL)
+                     (LISP:IF (EQ TEST (LISP:CHAR-CODE (ARG N J)))
+                            (RETURN T)))
+               (RETURN NIL)))])
+
+(LISP:CHAR<
+  [LAMBDA N                                                  (* jop%: "25-Aug-86 14:29")
+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR< takes at least one arg"))
+    (LISP:DO ((LAST (LISP:CHAR-CODE (ARG N 1)))
+              NEXT
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        (SETQ NEXT (LISP:CHAR-CODE (ARG N I)))
+        (LISP:IF (NOT (< LAST NEXT))
+            (RETURN NIL)
+            (SETQ LAST NEXT)))])
+
+(LISP:CHAR<=
+  [LAMBDA N                                                  (* jop%: "25-Aug-86 14:38")
+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR< takes at least one arg"))
+    (LISP:DO ((LAST (LISP:CHAR-CODE (ARG N 1)))
+              NEXT
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        (SETQ NEXT (LISP:CHAR-CODE (ARG N I)))
+        (LISP:IF (NOT (<= LAST NEXT))
+            (RETURN NIL)
+            (SETQ LAST NEXT)))])
+
+(LISP:CHAR=
+  [LAMBDA N                                                  (* jop%: "25-Aug-86 17:05")
+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR= takes at least one arg"))
+    (LISP:DO ((TEST (LISP:CHAR-CODE (ARG N 1)))
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        (LISP:IF [NOT (EQ TEST (LISP:CHAR-CODE (ARG N I]
+               (RETURN NIL)))])
+
+(LISP:CHAR>
+  [LAMBDA N                                                  (* jop%: "25-Aug-86 14:34")
+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR< takes at least one arg"))
+    (LISP:DO ((LAST (LISP:CHAR-CODE (ARG N 1)))
+              NEXT
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        (SETQ NEXT (LISP:CHAR-CODE (ARG N I)))
+        (LISP:IF (NOT (> LAST NEXT))
+            (RETURN NIL)
+            (SETQ LAST NEXT)))])
+
+(LISP:CHAR>=
+  [LAMBDA N                                                  (* jop%: "25-Aug-86 14:40")
+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR< takes at least one arg"))
+    (LISP:DO ((LAST (LISP:CHAR-CODE (ARG N 1)))
+              NEXT
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        (SETQ NEXT (LISP:CHAR-CODE (ARG N I)))
+        (LISP:IF (NOT (>= LAST NEXT))
+            (RETURN NIL)
+            (SETQ LAST NEXT)))])
+)
+
+(LISP:DEFUN LISP:DIGIT-CHAR-P (CHAR &OPTIONAL (RADIX 10))
+   "Returns the weigh of CHAR in radix RADIX, or NIL if CHAR is not a digit char in that radix."
+   (LET* [(CODE (LISP:CHAR-CODE CHAR))
+          (VAL (COND
+                  [(<= (CONSTANT (LISP:CHAR-CODE #\0))
+                       CODE
+                       (CONSTANT (LISP:CHAR-CODE #\9)))
+                   (- CODE (CONSTANT (LISP:CHAR-CODE #\0]
+                  [(<= (CONSTANT (LISP:CHAR-CODE #\A))
+                       CODE
+                       (CONSTANT (LISP:CHAR-CODE #\Z)))
+                   (+ 10 (- CODE (CONSTANT (LISP:CHAR-CODE #\A]
+                  ((<= (CONSTANT (LISP:CHAR-CODE #\a))
+                       CODE
+                       (CONSTANT (LISP:CHAR-CODE #\z)))
+                   (+ 10 (- CODE (CONSTANT (LISP:CHAR-CODE #\a]
+         (AND VAL (< VAL RADIX)
+              VAL)))
+
+(DEFOPTIMIZER LISP:CHAR-EQUAL (CHAR &REST MORE-CHARS)
+                                  (LISP:IF (EQL 1 (LISP:LENGTH MORE-CHARS))
+                                      `[EQ (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE ,CHAR))
+                                           (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE
+                                                                    ,(CAR MORE-CHARS]
+                                      'COMPILER:PASS))
+
+(DEFOPTIMIZER LISP:CHAR-GREATERP (CHAR &REST MORE-CHARS)
+                                     `(> (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE ,CHAR))
+                                         ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA
+                                                                   (FORM)
+                                                                   `(%%CHAR-UPCASE-CODE
+                                                                     (LISP:CHAR-CODE ,FORM]
+                                                  MORE-CHARS)))
+
+(DEFOPTIMIZER LISP:CHAR-LESSP (CHAR &REST MORE-CHARS)
+                                  `(< (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE ,CHAR))
+                                      ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA
+                                                                (FORM)
+                                                                `(%%CHAR-UPCASE-CODE
+                                                                  (LISP:CHAR-CODE ,FORM]
+                                               MORE-CHARS)))
+
+(DEFOPTIMIZER LISP:CHAR-NOT-EQUAL (CHAR &REST MORE-CHARS)
+                                      (LISP:IF (EQL 1 (LISP:LENGTH MORE-CHARS))
+                                          `[NOT (EQ (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE
+                                                                             ,CHAR))
+                                                    (%%CHAR-UPCASE-CODE
+                                                     (LISP:CHAR-CODE ,(CAR MORE-CHARS]
+                                          'COMPILER:PASS))
+
+(DEFOPTIMIZER LISP:CHAR-NOT-GREATERP (CHAR &REST MORE-CHARS)
+                                         `(<=
+                                           (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE ,CHAR))
+                                           ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA
+                                                                     (FORM)
+                                                                     `(%%CHAR-UPCASE-CODE
+                                                                       (LISP:CHAR-CODE
+                                                                        ,FORM]
+                                                    MORE-CHARS)))
+
+(DEFOPTIMIZER LISP:CHAR-NOT-LESSP (CHAR &REST MORE-CHARS)
+                                      `(>= (%%CHAR-UPCASE-CODE (LISP:CHAR-CODE ,CHAR))
+                                           ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA
+                                                                     (FORM)
+                                                                     `(%%CHAR-UPCASE-CODE
+                                                                       (LISP:CHAR-CODE
+                                                                        ,FORM]
+                                                    MORE-CHARS)))
+
+(DEFOPTIMIZER LISP:CHAR/= (CHAR &REST MORE-CHARS)
+                              (LISP:IF (CDR MORE-CHARS)
+                                  'COMPILER:PASS
+                                  `(NEQ ,CHAR ,(CAR MORE-CHARS))))
+
+(DEFOPTIMIZER LISP:CHAR< (CHAR &REST MORE-CHARS)
+                             `(< (LISP:CHAR-CODE ,CHAR)
+                                 ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA (FORM)
+                                                                 `(LISP:CHAR-CODE ,FORM]
+                                          MORE-CHARS)))
+
+(DEFOPTIMIZER LISP:CHAR<= (CHAR &REST MORE-CHARS)
+                              `(<= (LISP:CHAR-CODE ,CHAR)
+                                   ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA (FORM)
+                                                                   `(LISP:CHAR-CODE ,FORM]
+                                            MORE-CHARS)))
+
+(DEFOPTIMIZER LISP:CHAR= (CHAR &REST MORE-CHARS)
+                             (LISP:IF (CDR MORE-CHARS)
+                                 [LET
+                                  ((CH (GENSYM)))
+                                  `(LET ((,CH ,CHAR))
+                                        (AND ,@(for X in MORE-CHARS
+                                                  collect `(EQ ,CH ,X]
+                                 `(EQ ,CHAR ,(CAR MORE-CHARS))))
+
+(DEFOPTIMIZER LISP:CHAR> (CHAR &REST MORE-CHARS)
+                             `(> (LISP:CHAR-CODE ,CHAR)
+                                 ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA (FORM)
+                                                                 `(LISP:CHAR-CODE ,FORM]
+                                          MORE-CHARS)))
+
+(DEFOPTIMIZER LISP:CHAR>= (CHAR &REST MORE-CHARS)
+                              `(>= (LISP:CHAR-CODE ,CHAR)
+                                   ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA (FORM)
+                                                                   `(LISP:CHAR-CODE ,FORM]
+                                            MORE-CHARS)))
+
+(DEFOPTIMIZER LISP:CHARACTERP (OBJECT)
+                                  `(TYPENAMEP ,OBJECT 'CHARACTER))
+
+(DEFOPTIMIZER LISP:LOWER-CASE-P (CHAR)
+                                    `(<= (CONSTANT (LISP:CHAR-CODE #\a))
+                                         (LISP:CHAR-CODE ,CHAR)
+                                         (CONSTANT (LISP:CHAR-CODE #\z))))
+
+(DEFOPTIMIZER LISP:STRING-CHAR-P (CHAR)
+                                     `(\DTEST ,CHAR 'CHARACTER))
+
+(DEFOPTIMIZER LISP:UPPER-CASE-P (CHAR)
+                                    `(<= (CONSTANT (LISP:CHAR-CODE #\A))
+                                         (LISP:CHAR-CODE ,CHAR)
+                                         (CONSTANT (LISP:CHAR-CODE #\Z))))
+
+
+
+(* ;; "Internals")
+
+
+(DEFMACRO %%CHAR-DOWNCASE-CODE (CODE)
+   `(LET ((%%CODE ,CODE))
+         (LISP:IF (<= (CONSTANT (LISP:CHAR-CODE #\A))
+                      %%CODE
+                      (CONSTANT (LISP:CHAR-CODE #\Z)))
+             [+ %%CODE (- (CONSTANT (LISP:CHAR-CODE #\a))
+                          (CONSTANT (LISP:CHAR-CODE #\A]
+             %%CODE)))
+
+(DEFMACRO %%CHAR-UPCASE-CODE (CODE)
+   `(LET ((%%CODE ,CODE))
+         (LISP:IF (<= (CONSTANT (LISP:CHAR-CODE #\a))
+                      %%CODE
+                      (CONSTANT (LISP:CHAR-CODE #\z)))
+             [- %%CODE (- (CONSTANT (LISP:CHAR-CODE #\a))
+                          (CONSTANT (LISP:CHAR-CODE #\A]
+             %%CODE)))
+
+(DEFMACRO %%CODE-CHAR (CODE)
+   `(\VAG2 \CHARHI ,CODE))
+
+
+
+(* ;; "Compiler options")
+
+
+(PUTPROPS CMLCHARACTER FILETYPE LISP:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA LISP:CHAR>= LISP:CHAR> LISP:CHAR= LISP:CHAR<= LISP:CHAR< LISP:CHAR/= 
+                         LISP:CHAR-NOT-LESSP LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-EQUAL 
+                         LISP:CHAR-LESSP LISP:CHAR-GREATERP LISP:CHAR-EQUAL)
+)
+(PRETTYCOMPRINT CMLCHARACTERCOMS)
+
+(RPAQQ CMLCHARACTERCOMS
+       [(COMS                                                (* ; 
+                                         "Interlisp CHARCODE; Some is here, the rest is in LLREAD.")
+              (FNS CHARCODE CHARCODE.UNDECODE)
+              (PROP MACRO SELCHARQ ALPHACHARP DIGITCHARP UCASECODE)
+              (OPTIMIZERS CHARCODE)
+              (ALISTS (DWIMEQUIVLST SELCHARQ)
+                     (PRETTYEQUIVLST SELCHARQ)))
+        (COMS                                                (* ; "Common Lisp CHARACTER type")
+              (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CHARACTER))
+              (VARIABLES \CHARHI)
+              (VARIABLES LISP:CHAR-BITS-LIMIT LISP:CHAR-CODE-LIMIT LISP:CHAR-CONTROL-BIT 
+                     LISP:CHAR-FONT-LIMIT LISP:CHAR-HYPER-BIT LISP:CHAR-META-BIT LISP:CHAR-SUPER-BIT)
+              )
+        (COMS                                                (* ; "Basic character fns")
+              (FNS LISP:CHAR-CODE LISP:CHAR-INT LISP:INT-CHAR)
+              (FUNCTIONS LISP:CODE-CHAR)
+              (OPTIMIZERS LISP:CHAR-CODE LISP:CHAR-INT LISP:CODE-CHAR LISP:INT-CHAR))
+        [COMS                                                (* ; 
+                                                        "I/O; Some is here, the rest is in LLREAD.")
+              (FNS CHARACTER.PRINT)
+              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (SETTOPVAL (\TYPEGLOBALVARIABLE 'CHARACTER T)
+                                                        (NTYPX (LISP:CODE-CHAR 0 0 0)))
+                                                 (DEFPRINT 'CHARACTER 'CHARACTER.PRINT]
+        (COMS 
+              (* ;; "Common lisp character functions")
+
+              (FNS LISP:CHAR-BIT LISP:CHAR-BITS LISP:CHAR-DOWNCASE LISP:CHAR-FONT LISP:CHAR-NAME 
+                   LISP:CHAR-UPCASE LISP:CHARACTER LISP:NAME-CHAR LISP:SET-CHAR-BIT)
+              (FUNCTIONS LISP:DIGIT-CHAR LISP:MAKE-CHAR LISP::BASE-CHARACTER-P 
+                     LISP::EXTENDED-CHARACTER-P)
+              (OPTIMIZERS LISP:CHAR-UPCASE LISP:CHAR-DOWNCASE LISP:MAKE-CHAR))
+        (COMS 
+              (* ;; "Predicates")
+
+              (FNS LISP:ALPHA-CHAR-P LISP:ALPHANUMERICP LISP:BOTH-CASE-P LISP:CHARACTERP 
+                   LISP:GRAPHIC-CHAR-P LISP:LOWER-CASE-P LISP:STANDARD-CHAR-P LISP:STRING-CHAR-P 
+                   LISP:UPPER-CASE-P)
+              (FNS LISP:CHAR-EQUAL LISP:CHAR-GREATERP LISP:CHAR-LESSP LISP:CHAR-NOT-EQUAL 
+                   LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-LESSP LISP:CHAR/= LISP:CHAR< LISP:CHAR<= 
+                   LISP:CHAR= LISP:CHAR> LISP:CHAR>=)
+              (FUNCTIONS LISP:DIGIT-CHAR-P)
+              (OPTIMIZERS LISP:CHAR-EQUAL LISP:CHAR-GREATERP LISP:CHAR-LESSP LISP:CHAR-NOT-EQUAL 
+                     LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-LESSP LISP:CHAR/= LISP:CHAR< LISP:CHAR<= 
+                     LISP:CHAR= LISP:CHAR> LISP:CHAR>= LISP:CHARACTERP LISP:LOWER-CASE-P 
+                     LISP:STRING-CHAR-P LISP:UPPER-CASE-P))
+        (COMS 
+              (* ;; "Internals")
+
+              (FUNCTIONS %%CHAR-DOWNCASE-CODE %%CHAR-UPCASE-CODE %%CODE-CHAR))
+        (COMS 
+              (* ;; "Compiler options")
+
+              (PROP FILETYPE CMLCHARACTER)
+              (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)))
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML CHARCODE)
+                      (LAMA LISP:CHAR>= LISP:CHAR> LISP:CHAR= LISP:CHAR<= LISP:CHAR< LISP:CHAR/= 
+                            LISP:CHAR-NOT-LESSP LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-EQUAL 
+                            LISP:CHAR-LESSP LISP:CHAR-GREATERP LISP:CHAR-EQUAL])
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML CHARCODE)
+
+(ADDTOVAR LAMA LISP:CHAR>= LISP:CHAR> LISP:CHAR= LISP:CHAR<= LISP:CHAR< LISP:CHAR/= 
+                         LISP:CHAR-NOT-LESSP LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-EQUAL 
+                         LISP:CHAR-LESSP LISP:CHAR-GREATERP LISP:CHAR-EQUAL)
+)
+(PUTPROPS CMLCHARACTER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (4234 4520 (CHARCODE 4244 . 4303) (CHARCODE.UNDECODE 4305 . 4518)) (7120 7495 (
+LISP:CHAR-CODE 7130 . 7280) (LISP:CHAR-INT 7282 . 7348) (LISP:INT-CHAR 7350 . 7493)) (10135 11239 (
+CHARACTER.PRINT 10145 . 11237)) (11454 15081 (LISP:CHAR-BIT 11464 . 11621) (LISP:CHAR-BITS 11623 . 
+11784) (LISP:CHAR-DOWNCASE 11786 . 11976) (LISP:CHAR-FONT 11978 . 12139) (LISP:CHAR-NAME 12141 . 13934
+) (LISP:CHAR-UPCASE 13936 . 14122) (LISP:CHARACTER 14124 . 14670) (LISP:NAME-CHAR 14672 . 14916) (
+LISP:SET-CHAR-BIT 14918 . 15079)) (17155 20389 (LISP:ALPHA-CHAR-P 17165 . 17711) (LISP:ALPHANUMERICP 
+17713 . 17913) (LISP:BOTH-CASE-P 17915 . 18028) (LISP:CHARACTERP 18030 . 18176) (LISP:GRAPHIC-CHAR-P 
+18178 . 19317) (LISP:LOWER-CASE-P 19319 . 19480) (LISP:STANDARD-CHAR-P 19482 . 20152) (LISP:STRING-CHAR-P
+ 20154 . 20224) (LISP:UPPER-CASE-P 20226 . 20387)) (20390 26570 (LISP:CHAR-EQUAL 20400 . 20818) (
+LISP:CHAR-GREATERP 20820 . 21353) (LISP:CHAR-LESSP 21355 . 21885) (LISP:CHAR-NOT-EQUAL 21887 . 22537) 
+(LISP:CHAR-NOT-GREATERP 22539 . 23077) (LISP:CHAR-NOT-LESSP 23079 . 23614) (LISP:CHAR/= 23616 . 24246)
+ (LISP:CHAR< 24248 . 24724) (LISP:CHAR<= 24726 . 25204) (LISP:CHAR= 25206 . 25610) (LISP:CHAR> 25612
+ . 26088) (LISP:CHAR>= 26090 . 26568)))))
+STOP
diff --git a/CLTL2/CMLCHARACTER.LCOM b/CLTL2/CMLCHARACTER.LCOM
new file mode 100644
index 00000000..835538c8
Binary files /dev/null and b/CLTL2/CMLCHARACTER.LCOM differ
diff --git a/CLTL2/CMLCOMPILE b/CLTL2/CMLCOMPILE
new file mode 100644
index 00000000..3483d3d7
--- /dev/null
+++ b/CLTL2/CMLCOMPILE
@@ -0,0 +1,561 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 10:39:21" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLCOMPILE.;2" 31069  
+
+      previous date%: "30-Mar-92 12:16:41" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLCOMPILE.;1")
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1987, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLCOMPILECOMS)
+
+(RPAQQ CMLCOMPILECOMS
+       [(COMS (FUNCTIONS LISP:DISASSEMBLE)
+              (FNS FAKE-COMPILE-FILE INTERLISP-FORMAT-P INTERLISP-NLAMBDA-FUNCTION-P 
+                   COMPILE-FILE-EXPRESSION COMPILE-FILE-WALK-FUNCTION ARGTYPE.STATE 
+                   COMPILE.CHECK.ARGTYPE COMPILE.FILE.DEFINEQ COMPILE-FILE-SETF-SYMBOL-FUNCTION 
+                   COMPILE-FILE-EX/IMPORT COMPILE.FILE.APPLY COMPILE.FILE.RESET COMPILE-IN-CORE)
+              (FNS COMPILE-FILE-SCAN-FIRST)
+                                                             (* ; 
+                                                           "This function is support for AR#11185")
+              (VARS ARGTYPE.VARS)
+              (PROP COMPILE-FILE-EXPRESSION DEFINEQ * SETF-SYMBOL-FUNCTION PRETTYCOMPRINT)
+              (FUNCTIONS COMPILE-FILE-DECLARE%:))
+        [COMS (FNS NEWDEFC)
+              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD 'NEWDEFC 'DEFC]
+        (PROP FILETYPE CMLCOMPILE)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML)
+                                                                             (LAMA FAKE-COMPILE-FILE])
+
+(LISP:DEFUN LISP:DISASSEMBLE (NAME-OR-COMPILED-FUNCTION &KEY LEVEL-P (RADIX 8)
+                                        (OUTPUT *STANDARD-OUTPUT*)
+                                        FIRST-BYTE MARKED-PC)
+   (PRINTCODE (if (CCODEP NAME-OR-COMPILED-FUNCTION)
+                  then NAME-OR-COMPILED-FUNCTION
+                else (LISP:COMPILE NIL (if (LISP:SYMBOLP NAME-OR-COMPILED-FUNCTION)
+                                                 then (LISP:SYMBOL-FUNCTION 
+                                                                 NAME-OR-COMPILED-FUNCTION)
+                                               else NAME-OR-COMPILED-FUNCTION)))
+          LEVEL-P RADIX OUTPUT FIRST-BYTE MARKED-PC))
+(DEFINEQ
+
+(FAKE-COMPILE-FILE
+  (LISP:LAMBDA
+   (FILENAME &KEY LAP REDEFINE OUTPUT-FILE (SAVE-EXPRS T)
+          (COMPILER-OUTPUT T)
+          (PROCESS-ENTIRE-FILE NIL PEFP))                  (* ; "Edited 29-Jun-90 19:19 by nm")
+   (LET
+    (COMPILE.FILE.AFTER VALUE COMPILE.FILE.VALUE (NLAML NLAML)
+           (NLAMA NLAMA)
+           (LAMS LAMS)
+           (LAMA LAMA)
+           (DFNFLG NIL))
+    (DECLARE (LISP:SPECIAL COMPILE.FILE.AFTER COMPILE.FILE.VALUE NLAML NLAMA LAMS LAMA DFNFLG))
+    (RESETLST
+        (RESETSAVE NIL (LIST 'RESETUNDO)
+               (RESETUNDO))
+        (RESETSAVE COUTFILE COMPILER-OUTPUT)
+        (RESETSAVE STRF REDEFINE)
+        (RESETSAVE SVFLG (AND SAVE-EXPRS REDEFINE 'DEFER))
+        (RESETSAVE LAPFLG LAP)
+        (LET
+         ((*PACKAGE* *INTERLISP-PACKAGE*)
+          (*READ-BASE* 10)
+          (LOCALVARS SYSLOCALVARS)
+          (SPECVARS T)
+          STREAM LSTFIL ROOTNAME INTERLISP-FORMAT ENV FORM)
+         (DECLARE (LISP:SPECIAL *PACKAGE* *READ-BASE* LOCALVARS SPECVARS LSTFIL))
+         [RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
+                                (SETQ STREAM (OPENSTREAM FILENAME 'INPUT]
+         (LISP:MULTIPLE-VALUE-SETQ (ENV FORM)
+                (\PARSE-FILE-HEADER STREAM 'RETURN T))
+         (SETQ INTERLISP-FORMAT (AND ENV (NEQ ENV *COMMON-LISP-READ-ENVIRONMENT*)))
+         (if (NOT PEFP)
+             then (SETQ PROCESS-ENTIRE-FILE INTERLISP-FORMAT))
+         (if LAP
+             then (SETQ LSTFIL COUTFILE))
+         (SETQ FILENAME (FULLNAME STREAM))
+         (RESETSAVE NIL (LIST (FUNCTION COMPILE.FILE.RESET)
+                                [SETQ OUTPUT-FILE (OPENSTREAM (OR OUTPUT-FILE (PACKFILENAME.STRING
+                                                                               'VERSION NIL
+                                                                               'EXTENSION COMPILE.EXT
+                                                                               'BODY FILENAME))
+                                                         'OUTPUT
+                                                         'NEW
+                                                         '((TYPE BINARY]
+                                STREAM
+                                (ROOTFILENAME FILENAME)))
+         (if OUTPUT-FILE
+             then (RESETSAVE LCFIL OUTPUT-FILE)
+                   (PRINT-COMPILE-HEADER (LIST STREAM)
+                          '("COMPILE-FILEd")
+                          ENV))
+         (WITH-READER-ENVIRONMENT ENV
+             (PROG ((DEFERRED.EXPRESSIONS NIL)
+                    (*PRINT-ARRAY* T)
+                    (*PRINT-LEVEL* NIL)
+                    (*PRINT-LENGTH* NIL)
+                    (FIRSTFORMS NIL)
+                    (AFTERS NIL)
+                    (SCRATCH.LCOM '{CORE}SCRATCH.LCOM)
+                    DUMMYFILE TEMPVAL)
+                   (DECLARE (LISP:SPECIAL DEFERRED.EXPRESSIONS *PRINT-ARRAY* *PRINT-LEVEL* 
+                                       *PRINT-LENGTH* FIRSTFORMS AFTERS DEFERS))
+                                                             (* ; "Edited by TT (11-June-90 : for AR#11185) all contents of file are read, and each forms are compiled.(This reading method is for supporting %"FIRST%", %"NOTFIRST%" tag.)")
+                   [RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
+                                          (SETQ DUMMYFILE (OPENSTREAM SCRATCH.LCOM 'BOTH 'NEW]
+               LPDUMP
+                   [if (EQUAL (CAR FORM)
+                                  'RPAQQ)
+                       then                              (* ; 
+                                  "This is the support method of %"COMPILERVARS%" (2-July-1990 TT)")
+                             (SETQ TEMPVAL (CADDR FORM))
+                             (if (SETQ TEMPVAL (ASSOC 'DECLARE%: TEMPVAL))
+                                 then (if (SETQ TEMPVAL (FMEMB 'COMPILERVARS
+                                                                       (FMEMB 'DOEVAL@COMPILE TEMPVAL
+                                                                              )))
+                                              then (SETQ DFNFLG T)
+                                                    (if [SETQ TEMPVAL (FMEMB 'ADDVARS
+                                                                                 (SETQ TEMPVAL
+                                                                                  (CADR TEMPVAL]
+                                                        then (LISP:DOLIST (ARG (CDR TEMPVAL))
+                                                                     (APPLY 'ADDTOVAR ARG))]
+                   (COMPILE-FILE-EXPRESSION FORM DUMMYFILE NIL PROCESS-ENTIRE-FILE)
+                   (SKIPSEPRCODES STREAM)
+                   (if (EOFP STREAM)
+                       then (CLOSEF STREAM)
+                             (for FORM in FIRSTFORMS
+                                do (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL 
+                                              PROCESS-ENTIRE-FILE T))
+                             (COPYBYTES DUMMYFILE OUTPUT-FILE 0 (GETFILEPTR DUMMYFILE))
+                             (CLOSEF? DUMMYFILE)
+                             (DELFILE (FULLNAME DUMMYFILE))
+                             (AND PROCESS-ENTIRE-FILE (for EXP in (REVERSE 
+                                                                                 DEFERRED.EXPRESSIONS
+                                                                                 )
+                                                         do (APPLY* (CAR EXP)
+                                                                       (CDR EXP)
+                                                                       OUTPUT-FILE)))
+                             (for FORM in AFTERS do (COMPILE-FILE-EXPRESSION FORM 
+                                                                       OUTPUT-FILE NIL 
+                                                                       PROCESS-ENTIRE-FILE T))
+                             (RETURN))
+                   (SETQ FORM (READ STREAM))
+                   (GO LPDUMP))
+             (PRINT NIL OUTPUT-FILE))
+         (SETQ COMPILE.FILE.VALUE (CLOSEF OUTPUT-FILE))))    (* ; 
+                                                           "Do these after UNDONLSETQ entered")
+    (MAPC (REVERSE COMPILE.FILE.AFTER)
+          (FUNCTION EVAL))
+    COMPILE.FILE.VALUE)))
+
+(INTERLISP-FORMAT-P
+  [LAMBDA (STREAM)                                           (* bvm%: " 3-Aug-86 14:01")
+    (SELCHARQ (PEEKCCODE STREAM)
+         (; NIL)
+         ((^F "(") 
+              T)
+         NIL])
+
+(INTERLISP-NLAMBDA-FUNCTION-P
+  [LAMBDA (X)                                                (* lmm " 7-May-86 20:12")
+    (AND (LITATOM X)
+         (FMEMB (ARGTYPE X)
+                '(1 3))
+         (NOT (LISP:SPECIAL-FORM-P X])
+
+(COMPILE-FILE-EXPRESSION
+  [LAMBDA (FORM COMPILED.FILE COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P)
+                                                             (* ; "Edited 30-Jun-90 18:31 by nm")
+    (DECLARE (LISP:SPECIAL COMPILED.FILE))
+    (AND (LISTP FORM)
+         (SELECTQ (CAR FORM)
+             ((DECLARE%: FILECREATED) 
+                  (COMPILE-FILE-SCAN-FIRST FORM COMPILED.FILE NIL T COMPILE.TIME.TOO DEFER 
+                         FORCE-OUTPUT-P))
+             ((DEFMACRO) 
+                  (LET* ((DEFINITION (REMOVE-COMMENTS FORM))
+                         (NAME (XCL::%%DEFINER-NAME 'DEFMACRO DEFINITION))
+                         (BODY (XCL::%%EXPAND-DEFINER 'DEFMACRO DEFINITION)))
+                        (LISP:EVAL BODY)
+                        (COMPILE-FILE-EXPRESSION BODY COMPILED.FILE COMPILE.TIME.TOO DEFER 
+                               FORCE-OUTPUT-P)))
+             ((PROGN) 
+                  (for X in (CDR FORM) do (COMPILE-FILE-EXPRESSION X COMPILED.FILE 
+                                                             COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P)))
+             ((QUOTE)                                        (* ; 
+                                                           " ignore top level quoted expression -i")
+                  NIL)
+             ((LISP:COMPILER-LET)                            (* ; " top level compiler-let. bind variables and recursively compile sub-expressions. This is here mainly  for b PCL has top level compiler-lets")
+                  [LET [(VARS (LISP:MAPCAR #'(LISP:LAMBDA (X)
+                                                    (if (LISP:CONSP X)
+                                                        then (CAR X)
+                                                      else X))
+                                     (CADR FORM)))
+                        (VALS (LISP:MAPCAR #'[LISP:LAMBDA (X)
+                                                    (if (LISP:CONSP X)
+                                                        then (LISP:EVAL (CADR X]
+                                     (CADR FORM]
+                       (LISP:PROGV VARS VALS
+                           (LISP:MAPC #'(LISP:LAMBDA (X)
+                                               (COMPILE-FILE-EXPRESSION X COMPILED.FILE 
+                                                      COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P))
+                                  (CDDR FORM)))])
+             ((LISP:EVAL-WHEN) 
+                  [LET [[EVAL.SPECIFIED (OR (FMEMB 'EVAL (CADR FORM))
+                                            (FMEMB 'LISP:EVAL (CADR FORM]
+                        [LOAD.SPECIFIED (OR (FMEMB 'LOAD (CADR FORM))
+                                            (FMEMB 'LISP:LOAD (CADR FORM]
+                        (COMPILE.SPECIFIED (OR (FMEMB 'COMPILE (CADR FORM))
+                                               (FMEMB 'LISP:COMPILE (CADR FORM]
+                       (COND
+                          [(NOT LOAD.SPECIFIED)
+                           (COND
+                              ((OR COMPILE.SPECIFIED (AND COMPILE.TIME.TOO EVAL.SPECIFIED))
+                               (for INNER-FORM in (CDDR FORM) do (EVAL INNER-FORM]
+                          (T (for INNER-FORM in (CDDR FORM)
+                                do (COMPILE-FILE-EXPRESSION INNER-FORM COMPILED.FILE
+                                              (OR COMPILE.SPECIFIED (AND COMPILE.TIME.TOO 
+                                                                         EVAL.SPECIFIED))
+                                              DEFER FORCE-OUTPUT-P])
+             ((LISP:IN-PACKAGE LISP:IN-PACKAGE)              (* ; 
+        "These are special because they have to be dumped to the output BEFORE the package changes")
+                  (PRINT FORM COMPILED.FILE)
+                  (EVAL FORM))
+             ((LISP:MAKE-PACKAGE LISP:SHADOW LISP:SHADOWING-IMPORT EXPORT LISP:UNEXPORT 
+                     LISP:USE-PACKAGE LISP:UNUSE-PACKAGE IMPORT) 
+                                                             (* ; "This is Special also, becouse  the compiling Environment Must be changed.(see CLtL, 11.7. Package System Functions and Variables)  edited by TT(10-April-90)")
+                  (PRINT FORM COMPILED.FILE)
+                  (EVAL FORM))
+             ((LISP:SETQ)                                    (* ; 
+           "Gasly kludge because cl:setq needs to run in the init before macroexpansion is enabled")
+                  (COMPILE-FILE-EXPRESSION (EXPANDMACRO FORM T)
+                         COMPILED.FILE COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P))
+             (LET [(PROP (OR (GETPROP (CAR FORM)
+                                    'COMPILE-FILE-EXPRESSION)
+                             (GETPROP (CAR FORM)
+                                    'COMPILE.FILE.EXPRESSION]
+                  (if [AND (NOT PROP)
+                               (NOT (LISP:SPECIAL-FORM-P (CAR FORM)))
+                               (NOT (INTERLISP-NLAMBDA-FUNCTION-P (CAR FORM)))
+                               (NEQ FORM (SETQ FORM (LISP:MACROEXPAND-1 FORM]
+                      then (COMPILE-FILE-EXPRESSION FORM COMPILED.FILE COMPILE.TIME.TOO DEFER
+                                      FORCE-OUTPUT-P)
+                    else (if COMPILE.TIME.TOO
+                                 then (EVAL FORM))
+                          (if PROP
+                              then (COMPILE.FILE.APPLY PROP FORM DEFER FORCE-OUTPUT-P)
+                            elseif [NOT (EQUAL FORM (SETQ FORM (WALK-FORM FORM :WALK-FUNCTION
+                                                                          (FUNCTION 
+                                                                           COMPILE-FILE-WALK-FUNCTION
+                                                                           ]
+                              then (COMPILE-FILE-EXPRESSION FORM COMPILED.FILE 
+                                              COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P)
+                            else (COMPILE.FILE.APPLY (FUNCTION PRINT)
+                                            FORM DEFER FORCE-OUTPUT-P])
+
+(COMPILE-FILE-WALK-FUNCTION
+  [LAMBDA (FORM)                                             (* lmm "26-Jun-86 17:25")
+    (if (NLISTP FORM)
+        then FORM
+      else (LISP:VALUES FORM (INTERLISP-NLAMBDA-FUNCTION-P (CAR FORM])
+
+(ARGTYPE.STATE
+  [LAMBDA NIL
+    (for X in ARGTYPE.VARS do (PRINTOUT T X %, (EVAL (CADR X))
+                                                 T])
+
+(COMPILE.CHECK.ARGTYPE
+  [LAMBDA (X AT)                                             (* lmm "15-Jun-85 16:58")
+    (if (NEQ AT (LET (BLKFLG)
+                         (COMP.ARGTYPE X)))
+        then                                             (* ; 
+                                                         "Incorrectly on one of the defining lists")
+        (for ATYPEPAIR in ARGTYPE.VARS
+           do (LET [(VAL (FMEMB X (EVALV (CADR ATYPEPAIR]
+                       (if (EQ AT (CAR ATYPEPAIR))
+                           then (if VAL
+                                        then (PRINTOUT COUTFILE "Compiler confused: " X " on "
+                                                        (CADR ATYPEPAIR)
+                                                        " but compiler doesn't think its a "
+                                                        (CADDR ATYPEPAIR)))
+                                 [/SETTOPVAL (CADR ATYPEPAIR)
+                                        (CONS X (PROGN (GETTOPVAL (CADR ATYPEPAIR]
+                         else (if VAL
+                                      then (PRINTOUT COUTFILE "Warning: compiler thought " X " "
+                                                      (LIST 'a (OR (CADDR (ASSOC AT ARGTYPE.VARS))
+                                                                   "LAMBDA spread")
+                                                            'function)
+                                                      " was a "
+                                                      (CADDR ATYPEPAIR)
+                                                      " because it was incorrectly on "
+                                                      (CADR ATYPEPAIR)
+                                                      T)
+                                            (/SETTOPVAL (CADR ATYPEPAIR)
+                                                   (REMOVE X (PROGN (GETTOPVAL (CADR ATYPEPAIR])
+
+(COMPILE.FILE.DEFINEQ
+  [LAMBDA (FORM LCFIL)                                       (* bvm%: "18-Sep-86 14:35")
+    (for DEF in (CDR FORM) unless (FMEMB (CAR DEF)
+                                                     DONTCOMPILEFNS)
+       do (COMPILE.CHECK.ARGTYPE (CAR DEF)
+                     (ARGTYPE (CADR DEF)))
+             (BYTECOMPILE2 (CAR DEF)
+                    (COMPILE1A (CAR DEF)
+                           (CADR DEF)
+                           NIL])
+
+(COMPILE-FILE-SETF-SYMBOL-FUNCTION
+  [LAMBDA (FORM LCFIL)                                       (* bvm%: " 8-Sep-86 16:55")
+    (if [AND (FMEMB (CAR (LISTP (LISP:THIRD FORM)))
+                        '(FUNCTION LISP:FUNCTION))
+                 (EQ (CAR (LISTP (LISP:SECOND FORM)))
+                     'QUOTE)
+                 (LISP:CONSP (LISP:SECOND (LISP:THIRD FORM]
+        then (BYTECOMPILE2 (CADR (LISP:SECOND FORM))
+                        (CADR (LISP:THIRD FORM)))
+      else (PRINT (WALK-FORM FORM :WALK-FUNCTION (FUNCTION COMPILE-FILE-WALK-FUNCTION))
+                      LCFIL])
+
+(COMPILE-FILE-EX/IMPORT
+  [LAMBDA (FORM LCFIL RDTBL)                                 (* bvm%: " 3-Aug-86 15:05")
+
+         (* * "EXPORT, IMPORT, SHADOW, USE-PACKAGE are all implicitly EVAL@COMPILE, since they have to affect the package being used to read what follows")
+
+    (PRINT FORM LCFIL RDTBL)
+    (EVAL FORM])
+
+(COMPILE.FILE.APPLY
+  [LAMBDA (PROP FORM DEFER FORCE-OUTPUT-P)                   (* ; "Edited 29-Jun-90 19:21 by nm")
+    (if FORCE-OUTPUT-P
+        then (PRINT FORM COMPILED.FILE)
+      else (if DEFER
+                   then (push DEFERRED.EXPRESSIONS (CONS PROP FORM))
+                 else (APPLY* PROP FORM COMPILED.FILE])
+
+(COMPILE.FILE.RESET
+  [LAMBDA (COMPILED.FILE SOURCEFILE ROOTNAME)                (* bvm%: " 9-Sep-86 15:16")
+                                                             (* Cleans up after brecompile and 
+                                                           bcompl have finished operating,)
+    (if (AND COMPILED.FILE (OPENP COMPILED.FILE))
+        then (CLOSE-AND-MAYBE-DELETE COMPILED.FILE))
+    (if SOURCEFILE
+        then (CLOSEF? SOURCEFILE))
+    (if (NULL RESETSTATE)
+        then                                             (* Finished successfully.)
+              (/SETATOMVAL 'NOTCOMPILEDFILES (REMOVE ROOTNAME NOTCOMPILEDFILES)) 
+                                                             (* Removes FILES from 
+                                                           NOTCOMPILEDFILES.)])
+
+(COMPILE-IN-CORE
+  [LAMBDA (fn-name fn-expr fn-type NOSAVE)
+    (DECLARE (SPECVARS LCFIL LAPFLG STRF SVFLG LSTFIL SPECVARS LOCALVARS DONT-TRANSFER-PUTD))
+                                                             (* lmm " 2-Jun-86 22:04")
+
+         (* in-core compiling for functions and forms, without the interview.
+       if X is a list, we assume that we are being called merely to display the lap 
+       and machine code. the form is compiled as the definition of FOO but the 
+       compiled :CODE is thrown away. -
+       if X is a litatom, then saving, redefining, and printing is controlled by the 
+       flags.)
+
+    (LET ((NOREDEFINE NIL)
+          (PRINTLAP NIL)
+          (DONT-TRANSFER-PUTD T))
+         (RESETVARS [(NLAMA NLAMA)
+                     (NLAML NLAML)
+                     (LAMS LAMS)
+                     (LAMA LAMA)
+                     (NOFIXFNSLST NOFIXFNSLST)
+                     (NOFIXVARSLST NOFIXVARSLST)
+                     (COUTFILE (COND
+                                  ((AND (BOUNDP 'NULLFILE)
+                                        (STREAMP NULLFILE)
+                                        (OPENP NULLFILE))
+                                   NULLFILE)
+                                  (T (SETQ NULLFILE (OPENFILE '{NULL} 'OUTPUT]
+                    (RETURN (RESETLST                        (* RESETLST to provide reset context 
+                                                           for macros under COMPILE1 as 
+                                                           generated e.g. by DECL.)
+                                [PROG ((LCFIL)
+                                       [LAPFLG (AND PRINTLAP (COND
+                                                                (BYTECOMPFLG T)
+                                                                (T 2]
+                                       (STRF (NOT NOREDEFINE))
+                                       (SVFLG (if (EQ fn-type 'SELECTOR)
+                                                  then 'SELECTOR
+                                                else (NOT NOSAVE)))
+                                       (LSTFIL T)
+                                       (SPECVARS SYSSPECVARS)
+                                       (LOCALVARS T))
+                                      (RETURN (PROGN (SETQ fn-expr (COMPILE1A fn-name fn-expr T))
+                                                     (PROG ((FREEVARS FREEVARS))
+                                                           (RETURN (BYTECOMPILE2 fn-name fn-expr])])
+)
+(DEFINEQ
+
+(COMPILE-FILE-SCAN-FIRST
+  [LAMBDA (FORM COMPILED.FILE FIRSTFLG DOCOPY EVAL@COMPILE DEFER FORCE-OUTPUT-P)
+                                                             (* ; "Edited 30-Jun-90 18:32 by nm")
+                                                             (* ; "Edited 26-Apr-90 by tt")
+                                                             (* ; 
+                      "This is enhancement for Fake Compiler's interpretation of file package coms")
+    (PROG ((DFNFLG DFNFLG)
+           (FIRST FIRSTFLG)
+           (DOCOPY DOCOPY)
+           (EVAL@COMPILE EVAL@COMPILE)
+           NOTFIRST)
+          (if (LISTP FORM)
+              then
+              (SELECTQ (CAR FORM)
+                  ((DECLARE%:) 
+                       (LISP:DO ((TAIL (CDR FORM)
+                                       (CDR TAIL)))
+                                ((LISP:ENDP TAIL))
+                           [if (LISP:SYMBOLP (CAR TAIL))
+                               then (CASE (CAR TAIL)
+                                            ((DOCOPY COPY) (SETQ DOCOPY T))
+                                            ((DONTCOPY) (SETQ DOCOPY NIL))
+                                            ((COPYWHEN) [SETQ DOCOPY (EVAL (CAR (SETQ TAIL
+                                                                                 (CDR TAIL])
+                                            ((EVAL@LOAD DOEVAL@LOAD DONTEVAL@LOAD) NIL)
+                                            ((EVAL@LOADWHEN) (LISP:POP TAIL))
+                                            ((EVAL@COMPILE DOEVAL@COMPILE) (SETQ EVAL@COMPILE T))
+                                            ((DONTEVAL@COMPILE) (SETQ EVAL@COMPILE NIL))
+                                            ((EVAL@COMPILEWHEN) [SETQ EVAL@COMPILE
+                                                                 (EVAL (CAR (SETQ TAIL (CDR TAIL])
+                                            ((FIRST) 
+                                               (SETQ FIRST T)
+                                               (SETQ NOTFIRST NIL))
+                                                             (* ; "for First")
+                                            ((NOTFIRST) 
+                                               (SETQ NOTFIRST T)
+                                               (SETQ FIRST NIL))
+                                                             (* ; "for Not First")
+                                            ((COMPILERVARS) (SETQ DFNFLG T))
+                                                             (* ; "for Compilervars")
+                                            (LISP:OTHERWISE (LISP:FORMAT COUTFILE 
+                                                 "Warning: Ignoring unrecognized DECLARE: tag: ~S~%%"
+                                                                   (CAR TAIL))))
+                             else (COND
+                                         ((EQ 'DECLARE%: (CAR (CAR TAIL)))
+                                          (COMPILE-FILE-SCAN-FIRST (CAR TAIL)
+                                                 COMPILED.FILE FIRST DOCOPY EVAL@COMPILE DEFER))
+                                         (T (LISP:WHEN EVAL@COMPILE
+                                                (EVAL (CAR TAIL)))
+                                            (LISP:WHEN DOCOPY
+                                                (LISP:IF FIRST
+                                                    (SETQ FIRSTFORMS (NCONC1 FIRSTFORMS (CAR TAIL)))
+                                                    (LISP:IF NOTFIRST
+                                                        (SETQ AFTERS (NCONC1 AFTERS (CAR TAIL)))
+                                                        (COMPILE-FILE-EXPRESSION (CAR TAIL)
+                                                               COMPILED.FILE EVAL@COMPILE DEFER 
+                                                               FORCE-OUTPUT-P))))]))
+                  ((FILECREATED) 
+                       (if FORCE-OUTPUT-P
+                           then (PRINT FORM COMPILED.FILE)
+                         else (SETQ FIRSTFORMS (NCONC1 FIRSTFORMS FORM))))
+                  NIL])
+)
+
+
+
+(* ; "This function is support for AR#11185")
+
+
+(RPAQQ ARGTYPE.VARS ((1 NLAML "NLAMBDA spread")
+                         (2 LAMA "LAMBDA nospread")
+                         (0 LAMS "LAMBDA spread")
+                         (3 NLAMA "NLAMBDA no-spread")))
+
+(PUTPROPS DEFINEQ COMPILE-FILE-EXPRESSION COMPILE.FILE.DEFINEQ)
+
+(PUTPROPS * COMPILE-FILE-EXPRESSION NILL)
+
+(PUTPROPS SETF-SYMBOL-FUNCTION COMPILE-FILE-EXPRESSION COMPILE-FILE-SETF-SYMBOL-FUNCTION)
+
+(PUTPROPS PRETTYCOMPRINT COMPILE-FILE-EXPRESSION NILL)
+
+(LISP:DEFUN COMPILE-FILE-DECLARE%: (FORM COMPILED.FILE EVAL@COMPILE DOCOPY DEFER)
+   (LISP:DO ((TAIL (CDR FORM)
+                   (CDR TAIL)))
+            ((LISP:ENDP TAIL))
+       (LISP:IF (LISP:SYMBOLP (CAR TAIL))
+           (CASE (CAR TAIL)
+               ((EVAL@LOAD DOEVAL@LOAD DONTEVAL@LOAD) NIL)
+               ((EVAL@LOADWHEN) (LISP:POP TAIL))
+               ((EVAL@COMPILE DOEVAL@COMPILE) (SETQ EVAL@COMPILE T))
+               ((DONTEVAL@COMPILE) (SETQ EVAL@COMPILE NIL))
+               ((EVAL@COMPILEWHEN) [SETQ EVAL@COMPILE (EVAL (CAR (SETQ TAIL (CDR TAIL])
+               ((COPY DOCOPY) (SETQ DOCOPY T))
+               ((DONTCOPY) (SETQ DOCOPY NIL))
+               ((COPYWHEN) [SETQ DOCOPY (EVAL (CAR (SETQ TAIL (CDR TAIL])
+               ((FIRST) )
+               ((NOTFIRST COMPILERVARS) )
+               (LISP:OTHERWISE (LISP:FORMAT COUTFILE 
+                                      "Warning: Ignoring unrecognized DECLARE: tag: ~S~%%"
+                                      (CAR TAIL))))
+           [COND
+              ((EQ 'DECLARE%: (CAR (CAR TAIL)))
+               (COMPILE-FILE-DECLARE%: (CAR TAIL)
+                      COMPILED.FILE EVAL@COMPILE DOCOPY DEFER))
+              (T (LISP:WHEN EVAL@COMPILE
+                     (EVAL (CAR TAIL)))
+                 (LISP:WHEN DOCOPY
+                     (COMPILE-FILE-EXPRESSION (CAR TAIL)
+                            COMPILED.FILE EVAL@COMPILE DEFER))])))
+(DEFINEQ
+
+(NEWDEFC
+  [LAMBDA (NM DF)                                            (* bvm%: "30-Sep-86 23:12")
+    [COND
+       ((EQ SVFLG 'DEFER)
+        (push COMPILE.FILE.AFTER (LIST (FUNCTION NEWDEFC)
+                                           (KWOTE NM)
+                                           (KWOTE DF)
+                                           T)))
+       ((OR (NULL DFNFLG)
+            (EQ DFNFLG T))
+        [COND
+           ((GETD NM)
+            (VIRGINFN NM T)
+            (COND
+               ((NULL DFNFLG)
+                (LISP:FORMAT *ERROR-OUTPUT* "~&(~S redefined)~%%" NM)
+                (SAVEDEF NM]
+        (/PUTD NM DF T))
+       (T 
+          (* ;; "Save on CODE prop.  Be nice and change it from archaic CCODEP object to modern compiled code object.")
+
+          (/PUTPROP NM 'CODE (if (ARRAYP DF)
+                                 then (create COMPILED-CLOSURE
+                                                 FNHEADER _ (fetch (ARRAYP BASE) of DF))
+                               else DF]
+    DF])
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(MOVD 'NEWDEFC 'DEFC)
+)
+
+(PUTPROPS CMLCOMPILE FILETYPE LISP:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA FAKE-COMPILE-FILE)
+)
+(PUTPROPS CMLCOMPILE COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (2394 23384 (FAKE-COMPILE-FILE 2404 . 8967) (INTERLISP-FORMAT-P 8969 . 9191) (
+INTERLISP-NLAMBDA-FUNCTION-P 9193 . 9429) (COMPILE-FILE-EXPRESSION 9431 . 15709) (
+COMPILE-FILE-WALK-FUNCTION 15711 . 15960) (ARGTYPE.STATE 15962 . 16124) (COMPILE.CHECK.ARGTYPE 16126
+ . 18118) (COMPILE.FILE.DEFINEQ 18120 . 18615) (COMPILE-FILE-SETF-SYMBOL-FUNCTION 18617 . 19227) (
+COMPILE-FILE-EX/IMPORT 19229 . 19557) (COMPILE.FILE.APPLY 19559 . 19921) (COMPILE.FILE.RESET 19923 . 
+20784) (COMPILE-IN-CORE 20786 . 23382)) (23385 27623 (COMPILE-FILE-SCAN-FIRST 23395 . 27621)) (29617 
+30683 (NEWDEFC 29627 . 30681)))))
+STOP
diff --git a/CLTL2/CMLCOMPILE.LCOM b/CLTL2/CMLCOMPILE.LCOM
new file mode 100644
index 00000000..e4a8ee71
Binary files /dev/null and b/CLTL2/CMLCOMPILE.LCOM differ
diff --git a/CLTL2/CMLDEFFER b/CLTL2/CMLDEFFER
new file mode 100644
index 00000000..d4c2e7c2
--- /dev/null
+++ b/CLTL2/CMLDEFFER
@@ -0,0 +1,248 @@
+(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
diff --git a/CLTL2/CMLDEFFER.DFASL b/CLTL2/CMLDEFFER.DFASL
new file mode 100644
index 00000000..681c262e
Binary files /dev/null and b/CLTL2/CMLDEFFER.DFASL differ
diff --git a/CLTL2/CMLDEFFER.~2~ b/CLTL2/CMLDEFFER.~2~
new file mode 100644
index 00000000..d4c2e7c2
--- /dev/null
+++ b/CLTL2/CMLDEFFER.~2~
@@ -0,0 +1,248 @@
+(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
diff --git a/CLTL2/CMLDOC b/CLTL2/CMLDOC
new file mode 100644
index 00000000..b38c1695
--- /dev/null
+++ b/CLTL2/CMLDOC
@@ -0,0 +1,81 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 10:41:09" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLDOC.;2" 3493   
+
+      previous date%: "14-Apr-92 20:18:56" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLDOC.;1")
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLDOCCOMS)
+
+(RPAQQ CMLDOCCOMS (
+
+(* ;;; "Documentation strings")
+
+                       (VARIABLES *DOCUMENTATION-HASH-TABLE*)
+                       (FUNCTIONS LISP:DOCUMENTATION HASH-TABLE-FOR-DOC-TYPE SET-DOCUMENTATION)
+                       (SETFS LISP:DOCUMENTATION)
+                       
+                       (* ;; "Use the proper compiler")
+
+                       (PROP FILETYPE CMLDOC)))
+
+
+
+(* ;;; "Documentation strings")
+
+
+(DEFGLOBALVAR *DOCUMENTATION-HASH-TABLE*
+
+(* ;;; "This is the repository for all documentation strings in the system.  It is a two-level hash-table scheme, just like *definition-hash-table*.  At the first level, *DOCUMENTATION-HASH-TABLE* maps the symbols that name documentation-types into a separate hash table for each type.  Those tables map names into the documentation strings for those names.  The first-level table uses an EQ test while the second-level ones use CL:EQUAL.")
+
+   (* ;; "The hash-table is initialized to have second-level tables for each of the required documentation types.")
+
+   (LET ((LISP::HT (LISP:MAKE-HASH-TABLE :TEST 'EQ :SIZE 10 :REHASH-SIZE 5)))
+        [FOR TYPE-LIST IN '((TYPES TYPE)
+                                    (SETFS LISP:SETF)
+                                    (STRUCTURES LISP:STRUCTURE RECORD RECORDS)
+                                    (FUNCTIONS LISP:FUNCTION FN FNS)
+                                    (VARIABLES LISP:VARIABLE VAR VARS))
+           DO (LET ((TABLE (LISP:MAKE-HASH-TABLE :TEST 'LISP:EQUAL :SIZE 50 :REHASH-SIZE 50)))
+                       (FOR TYPE IN TYPE-LIST DO (LISP:SETF (LISP:GETHASH TYPE LISP::HT)
+                                                                    TABLE]
+        LISP::HT))
+
+(LISP:DEFUN LISP:DOCUMENTATION (NAME DOC-TYPE)
+   (GETHASH NAME (HASH-TABLE-FOR-DOC-TYPE DOC-TYPE)))
+
+(LISP:DEFUN HASH-TABLE-FOR-DOC-TYPE (DOC-TYPE)
+   (OR (GETHASH DOC-TYPE *DOCUMENTATION-HASH-TABLE*)
+       (AND FILEPKGFLG (GETHASH (SETQ DOC-TYPE (GETFILEPKGTYPE DOC-TYPE 'TYPE))
+
+                              (* ;; 
+                  "note that GETFILEPKGTYPE will signal an error if it doesn't recognize the type.")
+
+                              *DOCUMENTATION-HASH-TABLE*))
+       (LISP:SETF (GETHASH DOC-TYPE *DOCUMENTATION-HASH-TABLE*)
+              (LISP:MAKE-HASH-TABLE :TEST 'LISP:EQUAL :SIZE 50 :REHASH-SIZE 50))))
+
+(LISP:DEFUN SET-DOCUMENTATION (NAME DOC-TYPE NEW-STRING) (* ; "Edited 14-Apr-92 20:16 by jrb:")
+   (LISP:CHECK-TYPE NEW-STRING (OR (EQL NIL)
+                                   STRING))
+   (LISP:IF LISPXHIST
+       (UNDOABLY-SETF (GETHASH NAME (HASH-TABLE-FOR-DOC-TYPE DOC-TYPE))
+              NEW-STRING)
+       (LISP:SETF (GETHASH NAME (HASH-TABLE-FOR-DOC-TYPE DOC-TYPE))
+              NEW-STRING)))
+
+(LISP:DEFSETF LISP:DOCUMENTATION SET-DOCUMENTATION)
+
+
+
+(* ;; "Use the proper compiler")
+
+
+(PUTPROPS CMLDOC FILETYPE LISP:COMPILE-FILE)
+(PUTPROPS CMLDOC COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/CLTL2/CMLDOC.LCOM b/CLTL2/CMLDOC.LCOM
new file mode 100644
index 00000000..2bcc3ad2
Binary files /dev/null and b/CLTL2/CMLDOC.LCOM differ
diff --git a/CLTL2/CMLEVAL b/CLTL2/CMLEVAL
new file mode 100644
index 00000000..2aa353da
--- /dev/null
+++ b/CLTL2/CMLEVAL
@@ -0,0 +1,2174 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
+(FILECREATED "18-Oct-93 10:51:39" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLEVAL.;2" 113967 
+
+      |previous| |date:| "30-Mar-92 14:31:25" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLEVAL.;1")
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT CMLEVALCOMS)
+
+(RPAQQ CMLEVALCOMS
+       (
+
+(* |;;;| "Common Lisp interpreter")
+
+        (COMS 
+              (* |;;| "These  really don't belong here")
+
+              (FUNCTIONS LISP:EQUAL LISP:EQUALP)
+              
+              (* |;;| 
+            "For the byte compiler: Optimize by constant fold and coerce to EQ where possible")
+
+              (PROP BYTEMACRO LISP:EQUAL LISP:EQUALP)
+              (PROP DOPVAL LISP:EQUAL))
+        (COMS (FUNCTIONS \\REMOVE-DECLS)
+              (FUNCTIONS LISP:SPECIAL-FORM-P))
+        (COMS (SPECIAL-FORMS INTERLISP)
+              (PROP DMACRO INTERLISP COMMON-LISP)
+              (FNS COMMON-LISP))
+        (COMS (ADDVARS (LAMBDASPLST LISP:LAMBDA))
+              (FNS \\TRANSLATE-CL\:LAMBDA)
+              (VARIABLES *CHECK-ARGUMENT-COUNTS* *SPECIAL-BINDING-MARK*))
+        (VARIABLES LISP:LAMBDA-LIST-KEYWORDS LISP:CALL-ARGUMENTS-LIMIT LISP:LAMBDA-PARAMETERS-LIMIT)
+        (STRUCTURES CLOSURE ENVIRONMENT)
+        (FUNCTIONS \\MAKE-CHILD-ENVIRONMENT)
+        (COMS (FNS LISP:EVAL \\EVAL-INVOKE-LAMBDA \\INTERPRET-ARGUMENTS \\INTERPRETER-LAMBDA 
+                   CHECK-BINDABLE CHECK-KEYWORDS)
+              (FUNCTIONS ARG-REF)
+              (PROP DMACRO .COMPILER-SPREAD-ARGUMENTS.))
+        (FNS DECLARED-SPECIAL)
+        (COMS                                                (* \; 
+                                                   "FUNCALL and APPLY, not quite same as Interlisp")
+              (FNS LISP:FUNCALL LISP:APPLY)
+              (PROP DMACRO LISP:APPLY LISP:FUNCALL))
+        (COMS                                                (* \; 
+                                  "COMPILER-LET needs to work differently compiled and interpreted")
+              (FNS LISP:COMPILER-LET COMP.COMPILER-LET)
+              (PROP DMACRO LISP:COMPILER-LET)
+              (SPECIAL-FORMS LISP:COMPILER-LET))
+        (COMS                                                (* \; 
+                           "Lexical function- and macro-binding forms: FLET, LABELS, and MACROLET.")
+              (SPECIAL-FORMS LISP:MACROLET LISP:FLET LISP:LABELS))
+        (SPECIAL-FORMS QUOTE)
+        (COMS (SPECIAL-FORMS THE)
+              (PROP DMACRO THE))
+        (COMS (PROP DMACRO LISP:EVAL-WHEN)
+              (FNS LISP:EVAL-WHEN)
+              (SPECIAL-FORMS LISP:EVAL-WHEN))
+        (COMS (SPECIAL-FORMS DECLARE)
+              (FUNCTIONS LISP:LOCALLY LISP:LOCALLY))
+        (COMS                                                (* \; "Interlisp version on LLINTERP")
+              (SPECIAL-FORMS PROGN)
+              (FNS \\EVAL-PROGN))
+        (COMS                                                (* \; 
+              "Confused because currently Interlisp special form, fixing MACRO-FUNCTION is complex")
+                                                             (* \; 
+                                                           "The Interlisp function is on LLINTERP")
+              (SPECIAL-FORMS PROG1)
+              (FUNCTIONS PROG1))
+        (COMS (SPECIAL-FORMS LET* LET)
+              (PROP MACRO LET LET*)
+              (FNS \\LET*-RECURSION |\\LETtran|))
+        (COMS (SPECIAL-FORMS COND)
+              (FUNCTIONS COND))
+        (COMS (FNS LISP:IF)
+              (SPECIAL-FORMS LISP:IF)
+              (PROP DMACRO LISP:IF))
+        (COMS                                                (* \; 
+                                                        "Interlisp NLAMBDA definitions on LLINTERP")
+                                                             (* \; "both special form and macro")
+              (FUNCTIONS AND OR)
+              (SPECIAL-FORMS AND OR))
+        (COMS                                                (* \; "BLOCK and RETURN go together")
+              (FNS LISP:BLOCK)
+              (PROP DMACRO LISP:BLOCK)
+              (SPECIAL-FORMS LISP:BLOCK)
+              (FUNCTIONS RETURN)
+              (FNS LISP:RETURN-FROM)
+              (SPECIAL-FORMS LISP:RETURN-FROM))
+        (COMS                                                (* \; 
+                                                           "IL and CL versions of FUNCTION.")
+              (FNS LISP:FUNCTION)
+              (PROP DMACRO LISP:FUNCTION)
+              (SPECIAL-FORMS FUNCTION LISP:FUNCTION)
+              (FUNCTIONS LISP:FUNCTIONP LISP:COMPILED-FUNCTION-P))
+        (SPECIAL-FORMS LISP:MULTIPLE-VALUE-CALL LISP:MULTIPLE-VALUE-PROG1)
+        (FNS COMP.CL-EVAL)
+        (FUNCTIONS LISP:EVALHOOK LISP:APPLYHOOK)
+        (VARIABLES *EVALHOOK* *APPLYHOOK* LISP::*SKIP-EVALHOOK* LISP::*SKIP-APPLYHOOK*)
+        (COMS                                                (* \; "CONSTANTS mechanism")
+              (FNS LISP:CONSTANTP)
+              (SETFS LISP:CONSTANTP)
+              (FUNCTIONS XCL::SET-CONSTANTP))
+        (COMS                                                (* \; 
+                                                    "Interlisp SETQ for Common Lisp and vice versa")
+              (SPECIAL-FORMS LISP:SETQ SETQ)
+              (PROP DMACRO LISP:SETQ)
+              
+              (* |;;| 
+            "An nlambda definition for cl:setq so cmldeffer may use cl:setq will run in the init")
+
+              (FNS LISP:SETQ)
+              (FUNCTIONS SETQ)
+              (FNS SET-SYMBOL)
+              (FUNCTIONS LISP:PSETQ)
+              (FUNCTIONS SETQQ))
+        (COMS (SPECIAL-FORMS LISP:CATCH LISP:THROW LISP:UNWIND-PROTECT)
+              (FNS LISP:THROW LISP:CATCH LISP:UNWIND-PROTECT))
+        (COMS (FUNCTIONS PROG PROG*)
+              (SPECIAL-FORMS GO LISP:TAGBODY)
+              (FNS LISP:TAGBODY))
+        (COMS                                                (* \; "for macro caching")
+              (FNS CACHEMACRO)
+              (VARIABLES *MACROEXPAND-HOOK*)
+              (VARS (*IN-COMPILER-LET* NIL)))
+        (COMS 
+              (* |;;| "PROCLAIM and friends.")
+
+              
+              (* |;;| "Needs to come first because DEFVARs put it out.  With package code in the init, also need this here rather than CMLEVAL")
+
+              (FUNCTIONS LISP:PROCLAIM)
+                                                             (* \; "used by the codewalker, too")
+              (MACROS VARIABLE-GLOBALLY-SPECIAL-P VARIABLE-GLOBAL-P)
+              (FUNCTIONS XCL::DECL-SPECIFIER-P XCL::SET-DECL-SPECIFIER-P)
+              (FUNCTIONS XCL::GLOBALLY-NOTINLINE-P XCL::SET-GLOBALLY-NOTINLINE-P)
+              (SETFS XCL::DECL-SPECIFIER-P XCL::GLOBALLY-NOTINLINE-P)
+              (PROP PROPTYPE GLOBALLY-SPECIAL GLOBALVAR SI::DECLARATION-SPECIFIER 
+                    SI::GLOBALLY-NOTINLINE SPECIAL-FORM)
+              (FUNCTIONS LISP:DECLAIM)
+              
+              (* |;;| 
+      "This proclamation is here to shut DECLARE up about CLtL2 declarations that we ignore anyway")
+
+              
+              (* |;;| "We don't need one of these for (OPTIMIZE DEBUG) since we throw all OPTIMIZE declarations away already")
+
+              (P (LISP:PROCLAIM '(LISP:DECLARATION DYNAMIC-EXTENT))))
+        (PROP (FILETYPE MAKEFILE-ENVIRONMENT)
+              CMLEVAL)
+        (DECLARE\: EVAL@COMPILE DONTCOPY (OPTIMIZERS CL-EVAL-FN3-CALL))
+        (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
+        (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA LISP:TAGBODY LISP:UNWIND-PROTECT LISP:CATCH LISP:SETQ LISP:BLOCK 
+                               LISP:EVAL-WHEN LISP:COMPILER-LET COMMON-LISP)
+                      (NLAML LISP:THROW LISP:FUNCTION LISP:RETURN-FROM LISP:IF)
+                      (LAMA LISP:APPLY LISP:FUNCALL)))))
+
+
+
+(* |;;;| "Common Lisp interpreter")
+
+
+
+
+(* |;;| "These  really don't belong here")
+
+
+(LISP:DEFUN LISP:EQUAL (LISP::X LISP::Y)
+   (LISP:TYPECASE LISP::X
+       (LISP:SYMBOL (EQ LISP::X LISP::Y))
+       (LISP:NUMBER (EQL LISP::X LISP::Y))
+       (CONS (AND (LISP:CONSP LISP::Y)
+                    (LISP:EQUAL (CAR LISP::X)
+                           (CAR LISP::Y))
+                    (LISP:EQUAL (CDR LISP::X)
+                           (CDR LISP::Y))))
+       (STRING (AND (LISP:STRINGP LISP::Y)
+                      (LISP:STRING= LISP::X LISP::Y)))
+       (LISP:BIT-VECTOR (AND (LISP:BIT-VECTOR-P LISP::Y)
+                               (LET ((LISP::SX (LISP:LENGTH LISP::X)))
+                                    (AND (EQL LISP::SX (LISP:LENGTH LISP::Y))
+                                           (LISP:DOTIMES (LISP::I LISP::SX T)
+                                               (LISP:IF (NOT (EQ (BIT LISP::X LISP::I)
+                                                                     (BIT LISP::Y LISP::I)))
+                                                      (RETURN NIL)))))))
+       (PATHNAME (AND (LISP:PATHNAMEP LISP::Y)
+                        (%PATHNAME-EQUAL LISP::X LISP::Y)))
+       (T (EQ LISP::X LISP::Y))))
+
+(LISP:DEFUN LISP:EQUALP (LISP::X LISP::Y)                (* \; "Edited 23-Mar-92 14:07 by jrb:")
+   (OR (EQ LISP::X LISP::Y)
+          (LISP:TYPECASE LISP::X
+              (LISP:SYMBOL NIL)
+              (LISP:NUMBER (AND (LISP:NUMBERP LISP::Y)
+                                  (= LISP::X LISP::Y)))
+              (CONS (AND (LISP:CONSP LISP::Y)
+                           (LISP:EQUALP (CAR LISP::X)
+                                  (CAR LISP::Y))
+                           (LISP:EQUALP (CDR LISP::X)
+                                  (CDR LISP::Y))))
+              (LISP:CHARACTER (AND (LISP:CHARACTERP LISP::Y)
+                                     (LISP:CHAR-EQUAL LISP::X LISP::Y)))
+              (STRING (AND (LISP:STRINGP LISP::Y)
+                             (STRING-EQUAL LISP::X LISP::Y)))
+              (PATHNAME (AND (LISP:PATHNAMEP LISP::Y)
+                               (%PATHNAME-EQUAL LISP::X LISP::Y)))
+              (LISP:VECTOR (AND (LISP:VECTORP LISP::Y)
+                                  (LET ((LISP::SX (LISP:LENGTH LISP::X)))
+                                       (AND (EQL LISP::SX (LISP:LENGTH LISP::Y))
+                                              (LISP:DOTIMES (LISP::I LISP::SX T)
+                                                  (LISP:IF (NOT (LISP:EQUALP (LISP:AREF
+                                                                                      LISP::X LISP::I
+                                                                                      )
+                                                                           (LISP:AREF LISP::Y LISP::I
+                                                                                  )))
+                                                         (RETURN NIL)))))))
+              (LISP:ARRAY (AND (LISP:ARRAYP LISP::Y)
+                                 (LISP:EQUAL (LISP:ARRAY-DIMENSIONS LISP::X)
+                                        (LISP:ARRAY-DIMENSIONS LISP::Y))
+                                 (LET ((LISP::FX (%FLATTEN-ARRAY LISP::X))
+                                       (LISP::FY (%FLATTEN-ARRAY LISP::Y)))
+                                      (LISP:DOTIMES (LISP::I (LISP:ARRAY-TOTAL-SIZE LISP::X)
+                                                           T)
+                                          (LISP:IF (NOT (LISP:EQUALP (LISP:AREF LISP::FX 
+                                                                                    LISP::I)
+                                                                   (LISP:AREF LISP::FY LISP::I)))
+                                                 (RETURN NIL))))))
+              (LISP:HASH-TABLE (AND (LISP:HASH-TABLE-P LISP::Y)
+                                      (EQ (LISP:HASH-TABLE-TEST LISP::X)
+                                          (LISP:HASH-TABLE-TEST LISP::Y))
+                                      (= (HARRAYPROP LISP::X 'NUMKEYS)
+                                         (HARRAYPROP LISP::Y 'NUMKEYS))
+                                      (LISP:CATCH 'LISP::HASH-TABLE-CHECK
+                                          (LISP:MAPHASH
+                                           #'(LISP:LAMBDA (LISP::K LISP::V)
+                                                    (LISP:UNLESS (LISP:EQUALP (LISP:GETHASH
+                                                                                   LISP::K LISP::Y
+                                                                                   'DEFAULT)
+                                                                        LISP::V)
+                                                        (LISP:THROW 'LISP::HASH-TABLE-CHECK NIL
+                                                               )))
+                                           LISP::X)
+                                          T)))
+              (T 
+                 (* |;;| "so that datatypes will be properly compared")
+
+                 (LET ((LISP::TYPENAME (TYPENAME LISP::X)))
+                      (AND (EQ LISP::TYPENAME (TYPENAME LISP::Y))
+                             (LET ((LISP::DESCRIPTORS (GETDESCRIPTORS LISP::TYPENAME)))
+                                  (LISP:IF LISP::DESCRIPTORS
+                                      (FOR LISP::FIELD IN LISP::DESCRIPTORS
+                                         ALWAYS (LISP:EQUALP (FETCHFIELD LISP::FIELD LISP::X)
+                                                           (FETCHFIELD LISP::FIELD LISP::Y)))))))))))
+
+
+
+(* |;;| "For the byte compiler: Optimize by constant fold and coerce to EQ where possible")
+
+
+(PUTPROPS LISP:EQUAL BYTEMACRO COMP.EQ)
+
+(PUTPROPS LISP:EQUALP BYTEMACRO COMP.EQ)
+
+(PUTPROPS LISP:EQUAL DOPVAL (2 CMLEQUAL))
+
+(LISP:DEFUN \\REMOVE-DECLS (LISP::BODY LISP::ENVIRONMENT)
+
+(* |;;;| "This is like parse-body, except that it returns the body and  a list of specials declared in this frame.  It side-effects the environment to mark the specials.")
+
+   (PROG ((LISP::SPECIALS NIL)
+              LISP::FORM)
+         LISP::NEXT-FORM
+             (LISP:IF (NULL LISP::BODY)
+                    (GO LISP::DONE))
+             (LISP:SETQ LISP::FORM (CAR LISP::BODY))
+         LISP::RETRY-FORM
+             (COND
+                ((OR (LISP:ATOM LISP::FORM)
+                        (NOT (LISP:SYMBOLP (CAR LISP::FORM))))
+                 (GO LISP::DONE))
+                ((EQ (CAR LISP::FORM)
+                     'DECLARE)
+                 (LISP:MAPC #'(LISP:LAMBDA (LISP:DECLARATION)
+                                     (LISP:WHEN (LISP:CONSP LISP:DECLARATION)
+                                         (LISP:WHEN (OR (EQ (CAR LISP:DECLARATION)
+                                                                'LISP:SPECIAL)
+                                                           (EQ (CAR LISP:DECLARATION)
+                                                               'SPECVARS))
+                                             (LISP:IF (EQ (CDR LISP:DECLARATION)
+                                                          T)
+
+                                 (* |;;| "(specvars . t) refers to all variables inside this scope, not just those bound in this frame.  So handling (specvars . t) by declaring the variables in this frame special would not be correct. Hence print a warning and continue.")
+
+                                                 (LISP:WARN 
+                                               "(IL:SPECVARS . T) has no effect in the CL evaluator."
+                                                        )
+                                                 (LISP:MAPC #'(LISP:LAMBDA (LISP::NAME)
+                                                                     (LISP:PUSH LISP::NAME 
+                                                                            LISP::SPECIALS))
+                                                        (CDR LISP:DECLARATION))))))
+                        (CDR LISP::FORM))
+                 (LISP:POP LISP::BODY)
+                 (GO LISP::NEXT-FORM))
+                ((LISP:SPECIAL-FORM-P (CAR LISP::FORM))
+                 (GO LISP::DONE))
+                (T (LET ((LISP::NEW-FORM (LISP:MACROEXPAND-1 LISP::FORM LISP::ENVIRONMENT)))
+                        (COND
+                           ((AND (NOT (EQ LISP::NEW-FORM LISP::FORM))
+                                   (LISP:CONSP LISP::NEW-FORM))
+                            (LISP:SETQ LISP::FORM LISP::NEW-FORM)
+                            (GO LISP::RETRY-FORM))
+                           (T (GO LISP::DONE))))))
+         LISP::DONE
+             (RETURN (LISP:IF LISP::SPECIALS
+                             (PROGN (FOR LISP::VAR IN LISP::SPECIALS
+                                       DO (LISP:SETF (ENVIRONMENT-VARS LISP::ENVIRONMENT)
+                                                     (LIST* LISP::VAR *SPECIAL-BINDING-MARK*
+                                                            (ENVIRONMENT-VARS LISP::ENVIRONMENT))))
+                                    (LISP:VALUES LISP::BODY LISP::SPECIALS))
+                             LISP::BODY))))
+
+(LISP:DEFUN LISP:SPECIAL-FORM-P (LISP::X)
+   (GET LISP::X 'SPECIAL-FORM))
+
+(DEFINE-SPECIAL-FORM INTERLISP PROGN)
+
+(PUTPROPS INTERLISP DMACRO ((X . Y)
+                                    (PROGN X . Y)))
+
+(PUTPROPS COMMON-LISP DMACRO ((X)
+                                      X))
+(DEFINEQ
+
+(COMMON-LISP
+  (NLAMBDA COMMON-LISP-FORMS                                 (* \; 
+                                                           "Edited 12-Feb-87 20:24 by Pavel")
+    (\\EVAL-PROGN COMMON-LISP-FORMS NIL)))
+)
+
+(ADDTOVAR LAMBDASPLST LISP:LAMBDA)
+(DEFINEQ
+
+(\\TRANSLATE-CL\:LAMBDA
+  (LAMBDA (EXPR)                                             (* \; 
+                                                           "Edited 13-Feb-87 23:20 by Pavel")
+    (LET
+     (VRBLS KEYVARS OPTVARS AUXLIST RESTFORM VARTYP BODY KEYWORDS (CNT 1)
+            (MIN 0)
+            (MAX 0)
+            DECLS
+            (SIMPLEP T))
+     (|for| BINDING VAR |in| (CAR (CDR EXPR))
+        |do|
+        (SELECTQ BINDING
+            ((&REST &BODY) 
+                 (SETQ VARTYP '&REST))
+            (&OPTIONAL (SETQ VARTYP BINDING))
+            (&AUX (SETQ VARTYP BINDING))
+            (&ALLOW-OTHER-KEYS 
+                 (OR (EQ VARTYP '&KEY)
+                        (ERROR "&ALLOW-OTHER-KEYS not in &KEY")))
+            (&KEY (SETQ VARTYP '&KEY))
+            (SELECTQ VARTYP
+                (NIL "required" (|push| VRBLS BINDING)
+                             (|add| CNT 1)
+                             (|add| MIN 1)
+                             (|add| MAX 1)
+                             (AND *CHECK-ARGUMENT-COUNTS* (SETQ SIMPLEP NIL)))
+                (&REST (SETQ RESTFORM `((,BINDING (|for| I |from| ,CNT |to| |-args-|
+                                                         |collect| (ARG |-args-| I)))))
+                       (SETQ MAX NIL)
+                       (SETQ SIMPLEP NIL))
+                (&AUX (|push| AUXLIST BINDING))
+                (&KEY (LET*
+                       (SVAR (INIT (COND
+                                      ((LISTP BINDING)
+                                       (PROG1 (CADR BINDING)
+                                           (SETQ SVAR (CADDR BINDING))
+                                           (SETQ BINDING (CAR BINDING))))))
+                             (KEY (COND
+                                     ((LISTP BINDING)
+                                      (PROG1 (CAR BINDING)
+                                          (SETQ BINDING (CADR BINDING))))
+                                     (T (MAKE-KEYWORD BINDING)))))
+                       (COND
+                          (SVAR (|push| KEYVARS (LIST SVAR T))))
+                       (|push|
+                        KEYVARS
+                        (LIST BINDING
+                              `(|for| \\INDEX |from| ,CNT |to| |-args-| |by| 2
+                                  |when| (EQ (ARG |-args-| \\INDEX)
+                                                 ,KEY) |do| (RETURN (ARG |-args-|
+                                                                                 (ADD1 \\INDEX)))
+                                  |finally| (RETURN
+                                                 ,(COND
+                                                     (SVAR `(PROGN (SETQ ,SVAR NIL)
+                                                                   ,INIT))
+                                                     (T INIT)))))))
+                      (SETQ MAX NIL)
+                      (SETQ SIMPLEP NIL))
+                (&OPTIONAL (OR (LISTP BINDING)
+                                  (SETQ BINDING (LIST BINDING)))
+                           (LET ((SVAR (CADDR BINDING)))
+                                (LISP:WHEN SVAR
+                                    (|push| OPTVARS SVAR)
+                                    (SETQ SIMPLEP NIL))
+                                (LISP:WHEN (CADR BINDING)
+                                       (SETQ SIMPLEP NIL))
+                                (|push| OPTVARS
+                                       `(,(CAR BINDING)
+                                         (COND
+                                            ((IGREATERP ,CNT |-args-|)
+                                             ,(CADR BINDING))
+                                            (T ,@(COND
+                                                    (SVAR `((SETQ ,SVAR T))))
+                                               (ARG |-args-| ,CNT))))))
+                           (AND MAX (|add| MAX 1))
+                           (|add| CNT 1))
+                (SHOULDNT))))
+     (LISP:MULTIPLE-VALUE-SETQ (BODY DECLS)
+            (PARSE-BODY (CDR (CDR EXPR))
+                   NIL))
+     (LISP:IF SIMPLEP
+         `(,'LAMBDA (,@(REVERSE VRBLS)
+                     ,@(MAPCAR (REVERSE OPTVARS)
+                              (FUNCTION CAR)))
+            (DECLARE (LOCALVARS . T))
+            ,@DECLS
+            (,'LET* (,@(REVERSE AUXLIST))
+                   ,@DECLS
+                   ,@BODY))
+         `(LAMBDA |-args-|
+            (DECLARE (LOCALVARS . T))
+            ,@(COND
+                 ((AND *CHECK-ARGUMENT-COUNTS* MIN (NEQ MIN 0))
+                  `((COND
+                       ((ILESSP ,'|-args-| ,MIN)
+                        (ERROR "Too few args" ,'|-args-|))))))
+            ,@(COND
+                 ((AND *CHECK-ARGUMENT-COUNTS* MAX)
+                  `((COND
+                       ((IGREATERP ,'|-args-| ,MAX)
+                        (ERROR "Too many args" ,'|-args-|))))))
+            (,'LET* (,@(|for| VAR |in| (REVERSE VRBLS) |as| I |from| 1
+                          |collect| (LIST VAR `(ARG |-args-| ,I)))
+                     ,@(REVERSE OPTVARS)
+                     ,@(REVERSE KEYVARS)
+                     ,@RESTFORM
+                     ,@(REVERSE AUXLIST))
+                   ,@DECLS
+                   ,@BODY))))))
+)
+
+(LISP:DEFPARAMETER *CHECK-ARGUMENT-COUNTS* NIL)
+
+(DEFGLOBALVAR *SPECIAL-BINDING-MARK* 
+   "Variable specially bound. This string should never be visible")
+
+(LISP:DEFCONSTANT LISP:LAMBDA-LIST-KEYWORDS '(&OPTIONAL &REST &KEY &AUX &BODY &WHOLE 
+                                                        &ALLOW-OTHER-KEYS &ENVIRONMENT &CONTEXT))
+
+(LISP:DEFCONSTANT LISP:CALL-ARGUMENTS-LIMIT 512)
+
+(LISP:DEFCONSTANT LISP:LAMBDA-PARAMETERS-LIMIT 512)
+
+(LISP:DEFSTRUCT (CLOSURE (:PRINT-FUNCTION (LAMBDA (CLOSURE STREAM)
+                                                (LET ((*PRINT-RADIX* NIL))
+                                                     (LISP:FORMAT STREAM 
+                                                            "#<Interpreted closure @ ~O,~O>"
+                                                            (\\HILOC CLOSURE)
+                                                            (\\LOLOC CLOSURE))))))
+
+(* |;;;| "An interpreted lexical closure.  Contains the function and an environment object.")
+
+   FUNCTION
+   ENVIRONMENT)
+
+(LISP:DEFSTRUCT (ENVIRONMENT (:CONSTRUCTOR \\MAKE-ENVIRONMENT NIL)
+                                 (:COPIER \\COPY-ENVIRONMENT)
+                                 (:PRINT-FUNCTION (LAMBDA (ENV STREAM DEPTH)
+                                                    (DECLARE (IGNORE DEPTH))
+                                                    (LET ((*PRINT-RADIX* NIL))
+                                                         (LISP:FORMAT STREAM 
+                                                                "#<Lexical Environment @ ~O,~O>"
+                                                                (\\HILOC ENV)
+                                                                (\\LOLOC ENV))))))
+
+(* |;;;| "An environment used by the Common Lisp interpreter.  Every environment contains all of the information of its parents.  That is, new child environments are made by copying the parent and then pushing new data onto one of the fields.  This makes certain tests very fast.")
+
+   (* |;;| "Lexically-bound or -declared variables.  A property list mapping names into either *SPECIAL-BINDING-MARK* or their values.")
+
+   VARS
+
+   (* |;;| "Lexical functions and macros.  A property list mapping names into either (:function . fn) or (:macro . expansion-fn).")
+
+   FUNCTIONS
+
+   (* |;;| "A property list mapping block names into unique blips.  RETURN-FROMs can throw to the appropriate blip.")
+
+   BLOCKS
+
+   (* |;;| "A property list mapping TAGBODY bodies into unique blips.  GOs throw the correct tail of the body to the blip.")
+
+   TAGBODIES)
+
+(DEFMACRO \\MAKE-CHILD-ENVIRONMENT (PARENT &KEY ((:BLOCK (BLOCK-NAME BLOCK-BLIP))
+                                                     NIL BLOCK-P)
+                                              ((:TAGBODY (TAGBODY-TAIL TAGBODY-BLIP))
+                                               NIL TAGBODY-P))
+   `(LET* (($$PARENT ,PARENT)
+           ($$NEW-ENV (LISP:IF $$PARENT
+                          (\\COPY-ENVIRONMENT $$PARENT)
+                          (\\MAKE-ENVIRONMENT))))
+          ,@(AND BLOCK-P `((LISP:SETF (ENVIRONMENT-BLOCKS $$NEW-ENV)
+                                      (LIST* ,BLOCK-NAME ,BLOCK-BLIP (ENVIRONMENT-BLOCKS $$NEW-ENV)))
+                               ))
+          ,@(AND TAGBODY-P `((LISP:SETF (ENVIRONMENT-TAGBODIES $$NEW-ENV)
+                                        (LIST* ,TAGBODY-TAIL ,TAGBODY-BLIP (ENVIRONMENT-TAGBODIES
+                                                                            $$NEW-ENV)))))
+          $$NEW-ENV))
+(DEFINEQ
+
+(LISP:EVAL
+  (LAMBDA (LISP::EXPRESSION LISP::ENVIRONMENT)               (* \; "Edited  7-Feb-91 20:42 by jds")
+
+    (* |;;| "This is in Interlisp and not a DEFUN to help avoid bootstrap death, although bootstrap death is quite possible anyway if, for example, any of the macros here are in Common Lisp and the macro definitions are interpreted.")
+
+    (DECLARE (LOCALVARS . T))
+    (COND
+       ((AND *EVALHOOK* (NOT (PROG1 LISP::*SKIP-EVALHOOK* (LISP:SETQ 
+                                                                         LISP::*SKIP-EVALHOOK* NIL)
+                                        )))
+        (LET ((LISP::HOOKFN *EVALHOOK*)
+              (*EVALHOOK* NIL))
+             (LISP:FUNCALL LISP::HOOKFN LISP::EXPRESSION LISP::ENVIRONMENT)))
+       (T
+        (LISP:TYPECASE LISP::EXPRESSION
+            (LISP:SYMBOL (COND
+                            ((NULL LISP::EXPRESSION)
+                             NIL)
+                            ((EQ LISP::EXPRESSION T)
+                             T)
+                            (T (LET (LISP::LOC LISP::VAL)
+                                    (LISP:BLOCK LISP::EVAL-VARIABLE
+                                        (LISP:WHEN LISP::ENVIRONMENT
+                                            (|for| LISP::TAIL |on| (ENVIRONMENT-VARS 
+                                                                                  LISP::ENVIRONMENT)
+                                               |by| (CDDR LISP::TAIL)
+                                               |when| (EQ LISP::EXPRESSION (CAR LISP::TAIL))
+                                               |do| (LISP:SETQ LISP::VAL (CADR LISP::TAIL))
+                                                     (|if| (EQ LISP::VAL *SPECIAL-BINDING-MARK*)
+                                                         |then| 
+
+                                                               (* |;;| 
+                                           "return from FOR loop, skipping to SPECIALS code below.")
+
+                                                               (RETURN NIL)
+                                                       |else| (LISP:RETURN-FROM 
+                                                                         LISP::EVAL-VARIABLE 
+                                                                         LISP::VAL))))
+
+                                        (* |;;| 
+                                     "following copied from \\EVALVAR in the Interlisp interpreter")
+
+                                        (SETQ LISP::LOC (\\STKSCAN LISP::EXPRESSION))
+                                        (COND
+                                           ((EQ (LISP:SETQ LISP::VAL (\\GETBASEPTR LISP::LOC 0))
+                                                'NOBIND)     (* \; 
+                                 "Value is NOBIND even if it was not found as the top-level value.")
+                                            (LISP:ERROR 'UNBOUND-VARIABLE :NAME LISP::EXPRESSION))
+                                           (T LISP::VAL)))))))
+            (CONS 
+               (COND
+                  ((LISP:CONSP (CAR LISP::EXPRESSION))
+                   (LET ((LISP::ARGCOUNT 1))
+
+                        (* |;;| "This is a very very awful hack for getting into internal lambda expressions  .COMPILER-SPREAD-ARGUMENTS. is handled specially by the compiler--it iterates over a list pushing things")
+
+                        (* |;;| "secondly, the (OPCODES) directly calls EVAL-INVOKE-LAMBDA with more args than are given, blowing away the following APPLYFN. Larry thought this level of hackery was important for performance.")
+
+                        (.COMPILER-SPREAD-ARGUMENTS. (CDR LISP::EXPRESSION)
+                               LISP::ARGCOUNT
+                               (CL-EVAL-FN3-CALL (CAR LISP::EXPRESSION)
+                                      LISP::ENVIRONMENT)
+                               ((LISP:EVAL LISP::ENVIRONMENT)))))
+                  (T (LET ((LISP::FN-DEFN (AND LISP::ENVIRONMENT (LISP:GETF (
+                                                                                ENVIRONMENT-FUNCTIONS
+                                                                                 LISP::ENVIRONMENT)
+                                                                            (CAR LISP::EXPRESSION))))
+                           )
+                          (COND
+                             ((NULL LISP::FN-DEFN)           (* \; 
+                                          "The normal case: the function is not lexically-defined.")
+                              (CASE (ARGTYPE (CAR LISP::EXPRESSION))
+                                  ((0 2) 
+
+                                     (* |;;| "has a Interlisp/CommonLisp lambda-spread definition")
+
+                                     (LISP:IF (AND *APPLYHOOK* (NOT (PROG1 
+                                                                               LISP::*SKIP-APPLYHOOK*
+                                                                               (LISP:SETQ 
+                                                                               LISP::*SKIP-APPLYHOOK*
+                                                                                      NIL))))
+                                         (LET* ((LISP::ARGS (LISP:MAPCAR #'(LISP:LAMBDA (LISP::ARG)
+                                                                                  (LISP:EVAL
+                                                                                   LISP::ARG 
+                                                                                   LISP::ENVIRONMENT)
+                                                                                  )
+                                                                   (CDR LISP::EXPRESSION)))
+                                                (LISP::HOOKFN *APPLYHOOK*)
+                                                (*APPLYHOOK* NIL))
+                                               (LISP:FUNCALL LISP::HOOKFN (CAR LISP::EXPRESSION)
+                                                      LISP::ARGS LISP::ENVIRONMENT))
+                                         (LET ((LISP::ARGCOUNT 0))
+                                              (.COMPILER-SPREAD-ARGUMENTS. (CDR LISP::EXPRESSION)
+                                                     LISP::ARGCOUNT
+                                                     (CAR LISP::EXPRESSION)
+                                                     ((LISP:EVAL LISP::ENVIRONMENT))))))
+                                  (T 
+                                     (* |;;| 
+                                   "in Common Lisp, special form overrides nlambda definition")
+
+                                     (* |;;| "note that the GET will error if not a symbol. ")
+
+                                     (LET ((LISP::TEMP (GET (CAR LISP::EXPRESSION)
+                                                            'SPECIAL-FORM)))
+                                          (COND
+                                             (LISP::TEMP     (* \; 
+                                                           "CAR is the name of a special form.")
+                                                    (LISP:FUNCALL LISP::TEMP (CDR 
+                                                                                     LISP::EXPRESSION
+                                                                                      )
+                                                           LISP::ENVIRONMENT))
+                                             ((LISP:SETQ LISP::TEMP (LISP:MACRO-FUNCTION
+                                                                         (CAR LISP::EXPRESSION)))
+                                                             (* \; "CAR is the name of a macro")
+                                              (LISP:EVAL (LISP:FUNCALL LISP::TEMP 
+                                                                    LISP::EXPRESSION 
+                                                                    LISP::ENVIRONMENT)
+                                                     LISP::ENVIRONMENT))
+                                             (T (ERROR "Undefined car of form" (CAR LISP::EXPRESSION)
+                                                       )))))))
+                             ((EQ (CAR LISP::FN-DEFN)
+                                  :MACRO)                    (* \; "A use of a lexical macro.")
+                              (LISP:EVAL (LISP:FUNCALL (CDR LISP::FN-DEFN)
+                                                    LISP::EXPRESSION LISP::ENVIRONMENT)
+                                     LISP::ENVIRONMENT))
+                             (T                              (* \; "A call to a lexical function")
+                                (LET ((LISP::ARGCOUNT 0))
+                                     (.COMPILER-SPREAD-ARGUMENTS. (CDR LISP::EXPRESSION)
+                                            LISP::ARGCOUNT
+                                            (CDR LISP::FN-DEFN)
+                                            ((LISP:EVAL LISP::ENVIRONMENT))))))))))
+            (T 
+               (* |;;| "CLtL2 says all CLtL objects except symbols and lists are self-evaluating; I'm extending that to all objects (including Interlisp thingies).")
+
+               LISP::EXPRESSION))))))
+
+(\\EVAL-INVOKE-LAMBDA
+  (LAMBDA (N LAM ENV)
+    (DECLARE (LOCALVARS . T))                            (* \; 
+                                                           "Edited 28-Apr-87 11:55 by Pavel")
+    (LET ((ARGBLOCK (ADDSTACKBASE (- (FETCH (FX NEXTBLOCK) OF (\\MYALINK))
+                                     (+ (LISP:DECF N)
+                                        N)))))
+
+         (* |;;| "First sub-form is a list of (variable initialization) pairs.  Initializes the variables, binding them to new values all at once, then executes the remaining forms as in a PROGN.")
+
+         (LISP:MULTIPLE-VALUE-BIND (BODY SPECIALS)
+                (\\REMOVE-DECLS (CDDR LAM)
+                       (LISP:SETQ ENV (\\MAKE-CHILD-ENVIRONMENT ENV)))
+                (\\INTERPRET-ARGUMENTS "a LAMBDA as the CAR of a form"
+                       (CASE (CAR LAM)
+                           ((LAMBDA OPENLAMBDA) '&INTERLISP)
+                           ((LISP:LAMBDA) '&REQUIRED)
+                           (T (LISP:ERROR "(~S ...) is not legal as the CAR of a form." (CAR LAM))))
+                       (CADR LAM)
+                       SPECIALS ENV BODY ARGBLOCK N 0)))))
+
+(\\INTERPRET-ARGUMENTS
+  (LAMBDA (\\FN-NAME \\ARGTYPE \\ARGLIST \\SPECIALS \\ENVIRONMENT \\BODY \\ARGUMENT-BLOCK \\LENGTH 
+                 \\INDEX)                                    (* \; "Edited  7-Apr-88 16:16 by amd")
+
+    (* |;;| "Written in a somewhat arcane style to avoid recursive calls whenever possible, & keep code inline. RECUR does a recursive call if under a PROGV, but otherwise does a GO. ")
+
+    (LISP:MACROLET
+     ((RECUR (TAG)
+             `(GO ,TAG))
+      (WITH-BINDING
+       (VAR VAL &REST FORMS)
+       `(PROGN (CHECK-BINDABLE ,VAR)
+               (LISP:IF (OR (FMEMB ,VAR \\SPECIALS)
+                               (VARIABLE-GLOBALLY-SPECIAL-P ,VAR))
+                   (LISP:MACROLET ((RECUR (TAG)
+                                          `(\\INTERPRET-ARGUMENTS
+                                            \\FN-NAME
+                                            ,(LISP:IF (EQ TAG 'IN-KEYWORDS)
+                                                 '\\ARGTYPE
+                                                 `',TAG)
+                                            \\ARGLIST \\SPECIALS \\ENVIRONMENT \\BODY 
+                                            \\ARGUMENT-BLOCK \\LENGTH \\INDEX)))
+                          (LISP:PROGV (LIST ,VAR)
+                                 (LIST ,VAL)
+                                 ,@FORMS))
+                   (PROGN (LISP:SETF (ENVIRONMENT-VARS \\ENVIRONMENT)
+                                 (LIST* ,VAR ,VAL (ENVIRONMENT-VARS \\ENVIRONMENT)))
+                          ,@FORMS)))))
+     (PROG (\\VAR \\VAL \\SVAR \\SP)
+
+      (* |;;| "dispatch on input type. The in-keywords case is special, since it needs to pass down where the beginning of the keywords section is")
+
+               (CASE \\ARGTYPE
+                   (&REQUIRED (GO &REQUIRED))
+                   (&OPTIONAL (GO &OPTIONAL))
+                   (&INTERLISP (GO &INTERLISP))
+                   (&REST (GO &REST))
+                   (&KEY (GO &KEY))
+                   (&AUX (GO &AUX))
+                   (&BODY (GO &BODY))
+                   (T (GO IN-KEYWORDS)))
+           &REQUIRED
+               (RETURN
+                (COND
+                   ((NULL \\ARGLIST)
+                    (LISP:IF (< \\INDEX \\LENGTH)
+                        (LISP:ERROR 'TOO-MANY-ARGUMENTS :CALLEE \\FN-NAME :ACTUAL \\LENGTH :MAXIMUM 
+                               \\INDEX))
+                    (RECUR &BODY))
+                   (T (CASE (SETQ \\VAR (|pop| \\ARGLIST))
+                          (&OPTIONAL (RECUR &OPTIONAL))
+                          (&REST (RECUR &REST))
+                          (&AUX (RECUR &AUX))
+                          (&KEY (RECUR &KEY))
+                          (T (COND
+                                ((>= \\INDEX \\LENGTH)
+                                 (LISP:ERROR 'TOO-FEW-ARGUMENTS :CALLEE \\FN-NAME :ACTUAL \\LENGTH 
+                                        :MINIMUM
+                                        (+ 1 \\INDEX
+                                           (FOR ARG IN \\ARGLIST
+                                              WHILE (NOT (FMEMB ARG '(&OPTIONAL &REST &AUX &KEY))
+                                                             ) SUM 1)))))
+                             (SETQ \\VAL (ARG-REF \\ARGUMENT-BLOCK (PROG1 \\INDEX
+                                                                                  (LISP:INCF \\INDEX)
+                                                                                  )))
+                             (WITH-BINDING \\VAR \\VAL (RECUR &REQUIRED)))))))
+           &OPTIONAL
+               (RETURN (COND
+                              ((NULL \\ARGLIST)
+                               (LISP:IF (< \\INDEX \\LENGTH)
+                                   (LISP:ERROR 'TOO-MANY-ARGUMENTS :CALLEE \\FN-NAME :ACTUAL \\LENGTH
+                                          :MAXIMUM \\INDEX))
+                               (RECUR &BODY))
+                              (T (CASE (SETQ \\VAR (|pop| \\ARGLIST))
+                                     (&REST (RECUR &REST))
+                                     (&AUX (RECUR &AUX))
+                                     (&KEY (RECUR &KEY))
+                                     (T (LISP:IF (>= \\INDEX \\LENGTH)
+                                            (LISP:IF (LISP:CONSP \\VAR)
+                                                (PROGN (SETQ \\VAL (LISP:EVAL (CADR \\VAR)
+                                                                              \\ENVIRONMENT))
+                                                       (SETQ \\SVAR (CADDR \\VAR))
+                                                       (SETQ \\VAR (CAR \\VAR))
+                                                       (SETQ \\SP NIL))
+                                                (SETQ \\VAL NIL))
+                                            (PROGN (COND
+                                                      ((LISP:CONSP \\VAR)
+                                                       (SETQ \\SVAR (CADDR \\VAR))
+                                                       (SETQ \\SP T)
+                                                       (SETQ \\VAR (CAR \\VAR))))
+                                                   (SETQ \\VAL (ARG-REF \\ARGUMENT-BLOCK 
+                                                                          \\INDEX))
+                                                   (LISP:INCF \\INDEX)))
+                                        (WITH-BINDING \\VAR \\VAL (LISP:IF \\SVAR
+                                                                      (WITH-BINDING \\SVAR \\SP
+                                                                             (RECUR &OPTIONAL))
+                                                                      (RECUR &OPTIONAL))))))))
+           &INTERLISP
+               (RETURN (COND
+                              ((NULL \\ARGLIST)
+                               (RECUR &BODY))
+                              (T (SETQ \\VAR (|pop| \\ARGLIST))
+                                 (LISP:IF (>= \\INDEX \\LENGTH)
+                                     (SETQ \\VAL NIL)
+                                     (PROGN (SETQ \\VAL (ARG-REF \\ARGUMENT-BLOCK \\INDEX))
+                                            (LISP:INCF \\INDEX)))
+                                 (WITH-BINDING \\VAR \\VAL (RECUR &INTERLISP)))))
+           &REST
+               (SETQ \\VAR (|pop| \\ARGLIST))
+               (SETQ \\VAL (|for| I |from| \\INDEX |while| (< I \\LENGTH)
+                                  |collect| (ARG-REF \\ARGUMENT-BLOCK I)))
+               (RETURN (WITH-BINDING \\VAR \\VAL (LISP:IF (NULL \\ARGLIST)
+                                                         (RECUR &BODY)
+                                                         (CASE (|pop| \\ARGLIST)
+                                                             (&AUX (RECUR &AUX))
+                                                             (&KEY (RECUR &KEY))
+                                                             (T (LISP:ERROR 'INVALID-ARGUMENT-LIST 
+                                                                       :CALLEE \\FN-NAME))))))
+           &KEY
+               (OR (EVENP (- \\LENGTH \\INDEX))
+                      (LISP:ERROR "Not an even number of arguments for &KEY"))
+               (SETQ \\ARGTYPE \\ARGLIST)                (* \; 
+                                               "Type is now the beginning of the keyword arguments")
+           IN-KEYWORDS
+               (RETURN
+                (COND
+                   ((NULL \\ARGLIST)
+                    (CHECK-KEYWORDS \\ARGTYPE \\ARGUMENT-BLOCK \\LENGTH \\INDEX)
+                    (RECUR &BODY))
+                   (T (CASE (SETQ \\VAR (|pop| \\ARGLIST))
+                          (&AUX 
+                             (CHECK-KEYWORDS \\ARGTYPE \\ARGUMENT-BLOCK \\LENGTH \\INDEX)
+                             (RECUR &AUX))
+                          (&ALLOW-OTHER-KEYS (LISP:IF (NULL \\ARGLIST)
+                                                 (RECUR &BODY)
+                                                 (CASE (|pop| \\ARGLIST)
+                                                     (&AUX (RECUR &AUX))
+                                                     (T (LISP:ERROR 'INVALID-ARGUMENT-LIST :CALLEE 
+                                                               \\FN-NAME)))))
+                          (T (COND
+                                ((LISP:CONSP \\VAR)
+                                 (SETQ \\VAL (CADR \\VAR))
+                                 (SETQ \\SVAR (CADDR \\VAR))
+                                 (SETQ \\VAR (CAR \\VAR)))
+                                (T (SETQ \\SVAR NIL)
+                                   (SETQ \\VAL NIL)))
+                             (LET ((KEY (LISP:IF (LISP:CONSP \\VAR)
+                                            (PROG1 (CAR \\VAR)
+                                                (SETQ \\VAR (CADR \\VAR)))
+                                            (MAKE-KEYWORD \\VAR))))
+                                  (|for| I |from| \\INDEX |while| (< I \\LENGTH)
+                                     |by| 2
+                                     |do| (LISP:IF (EQ (ARG-REF \\ARGUMENT-BLOCK I)
+                                                           KEY)
+                                                  (RETURN (PROGN (SETQ \\VAL
+                                                                      (ARG-REF \\ARGUMENT-BLOCK
+                                                                             (+ I 1)))
+                                                                     (SETQ \\SP T))))
+                                     |finally| (SETQ \\VAL (LISP:EVAL \\VAL \\ENVIRONMENT
+                                                                          ))
+                                           (SETQ \\SP NIL)))
+                             (WITH-BINDING \\VAR \\VAL (LISP:IF \\SVAR
+                                                           (WITH-BINDING \\SVAR \\SP (RECUR 
+                                                                                          IN-KEYWORDS
+                                                                                            ))
+                                                           (RECUR IN-KEYWORDS))))))))
+           &AUX
+               (RETURN (COND
+                              ((NULL \\ARGLIST)
+                               (RECUR &BODY))
+                              (T (SETQ \\VAR (|pop| \\ARGLIST))
+                                 (LISP:IF (LISP:CONSP \\VAR)
+                                     (PROGN (SETQ \\VAL (LISP:EVAL (CADR \\VAR)
+                                                                   \\ENVIRONMENT))
+                                            (SETQ \\VAR (CAR \\VAR)))
+                                     (SETQ \\VAL NIL))
+                                 (WITH-BINDING \\VAR \\VAL (RECUR &AUX)))))
+           &BODY
+               (RETURN (LISP:IF (NULL (CDR \\BODY))
+                               (LISP:IF (LISP:CONSP (SETQ \\BODY (CAR \\BODY)))
+                                   (CASE (CAR \\BODY)
+                                       (LISP:BLOCK 
+
+                                          (* |;;| "special case to handle BLOCK to avoid consing two environments just to enter a normal LAMBDA function")
+
+                                          (LET ((BLIP (CONS NIL NIL)))
+                                               (LISP:SETF (ENVIRONMENT-BLOCKS \\ENVIRONMENT)
+                                                      (LIST* (CADR \\BODY)
+                                                             BLIP
+                                                             (ENVIRONMENT-BLOCKS \\ENVIRONMENT)))
+                                               (LISP:CATCH BLIP
+                                                   (\\EVAL-PROGN (CDDR \\BODY)
+                                                          \\ENVIRONMENT))))
+                                       (T (LISP:EVAL \\BODY \\ENVIRONMENT)))
+                                   (LISP:EVAL \\BODY \\ENVIRONMENT))
+                               (PROGN (LISP:EVAL (POP \\BODY)
+                                             \\ENVIRONMENT)
+                                      (RECUR &BODY))))))))
+
+(\\INTERPRETER-LAMBDA
+  (LAMBDA (N DEF ENV FN)                                     (* \; 
+                                                           "Edited 13-Feb-87 21:21 by Pavel")
+    (DECLARE (LOCALVARS . T))
+    (LET ((ARGBLOCK (ADDSTACKBASE (|fetch| (BF IVAR) |of| (|fetch| (FX BLINK)
+                                                                     |of| (\\MYALINK))))))
+         (SETQ ENV (\\MAKE-CHILD-ENVIRONMENT ENV))
+         (LISP:MULTIPLE-VALUE-BIND (BODY SPECIALS)
+                (\\REMOVE-DECLS (CDR (CDR DEF))
+                       ENV)
+                (\\INTERPRET-ARGUMENTS FN '&REQUIRED (CAR (CDR DEF))
+                       SPECIALS ENV BODY ARGBLOCK (- N 1)
+                       0)))))
+
+(CHECK-BINDABLE
+  (LAMBDA (VAR)                                              (* \; 
+                                                           "Edited 13-Feb-87 22:06 by Pavel")
+    (LISP:UNLESS (LISP:SYMBOLP VAR)
+           (LISP:ERROR "Attempt to bind a non-symbol: ~S" VAR))
+    (LISP:WHEN (OR (LISP:CONSTANTP VAR)
+                      (FMEMB VAR LISP:LAMBDA-LIST-KEYWORDS))
+        (LISP:ERROR (LISP:IF (LISP:KEYWORDP VAR)
+                        "Attempt to bind a keyword: ~S"
+                        "Attempt to bind a constant: ~S")
+               VAR))
+    (LISP:WHEN (VARIABLE-GLOBAL-P VAR)
+           (LISP:CERROR "Go ahead and bind it anyway" 
+                  "Attempt to bind a variable proclaimed global: ~S" VAR))
+    VAR))
+
+(CHECK-KEYWORDS
+  (LAMBDA (KEY-ARGUMENTS ARGBLOCK LENGTH N)                  (* \; "Edited  1-Dec-87 16:47 by amd")
+
+    (* |;;| "check to see if any keywords in ARGBLOCK are not in the keys - not called if &ALLOW-OTHER-KEYS was set")
+
+    (LISP:BLOCK CHECK-KEYS
+        (LET (BADKEYWORD)
+             (LISP:DO ((I N (+ I 2)))
+                      ((>= I LENGTH))
+                 (LET ((GIVEN-KEY (ARG-REF ARGBLOCK I)))
+                      (LISP:IF (EQ GIVEN-KEY :ALLOW-OTHER-KEYS)
+                          (LISP:IF (ARG-REF ARGBLOCK (LISP:1+ I))
+                              (LISP:RETURN-FROM CHECK-KEYS NIL)
+                              NIL)
+                          (LISP:DO ((KEYTAIL KEY-ARGUMENTS (CDR KEYTAIL)))
+                                   ((OR (NULL KEYTAIL)
+                                           (EQ (CAR KEYTAIL)
+                                               '&AUX))       (* \; "got to end of keyword segment")
+                                    (SETQ BADKEYWORD GIVEN-KEY))
+                              (LET ((WANTED-KEY (CAR KEYTAIL)))
+                                   (IF (LISP:CONSP WANTED-KEY)
+                                       THEN (SETQ WANTED-KEY (CAR WANTED-KEY))
+                                             (LISP:IF (LISP:CONSP WANTED-KEY)
+                                                 (SETQ WANTED-KEY (CAR WANTED-KEY))
+                                                 (SETQ WANTED-KEY (MAKE-KEYWORD WANTED-KEY)))
+                                     ELSE (SETQ WANTED-KEY (MAKE-KEYWORD WANTED-KEY)))
+                                   (LISP:IF (EQ WANTED-KEY GIVEN-KEY)
+                                          (RETURN NIL)))))))
+             (LISP:IF BADKEYWORD (LISP:ERROR 
+                                       "Keyword argument doesn't match expected list of keywords: ~A"
+                                            BADKEYWORD))))))
+)
+
+(DEFMACRO ARG-REF (BLOCK N)
+   `(\\GETBASEPTR ,BLOCK (LLSH ,N 1)))
+
+(PUTPROPS .COMPILER-SPREAD-ARGUMENTS. DMACRO (APPLY COMP.SPREAD))
+(DEFINEQ
+
+(DECLARED-SPECIAL
+  (LAMBDA (VAR DECLS)                                        (* |lmm| "24-May-86 22:27")
+    (AND DECLS (OR (AND (LISTP (CAR DECLS))
+                                  (EQ (CAAR DECLS)
+                                      'DECLARE)
+                                  (|for| DEC |in| (CDAR DECLS)
+                                     |when| (AND (EQ (CAR DEC)
+                                                             'LISP:SPECIAL)
+                                                       (FMEMB VAR (CDR DEC)))
+                                     |do| (RETURN T)))
+                          (DECLARED-SPECIAL VAR (CDR DECLS))))))
+)
+
+
+
+(* \; "FUNCALL and APPLY, not quite same as Interlisp")
+
+(DEFINEQ
+
+(LISP:FUNCALL
+  (LISP:LAMBDA (LISP::FN &REST LISP::ARGS)                   (* \; 
+                                                           "Edited 14-Feb-87 00:16 by Pavel")
+         (LISP:APPLY LISP::FN LISP::ARGS)))
+
+(LISP:APPLY
+  (LAMBDA LISP::N                                            (* \; 
+                                                           "Edited 14-Feb-87 00:16 by Pavel")
+    (LISP:IF (EQ LISP::N 0)
+        (ERROR "TOO FEW ARGUMENTS TO APPLY")
+        (SPREADAPPLY (ARG LISP::N 1)
+               (LET ((LISP::AV (ARG LISP::N LISP::N)))
+                    (FOR LISP::I FROM (LISP:1- LISP::N) TO 2 BY -1
+                       DO (LISP:PUSH (ARG LISP::N LISP::I)
+                                     LISP::AV))
+                    LISP::AV)))))
+)
+
+(PUTPROPS LISP:APPLY DMACRO (DEFMACRO (FN &REST ARGS) (CASE COMPILE.CONTEXT
+                                                                  ((EFFECT RETURN) 
+                                                                     `(LET
+                                                                       ((FN ,FN)
+                                                                        (CNT
+                                                                         ,(LENGTH (CDR ARGS))))
+                                                                       (.SPREAD. ((OPCODES)
+                                                                                  \,@ ARGS)
+                                                                              CNT FN)))
+                                                                  (T 
+                                                                     (* |;;| 
+                                                       "otherwise might not return multiple values")
+
+                                                                     'IGNOREMACRO))))
+
+(PUTPROPS LISP:FUNCALL DMACRO (DEFMACRO (FN &REST ARGS) (COND
+                                                                   ((AND
+                                                                     (NLISTP FN)
+                                                                     (EVERY ARGS
+                                                                            (FUNCTION NLISTP)))
+                                                                    `((OPCODES APPLYFN)
+                                                                      ,@ARGS
+                                                                      ,(LENGTH ARGS)
+                                                                      ,FN))
+                                                                   (T
+                                                                    (LET
+                                                                     ((TEM (GENSYM)))
+                                                                     `((LAMBDA (,TEM)
+                                                                         ((OPCODES APPLYFN)
+                                                                          ,@ARGS
+                                                                          ,(LENGTH ARGS)
+                                                                          ,TEM))
+                                                                       ,FN))))))
+
+
+
+(* \; "COMPILER-LET needs to work differently compiled and interpreted")
+
+(DEFINEQ
+
+(LISP:COMPILER-LET
+  (NLAMBDA $$COMPILER-LET-TAIL                               (* \; "Edited  7-Apr-88 16:05 by amd")
+    (LISP:PROGV (|for| X |in| (CAR $$COMPILER-LET-TAIL) |collect| (COND
+                                                                                 ((LISP:CONSP X)
+                                                                                  (CAR X))
+                                                                                 (T X)))
+           (|for| X |in| (CAR $$COMPILER-LET-TAIL) |collect| (COND
+                                                                            ((LISP:CONSP X)
+                                                                             (\\EVAL (CADR X)))))
+           (\\EVPROGN (CDR $$COMPILER-LET-TAIL)))))
+
+(COMP.COMPILER-LET
+  (LAMBDA (\\A)
+    (DECLARE (LOCALVARS . T))                            (* \; "Edited  7-Apr-88 16:38 by amd")
+                                                             (* ENTRY POINT INTO BYTECOMPILER)
+                                                             (* |lmm| "27-May-86 11:17")
+    (LISP:PROGV (|for| X |in| (CAR \\A) |collect| (|if| (LISP:CONSP X)
+                                                                  |then| (CAR X)
+                                                                |else| X))
+           (|for| X |in| (CAR \\A) |collect| (COND
+                                                            ((LISP:CONSP X)
+                                                             (EVAL (CADR X)))))
+           (COMP.PROGN (CDR \\A)))))
+)
+
+(PUTPROPS LISP:COMPILER-LET DMACRO COMP.COMPILER-LET)
+
+(DEFINE-SPECIAL-FORM LISP:COMPILER-LET (LISP::ARGS &REST LISP::BODY &ENVIRONMENT LISP::ENV)
+   (LET ((*IN-COMPILER-LET* T))
+        (DECLARE (LISP:SPECIAL *IN-COMPILER-LET*))       (* \; 
+      "the *IN-COMPILER-LET* is for macro-caching. It says: don't cache macros under compiler lets")
+        (LISP:PROGV (FOR LISP::X IN LISP::ARGS COLLECT (IF (LISP:CONSP LISP::X)
+                                                                       THEN (CAR LISP::X)
+                                                                     ELSE LISP::X))
+               (FOR LISP::X IN LISP::ARGS COLLECT (IF (LISP:CONSP LISP::X)
+                                                                  THEN (LISP:EVAL
+                                                                            (CADR LISP::X)
+                                                                            LISP::ENV)
+                                                                ELSE NIL))
+               (\\EVAL-PROGN LISP::BODY LISP::ENV))))
+
+
+
+(* \; "Lexical function- and macro-binding forms: FLET, LABELS, and MACROLET.")
+
+
+(DEFINE-SPECIAL-FORM LISP:MACROLET (LISP::MACRO-DEFNS &BODY LISP::BODY &ENVIRONMENT LISP::ENV)
+   (LET (LISP::NEW-ENV LISP::FUNCTIONS)
+
+        (* |;;| 
+   "We parse and handle the declarations here, so they'll take effect in the new child environment")
+
+        (LISP:MULTIPLE-VALUE-BIND
+         (LISP::BODY LISP::SPECIALS)
+         (\\REMOVE-DECLS LISP::BODY (LISP:SETQ LISP::NEW-ENV (\\MAKE-CHILD-ENVIRONMENT
+                                                                      LISP::ENV)))
+         (LISP:SETQ LISP::FUNCTIONS (ENVIRONMENT-FUNCTIONS LISP::NEW-ENV))
+         (FOR LISP::MACRO-DEFN IN LISP::MACRO-DEFNS
+            DO (LISP:SETQ LISP::FUNCTIONS
+                          (LIST* (CAR LISP::MACRO-DEFN)
+                                 (CONS :MACRO `(LISP:LAMBDA (SI::$$MACRO-FORM SI::$$MACRO-ENVIRONMENT
+                                                                   )
+                                                      (LISP:BLOCK ,(CAR LISP::MACRO-DEFN)
+                                                          ,(PARSE-DEFMACRO (CADR LISP::MACRO-DEFN)
+                                                                  'SI::$$MACRO-FORM
+                                                                  (CDDR LISP::MACRO-DEFN)
+                                                                  (CAR LISP::MACRO-DEFN)
+                                                                  NIL :ENVIRONMENT 
+                                                                  'SI::$$MACRO-ENVIRONMENT))))
+                                 LISP::FUNCTIONS)))
+         (LISP:SETF (ENVIRONMENT-FUNCTIONS LISP::NEW-ENV)
+                LISP::FUNCTIONS)
+         (\\EVAL-PROGN LISP::BODY LISP::NEW-ENV))))
+
+(DEFINE-SPECIAL-FORM LISP:FLET (LISP::FN-DEFNS &BODY LISP::BODY &ENVIRONMENT LISP::ENV)
+   (LET
+    (LISP::NEW-ENV LISP::FUNCTIONS)
+
+    (* |;;| 
+  "We parse and handle the declarations here, so they'll take effect in the new child environment")
+
+    (LISP:MULTIPLE-VALUE-BIND
+     (LISP::BODY LISP::SPECIALS)
+     (\\REMOVE-DECLS LISP::BODY (LISP:SETQ LISP::NEW-ENV (\\MAKE-CHILD-ENVIRONMENT 
+                                                                        LISP::ENV)))
+     (LISP:SETQ LISP::FUNCTIONS (ENVIRONMENT-FUNCTIONS LISP::NEW-ENV))
+     (FOR LISP::FN-DEFN IN LISP::FN-DEFNS BIND LISP::FNAME
+        DO
+        (LISP:SETQ LISP::FNAME (LISP:FIRST LISP::FN-DEFN))
+        (LISP:SETQ
+         LISP::FUNCTIONS
+         (LIST* LISP::FNAME
+                (CONS :FUNCTION (MAKE-CLOSURE
+                                 :FUNCTION
+                                 (LISP:MULTIPLE-VALUE-BIND
+                                  (LISP::BODY LISP::DECLS)
+                                  (PARSE-BODY (CDDR LISP::FN-DEFN)
+                                         LISP::ENV T)
+                                  `(LISP:LAMBDA ,(LISP:SECOND LISP::FN-DEFN)
+                                          ,@LISP::DECLS
+                                          (LISP:BLOCK ,(LISP:IF (LISP:SYMBOLP LISP::FNAME 
+                                                                               LISP::FNAME
+                                                                               (LISP:SECOND 
+                                                                                      LISP::FNAME)))
+                                                 ,@LISP::BODY)))
+                                 :ENVIRONMENT LISP::ENV))
+                LISP::FUNCTIONS)))
+     (LISP:SETF (ENVIRONMENT-FUNCTIONS LISP::NEW-ENV)
+            LISP::FUNCTIONS)
+     (\\EVAL-PROGN LISP::BODY LISP::NEW-ENV))))
+
+(DEFINE-SPECIAL-FORM LISP:LABELS (LISP::FN-DEFNS &BODY LISP::BODY &ENVIRONMENT LISP::ENV)
+   (LET
+    (LISP::NEW-ENV LISP::FUNCTIONS)
+
+    (* |;;| 
+  "We parse and handle the declarations here, so they'll take effect in the new child environment")
+
+    (LISP:MULTIPLE-VALUE-BIND
+     (LISP::BODY LISP::SPECIALS)
+     (\\REMOVE-DECLS LISP::BODY (LISP:SETQ LISP::NEW-ENV (\\MAKE-CHILD-ENVIRONMENT 
+                                                                        LISP::ENV)))
+     (LISP:SETQ LISP::FUNCTIONS (ENVIRONMENT-FUNCTIONS LISP::NEW-ENV))
+     (FOR LISP::FN-DEFN IN LISP::FN-DEFNS BIND LISP::FNAME
+        DO (LISP:SETQ LISP::FNAME (LISP:FIRST LISP::FN-DEFN))
+              (LISP:SETQ
+               LISP::FUNCTIONS
+               (LIST* LISP::FNAME
+                      (CONS :FUNCTION 
+
+                            (* |;;| "Must share the environment object so that all of the new lexical function bindings appear in each new functions environment.")
+
+                            (MAKE-CLOSURE :FUNCTION
+                                   (LISP:MULTIPLE-VALUE-BIND
+                                    (LISP::BODY LISP::DECLS)
+                                    (PARSE-BODY (CDDR LISP::FN-DEFN)
+                                           LISP::NEW-ENV T)
+                                    `(LISP:LAMBDA ,(LISP:SECOND LISP::FN-DEFN)
+                                            ,@LISP::DECLS
+                                            (LISP:BLOCK ,(LISP:IF (LISP:SYMBOLP LISP::FNAME)
+                                                                 LISP::FNAME
+                                                                 (LISP:SECOND LISP::FNAME))
+                                                   ,@LISP::BODY)))
+                                   :ENVIRONMENT LISP::NEW-ENV))
+                      LISP::FUNCTIONS)))
+     (LISP:SETF (ENVIRONMENT-FUNCTIONS LISP::NEW-ENV)
+            LISP::FUNCTIONS)
+     (\\EVAL-PROGN LISP::BODY LISP::NEW-ENV))))
+
+(DEFINE-SPECIAL-FORM QUOTE CAR)
+
+(DEFINE-SPECIAL-FORM THE (LISP::TYPE-SPEC LISP::FORM &ENVIRONMENT LISP::ENV)
+   (LISP:IF (AND (LISP:CONSP LISP::TYPE-SPEC)
+                   (EQ (CAR LISP::TYPE-SPEC)
+                       'LISP:VALUES))
+       (LET ((LISP:VALUES (LISP:MULTIPLE-VALUE-LIST (LISP:EVAL LISP::FORM LISP::ENV))))
+            (LISP:IF (LISP:NOTEVERY #'(LISP:LAMBDA (LISP::VALUE LISP::SPEC)
+                                             (TYPEP LISP::VALUE LISP::SPEC))
+                            LISP:VALUES
+                            (CDR LISP::TYPE-SPEC))
+                (CHECK-TYPE-FAIL T LISP::FORM LISP:VALUES LISP::TYPE-SPEC NIL)
+                (LISP:VALUES-LIST LISP:VALUES)))
+       (LET ((LISP::VALUE (LISP:EVAL LISP::FORM LISP::ENV)))
+            (LISP:IF (TYPEP LISP::VALUE LISP::TYPE-SPEC)
+                LISP::VALUE
+                (CHECK-TYPE-FAIL T LISP::FORM LISP::VALUE LISP::TYPE-SPEC NIL)))))
+
+(PUTPROPS THE DMACRO ((SPEC FORM)
+                              FORM))
+
+(PUTPROPS LISP:EVAL-WHEN DMACRO (DEFMACRO (OPTIONS &BODY BODY) (AND
+                                                                        (OR (FMEMB 'COMPILE OPTIONS)
+                                                                            (FMEMB 'LISP:COMPILE 
+                                                                                   OPTIONS))
+                                                                        (MAPC BODY
+                                                                              (FUNCTION LISP:EVAL)))
+                                           (AND (OR (FMEMB 'LOAD OPTIONS)
+                                                    (FMEMB 'LISP:LOAD OPTIONS))
+                                                `(PROGN ,@BODY))))
+(DEFINEQ
+
+(LISP:EVAL-WHEN
+  (NLAMBDA OPTIONS.BODY                                      (* |lmm| " 1-Jun-86 15:16")
+    (AND (OR (FMEMB 'LISP:EVAL (CAR OPTIONS.BODY))
+                    (FMEMB 'EVAL (CAR OPTIONS.BODY))
+                    (FMEMB :EXECUTE (CAR OPTIONS.BODY)))
+           (MAPC (CDR OPTIONS.BODY)
+                 (FUNCTION \\EVAL)))))
+)
+
+(DEFINE-SPECIAL-FORM LISP:EVAL-WHEN (LISP::TAGS &REST LISP::BODY &ENVIRONMENT LISP::ENV)
+   (AND (OR (LISP:MEMBER 'LISP:EVAL LISP::TAGS)
+                   (LISP:MEMBER 'EVAL LISP::TAGS)
+                   (LISP:MEMBER :EXECUTE LISP::TAGS))
+          (\\EVAL-PROGN LISP::BODY LISP::ENV)))
+
+(DEFINE-SPECIAL-FORM DECLARE FALSE)
+
+(DEFMACRO LISP:LOCALLY (&BODY LISP::BODY)
+
+   (* |;;| "This is a macro and not a special form because, as near as I can tell, it doesn't matter to Medley; saying LOCALLY at the top level allows pervasive declarations of all the types Medley actually observes.")
+
+   `(LET NIL ,@LISP::BODY))
+
+(DEFMACRO LISP:LOCALLY (&BODY LISP::BODY)
+
+   (* |;;| "This is a macro and not a special form because, as near as I can tell, it doesn't matter to Medley; saying LOCALLY at the top level allows pervasive declarations of all the types Medley actually observes.")
+
+   `(LET NIL ,@LISP::BODY))
+
+
+
+(* \; "Interlisp version on LLINTERP")
+
+
+(DEFINE-SPECIAL-FORM PROGN \\EVAL-PROGN)
+(DEFINEQ
+
+(\\EVAL-PROGN
+  (LAMBDA (BODY ENVIRONMENT)                                 (* \; 
+                                                           "Edited 12-Feb-87 20:25 by Pavel")
+    (|if| (CDR BODY)
+        |then| (LISP:EVAL (CAR BODY)
+                          ENVIRONMENT)
+              (\\EVAL-PROGN (CDR BODY)
+                     ENVIRONMENT)
+      |else| (LISP:EVAL (CAR BODY)
+                        ENVIRONMENT))))
+)
+
+
+
+(* \; "Confused because currently Interlisp special form, fixing MACRO-FUNCTION is complex")
+
+
+
+
+(* \; "The Interlisp function is on LLINTERP")
+
+
+(DEFINE-SPECIAL-FORM PROG1 (LISP:FIRST &REST LISP:REST &ENVIRONMENT LISP::ENV)
+   (LET ((LISP::VAL (LISP:EVAL LISP:FIRST LISP::ENV)))
+        (LISP:TAGBODY PROG1 (LISP:IF LISP:REST
+                                    (PROGN (LISP:EVAL (CAR LISP:REST)
+                                                  LISP::ENV)
+                                           (LISP:SETQ LISP:REST (CDR LISP:REST)))
+                                    (LISP:RETURN-FROM PROG1 LISP::VAL))
+               (GO PROG1))))
+
+(DEFMACRO PROG1 (LISP:FIRST &REST LISP:REST)
+   `(LET ((SI::$PROG1-FIRST-EXPRESSION$ ,LISP:FIRST))
+         (DECLARE (LOCALVARS SI::$PROG1-FIRST-EXPRESSION$))
+         ,@LISP:REST SI::$PROG1-FIRST-EXPRESSION$))
+
+(DEFINE-SPECIAL-FORM LET* (LISP::VARS &REST LISP::BODY &ENVIRONMENT LISP::ENV)
+   (LISP:MULTIPLE-VALUE-BIND (LISP::BODY LISP::SPECIALS)
+          (\\REMOVE-DECLS LISP::BODY (LISP:SETQ LISP::ENV (\\MAKE-CHILD-ENVIRONMENT
+                                                                   LISP::ENV)))
+          (\\LET*-RECURSION LISP::VARS LISP::SPECIALS LISP::ENV LISP::BODY)))
+
+(DEFINE-SPECIAL-FORM LET (LISP::VARS &BODY LISP::BODY &ENVIRONMENT LISP::ENV &AUX LISP::\\NEW-ENV
+                                    )
+
+   (* |;;| "Initializes the variables, binding them to new values all at once, then executes the remaining forms as in a PROGN.")
+
+   (LISP:MULTIPLE-VALUE-BIND (LISP::\\BODY LISP::SPECIALS)
+          (\\REMOVE-DECLS LISP::BODY (LISP:SETQ LISP::\\NEW-ENV (\\MAKE-CHILD-ENVIRONMENT
+                                                                         LISP::ENV)))
+
+          (* |;;| "Note that since remove decls side-effects the environment, variables which are declared special inside this scope will cause references inside the variable value forms to do special reference.")
+
+          (LET ((LISP::ENV-VARS (ENVIRONMENT-VARS LISP::\\NEW-ENV))
+                LISP::SPECVARS LISP::SPECVALS LISP::VALUE)
+               (FOR LISP::VAR IN LISP::VARS
+                  DO (COND
+                            ((LISP:CONSP LISP::VAR)
+
+                             (* |;;| "NEW-ENV current has all of the new specials, but none of the new lexicals. This is the right environment to eval in.")
+
+                             (LISP:SETQ LISP::VALUE (LISP:EVAL (CADR LISP::VAR)
+                                                               LISP::\\NEW-ENV))
+                             (LISP:SETQ LISP::VAR (CAR LISP::VAR)))
+                            (T (LISP:SETQ LISP::VALUE NIL)))
+                        (CHECK-BINDABLE LISP::VAR)
+                        (IF (OR (FMEMB LISP::VAR LISP::SPECIALS)
+                                       (VARIABLE-GLOBALLY-SPECIAL-P LISP::VAR))
+                            THEN (LISP:PUSH LISP::VAR LISP::SPECVARS)
+                                  (LISP:PUSH LISP::VALUE LISP::SPECVALS)
+                          ELSE (LISP:SETQ LISP::ENV-VARS (LIST* LISP::VAR LISP::VALUE 
+                                                                        LISP::ENV-VARS))))
+               (LISP:SETF (ENVIRONMENT-VARS LISP::\\NEW-ENV)
+                      LISP::ENV-VARS)
+               (LISP:IF LISP::SPECVARS
+                   (LISP:PROGV LISP::SPECVARS LISP::SPECVALS
+                       (\\EVAL-PROGN LISP::\\BODY LISP::\\NEW-ENV))
+                   (\\EVAL-PROGN LISP::\\BODY LISP::\\NEW-ENV)))))
+
+(PUTPROPS LET MACRO (X (|\\LETtran| X)))
+
+(PUTPROPS LET* MACRO (X (|\\LETtran| X T)))
+(DEFINEQ
+
+(\\LET*-RECURSION
+  (LAMBDA (VARS $$LET*-SPECIALS $$LET*-ENV $$LET*-BODY)
+    (DECLARE (LOCALVARS . T))                            (* \; "Edited  7-Apr-88 16:09 by amd")
+    (|bind| VAR VALUE |for| $$LET*-TAIL |on| VARS |eachtime| (SETQ VAR
+                                                                              (CAR $$LET*-TAIL))
+       |do| (COND
+                   ((LISP:CONSP VAR)
+                    (SETQ VALUE (LISP:EVAL (CADR VAR)
+                                           $$LET*-ENV))
+                    (SETQ VAR (CAR VAR)))
+                   (T (SETQ VALUE NIL)))
+             (CHECK-BINDABLE VAR)
+             (LISP:IF (OR (FMEMB VAR $$LET*-SPECIALS)
+                             (VARIABLE-GLOBALLY-SPECIAL-P VAR))
+                 (RETURN (LISP:PROGV (LIST VAR)
+                                    (LIST VALUE)
+                                    (\\LET*-RECURSION (CDR $$LET*-TAIL)
+                                           $$LET*-SPECIALS $$LET*-ENV $$LET*-BODY)))
+                 (LISP:SETF (ENVIRONMENT-VARS $$LET*-ENV)
+                        (LIST* VAR VALUE (ENVIRONMENT-VARS $$LET*-ENV))))
+       |finally| (RETURN (\\EVAL-PROGN $$LET*-BODY $$LET*-ENV)))))
+
+(|\\LETtran|
+  (LAMBDA (LETTAIL SEQUENTIALP)                              (* \; "Edited 23-Dec-86 16:23 by lmm")
+
+    (* |;;| "Interlisp version of LET/LET*/PROG*")
+
+    (PROG ((VARS (MAPCAR (CAR LETTAIL)
+                            (FUNCTION (LAMBDA (BINDENTRY)
+                                        (|if| (LISTP BINDENTRY)
+                                            |then| (CAR BINDENTRY)
+                                          |else| BINDENTRY)))))
+               (VALS (MAPCAR (CAR LETTAIL)
+                            (FUNCTION (LAMBDA (BINDENTRY)
+                                        (|if| (LISTP BINDENTRY)
+                                            |then| (CADR BINDENTRY)
+                                          |else| NIL)))))
+               (BODY (CDR LETTAIL))
+               (DECLS NIL))
+              (LISP:MULTIPLE-VALUE-SETQ (BODY DECLS)
+                     (PARSE-BODY BODY NIL))
+              (RETURN (|if| (NOT SEQUENTIALP)
+                              |then| `((,'LAMBDA ,VARS
+                                             ,@DECLS
+                                             ,@BODY)
+                                           ,@VALS)
+                            |elseif| (NULL (CDR VARS))
+                              |then| (SELECTQ SEQUENTIALP
+                                             (PROG* `(PROG ,@LETTAIL))
+                                             `((,'LAMBDA ,VARS
+                                                 ,@DECLS
+                                                 ,@BODY)
+                                               ,@VALS))
+                            |else|                       (* \; 
+                                "in the sequential case, all declarations must be included in each")
+                                  (|if| (EQ SEQUENTIALP 'PROG*)
+                                      |then| (SETQ BODY (LIST (LIST* 'PROG NIL BODY))))
+                                  (|for| VAR |in| (REVERSE (CDR VARS)) |as| VAL
+                                     |in| (REVERSE (CDR VALS))
+                                     |do| (SETQ BODY `(((,'LAMBDA (,VAR)
+                                                                  ,@DECLS
+                                                                  ,@BODY)
+                                                                ,VAL))))
+                                  `((,'LAMBDA (,(CAR VARS))
+                                      ,@DECLS
+                                      ,@BODY)
+                                    ,(CAR VALS)))))))
+)
+
+(DEFINE-SPECIAL-FORM COND (&REST LISP::COND-CLAUSES &ENVIRONMENT LISP::ENVIRONMENT)
+   (PROG NIL
+         LISP::CONDLOOP
+             (COND
+                ((NULL LISP::COND-CLAUSES)
+                 (RETURN NIL))
+                ((NULL (CDAR LISP::COND-CLAUSES))
+                 (RETURN (OR (LISP:EVAL (CAAR LISP::COND-CLAUSES)
+                                            LISP::ENVIRONMENT)
+                                    (PROGN (LISP:SETQ LISP::COND-CLAUSES (CDR LISP::COND-CLAUSES)
+                                                  )
+                                           (GO LISP::CONDLOOP)))))
+                ((LISP:EVAL (CAAR LISP::COND-CLAUSES)
+                        LISP::ENVIRONMENT)
+                 (RETURN (\\EVAL-PROGN (CDAR LISP::COND-CLAUSES)
+                                    LISP::ENVIRONMENT)))
+                (T (LISP:SETQ LISP::COND-CLAUSES (CDR LISP::COND-CLAUSES))
+                   (GO LISP::CONDLOOP)))))
+
+(DEFMACRO COND (&REST LISP::TAIL)
+   (LISP:IF LISP::TAIL
+       (LISP:IF (NULL (CDAR LISP::TAIL))
+           (LISP:IF (CDR LISP::TAIL)
+               (LET ((VAR (LISP:GENTEMP)))
+                    `(LET ((,VAR ,(CAAR LISP::TAIL)))
+                          (LISP:IF ,VAR
+                              ,VAR
+                              (COND
+                                 ,@(CDR LISP::TAIL)))))
+               `(LISP:VALUES ,(CAAR LISP::TAIL)))
+           `(LISP:IF ,(CAAR LISP::TAIL)
+                ,(MKPROGN (CDAR LISP::TAIL))
+                ,@(LISP:IF (CDR LISP::TAIL)
+                      (LIST (LISP:IF (EQ (CAADR LISP::TAIL)
+                                         T)
+                                (LISP:IF (NULL (CDADR LISP::TAIL))
+                                    T
+                                    (MKPROGN (CDADR LISP::TAIL)))
+                                `(COND
+                                    ,@(CDR LISP::TAIL)))))))))
+(DEFINEQ
+
+(LISP:IF
+  (NLAMBDA (LISP::TEST LISP::THEN LISP::ELSE)
+    (DECLARE (LOCALVARS . T))                            (* \; 
+                                                           "Edited 12-Feb-87 20:27 by Pavel")
+    (LISP:IF (\\EVAL LISP::TEST)
+        (\\EVAL LISP::THEN)
+        (\\EVAL LISP::ELSE))))
+)
+
+(DEFINE-SPECIAL-FORM LISP:IF (LISP::TEST LISP::THEN &OPTIONAL LISP::ELSE &ENVIRONMENT 
+                                        LISP::ENVIRONMENT)
+   (LISP:IF (LISP:EVAL LISP::TEST LISP::ENVIRONMENT)
+       (LISP:EVAL LISP::THEN LISP::ENVIRONMENT)
+       (LISP:EVAL LISP::ELSE LISP::ENVIRONMENT)))
+
+(PUTPROPS LISP:IF DMACRO COMP.IF)
+
+
+
+(* \; "Interlisp NLAMBDA definitions on LLINTERP")
+
+
+
+
+(* \; "both special form and macro")
+
+
+(DEFMACRO AND (&REST LISP::FORMS)
+   (COND
+      ((CDR LISP::FORMS)
+       `(LISP:IF ,(CAR LISP::FORMS)
+            (AND ,@(CDR LISP::FORMS))))
+      (LISP::FORMS (CAR LISP::FORMS))
+      (T T)))
+
+(DEFMACRO OR (&REST LISP::FORMS)
+   (LISP:IF (NULL (CDR LISP::FORMS))
+       (CAR LISP::FORMS)
+       `(LET ((SI::*OR-GENTEMP* ,(CAR LISP::FORMS)))
+             (DECLARE (LOCALVARS SI::*OR-GENTEMP*))
+             (LISP:IF SI::*OR-GENTEMP*
+                 SI::*OR-GENTEMP*
+                 (OR ,@(CDR LISP::FORMS))))))
+
+(DEFINE-SPECIAL-FORM AND (&REST LISP::AND-CLAUSES &ENVIRONMENT LISP::ENV)
+   (LISP:LOOP (COND
+                 ((NULL LISP::AND-CLAUSES)
+                  (RETURN T))
+                 ((NULL (CDR LISP::AND-CLAUSES))
+                  (RETURN (LISP:EVAL (CAR LISP::AND-CLAUSES)
+                                     LISP::ENV)))
+                 (T (LISP:IF (LISP:EVAL (CAR LISP::AND-CLAUSES)
+                                    LISP::ENV)
+                        (LISP:POP LISP::AND-CLAUSES)
+                        (RETURN NIL))))))
+
+(DEFINE-SPECIAL-FORM OR (&REST LISP::TAIL &ENVIRONMENT LISP::ENV)
+   (BIND LISP::VAL FOR OLD LISP::TAIL ON LISP::TAIL (COND
+                                                                       ((NULL (CDR LISP::TAIL))
+                                                                        (RETURN
+                                                                         (LISP:EVAL (CAR 
+                                                                                           LISP::TAIL
+                                                                                             )
+                                                                                LISP::ENV)))
+                                                                       ((LISP:SETQ
+                                                                         LISP::VAL
+                                                                         (LISP:EVAL (CAR 
+                                                                                           LISP::TAIL
+                                                                                             )
+                                                                                LISP::ENV))
+                                                                        (RETURN LISP::VAL)))))
+
+
+
+(* \; "BLOCK and RETURN go together")
+
+(DEFINEQ
+
+(LISP:BLOCK
+  (NLAMBDA LISP::TAIL                                        (* \; 
+                                                           "Edited 12-Feb-87 20:31 by Pavel")
+    (\\EVPROGN (CDR LISP::TAIL))))
+)
+
+(PUTPROPS LISP:BLOCK DMACRO COMP.BLOCK)
+
+(DEFINE-SPECIAL-FORM LISP:BLOCK (LISP::NAME &REST LISP::\\BODY &ENVIRONMENT LISP::ENVIRONMENT)
+
+   (* |;;| "Syntax is (BLOCK name  . body).  The body is evaluated as a PROGN, but it is possible to exit the block using (RETURN-FROM name value).  The RETURN-FROM must be lexically contained within the block.")
+
+   (LET* ((LISP::BLIP (CONS NIL NIL))
+          (LISP::\\NEW-ENV (\\MAKE-CHILD-ENVIRONMENT LISP::ENVIRONMENT :BLOCK (LISP::NAME 
+                                                                                         LISP::BLIP))
+                 ))
+         (LISP:CATCH LISP::BLIP (\\EVAL-PROGN LISP::\\BODY LISP::\\NEW-ENV))))
+
+(DEFMACRO RETURN (LISP::VALUE)
+   `(LISP:RETURN-FROM NIL ,LISP::VALUE))
+(DEFINEQ
+
+(LISP:RETURN-FROM
+  (NLAMBDA (LISP::RETFROM-TAG LISP::RETFROM-VALUE)
+    (DECLARE (LOCALVARS . T))                            (* \; 
+                                                           "Edited 12-Feb-87 20:35 by Pavel")
+    (LET ((LISP::RETVALUES (LISP:MULTIPLE-VALUE-LIST (\\EVAL LISP::RETFROM-VALUE))))
+         (LET ((LISP::FRAME (STKNTH 1)))
+              (WHILE LISP::FRAME DO (LISP:IF (OR (AND (NULL LISP::RETFROM-TAG)
+                                                                    (EQ (STKNAME LISP::FRAME)
+                                                                        '\\PROG0))
+                                                            (AND (EQ (STKNAME LISP::FRAME)
+                                                                         'LISP:BLOCK)
+                                                                   (EQ (CAR (STKARG 1 LISP::FRAME))
+                                                                       LISP::RETFROM-TAG)))
+                                                (RETVALUES LISP::FRAME LISP::RETVALUES T)
+                                                (LISP:SETQ LISP::FRAME (STKNTH 1 LISP::FRAME 
+                                                                                  LISP::FRAME)))
+                 FINALLY (LISP:ERROR 'ILLEGAL-RETURN :TAG LISP::RETFROM-TAG))))))
+)
+
+(DEFINE-SPECIAL-FORM LISP:RETURN-FROM (LISP::BLOCK-NAME LISP::EXPR &ENVIRONMENT LISP::ENV)
+   (LET ((LISP::BLIP (AND LISP::ENV (LISP:GETF (ENVIRONMENT-BLOCKS LISP::ENV)
+                                               LISP::BLOCK-NAME))))
+        (LISP:IF (AND LISP::BLOCK-NAME (NULL LISP::BLIP))
+            (LISP:ERROR 'ILLEGAL-RETURN :TAG LISP::BLOCK-NAME)
+            (LET ((LISP::\\BLK LISP::BLOCK-NAME)
+                  (LISP::VALS (LISP:MULTIPLE-VALUE-LIST (LISP:EVAL LISP::EXPR LISP::ENV))))
+                 (COND
+                    (LISP::BLIP                              (* \; 
+                                                       "This is a CL RETURN-FROM, so do the throw.")
+                           (HANDLER-BIND ((ILLEGAL-THROW #'(LISP:LAMBDA (LISP::C)
+                                                                  (DECLARE (IGNORE LISP::C))
+                                                                  (LISP:ERROR 'ILLEGAL-RETURN :TAG 
+                                                                         LISP::\\BLK))))
+                                  (LISP:THROW LISP::BLIP (LISP:VALUES-LIST LISP::VALS))))
+                    (T                                       (* \; 
+                              "This is an IL RETURN, so return from the closest enclosing \\PROG0.")
+                       (RETVALUES (STKPOS '\\PROG0)
+                              LISP::VALS T)))))))
+
+
+
+(* \; "IL and CL versions of FUNCTION.")
+
+(DEFINEQ
+
+(LISP:FUNCTION
+  (NLAMBDA (LISP::FN)                                        (* \; 
+                                                           "Edited 30-Jan-87 19:07 by Pavel")
+
+(* |;;;| "Fake CL:FUNCTION for Interlisp --- no lexical closures")
+
+    (LISP:IF (LISP:SYMBOLP LISP::FN)
+        (LISP:SYMBOL-FUNCTION LISP::FN)
+        LISP::FN)))
+)
+
+(PUTPROPS LISP:FUNCTION DMACRO (DEFMACRO (X) (COND
+                                                        ((LISP:SYMBOLP X)
+                                                         `(LISP:SYMBOL-FUNCTION ',X))
+                                                        (T `(FUNCTION ,X)))))
+
+(DEFINE-SPECIAL-FORM FUNCTION (FN &OPTIONAL FUNARGP &ENVIRONMENT ENVIRONMENT)
+
+   (* |;;| "Interlisp FUNCTION in Common Lisp interpreter:")
+
+   (* |;;| "like CL:FUNCTION except that (FUNCTION FOO) just returns FOO and not its definition.")
+
+   (COND
+      (FUNARGP (LISP:FUNCALL #'FUNCTION FN FUNARGP))
+      ((LISP:SYMBOLP FN)
+       (LET (FN-DEFN)
+            (COND
+               ((OR (NULL ENVIRONMENT)
+                       (NULL (SETQ FN-DEFN (LISP:GETF (ENVIRONMENT-FUNCTIONS ENVIRONMENT)
+                                                      FN))))
+                FN)
+               ((EQ (CAR FN-DEFN)
+                    :FUNCTION)
+                (CDR FN-DEFN))
+               (T (LISP:ERROR "The lexical macro ~S is not a legal argument to ~S." FN 'FUNCTION)))))
+      ((OR (NULL ENVIRONMENT)
+              (AND (FOR VALUE IN (CDR (ENVIRONMENT-VARS ENVIRONMENT)) BY CDDR
+                          ALWAYS (EQ VALUE *SPECIAL-BINDING-MARK*))
+                     (NULL (ENVIRONMENT-FUNCTIONS ENVIRONMENT))
+                     (NULL (ENVIRONMENT-BLOCKS ENVIRONMENT))
+                     (NULL (ENVIRONMENT-TAGBODIES ENVIRONMENT))))
+       FN)
+      (T (MAKE-CLOSURE :FUNCTION (COND
+                                    ((EQ (CAR FN)
+                                         'LAMBDA)
+                                     `(LISP:LAMBDA (&OPTIONAL ,@(CADR FN)
+                                                          &REST IGNORE)
+                                             ,@(CDDR FN)))
+                                    (T FN))
+                :ENVIRONMENT ENVIRONMENT))))
+
+(DEFINE-SPECIAL-FORM LISP:FUNCTION (LISP::FN &ENVIRONMENT LISP::ENVIRONMENT)
+   (COND
+      ((LISP:SYMBOLP LISP::FN)
+       (LET (LISP::FN-DEFN)
+            (COND
+               ((OR (NULL LISP::ENVIRONMENT)
+                       (NULL (LISP:SETQ LISP::FN-DEFN (LISP:GETF (ENVIRONMENT-FUNCTIONS 
+                                                                            LISP::ENVIRONMENT)
+                                                                 LISP::FN))))
+                (LISP:SYMBOL-FUNCTION LISP::FN))
+               ((EQ (CAR LISP::FN-DEFN)
+                    :FUNCTION)
+                (CDR LISP::FN-DEFN))
+               (T (LISP:ERROR "The lexical macro ~S is not a legal argument to ~S." LISP::FN
+                         'LISP:FUNCTION)))))
+      ((LISP::SETF-NAME-P LISP::FN)                          (* \; "Like symbol case, sort of...")
+       (LET (LISP::FN-DEFN)
+            (COND
+               ((OR (NULL LISP::ENVIRONMENT)
+                       (NULL (PROGN (LISP:DO ((LISP::EF (ENVIRONMENT-FUNCTIONS LISP::ENVIRONMENT)
+                                                     (CDDR LISP::EF)))
+                                             ((NULL LISP::EF))
+                                        (LISP:WHEN (LISP:EQUAL (CAR LISP::EF)
+                                                          LISP::FN)
+                                            (LISP:SETQ LISP::FN-DEFN (CADR LISP::EF))
+                                            (LISP:SETQ LISP::EF NIL)))
+                                    LISP::FN-DEFN)))
+                (LISP:FDEFINITION LISP::FN))
+               ((EQ (CAR LISP::FN-DEFN)
+                    :FUNCTION)
+                (CDR LISP::FN-DEFN))
+               (T (LISP:ERROR "It is illegal to MACROLET ~s" LISP::FN)))))
+      ((OR (NULL LISP::ENVIRONMENT)
+              (AND (FOR LISP::VALUE IN (CDR (ENVIRONMENT-VARS LISP::ENVIRONMENT))
+                          BY CDDR ALWAYS (EQ LISP::VALUE *SPECIAL-BINDING-MARK*))
+                     (NULL (ENVIRONMENT-FUNCTIONS LISP::ENVIRONMENT))
+                     (NULL (ENVIRONMENT-BLOCKS LISP::ENVIRONMENT))
+                     (NULL (ENVIRONMENT-TAGBODIES LISP::ENVIRONMENT))))
+
+       (* |;;| "Environment is empty: don't have to make a closure.")
+
+       LISP::FN)
+      (T (MAKE-CLOSURE :FUNCTION (COND
+                                    ((EQ (CAR LISP::FN)
+                                         'LAMBDA)
+                                     `(LISP:LAMBDA (&OPTIONAL ,@(CADR LISP::FN)
+                                                          &REST IGNORE)
+                                             ,@(CDDR LISP::FN)))
+                                    (T LISP::FN))
+                :ENVIRONMENT
+                (\\COPY-ENVIRONMENT LISP::ENVIRONMENT)       (* \; 
+      "environment is copied so that forms that side-effect it (such as LET*) will work correctly.")
+                ))))
+
+(LISP:DEFUN LISP:FUNCTIONP (LISP::FN)
+   (AND (OR (LISP:SYMBOLP LISP::FN)
+                   (LISP:COMPILED-FUNCTION-P LISP::FN)
+                   (AND (LISP:CONSP LISP::FN)
+                          (EQ (CAR LISP::FN)
+                              'LISP:LAMBDA))
+                   (CLOSURE-P LISP::FN))
+          T))
+
+(LISP:DEFUN LISP:COMPILED-FUNCTION-P (LISP::FN)
+   (OR (TYPEP LISP::FN 'COMPILED-CLOSURE)
+          (AND (ARRAYP LISP::FN)
+                 (EQ (|fetch| (ARRAYP TYP) |of| LISP::FN)
+                     \\ST.CODE))))
+
+(DEFINE-SPECIAL-FORM LISP:MULTIPLE-VALUE-CALL (LISP::FN &REST LISP::ARGS &ENVIRONMENT LISP::ENV)
+
+   (* |;;| 
+ "for interpreted calls only.  The macro inserts a \\MVLIST call after the computation of TAIL")
+
+   (LISP:APPLY (LISP:EVAL LISP::FN LISP::ENV)
+          (FOR LISP::X IN LISP::ARGS JOIN (\\MVLIST (LISP:EVAL LISP::X LISP::ENV)))))
+
+(DEFINE-SPECIAL-FORM LISP:MULTIPLE-VALUE-PROG1 (LISP::FORM &REST LISP::OTHER-FORMS &ENVIRONMENT 
+                                                          LISP::ENV)
+   (LISP:VALUES-LIST (PROG1 (LISP:MULTIPLE-VALUE-LIST (LISP:EVAL LISP::FORM LISP::ENV))
+                         (FOR LISP::X IN LISP::OTHER-FORMS DO (LISP:EVAL LISP::X 
+                                                                                 LISP::ENV)))))
+(DEFINEQ
+
+(COMP.CL-EVAL
+  (LAMBDA (EXP)                                              (* |lmm| " 5-Jun-86 00:44")
+    (COMP.SPREAD `(CDR ,@EXP)
+           '*EVAL-ARGUMENT-COUNT*
+           `(CAR ,@EXP)
+           '((LISP:EVAL ENVIRONMENT)))))
+)
+
+(LISP:DEFUN LISP:EVALHOOK (LISP::FORM LISP::EVALHOOKFN LISP::APPLYHOOKFN &OPTIONAL LISP::ENV)
+   "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn.  Ignores these hooks once, for the top-level evaluation of Form."
+   (LET ((*EVALHOOK* LISP::EVALHOOKFN)
+         (LISP::*SKIP-EVALHOOK* T)
+         (*APPLYHOOK* LISP::APPLYHOOKFN)
+         (LISP::*SKIP-APPLYHOOK* NIL))
+        (LISP:EVAL LISP::FORM LISP::ENV)))
+
+(LISP:DEFUN LISP:APPLYHOOK (LISP:FUNCTION LISP::ARGS LISP::EVALHOOKFN LISP::APPLYHOOKFN 
+                                      &OPTIONAL LISP::ENV)
+   "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn.  Ignores these hooks once, for the top-level evaluation of Form."
+   (DECLARE (IGNORE LISP::ENV))
+
+   (* |;;| "the env argument is not used as agreed on the Common Lisp mailing list.  (Arguments have already been evaluated.)")
+
+   (LET ((*EVALHOOK* LISP::EVALHOOKFN)
+         (LISP::*SKIP-EVALHOOK* T)
+         (*APPLYHOOK* LISP::APPLYHOOKFN)
+         (LISP::*SKIP-APPLYHOOK* NIL))
+        (LISP:APPLY LISP:FUNCTION LISP::ARGS)))
+
+(LISP:DEFVAR *EVALHOOK* NIL)
+
+(LISP:DEFVAR *APPLYHOOK* NIL)
+
+(LISP:DEFVAR LISP::*SKIP-EVALHOOK* NIL
+   "Used with non-null *EVALHOOK* to suppress the use of the hook-function
+  for one level of eval.")
+
+(LISP:DEFVAR LISP::*SKIP-APPLYHOOK* NIL
+   "Used with non-null *APPLYHOOK* to suppress the use of the hook function
+  for one level of eval.")
+
+
+
+(* \; "CONSTANTS mechanism")
+
+(DEFINEQ
+
+(LISP:CONSTANTP
+  (LAMBDA (OBJECT ENVIRONMENT)                               (* |vanMelle| "19-Nov-86 21:43")
+    (LISP:TYPECASE OBJECT
+        (LISP:NUMBER T)
+        (LISP:CHARACTER T)
+        (STRING T)
+        (LISP:BIT-VECTOR T)
+        (LISP:SYMBOL (OR (EQ OBJECT NIL)
+                            (EQ OBJECT T)
+                            (LISP:KEYWORDP OBJECT)
+                            (AND COMPVARMACROHASH (SETQ OBJECT (GETHASH OBJECT 
+                                                                              COMPVARMACROHASH))
+                                   (LISP:CONSTANTP OBJECT))))
+        (CONS (CASE (CAR OBJECT)
+                  ((CONSTANT QUOTE) T)
+                  (LISP:OTHERWISE (COND
+                                     ((FMEMB (CAR OBJECT)
+                                             CONSTANTFOLDFNS)
+                                      (EVERY (CDR OBJECT)
+                                             (FUNCTION LISP:CONSTANTP)))
+                                     (T (LISP:MULTIPLE-VALUE-BIND (NEW-FORM EXPANDED)
+                                               (LISP:MACROEXPAND OBJECT ENVIRONMENT)
+                                               (AND EXPANDED (LISP:CONSTANTP NEW-FORM)))))))))
+    ))
+)
+
+(LISP:DEFSETF LISP:CONSTANTP XCL::SET-CONSTANTP)
+
+(LISP:DEFUN XCL::SET-CONSTANTP (LISP:SYMBOL XCL::FLAG)
+   (LISP:IF (NOT (NULL XCL::FLAG))
+       (LISP:SETF (GETHASH LISP:SYMBOL COMPVARMACROHASH)
+              `(CONSTANT ,LISP:SYMBOL))
+       (LISP:WHEN (TYPEP COMPVARMACROHASH 'LISP:HASH-TABLE)
+              (REMHASH LISP:SYMBOL COMPVARMACROHASH))))
+
+
+
+(* \; "Interlisp SETQ for Common Lisp and vice versa")
+
+
+(DEFINE-SPECIAL-FORM LISP:SETQ (&REST LISP::TAIL &ENVIRONMENT LISP::ENV)
+   (LET (LISP::VALUE)
+        (WHILE LISP::TAIL DO (LISP:SETQ LISP::VALUE (SET-SYMBOL (LISP:POP LISP::TAIL)
+                                                                       (LISP:EVAL (LISP:POP
+                                                                                       LISP::TAIL)
+                                                                              LISP::ENV)
+                                                                       LISP::ENV)))
+        LISP::VALUE))
+
+(DEFINE-SPECIAL-FORM SETQ (VAR VALUE &ENVIRONMENT ENV)
+   (SET-SYMBOL VAR (LISP:EVAL VALUE ENV)
+          ENV))
+
+(PUTPROPS LISP:SETQ DMACRO (DEFMACRO (X Y &REST LISP:REST) `(PROGN
+                                                                     (SETQ ,X ,Y)
+                                                                     ,@(AND
+                                                                        LISP:REST
+                                                                        `((LISP:SETQ ,@LISP:REST))))))
+
+
+
+(* |;;| "An nlambda definition for cl:setq so cmldeffer may use cl:setq will run in the init")
+
+(DEFINEQ
+
+(LISP:SETQ
+  (NLAMBDA LISP::TAIL                                        (* \; "Edited 15-Nov-87 17:34 by jop")
+    (LET ((LISP::VALUE NIL))
+         (LISP:LOOP (LISP:IF (NULL LISP::TAIL)
+                           (RETURN LISP::VALUE))
+                (LISP:SETQ LISP::VALUE (SET (LISP:POP LISP::TAIL)
+                                                (LISP:IF (NOT (BOUNDP *EVALHOOK*))
+                                                    (PROGN 
+                                                           (* |;;| "CMLEVAL Init-forms not yet run")
+
+                                                           (EVAL (LISP:POP LISP::TAIL)))
+                                                    (LISP:EVAL (LISP:POP LISP::TAIL)))))))))
+)
+
+(DEFMACRO SETQ (VAR &REST VALUE-FORMS)
+   (COND
+      ((NULL VALUE-FORMS)
+       `(LISP:SETQ ,VAR NIL))
+      ((NULL (CDR VALUE-FORMS))
+       `(LISP:SETQ ,VAR ,(CAR VALUE-FORMS)))
+      (T `(LISP:SETQ ,VAR (PROG1 ,@VALUE-FORMS)))))
+(DEFINEQ
+
+(SET-SYMBOL
+  (LAMBDA (LISP:SYMBOL VALUE ENVIRONMENT)                    (* \; "Edited  7-Jan-87 15:37 by gbn")
+    (LISP:BLOCK SET-SYMBOL
+        (|if| ENVIRONMENT
+            |then| (SETQ ENVIRONMENT (ENVIRONMENT-VARS ENVIRONMENT))
+                  (WHILE ENVIRONMENT
+                     DO (IF (EQ LISP:SYMBOL (CAR ENVIRONMENT))
+                                THEN 
+
+                                      (* |;;| "found a binding for this symbol")
+
+                                      (IF (EQ (CAR (SETQ ENVIRONMENT (CDR ENVIRONMENT)))
+                                                  *SPECIAL-BINDING-MARK*)
+                                          THEN 
+
+                                                (* |;;| 
+                           "it is a special binding, or a mark that we are using the special value")
+
+                                                (RETURN NIL) 
+                                                             (* \; "return from WHILE"))
+                                      (RPLACA ENVIRONMENT VALUE) 
+
+                                      (* |;;| "smash new value in")
+
+                                      (LISP:RETURN-FROM SET-SYMBOL VALUE)
+                              ELSE (SETQ ENVIRONMENT (CDDR ENVIRONMENT)))))
+
+        (* |;;| "no environment, or not found")
+
+        (SETQ ENVIRONMENT (\\STKSCAN LISP:SYMBOL))
+        (COND
+           ((EQ (\\HILOC ENVIRONMENT)
+                \\STACKHI)
+            (\\PUTBASEPTR ENVIRONMENT 0 VALUE))
+           (T (\\RPLPTR ENVIRONMENT 0 VALUE)))
+        VALUE)))
+)
+
+(DEFMACRO LISP:PSETQ (&REST TAIL)
+   (AND TAIL `(PROGN (SETQ ,(|pop| TAIL)
+                          ,(LISP:IF (CDR TAIL)
+                               `(PROG1 ,(POP TAIL)
+                                    (LISP:PSETQ ,@TAIL))
+                               (CAR TAIL)))
+                         NIL)))
+
+(DEFMACRO SETQQ (SYMBOL VALUE)                           (* \; 
+                                                    "so common lisp interpreter will know about it")
+   `(SETQ ,SYMBOL ',VALUE))
+
+(DEFINE-SPECIAL-FORM LISP:CATCH (LISP::CATCH-TAG &REST LISP::\\CATCH-FORMS &ENVIRONMENT 
+                                           LISP::\\CATCH-ENV)
+   (LISP:CATCH (LISP:EVAL LISP::CATCH-TAG LISP::\\CATCH-ENV)
+          (\\EVAL-PROGN LISP::\\CATCH-FORMS LISP::\\CATCH-ENV)))
+
+(DEFINE-SPECIAL-FORM LISP:THROW (LISP::TAG LISP::VALUE &ENVIRONMENT LISP::ENV)
+   (LISP:THROW (LISP:EVAL LISP::TAG LISP::ENV)
+          (LISP:EVAL LISP::VALUE LISP::ENV)))
+
+(DEFINE-SPECIAL-FORM LISP:UNWIND-PROTECT (LISP::\\FORM &REST LISP::\\CLEANUPS &ENVIRONMENT 
+                                                    LISP::\\ENV)
+   (LISP:UNWIND-PROTECT
+       (LISP:EVAL LISP::\\FORM LISP::\\ENV)
+       (\\EVAL-PROGN LISP::\\CLEANUPS LISP::\\ENV)))
+(DEFINEQ
+
+(LISP:THROW
+  (NLAMBDA (THROW-TAG THROW-VALUE)
+    (DECLARE (LOCALVARS . T))                            (* |lmm| "30-May-86 00:09")
+    (LISP:THROW (\\EVAL THROW-TAG)
+           (\\EVAL THROW-VALUE))))
+
+(LISP:CATCH
+  (NLAMBDA \\CATCH-FORMS                                     (* \; "Edited  7-Apr-88 16:53 by amd")
+    (LISP:CATCH (\\EVAL (CAR \\CATCH-FORMS))
+        (\\EVPROGN (CDR \\CATCH-FORMS)))))
+
+(LISP:UNWIND-PROTECT
+  (NLAMBDA \\UNWIND-FORMS                                    (* \; "Edited  7-Apr-88 16:54 by amd")
+    (LISP:UNWIND-PROTECT
+        (\\EVAL (CAR \\UNWIND-FORMS))
+        (\\EVPROGN (CDR \\UNWIND-FORMS)))))
+)
+
+(DEFMACRO PROG (VARS &BODY (BODY DECLS))
+   `(LISP:BLOCK NIL
+        (LET ,VARS ,@DECLS (LISP:TAGBODY ,@BODY))))
+
+(DEFMACRO PROG* (VARS &BODY (BODY DECLS))
+   `(LISP:BLOCK NIL
+        (LET* ,VARS ,@DECLS (LISP:TAGBODY ,@BODY))))
+
+(DEFINE-SPECIAL-FORM GO (LISP::\\TAG &ENVIRONMENT LISP::ENV)
+   (BIND LISP::TAIL FOR LISP::TAGBODIES ON (AND LISP::ENV (ENVIRONMENT-TAGBODIES
+                                                                           LISP::ENV)) BY CDDR
+      WHEN (LISP:SETQ LISP::TAIL (LISP:MEMBER LISP::\\TAG (CAR LISP::TAGBODIES))) 
+
+            (* |;;| "MUST use EQL, as tags may be integers.")
+ DO (HANDLER-BIND ((ILLEGAL-THROW #'(LISP:LAMBDA (LISP::C)
+                                               (LISP:ERROR 'ILLEGAL-GO :TAG LISP::\\TAG))))
+               (LISP:THROW (CADR LISP::TAGBODIES)
+                      LISP::TAIL)) FINALLY (LISP:ERROR 'ILLEGAL-GO :TAG LISP::\\TAG)))
+
+(DEFINE-SPECIAL-FORM LISP:TAGBODY (&REST LISP::\\TAGBODY-TAIL &ENVIRONMENT LISP::ENV)
+   (LET* ((LISP::BLIP (CONS NIL NIL))
+          (LISP::\\NEW-ENV (\\MAKE-CHILD-ENVIRONMENT LISP::ENV :TAGBODY (LISP::\\TAGBODY-TAIL
+                                                                             LISP::BLIP))))
+         (WHILE (LISP:SETQ LISP::\\TAGBODY-TAIL (LISP:CATCH LISP::BLIP
+                                                            (FOR LISP::X IN 
+                                                                                 LISP::\\TAGBODY-TAIL
+                                                               UNLESS (LISP:SYMBOLP LISP::X)
+                                                               DO (LISP:EVAL LISP::X 
+                                                                             LISP::\\NEW-ENV)))))))
+(DEFINEQ
+
+(LISP:TAGBODY
+  (NLAMBDA TAIL                                              (* |lmm| "23-May-86 16:05")
+                                                             (* |like| PROG |with| |no| 
+                                                           |variables|)
+    (LET ((TL (CONS NIL TAIL)))
+         (\\PROG0 TL TL))))
+)
+
+
+
+(* \; "for macro caching")
+
+(DEFINEQ
+
+(CACHEMACRO
+  (LAMBDA (FN BODY ENV)                                      (* \; "Edited 25-Sep-87 18:32 by jop")
+
+(* |;;;| "We want to cache the expansion unless")
+
+    (* |;;| "1) the env is not an interpreted env (including NIL), ")
+
+    (* |;;| "2) there are lexical macros in force, OR")
+
+    (* |;;| "3) There is a compiler-let in force.")
+
+    (LISP:IF (OR (NOT (TYPEP ENV 'ENVIRONMENT))
+                    (AND ENV (FOR FN IN (CDR (ENVIRONMENT-FUNCTIONS ENV)) BY CDDR
+                                    THEREIS (EQ (CAR FN)
+                                                    :MACRO)))
+                    *IN-COMPILER-LET*)
+        (LISP:FUNCALL FN BODY ENV)
+        (OR (GETHASH BODY CLISPARRAY)
+               (PUTHASH BODY (LISP:FUNCALL FN BODY ENV)
+                      CLISPARRAY)))))
+)
+
+(LISP:DEFPARAMETER *MACROEXPAND-HOOK* 'CACHEMACRO)
+
+(RPAQQ *IN-COMPILER-LET* NIL)
+
+
+
+(* |;;| "PROCLAIM and friends.")
+
+
+
+
+(* |;;| 
+"Needs to come first because DEFVARs put it out.  With package code in the init, also need this here rather than CMLEVAL"
+)
+
+
+(LISP:DEFUN LISP:PROCLAIM (LISP::PROCLAMATION)
+
+   (* |;;| "PROCLAIM is a top-level form used to pass assorted information to the compiler.  This interpreter ignores proclamations except for those declaring variables to be SPECIAL.")
+
+   (LISP:WHEN (LISP:CONSP LISP::PROCLAMATION)
+       (CASE (CAR LISP::PROCLAMATION)
+           (LISP:SPECIAL (FOR LISP::X IN (CDR LISP::PROCLAMATION)
+                            DO (LISP:SETF (VARIABLE-GLOBALLY-SPECIAL-P LISP::X)
+                                          T)
+                                  (LISP:SETF (VARIABLE-GLOBAL-P LISP::X)
+                                         NIL)
+                                  (LISP:SETF (LISP:CONSTANTP LISP::X)
+                                         NIL)))
+           (GLOBAL (FOR LISP::X IN (CDR LISP::PROCLAMATION) DO (LISP:SETF (
+                                                                                    VARIABLE-GLOBAL-P
+                                                                                       LISP::X)
+                                                                                  T)
+                                                                          (LISP:SETF (
+                                                                          VARIABLE-GLOBALLY-SPECIAL-P
+                                                                                      LISP::X)
+                                                                                 NIL)
+                                                                          (LISP:SETF (
+                                                                                    LISP:CONSTANTP
+                                                                                      LISP::X)
+                                                                                 NIL)))
+           (SI::CONSTANT (FOR LISP::X IN (CDR LISP::PROCLAMATION)
+                            DO (LISP:SETF (LISP:CONSTANTP LISP::X)
+                                          T)
+                                  (LISP:SETF (VARIABLE-GLOBAL-P LISP::X)
+                                         NIL)
+                                  (LISP:SETF (VARIABLE-GLOBALLY-SPECIAL-P LISP::X)
+                                         NIL)))
+           (LISP:DECLARATION (FOR LISP::X IN (CDR LISP::PROCLAMATION)
+                                DO (LISP:SETF (XCL::DECL-SPECIFIER-P LISP::X)
+                                              T)))
+           (LISP:NOTINLINE (FOR LISP::X IN (CDR LISP::PROCLAMATION)
+                              DO (LISP:SETF (XCL::GLOBALLY-NOTINLINE-P LISP::X)
+                                            T)))
+           (LISP:INLINE (FOR LISP::X IN (CDR LISP::PROCLAMATION)
+                           DO (LISP:SETF (XCL::GLOBALLY-NOTINLINE-P LISP::X)
+                                         NIL))))))
+
+
+
+(* \; "used by the codewalker, too")
+
+(DECLARE\: EVAL@COMPILE 
+
+(PUTPROPS VARIABLE-GLOBALLY-SPECIAL-P MACRO ((VARIABLE)
+                                                     (GET VARIABLE 'GLOBALLY-SPECIAL)))
+
+(PUTPROPS VARIABLE-GLOBAL-P MACRO ((VARIABLE)
+                                           (GET VARIABLE 'GLOBALVAR)))
+)
+
+(LISP:DEFUN XCL::DECL-SPECIFIER-P (LISP:SYMBOL)
+   (GET LISP:SYMBOL 'SI::DECLARATION-SPECIFIER))
+
+(LISP:DEFUN XCL::SET-DECL-SPECIFIER-P (XCL::SPEC XCL::VAL)
+   (LISP:SETF (GET XCL::SPEC 'SI::DECLARATION-SPECIFIER)
+          XCL::VAL))
+
+(LISP:DEFUN XCL::GLOBALLY-NOTINLINE-P (XCL::FN)
+   (GET XCL::FN 'SI::GLOBALLY-NOTINLINE))
+
+(LISP:DEFUN XCL::SET-GLOBALLY-NOTINLINE-P (XCL::FN XCL::VAL)
+   (LISP:SETF (GET XCL::FN 'SI::GLOBALLY-NOTINLINE)
+          XCL::VAL))
+
+(LISP:DEFSETF XCL::DECL-SPECIFIER-P XCL::SET-DECL-SPECIFIER-P)
+
+(LISP:DEFSETF XCL::GLOBALLY-NOTINLINE-P XCL::SET-GLOBALLY-NOTINLINE-P)
+
+(PUTPROPS GLOBALLY-SPECIAL PROPTYPE IGNORE)
+
+(PUTPROPS GLOBALVAR PROPTYPE IGNORE)
+
+(PUTPROPS SI::DECLARATION-SPECIFIER PROPTYPE IGNORE)
+
+(PUTPROPS SI::GLOBALLY-NOTINLINE PROPTYPE IGNORE)
+
+(PUTPROPS SPECIAL-FORM PROPTYPE IGNORE)
+
+(DEFMACRO LISP:DECLAIM (&REST LISP::DECL-SPECS)
+   `(LISP:EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
+           (LISP:MAPC #'LISP:PROCLAIM ',LISP::DECL-SPECS)))
+
+
+
+(* |;;| 
+"This proclamation is here to shut DECLARE up about CLtL2 declarations that we ignore anyway")
+
+
+
+
+(* |;;| 
+"We don't need one of these for (OPTIMIZE DEBUG) since we throw all OPTIMIZE declarations away already"
+)
+
+
+(LISP:PROCLAIM '(LISP:DECLARATION DYNAMIC-EXTENT))
+
+(PUTPROPS CMLEVAL FILETYPE LISP:COMPILE-FILE)
+
+(PUTPROPS CMLEVAL MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "INTERLISP"))
+(DECLARE\: EVAL@COMPILE DONTCOPY 
+
+(DEFOPTIMIZER CL-EVAL-FN3-CALL (ARG1 ARG2 &ENVIRONMENT ENV)
+
+                                 (* |;;| "Emit a call to FN3 after pushing only 2 arguments (the other having been pushed by IL:.COMPILER-SPREAD-ARGUMENTS. earlier in the game).  Used in CL:EVAL.")
+
+                                   (COND
+                                      ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
+                                       `((OPCODES FN3 0 0 (FN . \\EVAL-INVOKE-LAMBDA)
+                                                RETURN)
+                                         ,ARG1
+                                         ,ARG2))
+                                      (T `((OPCODES FN3 0 (FN . \\EVAL-INVOKE-LAMBDA)
+                                                  RETURN)
+                                           ,ARG1
+                                           ,ARG2))))
+)
+(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 
+(DECLARE\: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA LISP:TAGBODY LISP:UNWIND-PROTECT LISP:CATCH LISP:SETQ LISP:BLOCK LISP:EVAL-WHEN 
+                          LISP:COMPILER-LET COMMON-LISP)
+
+(ADDTOVAR NLAML LISP:THROW LISP:FUNCTION LISP:RETURN-FROM LISP:IF)
+
+(ADDTOVAR LAMA LISP:APPLY LISP:FUNCALL)
+)
+(PUTPROPS CMLEVAL COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 1993))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (17862 18109 (COMMON-LISP 17872 . 18107)) (18150 23722 (\\TRANSLATE-CL\:LAMBDA 18160
+ . 23720)) (27353 54374 (LISP:EVAL 27363 . 36956) (\\EVAL-INVOKE-LAMBDA 36958 . 38163) (
+\\INTERPRET-ARGUMENTS 38165 . 50863) (\\INTERPRETER-LAMBDA 50865 . 51630) (CHECK-BINDABLE 51632 . 
+52393) (CHECK-KEYWORDS 52395 . 54372)) (54522 55231 (DECLARED-SPECIAL 54532 . 55229)) (55296 56123 (
+LISP:FUNCALL 55306 . 55541) (LISP:APPLY 55543 . 56121)) (58786 60461 (LISP:COMPILER-LET 58796 . 59612)
+ (COMP.COMPILER-LET 59614 . 60459)) (69251 69619 (LISP:EVAL-WHEN 69261 . 69617)) (70664 71132 (
+\\EVAL-PROGN 70674 . 71130)) (74895 78849 (\\LET*-RECURSION 74905 . 76181) (|\\LETtran| 76183 . 78847)
+) (80818 81150 (LISP:IF 80828 . 81148)) (84128 84360 (LISP:BLOCK 84138 . 84358)) (85158 86554 (
+LISP:RETURN-FROM 85168 . 86552)) (88065 88435 (LISP:FUNCTION 88075 . 88433)) (94781 95036 (
+COMP.CL-EVAL 94791 . 95034)) (96600 97892 (LISP:CONSTANTP 96610 . 97890)) (99557 100327 (LISP:SETQ 
+99567 . 100325)) (100588 102252 (SET-SYMBOL 100598 . 102250)) (103570 104245 (LISP:THROW 103580 . 
+103797) (LISP:CATCH 103799 . 104006) (LISP:UNWIND-PROTECT 104008 . 104243)) (106096 106449 (LISP:TAGBODY
+ 106106 . 106447)) (106485 107356 (CACHEMACRO 106495 . 107354)))))
+STOP
diff --git a/CLTL2/CMLEVAL.LCOM b/CLTL2/CMLEVAL.LCOM
new file mode 100644
index 00000000..5bda4b6e
Binary files /dev/null and b/CLTL2/CMLEVAL.LCOM differ
diff --git a/CLTL2/CMLEXEC b/CLTL2/CMLEXEC
new file mode 100644
index 00000000..dc35ca21
--- /dev/null
+++ b/CLTL2/CMLEXEC
@@ -0,0 +1,821 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+(FILECREATED " 8-Apr-92 22:06:20" {DSK}<usr>local>lde>lispcore>sources>CMLEXEC.;2 70091  
+
+      changes to%:  (ALISTS (BackgroundMenuCommands EXEC))
+
+      previous date%: "25-Jun-91 12:22:29" {DSK}<usr>local>lde>lispcore>sources>CMLEXEC.;1)
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1987, 1988, 1990, 1991, 1992 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLEXECCOMS)
+
+(RPAQQ CMLEXECCOMS ((FILES CMLUNDO PROFILE) (XCL:PROFILES "EXEC") (STRUCTURES COMMAND-ENTRY EXEC-EVENT-ID EXEC-EVENT HISTORY) (* ; "These are public except for command-entry.") (FUNCTIONS XCL::EXEC-CLOSEFN XCL::EXEC-SHRINKFN XCL::SETUP-EXEC-WINDOW XCL::EXEC-TITLE-FUNCTION FIX-FORM XCL::GET-PROCESS-PROFILE XCL::SAVE-CURRENT-EXEC-PROFILE XCL::SETF-GET-PROCESS-PROFILE XCL:SET-EXEC-TYPE XCL:SET-DEFAULT-EXEC-TYPE XCL::ENTER-EXEC-FUNCTION) (SETFS XCL::GET-PROCESS-PROFILE) (FUNCTIONS DO-EVENT EXEC EXEC-EVAL PRINT-ALL-DOCUMENTATION PRINT-DOCUMENTATION VALUE-OF ADD-EXEC EXEC-READ-LINE EXEC-EVENT-ID-PROMPT FIND-EXEC-COMMAND) (FUNCTIONS CIRCLAR-COPYER) (FNS COPY-CIRCLE) (* ; "CIRCLAR-COPYER and COPY-CIRCLE are the solution for AR#11172") (FNS EXEC-READ DIR) (VARIABLES *PER-EXEC-VARIABLES* CL:* CL:** CL:*** + CL:++ CL:+++ - / CL:// CL:/// *CURRENT-EVENT* *EXEC-ID* XCL:*EXEC-PROMPT* XCL:*EVAL-FUNCTION* *NOT-YET-EVALUATED* *THIS-EXEC-COMMANDS* *EXEC-COMMAND-TABLE* *DEBUGGER-COMMAND-TABLE* *CURRENT-EXEC-TYPE* *EXEC-MAKE-UNDOABLE-P*) (VARIABLES *EDIT-INPUT-WITH-TTYIN*) (FNS DO-APPLY-EVENT DO-HISTORY-SEARCH EVAL-INPUT EVENTS-INPUT EXEC-PRIN1 EXEC-VALUE-OF GET-NEXT-HISTORY-EVENT HISTORY-ADD-TO-SPELLING-LISTS HISTORY-NTH PRINT-HISTORY FIND-HISTORY-EVENTS PRINT-EVENT PRINT-EVENT-PROMPT PROCESS-EXEC-ID SEARCH-FOR-EVENT-NUMBER \PICK.EVALQT LISPXREPRINT) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? (QUOTE READ) (QUOTE TTYINREAD)) (MOVD (QUOTE \PICK.EVALQT) (QUOTE \PROC.REPEATEDLYEVALQT)) (SETQ BackgroundMenu))) (FUNCTIONS CASE-EQUALP EXEC-EVENT-PROPS EXEC-PRINT EXEC-FORMAT) (ALISTS (BackgroundMenuCommands EXEC)) (ALISTS (SYSTEMINITVARS LISPXHISTORY GREETHIST)) (* ;; "Exec Commands") (DEFINE-TYPES COMMANDS) (FUNCTIONS DEFCOMMAND) (COMMANDS "?" "??" "CONN" "DA" "DIR" "DO-EVENTS" "FIX" "FORGET" "NAME" "NDIR" "PL" "REDO" "REMEMBER" "SHH" "UNDO" "USE" "PP") (* ;; "Arrange to use the correct compiler") (PROP FILETYPE CMLEXEC) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DIR) (NLAML) (LAMA)))))
+
+(FILESLOAD CMLUNDO PROFILE)
+
+(XCL:DEFPROFILE "EXEC" (XCL:*DEBUGGER-PROMPT* "") (XCL:*EXEC-PROMPT* "") (*READTABLE* "XCL") (*PACKAGE* "XCL") (XCL:*EVAL-FUNCTION* (QUOTE CL:EVAL)))
+
+(CL:DEFSTRUCT (COMMAND-ENTRY (:TYPE LIST)) ARGUMENTS FUNCTION MODE)
+
+(CL:DEFSTRUCT (EXEC-EVENT-ID (:TYPE LIST)) NUMBER NAME dummy)
+
+(CL:DEFSTRUCT (EXEC-EVENT (:TYPE LIST)) INPUT ID (VALUE *NOT-YET-EVALUATED*) dummy)
+
+(CL:DEFSTRUCT (HISTORY (:TYPE LIST)) (EVENTS NIL) (INDEX 0) (SIZE 100) (MOD 100))
+
+
+
+(* ; "These are public except for command-entry.")
+
+
+(CL:DEFUN XCL::EXEC-CLOSEFN (XCL::WINDOW) (LET ((XCL::PROCESS (WINDOWPROP XCL::WINDOW (QUOTE PROCESS)))) (COND ((EQ (THIS.PROCESS) XCL::PROCESS) (ADD.PROCESS (BQUOTE (CLOSEW (QUOTE (\, XCL::WINDOW))))) (QUOTE DON'T)) ((PROCESSP XCL::PROCESS) (CL:IF (TTY.PROCESSP XCL::PROCESS) (TTY.PROCESS T)) (DEL.PROCESS XCL::PROCESS)))))
+
+(CL:DEFUN XCL::EXEC-SHRINKFN (XCL::WINDOW) (LET ((XCL::PROCESS (WINDOWPROP XCL::WINDOW (QUOTE PROCESS)))) (COND ((EQ (THIS.PROCESS) XCL::PROCESS) (ADD.PROCESS (BQUOTE (SHRINKW (QUOTE (\, XCL::WINDOW))))) (QUOTE DON'T)) ((TTY.PROCESSP XCL::PROCESS) (TTY.PROCESS T) NIL))))
+
+(CL:DEFUN XCL::SETUP-EXEC-WINDOW (XCL::WINDOW) "Add (non-title) properties to a new exec window." (WINDOWADDPROP XCL::WINDOW (QUOTE CLOSEFN) (QUOTE XCL::EXEC-CLOSEFN)) (WINDOWADDPROP XCL::WINDOW (QUOTE SHRINKFN) (QUOTE XCL::EXEC-SHRINKFN)) XCL::WINDOW)
+
+(CL:DEFUN XCL::EXEC-TITLE-FUNCTION (XCL::WINDOW EXEC-ID) (WINDOWPROP XCL::WINDOW (QUOTE TITLE) (CL:FORMAT NIL "Exec ~A (~A)" EXEC-ID (READTABLEPROP *READTABLE* (QUOTE NAME)))))
+
+(CL:DEFUN FIX-FORM (INPUT &OPTIONAL (CIRCLE-FLAG NIL)) (* ;;; "Edits a form, in the current window if it is shorter than ttyinfixlimit, or if longer in the display editor using edite.  Returns the newly edited form.") (* ; "Edited by Tomoru Teruuchi") (COND ((OR (NOT *EDIT-INPUT-WITH-TTYIN*) (NOT (IMAGESTREAMP (TTYDISPLAYSTREAM))) (AND (NOT CIRCLE-FLAG) (EQUAL 0 (COUNTDOWN INPUT TTYINFIXLIMIT))) (* ; "(IGEQ (COUNT INPUT) TTYINFIXLIMIT)  is Original Code. But This Codecan't accept circler. Edited by TT (31-May-1990)")) (EDITE (CL:IF (AND (EQ 1 (LENGTH INPUT)) (CL:CONSP (CAR INPUT))) (CAR INPUT) INPUT) NIL NIL T NIL :CLOSE-ON-COMPLETION) INPUT) (T (PRINT-EVENT-PROMPT *CURRENT-EVENT*) (DSPFONT INPUTFONT T) (CURSOR T) (* ; "make sure can edit (in case cursor smashed somehow?)") (CL:WHEN NIL (* ; "Old expression") (TTYIN "" NIL NIL (QUOTE LISPXREAD) NIL NIL BUFFER-EXPR-FROM-BELOW *READTABLE*)) (EXEC-READ-LINE (LET ((%#RPARS NIL) (FONTCHANGEFLG NIL) (*PRINT-ESCAPE* T) (*PRINT-RADIX* (NOT (= *READ-BASE* 10))) (*PRINT-BASE* *READ-BASE*) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) (*PRINT-GENSYM* (QUOTE :REREAD)) (*PRINT-ARRAY* T) (*PRINT-STRUCTURE* T)) (DECLARE (CL:SPECIAL %#RPARS FONTCHANGEFLG) (* ; "others are already globally special ")) (CL:WITH-OUTPUT-TO-STRING (STR) (FOR X ON INPUT DO (IF CIRCLE-FLAG THEN (* ; "Edited by TT (31-May-1990) CL:PRIN1 can print circlar") (CL:PRIN1 (CAR X) STR) ELSEIF (LISTP (CAR X)) THEN (PRINTDEF (CAR X) (POSITION STR) NIL NIL NIL STR) ELSE (PRIN2 (CAR X) STR)) (AND (CDR X) (PRIN1 " " STR)))))))))
+
+(CL:DEFUN XCL::GET-PROCESS-PROFILE (&OPTIONAL (XCL::PROCESS (THIS.PROCESS))) (PROCESSPROP XCL::PROCESS (QUOTE PROFILE)))
+
+(CL:DEFUN XCL::SAVE-CURRENT-EXEC-PROFILE NIL "Resave the profiled bindings of the exec process into their cache." (LET ((XCL::PROFILE (XCL::GET-PROCESS-PROFILE (THIS.PROCESS)))) (CL:IF (XCL:PROFILE-P XCL::PROFILE) (XCL:SAVE-PROFILE XCL::PROFILE))))
+
+(CL:DEFUN XCL::SETF-GET-PROCESS-PROFILE (&OPTIONAL (XCL::PROCESS (THIS.PROCESS)) (XCL::PROFILE XCL:*PROFILE*)) (CL:SETQ XCL::PROFILE (XCL::PROFILIZE XCL::PROFILE)) (PROCESSPROP XCL::PROCESS (QUOTE PROFILE) XCL::PROFILE) XCL::PROFILE)
+
+(CL:DEFUN XCL:SET-EXEC-TYPE (TYPE) "Set the current Exec's type to TYPE" (* ;; "The EXECA-FRAME bit is a gross hack to make this function work inside init files.  The problem is that you want to affect the EXEC, regardless of who has bound the per-exec variables between here an the EXEC frame.  Yech.") (LET ((XCL::EXECA-FRAME (STKPOS (QUOTE XCL::EXECA0001)))) (COND (XCL::EXECA-FRAME (ENVEVAL (BQUOTE (XCL:RESTORE-PROFILE (QUOTE (\, TYPE)))) XCL::EXECA-FRAME XCL::EXECA-FRAME)) (T (XCL:RESTORE-PROFILE TYPE)))))
+
+(CL:DEFUN XCL:SET-DEFAULT-EXEC-TYPE (TYPE) (SETTOPVAL (QUOTE XCL:*PROFILE*) TYPE))
+
+(CL:DEFUN XCL::ENTER-EXEC-FUNCTION (XCL::EXEC-FUNCTION XCL::PROFILE XCL::ID) "Start up an exec function in the proper profile, setting the default window title properly." (XCL:WITH-PROFILE (XCL:COPY-PROFILE XCL::PROFILE) (XCL::EXEC-TITLE-FUNCTION T (PROCESS-EXEC-ID (THIS.PROCESS) XCL::ID)) (CL:FUNCALL XCL::EXEC-FUNCTION)))
+
+(CL:DEFSETF XCL::GET-PROCESS-PROFILE XCL::SETF-GET-PROCESS-PROFILE)
+
+(CL:DEFUN DO-EVENT (ORIGINAL-INPUT ENVIRONMENT &OPTIONAL (FUNCTION (FUNCTION EVAL-INPUT))) (* ; "Edited by Tomoru Teruuchi") (PROG (TODO INPUT VALUES COM (ADD-TO-SPELLING-LIST ADDSPELLFLG) STR (RETRYFLAG NIL) (* ; "A really gross hack for RETRY to always break.  It exists because: users can setq HELPFLAG anywhere (can't bind it in DO-EVENTand set it in RETRY), RETRY operates on commands (can't wrap the form with a binding of HELPFLAG).")) (DECLARE (CL:SPECIAL RETRYFLAG)) (* ; "RETRY command sets this variable if it wants to be sure to break.") (DSPFONT PRINTOUTFONT T) (SETQ INPUT ORIGINAL-INPUT) RETRY (SETQ TODO (COPY-CIRCLE INPUT)) (* ; "Break EQ link between input and evaluated form (todo), so that in-place mods don't affect history.") (COND ((AND (OR (STRINGP (CAR INPUT)) (CL:SYMBOLP (CAR INPUT))) (PROGN (SETQ STR (STRING (CAR INPUT))) (SOME *THIS-EXEC-COMMANDS* (FUNCTION (LAMBDA (TABLE) (SETQ COM (GETHASH STR TABLE))))))) (* ;; "Handle exec commands.") (CL:ECASE (COMMAND-ENTRY-MODE COM) (:QUIET (MAPC (SETQ VALUES (CL:MULTIPLE-VALUE-LIST (CL:FUNCALL (COMMAND-ENTRY-FUNCTION COM) INPUT ENVIRONMENT))) (FUNCTION (LAMBDA (X) (EXEC-PRINT X)))) (SETQ IT (CAR VALUES)) (* ; "just do it and return") (RETURN)) ((:HISTORY :INPUT) (* ; " create new input. If an error occurs while handling the command, the INPUT will be left as the original input.") (CL:WHEN *CURRENT-EVENT* (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) INPUT)) (SETQ INPUT (CL:FUNCALL (COMMAND-ENTRY-FUNCTION COM) INPUT ENVIRONMENT)) (CL:WHEN *CURRENT-EVENT* (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) INPUT) (* ; " Overwrite the original input with the newly generated one.") (CL:SETF (EXEC-EVENT-PROPS *CURRENT-EVENT*) (LIST* (QUOTE *HISTORY*) ORIGINAL-INPUT (EXEC-EVENT-PROPS *CURRENT-EVENT*)))) (GO RETRY) (* ; " could have generated a command")) ((NIL :EVAL) (* ; " normal kind of command, just apply") (SETQ TODO (BQUOTE ((CL:FUNCALL (QUOTE (\, (COMMAND-ENTRY-FUNCTION COM))) (QUOTE (\, INPUT)) (QUOTE (\, ENVIRONMENT)))))) (SETQ ADD-TO-SPELLING-LIST NIL) (CL:WHEN *CURRENT-EVENT* (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) INPUT))))) (T (* ;; "Handle non-exec commands (fns, functions, macros, etc.).") (CL:WHEN *CURRENT-EVENT* (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) INPUT)) (CL:WHEN *EXEC-MAKE-UNDOABLE-P* (if (CDR TODO) then (SETQ TODO (CONS (OR (CDR (ASSOC (CAR TODO) LISPXFNS)) (CAR TODO)) (CDR TODO))) else (SETQ TODO (LIST (XCL::MAKE-UNDOABLE (CAR TODO) NIL))))))) (AND ADD-TO-SPELLING-LIST (HISTORY-ADD-TO-SPELLING-LISTS TODO)) (SETQ LISPXHIST *CURRENT-EVENT*) (DSPFONT PRINTOUTFONT T) (RETURN (LET ((HELPCLOCK (CLOCK 2)) VALUES) (DECLARE (CL:SPECIAL HELPCLOCK)) (CL:SETQ CL:+++ CL:++ CL:++ + + - - (CAR INPUT)) (* ;; "the book doesn't define what - and friends should be when input is in APPLY format.  Here it says it is just the function name.") (SETQ VALUES (CL:MULTIPLE-VALUE-LIST (CL:IF RETRYFLAG (LET ((HELPFLAG (QUOTE BREAK!))) (DECLARE (CL:SPECIAL HELPFLAG)) (CL:FUNCALL FUNCTION TODO ENVIRONMENT)) (CL:FUNCALL FUNCTION TODO ENVIRONMENT)))) (CL:SETQ CL:/// CL:// CL:// / / VALUES) (CL:UNLESS (EQ (QUOTE NOBIND) (CAR VALUES)) (* ; "Be a bit careful about NOBIND.") (CL:SETQ CL:*** CL:** CL:** CL:* CL:* (SETQ IT (CAR VALUES)))) (CL:WHEN *CURRENT-EVENT* (CL:SETF (EXEC-EVENT-VALUE *CURRENT-EVENT*) (CAR VALUES)) (CL:SETF (EXEC-EVENT-PROPS *CURRENT-EVENT*) (LIST* (QUOTE LISPXVALUES) VALUES (EXEC-EVENT-PROPS *CURRENT-EVENT*)))) (DSPFONT VALUEFONT T) (for X in VALUES do (EXEC-PRINT X)) VALUES))))
+
+(CL:DEFUN EXEC (&KEY XCL::TOP-LEVEL-P (* ; "True of top level execs.  Used for event number restarting and profile caching.") (XCL::WINDOW (WFROMDS (TTYDISPLAYSTREAM))) (* ; "Window for this exec, if any.") (XCL::TITLE NIL XCL::TITLE-SUPPLIED) (* ; "If given, specific title for this window.") ((:COMMAND-TABLES *THIS-EXEC-COMMANDS*) (LIST *EXEC-COMMAND-TABLE*)) (* ; "List of hash tables to look up commands in.") XCL::ENVIRONMENT (* ; "Lexical environment to evaluate things in, default NIL.") XCL::PROMPT (* ; "Special prompt to use (optional).") ((:FUNCTION XCL::FN) (QUOTE EVAL-INPUT)) (* ; "Function for processing input.") XCL::PROFILE (* ; "Optional profile, sets the exec's bindings.") XCL::ID (* ; "A handle on the exec.") &ALLOW-OTHER-KEYS (* ; "To catch obsolete calls") &AUX (*EXEC-ID* (PROCESS-EXEC-ID (THIS.PROCESS) XCL::ID)) (XCL::PROFILE-CACHE (XCL::GET-PROCESS-PROFILE (THIS.PROCESS))) (* ; "The exec's cached profile (if entering from a hardreset).")) (CL:PROGV (MAPCAR *PER-EXEC-VARIABLES* (FUNCTION CAR)) (MAPCAR *PER-EXEC-VARIABLES* (FUNCTION (LAMBDA (XCL::X) (EVAL (CADR XCL::X))))) (CL:WHEN (OR (NULL XCL::TOP-LEVEL-P) (NULL XCL::PROFILE-CACHE)) (* ; "If not hardresetting...") (CL:WHEN XCL::PROFILE (* ; "then initialize the profile vars.") (XCL:RESTORE-PROFILE XCL::PROFILE)) (CL:WHEN XCL::PROMPT (* ; "If a special prompt was provided (as from the debugger)...") (CL:SETQ XCL:*EXEC-PROMPT* XCL::PROMPT) (* ; "...use it."))) (CL:WHEN XCL::TOP-LEVEL-P (CL:IF (NULL XCL::PROFILE-CACHE) (* ; "This was a new entry into top level exec.") (CL:SETF (XCL::GET-PROCESS-PROFILE (THIS.PROCESS)) (XCL:SAVE-PROFILE (XCL:COPY-PROFILE "EXEC"))) (* ; "...make a fresh cache and save bindings into it.") (XCL:RESTORE-PROFILE XCL::PROFILE-CACHE) (* ; "...otherwise it was a HARDRESET."))) (CL:WHEN XCL::WINDOW (COND ((NOT XCL::TITLE-SUPPLIED) (* ; "If no title was supplied, set it to the default.") (XCL::EXEC-TITLE-FUNCTION XCL::WINDOW *EXEC-ID*)) (XCL::TITLE (* ; "If a non-nil title was supplied, set the title to it.") (WINDOWPROP XCL::WINDOW (QUOTE TITLE) XCL::TITLE))) (TTYDISPLAYSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM XCL::WINDOW))) (LET ((*CURRENT-EVENT* NIL) (* ; "the event being processed. Used by some commands") (XCL::OLD-DS (CL:IF XCL::WINDOW (TTYDISPLAYSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM XCL::WINDOW))))) (CL:LOOP (CL:FORMAT T "~&~%%") (* ; "newlines to notice that this is a new instance of the exec") (PROG1 (ERSETQ (CL:LOOP (* ; "loop until errors out") (CL:SETQ *CURRENT-EVENT* (GET-NEXT-HISTORY-EVENT LISPXHISTORY *EXEC-ID* XCL:*EXEC-PROMPT* (NOT XCL::TOP-LEVEL-P))) (* ; "This optimization keeps HARDRESET from generating all new event numbers for all execs that are open.") (PRINT-EVENT-PROMPT *CURRENT-EVENT*) (DSPFONT INPUTFONT T) (LET ((XCL::ORIGINAL-INPUT (EXEC-READ-LINE)) (LISPXHIST LISPXHIST) (HELPCLOCK 0)) (DECLARE (CL:SPECIAL LISPXHIST HELPCLOCK)) (CL:UNLESS (CL:EQUAL XCL::ORIGINAL-INPUT (QUOTE (NIL))) (DO-EVENT XCL::ORIGINAL-INPUT XCL::ENVIRONMENT XCL::FN) (CL:WHEN XCL::TOP-LEVEL-P (* ; "Used to determine whether to cache the settings of the profile back into the process (for retrieval in case of hardreset).") (XCL::SAVE-CURRENT-EXEC-PROFILE)))))) (CL:WHEN XCL::WINDOW (TTYDISPLAYSTREAM XCL::OLD-DS)))))))
+
+(CL:DEFUN EXEC-EVAL (FORM &OPTIONAL ENVIRONMENT &KEY (PROMPT ">") (ID "eval/") ((:TYPE *CURRENT-EXEC-TYPE*) (QUOTE COMMON-LISP))) (* ; "Edited by JDS 16-Aug-90 12:55.") (LET ((*CURRENT-EVENT* (GET-NEXT-HISTORY-EVENT LISPXHISTORY ID PROMPT T)) (LISPXHIST LISPXHIST) (HELPCLOCK 0) VALUES) (DECLARE (CL:SPECIAL *CURRENT-EVENT* LISPXHIST HELPCLOCK)) (SETQ VALUES (CL:MULTIPLE-VALUE-LIST (EVAL-INPUT (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) (LIST FORM)) ENVIRONMENT))) (SETQ IT (CAR VALUES)) (COND (*CURRENT-EVENT* (* ;; "Only update the current event if it's not NIL.  This might happen, e.g., if LISPXHIST has been set to NIL by the user.") (CL:SETF (EXEC-EVENT-PROPS *CURRENT-EVENT*) (LIST* (QUOTE LISPXVALUES) VALUES (EXEC-EVENT-PROPS *CURRENT-EVENT*))) (CL:SETF (EXEC-EVENT-VALUE *CURRENT-EVENT*) IT))) (CL:VALUES-LIST VALUES)))
+
+(CL:DEFUN PRINT-ALL-DOCUMENTATION (NAME) "Print all documentation strings for NAME (as symbol and string)." (LET ((FOUND NIL)) (CL:DOLIST (TYPE FILEPKGTYPES) (CL:WHEN (AND (CL:SYMBOLP TYPE) (GET TYPE (QUOTE DEFINED-BY)) (HASH-TABLE-FOR-DOC-TYPE TYPE)) (SETQ FOUND (OR (PRINT-DOCUMENTATION NAME TYPE) FOUND)) (CL:WHEN (CL:SYMBOLP NAME) (SETQ FOUND (OR (PRINT-DOCUMENTATION (STRING NAME) TYPE) FOUND))))) (CL:UNLESS FOUND (CL:FORMAT *TERMINAL-IO* "No documentation found.~%%"))))
+
+(CL:DEFUN PRINT-DOCUMENTATION (NAME TYPE) "If it exists, print documentation for NAME as TYPE.  Returns T if doc was found, else NIL." (LET ((DOC (CL:DOCUMENTATION NAME TYPE))) (AND DOC (TRUE (CL:FORMAT *TERMINAL-IO* "~&~A (~A)" DOC (OR (CL:DOCUMENTATION NAME (QUOTE DEFINE-TYPES)) TYPE))))))
+
+(DEFMACRO VALUE-OF (&REST EVENT-SPEC) (BQUOTE (EXEC-VALUE-OF (QUOTE (\, EVENT-SPEC)))))
+
+(CL:DEFUN ADD-EXEC (&KEY (XCL::PROFILE XCL:*PROFILE*) XCL::REGION XCL::TTY (EXEC (QUOTE EXEC)) XCL::ID &ALLOW-OTHER-KEYS) (LET* ((XCL::WINDOW (XCL::SETUP-EXEC-WINDOW (CREATEW XCL::REGION "Exec"))) (XCL::HANDLE (ADD.PROCESS (BQUOTE (PROGN (TTYDISPLAYSTREAM (QUOTE (\, XCL::WINDOW))) (PROCESSPROP (THIS.PROCESS) (QUOTE WINDOW) (QUOTE (\, XCL::WINDOW))) (\, (CASE EXEC (EXEC (BQUOTE (EXEC :TOP-LEVEL-P T :PROFILE (QUOTE (\, XCL::PROFILE)) :ID (QUOTE (\, XCL::ID))))) (T (BQUOTE (XCL::ENTER-EXEC-FUNCTION (QUOTE (\, EXEC)) (QUOTE (\, XCL::PROFILE)) (QUOTE (\, XCL::ID))))))))) (QUOTE NAME) (QUOTE EXEC) (QUOTE RESTARTABLE) T))) (AND XCL::TTY (TTY.PROCESS XCL::HANDLE)) XCL::HANDLE))
+
+(CL:DEFUN EXEC-READ-LINE (&OPTIONAL BUFFER-STRING) (* ;; "Code stolen from READLINE, and not cleaned up. ") (PROG (LINE SPACEFLG CHRCODE (*IN-THE-DEBUGGER* NIL)) (COND ((AND (READP T) (SYNTAXP (PEEKCCODE T T) (QUOTE EOL))) (* ; "Avoid picking up end of line as a NIL.") (READC T))) (SETQ LINE (LIST (EXEC-READ BUFFER-STRING))) TOP (COND ((LISTP (CAR LINE)) (* ; "If we got a list, return right away--it's a standard EVAL form of input") (GO OUT))) LP (SETQ SPACEFLG NIL) (* ; "to distinguish between") (* ; "FOO (A B)") (* ; "FOO(A B)") (* ; "the latter has no space and returns right away") LP1 (COND ((NOT (READP T)) (* ; "nothing more in line buffer, so must have consumed last thing on the line") (GO OUT)) ((NULL (SETQ CHRCODE (PEEKCCODE T T))) (* ; "PEEKCCODE can return NIL when stream is at EOF.  However, we already checked for READP before getting here.") (GO OUT)) ((SYNTAXP CHRCODE (QUOTE EOL)) (READC T) (GO OUT)) ((OR (SYNTAXP CHRCODE (QUOTE RIGHTPAREN) *READTABLE*) (SYNTAXP CHRCODE (QUOTE RIGHTBRACKET) *READTABLE*)) (AND (READ T *READTABLE*) (SHOULDNT)) (AND (NULL (CDR LINE)) (SETQ LINE (NCONC1 LINE NIL))) (* ; " A %")%" is treated as NIL if it is the second thing on the line when EXEC-READ-LINE is called") (GO OUT)) ((EQ CHRCODE (CHARCODE SPACE)) (SETQ SPACEFLG T) (READC T) (GO LP1))) (SETQ LINE (NCONC1 LINE (EXEC-READ))) (COND ((NULL (OR (SYNTAXP (SETQ CHRCODE (CHCON1 (LASTC T))) (QUOTE RIGHTPAREN) *READTABLE*) (SYNTAXP CHRCODE (QUOTE RIGHTBRACKET) *READTABLE*))) (GO LP)) ((NOT SPACEFLG) (* ; "A list terminates the line if it is the second element on the line, not preceded by a space.") (* ;; "[JDS 1/12/88:  This used to test (AND (NOT SPACEFLG) (READP T)), and loop if there were more input pending.  This seems wrong, because when you type it should throw the carriage at once, and not depend on how fast you're typing.  Further, when there's type-ahead, it's often followed by a SPACE, to prevent output pausing.  With the old test here, that would hang up a final eval-quote form without executing it.]") (GO OUT)) (T (GO LP))) (GO LP) OUT (RETURN (COND ((AND (LISTP LINE) CTRLUFLG) (* ; "Edit interrupt during reading--forces structure editor use.") (SETQ CTRLUFLG NIL) (LET ((*EDIT-INPUT-WITH-TTYIN* NIL)) (FIX-FORM LINE))) (T LINE)))))
+
+(DEFMACRO EXEC-EVENT-ID-PROMPT (EVENT-ID) (BQUOTE (CDDR (\, EVENT-ID))))
+
+(CL:DEFUN FIND-EXEC-COMMAND (NAME TABLE) "Find an exec command based on its name (either a string or a symbol).  Returns the command entry or NIL if not found." (CL:WHEN (OR (CL:STRINGP NAME) (CL:SYMBOLP NAME)) (LET ((STR (CL:IF (CL:SYMBOLP NAME) (CL:SYMBOL-NAME NAME) NAME))) (CL:SOME (CL:FUNCTION (CL:LAMBDA (TABLE) (SETQ COM (GETHASH STR TABLE)))) TABLE))))
+
+(CL:DEFUN CIRCLAR-COPYER (INPUT) (* ; "Edited by TT 31-May-1990") (PROG (SCANBUF REST VAL NEW BODY ID AUX (CIRCLAR-FLAG NIL)) (COND ((NLISTP INPUT) (RETURN INPUT)) (T (push SCANBUF (CONS INPUT (SETQ VAL (CONS NIL NIL)))) (push REST VAL) (RPLACA VAL (CAR INPUT)) (RPLACD VAL (CDR INPUT)) (* ;;; "(COND ((EQ X (CAR X)) (RPLACA VAL VAL)) (T (RPLACA VAL (CAR X)))) (COND ((EQ X (CDR X)) (RPLACD VAL VAL)) (T (RPLACD VAL (CDR X))))"))) (* ; "Initialization is over") LP (SETQ BODY (pop REST)) LP0 (COND ((NULL BODY) (RETURN (CL:VALUES VAL CIRCLAR-FLAG))) ((NLISTP BODY) (GO LP)) (T (SETQ NEW BODY) (COND ((NLISTP (CDR NEW))) ((SETQ ID (FASSOC (CDR NEW) SCANBUF)) (SETQ CIRCLAR-FLAG T) (RPLACD NEW (CDR ID))) (T (push REST (SETQ AUX (CONS (CADR NEW) (CDDR NEW)))) (push SCANBUF (CONS (CDR NEW) AUX)) (RPLACD NEW AUX))) (COND ((NLISTP (CAR NEW))) ((SETQ ID (FASSOC (CAR NEW) SCANBUF)) (SETQ CIRCLAR-FLAG T) (RPLACA NEW (CDR ID))) (T (push REST (SETQ AUX (CONS (CAAR NEW) (CDAR NEW)))) (push SCANBUF (CONS (CAR NEW) AUX)) (RPLACA NEW AUX))))) (GO LP)))
+(DEFINEQ
+
+(COPY-CIRCLE
+(LAMBDA (X) (* ; "Edited 23-May-90 15:02 by Tomtom") (PROG (SCANBUF REST VAL NEW BODY ID AUX) (COND ((NLISTP X) (RETURN X)) (T (push SCANBUF (CONS X (SETQ VAL (CONS NIL NIL)))) (push REST VAL) (RPLACA VAL (CAR X)) (RPLACD VAL (CDR X)) (* ;;; "(COND ((EQ X (CAR X)) (RPLACA VAL VAL)) (T (RPLACA VAL (CAR X)))) (COND ((EQ X (CDR X)) (RPLACD VAL VAL)) (T (RPLACD VAL (CDR X))))"))) (* ; "Initialization is over") LP (SETQ BODY (pop REST)) LP0 (COND ((NULL BODY) (RETURN VAL)) ((NLISTP BODY) (GO LP)) (T (SETQ NEW BODY) (COND ((NLISTP (CDR NEW))) ((SETQ ID (FASSOC (CDR NEW) SCANBUF)) (RPLACD NEW (CDR ID))) (T (push REST (SETQ AUX (CONS (CADR NEW) (CDDR NEW)))) (push SCANBUF (CONS (CDR NEW) AUX)) (RPLACD NEW AUX))) (COND ((NLISTP (CAR NEW))) ((SETQ ID (FASSOC (CAR NEW) SCANBUF)) (RPLACA NEW (CDR ID))) (T (push REST (SETQ AUX (CONS (CAAR NEW) (CDAR NEW)))) (push SCANBUF (CONS (CAR NEW) AUX)) (RPLACA NEW AUX))))) (GO LP)))
+)
+)
+
+
+
+(* ; "CIRCLAR-COPYER and COPY-CIRCLE are the solution for AR#11172")
+
+(DEFINEQ
+
+(EXEC-READ
+  [CL:LAMBDA (&OPTIONAL BUFFER-STRING)                   (* ; "Edited  4-Feb-88 18:22 by amd")
+
+(* ;;; "Reads structure from the user (in the exec), taking care to handle read errors so that they will be edited and fixed.")
+
+         (HANDLER-BIND [[XCL:SYMBOL-COLON-ERROR #'(LAMBDA (CONDITION)
+                                                    (DECLARE (CL:SPECIAL CTRLUFLG))
+                                                    (CL:FORMAT *TERMINAL-IO* "~a~%%" CONDITION)
+                                                    (SETQ CTRLUFLG T)
+                                                    (XCL::ESCAPE-COLONS-PROCEED)
+                                                    (SHOULDNT 
+                                                           "Didn't find XCL::ESCAPE-COLONS-PROCEED"]
+                        [XCL:MISSING-EXTERNAL-SYMBOL #'(LAMBDA (CONDITION)
+                                                         (DECLARE (CL:SPECIAL CTRLUFLG))
+                                                         (CL:FORMAT *TERMINAL-IO* "~a~%%" CONDITION)
+                                                         (SETQ CTRLUFLG T)
+                                                         (XCL:MAKE-INTERNAL-PROCEED)
+                                                         (SHOULDNT 
+                                                              "Didn't find XCL:MAKE-INTERNAL-PROCEED"
+                                                                ]
+                        (XCL:MISSING-PACKAGE #'(LAMBDA (CONDITION)
+                                                 (DECLARE (CL:SPECIAL CTRLUFLG))
+                                                 (CL:FORMAT *TERMINAL-IO* "~a~%%" CONDITION)
+                                                 (SETQ CTRLUFLG T)
+                                                 (XCL:UGLY-SYMBOL-PROCEED)
+                                                 (SHOULDNT "Didn't find XCL:UGLY-SYMBOL-PROCEED"]
+                (COND
+                   ([OR (NOT (GETD 'TTYIN))
+                        (NOT *EDIT-INPUT-WITH-TTYIN*)
+                        (NOT (DISPLAYSTREAMP (GETSTREAM T 'OUTPUT]
+                                                             (* ; 
+                                                 "If debugging and TTYIN breaks, don't want to die")
+
+                    (CL:READ T))
+                   (T (LET (X)
+                           (COND
+                              ((OR (LINEBUFFER-SKIPSEPRS T *READTABLE*)
+                                   (until (SETQ X (TTYIN "" NIL NIL '(EVALQT FILLBUFFER NOPROMPT) 
+                                                             NIL NIL BUFFER-STRING *READTABLE*))
+                                      do 
+          
+          (* ;; "Until he types something at all, keep printing the event-number prompt.")
+
+                                            (PRINT-EVENT-PROMPT *CURRENT-EVENT*)
+                                            (DSPFONT INPUTFONT T))
+                                   (EQ X T))
+                               (CL:READ-PRESERVING-WHITESPACE T))
+                              (T (CAR X])
+
+(DIR
+  [NLAMBDA ARGS                                              (* ; "Edited 12-Mar-87 16:08 by raf")
+
+    (DODIR ARGS])
+)
+
+(CL:DEFPARAMETER *PER-EXEC-VARIABLES* (QUOTE ((CL:* CL:*) (CL:** CL:**) (CL:*** CL:***) (+ +) (CL:++ CL:++) (CL:+++ CL:+++) (- -) (/ /) (CL:// CL://) (CL:/// CL:///) (HELPFLAG T) (*EVALHOOK* NIL) (*APPLYHOOK* NIL) (*ERROR-OUTPUT* *TERMINAL-IO*) (*READTABLE* *READTABLE*) (*PACKAGE* *PACKAGE*) (XCL:*EVAL-FUNCTION* XCL:*EVAL-FUNCTION*) (XCL:*EXEC-PROMPT* XCL:*EXEC-PROMPT*) (XCL:*DEBUGGER-PROMPT* XCL:*DEBUGGER-PROMPT*))) "List of (non-profile) variables rebound for each Exec")
+
+(CL:DEFVAR CL:* NIL)
+
+(CL:DEFVAR CL:** NIL)
+
+(CL:DEFVAR CL:*** NIL)
+
+(CL:DEFVAR + NIL)
+
+(CL:DEFVAR CL:++ NIL)
+
+(CL:DEFVAR CL:+++ NIL)
+
+(CL:DEFVAR - NIL)
+
+(CL:DEFVAR / NIL "Holds a list of all the values returned by the most recent top-level EVAL.")
+
+(CL:DEFVAR CL:// NIL "Gets the previous value of / when a new value is computed.")
+
+(CL:DEFVAR CL:/// NIL "Gets the previous value of // when a new value is computed.")
+
+(CL:DEFVAR *CURRENT-EVENT* NIL "contains the current event being processed. Used for communicating between Exec and commands")
+
+(CL:DEFVAR *EXEC-ID* NIL "A unique per-exec-process ID so that commands that search the history list can find this Exec's events")
+
+(CL:DEFVAR XCL:*EXEC-PROMPT* "> " "Default prompt used by exec")
+
+(CL:DEFPARAMETER XCL:*EVAL-FUNCTION* (QUOTE CL:EVAL) "The evaluator to use in the exec")
+
+(CL:DEFVAR *NOT-YET-EVALUATED* "<not yet evaluated>")
+
+(CL:DEFVAR *THIS-EXEC-COMMANDS* NIL "List of command hash-tables for the current executive")
+
+(DEFGLOBALVAR *EXEC-COMMAND-TABLE* (HASHARRAY 30 NIL (QUOTE STRING-EQUAL-HASHBITS) (QUOTE STRING-EQUAL)) "hash-table for top level exec commands")
+
+(DEFGLOBALVAR *DEBUGGER-COMMAND-TABLE* (HASHARRAY 20 NIL (QUOTE STRING-EQUAL-HASHBITS) (QUOTE STRING-EQUAL)) "string-equal hash-table for debugger commands")
+
+(CL:DEFVAR *CURRENT-EXEC-TYPE* NIL "Rebound under Exec; if NIL, means use default")
+
+(CL:DEFPARAMETER *EXEC-MAKE-UNDOABLE-P* T "global parameter controls whether the exec makes input undoable")
+
+(CL:DEFVAR *EDIT-INPUT-WITH-TTYIN* T)
+(DEFINEQ
+
+(DO-APPLY-EVENT
+  [LAMBDA (TODO)                                             (* lmm "31-Jul-86 03:22")
+    (CL:IF (CL:MACRO-FUNCTION (CAR TODO))
+           (CL:IF (EQ (ARGTYPE (CAR TODO))
+                             3)
+                  (CL:FUNCALL (CAR TODO)
+                         (CL:IF (CDDR TODO)
+                                (CDR TODO)
+                                (CADR TODO)))
+                  (CL:EVAL TODO))
+           (CL:APPLY (CAR TODO)
+                  (CADR TODO])
+
+(DO-HISTORY-SEARCH
+  [LAMBDA (SPEC PRED-P VALUE-P)                              (* ; "Edited 10-Mar-87 18:53 by raf")
+          
+          (* ;; 
+          "SEARCHES HISTORY LIST, LOOKING FOR SPEC AND RESETTING *EVENTS* TO THE CORRESPONDING TAIL.")
+
+    (PROG (PAT1 PAT2 TEM PRED)
+              (DECLARE (CL:SPECIAL *EVENTS*))            (* ; "Setup by FIND-HISTORY-EVENTS")
+
+              [COND
+                 ((NOT PRED-P)
+                  (SETQ PAT2 (EDITFPAT SPEC T]
+          LP  [COND
+                 ((EQ (CAR *EVENTS*)
+                         *CURRENT-EVENT*)
+                  (SETQ *EVENTS* (CDR *EVENTS*]
+              [COND
+                 ((COND
+                     (PRED-P (APPLY* SPEC (CAR *EVENTS*)))
+                     [PAT1 (EDIT4E PAT1 (CAR (EXEC-EVENT-INPUT (CAR *EVENTS*]
+                     (T (EDITFINDP [COND
+                                          (VALUE-P (CL:GETF (EXEC-EVENT-PROPS (CAR *EVENTS*))
+                                                          'LISPXVALUES))
+                                          (T (EXEC-EVENT-INPUT (CAR *EVENTS*]
+                               PAT2 T)))
+                  (RETURN *EVENTS*))
+                 (T (SETQ *EVENTS* (CDR *EVENTS*]
+          LP1 (COND
+                 ((NULL *EVENTS*)
+                  (RETURN NIL)))
+              (GO LP])
+
+(EVAL-INPUT
+  [CL:LAMBDA
+   (TODO ENV)                                                (* ; "Edited 23-Nov-87 13:07 by raf")
+
+   (CASE XCL:*EVAL-FUNCTION*
+         [EVAL                                           (* ; "Interlisp EVAL")
+
+                (COND
+                   [(CDR TODO)                           (* ; "this is the 'apply' case")
+          
+          (* ;; "we first check for input of things like macros in apply format or Interlisp NLAMBDA functions (which have a MACRO-FUNCTION)")
+
+                    (if [OR (CDDR TODO)
+                               (AND (CADR TODO)
+                                      (NLISTP (CADR TODO]
+                        then
+                        (if (FMEMB (ARGTYPE (CAR TODO))
+                                   '(1 3))
+                            then                             (* ; 
+                                  "this is an Interlisp NLAMBDA function (1 = spread, 3 = nospread).")
+
+                            [if (AND (EQ (ARGTYPE (CAR TODO))
+                                                3)
+                                       (CDDR TODO))
+                                then
+                                (APPLY (CAR TODO)
+                                       (CDR TODO))
+                                else
+                                (if (CDDR TODO)
+                                    then
+                                    (PRIN1 "... = ")
+                                    (PRINT TODO)
+                                    (APPLY (CAR TODO)
+                                           (CDR TODO))
+                                    else
+                                    (APPLY (CAR TODO)
+                                           (CADR TODO]
+                            else
+          
+          (* ;; "evaluate the entire input list as if it were typed in with parens around it, e.g.  a 'FOR I FROM 1 TO 10 DO ...' possibly bogus 'DWIM' case")
+
+                            (EVAL TODO))
+                        else                                 (* ; "a normal apply case")
+
+                        (if (CDDR TODO)
+                            then
+                            (PRIN1 "... = ")
+                            (PRINT TODO)
+                            (APPLY (CAR TODO)
+                                   (MAPCAR (CDR TODO)
+                                          (FUNCTION EVAL)))
+                            else
+                            (APPLY (CAR TODO)
+                                   (CADR TODO]
+                   (T                                        (* ; "a normal eval case")
+
+                      (EVAL (CAR TODO]
+         (T                                                  (* ; "Common Lisp EVAL")
+          
+          (* ;; "maybe should have used ECASE and checked for Common-Lisp explicitly, but could get recursive errors if *current-exec-type* was rebound")
+
+            (COND
+               [(CDR TODO)                               (* ; "this is the 'apply' case")
+          
+          (* ;; "we first check for input of things like macros in apply format or Interlisp NLAMBDA functions (which have a MACRO-FUNCTION)")
+
+                (COND
+                   [(CL:MACRO-FUNCTION (CAR TODO))
+                    (COND
+                       [(FMEMB (ARGTYPE (CAR TODO))
+                               '(1 3))                       (* ; 
+                                  "this is an Interlisp NLAMBDA function (1 = spread, 3 = nospread).")
+
+                        (COND
+                           ((AND (EQ (ARGTYPE (CAR TODO))
+                                            3)
+                                   (CDDR TODO))
+                            (APPLY (CAR TODO)
+                                   (CDR TODO)))
+                           (T (COND
+                                 ((CDDR TODO)
+                                  (PRIN1 "... = ")
+                                  (PRINT TODO)
+                                  (APPLY (CAR TODO)
+                                         (CDR TODO)))
+                                 (T (APPLY (CAR TODO)
+                                           (CADR TODO]
+                       (T 
+          
+          (* ;; "evaluate the entire input list as if it were typed in with parens around it, e.g.  a 'FOR I FROM 1 TO 10 DO ...' possibly bogus 'DWIM' case")
+
+                          (CL:EVAL TODO ENV]
+                   (T                                        (* ; "a normal apply case")
+
+                      (COND
+                         [(CDDR TODO)
+                          (PRIN1 "... = ")
+                          (PRINT TODO)
+                          (CL:APPLY (CAR TODO)
+                                 (CL:MAPCAR #'(CL:LAMBDA (A)
+                                                         (CL:EVAL A ENV)) (CDR TODO]
+                         (T (CL:APPLY (CAR TODO)
+                                   (CADR TODO]
+               (T                                            (* ; "a normal eval case")
+
+                  (CL:EVAL (CAR TODO)
+                         ENV])
+
+(EVENTS-INPUT
+  [CL:LAMBDA (EVENTS)                                        (* ; "Edited 26-Nov-86 11:16 by lmm")
+                                                             (* ; 
+     "takes a list of events and returns the input concatenated into a single event, as appropriate ")
+
+         (IF (CDR EVENTS)
+             THEN
+             [CONS 'DO-EVENTS (FOR EVENT IN EVENTS COLLECT (IF (CDR (EXEC-EVENT-INPUT
+                                                                             EVENT))
+                                                                   THEN
+                                                                   (CONS 'EVENT (
+                                                                                   EXEC-EVENT-INPUT
+                                                                                     EVENT))
+                                                                   ELSE
+                                                                   (CAR (EXEC-EVENT-INPUT
+                                                                             EVENT]
+             ELSE
+             (LET* ((INPUT (EXEC-EVENT-INPUT (CAR EVENTS)))
+                        (TAIL (FMEMB HISTSTR0 INPUT)))
+                    (IF TAIL THEN (LDIFF INPUT TAIL)
+                        ELSE INPUT])
+
+(EXEC-PRIN1
+  (CL:LAMBDA (VALUE)                                         (* ; "Edited 23-Feb-87 18:15 by raf")
+
+         (WRITE VALUE :STREAM *TERMINAL-IO* :ESCAPE T)))
+
+(EXEC-VALUE-OF
+  [LAMBDA (EVENT-SPEC)                                       (* lmm "11-Sep-86 17:28")
+    (CL:VALUES-LIST (LISTGET (EXEC-EVENT-PROPS (CAR (FIND-HISTORY-EVENTS EVENT-SPEC 
+                                                                       LISPXHISTORY)))
+                               'LISPXVALUES])
+
+(GET-NEXT-HISTORY-EVENT
+  [LAMBDA (HISTORY ID PROMPT FIRST-ONLY)                     (* ; "Edited  2-Mar-87 15:34 by raf")
+
+    (for EVENT in (HISTORY-EVENTS HISTORY)
+         do
+         (CL:WHEN (EQ (CADR (LISTP (EXEC-EVENT-ID EVENT)))
+                         ID)
+                (CL:IF (AND (NULL (EXEC-EVENT-INPUT EVENT))
+                                  (NULL (EXEC-EVENT-PROPS EVENT)))
+                       (PROGN (CL:SETF (CDDR (EXEC-EVENT-ID EVENT))
+                                         PROMPT)
+                              (RETURN EVENT))
+                       (GO $$OUT)))
+         (if FIRST-ONLY then                                 (* ; "only do this for the first event")
+
+             (GO $$OUT))
+         finally
+         (COND
+            (HISTORY                                         (* ; "Watch out for NIL LISPXHISTORY")
+
+                   (SETQ EVENT (MAKE-EXEC-EVENT :ID (LIST* (CL:INCF (HISTORY-INDEX
+                                                                                 HISTORY))
+                                                                   ID PROMPT)))
+                   (CL:PUSH EVENT (HISTORY-EVENTS HISTORY))
+                   (CL:SETF (CDR (CL:NTHCDR (CL:1- (HISTORY-SIZE HISTORY))
+                                            (HISTORY-EVENTS HISTORY)))
+                          NIL)
+                   (RETURN EVENT])
+
+(HISTORY-ADD-TO-SPELLING-LISTS
+  [LAMBDA (INPUT)                                        (* lmm "31-Jul-86 02:22")
+    (COND
+       ((CDR INPUT)                                      (* ; 
+                                                    "Add to the spelling list if it has a definition")
+
+        (AND (LITATOM (CAR INPUT))
+               (FGETD (CAR INPUT))
+               (ADDSPELL (CAR INPUT)
+                      2)))
+       ([AND (CL:CONSP (CAR INPUT))
+               (LITATOM (CAR (CAR INPUT]         (* ; "looks like a valid function")
+
+        (AND [OR (CL:FBOUNDP (CAR (CAR INPUT)))
+                        (CL:SPECIAL-FORM-P (CAR (CAR INPUT]
+               (ADDSPELL (CAR (CAR INPUT))
+                      2)))
+       ((AND (CL:SYMBOLP (CAR INPUT))
+               (BOUNDP (CAR INPUT)))
+        (ADDSPELL (CAR INPUT)
+               3])
+
+(HISTORY-NTH
+  [LAMBDA (LST N ID)                                         (* lmm " 6-Nov-86 01:40")
+    (bind EVENT while LST do (if (<= N 0)
+                                 then
+                                 (RETURN))
+          (SETQ EVENT (CAR LST))
+          (CL:IF (AND (EXEC-EVENT-INPUT EVENT)
+                            (NEQ EVENT *CURRENT-EVENT*)
+                            (OR (NOT (STRINGP ID))
+                                   (EQ (CADR (LISTP (EXEC-EVENT-ID EVENT)))
+                                          ID)))
+                 (if (<= (CL:DECF N)
+                      0)
+                     then
+                     (RETURN LST)))
+          (pop LST])
+
+(PRINT-HISTORY
+  [CL:LAMBDA (HISTORY EVENT-SPECS &OPTIONAL NOVALUES)        (* lmm " 5-Nov-86 23:29")
+         (PROG [HELPCLOCK (EVENTS (CL:IF EVENT-SPECS (FIND-HISTORY-EVENTS EVENT-SPECS 
+                                                                    HISTORY)
+                                             (HISTORY-EVENTS HISTORY]
+                   (TERPRI T)
+                   (for X in EVENTS do (PRINT-EVENT X NOVALUES)
+                        (FRESHLINE T)
+                        (TERPRI T))
+                   (TERPRI T)
+                   (RETURN (CL:VALUES])
+
+(FIND-HISTORY-EVENTS
+  [LAMBDA (EVENT-SPEC HISTORY)                               (* ; "Edited  6-Nov-87 15:22 by raf")
+
+    (PROG [(*EVENTS* (HISTORY-EVENTS HISTORY))
+               (ORIGINAL-EVENT-SPEC EVENT-SPEC)
+               SPEC TEM VALUE-P VAL PRED-P ALL-P (AND-SPEC (CL:MEMBER "AND" EVENT-SPEC :TEST
+                                                                  'STRING.EQUAL]
+              (DECLARE (CL:SPECIAL *EVENTS*))            (* ; "Used by DO-HISTORY-SEARCH")
+
+              [if AND-SPEC then (RETURN (APPEND (SETQ *EVENTS* (FIND-HISTORY-EVENTS
+                                                                            (LDIFF EVENT-SPEC 
+                                                                                   AND-SPEC)
+                                                                            HISTORY))
+                                                   (for X in (FIND-HISTORY-EVENTS (CDR 
+                                                                                             AND-SPEC
+                                                                                             )
+                                                                    HISTORY)
+                                                        when
+                                                        (NOT (FMEMB X *EVENTS*))
+                                                        collect X]
+          LP  (CL:WHEN (EQ (CAR *EVENTS*)
+                              *CURRENT-EVENT*)
+                     (SETQ *EVENTS* (CDR *EVENTS*)))
+              [CASE-EQUALP (SETQ SPEC (CAR EVENT-SPEC))
+                     (ALL (SETQ ALL-P T)
+                          (pop EVENT-SPEC)
+                          (GO LP))
+                     (F [COND
+                           ((SETQ TEM (CDR EVENT-SPEC))
+                                                             (* ; 
+        "Otherwise, F is not a special symbol, e.g.  user types REDO F, meaning search for F itself.")
+
+                            (SETQ EVENT-SPEC (CDR EVENT-SPEC))
+                            (SETQ SPEC (CAR EVENT-SPEC]
+                        (DO-HISTORY-SEARCH SPEC PRED-P VALUE-P))
+                     [FROM (LET ((EVENTS (FIND-HISTORY-EVENTS (CDR EVENT-SPEC)
+                                                    HISTORY)))
+                                  (CL:WHEN (CDR EVENTS)
+                                         (ERROR "from?"))
+                                  (RETURN (REVERSE (LDIFF *EVENTS*
+                                                                  (CDR (CL:MEMBER
+                                                                            (CAR EVENTS)
+                                                                            *EVENTS*]
+                     (SUCHTHAT 
+          
+          (* ;; "What follows SUCHTHAT is a function to be applied to the entire event;  and if true, approves that event.")
+
+                            (SETQ PRED-P T)
+                            (SETQ EVENT-SPEC (CDR EVENT-SPEC))
+                            (SETQ SPEC (CAR EVENT-SPEC))
+                            (DO-HISTORY-SEARCH SPEC PRED-P VALUE-P))
+                     (= (SETQ VALUE-P T)
+                            (GO LP))
+                     (T (COND
+                           ((NOT (CL:INTEGERP SPEC))
+                            (DO-HISTORY-SEARCH SPEC PRED-P VALUE-P)
+                                                             (* ; "Does searching.")
+
+                            )
+                           [(< SPEC 0)                   (* ; "count backward")
+
+                            (SETQ *EVENTS* (HISTORY-NTH *EVENTS* (- SPEC)
+                                                      (AND (NOT ALL-P)
+                                                             *EXEC-ID*]
+                           (T                                (* ; "absolute event number")
+
+                              (SETQ *EVENTS* (SEARCH-FOR-EVENT-NUMBER *EVENTS* HISTORY SPEC]
+              [COND
+                 ((NULL *EVENTS*)
+                  (COND
+                     (ALL-P (RETURN VAL)))
+                  (ERROR SPEC '" ?" T))
+                 ((NULL (SETQ EVENT-SPEC (CDR EVENT-SPEC)))
+                  (COND
+                     [(NULL ALL-P)
+                      (RETURN (LIST (CAR *EVENTS*]
+                     (T (SETQ VAL (NCONC1 VAL (CAR *EVENTS*)))
+                        (SETQ EVENT-SPEC ORIGINAL-EVENT-SPEC]
+              (SETQ *EVENTS* (CDR *EVENTS*))
+              (CL:WHEN (EQ (CAR *EVENTS*)
+                              *CURRENT-EVENT*)
+                     (SETQ *EVENTS* (CDR *EVENTS*)))
+              (SETQ VALUE-P NIL)
+              (SETQ PRED-P NIL)
+              (GO LP])
+
+(PRINT-EVENT
+  [CL:LAMBDA (EVENT &OPTIONAL NOVALUES)                      (* ; "Edited  9-Mar-87 11:02 by raf")
+
+         (PROG ((INPUT (EXEC-EVENT-INPUT EVENT))
+                    (FILE (\GETSTREAM T 'OUTPUT))
+                    (POSITION (STRINGWIDTH "99/9999>" T))
+                    Y TEM EVENT#)
+                   (FRESHLINE FILE)
+                   (if (SETQ TEM (LISTGET (EXEC-EVENT-PROPS EVENT)
+                                            '*HISTORY*))
+                       then
+                       (DSPXPOSITION POSITION FILE)
+                       (CL:FORMAT FILE "~{~S ~}~&" TEM))
+                   (PRINT-EVENT-PROMPT EVENT)
+                   (DSPXPOSITION (MAX POSITION (DSPXPOSITION NIL FILE))
+                          T)
+                   (DSPFONT INPUTFONT FILE)
+               LP  [COND
+                      ((SETQ Y (FMEMB HISTSTR0 (LISTP INPUT)))
+                       (SETQ INPUT (LDIFF INPUT Y]
+                   [COND
+                      [(NLISTP INPUT)
+                       (COND
+                          ((NULL INPUT)
+                           (if (EXEC-EVENT-PROPS EVENT)
+                               then                          (* ; "don't do anything")
+
+                               else
+                               (PRIN1 "<in progress>" FILE)))
+                          (T                                 (* ; "shouldn't happen??")
+
+                             (EXEC-PRIN1 INPUT]
+                      [(CDDR INPUT)                      (* ; 
+                                                             "a command, just print out all elements")
+
+                       (CASE (CAR INPUT)
+                             (DO-EVENTS                      (* ; 
+                                                             " special generated combination event")
+
+                                    (DSPFONT DEFAULTFONT FILE)
+                                    (CL:FORMAT FILE "~A" (CAR INPUT))
+                                    (DSPFONT INPUTFONT FILE)
+                                    (for X in (CDR INPUT)
+                                         do
+                                         (FRESHLINE FILE)
+                                         (DSPXPOSITION POSITION FILE)
+                                         (CL:FORMAT FILE "   ~S" X)))
+                             (T (CL:FORMAT FILE "~{~S ~}~&" INPUT]
+                      [(CDR INPUT)                       (* ; "APPLY format")
+
+                       (EXEC-PRIN1 (CAR INPUT))
+                       (COND
+                          ((NULL (SETQ TEM (CADR INPUT)))
+                           (PRIN1 ")" FILE))
+                          (T (COND
+                                ((NLISTP TEM)
+                                 (SPACES 1 FILE)))
+                             (EXEC-PRIN1 TEM]
+                      (T                                     (* ; "EVAL input")
+
+                         (EXEC-PRIN1 (CAR INPUT]
+                   (COND
+                      (Y (SETQ INPUT (CDR Y))
+                         (TERPRI FILE)
+                         (DSPXPOSITION POSITION FILE)
+                         (GO LP)))
+               LP1 [LET [(RNT (CL:GETF (EXEC-EVENT-PROPS EVENT)
+                                         '*LISPXPRINT*]
+                          (if RNT then (DSPFONT PRINTOUTFONT FILE)
+                              (FRESHLINE FILE)
+                              (MAPC RNT (FUNCTION (LAMBDA (X)
+                                                            (LISPXREPRINT X FILE]
+                   (COND
+                      ((NOT NOVALUES)
+                       (DSPFONT VALUEFONT FILE)
+                       (for X in (LISTGET (CDDDR EVENT)
+                                        'LISPXVALUES)
+                            do
+                            (FRESHLINE FILE)
+                            (DSPXPOSITION POSITION FILE)
+                            (EXEC-PRIN1 X])
+
+(PRINT-EVENT-PROMPT
+  [LAMBDA (EVENT)                                            (* ; "Edited  2-Mar-87 16:47 by raf")
+
+    (LET [(TERM (\GETSTREAM T 'OUTPUT]               (* ; 
+                             "Crock because format interprets T to mean primary output, not terminal")
+
+           (FRESHLINE TERM)
+           (if (CL:CONSP (EXEC-EVENT-ID EVENT))
+               then
+               (DSPFONT PROMPTFONT TERM)
+               (DESTRUCTURING-BIND (INDEX ID . PROMPT)
+                      (EXEC-EVENT-ID EVENT)
+                      (IF (CL:EQUAL ID "")
+                          THEN
+                          (CL:FORMAT TERM "~D~A" INDEX PROMPT)
+                          ELSE
+                          (CL:FORMAT TERM "~A/~D~A" ID INDEX PROMPT)))
+               elseif LISPXHISTORY then (CL:FORMAT TERM "~D~A" (ENTRY# LISPXHISTORY EVENT)
+                                               (EXEC-EVENT-ID EVENT))
+               else                                          (* ; 
+                                                             "No prompt availible, use the default.")
+
+               (CL:FORMAT TERM "~A" XCL:*EXEC-PROMPT*])
+
+(PROCESS-EXEC-ID
+  (CL:LAMBDA (PROCESS &OPTIONAL ID)                          (* ; "Edited  5-Mar-87 17:29 by raf")
+
+         (OR (PROCESSPROP PROCESS 'ID)
+                (LET ((NAME (PROCESS.NAME PROCESS)))
+                       [PROCESSPROP PROCESS 'ID (OR ID (SETQ ID
+                                                                (COND
+                                                                   ((STRPOS "EXEC" NAME 1 NIL T)
+                                                                    (OR (SUBSTRING NAME 6 -1)
+                                                                           ""))
+                                                                   (T 
+                                                             (* ; "under some other process")
+
+                                                                      (STRING NAME]
+                       ID))))
+
+(SEARCH-FOR-EVENT-NUMBER
+  [LAMBDA (EVENTS HISTORY SPEC)                              (* lmm "11-Sep-86 10:53")
+    (while EVENTS do (if [LET [(ID (EXEC-EVENT-ID (CAR EVENTS]
+                                (COND
+                                   ((LISTP ID)
+                                    (EQL (CAR ID)
+                                           SPEC))
+                                   (T (EQL SPEC (ENTRY# HISTORY (CAR EVENTS]
+                         then
+                         (RETURN EVENTS)
+                         else
+                         (pop EVENTS])
+
+(\PICK.EVALQT
+  [LAMBDA NIL                                                (* ; "Edited 27-Feb-87 17:40 by raf")
+
+(* ;;; 
+"Replacement for \PROC.REPEATEDLYEVALQT.  Activated by the HARDRESET at the end of LOADUP.LISP")
+
+    (INPUT T)
+    (OUTPUT T)
+    (TTYDISPLAYSTREAM \TopLevelTtyWindow)
+    (\RESETSYSTEMSTATE)
+    (EXEC :TOP-LEVEL-P T :PROFILE XCL:*PROFILE* :WINDOW (XCL::SETUP-EXEC-WINDOW 
+                                                                   \TopLevelTtyWindow])
+
+(LISPXREPRINT
+  [LAMBDA (X FILE)                                           (* ; "Edited 19-Jan-87 16:03 by bvm:")
+                                                             (* ; 
+                              "takes an element from a *LISPXPRINT* property and prints it properly.")
+
+    [OR FILE (SETQ FILE (\GETSTREAM T 'OUTPUT]
+    (COND
+       ((STRINGP X)
+        (PRIN1 X FILE))
+       ((NLISTP X)
+        (PRIN2 X FILE))
+       ((CL:STRINGP (CAR X))
+        (CL:APPLY (FUNCTION CL:FORMAT)
+               FILE X))
+       (T (SELECTQ (CAR X)
+                ((PRINT PRIN1 PRIN2 SPACES) 
+                       (APPLY* (CAR X)
+                              (CADR X)
+                              FILE
+                              (CADDDR X)))
+                (TAB (TAB (CADR X)
+                            (CADDR X)
+                            FILE))
+                (TERPRI (TERPRI FILE))
+                (LISPXPRINTDEF0 [APPLY (CAR X)
+                                       (CONS (CADR X)
+                                              (CONS FILE (CDDDR X])
+                (APPLY (CAR X)
+                       (CONS (CADR X)
+                              (CONS FILE (CDDDR X])
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(MOVD? (QUOTE READ) (QUOTE TTYINREAD))
+
+(MOVD (QUOTE \PICK.EVALQT) (QUOTE \PROC.REPEATEDLYEVALQT))
+
+(SETQ BackgroundMenu)
+)
+
+(DEFMACRO CASE-EQUALP (SELECTOR &REST CASES) (LET* ((KV (CL:IF (CL:SYMBOLP SELECTOR) SELECTOR (GENSYM))) (CLAUSES (for STRING-CASE in CASES collect (COND ((FMEMB (CAR STRING-CASE) (QUOTE (T CL:OTHERWISE))) (BQUOTE (T (\,@ (CDR STRING-CASE))))) ((NOT (CL:CONSP (CAR STRING-CASE))) (BQUOTE ((STRING.EQUAL (\, KV) (QUOTE (\, (CAR STRING-CASE)))) (\,@ (CDR STRING-CASE))))) (T (BQUOTE ((OR (\,@ (CL:DO ((X (CAR STRING-CASE) (CDR X)) (Y NIL)) ((CL:ATOM X) (REVERSE Y)) (CL:PUSH (BQUOTE (STRING.EQUAL (\, KV) (QUOTE (\, (CAR X))))) Y)))) (\,@ (CDR STRING-CASE))))))))) (CL:IF (EQ KV SELECTOR) (BQUOTE (COND (\,@ CLAUSES))) (BQUOTE (LET (((\, KV) (\, SELECTOR))) (COND (\,@ CLAUSES)))))))
+
+(DEFMACRO EXEC-EVENT-PROPS (X) (BQUOTE (CDDDR (\, X))))
+
+(CL:DEFUN EXEC-PRINT (VALUE) (FRESHLINE T) (WRITE VALUE :STREAM *TERMINAL-IO* :ESCAPE T))
+
+(CL:DEFUN EXEC-FORMAT (FORMAT-STRING &REST ARGS) (AND (CL:STRINGP FORMAT-STRING) (LISPXPUT (QUOTE *LISPXPRINT*) (LIST (CONS FORMAT-STRING ARGS)) T *CURRENT-EVENT*)) (CL:APPLY (QUOTE CL:FORMAT) (\GETSTREAM T (QUOTE OUTPUT)) FORMAT-STRING ARGS))
+
+(ADDTOVAR BackgroundMenuCommands (EXEC (QUOTE (ADD-EXEC :TTY T)) "Start a new Exec using XCL:*PROFILE*" (SUBITEMS ("Xerox Common Lisp" (QUOTE (ADD-EXEC :PROFILE "XCL" :TTY T)) "Start a new Exec using XCL profile") ("Common Lisp" (QUOTE (ADD-EXEC :PROFILE "COMMON-LISP" :TTY T)) "Start a Common Lisp Exec" (SUBITEMS ("Old Common Lisp" (QUOTE (ADD-EXEC :PROFILE "LISP" :TTY T)) "Start an old Common Lisp (LISP package) Exec"))) ("Interlisp" (QUOTE (ADD-EXEC :PROFILE "INTERLISP" :TTY T)) "Start an Interlisp Exec" (SUBITEMS ("Old-Interlisp" (QUOTE (ADD-EXEC :PROFILE "OLD-INTERLISP-T" :EXEC (QUOTE EVALQT) :TTY T)) "Start an old-style LISPX window"))))))
+
+(ADDTOVAR SYSTEMINITVARS (LISPXHISTORY NIL 0 100 100) (GREETHIST))
+
+
+
+(* ;; "Exec Commands")
+
+
+(DEF-DEFINE-TYPE COMMANDS "Exec Commands")
+
+(DEFDEFINER (DEFCOMMAND (:NAME (CL:LAMBDA (WHOLE) (LET ((NAME (CL:SECOND WHOLE))) (CL:IF (CL:CONSP NAME) (CAR NAME) NAME))))) COMMANDS (NAME ARGUMENTS &ENVIRONMENT ENV &BODY BODY) (LET ((COMMAND-LEVEL (QUOTE *EXEC-COMMAND-TABLE*)) (COMMAND-TYPE :EVAL) (PREFIX "exec-")) (if (LISTP NAME) then (SETQ NAME (PROG1 (CAR NAME) (for X in (CDR NAME) do (CL:ECASE X ((:QUIET :HISTORY :INPUT :EVAL :MACRO) (SETQ COMMAND-TYPE X)) ((:DEBUGGER :BREAK) (SETQ COMMAND-LEVEL (QUOTE *DEBUGGER-COMMAND-TABLE*)) (SETQ PREFIX "break-"))))))) (LET* ((CMACRONAME (PACK* PREFIX NAME)) (STRINGNAME (STRING NAME))) (CL:MULTIPLE-VALUE-BIND (PARSED-BODY PARSED-DECLARATIONS PARSED-DOCSTRING) (PARSE-DEFMACRO ARGUMENTS (QUOTE $$MACRO-FORM) BODY NAME ENV :ENVIRONMENT (QUOTE $$MACRO-ENV)) (BQUOTE (PROGN (CL:SETF (CL:SYMBOL-FUNCTION (QUOTE (\, CMACRONAME))) (FUNCTION (CL:LAMBDA ($$MACRO-FORM $$MACRO-ENV) (\,@ PARSED-DECLARATIONS) (\, PARSED-BODY)))) (CL:SETF (CL:DOCUMENTATION (\, STRINGNAME) (QUOTE COMMANDS)) (\, PARSED-DOCSTRING)) (PUTHASH (\, STRINGNAME) (QUOTE (\, (MAKE-COMMAND-ENTRY :FUNCTION CMACRONAME :MODE COMMAND-TYPE :ARGUMENTS (\SIMPLIFY.CL.ARGLIST ARGUMENTS)))) (\, COMMAND-LEVEL))))))))
+
+(DEFCOMMAND ("?" :QUIET) (&OPTIONAL (NAME NIL NAMEP)) "Show forms of valid input. ? <name> shows name's documentation." (CL:IF NAMEP (PRINT-ALL-DOCUMENTATION NAME) (PROGN (CL:FORMAT T "~&You are typing at the Exec. Enter~&") (DSPFONT INPUTFONT T) (CL:FORMAT T "<expression>") (DSPFONT DEFAULTFONT T) (CL:FORMAT T " ~20Tto evaluate an expression~&") (DSPFONT INPUTFONT T) (CL:FORMAT T "function(arg1 arg2 ...)") (DSPFONT DEFAULTFONT T) (CL:FORMAT T " ~20Tto apply function to the arguments given~&~%%or one of:") (FOR X ON (REVERSE *THIS-EXEC-COMMANDS*) DO (LET (COMS) (MAPHASH (CAR X) (CL:FUNCTION (CL:LAMBDA (VAL KEY) (AND (NOT (SOME (CDR X) (CL:FUNCTION (CL:LAMBDA (TAB) (GETHASH KEY TAB))))) (PUSH COMS (LIST KEY VAL)))))) (CL:MAPC (CL:FUNCTION (CL:LAMBDA (COM) (CL:FORMAT T "~&") (DSPFONT INPUTFONT T) (CL:FORMAT T "~A " (CAR COM)) (DSPFONT COMMENTFONT T) (PRINT-ARGLIST (COMMAND-ENTRY-ARGUMENTS (CADR COM))) (DSPFONT DEFAULTFONT T) (LET ((DOC (CL:DOCUMENTATION (CAR COM) (QUOTE COMMANDS)))) (CL:WHEN DOC (TAB 20 1 T) (CL:FORMAT T "~A" DOC))))) (CL:SORT COMS (CL:FUNCTION CL:STRING<) :KEY (CL:FUNCTION CAR))))))) (CL:VALUES))
+
+(DEFCOMMAND ("??" :QUIET) (&REST EVENT-SPECS) "Show events specified EVENT-SPECS (or all events)" (IF (AND EVENT-SPECS (EQ (CAR EVENT-SPECS) (QUOTE :INPUT))) THEN (PRINT-HISTORY LISPXHISTORY (CDR EVENT-SPECS) T) ELSE (PRINT-HISTORY LISPXHISTORY EVENT-SPECS)) (CL:VALUES))
+
+(DEFCOMMAND ("CONN" :EVAL) (&OPTIONAL DIRECTORY) "Change default pathname to DIRECTORY" (/CNDIR DIRECTORY))
+
+(DEFCOMMAND "DA" NIL "Returns current time & date" (DATE))
+
+(DEFCOMMAND ("DIR" :EVAL) (&OPTIONAL PATHNAME &REST KEYWORDS) "Show directory listing for PATHNAME" (DODIR (CONS PATHNAME (MAPCAR KEYWORDS (FUNCTION (LAMBDA (CL:KEYWORD) (IF (CL:SYMBOLP CL:KEYWORD) THEN (CL:INTERN (CL:SYMBOL-NAME CL:KEYWORD) "INTERLISP") ELSE CL:KEYWORD)))))))
+
+(DEFCOMMAND "DO-EVENTS" (&REST INPUTS &ENVIRONMENT ENV) "Execute the multiple events in INPUTS, using the environment ENV for all evaluations." (LET ((OUTER-EVENT (AND *CURRENT-EVENT* (COPY-EXEC-EVENT *CURRENT-EVENT*))) (* ; "DO-EVENT smashes *CURRENT-EVENT*, so we copy and save it.")) (CL:WHEN OUTER-EVENT (CL:SETF (EXEC-EVENT-INPUT OUTER-EVENT) (CONS (QUOTE DO-EVENTS) INPUTS)) (* ; "Each of these is fixed up below.")) (ERSETQ (CL:MAPL (CL:FUNCTION (CL:LAMBDA (INPUT) (LET ((TODO (CL:IF (EQ (CAR (LISTP (CAR INPUT))) (QUOTE EVENT)) (CDR (CAR INPUT)) (LIST (CAR INPUT)))) VALUES) (CL:WHEN ADDSPELLFLG (HISTORY-ADD-TO-SPELLING-LISTS TODO)) (SETQ VALUES (DO-EVENT TODO ENV)) (* ; "If it exists, *CURRENT-EVENT* gets smashed here.") (CL:WHEN OUTER-EVENT (* ; "If there is an outer event...") (* ;; "Fix the outer event's list of inputs with the expanded input.") (RPLACA INPUT (CAR (EXEC-EVENT-INPUT *CURRENT-EVENT*))) (CL:WHEN VALUES (* ; "If the last sub-event generated some values...") (* ;; "Add the new values to the outer event's values.") (LET ((OLD-VALUES (CL:GETF (EXEC-EVENT-PROPS OUTER-EVENT) (QUOTE LISPXVALUES)))) (CL:IF OLD-VALUES (NCONC OLD-VALUES VALUES) (CL:SETF (EXEC-EVENT-PROPS OUTER-EVENT) (LIST* (QUOTE LISPXVALUES) VALUES (EXEC-EVENT-PROPS OUTER-EVENT)))))))))) INPUTS)) (CL:WHEN *CURRENT-EVENT* (* ; "If there was a current event...") (* ; "Smash saved values back from OUTER-EVENT.") (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) (EXEC-EVENT-INPUT OUTER-EVENT)) (CL:SETF (EXEC-EVENT-ID *CURRENT-EVENT*) (EXEC-EVENT-ID OUTER-EVENT)) (CL:SETF (EXEC-EVENT-VALUE *CURRENT-EVENT*) (EXEC-EVENT-VALUE OUTER-EVENT)) (CL:SETF (EXEC-EVENT-PROPS *CURRENT-EVENT*) (EXEC-EVENT-PROPS OUTER-EVENT)))) (SETQ *CURRENT-EVENT* NIL) (* ; "Keeps the DO-EVENT which is evaluating us from setting the event's results to (the result of evaluating) the NIL we return.  This is alright since *CURRENT-EVENT* is already pointed to by the history list.") (CL:VALUES) (* ; "We've evaluated all the subforms directly with DO-EVENT so we don't return a form to EVAL."))
+
+(DEFCOMMAND ("FIX" :HISTORY) (&REST EVENT-SPEC) "Edit input for specified events" (APPLY (QUOTE FIX-FORM) (CL:MULTIPLE-VALUE-LIST (CIRCLAR-COPYER (EVENTS-INPUT (FIND-HISTORY-EVENTS (OR EVENT-SPEC (QUOTE (-1))) LISPXHISTORY))))))
+
+(DEFCOMMAND "FORGET" (&REST EVENT-SPEC) "Erase UNDO information (for specified events)." (FOR EVENT IN (FIND-HISTORY-EVENTS (OR EVENT-SPEC (QUOTE (-1))) LISPXHISTORY) DO (UNDOLISPX2 EVENT T) FINALLY (CL:FORMAT T "Forgotten.~&")) (CL:VALUES))
+
+(DEFCOMMAND "NAME" (COMMAND-NAME &OPTIONAL ARGUMENT-LIST &REST EVENT-SPEC) "NAME command-name [argument-list] [event-spec] defines new command containing the event." (CL:UNLESS (LISTP ARGUMENT-LIST) (CL:PUSH ARGUMENT-LIST EVENT-SPEC) (SETQ ARGUMENT-LIST NIL)) (LET ((EVENTS (FIND-HISTORY-EVENTS EVENT-SPEC LISPXHISTORY)) (ARGNAMES (FOR I FROM 1 AS X IN ARGUMENT-LIST COLLECT (PACK* (QUOTE ARG) I)))) (CL:EVAL (BQUOTE (DEFCOMMAND ((\, COMMAND-NAME) :HISTORY) (\, ARGNAMES) (SUBPAIR (QUOTE (\, ARGNAMES)) (LIST (\,@ ARGNAMES)) (QUOTE (\, (SUBPAIR ARGUMENT-LIST ARGNAMES (EVENTS-INPUT EVENTS) T)))))))))
+
+(DEFCOMMAND ("NDIR" :EVAL) (&OPTIONAL PATHNAME &REST KEYWORDS) "Show directory listing for PATHNAME in abbreviated format" (DODIR (CONS PATHNAME KEYWORDS) (QUOTE (P COLUMNS 20)) (QUOTE *) ""))
+
+(DEFCOMMAND "PL" (CL:SYMBOL) "Show property list of SYMBOL" (PRINTPROPS CL:SYMBOL) (CL:VALUES))
+
+(DEFCOMMAND ("REDO" :HISTORY) (&REST EVENT-SPEC) "Re-execute specified event(s)" (EVENTS-INPUT (FIND-HISTORY-EVENTS (OR EVENT-SPEC (QUOTE (-1))) LISPXHISTORY)))
+
+(DEFCOMMAND ("REMEMBER" :EVAL) (&REST EVENT-SPEC) "Tell Manager to remember type-in from specified event(s)" (MARKASCHANGED (GETEXPRESSIONFROMEVENTSPEC EVENT-SPEC) (QUOTE EXPRESSIONS)))
+
+(DEFCOMMAND ("SHH" :QUIET) (&REST LINE) "Execute LINE without history processing" (EVAL-INPUT LINE))
+
+(DEFCOMMAND "UNDO" (&REST EVENT-SPEC) "Undo side effects associated with the specified event (or last undoable one)" (FOR EVENT IN (FIND-HISTORY-EVENTS (OR EVENT-SPEC (QUOTE (-1))) LISPXHISTORY) DO (LET ((INPUT (CAR (EXEC-EVENT-INPUT EVENT))) (RESULT (UNDOLISPX2 EVENT))) (CL:IF (LISTP INPUT) (SETQ INPUT (CAR INPUT))) (COND ((NULL RESULT) (CL:FORMAT T "No undo info saved for ~A.~&" INPUT)) ((EQ RESULT (QUOTE already)) (CL:FORMAT T "~A already undone.~&" INPUT)) (T (CL:FORMAT T "~A undone.~&" INPUT))))) (CL:VALUES))
+
+(DEFCOMMAND ("USE" :HISTORY) (&REST LINE) "USE <new> [FOR <old>] [IN <event-spec>]" (* ;; "this code stolen from LISPXUSE in HIST and edited. The structure is still pretty incomprehensible") (PROG (EVENT-SPECS EXPR ARGS VARS (STATE (QUOTE VARS)) LST TEM USE-ARGS GENLST) LP (COND ((OR (NULL LST) (NULL (CDR LINE)) (NULL (CASE-EQUALP (CAR LINE) (* ; "look for one of the special keywords") (FOR (COND ((EQ STATE (QUOTE VARS)) (SETQ VARS (NCONC1 VARS LST)) (SETQ TEM (APPEND LST TEM)) (SETQ STATE (QUOTE ARGS)) (SETQ LST NIL) T))) (AND (COND ((EQ STATE (QUOTE EXPR)) NIL) (T (COND ((EQ STATE (QUOTE ARGS)) (SETQ ARGS (NCONC1 ARGS LST))) ((EQ STATE (QUOTE VARS)) (* ; "E.g. user types USE A AND B following previous USE command.") (SETQ VARS (NCONC1 VARS LST)))) (SETQ STATE (QUOTE VARS)) (SETQ LST NIL) T))) (IN (COND ((AND (EQ STATE (QUOTE VARS)) (NULL ARGS)) (SETQ VARS (NCONC1 VARS LST)) (SETQ TEM (APPEND LST TEM)) (SETQ STATE (QUOTE EXPR)) (SETQ LST NIL) T) ((EQ STATE (QUOTE ARGS)) (SETQ ARGS (NCONC1 ARGS LST)) (SETQ STATE (QUOTE EXPR)) (SETQ LST NIL) T)))))) (SETQ LST (NCONC1 LST (COND (NIL (MEMBER (CAR LINE) TEM) (* ;; "This enables USE A B FOR B A, USE A FOR B AND B FOR A, or USE A FOR B AND B C FOR A") (LET ((TEMP (CONCAT "temp string"))) (CL:PUSH (CONS (CAR LINE) TEMP) GENLST) TEMP)) (T (CAR LINE))))))) (COND ((SETQ LINE (CDR LINE)) (GO LP))) (CL:ECASE STATE (VARS (SETQ VARS (NCONC1 VARS LST))) (ARGS (SETQ ARGS (NCONC1 ARGS LST))) (EXPR (SETQ EXPR LST))) (CL:WHEN (NULL EXPR) (CL:IF ARGS (SETQ EXPR (LIST (QUOTE F) (CAAR ARGS))) (SETQ EXPR (QUOTE (-1))))) (* ;; "EXPR specifies expressions to be substituted into, e.g. USE FOO FOR FIE IN FUM or USE FOO FOR FIE. In the latter case, searches for FIE. The F is added to avoid confusion with event numbers, etc.") (* ;; "") (SETQ EXPR (MAPCAR (FIND-HISTORY-EVENTS EXPR LISPXHISTORY) (FUNCTION EXEC-EVENT-INPUT))) (* ; "EXPR is now a list of event inputs") (* ;; "at this point, VARS is a list of list of old things, the extra list corresponding to the clauses of an AND, e.g. ") (* ;; "USE A B FOR C AND D E FOR F would have ") (* ;; "((A B) (D E)) for VARS and") (* ;; "((C) (F)) for ARGS.") (IF (NULL ARGS) THEN (SETQ EXPR (FOR X IN EXPR JOIN (FOR VAR IN VARS COLLECT (IF (CL:CONSP (CAR X)) THEN (CONS (CONS (CAR VAR) (CDAR X)) (CDR X)) ELSE (CONS (CAR VAR) (CDR X)))))) ELSE (WHILE ARGS DO (SETQ EXPR (LISPXUSE1 (POP VARS) (POP ARGS) EXPR)) FINALLY (COND (VARS (ERROR (QUOTE "use what??") "" T))) (MAPC GENLST (FUNCTION (LAMBDA (X) (LISPXSUBST (CAR X) (CDR X) EXPR T)))) (* ;; "samples:") (* ;; " USE A B C D FOR X Y means substitute A for X and B for Y and then do it again with C for X and D for Y") (* ;; " Equivalent to USE A C FOR X AND B D FOR Y") (* ;; " USE A B C FOR D AND X Y Z FOR W means 3 operations:") (* ;; "  A for D and X for W in the first") (* ;; "  B for D and Y for W in the second") (* ;; " C for D and Z for W in the third") (* ;; "USE A B C FOR D AND X FOR Y means 3 operations:") (* ;; " A for D and X for Y in first") (* ;; " B for D and X for Y in second, etc.") (* ;; "USE A B C FOR D AND X Y FOR Z causes error") (* ;; "") (* ;; " USE A B FOR B A will work correctly, but USE A FOR B AND B FOR A will result in all B's being changed to A's.") (* ;; "") (* ;; "The general rule is substitution proceeds from left to right with each %%'AND' handled separately. Whenever the number of variables exceeds the number of expressions available, the expressions multiply."))) (RETURN (COND ((CDR EXPR) (CONS (QUOTE DO-EVENTS) (for X in EXPR collect (COND ((CDR X) (CONS (QUOTE EVENT) X)) (T (CAR X)))))) (T (CAR EXPR))))))
+
+(DEFCOMMAND "PP" (&OPTIONAL (NAME LASTWORD) &REST TYPES) "Show TYPES (or any) definition for NAME" (CL:BLOCK NIL (* ;; "returned from if no definitions found") (for TYPE in (OR TYPES (TYPESOF NAME NIL NIL (QUOTE ?) (FUNCTION (LAMBDA (TYPE) (NEQ (GET TYPE (QUOTE EDITDEF)) (QUOTE NILL))))) (TYPESOF (SETQ NAME (OR (FIXSPELL NAME NIL USERWORDS NIL NIL (FUNCTION (LAMBDA (WORD) (TYPESOF WORD NIL (QUOTE (FIELDS FILES)) (QUOTE CURRENT)))) NIL NIL NIL (QUOTE MUSTAPPROVE)) (PROGN (CL:FORMAT *TERMINAL-IO* "No definitions found for ~S." NAME) (RETURN NIL)))) NIL NIL (QUOTE ?) (FUNCTION (LAMBDA (TYPE) (NEQ (GET TYPE (QUOTE EDITDEF)) (QUOTE NILL)))))) do (CL:FORMAT *TERMINAL-IO* "~A definition for ~S:~%%" TYPE NAME) (SHOWDEF NAME TYPE))) (CL:VALUES))
+
+
+
+(* ;; "Arrange to use the correct compiler")
+
+
+(PUTPROPS CMLEXEC FILETYPE CL:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA DIR)
+
+(ADDTOVAR NLAML)
+
+(ADDTOVAR LAMA)
+)
+(PRETTYCOMPRINT CMLEXECCOMS)
+
+(RPAQQ CMLEXECCOMS ((FILES CMLUNDO PROFILE) (XCL:PROFILES "EXEC") (STRUCTURES COMMAND-ENTRY EXEC-EVENT-ID EXEC-EVENT HISTORY) (* ; "These are public except for command-entry.") (FUNCTIONS XCL::EXEC-CLOSEFN XCL::EXEC-SHRINKFN XCL::SETUP-EXEC-WINDOW XCL::EXEC-TITLE-FUNCTION FIX-FORM XCL::GET-PROCESS-PROFILE XCL::SAVE-CURRENT-EXEC-PROFILE XCL::SETF-GET-PROCESS-PROFILE XCL:SET-EXEC-TYPE XCL:SET-DEFAULT-EXEC-TYPE XCL::ENTER-EXEC-FUNCTION) (SETFS XCL::GET-PROCESS-PROFILE) (FUNCTIONS DO-EVENT EXEC EXEC-EVAL PRINT-ALL-DOCUMENTATION PRINT-DOCUMENTATION VALUE-OF ADD-EXEC EXEC-READ-LINE EXEC-EVENT-ID-PROMPT FIND-EXEC-COMMAND) (FUNCTIONS CIRCLAR-COPYER) (FNS COPY-CIRCLE) (* ; "CIRCLAR-COPYER and COPY-CIRCLE are the solution for AR#11172") (FNS EXEC-READ DIR) (VARIABLES *PER-EXEC-VARIABLES* CL:* CL:** CL:*** + CL:++ CL:+++ - / CL:// CL:/// *CURRENT-EVENT* *EXEC-ID* XCL:*EXEC-PROMPT* XCL:*EVAL-FUNCTION* *NOT-YET-EVALUATED* *THIS-EXEC-COMMANDS* *EXEC-COMMAND-TABLE* *DEBUGGER-COMMAND-TABLE* *CURRENT-EXEC-TYPE* *EXEC-MAKE-UNDOABLE-P*) (VARIABLES *EDIT-INPUT-WITH-TTYIN*) (FNS DO-APPLY-EVENT DO-HISTORY-SEARCH EVAL-INPUT EVENTS-INPUT EXEC-PRIN1 EXEC-VALUE-OF GET-NEXT-HISTORY-EVENT HISTORY-ADD-TO-SPELLING-LISTS HISTORY-NTH PRINT-HISTORY FIND-HISTORY-EVENTS PRINT-EVENT PRINT-EVENT-PROMPT PROCESS-EXEC-ID SEARCH-FOR-EVENT-NUMBER \PICK.EVALQT LISPXREPRINT) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? (QUOTE READ) (QUOTE TTYINREAD)) (MOVD (QUOTE \PICK.EVALQT) (QUOTE \PROC.REPEATEDLYEVALQT)) (SETQ BackgroundMenu))) (FUNCTIONS CASE-EQUALP EXEC-EVENT-PROPS EXEC-PRINT EXEC-FORMAT) (ALISTS (BackgroundMenuCommands EXEC)) (ALISTS (SYSTEMINITVARS LISPXHISTORY GREETHIST)) (* ;; "Exec Commands") (DEFINE-TYPES COMMANDS) (FUNCTIONS DEFCOMMAND) (COMMANDS "?" "??" "CONN" "DA" "DIR" "DO-EVENTS" "FIX" "FORGET" "NAME" "NDIR" "PL" "REDO" "REMEMBER" "SHH" "UNDO" "USE" "PP") (* ;; "Arrange to use the correct compiler") (PROP FILETYPE CMLEXEC) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PROCESS-EXEC-ID PRINT-EVENT PRINT-HISTORY EXEC-PRIN1 EVENTS-INPUT EVAL-INPUT EXEC-READ)))))
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA)
+
+(ADDTOVAR NLAML)
+
+(ADDTOVAR LAMA PROCESS-EXEC-ID PRINT-EVENT PRINT-HISTORY EXEC-PRIN1 EVENTS-INPUT EVAL-INPUT EXEC-READ)
+)
+(PUTPROPS CMLEXEC COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991 1992))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (20107 21061 (COPY-CIRCLE 20117 . 21059)) (21139 24444 (EXEC-READ 21149 . 24310) (DIR 
+24312 . 24442)) (26450 53584 (DO-APPLY-EVENT 26460 . 27022) (DO-HISTORY-SEARCH 27024 . 28481) (
+EVAL-INPUT 28483 . 33912) (EVENTS-INPUT 33914 . 35292) (EXEC-PRIN1 35294 . 35470) (EXEC-VALUE-OF 35472
+ . 35811) (GET-NEXT-HISTORY-EVENT 35813 . 37308) (HISTORY-ADD-TO-SPELLING-LISTS 37310 . 38298) (
+HISTORY-NTH 38300 . 39050) (PRINT-HISTORY 39052 . 39673) (FIND-HISTORY-EVENTS 39675 . 44736) (
+PRINT-EVENT 44738 . 48959) (PRINT-EVENT-PROMPT 48961 . 50165) (PROCESS-EXEC-ID 50167 . 51112) (
+SEARCH-FOR-EVENT-NUMBER 51114 . 51742) (\PICK.EVALQT 51744 . 52255) (LISPXREPRINT 52257 . 53582)))))
+STOP
diff --git a/CLTL2/CMLEXEC.LCOM b/CLTL2/CMLEXEC.LCOM
new file mode 100644
index 00000000..86e3d88a
Binary files /dev/null and b/CLTL2/CMLEXEC.LCOM differ
diff --git a/CLTL2/CMLFILESYS b/CLTL2/CMLFILESYS
new file mode 100644
index 00000000..5b82bd84
--- /dev/null
+++ b/CLTL2/CMLFILESYS
@@ -0,0 +1,156 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+(FILECREATED "18-Oct-93 11:06:53" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLFILESYS.;2" 8169   
+
+      |previous| |date:| " 3-Aug-91 11:23:10" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLFILESYS.;1"
+)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT CMLFILESYSCOMS)
+
+(RPAQQ CMLFILESYSCOMS ((FUNCTIONS LISP:DIRECTORY LISP:FILE-AUTHOR LISP:FILE-LENGTH 
+                                  LISP:FILE-POSITION LISP:USER-HOMEDIR-PATHNAME LISP:FILE-WRITE-DATE)
+                           (FUNCTIONS LISP:PROBE-FILE LISP:RENAME-FILE LISP:DELETE-FILE)
+                           (PROP FILETYPE CMLFILESYS)))
+
+(LISP:DEFUN LISP:DIRECTORY (PATHNAME)
+   (LISP:WHEN (LISP::LOGICAL-PATHNAME-P PATHNAME)
+       (LISP:SETQ PATHNAME (LISP:TRANSLATE-LOGICAL-PATHNAME PATHNAME)))
+   (LET (GENERATOR FILE)
+        (DECLARE (LISP:SPECIAL GENERATOR))
+        (RESETLST
+            (|if| (EQL \\MACHINETYPE \\MAIKO)
+                |then| (RESETSAVE NIL '(AND RESETSTATE (\\UFS.ABORT.CL-DIRECTORY))))
+            (LISP:SETQ GENERATOR (\\GENERATEFILES (DIRECTORY.FILL.PATTERN (LISP:NAMESTRING PATHNAME))
+                                        NIL
+                                        '(SORT RESETLST)))
+            (|while| (SETQ FILE (\\GENERATENEXTFILE GENERATOR)) |collect| (PATHNAME FILE)))))
+
+(LISP:DEFUN LISP:FILE-AUTHOR (LISP::FILE)
+
+(* |;;;| "Returns author of file as string, or NIL if it cannot be determined.  FILE is a filename or stream.")
+
+   (LET ((LISP::AUTHOR (GETFILEINFO LISP::FILE 'AUTHOR)))
+        (LISP:IF LISP::AUTHOR
+            (COERCE LISP::AUTHOR 'LISP:SIMPLE-STRING)
+            NIL)))
+
+(LISP:DEFUN LISP:FILE-LENGTH (FILE-STREAM)
+   (|if| (AND (STREAMP FILE-STREAM)
+                  (OPENP FILE-STREAM))
+       |then| (GETEOFPTR FILE-STREAM)))
+
+(LISP:DEFUN LISP:FILE-POSITION (LISP::FILE-STREAM &OPTIONAL (LISP:POSITION NIL LISP::POSITIONP)
+                                          )
+   (LISP:UNLESS (STREAMP LISP::FILE-STREAM)
+          (\\ILLEGAL.ARG LISP::FILE-STREAM))
+   (LISP:IF LISP::POSITIONP
+       (LISP:IF (RANDACCESSP LISP::FILE-STREAM)
+           (PROGN (SETFILEPTR LISP::FILE-STREAM (CASE LISP:POSITION
+                                                    (:START 0)
+                                                    (:END (GETEOFPTR LISP::FILE-STREAM))
+                                                    (T LISP:POSITION)))
+                  T)
+           NIL)
+       (GETFILEPTR LISP::FILE-STREAM)))
+
+(LISP:DEFUN LISP:USER-HOMEDIR-PATHNAME (&OPTIONAL HOST)
+   (DECLARE (GLOBALVARS LOGINHOST/DIR *DEFAULT-PATHNAME-DEFAULTS*))
+   (LISP:IF (MACHINETYPE 'MAIKO)
+       (LISP:IF (AND HOST (LISP:STRING-NOT-EQUAL (STRING HOST)
+                                 (UNIX-GETPARM "HOSTNAME")))
+           NIL
+           (LISP:MAKE-PATHNAME :HOST :DSK :DIRECTORY (UNPACKFILENAME.STRING (UNIX-GETENV "HOME")
+                                                            'DIRECTORY
+                                                            'RETURN)))
+       (PATHNAME (OR LOGINHOST/DIR *DEFAULT-PATHNAME-DEFAULTS*))))
+
+(LISP:DEFUN LISP:FILE-WRITE-DATE (FILE)
+
+   (* |;;| "Return file's creation date, or NIL if it doesn't exist.")
+
+   (* |;;| "N.B. date is returned in Common Lisp Universal Time, not Interlisp-D internal time")
+
+   (LET ((TN (LISP:PROBE-FILE FILE)))
+        (LISP:WHEN TN
+            (%CONVERT-INTERNAL-TIME-TO-CLUT (GETFILEINFO TN 'ICREATIONDATE)))))
+
+(LISP:DEFUN LISP:PROBE-FILE (FILE)
+
+(* |;;;| "Return a pathname which is the truename of the file if it exists, NIL otherwise.  Returns NIL for non-file args.")
+
+   (LISP:TYPECASE FILE
+       (STREAM (IF (OPENP FILE)
+                   THEN (PATHNAME (FETCH (STREAM FULLNAME) OF FILE))
+                 ELSE (LET ((NAMESTRING-IF-EXISTS (INFILEP (FETCH (STREAM FULLNAME)
+                                                                  OF FILE))))
+                               (AND NAMESTRING-IF-EXISTS (PATHNAME NAMESTRING-IF-EXISTS)))))
+       (LISP:LOGICAL-PATHNAME (LISP:PROBE-FILE (LISP:TRANSLATE-LOGICAL-PATHNAME FILE)))
+       (T (LET ((INFILEP (\\GETFILENAME FILE 'OLD)))
+               (IF INFILEP
+                   THEN (PATHNAME INFILEP)
+                 ELSE NIL)))))
+
+(LISP:DEFUN LISP:RENAME-FILE (LISP::FILE LISP::NEW-NAME)
+
+(* |;;;| "Give FILE the new name NEW-NAME.  If FILE is an open stream, error.  Otherwise, do the rename.  If successful, return three values: the new name, truename of original file, truename of new file.")
+
+(* |;;;| "NEW MESSINESS resulting from acceptance of logical-pathnames: the CLtL2 spec for the first argument, (MERGE-PATHNAMES NEW-NAME FILE), makes no sense if either of FILE or NEW-NAME is a logical-pathname, since the logical-to-normal translation process can do arbitrary weird stuff.  Therefore, if either argument is a logical-pathname, we punt and return the new truename as the first argument.")
+
+   (LET* ((LISP::LOGICAL-USED? NIL)
+          (LISP::OLD-PATHNAME (LISP:IF (LISP::LOGICAL-PATHNAME-P LISP::FILE)
+                                  (PROGN (LISP:SETQ LISP::LOGICAL-USED? T)
+                                         (LISP:TRANSLATE-LOGICAL-PATHNAME LISP::FILE))
+                                  (PATHNAME LISP::FILE)))
+          (LISP::NEW-FULLNAME))
+         (LISP:WHEN (LISP::LOGICAL-PATHNAME-P LISP::NEW-NAME)
+             (LISP:SETQ LISP::LOGICAL-USED? T LISP::NEW-NAME (LISP:TRANSLATE-LOGICAL-PATHNAME 
+                                                                    LISP::NEW-NAME)))
+         (IF (STREAMP LISP::FILE)
+             THEN (IF (OPENP LISP::FILE)
+                          THEN (LISP:ERROR "Renaming open streams is not supported: ~S" 
+                                          LISP::FILE)
+                        ELSE (LISP:SETQ LISP::NEW-FULLNAME (RENAMEFILE (LISP:SETQ
+                                                                            LISP::FILE
+                                                                            (FETCH (STREAM 
+                                                                                             FULLNAME
+                                                                                              )
+                                                                               OF LISP::FILE))
+                                                                      LISP::NEW-NAME)))
+           ELSE 
+
+                 (* |;;| "IL:RENAMEFILE will accept logical-pathnames")
+
+                 (LISP:SETQ LISP::NEW-FULLNAME (RENAMEFILE (LISP:IF LISP::LOGICAL-USED?
+                                                               LISP::OLD-PATHNAME
+                                                               LISP::FILE)
+                                                      LISP::NEW-NAME)))
+         (IF LISP::NEW-FULLNAME
+             THEN (LISP:VALUES (LISP:IF LISP::LOGICAL-USED?
+                                       (PATHNAME LISP::NEW-FULLNAME)
+                                       (LISP:MERGE-PATHNAMES LISP::NEW-NAME LISP::FILE))
+                             LISP::OLD-PATHNAME
+                             (PATHNAME LISP::NEW-FULLNAME))
+           ELSE (LISP:ERROR "Rename failed"))))
+
+(LISP:DEFUN LISP:DELETE-FILE (FILE)
+   
+         (* * "Delete the specified file.")
+
+   (LET ((TN (LISP:PROBE-FILE FILE)))
+        (LISP:WHEN (STREAMP FILE)
+               (LISP:CLOSE FILE :ABORT T))
+        (LISP:IF TN
+            (LET ((NS (INTERLISP-NAMESTRING TN)))
+                 (LISP:UNLESS (DELFILE NS)
+                        (LISP:ERROR "Could not delete the file ~S" FILE)))
+            (LISP:UNLESS (STREAMP FILE)
+                   (LISP:ERROR "File to be deleted does not exist: ~S" FILE))))
+   T)
+
+(PUTPROPS CMLFILESYS FILETYPE LISP:COMPILE-FILE)
+(PUTPROPS CMLFILESYS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1993))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/CLTL2/CMLFILESYS.LCOM b/CLTL2/CMLFILESYS.LCOM
new file mode 100644
index 00000000..f7f372c9
Binary files /dev/null and b/CLTL2/CMLFILESYS.LCOM differ
diff --git a/CLTL2/CMLFLOAT b/CLTL2/CMLFLOAT
new file mode 100644
index 00000000..7fb6d55d
--- /dev/null
+++ b/CLTL2/CMLFLOAT
@@ -0,0 +1,385 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
+(IL:FILECREATED "24-Mar-92 13:57:12" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLFLOAT.;2| 42560  
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:CMLFLOATCOMS) (IL:VARIABLES CL:LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT CL:LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT CL:LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT CL:LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT CL:LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT CL:LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT CL:LEAST-POSITIVE-NORMALIZED-LONG-FLOAT CL:LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT)
+
+      IL:|previous| IL:|date:| "16-May-90 13:16:23" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>CMLFLOAT.;1|)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CMLFLOATCOMS)
+
+(IL:RPAQQ IL:CMLFLOATCOMS ((IL:* IL:|;;;| "CMLFLOAT -- Covering sections 12.5-12.5.3 irrational, transcendental, exponential, logarithmic, trigonometric, and hyperbolic functions.  Section 12.10, implementation parameters. ") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:* IL:\; "To generate unboxed opcodes") (IL:FILES IL:UNBOXEDOPS) (IL:* IL:\; "To get constants from llfloat ") (IL:FILES (IL:LOADCOMP) IL:LLFLOAT)) (IL:COMS (IL:* IL:|;;| "Section 12.10, implementation parameters.  ") (IL:* IL:|;;| "%FLOAT allows us to recreate FLOATPs in a way that is independent of the ordinairy reading and printing FLOATPs to files which involves loss of the last couple bits of accuracy due to rounding effects.") (IL:* IL:|;;| "Reading and printing of floats has since been fixed, so LISP::%FLOAT is not technically necessary anymore - JRB") (IL:FUNCTIONS %FLOAT) (IL:VARIABLES MOST-POSITIVE-FIXNUM MOST-NEGATIVE-FIXNUM) (IL:VARIABLES MOST-POSITIVE-SINGLE-FLOAT LEAST-POSITIVE-SINGLE-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT MOST-NEGATIVE-SINGLE-FLOAT) (IL:VARIABLES MOST-POSITIVE-SHORT-FLOAT LEAST-POSITIVE-SHORT-FLOAT LEAST-NEGATIVE-SHORT-FLOAT MOST-NEGATIVE-SHORT-FLOAT MOST-POSITIVE-DOUBLE-FLOAT LEAST-POSITIVE-DOUBLE-FLOAT LEAST-NEGATIVE-DOUBLE-FLOAT MOST-NEGATIVE-DOUBLE-FLOAT MOST-POSITIVE-LONG-FLOAT LEAST-POSITIVE-LONG-FLOAT LEAST-NEGATIVE-LONG-FLOAT MOST-NEGATIVE-LONG-FLOAT) (IL:* IL:|;;| "CLtL2 implementation parameters ") (IL:VARIABLES CL:LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT CL:LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT CL:LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT CL:LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT CL:LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT CL:LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT CL:LEAST-POSITIVE-NORMALIZED-LONG-FLOAT CL:LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT) (IL:* IL:|;;| "EPSILON is the smallest positive floating point number such that (NOT (= (FLOAT 1 EPSILON) (+ (FLOAT 1 EPSILON) EPSILON))) ") (IL:VARIABLES SINGLE-FLOAT-EPSILON) (IL:VARIABLES SHORT-FLOAT-EPSILON DOUBLE-FLOAT-EPSILON LONG-FLOAT-EPSILON) (IL:* IL:|;;| "NEGATIVE-EPSILON is the smallest negative floating point number such that (NOT (= (FLOAT 1 NEGATIVE-EPSILON) (- (FLOAT 1 NEGATIVE-EPSILON) NEGATIVE-EPSILON))) ") (IL:VARIABLES SINGLE-FLOAT-NEGATIVE-EPSILON) (IL:VARIABLES SHORT-FLOAT-NEGATIVE-EPSILON DOUBLE-FLOAT-NEGATIVE-EPSILON LONG-FLOAT-NEGATIVE-EPSILON) (IL:VARIABLES PI)) (IL:COMS (IL:* IL:|;;| "Internal constants") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %E %2PI %PI %2PI/3 %PI/2 %-PI/2 %PI/3 %PI/4 %-PI/4 %PI/6 %2/PI))) (IL:COMS (IL:* IL:|;;| "Utility macros") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %FLOAT-UNBOX %GET-TABLE-ENTRY %POLYEVAL %UFTRUNCATE %UMAKE-FLOAT))) (IL:* IL:|;;| " Unpack floating point functions") (IL:COMS (IL:FUNCTIONS DECODE-FLOAT SCALE-FLOAT FLOAT-RADIX FLOAT-SIGN FLOAT-DIGITS FLOAT-PRECISION INTEGER-DECODE-FLOAT)) (IL:COMS (IL:* IL:|;;| "Exp  (e to the power x)") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %LOG-BASE2-E)) (IL:VARIABLES %EXP-POLY %EXP-TABLE)) (IL:FUNCTIONS %EXP-FLOAT) (IL:FUNCTIONS EXP)) (IL:COMS (IL:* IL:|;;| "Expt (x to the power y)") (IL:FUNCTIONS %EXPT-INTEGER %EXPT-FLOAT-INTEGER) (IL:FUNCTIONS EXPT)) (IL:COMS (IL:* IL:|;;| "Log (log base e)") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %LOG2 %SQRT2)) (IL:VARIABLES %LOG-PPOLY %LOG-QPOLY)) (IL:FUNCTIONS %LOG-FLOAT) (IL:FUNCTIONS LOG)) (IL:COMS (IL:* IL:|;;| "Sqrt") (IL:FUNCTIONS %SQRT-FLOAT %SQRT-COMPLEX) (IL:FUNCTIONS SQRT)) (IL:COMS (IL:* IL:|;;| "Sin and Cos") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %SIN-EPSILON)) (IL:VARIABLES %SIN-PPOLY %SIN-QPOLY)) (IL:FUNCTIONS %SIN-FLOAT) (IL:FUNCTIONS SIN COS)) (IL:COMS (IL:* IL:|;;| "Tan") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %TAN-EPSILON)) (IL:VARIABLES %TAN-PPOLY %TAN-QPOLY)) (IL:FUNCTIONS %TAN-FLOAT) (IL:FUNCTIONS TAN)) (IL:COMS (IL:* IL:|;;| "Asin and Acos") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %ASIN-EPSILON)) (IL:VARIABLES %ASIN-PPOLY %ASIN-QPOLY)) (IL:FUNCTIONS %ASIN-FLOAT) (IL:FUNCTIONS ASIN ACOS)) (IL:COMS (IL:* IL:|;;| "Atan ") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %SQRT3 %2-SQRT3 %INV-2-SQRT3)) (IL:FUNCTIONS %ATAN-FLOAT) (IL:FUNCTIONS ATAN)) (IL:COMS (IL:* IL:|;;| "Cis (exp (i x))") (IL:FUNCTIONS CIS)) (IL:COMS (IL:* IL:|;;| "Sinh, Cosh Tanh") (IL:FUNCTIONS SINH COSH TANH)) (IL:COMS (IL:* IL:|;;| "Asinh Acosh Atanh") (IL:FUNCTIONS ASINH ACOSH ATANH)) (IL:COMS (IL:* IL:|;;| "rational and rationalize ") (IL:FUNCTIONS %RATIONAL-FLOAT %RATIONALIZE-FLOAT)) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:LOCALVARS . T)) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:CMLFLOAT)))
+
+
+
+(IL:* IL:|;;;| 
+"CMLFLOAT -- Covering sections 12.5-12.5.3 irrational, transcendental, exponential, logarithmic, trigonometric, and hyperbolic functions.  Section 12.10, implementation parameters. "
+)
+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(IL:FILESLOAD IL:UNBOXEDOPS)
+
+
+(IL:FILESLOAD (IL:LOADCOMP) IL:LLFLOAT)
+)
+
+
+
+(IL:* IL:|;;| "Section 12.10, implementation parameters.  ")
+
+
+
+
+(IL:* IL:|;;| 
+"%FLOAT allows us to recreate FLOATPs in a way that is independent of the ordinairy reading and printing FLOATPs to files which involves loss of the last couple bits of accuracy due to rounding effects."
+)
+
+
+
+
+(IL:* IL:|;;| 
+"Reading and printing of floats has since been fixed, so LISP::%FLOAT is not technically necessary anymore - JRB"
+)
+
+
+(DEFUN %FLOAT (HIWORD LOWORD) (IL:\\FLOATBOX (IL:\\VAG2 HIWORD LOWORD)))
+
+(DEFCONSTANT MOST-POSITIVE-FIXNUM 65535)
+
+(DEFCONSTANT MOST-NEGATIVE-FIXNUM -65536)
+
+(DEFCONSTANT MOST-POSITIVE-SINGLE-FLOAT (%FLOAT 32639 65535))
+
+(DEFCONSTANT LEAST-POSITIVE-SINGLE-FLOAT (%FLOAT 0 1))
+
+(DEFCONSTANT LEAST-NEGATIVE-SINGLE-FLOAT (%FLOAT 32768 1))
+
+(DEFCONSTANT MOST-NEGATIVE-SINGLE-FLOAT (%FLOAT 65407 65535))
+
+(DEFCONSTANT MOST-POSITIVE-SHORT-FLOAT MOST-POSITIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT LEAST-POSITIVE-SHORT-FLOAT LEAST-POSITIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT LEAST-NEGATIVE-SHORT-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT MOST-NEGATIVE-SHORT-FLOAT MOST-NEGATIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT MOST-POSITIVE-DOUBLE-FLOAT MOST-POSITIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT LEAST-POSITIVE-DOUBLE-FLOAT LEAST-POSITIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT LEAST-NEGATIVE-DOUBLE-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT MOST-NEGATIVE-DOUBLE-FLOAT MOST-NEGATIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT MOST-POSITIVE-LONG-FLOAT MOST-POSITIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT LEAST-POSITIVE-LONG-FLOAT LEAST-POSITIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT LEAST-NEGATIVE-LONG-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT MOST-NEGATIVE-LONG-FLOAT MOST-NEGATIVE-SINGLE-FLOAT)
+
+
+
+(IL:* IL:|;;| "CLtL2 implementation parameters ")
+
+
+(DEFCONSTANT CL:LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT (%FLOAT 128 0) "Documentation string")
+
+(DEFCONSTANT CL:LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT (%FLOAT 32896 0))
+
+(DEFCONSTANT CL:LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT (%FLOAT 128 0))
+
+(DEFCONSTANT CL:LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT (%FLOAT 32896 0))
+
+(DEFCONSTANT CL:LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT (%FLOAT 128 0))
+
+(DEFCONSTANT CL:LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT (%FLOAT 32896 0))
+
+(DEFCONSTANT CL:LEAST-POSITIVE-NORMALIZED-LONG-FLOAT (%FLOAT 128 0))
+
+(DEFCONSTANT CL:LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT (%FLOAT 32896 0))
+
+
+
+(IL:* IL:|;;| 
+"EPSILON is the smallest positive floating point number such that (NOT (= (FLOAT 1 EPSILON) (+ (FLOAT 1 EPSILON) EPSILON))) "
+)
+
+
+(DEFCONSTANT SINGLE-FLOAT-EPSILON (%FLOAT (ASH 103 7) 1))
+
+(DEFCONSTANT SHORT-FLOAT-EPSILON SINGLE-FLOAT-EPSILON)
+
+(DEFCONSTANT DOUBLE-FLOAT-EPSILON SINGLE-FLOAT-EPSILON)
+
+(DEFCONSTANT LONG-FLOAT-EPSILON SINGLE-FLOAT-EPSILON)
+
+
+
+(IL:* IL:|;;| 
+"NEGATIVE-EPSILON is the smallest negative floating point number such that (NOT (= (FLOAT 1 NEGATIVE-EPSILON) (- (FLOAT 1 NEGATIVE-EPSILON) NEGATIVE-EPSILON))) "
+)
+
+
+(DEFCONSTANT SINGLE-FLOAT-NEGATIVE-EPSILON (%FLOAT 13184 0))
+
+(DEFCONSTANT SHORT-FLOAT-NEGATIVE-EPSILON SINGLE-FLOAT-NEGATIVE-EPSILON)
+
+(DEFCONSTANT DOUBLE-FLOAT-NEGATIVE-EPSILON SINGLE-FLOAT-NEGATIVE-EPSILON)
+
+(DEFCONSTANT LONG-FLOAT-NEGATIVE-EPSILON SINGLE-FLOAT-NEGATIVE-EPSILON)
+
+(DEFCONSTANT PI (%FLOAT 16457 4059))
+
+
+
+(IL:* IL:|;;| "Internal constants")
+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFCONSTANT %E (%FLOAT 16429 63572))
+
+(DEFCONSTANT %2PI (%FLOAT 16585 4059))
+
+(DEFCONSTANT %PI (%FLOAT 16457 4059))
+
+(DEFCONSTANT %2PI/3 (%FLOAT 16390 2706))
+
+(DEFCONSTANT %PI/2 (%FLOAT 16329 4059))
+
+(DEFCONSTANT %-PI/2 (%FLOAT 49097 4059))
+
+(DEFCONSTANT %PI/3 (%FLOAT 16262 2706))
+
+(DEFCONSTANT %PI/4 (%FLOAT 16201 4059))
+
+(DEFCONSTANT %-PI/4 (%FLOAT 48969 4059))
+
+(DEFCONSTANT %PI/6 (%FLOAT 16134 2706))
+
+(DEFCONSTANT %2/PI (%FLOAT 16162 63875))
+)
+
+
+
+(IL:* IL:|;;| "Utility macros")
+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFMACRO %FLOAT-UNBOX (FLOAT SIGN EXP HI LO &OPTIONAL DONTSHIFT) (IL:* IL:|;;| "If dontshift is T -- the floatp fields are simply unpacked (with the hiddenbit restored -- and exp set to 1 for denormalized numbers). If dontshift is NIL -- exp, hi and lo are fiddled so the high bit of hi is on.") (IL:BQUOTE (LET ((FLONUM (FLOAT (IL:\\\, FLOAT)))) (SETQ (IL:\\\, SIGN) (IL:|fetch| (IL:FLOATP IL:SIGNBIT) IL:|of| FLONUM)) (SETQ (IL:\\\, EXP) (IL:|fetch| (IL:FLOATP IL:EXPONENT) IL:|of| FLONUM)) (SETQ (IL:\\\, HI) (IL:|fetch| (IL:FLOATP IL:HIFRACTION) IL:|of| FLONUM)) (SETQ (IL:\\\, LO) (IL:|fetch| (IL:FLOATP IL:LOFRACTION) IL:|of| FLONUM)) (IF (EQ (IL:\\\, EXP) IL:\\MAX.EXPONENT) (IL:* IL:\; "might want to check for NaN's here if EXP = \\MAX.EXPONENT") (ERROR "Not a number: ~s" FLONUM)) (IF (EQ 0 (IL:\\\, EXP)) (WHEN (NOT (AND (EQ 0 (IL:\\\, HI)) (EQ 0 (IL:\\\, LO)))) (IL:* IL:\; "Denormalized number") (SETQ (IL:\\\, EXP) 1) (IL:\\\,@ (IF (NULL DONTSHIFT) (IL:BQUOTE ((LOOP (IF (NOT (EQ 0 (LOGAND (IL:\\\, HI) IL:\\HIDDENBIT))) (RETURN NIL)) (IL:.LLSH1. (IL:\\\, HI) (IL:\\\, LO)) (SETQ (IL:\\\, EXP) (1- (IL:\\\, EXP))))))))) (IL:* IL:\; " Restore the hidden bit") (SETQ (IL:\\\, HI) (+ (IL:\\\, HI) IL:\\HIDDENBIT))) (IL:\\\,@ (IF (NULL DONTSHIFT) (IL:BQUOTE ((IL:.LLSH8. (IL:\\\, HI) (IL:\\\, LO)))))) NIL)))
+
+(DEFMACRO %GET-TABLE-ENTRY (ARRAY INDEX) (IL:BQUOTE (IL:\\GETBASEFLOATP (IL:|fetch| (IL:ONED-ARRAY IL:BASE) IL:|of| (IL:\\\, ARRAY)) (IL:LLSH (IL:\\\, INDEX) 1))))
+
+(DEFMACRO %POLYEVAL (X COEFFS DEGREE) (IL:BQUOTE (IL:\\FLOATBOX ((IL:OPCODES IL:UBFLOAT3 0) (IL:\\FLOATUNBOX (IL:\\\, X)) (IL:|fetch| (IL:ONED-ARRAY IL:BASE) IL:|of| (IL:\\\, COEFFS)) (IL:\\\, DEGREE)))))
+
+(DEFMACRO %UFTRUNCATE (INT REM FLOAT &OPTIONAL DIVISOR) (IL:* IL:|;;| "As in truncate. Assumes FLOAT and DIVISOR are unboxed floatp's. ") (IF DIVISOR (IL:BQUOTE (LET ((FFLOAT (IL:\\\, FLOAT)) (FDIVISOR (IL:\\\, DIVISOR))) (DECLARE (TYPE FLOAT FFLOAT FDIVISOR)) (SETQ (IL:\\\, INT) (IL:UFIX (IL:FQUOTIENT FFLOAT FDIVISOR))) (SETQ (IL:\\\, REM) (- FFLOAT (* FDIVISOR (FLOAT (IL:\\\, INT))))) NIL)) (IL:BQUOTE (LET ((FFLOAT (IL:\\\, FLOAT))) (DECLARE (TYPE FLOAT FFLOAT)) (SETQ (IL:\\\, INT) (IL:UFIX FFLOAT)) (SETQ (IL:\\\, REM) (- FFLOAT (FLOAT (IL:\\\, INT)))) NIL))))
+
+(DEFMACRO %UMAKE-FLOAT (SIGN EXP HI LOW) (IL:* IL:|;;| "as in \\makefloat -- but produces an unboxed number") (IL:BQUOTE (IL:\\FLOATBOX ((IL:OPENLAMBDA (SIGN EXP HI LO) (IL:.LRSH8. HI LO) (SETQ HI (+ (ASH EXP 7) (LOGAND 127 HI))) (IF (EQ SIGN 1) (SETQ HI (LOGIOR IL:\\SIGNBIT HI))) (IL:\\VAG2 HI LO)) (IL:\\\, SIGN) (IL:\\\, EXP) (IL:\\\, HI) (IL:\\\, LOW)))))
+)
+
+
+
+(IL:* IL:|;;| " Unpack floating point functions")
+
+
+(DEFUN DECODE-FLOAT (FLOAT) (SETQ FLOAT (FLOAT FLOAT)) (IF (= FLOAT 0.0) (VALUES 0.0 0 1.0) (LET (SIGN EXP HI LO) (%FLOAT-UNBOX FLOAT SIGN EXP HI LO) (VALUES (IL:\\MAKEFLOAT 0 (1- IL:\\EXPONENT.BIAS) HI LO) (- EXP (1- IL:\\EXPONENT.BIAS)) (IF (EQ SIGN 0) 1.0 -1.0)))))
+
+(DEFUN SCALE-FLOAT (FLOAT INTEGER &OPTIONAL OLD-BOX) (SETQ FLOAT (FLOAT FLOAT)) (IF (= FLOAT 0.0) 0.0 (LET (SIGN EXP HI LO) (%FLOAT-UNBOX FLOAT SIGN EXP HI LO) (IL:\\MAKEFLOAT SIGN (+ EXP INTEGER) HI LO NIL OLD-BOX))))
+
+(DEFUN FLOAT-RADIX (FLOAT) 2)
+
+(DEFUN FLOAT-SIGN (FLOAT1 &OPTIONAL FLOAT2 OLD-BOX) (IL:* IL:|;;| "Old-box is a floatp box to reuse (may be eq to float2)") (IF (FLOATP FLOAT1) (IF (NULL FLOAT2) (IF (MINUSP FLOAT1) -1.0 1.0) (IF (FLOATP FLOAT2) (IF (EQ (MINUSP FLOAT1) (MINUSP FLOAT2)) FLOAT2 (IF (FLOATP OLD-BOX) (LET ((NEW-SIGN-BIT (IF (EQ 0 (IL:FETCH (IL:FLOATP IL:SIGNBIT) IL:OF FLOAT2)) 1 0))) (IL:* IL:|;;| "Now smash the old-box") (IL:\\PUTBASEFLOATP OLD-BOX 0 FLOAT2) (IL:|replace| (IL:FLOATP IL:SIGNBIT) IL:|of| OLD-BOX IL:|with| NEW-SIGN-BIT) OLD-BOX) (- FLOAT2))) (%NOT-FLOAT-ERROR FLOAT2))) (%NOT-FLOAT-ERROR FLOAT1)))
+
+(DEFUN FLOAT-DIGITS (FLOAT) (IF (FLOATP FLOAT) 24 (%NOT-FLOAT-ERROR FLOAT)))
+
+(DEFUN FLOAT-PRECISION (FLOAT) (IF (FLOATP FLOAT) (IF (= FLOAT 0.0) 0 (LET (SIGN EXP HI LO) (%FLOAT-UNBOX FLOAT SIGN EXP HI LO T) (IF (< HI IL:\\HIDDENBIT) (IL:* IL:\; "Denormalized number") (IF (EQ HI 0) (INTEGER-LENGTH LO) (+ 16 (INTEGER-LENGTH HI))) (IL:* IL:\; "Normalized number") 24))) (%NOT-FLOAT-ERROR FLOAT)))
+
+(DEFUN INTEGER-DECODE-FLOAT (FLOAT) (IL:* IL:|;;| "As in decode-float -- but returns integers") (SETQ FLOAT (FLOAT FLOAT)) (IF (= FLOAT 0.0) (VALUES 0 0 1) (LET (SIGN EXP HI LO) (%FLOAT-UNBOX FLOAT SIGN EXP HI LO T) (VALUES (+ (ASH HI 16) LO) (- EXP (+ IL:\\EXPONENT.BIAS 23)) (IF (EQ SIGN 0) 1 -1)))))
+
+
+
+(IL:* IL:|;;| "Exp  (e to the power x)")
+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFCONSTANT %LOG-BASE2-E (%FLOAT 16312 43579))
+)
+
+(XCL:DEFGLOBALVAR %EXP-POLY (IL:* IL:|;;| "%EXP-POLY contains P and Q coefficients of Hart et al EXPB 1103 rational approximation to (EXPT 2 X) in interval (0 .125).   ") (MAKE-ARRAY 6 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 15549 17659) (%FLOAT 16256 0) (%FLOAT 16801 38273) (%FLOAT 17257 7717) (%FLOAT 17597 11739) (%FLOAT 17800 30401))))
+
+(XCL:DEFGLOBALVAR %EXP-TABLE (IL:* IL:|;;| "  %EXP-TABLE contains values of powers (EXPT 2 (/ N 8))  . ") (MAKE-ARRAY 8 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 16256 0) (%FLOAT 16267 38338) (%FLOAT 16280 14320) (%FLOAT 16293 65239) (%FLOAT 16309 1267) (%FLOAT 16325 26410) (%FLOAT 16343 17661) (%FLOAT 16362 49351))))
+
+(DEFUN %EXP-FLOAT (X) (IL:* IL:|;;| "(CL:EXP X) for float X calculated via EXPB 1103 rational approximation of Hart et al. ") (LET ((FX (FLOAT X)) R M N ANSWER RECIPFLG) (DECLARE (TYPE FLOAT FX R)) (IL:* IL:|;;| "First, arrange X to be in interval (0 infinity) via identity (CL:EXP (minus X)) = (/ 1.0 (CL:EXP X))") (WHEN (IL:UFLESSP FX 0.0) (SETQ FX (IL:UFMINUS FX)) (SETQ RECIPFLG T)) (IL:* IL:|;;| "Next, the problem of (CL:EXP X) is converted into a problem (EXPT 2 Y) where Y = (* %LOG-BASE2-E X).   ") (IL:* IL:|;;| "Then range reduction is accomplished via (EXPT 2 Y) = (* (EXPT 2 M) (EXPT 2 (/ N 8)) (EXPT 2 R)) where M and N are integers and R is a float in the interval (0.0 .125).   ") (IL:* IL:|;;| "After M, N, R are determined, (EXPT 2 M) is effected by scaling, (EXPT 2 (/ N 8)) is found by table lookup, and (EXPT 2 R) is calculated by rational approximation EXPB 1103 of Hart et al.  ") (%UFTRUNCATE M R (* %LOG-BASE2-E FX)) (%UFTRUNCATE N R R 0.125) (SETQ FX (IL:FTIMES (%GET-TABLE-ENTRY %EXP-TABLE N) (IL:FQUOTIENT (%POLYEVAL R %EXP-POLY 5) (%POLYEVAL (IL:UFMINUS R) %EXP-POLY 5)))) (COND (RECIPFLG (SETQ ANSWER (SETQ FX (IL:FQUOTIENT 1.0 FX))) (SCALE-FLOAT ANSWER (- M) ANSWER)) (T (SETQ ANSWER FX) (SCALE-FLOAT ANSWER M ANSWER)))))
+
+(DEFUN EXP (NUMBER) (TYPECASE NUMBER (COMPLEX (LET ((EXP (%EXP-FLOAT (COMPLEX-REALPART NUMBER))) (Y (COMPLEX-IMAGPART NUMBER))) (COMPLEX (* EXP (COS Y)) (* EXP (SIN Y))))) (NUMBER (%EXP-FLOAT NUMBER)) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER))))
+
+
+
+(IL:* IL:|;;| "Expt (x to the power y)")
+
+
+(DEFUN %EXPT-INTEGER (BASE POWER) (IL:* IL:|;;| "(EXPT BASE POWER) where BASE is an integer and POWER is an integer. ") (COND ((MINUSP POWER) (/ (%EXPT-INTEGER BASE (- POWER)))) ((EQ BASE 2) (ASH 1 POWER)) (T (IL:* IL:|;;| "Integer to positive integer power") (IL:* IL:\; "Must check first for infinity cases") (COND ((EQ BASE IL:MIN.INTEGER) (IF (INTEGERP POWER) (COND ((< POWER 0) 0) ((EQ POWER 0) 1) ((EQ POWER IL:MAX.INTEGER) (ERROR "Can't raise negative infinity to infinite power.")) ((EVENP POWER) IL:MAX.INTEGER) (T (IL:* IL:\; "Odd integer POWER") IL:MIN.INTEGER)) (ERROR "Can't raise negative infinity to noninteger power." POWER))) ((EQ BASE IL:MAX.INTEGER) (IF (EQ POWER 0) 1 IL:MAX.INTEGER)) ((EQ POWER IL:MAX.INTEGER) (COND ((EQ BASE 0) 0) ((> BASE 0) IL:MAX.INTEGER) (T (ERROR "Can't expt negative number to infinite power.")))) (T (LET ((TOTAL 1)) (LOOP (IF (ODDP POWER) (SETQ TOTAL (* BASE TOTAL))) (SETQ POWER (ASH POWER -1)) (IF (EQ 0 POWER) (RETURN TOTAL)) (SETQ BASE (* BASE BASE)))))))))
+
+(DEFUN %EXPT-FLOAT-INTEGER (BASE POWER) (IL:* IL:|;;| "(EXPT BASE POWER) where BASE is a float and POWER is an integer. ") (COND ((MINUSP POWER) (IL:FQUOTIENT 1.0 (%EXPT-FLOAT-INTEGER BASE (- POWER)))) (T (IL:* IL:|;;| "float to positive integer power") (LET ((FBASE (FLOAT BASE)) (TOTAL 1.0)) (DECLARE (TYPE FLOAT FBASE TOTAL)) (LOOP (IF (ODDP POWER) (SETQ TOTAL (* FBASE TOTAL))) (SETQ POWER (ASH POWER -1)) (IF (EQ 0 POWER) (RETURN TOTAL)) (SETQ FBASE (* FBASE FBASE)))))))
+
+(DEFUN EXPT (BASE-NUMBER POWER-NUMBER) (IL:* IL:|;;| "This function calculates BASE-NUMBER raised to the nth power.  It separates the cases by the type of POWER-NUMBER for efficiency reasons, as powers can be calculated more efficiently if POWER-NUMBER is a positive integer, Therefore, All integer values of POWER-NUMBER are calculated as positive integers, and inverted if negative. ") (TYPECASE POWER-NUMBER (INTEGER (IF (EQ POWER-NUMBER 0) (TYPECASE BASE-NUMBER (FLOAT 1.0) ((COMPLEX FLOAT) (COMPLEX 1.0 0.0)) (NUMBER 1) (OTHERWISE (%NOT-NUMBER-ERROR BASE-NUMBER))) (TYPECASE BASE-NUMBER (INTEGER (%EXPT-INTEGER BASE-NUMBER POWER-NUMBER)) (RATIO (%MAKE-RATIO (%EXPT-INTEGER (RATIO-NUMERATOR BASE-NUMBER) POWER-NUMBER) (%EXPT-INTEGER (RATIO-DENOMINATOR BASE-NUMBER) POWER-NUMBER))) (FLOAT (%EXPT-FLOAT-INTEGER BASE-NUMBER POWER-NUMBER)) (COMPLEX (* (%EXPT-FLOAT-INTEGER (%COMPLEX-ABS BASE-NUMBER) POWER-NUMBER) (CIS (* POWER-NUMBER (PHASE BASE-NUMBER))))) (OTHERWISE (%NOT-NUMBER-ERROR BASE-NUMBER))))) (NUMBER (IF (= BASE-NUMBER 0) BASE-NUMBER (EXP (* POWER-NUMBER (LOG BASE-NUMBER))))) (OTHERWISE (%NOT-NUMBER-ERROR POWER-NUMBER))))
+
+
+
+(IL:* IL:|;;| "Log (log base e)")
+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFCONSTANT %LOG2 (%FLOAT 16177 29208))
+
+(DEFCONSTANT %SQRT2 (%FLOAT 16309 1267))
+)
+
+(XCL:DEFGLOBALVAR %LOG-PPOLY (IL:* IL:|;;| "%LOG-PPOLY and %LOG-QPOLY contain P and Q coefficients of Hart et al LOGE 2707 rational approximation to (LOG X) in interval ((SQRT .5) (SQRT 2))") (MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 16042 22803) (%FLOAT 49484 23590) (%FLOAT 17044 17982) (%FLOAT 49926 37153) (%FLOAT 17046 5367))))
+
+(XCL:DEFGLOBALVAR %LOG-QPOLY (IL:* IL:|;;| "%LOG-PPOLY and %LOG-QPOLY contain P and Q coefficients of Hart et al LOGE 2707 rational approximation to (LOG X) in interval ((SQRT .5) (SQRT 2))") (MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 16256 0) (%FLOAT 49512 9103) (%FLOAT 16992 42274) (%FLOAT 49823 38048) (%FLOAT 16918 5367))))
+
+(DEFUN %LOG-FLOAT (X) (IL:* IL:|;;| "(LOG X) for positive float X. ") (IF (<= (SETQ X (FLOAT X)) 0.0) (ERROR "Log of zero: ~s" X)) (IL:* IL:|;;| "Range reduce to an R in interval ((SQRT 0.5) (SQRT 2)) via identity (LOG X) = (+ (LOG R) (* %LOG-2 EXP)) for a suitable integer EXP.  exp is found from the  exponent field of the iee floating point number representation of x.") (LET (R EXP ANSWER) (DECLARE (TYPE FLOAT R)) (LET (SIGN HI LO) (%FLOAT-UNBOX X SIGN EXP HI LO) (SETQ EXP (- EXP IL:\\EXPONENT.BIAS)) (SETQ R (%UMAKE-FLOAT SIGN IL:\\EXPONENT.BIAS HI LO)) NIL) (WHEN (IL:UFGREATERP R %SQRT2) (SETQ EXP (1+ EXP)) (SETQ R (IL:FQUOTIENT R 2.0))) (IL:* IL:|;;| "(LOG R) is calculated by rational approximation LOGE 2707 of Hart et al.") (LET* ((Z (IL:FQUOTIENT (1- R) (1+ R))) (Z2 (* Z Z))) (DECLARE (TYPE FLOAT Z Z2)) (SETQ ANSWER (SETQ R (+ (* Z (IL:FQUOTIENT (%POLYEVAL Z2 %LOG-PPOLY 4) (%POLYEVAL Z2 %LOG-QPOLY 4))) (* %LOG2 EXP))))) ANSWER))
+
+(DEFUN LOG (NUMBER &OPTIONAL BASE) (IF BASE (IL:QUOTIENT (LOG NUMBER) (LOG BASE)) (TYPECASE NUMBER ((OR FLOAT RATIONAL) (IF (MINUSP NUMBER) (COMPLEX (%LOG-FLOAT (- NUMBER)) PI) (%LOG-FLOAT NUMBER))) (COMPLEX (COMPLEX (%LOG-FLOAT (%COMPLEX-ABS NUMBER)) (PHASE NUMBER))) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER)))))
+
+
+
+(IL:* IL:|;;| "Sqrt")
+
+
+(DEFUN %SQRT-FLOAT (X) (IL:* IL:|;;| "(SQRT X) for nonnegative float X") (SETQ X (FLOAT X)) (IF (<= X 0.0) 0.0 (LET ((FX X) V) (DECLARE (TYPE FLOAT FX V)) (LET (SIGN EXP HI LO) (%FLOAT-UNBOX X SIGN EXP HI LO) (IL:* IL:|;;| "First guess") (SETQ V (%UMAKE-FLOAT 0 (+ (ASH EXP -1) (IL:CONSTANT (1+ (ASH IL:\\EXPONENT.BIAS -1)))) HI LO)) NIL) (IL:* IL:|;;| "Four step newton-raphson") (DOTIMES (I 4 V) (SETQ V (* 0.5 (+ V (IL:FQUOTIENT FX V))))))))
+
+(DEFUN %SQRT-COMPLEX (Z) (IL:* IL:|;;| "(SQRT X) for complex X. ") (LET ((R (FLOAT (COMPLEX-REALPART Z))) (I (FLOAT (COMPLEX-IMAGPART Z))) (ABS (SQRT (ABS Z))) (PHASE (IL:FQUOTIENT (PHASE Z) 2.0)) C D E ANSWER) (DECLARE (TYPE FLOAT ABS R I)) (IL:* IL:|;;| "Newton's method.") (LET ((C (* ABS (COS PHASE))) (D (* ABS (SIN PHASE))) E) (DECLARE (TYPE FLOAT C D E)) (DOTIMES (K 4 (COMPLEX C D)) (SETQ E (+ (* C C) (* D D))) (SETQ C (* 0.5 (+ C (IL:FQUOTIENT (+ (* R C) (* I D)) E)))) (SETQ D (* 0.5 (+ D (IL:FQUOTIENT (- (* I C) (* R D)) E))))))))
+
+(DEFUN SQRT (NUMBER) (IF (= NUMBER 0) 0.0 (TYPECASE NUMBER (COMPLEX (%SQRT-COMPLEX NUMBER)) (NUMBER (IF (MINUSP NUMBER) (IL:* IL:\; "Negative real axis maps into positive imaginary axis.") (COMPLEX 0 (SQRT (- NUMBER))) (%SQRT-FLOAT NUMBER))) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER)))))
+
+
+
+(IL:* IL:|;;| "Sin and Cos")
+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFCONSTANT %SIN-EPSILON (IL:* IL:|;;| "%SIN-EPSILON is sufficiently small that (SIN X) = X for X in interval (0 %SIN-EPSILON).  It suffices to take %SIN-EPSILON a little bit smaller than (SQRT (* 6 SINGLE-FLOAT-EPSILON)) which we get by the Taylor series expansion (SIN X) = (+ X (/ (EXPT X 3) 6) ...) (The relative error caused by ommitting (/ (EXPT X 3) 6) isn't observable.) Comparison against %SIN-EPSILON is used to avoid POLYEVAL microcode underflow when computing SIN.") (%FLOAT 14720 0))
+)
+
+(XCL:DEFGLOBALVAR %SIN-PPOLY (IL:* IL:|;;| "%SIN-PPOLY and %SIN-QPOLY contain adapted P and Q coefficients of Hart et al SIN 3374 rational approximation to (SIN X) in interval (0 (/ PI 2)).  The coefficients for %SIN-PPOLY and %SIN-QPOLY have been computed from Hart using extended precision routines and the relations %SIN-PPOLY = (REVERSE (for I from 0 as ENTRY in PS collect (/ (* (EXPT (/ 2 PI) (1+ (* 2 I))) ENTRY) Q0))) and %SIN-QPOLY = (REVERSE (for I from 0 as ENTRY in QS collect (/ (* (EXPT (/ 2 PI) (* 2 I)) ENTRY) Q0)))") (MAKE-ARRAY 6 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 45236 25611) (%FLOAT 13589 26148) (%FLOAT 47286 34797) (%FLOAT 15295 3306) (%FLOAT 48666 34805) (%FLOAT 16256 0))))
+
+(XCL:DEFGLOBALVAR %SIN-QPOLY (IL:* IL:|;;| "%SIN-PPOLY and %SIN-QPOLY contain adapted P and Q coefficients of Hart et al SIN 3374 rational approximation to (SIN X) in interval (0 (/ PI 2)).  The coefficients for %SIN-PPOLY and %SIN-QPOLY have been computed from Hart using extended precision routines and the relations %SIN-PPOLY = (REVERSE (for I from 0 as ENTRY in PS collect (/ (* (EXPT (/ 2 PI) (1+ (* 2 I))) ENTRY) Q0))) and %SIN-QPOLY = (REVERSE (for I from 0 as ENTRY in QS collect (/ (* (EXPT (/ 2 PI) (* 2 I)) ENTRY) Q0))) *") (MAKE-ARRAY 6 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 11384 52865) (%FLOAT 12553 9550) (%FLOAT 13604 38385) (%FLOAT 14593 18841) (%FLOAT 15489 5549) (%FLOAT 16256 0))))
+
+(DEFUN %SIN-FLOAT (X COS-FLG) (IL:* IL:|;;| "SIN of a FLOAT X calculated via SIN 3374 rational approximation of Hart et al.  ") (LET ((THETA (FLOAT X)) (SIGN 1.0) SIGN) (DECLARE (TYPE FLOAT THETA SIGN)) (IL:* IL:|;;| "If this function is called by COS then use (COS X) = (SIN (-- %PI/2 X)) = (SIN (+ %PI/2 X)). Case out on sign of X for improved numerical stability.  Avoids unnecessary rounding and promotes symmetric properties.  (COS X) = (COS (-- X)) is guaranteed by this strategy.") (IF COS-FLG (IF (IL:UFGREATERP THETA 0.0) (SETQ THETA (- %PI/2 THETA)) (SETQ THETA (+ %PI/2 THETA)))) (IL:* IL:|;;| "First range reduce to (0 infinity) by (SIN (minus X)) = (minus (SIN X)) This strategy guarantees (SIN (minus X)) = (minus (SIN X))") (WHEN (IL:UFLESSP THETA 0.0) (SETQ SIGN -1.0) (SETQ THETA (IL:UFMINUS THETA))) (IL:* IL:|;;| "Next range reduce to interval (0 %2PI) by (SIN X) = (SIN (MOD X %2PI)) ") (IF (IL:UFGEQ THETA %2PI) (SETQ THETA (- THETA (* %2PI (FLOAT (IL:UFIX (IL:FQUOTIENT THETA %2PI))))))) (IL:* IL:|;;| "Next range reduce to interval (0 PI) by (SIN (+ X PI)) = (minus (SIN X)) ") (WHEN (IL:UFGREATERP THETA PI) (SETQ THETA (- THETA PI)) (SETQ SIGN (IL:UFMINUS SIGN))) (IL:* IL:|;;| "Next range reduce to interval (0 %PI/2) by (SIN (+ X %PI/2)) = (SIN (minus %PI/2 X))") (IF (IL:UFGREATERP THETA %PI/2) (SETQ THETA (- PI THETA))) (IF (IL:UFLESSP THETA %SIN-EPSILON) (IL:* IL:|;;| "If R is in the interval (0 %SIN-EPSILON) then (SIN R) = R to the precision that we can offer.  Return R because (1) it is desirable that (SIN R) = R exactly for small R and (2) microcode POLYEVAL will underflow on sufficiently small positive R") (SETQ THETA (* SIGN THETA)) (IL:* IL:|;;| "Now use SIN 3374 rational approximation of Harris et al.  which works on interval (0 %PI/2) ") (LET ((R2 (* THETA THETA))) (DECLARE (TYPE FLOAT R2)) (SETQ THETA (* SIGN THETA (IL:FQUOTIENT (%POLYEVAL R2 %SIN-PPOLY 5) (%POLYEVAL R2 %SIN-QPOLY 5))))))))
+
+(DEFUN SIN (RADIANS) (TYPECASE RADIANS (COMPLEX (LET ((X (COMPLEX-REALPART RADIANS)) (Y (COMPLEX-IMAGPART RADIANS))) (COMPLEX (* (SIN X) (COSH Y)) (* (COS X) (SINH Y))))) (NUMBER (%SIN-FLOAT RADIANS NIL)) (OTHERWISE (%NOT-NUMBER-ERROR RADIANS))))
+
+(DEFUN COS (RADIANS) (TYPECASE RADIANS (COMPLEX (LET ((X (COMPLEX-REALPART RADIANS)) (Y (COMPLEX-IMAGPART RADIANS))) (COMPLEX (* (COS X) (COSH Y)) (- (* (SIN X) (SINH Y)))))) (NUMBER (%SIN-FLOAT RADIANS T)) (OTHERWISE (%NOT-NUMBER-ERROR RADIANS))))
+
+
+
+(IL:* IL:|;;| "Tan")
+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFCONSTANT %TAN-EPSILON (IL:* IL:|;;| "%TAN-EPSILON is sufficiently small that (TAN X) = X for X in interval (0 %TAN-EPSILON).  It suffices to take %TAN-EPSILON a little bit smaller than (SQRT (* 3 SINGLE-FLOAT-EPSILON)) which we get by the Taylor series expansion (TAN X) = (+ X (/ (EXPT X 3) 3) ...) (The relative error caused by ommitting (/ (EXPT X 3) 3) isn't observable.) Comparison against %TAN-EPSILON is used to avoid POLYEVAL microcode underflow when computing TAN.") (%FLOAT 14720 0))
+)
+
+(XCL:DEFGLOBALVAR %TAN-PPOLY (IL:* IL:|;;| "%TAN-PPOLY and %TAN-QPOLY contain adapted P and Q coefficients of Hart et al TAN 4288 rational approximation to (TAN X) in interval (-PI/4 PI/4).  The coefficients for %TAN-PPOLY and %TAN-QPOLY have been computed from Hart using extended precision routines and the relations %TAN-PPOLY = (REVERSE (for I from 0 as ENTRY in PS collect (/ (* (EXPT (/ 4 PI) (1+ (* 2 I))) ENTRY) Q0))) and %TAN-QPOLY = (REVERSE (for I from 0 as ENTRY in QS collect (/ (* (EXPT (/ 4 PI) (* 2 I)) ENTRY) Q0))) ") (MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 13237 21090) (%FLOAT 47141 15825) (%FLOAT 15246 8785) (%FLOAT 48655 48761) (%FLOAT 16256 0))))
+
+(XCL:DEFGLOBALVAR %TAN-QPOLY (IL:* IL:|;;| "%TAN-PPOLY and %TAN-QPOLY contain adapted P and Q coefficients of Hart et al TAN 4288 rational approximation to (TAN X) in interval (-PI/4 PI/4).  The coefficients for %TAN-PPOLY and %TAN-QPOLY have been computed from Hart using extended precision routines and the relations %TAN-PPOLY = (REVERSE (for I from 0 as ENTRY in PS collect (/ (* (EXPT (/ 4 PI) (1+ (* 2 I))) ENTRY) Q0))) and %TAN-QPOLY = (REVERSE (for I from 0 as ENTRY in QS collect (/ (* (EXPT (/ 4 PI) (* 2 I)) ENTRY) Q0))) ") (MAKE-ARRAY 6 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 45267 36947) (%FLOAT 13848 46875) (%FLOAT 47612 53738) (%FLOAT 15596 52854) (%FLOAT 48882 35303) (%FLOAT 16256 0))))
+
+(DEFUN %TAN-FLOAT (X) (IL:* IL:|;;| "TAN of a FLOAT X calculated via TAN 4288 rational approximation of Hart et al.") (LET ((FX (FLOAT X)) (SIGN 1.0) RECIPFLG) (DECLARE (TYPE FLOAT FX SIGN)) (IL:* IL:|;;| "First range reduce to (0 infinity) by (TAN (minus X)) = (minus (TAN X))") (WHEN (IL:UFLESSP FX 0.0) (SETQ SIGN -1.0) (SETQ FX (IL:UFMINUS FX))) (IL:* IL:|;;| "Next range reduce to (0 PI)") (IF (IL:UFGEQ FX PI) (SETQ FX (- FX (* PI (FLOAT (IL:UFIX (IL:FQUOTIENT FX PI))))))) (IL:* IL:|;;| "Next, range reduce to (-PI/4 PI/4) using (TAN X) = (TAN (minus X PI)) to get into interval (-PI/2 PI/2) and then (TAN X) = (/ (TAN (minus PI/2 X))) to get into interval (-PI/4 PI/4) ") (COND ((IL:UFGREATERP FX %PI/2) (SETQ FX (- FX PI)) (WHEN (IL:UFLESSP FX %-PI/4) (SETQ RECIPFLG T) (SETQ FX (- %-PI/2 FX)))) (T (WHEN (IL:UFGREATERP FX %PI/4) (SETQ RECIPFLG T) (SETQ FX (- %PI/2 FX))))) (COND ((IL:UFLESSP (IL:UFABS FX) %TAN-EPSILON) (IL:* IL:|;;| "If R is in the interval (0 %TAN-EPSILON) then (TAN R) = R to the precision that we can offer.  Return R because (1) it is desirable that (TAN R) = R exactly for small R and (2) microcode POLYEVAL will underflow on sufficiently small positive R.") (SETQ FX (* SIGN FX)) (IF RECIPFLG (SETQ FX (IL:FQUOTIENT 1.0 FX)) FX)) (T (IL:* IL:|;;| "Now use TAN 4288 rational approximation of Hart et al.  which works on interval (0 %PI/4)") (LET ((R2 (* FX FX))) (DECLARE (TYPE FLOAT R2)) (SETQ FX (* SIGN FX (IL:FQUOTIENT (%POLYEVAL R2 %TAN-PPOLY 4) (%POLYEVAL R2 %TAN-QPOLY 5)))) (IF RECIPFLG (SETQ FX (IL:FQUOTIENT 1.0 FX)) FX))))))
+
+(DEFUN TAN (RADIANS) (TYPECASE RADIANS (COMPLEX (LET* ((X (* 2.0 (COMPLEX-REALPART RADIANS))) (Y (* 2.0 (COMPLEX-IMAGPART RADIANS))) (DENOM (+ (COS X) (COSH Y)))) (COMPLEX (IL:QUOTIENT (SIN X) DENOM) (IL:QUOTIENT (SINH Y) DENOM)))) (NUMBER (%TAN-FLOAT RADIANS)) (OTHERWISE (%NOT-NUMBER-ERROR RADIANS))))
+
+
+
+(IL:* IL:|;;| "Asin and Acos")
+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFCONSTANT %ASIN-EPSILON (IL:* IL:|;;| "%ASIN-EPSILON is sufficiently small that (ASIN X) = X for X in interval (0 %ASIN-EPSILON).  It suffices to take %ASIN-EPSILON a little bit smaller than (* 2 SINGLE-FLOAT-EPSILON) which we get by the Taylor series expansion (ASIN X) = (+ X (/ (EXPT X 3) 6) ...) (The relative error caused by ommitting (/ (EXPT X 3) 6) isn't observable.) Comparison against %ASIN-EPSILON is used to avoid POLYEVAL microcode underflow when computing SIN.") (%FLOAT 14720 0))
+)
+
+(XCL:DEFGLOBALVAR %ASIN-PPOLY (IL:* IL:|;;| "%ASIN-PPOLY and %ASIN-QPOLY contain P and Q coefficients of Hart et al ARCSN 4671 rational approximation to (ASIN X) in interval (0 (SQRT .5)).") (MAKE-ARRAY 7 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 16007 50045) (%FLOAT 49549 8020) (%FLOAT 17236 15848) (%FLOAT 50285 63464) (%FLOAT 17650 31235) (%FLOAT 50403 62852) (%FLOAT 17440 39471))))
+
+(XCL:DEFGLOBALVAR %ASIN-QPOLY (IL:* IL:|;;| "%ASIN-PPOLY and %ASIN-QPOLY contain P and Q coefficients of Hart et al ARCSN 4671 rational approximation to (ASIN X) in interval (0 (SQRT .5)).") (MAKE-ARRAY 7 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 16256 0) (%FLOAT 49672 25817) (%FLOAT 17308 55260) (%FLOAT 50326 38098) (%FLOAT 17674 22210) (%FLOAT 50417 22451) (%FLOAT 17440 39471))))
+
+(DEFUN %ASIN-FLOAT (X ACOS-FLG) (IL:* IL:|;;| "(ASIN X) for float X calculated via ARCSN 4671 rational approximation of Hart et al.") (IF (OR (< X -1.0) (> X 1.0)) (ERROR "Arg not in range: ~s" X)) (LET ((FX (FLOAT X)) NEGATIVE REDUCED) (DECLARE (TYPE FLOAT FX)) (IL:* IL:|;;| "Range reduce to (0 1) via identity (ASIN (minus X)) = (minus (ASIN X)) ") (WHEN (IL:UFLESSP FX 0.0) (SETQ NEGATIVE T) (SETQ FX (IL:UFMINUS FX))) (IL:* IL:|;;| "Range reduce to (0 0.5) via identity (ASIN X) = (minus %PI/2 (* 2.0 (ASIN (SQRT (* 0.5 (minus 1.0 R)))))) Avoids numerical instability calculating (ASIN X) for X near one.  SIN is horizontally flat near %PI/2 so calculating (ASIN X) by rational approximation wouldn't work well for X near (SIN %PI/2) = 1") (WHEN (IL:UFGREATERP FX 0.5) (SETQ REDUCED T) (SETQ FX (SQRT (SETQ FX (* 0.5 (- 1.0 FX)))))) (IL:* IL:|;;| "R is now in range (0 0.5) Use ARCSN 4671 rational approximation to calculate (ASIN R) ") (IF (IL:UFGREATERP FX %ASIN-EPSILON) (IL:* IL:|;;| "If R is in the interval (0 %SIN-EPSILON) then (ASIN R) = R to the precision that we can offer. ") (LET ((R2 (* FX FX))) (DECLARE (TYPE FLOAT R2)) (SETQ FX (* FX (IL:QUOTIENT (%POLYEVAL R2 %ASIN-PPOLY 6) (%POLYEVAL R2 %ASIN-QPOLY 6)))) NIL)) (IF REDUCED (SETQ FX (- %PI/2 (* 2.0 FX)))) (IF NEGATIVE (SETQ FX (IL:UFMINUS FX))) (IL:* IL:|;;| "In case we want (ACOS X) then use identity (ACOS X) = (minus %PI/2 (ASIN X))") (IF ACOS-FLG (SETQ FX (- %PI/2 FX))) FX))
+
+(DEFUN ASIN (NUMBER) (TYPECASE NUMBER (COMPLEX (LET ((Z (LOG (+ (COMPLEX (- (COMPLEX-IMAGPART NUMBER)) (COMPLEX-REALPART NUMBER)) (SQRT (- 1 (* NUMBER NUMBER))))))) (COMPLEX (COMPLEX-IMAGPART Z) (- (COMPLEX-REALPART Z))))) (NUMBER (%ASIN-FLOAT NUMBER NIL)) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER))))
+
+(DEFUN ACOS (RADIANS) (TYPECASE RADIANS (COMPLEX (LET ((Z (SQRT (- 1 (* RADIANS RADIANS))))) (SETQ Z (LOG (+ RADIANS (COMPLEX (- (COMPLEX-IMAGPART Z)) (COMPLEX-REALPART Z))))) (COMPLEX (COMPLEX-IMAGPART Z) (- (COMPLEX-REALPART Z))))) (NUMBER (%ASIN-FLOAT RADIANS T)) (OTHERWISE (%NOT-NUMBER-ERROR RADIANS))))
+
+
+
+(IL:* IL:|;;| "Atan ")
+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFCONSTANT %SQRT3 (%FLOAT 16349 46039))
+
+(DEFCONSTANT %2-SQRT3 (%FLOAT 16009 12451))
+
+(DEFCONSTANT %INV-2-SQRT3 (%FLOAT 16494 55788))
+)
+
+(DEFUN %ATAN-FLOAT (Y &OPTIONAL X) (LET ((FY (FLOAT Y)) FX FARG) (DECLARE (TYPE FLOAT FY FX FARG)) (IL:* IL:|;;| "Compute farg") (COND ((NULL X) (IF (= Y 0.0) (RETURN-FROM %ATAN-FLOAT 0.0) (SETQ FARG FY))) (T (IL:* IL:|;;| "Don't use unboxed version of =, because it doesn't return t on comparison of 0.0 and -0.0") (SETQ FX (FLOAT X)) (COND ((= X 0.0) (IF (= Y 0.0) (ERROR "Both args to atan are 0.0") (RETURN-FROM %ATAN-FLOAT (IF (> Y 0.0) %PI/2 (- %PI/2))))) ((= Y 0.0) (RETURN-FROM %ATAN-FLOAT (IF (> X 0.0) 0.0 PI))) ((> Y 0.0) (IF (> X 0.0) (SETQ FARG (IL:FQUOTIENT FY FX)) (SETQ FARG (IL:FQUOTIENT (IL:UFMINUS FY) FX)))) ((> X 0.0) (SETQ FARG (IL:FQUOTIENT FY (IL:UFMINUS FX)))) (T (SETQ FARG (IL:FQUOTIENT FY FX)))))) (IL:* IL:|;;| "Compute result") (LET ((CONSTANT 0.0) (CONSTANT-FLAG T) NEGATE-FLAG ADD-FLAG) (DECLARE (TYPE FLOAT CONSTANT)) (IL:* IL:|;;| "(ATAN (minus X)) = (minus (ATAN X)) ") (WHEN (IL:UFLESSP FARG 0.0) (SETQ NEGATE-FLAG T) (SETQ FARG (IL:UFMINUS FARG))) (IL:* IL:|;;| "Range reduce to (0, 2-sqrt(3))") (COND ((IL:UFGEQ FARG %INV-2-SQRT3) (IL:* IL:|;;| "(ATAN X) = (minus %PI/2 (ATAN (/ X)))") (SETQ CONSTANT %PI/2) (SETQ FARG (IL:FQUOTIENT 1.0 FARG))) ((IL:UFGEQ FARG 1.0) (SETQ CONSTANT %PI/3) (SETQ FARG (IL:FQUOTIENT (- %SQRT3 FARG) (+ 1.0 (* FARG %SQRT3))))) ((IL:UFGEQ FARG %2-SQRT3) (SETQ ADD-FLAG T) (SETQ CONSTANT %PI/6) (SETQ FARG (IL:FQUOTIENT (- (* FARG %SQRT3) 1.0) (+ %SQRT3 FARG)))) (T (SETQ CONSTANT-FLAG NIL))) (IL:* IL:|;;| "Power series expansion cons'ed up on the fly") (LET ((SQR (IL:UFMINUS (* FARG FARG))) (INT 1.0) (POW FARG) (OLD 0.0)) (DECLARE (TYPE FLOAT SQR INT POW OLD)) (LOOP (IF (IL:UFEQP FARG OLD) (RETURN NIL)) (SETQ INT (+ INT 2.0)) (SETQ POW (* POW SQR)) (SETQ OLD FARG) (SETQ FARG (+ FARG (IL:FQUOTIENT POW INT))))) (IF CONSTANT-FLAG (IF ADD-FLAG (SETQ FARG (+ CONSTANT FARG)) (SETQ FARG (- CONSTANT FARG)))) (IF NEGATE-FLAG (SETQ FARG (IL:UFMINUS FARG)))) (IL:* IL:|;;| "Fix up") (IF X (COND ((IL:UFGREATERP FY 0.0) (IF (IL:UFLESSP FX 0.0) (SETQ FARG (- PI FARG)))) ((IL:UFGREATERP FX 0.0) (SETQ FARG (IL:UFMINUS FARG))) (T (SETQ FARG (- FARG PI))))) (IL:* IL:|;;| "Box and return") FARG))
+
+(DEFUN ATAN (Y &OPTIONAL X) (COND (X (%ATAN-FLOAT (FLOAT Y) (FLOAT X))) ((COMPLEXP Y) (LET ((R (COMPLEX-REALPART Y)) (I (COMPLEX-IMAGPART Y))) (IF (NOT (AND (ZEROP R) (= (ABS I) 1))) (LET ((Z (COMPLEX (- I) R))) (SETQ Z (* 0.5 (LOG (/ (+ 1 Z) (- 1 Z))))) (COMPLEX (COMPLEX-IMAGPART Z) (- (COMPLEX-REALPART Z)))) (ERROR "Argument not in domain for atan. ~S" Y)))) (T (%ATAN-FLOAT Y))))
+
+
+
+(IL:* IL:|;;| "Cis (exp (i x))")
+
+
+(DEFUN CIS (RADIANS) (IF (TYPEP RADIANS (QUOTE (AND NUMBER (NOT COMPLEX)))) (COMPLEX (%SIN-FLOAT RADIANS T) (%SIN-FLOAT RADIANS)) (%NOT-NONCOMPLEX-NUMBER-ERROR RADIANS)))
+
+
+
+(IL:* IL:|;;| "Sinh, Cosh Tanh")
+
+
+(DEFUN SINH (NUMBER) (IL:* IL:|;;| "Computed directly from its ") (IF (COMPLEXP NUMBER) (LET ((Z (EXP NUMBER))) (/ (- Z (/ Z)) 2)) (LET ((FZ (%EXP-FLOAT NUMBER))) (DECLARE (TYPE FLOAT FZ)) (SETQ FZ (IL:FQUOTIENT (- FZ (IL:FQUOTIENT 1.0 FZ)) 2.0)))))
+
+(DEFUN COSH (NUMBER) (IF (COMPLEXP NUMBER) (LET ((Z (EXP NUMBER))) (/ (+ Z (/ Z)) 2)) (LET ((FZ (%EXP-FLOAT NUMBER))) (DECLARE (TYPE FLOAT FZ)) (SETQ FZ (IL:FQUOTIENT (+ FZ (IL:FQUOTIENT 1.0 FZ)) 2.0)))))
+
+(DEFUN TANH (NUMBER) (IF (COMPLEXP NUMBER) (/ (SINH NUMBER) (COSH NUMBER)) (LET* ((FX (%EXP-FLOAT (* 2 NUMBER))) (FY (IL:FQUOTIENT 1.0 FX))) (DECLARE (TYPE FLOAT FX FY)) (SETQ FX (- (IL:FQUOTIENT 1.0 (+ 1.0 FY)) (IL:FQUOTIENT 1.0 (+ 1.0 FX)))))))
+
+
+
+(IL:* IL:|;;| "Asinh Acosh Atanh")
+
+
+(DEFUN ASINH (NUMBER) (IF (COMPLEXP NUMBER) (LOG (+ NUMBER (SQRT (+ (* NUMBER NUMBER) 1)))) (LET ((FX (FLOAT NUMBER)) BOX) (DECLARE (TYPE FLOAT FX BOX)) (LOG (SETQ BOX (+ FX (SQRT (SETQ BOX (+ (* FX FX) 1.0)))))))))
+
+(DEFUN ACOSH (NUMBER) (IF (OR (COMPLEXP NUMBER) (< NUMBER 1)) (LOG (+ NUMBER (* (+ NUMBER 1) (SQRT (/ (- NUMBER 1) (+ NUMBER 1)))))) (LET ((FX (FLOAT NUMBER)) BOX) (DECLARE (TYPE FLOAT FX BOX)) (LOG (SETQ BOX (+ FX (SQRT (SETQ BOX (- (* FX FX) 1.0)))))))))
+
+(DEFUN ATANH (NUMBER) (IF (OR (COMPLEXP NUMBER) (> (ABS NUMBER) 1)) (IF (AND (ZEROP (IMAGPART NUMBER)) (= (ABS (REALPART NUMBER)) 1)) (ERROR "Argument out of range. ~s" NUMBER) (* 0.5 (LOG (/ (+ 1 NUMBER) (- 1 NUMBER))))) (IF (= NUMBER 1.0) (ERROR "Argument out of range. ~s" NUMBER) (LET ((FX (FLOAT NUMBER)) BOX) (DECLARE (TYPE FLOAT FX BOX)) (SETQ BOX (* 0.5 (LOG (SETQ BOX (IL:FQUOTIENT (+ 1.0 FX) (- 1.0 FX))))))))))
+
+
+
+(IL:* IL:|;;| "rational and rationalize ")
+
+
+(DEFUN %RATIONAL-FLOAT (NUMBER) (IF (= NUMBER 0.0) 0 (LET (SIGN EXP HI LO MANT) (%FLOAT-UNBOX NUMBER SIGN EXP HI LO T) (SETQ MANT (+ (ASH HI 16) LO)) (IF (EQ SIGN 1) (SETQ MANT (- MANT))) (SETQ EXP (- EXP 23 IL:\\EXPONENT.BIAS)) (IF (< EXP 0) (%BUILD-RATIO MANT (ASH 1 (- EXP))) (ASH MANT EXP)))))
+
+(DEFUN %RATIONALIZE-FLOAT (X) (IL:* IL:|;;| "Produce a rational approximating X.  ") (IL:* IL:|;;| "This routine presupposes familiarity with topics in number theory and IEEE FLOATP representation.  The algorithm uses a standard mathematical technique for approximating a real valued number, but in very sophisticated form more amenable to the computer and the nature of IEEE FLOATPs and is not an algorithm you are likely to find published anywhere.   ") (IF (= X 0.0) (IL:* IL:\; "In case X = 0, just return 0 ") 0 (LET (SIGN EXPT HI LO XNUM XDEN R) (IL:* IL:|;;| "First of all, X is range reduced to the interval ((SQRT .5) (SQRT 2)) excluding (SQRT 2) This strategy has the property that FLOATPs differing only by sign and a power of two rationalize into rationals differing only by sign and a power of two.  The choice of interval ((SQRT .5) (SQRT 2)) versus another interval such as (.5 1) is due to our wanting there to be roughly the same number of significant bits in the numerator as in the denominator of the answer that is returned.  Here, significant bits is taken to mean the number of bits in the results returned by the continued fraction approximation and excludes the bits resulting from multiplying by the power of two.  ") (IL:* IL:\; "Get SIGN XNUM XDEN and EXPT for X.  ") (LET (BIT-SIGN EXP HI LO) (%FLOAT-UNBOX X BIT-SIGN EXP HI LO T) (SETQ XNUM (+ (ASH HI 16) LO)) (SETQ EXPT (- EXP (+ IL:\\EXPONENT.BIAS 23))) (SETQ SIGN (IF (EQ BIT-SIGN 0) 1 -1)) (IL:* IL:\; "Compute r") (LOOP (IF (NOT (EQ 0 (LOGAND HI IL:\\HIDDENBIT))) (RETURN NIL)) (IL:* IL:\; "Handle the denormalized case") (IL:.LLSH1. HI LO)) (IL:.LLSH8. HI LO) (SETQ R (IL:\\MAKEFLOAT 0 (1- IL:\\EXPONENT.BIAS) HI LO))) (IL:* IL:\; "24 because FLOATPs have 24 bit mantissas.  ") (SETQ XDEN (IL:CONSTANT (ASH 1 24))) (SETQ EXPT (+ EXPT 24)) (COND ((< XNUM 11863283) (IL:* IL:\; "11863283 = (SQRT 0.5) mantissa.  ") (SETQ XDEN (ASH XDEN -1)) (SETQ EXPT (1- EXPT)) (SETQ R (* 2 R)))) (IL:* IL:|;;| "At this point, X = (* (/ XNUM XDEN) (EXPT 2 EXPT)) and (/ XNUM XDEN) is in the interval ((SQRT 0.5) (SQRT 2)) ") (LET ((OLDNUM 1) (OLDDEN 0) (NUM 0) (DEN 1)) (IL:* IL:\; "Continued fraction approximation loop.  ") (LOOP (COND ((AND (NOT (EQ DEN 0)) (= (IL:FQUOTIENT NUM DEN) R)) (COND ((> EXPT 0) (SETQ NUM (ASH NUM EXPT))) ((< EXPT 0) (SETQ DEN (ASH DEN (- EXPT))))) (RETURN (/ (* SIGN NUM) DEN)))) (ROTATEF XNUM XDEN) (LET ((TRUNC (IL:IQUOTIENT XNUM XDEN))) (SETQ NUM (+ OLDNUM (* TRUNC (SETQ OLDNUM NUM)))) (SETQ DEN (+ OLDDEN (* TRUNC (SETQ OLDDEN DEN)))) (SETQ XNUM (- XNUM (* XDEN TRUNC)))))))))
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
+
+(IL:LOCALVARS . T)
+)
+)
+
+(IL:PUTPROPS IL:CMLFLOAT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
+
+(IL:PUTPROPS IL:CMLFLOAT IL:FILETYPE COMPILE-FILE)
+(IL:PUTPROPS IL:CMLFLOAT IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/CMLFLOAT.LCOM b/CLTL2/CMLFLOAT.LCOM
new file mode 100644
index 00000000..4fa85bf6
Binary files /dev/null and b/CLTL2/CMLFLOAT.LCOM differ
diff --git a/CLTL2/CMLFLOATARRAY b/CLTL2/CMLFLOATARRAY
new file mode 100644
index 00000000..8688b9e4
--- /dev/null
+++ b/CLTL2/CMLFLOATARRAY
@@ -0,0 +1,600 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "19-Oct-93 10:48:08" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLFLOATARRAY.;1" 29993  
+
+      previous date%: "11-Jun-90 14:41:02" "{Pele:mv:envos}<LispCore>Sources>CMLFLOATARRAY.;1")
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1987, 1990, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLFLOATARRAYCOMS)
+
+(RPAQQ CMLFLOATARRAYCOMS
+       [(DECLARE%: DONTCOPY DOEVAL@COMPILE (FILES (SYSLOAD FROM VALUEOF DIRECTORIES)
+                                                  UNBOXEDOPS FLOAT-ARRAY-SUPPORT))
+        
+        (* ;; "MAPARRAY fns and macros")
+
+        (FNS MAP-ARRAY)
+        (FUNCTIONS MAP-ARRAY-1 MAP-ARRAY-2)
+        (FUNCTIONS REDUCE-ARRAY EVALUATE-POLYNOMIAL FIND-ARRAY-ELEMENT-INDEX)
+        (FUNCTIONS FLATTEN-ARG MAX-ABS MIN-ABS)
+        (FUNCTIONS %%MAP-FLOAT-ARRAY-ABS %%MAP-FLOAT-ARRAY-FLOAT %%MAP-FLOAT-ARRAY-MINUS 
+               %%MAP-FLOAT-ARRAY-NEGATE %%MAP-FLOAT-ARRAY-PLUS %%MAP-FLOAT-ARRAY-QUOTIENT 
+               %%MAP-FLOAT-ARRAY-TIMES %%MAP-FLOAT-ARRAY-TRUNCATE %%REDUCE-FLOAT-ARRAY-MAX 
+               %%REDUCE-FLOAT-ARRAY-MAX-ABS %%REDUCE-FLOAT-ARRAY-MIN %%REDUCE-FLOAT-ARRAY-MIN-ABS 
+               %%REDUCE-FLOAT-ARRAY-PLUS %%REDUCE-FLOAT-ARRAY-TIMES)
+        
+        (* ;; "For convenience")
+
+        (PROP FILETYPE CMLFLOATARRAY)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML)
+                                                                             (LAMA MAP-ARRAY])
+(DECLARE%: DONTCOPY DOEVAL@COMPILE 
+
+(FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES)
+       UNBOXEDOPS FLOAT-ARRAY-SUPPORT)
+)
+
+
+
+(* ;; "MAPARRAY fns and macros")
+
+(DEFINEQ
+
+(MAP-ARRAY
+  [LAMBDA ARGS                                               (* ; "Edited  9-Apr-87 16:22 by jop")
+
+    (* ;; "First arg, RESULT, may either be an array of the correct type, or a symbol indicating the element-type of the result, or NIL if the map is for effect. Second arg is the mapping functions. Other args are arrays, all of which must have the same number of elements, or non-arrays which will be treated as scalars ")
+
+    (LISP:IF (< ARGS 3)
+           (LISP:ERROR "MAPARRAY takes at least three args"))
+    (LET ((RESULT (ARG ARGS 1))
+          (MAPFN (ARG ARGS 2))
+          (ARRAY1 (ARG ARGS 3))
+          FIRST-ARRAY)
+
+         (* ;; "Arg checking. First-array is the first array map argument")
+
+         (LISP:IF (NOT (TYPEP MAPFN 'LISP:FUNCTION))
+                (LISP:ERROR "Not a function: ~S" MAPFN))
+         (LISP:DO ((I 3 (LISP:1+ I))
+                   MAP-ARG)
+                  ((> I ARGS))
+             (SETQ MAP-ARG (ARG ARGS I))
+             (LISP:WHEN (LISP:ARRAYP MAP-ARG)
+                 (LISP:IF FIRST-ARRAY
+                     (LISP:IF (NOT (EQUAL-DIMENSIONS-P MAP-ARG FIRST-ARRAY))
+                            (LISP:ERROR "Dimensions mismatch" MAP-ARG))
+                     (SETQ FIRST-ARRAY MAP-ARG))))
+
+         (* ;; "Coerce RESULT into an array or NIL")
+
+         (LISP:TYPECASE RESULT
+             (LISP:ARRAY (LISP:IF [NOT (OR (EQUAL-DIMENSIONS-P RESULT FIRST-ARRAY)
+                                           (AND (NULL FIRST-ARRAY)
+                                                (EQ 0 (LISP:ARRAY-RANK RESULT]
+                                (LISP:ERROR "Dimensions mismatch: ~S" RESULT)))
+             ((OR LISP:SYMBOL CONS) (SETQ RESULT (LISP:IF FIRST-ARRAY
+                                                     (LISP:MAKE-ARRAY (LISP:ARRAY-DIMENSIONS 
+                                                                             FIRST-ARRAY)
+                                                            :ELEMENT-TYPE RESULT)
+                                                     (LISP:MAKE-ARRAY NIL :ELEMENT-TYPE RESULT))))
+             (T (OR (NULL RESULT)
+                    (LISP:ERROR "RESULT must be an array, an element type, or NIL: ~S" RESULT))))
+         (LISP:IF FIRST-ARRAY
+             (LISP:IF (AND RESULT (< ARGS 5))
+                 (LISP:ECASE ARGS
+                     (3                                      (* ; 
+                                                       "Note: in this case (EQ ARRAY1 FIRST-ARRAY)")
+                        (MAP-ARRAY-1 RESULT MAPFN ARRAY1))
+                     (4 (MAP-ARRAY-2 RESULT MAPFN ARRAY1 (ARG ARGS 4))))
+                 [LET* ((FLATTENED-RESULT (FLATTEN-ARG RESULT))
+                        (SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+                        [FLATTENED-ARRAYS (for I from 3 to ARGS
+                                             collect (FLATTEN-ARG (ARG ARGS I]
+                        (ELT-SLICE (LISP:COPY-LIST FLATTENED-ARRAYS))
+                        VALUE)
+                       (LISP:DOTIMES (INDEX SIZE RESULT)
+                           [SETQ VALUE (LISP:APPLY MAPFN (LISP:DO ((%%SUBSLICE ELT-SLICE (CDR 
+                                                                                           %%SUBSLICE
+                                                                                              ))
+                                                                   (%%SUBARRAYS FLATTENED-ARRAYS
+                                                                          (CDR %%SUBARRAYS)))
+                                                                  ((NULL %%SUBARRAYS)
+                                                                   ELT-SLICE)
+                                                             (AND (LISP:ARRAYP (CAR %%SUBARRAYS))
+                                                                  (RPLACA %%SUBSLICE
+                                                                         (LISP:AREF (CAR %%SUBARRAYS)
+                                                                                INDEX))))]
+                           (LISP:IF RESULT
+                               (LISP:SETF (LISP:AREF FLATTENED-RESULT INDEX)
+                                      VALUE)))])
+             (LISP:IF RESULT
+                 [LISP:SETF (LISP:AREF RESULT)
+                        (LISP:APPLY MAPFN (for I from 3 to ARGS
+                                             collect (ARG ARGS I]
+                 (LISP:APPLY MAPFN (for I from 3 to ARGS collect (ARG ARGS I)))))])
+)
+
+(LISP:DEFUN MAP-ARRAY-1 (RESULT MAPFN ARRAY)
+
+   (* ;; 
+ "Does something fast for MAPFNS - abs truncate float and EXPONENT. ARRAY is always an array.")
+
+   [LET [(RESULT-FLOAT-P (EQ (LISP:ARRAY-ELEMENT-TYPE RESULT)
+                             'LISP:SINGLE-FLOAT))
+         (ARRAY-FLOAT-P (EQ (LISP:ARRAY-ELEMENT-TYPE ARRAY)
+                            'LISP:SINGLE-FLOAT]              (* ; "Coerce MAPFN to standard form")
+        (SETQ MAPFN (LISP:TYPECASE MAPFN
+                        (LISP:SYMBOL (CASE MAPFN
+                                         (MINUS '-)
+                                         (FIX 'LISP:TRUNCATE)
+                                         (T MAPFN)))
+                        (COMPILED-CLOSURE (COND
+                                             ((OR (LISP::%%EQCODEP MAPFN '-)
+                                                  (LISP::%%EQCODEP MAPFN 'MINUS))
+                                              '-)
+                                             ((LISP::%%EQCODEP MAPFN 'ABS)
+                                              'ABS)
+                                             ((OR (LISP::%%EQCODEP MAPFN 'FIX)
+                                                  (LISP::%%EQCODEP MAPFN 'LISP:TRUNCATE))
+                                              'LISP:TRUNCATE)
+                                             ((LISP::%%EQCODEP MAPFN 'FLOAT)
+                                              'FLOAT)
+                                             (T MAPFN)))
+                        (T MAPFN)))
+        (COND
+           ((AND (EQ MAPFN '-)
+                 RESULT-FLOAT-P ARRAY-FLOAT-P)
+            (%%MAP-FLOAT-ARRAY-NEGATE RESULT ARRAY))
+           ((AND (EQ MAPFN 'ABS)
+                 RESULT-FLOAT-P ARRAY-FLOAT-P)
+            (%%MAP-FLOAT-ARRAY-ABS RESULT ARRAY))
+           ((AND (EQ MAPFN 'LISP:TRUNCATE)
+                 ARRAY-FLOAT-P)
+            (%%MAP-FLOAT-ARRAY-TRUNCATE RESULT ARRAY))
+           ((AND (EQ MAPFN 'FLOAT)
+                 RESULT-FLOAT-P)
+            (%%MAP-FLOAT-ARRAY-FLOAT RESULT ARRAY))
+           (T (LET ((FLATTENED-RESULT (FLATTEN-ARG RESULT))
+                    (FLATTENED-ARRAY (FLATTEN-ARG ARRAY)))
+                   (LISP:DOTIMES (INDEX (LISP:ARRAY-TOTAL-SIZE RESULT)
+                                        RESULT)
+                       (LISP:SETF (LISP:AREF FLATTENED-RESULT INDEX)
+                              (LISP:FUNCALL MAPFN (LISP:AREF FLATTENED-ARRAY INDEX))))])
+
+(LISP:DEFUN MAP-ARRAY-2 (RESULT MAPFN ARRAY-1 ARRAY-2)
+
+   (* ;; "Does something fast for MAPFNS + - * /. At least one of ARRAY-1 and ARRAY-2 is an array")
+
+   [LET [(ARRAYS-FLOAT-P (AND (EQ (LISP:ARRAY-ELEMENT-TYPE RESULT)
+                                  'LISP:SINGLE-FLOAT)
+                              [OR (TYPEP ARRAY-1 '(LISP:ARRAY LISP:SINGLE-FLOAT))
+                                  (TYPEP ARRAY-1 '(OR FLOAT LISP:RATIONAL]
+                              (OR (TYPEP ARRAY-2 '(LISP:ARRAY LISP:SINGLE-FLOAT))
+                                  (TYPEP ARRAY-2 '(OR FLOAT LISP:RATIONAL]
+                                                             (* ; "Coerce MAPFN to standard form")
+        (SETQ MAPFN (LISP:TYPECASE MAPFN
+                        (LISP:SYMBOL (CASE MAPFN
+                                         (PLUS '+)
+                                         (MINUS '-)
+                                         (TIMES 'LISP:*)
+                                         (QUOTIENT '/)
+                                         (T MAPFN)))
+                        (COMPILED-CLOSURE (COND
+                                             ((OR (LISP::%%EQCODEP MAPFN '+)
+                                                  (LISP::%%EQCODEP MAPFN 'PLUS))
+                                              '+)
+                                             ((OR (LISP::%%EQCODEP MAPFN '-)
+                                                  (LISP::%%EQCODEP MAPFN 'MINUS))
+                                              '-)
+                                             ((OR (LISP::%%EQCODEP MAPFN 'LISP:*)
+                                                  (LISP::%%EQCODEP MAPFN 'TIMES))
+                                              'LISP:*)
+                                             ((OR (LISP::%%EQCODEP MAPFN '/)
+                                                  (LISP::%%EQCODEP MAPFN 'QUOTIENT))
+                                              '/)
+                                             (T MAPFN)))
+                        (T MAPFN)))
+        (COND
+           ((AND (EQ MAPFN '+)
+                 ARRAYS-FLOAT-P)
+            (%%MAP-FLOAT-ARRAY-PLUS RESULT ARRAY-1 ARRAY-2))
+           ((AND (EQ MAPFN '-)
+                 ARRAYS-FLOAT-P)
+            (%%MAP-FLOAT-ARRAY-MINUS RESULT ARRAY-1 ARRAY-2))
+           ((AND (EQ MAPFN 'LISP:*)
+                 ARRAYS-FLOAT-P)
+            (%%MAP-FLOAT-ARRAY-TIMES RESULT ARRAY-1 ARRAY-2))
+           ((AND (EQ MAPFN '/)
+                 ARRAYS-FLOAT-P)
+            (%%MAP-FLOAT-ARRAY-QUOTIENT RESULT ARRAY-1 ARRAY-2))
+           (T (LET ((FLATTENED-RESULT (FLATTEN-ARG RESULT))
+                    (FLATTENED-ARRAY-1 (FLATTEN-ARG ARRAY-1))
+                    (FLATTENED-ARRAY-2 (FLATTEN-ARG ARRAY-2)))
+                   (LISP:IF (LISP:ARRAYP ARRAY-1)
+                       (LISP:IF (LISP:ARRAYP ARRAY-2)
+                           (LISP:DOTIMES (INDEX (LISP:ARRAY-TOTAL-SIZE RESULT)
+                                                RESULT)
+                               (LISP:SETF (LISP:AREF FLATTENED-RESULT INDEX)
+                                      (LISP:FUNCALL MAPFN (LISP:AREF FLATTENED-ARRAY-1 INDEX)
+                                             (LISP:AREF FLATTENED-ARRAY-2 INDEX))))
+                           (LISP:DOTIMES (INDEX (LISP:ARRAY-TOTAL-SIZE RESULT)
+                                                RESULT)
+                               (LISP:SETF (LISP:AREF FLATTENED-RESULT INDEX)
+                                      (LISP:FUNCALL MAPFN (LISP:AREF FLATTENED-ARRAY-1 INDEX)
+                                             FLATTENED-ARRAY-2))))
+                       (LISP:DOTIMES (INDEX (LISP:ARRAY-TOTAL-SIZE RESULT)
+                                            RESULT)
+                           (LISP:SETF (LISP:AREF FLATTENED-RESULT INDEX)
+                                  (LISP:FUNCALL MAPFN FLATTENED-ARRAY-1 (LISP:AREF FLATTENED-ARRAY-2
+                                                                               INDEX)))))])
+
+(LISP:DEFUN REDUCE-ARRAY (REDUCTION-FN ARRAY &OPTIONAL (INITIAL-VALUE NIL INITIAL-VALUE-P))
+   (SETQ REDUCTION-FN (LISP:TYPECASE REDUCTION-FN
+                          (LISP:SYMBOL (CASE REDUCTION-FN
+                                           (PLUS '+)
+                                           (TIMES 'LISP:*)
+                                           (T REDUCTION-FN)))
+                          (COMPILED-CLOSURE (COND
+                                               ((OR (LISP::%%EQCODEP REDUCTION-FN '+)
+                                                    (LISP::%%EQCODEP REDUCTION-FN 'PLUS))
+                                                '+)
+                                               ((OR (LISP::%%EQCODEP REDUCTION-FN 'LISP:*)
+                                                    (LISP::%%EQCODEP REDUCTION-FN 'TIMES))
+                                                'LISP:*)
+                                               ((LISP::%%EQCODEP REDUCTION-FN 'MIN)
+                                                'MIN)
+                                               ((LISP::%%EQCODEP REDUCTION-FN 'MAX)
+                                                'MAX)
+                                               ((LISP::%%EQCODEP REDUCTION-FN 'MIN-ABS)
+                                                'MIN-ABS)
+                                               ((LISP::%%EQCODEP REDUCTION-FN 'MAX-ABS)
+                                                'MAX-ABS)
+                                               (T REDUCTION-FN)))
+                          (T REDUCTION-FN)))
+   (LISP:IF (NOT (LISP:ARRAYP ARRAY))
+       (LISP:IF INITIAL-VALUE-P
+           (LISP:FUNCALL REDUCTION-FN INITIAL-VALUE ARRAY)
+           ARRAY)
+       [LET [(SIZE (LISP:ARRAY-TOTAL-SIZE ARRAY))
+             (ARRAY-FLOAT-P (EQ (LISP:ARRAY-ELEMENT-TYPE ARRAY)
+                                'LISP:SINGLE-FLOAT]
+            (CASE SIZE
+                (0 (LISP:IF INITIAL-VALUE-P
+                       INITIAL-VALUE
+                       (LISP:FUNCALL REDUCTION-FN)))
+                (1 (LISP:IF INITIAL-VALUE-P
+                       (LISP:FUNCALL REDUCTION-FN INITIAL-VALUE (LISP:AREF (FLATTEN-ARG ARRAY)
+                                                                       0))
+                       (LISP:AREF (FLATTEN-ARG ARRAY)
+                              0)))
+                (T [COND
+                      ((AND (EQ REDUCTION-FN '+)
+                            ARRAY-FLOAT-P)
+                       (%%REDUCE-FLOAT-ARRAY-PLUS ARRAY INITIAL-VALUE))
+                      ((AND (EQ REDUCTION-FN 'LISP:*)
+                            ARRAY-FLOAT-P)
+                       (%%REDUCE-FLOAT-ARRAY-TIMES ARRAY INITIAL-VALUE))
+                      ((AND (EQ REDUCTION-FN 'MIN)
+                            ARRAY-FLOAT-P)
+                       (%%REDUCE-FLOAT-ARRAY-MIN ARRAY INITIAL-VALUE))
+                      ((AND (EQ REDUCTION-FN 'MAX)
+                            ARRAY-FLOAT-P)
+                       (%%REDUCE-FLOAT-ARRAY-MAX ARRAY INITIAL-VALUE))
+                      ((AND (EQ REDUCTION-FN 'MIN-ABS)
+                            ARRAY-FLOAT-P)
+                       (%%REDUCE-FLOAT-ARRAY-MIN-ABS ARRAY INITIAL-VALUE))
+                      ((AND (EQ REDUCTION-FN 'MAX-ABS)
+                            ARRAY-FLOAT-P)
+                       (%%REDUCE-FLOAT-ARRAY-MAX-ABS ARRAY INITIAL-VALUE))
+                      (T (LISP:DO* ((FLATTENED-ARRAY (FLATTEN-ARG ARRAY))
+                                    (ACCUMULATOR (LISP:IF INITIAL-VALUE-P
+                                                     INITIAL-VALUE
+                                                     (LISP:AREF FLATTENED-ARRAY 0)))
+                                    (INDEX (LISP:IF INITIAL-VALUE-P
+                                               0
+                                               1)
+                                           (LISP:1+ INDEX)))
+                                   ((EQ INDEX SIZE)
+                                    ACCUMULATOR)
+                             (SETQ ACCUMULATOR (LISP:FUNCALL REDUCTION-FN ACCUMULATOR
+                                                      (LISP:AREF FLATTENED-ARRAY INDEX))))]))]))
+
+(LISP:DEFUN EVALUATE-POLYNOMIAL (X COEFFICIENTS)
+   (LISP:IF (NOT (LISP:ARRAYP COEFFICIENTS))
+       (LISP:ERROR "Not an array: ~S" COEFFICIENTS)
+       (LISP:IF (EQ (LISP:ARRAY-ELEMENT-TYPE COEFFICIENTS)
+                    'LISP:SINGLE-FLOAT)
+           (%%POLY-EVAL (FLOAT X)
+                  (%%GET-FLOAT-ARRAY-BASE COEFFICIENTS)
+                  (LISP:1- (LISP:ARRAY-TOTAL-SIZE COEFFICIENTS)))
+           (LISP:DO ((FLATTENED-ARRAY (FLATTEN-ARG COEFFICIENTS))
+                     (INDEX 1 (LISP:1+ INDEX))
+                     (SIZE (LISP:ARRAY-TOTAL-SIZE COEFFICIENTS))
+                     (PRODUCT (LISP:AREF COEFFICIENTS 0)))
+                    ((EQ INDEX SIZE)
+                     PRODUCT)
+               (SETQ PRODUCT (+ (LISP:* X PRODUCT)
+                                (LISP:AREF COEFFICIENTS INDEX)))))))
+
+(LISP:DEFUN FIND-ARRAY-ELEMENT-INDEX (ELEMENT ARRAY)
+   (LISP:IF (NOT (LISP:ARRAYP ARRAY))
+       (LISP:ERROR "Not an array: ~S" ARRAY)
+       (LISP:IF (EQ (LISP:ARRAY-ELEMENT-TYPE ARRAY)
+                    'LISP:SINGLE-FLOAT)
+           (LISP:DO ((BASE (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                           (\ADDBASE BASE 2))
+                     (INDEX 0 (LISP:1+ INDEX))
+                     (F-ELEMENT (FLOAT ELEMENT))
+                     (SIZE (LISP:ARRAY-TOTAL-SIZE ARRAY)))
+                    ((EQ INDEX SIZE)
+                     NIL)
+               (DECLARE (TYPE FLOAT F-ELEMENT))
+               (LISP:IF (UFEQP F-ELEMENT (\GETBASEFLOATP BASE 0))
+                      (RETURN INDEX)))
+           (LISP:DO ((FLATTENED-ARRAY (FLATTEN-ARG ARRAY))
+                     (INDEX 0 (LISP:1+ INDEX))
+                     (SIZE (LISP:ARRAY-TOTAL-SIZE ARRAY)))
+                    ((EQ INDEX SIZE)
+                     NIL)
+               (LISP:IF (EQL ELEMENT (LISP:AREF FLATTENED-ARRAY INDEX))
+                      (RETURN INDEX))))))
+
+(LISP:DEFUN FLATTEN-ARG (ARG)
+   (LISP:IF (OR (NOT (LISP:ARRAYP ARG))
+                (EQ 1 (LISP:ARRAY-RANK ARG)))
+       ARG
+       (LISP:MAKE-ARRAY (LISP:ARRAY-TOTAL-SIZE ARG)
+              :ELEMENT-TYPE
+              (LISP:ARRAY-ELEMENT-TYPE ARG)
+              :DISPLACED-TO ARG)))
+
+(LISP:DEFUN MAX-ABS (X Y)
+   (LISP:IF (> (ABS X)
+               (ABS Y))
+       X
+       Y))
+
+(LISP:DEFUN MIN-ABS (X Y)
+   (LISP:IF (< (ABS X)
+               (ABS Y))
+       X
+       Y))
+
+(LISP:DEFUN %%MAP-FLOAT-ARRAY-ABS (RESULT ARRAY)
+   (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+             (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                    (\ADDBASE RESULT-BASE 2))
+             (ARRAY-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                    (\ADDBASE ARRAY-BASE 2))
+             (INDEX 0 (LISP:1+ INDEX)))
+            ((EQ INDEX SIZE)
+             RESULT)
+       (\PUTBASEFLOATP RESULT-BASE 0 (UFABS (\GETBASEFLOATP ARRAY-BASE 0)))))
+
+(LISP:DEFUN %%MAP-FLOAT-ARRAY-FLOAT (RESULT ARRAY)
+   (LET ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT)))
+        (LISP:IF (EQUAL (LISP:ARRAY-ELEMENT-TYPE ARRAY)
+                        '(LISP:UNSIGNED-BYTE 16))
+            (%%BLKSMALLP2FLOAT (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                   (%%GET-FLOAT-ARRAY-BASE RESULT)
+                   SIZE)
+            (LISP:DO ((RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                             (\ADDBASE RESULT-BASE 2))
+                      (INDEX 0 (LISP:1+ INDEX)))
+                     ((EQ INDEX SIZE))
+                (\PUTBASEFLOATP RESULT-BASE 0 (FLOAT (LISP:AREF ARRAY INDEX)))))
+        RESULT))
+
+(LISP:DEFUN %%MAP-FLOAT-ARRAY-MINUS (RESULT ARRAY-1 ARRAY-2)
+   (LISP:IF (LISP:ARRAYP ARRAY-1)
+       (LISP:IF (LISP:ARRAYP ARRAY-2)
+           (%%BLKFDIFF (%%GET-FLOAT-ARRAY-BASE ARRAY-1)
+                  (%%GET-FLOAT-ARRAY-BASE ARRAY-2)
+                  (%%GET-FLOAT-ARRAY-BASE RESULT)
+                  (LISP:ARRAY-TOTAL-SIZE RESULT))
+           (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+                     (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                            (\ADDBASE RESULT-BASE 2))
+                     (ARRAY-1-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-1)
+                            (\ADDBASE ARRAY-1-BASE 2))
+                     (SCALAR (FLOAT ARRAY-2))
+                     (INDEX 0 (LISP:1+ INDEX)))
+                    ((EQ INDEX SIZE))
+               (DECLARE (TYPE FLOATP SCALAR))
+               (\PUTBASEFLOATP RESULT-BASE 0 (FDIFFERENCE (\GETBASEFLOATP ARRAY-1-BASE 0)
+                                                    SCALAR))))
+       (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+                 (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                        (\ADDBASE RESULT-BASE 2))
+                 (SCALAR (FLOAT ARRAY-1))
+                 (ARRAY-2-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-2)
+                        (\ADDBASE ARRAY-2-BASE 2))
+                 (INDEX 0 (LISP:1+ INDEX)))
+                ((EQ INDEX SIZE))
+           (DECLARE (TYPE FLOATP SCALAR))
+           (\PUTBASEFLOATP RESULT-BASE 0 (FDIFFERENCE SCALAR (\GETBASEFLOATP ARRAY-2-BASE 0)))))
+   RESULT)
+
+(LISP:DEFUN %%MAP-FLOAT-ARRAY-NEGATE (RESULT ARRAY)
+   (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+             (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                    (\ADDBASE RESULT-BASE 2))
+             (ARRAY-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                    (\ADDBASE ARRAY-BASE 2))
+             (INDEX 0 (LISP:1+ INDEX)))
+            ((EQ INDEX SIZE)
+             RESULT)
+       (\PUTBASEFLOATP RESULT-BASE 0 (UFMINUS (\GETBASEFLOATP ARRAY-BASE 0)))))
+
+(LISP:DEFUN %%MAP-FLOAT-ARRAY-PLUS (RESULT ARRAY-1 ARRAY-2)
+   (LISP:IF (NOT (LISP:ARRAYP ARRAY-1))
+          (LISP:ROTATEF ARRAY-1 ARRAY-2))                    (* ; "addition is commutative")
+   (LISP:IF (LISP:ARRAYP ARRAY-2)
+       (%%BLKFPLUS (%%GET-FLOAT-ARRAY-BASE ARRAY-1)
+              (%%GET-FLOAT-ARRAY-BASE ARRAY-2)
+              (%%GET-FLOAT-ARRAY-BASE RESULT)
+              (LISP:ARRAY-TOTAL-SIZE RESULT))
+       (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+                 (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                        (\ADDBASE RESULT-BASE 2))
+                 (ARRAY-1-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-1)
+                        (\ADDBASE ARRAY-1-BASE 2))
+                 (SCALAR (FLOAT ARRAY-2))
+                 (INDEX 0 (LISP:1+ INDEX)))
+                ((EQ INDEX SIZE))
+           (DECLARE (TYPE FLOATP SCALAR))
+           (\PUTBASEFLOATP RESULT-BASE 0 (FPLUS (\GETBASEFLOATP ARRAY-1-BASE 0)
+                                                SCALAR))))
+   RESULT)
+
+(LISP:DEFUN %%MAP-FLOAT-ARRAY-QUOTIENT (RESULT ARRAY-1 ARRAY-2)
+   (LISP:IF (LISP:ARRAYP ARRAY-1)
+       (LISP:IF (LISP:ARRAYP ARRAY-2)
+           (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+                     (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                            (\ADDBASE RESULT-BASE 2))
+                     (ARRAY-1-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-1)
+                            (\ADDBASE ARRAY-1-BASE 2))
+                     (ARRAY-2-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-2)
+                            (\ADDBASE ARRAY-1-BASE 2))
+                     (INDEX 0 (LISP:1+ INDEX)))
+                    ((EQ INDEX SIZE))
+               (\PUTBASEFLOATP RESULT-BASE 0 (FQUOTIENT (\GETBASEFLOATP ARRAY-1-BASE 0)
+                                                    (\GETBASEFLOATP ARRAY-2-BASE 0))))
+           (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+                     (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                            (\ADDBASE RESULT-BASE 2))
+                     (ARRAY-1-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-1)
+                            (\ADDBASE ARRAY-1-BASE 2))
+                     (SCALAR (FLOAT ARRAY-2))
+                     (INDEX 0 (LISP:1+ INDEX)))
+                    ((EQ INDEX SIZE))
+               (DECLARE (TYPE FLOATP SCALAR))
+               (\PUTBASEFLOATP RESULT-BASE 0 (FQUOTIENT (\GETBASEFLOATP ARRAY-1-BASE 0)
+                                                    SCALAR))))
+       (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+                 (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                        (\ADDBASE RESULT-BASE 2))
+                 (SCALAR (FLOAT ARRAY-1))
+                 (ARRAY-2-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-2)
+                        (\ADDBASE ARRAY-2-BASE 2))
+                 (INDEX 0 (LISP:1+ INDEX)))
+                ((EQ INDEX SIZE))
+           (DECLARE (TYPE FLOATP SCALAR))
+           (\PUTBASEFLOATP RESULT-BASE 0 (FQUOTIENT SCALAR (\GETBASEFLOATP ARRAY-2-BASE 0)))))
+   RESULT)
+
+(LISP:DEFUN %%MAP-FLOAT-ARRAY-TIMES (RESULT ARRAY-1 ARRAY-2)
+   (LISP:IF (NOT (LISP:ARRAYP ARRAY-1))
+          (LISP:ROTATEF ARRAY-1 ARRAY-2))                    (* ; "Multiplication is commutative")
+   (LISP:IF (LISP:ARRAYP ARRAY-2)
+       (%%BLKFTIMES (%%GET-FLOAT-ARRAY-BASE ARRAY-1)
+              (%%GET-FLOAT-ARRAY-BASE ARRAY-2)
+              (%%GET-FLOAT-ARRAY-BASE RESULT)
+              (LISP:ARRAY-TOTAL-SIZE RESULT))
+       (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+                 (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                        (\ADDBASE RESULT-BASE 2))
+                 (ARRAY-1-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-1)
+                        (\ADDBASE ARRAY-1-BASE 2))
+                 (SCALAR (FLOAT ARRAY-2))
+                 (INDEX 0 (LISP:1+ INDEX)))
+                ((EQ INDEX SIZE))
+           (DECLARE (TYPE FLOATP SCALAR))
+           (\PUTBASEFLOATP RESULT-BASE 0 (FTIMES (\GETBASEFLOATP ARRAY-1-BASE 0)
+                                                SCALAR))))
+   RESULT)
+
+(LISP:DEFUN %%MAP-FLOAT-ARRAY-TRUNCATE (RESULT ARRAY)
+   (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+             (ARRAY-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                    (\ADDBASE ARRAY-BASE 2))
+             (INDEX 0 (LISP:1+ INDEX)))
+            ((EQ INDEX SIZE)
+             RESULT)
+       (LISP:SETF (LISP:AREF RESULT INDEX)
+              (UFIX (\GETBASEFLOATP ARRAY-BASE 0)))))
+
+(LISP:DEFUN %%REDUCE-FLOAT-ARRAY-MAX (ARRAY INITIAL-VALUE)
+   (LET [(RESULT (LISP:AREF ARRAY (%%BLKFMAX (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                                         0
+                                         (LISP:ARRAY-TOTAL-SIZE ARRAY]
+        (LISP:IF INITIAL-VALUE
+            (MAX INITIAL-VALUE RESULT)
+            RESULT)))
+
+(LISP:DEFUN %%REDUCE-FLOAT-ARRAY-MAX-ABS (ARRAY INITIAL-VALUE)
+   (LET [(RESULT (LISP:AREF ARRAY (%%BLKFABSMAX (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                                         0
+                                         (LISP:ARRAY-TOTAL-SIZE ARRAY]
+        (LISP:IF INITIAL-VALUE
+            (MAX-ABS INITIAL-VALUE RESULT)
+            RESULT)))
+
+(LISP:DEFUN %%REDUCE-FLOAT-ARRAY-MIN (ARRAY INITIAL-VALUE)
+   (LET [(RESULT (LISP:AREF ARRAY (%%BLKFMIN (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                                         0
+                                         (LISP:ARRAY-TOTAL-SIZE ARRAY]
+        (LISP:IF INITIAL-VALUE
+            (MIN INITIAL-VALUE RESULT)
+            RESULT)))
+
+(LISP:DEFUN %%REDUCE-FLOAT-ARRAY-MIN-ABS (ARRAY INITIAL-VALUE)
+   (LET [(RESULT (LISP:AREF ARRAY (%%BLKFABSMIN (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                                         0
+                                         (LISP:ARRAY-TOTAL-SIZE ARRAY]
+        (LISP:IF INITIAL-VALUE
+            (MIN-ABS INITIAL-VALUE RESULT)
+            RESULT)))
+
+(LISP:DEFUN %%REDUCE-FLOAT-ARRAY-PLUS (ARRAY INITIAL-VALUE)
+   (LET [(RESULT (%%POLY-EVAL 1.0 (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                        (LISP:1- (LISP:ARRAY-TOTAL-SIZE ARRAY]
+        (LISP:IF INITIAL-VALUE
+            (+ INITIAL-VALUE RESULT)
+            RESULT)))
+
+(LISP:DEFUN %%REDUCE-FLOAT-ARRAY-TIMES (ARRAY INITIAL-VALUE)
+   (LET ((TOTAL 1.0))
+        (DECLARE (TYPE FLOAT TOTAL))
+        (LISP:DO ((I 0 (LISP:1+ I))
+                  (BASE (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                        (\ADDBASE BASE 2))
+                  (SIZE (LISP:ARRAY-TOTAL-SIZE ARRAY)))
+                 ((EQ I SIZE)
+                  TOTAL)
+            (SETQ TOTAL (LISP:* TOTAL (\GETBASEFLOATP BASE 0))))
+        (LISP:IF INITIAL-VALUE
+            (LISP:* INITIAL-VALUE TOTAL)
+            TOTAL)))
+
+
+
+(* ;; "For convenience")
+
+
+(PUTPROPS CMLFLOATARRAY FILETYPE LISP:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA MAP-ARRAY)
+)
+(PUTPROPS CMLFLOATARRAY COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (1897 6534 (MAP-ARRAY 1907 . 6532)))))
+STOP
diff --git a/CLTL2/CMLFLOATARRAY.LCOM b/CLTL2/CMLFLOATARRAY.LCOM
new file mode 100644
index 00000000..15242e88
Binary files /dev/null and b/CLTL2/CMLFLOATARRAY.LCOM differ
diff --git a/CLTL2/CMLFORMAT b/CLTL2/CMLFORMAT
new file mode 100644
index 00000000..afb37ce4
--- /dev/null
+++ b/CLTL2/CMLFORMAT
@@ -0,0 +1,1997 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 12:11:00" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLFORMAT.;2" 102570 
+
+      previous date%: "25-Oct-91 16:43:17" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLFORMAT.;1")
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLFORMATCOMS)
+
+(RPAQQ CMLFORMATCOMS
+       (
+        (* ;; "The FORMAT facility")
+
+        (STRUCTURES FORMAT-ERROR)
+        (FUNCTIONS MAKE-DISPATCH-VECTOR SCALE-EXPONENT SCALE-EXPT-AUX)
+        (FUNCTIONS FORMAT-ERROR)
+        (VARIABLES *DIGIT-STRING* *DIGITS*)
+        (FUNCTIONS FLONUM-TO-STRING FORMAT-WITH-CONTROL-STRING FORMAT-STRINGIFY-OUTPUT POP-FORMAT-ARG
+               WITH-FORMAT-PARAMETERS NEXTCHAR FORMAT-PEEK FORMAT-FIND-CHAR)
+        (FUNCTIONS FORMAT-GET-PARAMETER PARSE-FORMAT-OPERATION FORMAT-FIND-COMMAND LISP:FORMAT 
+               FORMAT-MAYBE-PPRINT SUB-FORMAT)
+        
+        (* ;; "Top-level entries in *FORMAT-DISPATCH-TABLE*")
+
+        (FUNCTIONS FORMAT-PRINT-BINARY FORMAT-PRINT-OCTAL FORMAT-PRINT-HEXADECIMAL FORMAT-PRINT-RADIX
+               FORMAT-FIXED FORMAT-EXPONENTIAL FORMAT-GENERAL-FLOAT FORMAT-PRINC 
+               FORMAT-PRINT-CHARACTER FORMAT-PLURAL FORMAT-PRIN1 FORMAT-TAB FORMAT-TERPRI 
+               FORMAT-FRESHLINE FORMAT-SKIP-ARGUMENTS FORMAT-PAGE FORMAT-TILDE FORMAT-DOLLARS 
+               FORMAT-INDIRECTION FORMAT-ESCAPE FORMAT-SEMICOLON-ERROR FORMAT-CONDITION 
+               FORMAT-ITERATION FORMAT-JUSTIFICATION FORMAT-CAPITALIZATION FORMAT-NEWLINE 
+               FORMAT-JUST-WRITE FORMAT-PPRINT-NEWLINE FORMAT-PPRINT-INDENT FORMAT-CALL-FUNCTION)
+        
+        (* ;; "Direct support for top-level entries")
+
+        (FUNCTIONS FORMAT-ROUND-COLUMNS FORMAT-EAT-WHITESPACE FORMAT-PRINT-NAMED-CHARACTER 
+               FORMAT-ADD-COMMAS FORMAT-WRITE-FIELD FORMAT-PRINT-NUMBER FORMAT-PRINT-SMALL-CARDINAL 
+               FORMAT-PRINT-CARDINAL FORMAT-PRINT-CARDINAL-AUX FORMAT-PRINT-ORDINAL 
+               FORMAT-PRINT-OLD-ROMAN FORMAT-PRINT-ROMAN FORMAT-PRINT-DECIMAL FORMAT-PRINT-RADIX-AUX
+               FORMAT-FIXED-AUX FORMAT-EXPONENT-MARKER FORMAT-EXP-AUX FORMAT-GENERAL-AUX 
+               FORMAT-UNTAGGED-CONDITION FORMAT-FUNNY-CONDITION FORMAT-BOOLEAN-CONDITION 
+               FORMAT-DO-ITERATION FORMAT-GET-TRAILING-SEGMENTS FORMAT-GET-SEGMENTS 
+               FORMAT-PPRINT-LOGICAL-BLOCK FORMAT-CHECK-JUSTIFY)
+        (FUNCTIONS CHARPOS WHITESPACE-CHAR-P MAKE-PAD-SEGS FORMAT-LOGICAL-FILL)
+        (FUNCTIONS NAME-ARRAY)
+        (VARIABLES *FORMAT-ARGUMENTS* *OUTER-FORMAT-ARGUMENTS* *FORMAT-CONTROL-STRING* 
+               *FORMAT-DISPATCH-TABLE* *FORMAT-INDEX* *FORMAT-LENGTH* *FORMAT-ORIGINAL-ARGUMENTS* 
+               *FORMAT-LOGICAL-BLOCK* *FORMAT-JUSTIFICATION* *FORMAT-INCOMPATIBLE-JUSTIFICATION* 
+               *FORMAT-COLON-ITERATION* CARDINAL-ONES CARDINAL-TENS CARDINAL-TEENS CARDINAL-PERIODS 
+               ORDINAL-ONES ORDINAL-TENS)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML)
+                                                                             (LAMA)))
+        
+        (* ;; "Arrange to use the correct compiler.")
+
+        (PROP FILETYPE CMLFORMAT)))
+
+
+
+(* ;; "The FORMAT facility")
+
+
+(DEFINE-CONDITION FORMAT-ERROR (LISP:ERROR)
+   (ARGS)
+   [:REPORT (LISP:LAMBDA (CONDITION *STANDARD-OUTPUT*)
+                   (LISP:FORMAT T "~%%~:{~@?~%%~}" (FORMAT-ERROR-ARGS CONDITION])
+
+(DEFMACRO MAKE-DISPATCH-VECTOR (&BODY ENTRIES)
+
+   (* ;; "Hairy dispatch-table initialization macro. Takes a list of two-element lists (<character> <function-object>) and returns a vector char-code-limit elements in length, where the Ith element is the function associated with the character with char-code I. If the character is case-convertible, it must be given in only one case however, an entry in the vector will be made for both.")
+
+   [LET ((ENTRIES (LISP:MAPCAN #'[LISP:LAMBDA (X)
+                                        (LET [(LOWER (LISP:CHAR-DOWNCASE (CAR X)))
+                                              (UPPER (LISP:CHAR-UPCASE (CAR X]
+                                             (LISP:IF (LISP:CHAR= LOWER UPPER)
+                                                 (LIST X)
+                                                 (LIST (CONS UPPER (CDR X))
+                                                       (CONS LOWER (CDR X))))]
+                         ENTRIES)))
+        (LISP:DO ([ENTRIES (SORT ENTRIES #'(LISP:LAMBDA (X Y)
+                                                  (LISP:CHAR< (CAR X)
+                                                         (CAR Y]
+                  (CHARIDX 0 (LISP:1+ CHARIDX))
+                  (COMTAB NIL (CONS (LISP:IF ENTRIES
+                                          (LISP:IF (= (LISP:CHAR-CODE (CAAR ENTRIES))
+                                                      CHARIDX)
+                                              (CADR (pop ENTRIES))
+                                              NIL)
+                                          NIL)
+                                      COMTAB)))
+                 [(= CHARIDX 256)
+                  (LISP:IF ENTRIES (LISP:ERROR "Garbage in dispatch vector - ~S" ENTRIES))
+                  `(LISP:MAKE-ARRAY '(256)
+                          :ELEMENT-TYPE T :INITIAL-CONTENTS ',(LISP:NREVERSE COMTAB])])
+
+(LISP:DEFUN SCALE-EXPONENT (X)
+   (SCALE-EXPT-AUX X 0.0 1.0 10.0 0.1 (CONSTANT (LISP:LOG 2.0 10.0))))
+
+(LISP:DEFUN SCALE-EXPT-AUX (X ZERO ONE TEN ONE-TENTH LOG10-OF-2)
+   [LISP:MULTIPLE-VALUE-BIND (SIG EXPONENT)
+          (LISP:DECODE-FLOAT X)
+          (DECLARE (IGNORE SIG))
+          (LISP:IF (= X ZERO)
+              (LISP:VALUES ZERO 1)
+              [LET* [(E (ROUND (LISP:* EXPONENT LOG10-OF-2)))
+                     (NEWX (LISP:IF (MINUSP E)
+                               (LISP:* X TEN (LISP:EXPT TEN (- -1 E)))
+                               (/ X TEN (LISP:EXPT TEN (LISP:1- E))))]
+                    (LISP:DO ((D TEN (LISP:* D TEN))
+                              (Y NEWX (/ NEWX D))
+                              (E E (LISP:1+ E)))
+                             [(< Y ONE)
+                              (LISP:DO ((M TEN (LISP:* M TEN))
+                                        (Z Y (LISP:* Z M))
+                                        (E E (LISP:1- E)))
+                                       ((>= Z ONE-TENTH)
+                                        (LISP:VALUES (/ X (LISP:EXPT 10 E))
+                                               E)))])])])
+
+(LISP:DEFUN FORMAT-ERROR (COMPLAINT &REST FORMAT-ARGS)
+   [LISP:ERROR 'FORMAT-ERROR :ARGS (LIST (LIST "~?~%%~S~%%~V@T^" COMPLAINT FORMAT-ARGS 
+                                               *FORMAT-CONTROL-STRING* (LISP:1+ *FORMAT-INDEX*])
+
+(LISP:DEFVAR *DIGIT-STRING* (LISP:MAKE-ARRAY 50 :ELEMENT-TYPE 'LISP:STRING-CHAR :FILL-POINTER 0 
+                                       :ADJUSTABLE T))
+
+(LISP:DEFCONSTANT *DIGITS* "0123456789")
+
+(LISP:DEFUN FLONUM-TO-STRING (X &OPTIONAL WIDTH DECPLACES SCALE FMIN)
+
+   (* ;; "Returns FIVE values: a string of digits with one decimal point, the string's length, T if the point is at the front, T if the point is at the end,  the index of the point in the string")
+
+   (LISP:IF (ZEROP X)
+       (LISP:VALUES "." 1 T T)
+       [LET* ((REALDP (COND
+                         (DECPLACES (LISP:IF FMIN
+                                        (MAX DECPLACES FMIN)
+                                        DECPLACES))
+                         (FMIN)))
+              [ROUND (COND
+                        [REALDP                              (* ; 
+                             "Foo! Compute rounding place based on size of number and scale factor")
+                               (MIN 9 (+ (DIGITSBDP X)
+                                         REALDP
+                                         (OR SCALE 0]
+                        (WIDTH (MAX 1 (MIN 9 (LISP:1- WIDTH]
+              MANTSTR INTEXP)
+             (LISP:MULTIPLE-VALUE-SETQ (MANTSTR INTEXP)
+                    (FLTSTR X ROUND))
+             (LISP:IF SCALE (LISP:INCF INTEXP SCALE))
+
+             (* ;; 
+       "OK, now copy the digit string into *digit-string* with the decimal point set appropriately")
+
+             (LISP:MACROLET [(STRPUT (C)
+                                    `(LISP:VECTOR-PUSH-EXTEND ,C *DIGIT-STRING*]
+                    (LET* ((DIGITS (LISP:LENGTH MANTSTR))
+                           (INDEX -1)
+                           (POINTPLACE (+ DIGITS INTEXP))
+                           DECPNT)
+
+                          (* ;; "MANTSTR may have more digits than necessary; prune off its zeros. Doing this will lose if X is zero.")
+
+                          (IF (NOT (ZEROP X))
+                              THEN (WHILE (AND (LISP:PLUSP DIGITS)
+                                                       (LISP:CHAR= (LISP:CHAR MANTSTR (LISP:1- DIGITS
+                                                                                             ))
+                                                              #\0)) DO (LISP:DECF DIGITS)
+                                                                          (LISP:INCF INTEXP)))
+                          (LISP:SETF (LISP:FILL-POINTER *DIGIT-STRING*)
+                                 0)
+                          [COND
+                             ((NOT (LISP:PLUSP POINTPLACE))  (* ; " .<digits>")
+                              (STRPUT #\.)
+                              (LISP:DOTIMES (I (- POINTPLACE))
+                                  (STRPUT #\0))
+                              (LISP:DOTIMES (I DIGITS)
+                                  (STRPUT (LISP:CHAR MANTSTR I)))
+                              (SETQ DECPNT 0))
+                             ((MINUSP INTEXP)                (* ; "<digits>.<digits>")
+                              (LISP:DOTIMES (I POINTPLACE)
+                                  (STRPUT (LISP:CHAR MANTSTR (LISP:INCF INDEX))))
+                              (STRPUT #\.)
+                              (LISP:DOTIMES (I (- INTEXP))
+                                  (STRPUT (LISP:CHAR MANTSTR (LISP:INCF INDEX))))
+                              (SETQ DECPNT (+ DIGITS INTEXP)))
+                             (T                              (* ; "<digits>00.")
+                                (LISP:DOTIMES (I DIGITS)
+                                    (STRPUT (LISP:CHAR MANTSTR I)))
+                                (LISP:DOTIMES (I INTEXP)
+                                    (STRPUT #\0))
+                                (STRPUT #\.)
+                                (SETQ DECPNT (+ DIGITS INTEXP]
+                          (SETQ DIGITS (LISP:1- (LISP:LENGTH *DIGIT-STRING*)))
+                          (IF DECPLACES
+                              THEN 
+
+                                    (* ;; "Need extra 0s to get enough decimal places")
+
+                                    (LISP:DOTIMES (I (- DECPLACES (- DIGITS DECPNT)))
+                                        (STRPUT #\0)
+                                        (LISP:INCF DIGITS)))
+                          (LISP:VALUES *DIGIT-STRING* (LISP:1+ DIGITS)
+                                 (= DECPNT 0)
+                                 (= DECPNT DIGITS)
+                                 DECPNT]))
+
+(DEFMACRO FORMAT-WITH-CONTROL-STRING (CONTROL-STRING &BODY FORMS)
+
+   (* ;; "This macro establishes the correct environment for processing an indirect control string. CONTROL-STRING is the string to process, and FORMS are the forms to do the processing. They invariably will involve a call to SUB-FORMAT.  CONTROL-STRING is guaranteed to be evaluated exactly once.")
+
+   `[LET ((STRING ,CONTROL-STRING))
+         (CONDITION-CASE (LET ((*FORMAT-CONTROL-STRING* STRING)
+                               (*FORMAT-LENGTH* (LISP:LENGTH STRING))
+                               (*FORMAT-INDEX* 0))
+                              ,@FORMS)
+                (FORMAT-ERROR (C)
+                       (LISP:ERROR 'FORMAT-ERROR :ARGS (CONS (LIST 
+                                              "While processing indirect control string~%%~S~%%~V@T^"
+                                                                   *FORMAT-CONTROL-STRING*
+                                                                   (LISP:1+ *FORMAT-INDEX*))
+                                                             (FORMAT-ERROR-ARGS C])
+
+(DEFMACRO FORMAT-STRINGIFY-OUTPUT (&BODY FORMS)
+
+   (* ;; "This macro collects output to the standard output stream in a string.  It used to try to avoid consing new string streams if possible.")
+
+   `(LISP:WITH-OUTPUT-TO-STRING (*STANDARD-OUTPUT*)
+           ,@FORMS))
+
+(LISP:DEFUN POP-FORMAT-ARG ()
+
+   (* ;; "Pops an argument from the current argument list.  This is either the list of arguments given to the top-level call to FORMAT, or the argument list for the current iteration in a ~{~} construct.  An error is signalled if the argument list is empty.  if we're under a ~<...~:> logical block, we have to do a PPRINT-POP equivalent")
+
+   (LISP:IF (AND *FORMAT-LOGICAL-BLOCK* (XP::XP-STRUCTURE-P *STANDARD-OUTPUT*)
+                 (XP::PPRINT-POP-CHECK+ *FORMAT-ARGUMENTS* *STANDARD-OUTPUT*))
+       (LISP:THROW 'XP::LOGICAL-BLOCK NIL)
+       (LISP:IF *FORMAT-ARGUMENTS*
+           (LISP:POP *FORMAT-ARGUMENTS*)
+           (FORMAT-ERROR "Missing argument"))))
+
+(DEFMACRO WITH-FORMAT-PARAMETERS (PARMVAR PARMDEFS &BODY FORMS)
+
+   (* ;; "This macro decomposes the argument list returned by PARSE-FORMAT-OPERATION. PARMVAR is the list of parameters. PARMDEFS is a list of lists of the form (<var> <default>) . The FORMS are evaluated in an environment where each <var> is bound to either the value of the parameter supplied in the parameter list, or to its <default> value if the parameter was omitted or explicitly defaulted.")
+
+   `(LET ,[FOR PARMDEF IN PARMDEFS COLLECT `(,(LISP:FIRST PARMDEF)
+                                                         (OR (LISP:IF ,PARMVAR
+                                                                 (POP ,PARMVAR))
+                                                             ,(LISP:SECOND PARMDEF]
+         (LISP:WHEN ,PARMVAR (FORMAT-ERROR "Too many parameters"))
+         ,@FORMS))
+
+(DEFMACRO NEXTCHAR ()
+
+   (* ;; "Gets the next character from the current control string.  It is an error if there is none.  Leave *format-index* pointing to the character returned.  *")
+
+   '(LISP:IF (< (LISP:INCF *FORMAT-INDEX*)
+                *FORMAT-LENGTH*)
+        (LISP:CHAR *FORMAT-CONTROL-STRING* *FORMAT-INDEX*)
+        (FORMAT-ERROR "Syntax error")))
+
+(DEFMACRO FORMAT-PEEK ()
+
+   (* ;; "Returns the current character, i.e.  the one pointed to by *format-index*.")
+
+   '(LISP:CHAR *FORMAT-CONTROL-STRING* *FORMAT-INDEX*))
+
+(DEFMACRO FORMAT-FIND-CHAR (CHAR START END)
+
+   (* ;; "Returns the index of the first occurrence of the specified character between indices START (inclusive) and END (exclusive) in the control string.")
+
+   `(LISP:POSITION ,CHAR *FORMAT-CONTROL-STRING* :START ,START :END ,END :TEST 'LISP:CHAR=))
+
+(LISP:DEFUN FORMAT-GET-PARAMETER ()
+
+   (* ;; "Attempts to parse a parameter, starting at the current index.  Returns the value of the parameter, or NIL if none is found.  On exit, *format-index* points to the first character which is not a part of the recognized parameter.")
+
+   (LET [(NUMSIGN (CASE (FORMAT-PEEK)
+                      (#\+ 
+                         (NEXTCHAR)
+                         NIL)
+                      (#\- 
+                         (NEXTCHAR)
+                         T)
+                      (T NIL))]
+        (CASE (FORMAT-PEEK)
+            (#\# 
+               (NEXTCHAR)
+               (LISP:LENGTH *FORMAT-ARGUMENTS*))
+            ((#\V #\v) (PROG1 (POP-FORMAT-ARG)
+                              (NEXTCHAR)))
+            (#\' (PROG1 (NEXTCHAR)
+                        (NEXTCHAR)))
+            ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (LISP:DO* [(LISP:NUMBER (LISP:DIGIT-CHAR-P
+                                                                                (FORMAT-PEEK))
+                                                                         (+ (LISP:* 10 LISP:NUMBER)
+                                                                            (LISP:DIGIT-CHAR-P (
+                                                                                        FORMAT-PEEK
+                                                                                                ]
+                                                                 ((NOT (LISP:DIGIT-CHAR-P (NEXTCHAR
+                                                                                           )))
+                                                                  (LISP:IF NUMSIGN
+                                                                      (- LISP:NUMBER)
+                                                                      LISP:NUMBER))))
+            (T NIL))))
+
+(LISP:DEFUN PARSE-FORMAT-OPERATION ()
+                                                             (* amd " 1-May-86 14:33")
+
+   (* ;; "Parses a format directive, including flags and parameters.  On entry, *format-index* should point to the '~' preceding the command.  On exit, *format-index* points to the command character itself.  Returns the list of parameters, the ':' flag, the '@' flag, and the command character as multiple values.  Explicitly defaulted parameters appear in the list of parameters as NIL.  Omitted parameters are simply not included in the list at all.  *")
+
+   (LET ((CH (NEXTCHAR))
+         PARMS COLON ATSIGN)
+
+        (* ;; "First get the parameters")
+
+        (SETQ PARMS (LISP:IF (OR (LISP:DIGIT-CHAR-P CH)
+                                 (LISP:MEMBER CH '(#\, #\# #\V #\v #\')
+                                        :TEST
+                                        (FUNCTION LISP:CHAR=)))
+                        (LISP:DO ((PARMS (LIST (FORMAT-GET-PARAMETER))
+                                         (CONS (FORMAT-GET-PARAMETER)
+                                               PARMS)))
+                                 ((LISP:CHAR/= (FORMAT-PEEK)
+                                         #\,)
+                                  (LISP:NREVERSE PARMS))
+                            (NEXTCHAR))
+                        'NIL))
+
+        (* ;; "Then check for : and @ (not necessarily in that order)")
+
+        [LISP:LOOP (CASE (FORMAT-PEEK)
+                       (#\: (LISP:IF COLON
+                                (RETURN NIL)
+                                (SETQ COLON (NEXTCHAR))))
+                       (#\@ (LISP:IF ATSIGN
+                                (RETURN NIL)
+                                (SETQ ATSIGN (NEXTCHAR))))
+                       (T (RETURN NIL)))]
+        (LISP:VALUES PARMS COLON ATSIGN (FORMAT-PEEK))))
+
+(LISP:DEFUN FORMAT-FIND-COMMAND (COMMAND-LIST)
+
+   (* ;; "Starting at the current value of *format-index*, finds the first occurrence of one of the specified directives.  Embedded constructs, i.e.  those inside ~ (~) %%, ~[~], ~{~}, or ~<~>, are ignored.  And error is signalled if no satisfactory command is found.  Otherwise, the following are returned as multiple values: The value of *format-index* at the start of the search The index of the '~' character preceding the command The parameter list of the command The ':' flag The '@' flag The command character Implementation note: The present implementation is not particulary careful with storage allocation.  It would be a good idea to have a separate function for skipping embedded constructs which did not bother to cons parameter lists and then throw them away.  We go to some trouble here to use POSITION for most of the searching.")
+
+   [LET ((START *FORMAT-INDEX*))
+        (LISP:DO ((PLACE START *FORMAT-INDEX*)
+                  (TILDE (FORMAT-FIND-CHAR #\~ START *FORMAT-LENGTH*)
+                         (FORMAT-FIND-CHAR #\~ PLACE *FORMAT-LENGTH*)))
+                 ((NOT TILDE)
+                  (FORMAT-ERROR "Expecting one of ~S" COMMAND-LIST))
+            (SETQ *FORMAT-INDEX* TILDE)
+            [LISP:MULTIPLE-VALUE-BIND (PARMS COLON ATSIGN COMMAND)
+                   (PARSE-FORMAT-OPERATION)
+                   (LISP:WHEN (MEMBER COMMAND COMMAND-LIST :TEST (FUNCTION LISP:CHAR=))
+                       (RETURN (LISP:VALUES START TILDE PARMS COLON ATSIGN COMMAND)))
+                   NIL
+                   (CASE COMMAND
+                       (#\{ 
+                          (NEXTCHAR)
+                          (FORMAT-FIND-COMMAND '(#\})))
+                       (#\< 
+                          (NEXTCHAR)
+                          (FORMAT-FIND-COMMAND '(#\>)))
+                       (#\( 
+                          (NEXTCHAR)
+                          (FORMAT-FIND-COMMAND '(#\))))
+                       (#\[ 
+                          (NEXTCHAR)
+                          (FORMAT-FIND-COMMAND '(#\])))
+                       ((#\} #\> #\) #\]) (FORMAT-ERROR "No matching bracket")))])])
+
+(LISP:DEFUN LISP:FORMAT (LISP::DESTINATION LISP::CONTROL-STRING &REST LISP::FORMAT-ARGUMENTS)
+   [LET ((*FORMAT-ORIGINAL-ARGUMENTS* LISP::FORMAT-ARGUMENTS)
+         (*FORMAT-ARGUMENTS* LISP::FORMAT-ARGUMENTS)
+         (*FORMAT-CONTROL-STRING* LISP::CONTROL-STRING)
+         *FORMAT-LOGICAL-BLOCK* *FORMAT-JUSTIFICATION* *FORMAT-INCOMPATIBLE-JUSTIFICATION*)
+        (LISP:UNLESS (EQ LISP:*PRINT-READABLY* 'XCL::PRINTING-READABLY)
+            (LISP::CHECK-READABLY "Arbitrary FORMAT control strings" 'LISP:FORMAT))
+        (COND
+           ((NOT LISP::DESTINATION)
+            (LISP:WITH-OUTPUT-TO-STRING (*STANDARD-OUTPUT*)
+                   (FORMAT-MAYBE-PPRINT)))
+           ((LISP:STRINGP LISP::DESTINATION)
+            (LISP:WITH-OUTPUT-TO-STRING (*STANDARD-OUTPUT* LISP::DESTINATION)
+                   (FORMAT-MAYBE-PPRINT))
+            NIL)
+           (T (LET [(*STANDARD-OUTPUT* (LISP:IF (EQ LISP::DESTINATION T)
+                                           *STANDARD-OUTPUT*
+
+                                           (* ;; " FORMAT extension - IL:DESTINATION may be anything that IL:GETSTREAM can coerce into being a stream")
+
+                                           (GETSTREAM LISP::DESTINATION 'OUTPUT))]
+                   (FORMAT-MAYBE-PPRINT)
+                   NIL])
+
+(LISP:DEFUN FORMAT-MAYBE-PPRINT ()
+   (LISP:CATCH 'FORMAT-ESCAPE
+       (LISP:CATCH 'FORMAT-COLON-ESCAPE
+           (LISP:IF (STRINGP *FORMAT-CONTROL-STRING*)
+               (SUB-FORMAT 0 (LISP:LENGTH *FORMAT-CONTROL-STRING*))
+               (LISP:APPLY *FORMAT-CONTROL-STRING* *STANDARD-OUTPUT* *FORMAT-ARGUMENTS*)))))
+
+(LISP:DEFUN SUB-FORMAT (START END)
+
+   (* ;; "This function does the real work of format.  The segment of the control string between indiced START (inclusive) and END (exclusive) is processed as follows: Text not part of a directive is output without further processing (except if *FORMAT-LOGICAL-BLOCK* is :FILL; blank sequences must then be followed by fill-style conditional newlines).  Directives are parsed along with their parameters and flags, and the appropriate handlers invoked with the arguments COLON, ATSIGN, and PARMS.  Implementation Note: FORMAT-FIND-CHAR uses the POSITION stream operation for speed.  This is potentially faster than character-at-a-time searching.")
+
+   [LET ((*FORMAT-INDEX* START)
+         (*FORMAT-LENGTH* END))
+        (DECLARE (LISP:SPECIAL *FORMAT-INDEX* *FORMAT-LENGTH*))
+        (LISP:DO* ((PLACE START *FORMAT-INDEX*)
+                   (TILDE (FORMAT-FIND-CHAR #\~ START END)
+                          (FORMAT-FIND-CHAR #\~ PLACE END))
+                   (LAST-CMD-NEWLINE?))
+                  ((NOT TILDE)
+                   (LISP:IF (EQ *FORMAT-LOGICAL-BLOCK* :FILL)
+                       (LISP:WHEN (FORMAT-LOGICAL-FILL *FORMAT-CONTROL-STRING* *STANDARD-OUTPUT*
+                                         PLACE END LAST-CMD-NEWLINE?)
+                              (XP:PPRINT-NEWLINE :FILL *STANDARD-OUTPUT*))
+                       (WRITE-STRING* *FORMAT-CONTROL-STRING* *STANDARD-OUTPUT* PLACE END)))
+            (LISP:WHEN (> TILDE PLACE)
+                (LISP:IF (EQ *FORMAT-LOGICAL-BLOCK* :FILL)
+                    (FORMAT-LOGICAL-FILL *FORMAT-CONTROL-STRING* *STANDARD-OUTPUT* PLACE TILDE 
+                           LAST-CMD-NEWLINE?)
+                    (WRITE-STRING* *FORMAT-CONTROL-STRING* *STANDARD-OUTPUT* PLACE TILDE)))
+            (SETQ *FORMAT-INDEX* TILDE)
+            [LISP:MULTIPLE-VALUE-BIND (PARMS COLON ATSIGN COMMAND)
+                   (PARSE-FORMAT-OPERATION)
+                   (SETQ LAST-CMD-NEWLINE? (LISP:CHAR= COMMAND #\Newline))
+                   (LET [(CMDFUN (LISP:AREF *FORMAT-DISPATCH-TABLE* (LISP:CHAR-CODE COMMAND]
+                        (LISP:IF CMDFUN
+                            (LISP:FUNCALL CMDFUN COLON ATSIGN PARMS)
+                            (FORMAT-ERROR "Illegal FORMAT command ~~~C" COMMAND))]
+            (LISP:UNLESS (< (LISP:INCF *FORMAT-INDEX*)
+                            END)
+                   (RETURN)))])
+
+
+
+(* ;; "Top-level entries in *FORMAT-DISPATCH-TABLE*")
+
+
+(LISP:DEFUN FORMAT-PRINT-BINARY (COLON ATSIGN PARMS)
+
+   (* ;; "Binary ~B")
+
+   (FORMAT-PRINT-NUMBER (POP-FORMAT-ARG)
+          2 COLON ATSIGN PARMS))
+
+(LISP:DEFUN FORMAT-PRINT-OCTAL (COLON ATSIGN PARMS)
+
+   (* ;; "Octal ~O")
+
+   (FORMAT-PRINT-NUMBER (POP-FORMAT-ARG)
+          8 COLON ATSIGN PARMS))
+
+(LISP:DEFUN FORMAT-PRINT-HEXADECIMAL (COLON ATSIGN PARMS)
+
+   (* ;; "Hexadecimal ~X")
+
+   (FORMAT-PRINT-NUMBER (POP-FORMAT-ARG)
+          16 COLON ATSIGN PARMS))
+
+(LISP:DEFUN FORMAT-PRINT-RADIX (COLON ATSIGN PARMS)
+
+   (* ;; "Radix ~R")
+
+   [LET ((LISP:NUMBER (POP-FORMAT-ARG)))
+        (LISP:IF (CAR PARMS)
+            (FORMAT-PRINT-NUMBER LISP:NUMBER (pop PARMS)
+                   COLON ATSIGN PARMS)
+            (LISP:IF PARMS
+                (FORMAT-WRITE-FIELD (FORMAT-STRINGIFY-OUTPUT (FORMAT-PRINT-RADIX-AUX
+                                                                      LISP:NUMBER COLON ATSIGN))
+                       (CADR PARMS)
+                       1 0 (COND
+                              ((CADDR PARMS))
+                              (T #\Space)
+                              NIL)
+                       T)
+                (FORMAT-PRINT-RADIX-AUX LISP:NUMBER COLON ATSIGN)))])
+
+(LISP:DEFUN FORMAT-FIXED (COLON ATSIGN PARMS)
+
+   (* ;; "Fixed-format floating point ~F")
+
+   (LISP:WHEN COLON (FORMAT-ERROR "Colon flag not allowed"))
+   [WITH-FORMAT-PARAMETERS PARMS ((W NIL)
+                                      (D NIL)
+                                      (K NIL)
+                                      (OVF NIL)
+                                      (PAD #\Space))
+
+          (* ;; "Note that the scale factor k defaults to nil.  This is interpreted as zero by flonum-to-string, but more efficiently.")
+
+          (LET ((LISP:NUMBER (POP-FORMAT-ARG))
+                (*PRINT-ESCAPE* NIL))
+               (LISP:IF (FLOATP LISP:NUMBER)
+                   (FORMAT-FIXED-AUX LISP:NUMBER W D K OVF PAD ATSIGN)
+                   (LISP:IF (LISP:RATIONALP LISP:NUMBER)
+                       (FORMAT-FIXED-AUX (COERCE LISP:NUMBER 'FLOAT)
+                              W D K OVF PAD ATSIGN)
+                       (LET ((*PRINT-BASE* 10))
+                            (FORMAT-WRITE-FIELD (LISP:PRINC-TO-STRING LISP:NUMBER)
+                                   W 1 0 #\Space T))))])
+
+(LISP:DEFUN FORMAT-EXPONENTIAL (COLON ATSIGN PARMS)
+
+   (* ;; "Exponential-format floating point ~E")
+
+   (LISP:WHEN COLON (FORMAT-ERROR "Colon flag not allowed"))
+   [WITH-FORMAT-PARAMETERS PARMS ((W NIL)
+                                      (D NIL)
+                                      (E NIL)
+                                      (K 1)
+                                      (OVF NIL)
+                                      (PAD #\Space)
+                                      (MARKER NIL))
+          (LET ((LISP:NUMBER (POP-FORMAT-ARG))
+                (*PRINT-ESCAPE* NIL))
+               (LISP:IF (FLOATP LISP:NUMBER)
+                   (FORMAT-EXP-AUX LISP:NUMBER W D E K OVF PAD MARKER ATSIGN)
+                   (LISP:IF (LISP:RATIONALP LISP:NUMBER)
+                       (FORMAT-EXP-AUX (COERCE LISP:NUMBER 'FLOAT)
+                              W D E K OVF PAD MARKER ATSIGN)
+                       (LET ((*PRINT-BASE* 10))
+                            (FORMAT-WRITE-FIELD (LISP:PRINC-TO-STRING LISP:NUMBER)
+                                   W 1 0 #\Space T))))])
+
+(LISP:DEFUN FORMAT-GENERAL-FLOAT (COLON ATSIGN PARMS)
+
+   (* ;; "General Floating Point --- ~G")
+
+   (LISP:WHEN COLON (FORMAT-ERROR "Colon flag not allowed"))
+   [WITH-FORMAT-PARAMETERS PARMS ((W NIL)
+                                      (D NIL)
+                                      (E NIL)
+                                      (K NIL)
+                                      (OVF #\*)
+                                      (PAD #\Space)
+                                      (MARKER NIL))
+          (LET ((LISP:NUMBER (POP-FORMAT-ARG))
+                (*PRINT-ESCAPE* NIL))
+
+               (* ;; "The Excelsior edition does not say what to do if the argument is not a float.  Here, we adopt the conventions used by ~F and ~E.")
+
+               (LISP:IF (FLOATP LISP:NUMBER)
+                   (FORMAT-GENERAL-AUX LISP:NUMBER W D E K OVF PAD MARKER ATSIGN)
+                   (LISP:IF (LISP:RATIONALP LISP:NUMBER)
+                       (FORMAT-GENERAL-AUX (COERCE LISP:NUMBER 'FLOAT)
+                              W D E K OVF PAD MARKER ATSIGN)
+                       (LET ((*PRINT-BASE* 10))
+                            (FORMAT-WRITE-FIELD (LISP:PRINC-TO-STRING LISP:NUMBER)
+                                   W 1 0 #\Space T))))])
+
+(LISP:DEFUN FORMAT-PRINC (COLON ATSIGN PARMS)
+
+   (* ;; "Ascii ~A *")
+
+   [LET ((ARG (POP-FORMAT-ARG)))
+        (LISP:IF (NULL PARMS)
+            (LISP:IF ARG
+                (LISP:PRINC ARG)
+                (LISP:IF COLON
+                    (WRITE-STRING* "()")
+                    (LISP:PRINC NIL)))
+            (WITH-FORMAT-PARAMETERS PARMS ((MINCOL 0)
+                                               (COLINC 1)
+                                               (MINPAD 0)
+                                               (PADCHAR #\Space))
+                   (FORMAT-WRITE-FIELD (LISP:IF ARG
+                                               (LISP:PRINC-TO-STRING ARG)
+                                               (LISP:IF COLON
+                                                   "()"
+                                                   (LISP:PRINC-TO-STRING NIL)))
+                          MINCOL COLINC MINPAD PADCHAR ATSIGN)))])
+
+(LISP:DEFUN FORMAT-PRINT-CHARACTER (COLON ATSIGN PARMS)
+
+   (* ;; "Character ~C")
+
+   [WITH-FORMAT-PARAMETERS PARMS NIL (LET ((LISP:CHAR (POP-FORMAT-ARG)))
+                                                (LISP:UNLESS (LISP:CHARACTERP LISP:CHAR)
+                                                       (FORMAT-ERROR 
+                                                              "Argument must be a character"))
+                                                (COND
+                                                   ((AND (NOT COLON)
+                                                         (NOT ATSIGN))
+                                                    (LISP:WRITE-CHAR LISP:CHAR))
+                                                   ((AND ATSIGN (NOT COLON))
+                                                    (LISP:PRIN1 LISP:CHAR))
+                                                   (T (FORMAT-PRINT-NAMED-CHARACTER LISP:CHAR 
+                                                             COLON])
+
+(LISP:DEFUN FORMAT-PLURAL (COLON ATSIGN PARMS)
+
+   (* ;; "Pluralize word ~P")
+
+   (LISP:WHEN PARMS (FORMAT-ERROR "Parameters not allowed"))
+   (LISP:WHEN COLON
+
+       (* ;; "Back up one argument first ")
+
+       [LET ((CDRS (- (LISP:LENGTH *FORMAT-ORIGINAL-ARGUMENTS*)
+                      (LISP:LENGTH *FORMAT-ARGUMENTS*)
+                      1)))
+            (LISP:IF (MINUSP CDRS)
+                (FORMAT-ERROR "No previous argument")
+                (SETQ *FORMAT-ARGUMENTS* (LISP:NTHCDR CDRS *FORMAT-ORIGINAL-ARGUMENTS*)))])
+   (LISP:IF (EQL (POP-FORMAT-ARG)
+                 1)
+       (WRITE-STRING* (LISP:IF ATSIGN
+                          "y"
+                          ""))
+       (WRITE-STRING* (LISP:IF ATSIGN
+                          "ies"
+                          "s"))))
+
+(LISP:DEFUN FORMAT-PRIN1 (COLON ATSIGN PARMS)
+
+   (* ;; "S-expression ~S")
+
+   [LET ((ARG (POP-FORMAT-ARG)))
+        (LISP:IF (NULL PARMS)
+            (LISP:IF ARG
+                (LISP:PRIN1 ARG)
+                (LISP:IF COLON
+                    (WRITE-STRING* "()")
+                    (LISP:PRIN1 NIL)))
+            (WITH-FORMAT-PARAMETERS PARMS ((MINCOL 0)
+                                               (COLINC 1)
+                                               (MINPAD 0)
+                                               (PADCHAR #\Space))
+                   (FORMAT-WRITE-FIELD (LISP:IF ARG
+                                               (LISP:PRIN1-TO-STRING ARG)
+                                               (LISP:IF COLON
+                                                   "()"
+                                                   (LISP:PRIN1-TO-STRING NIL)))
+                          MINCOL COLINC MINPAD PADCHAR ATSIGN)))])
+
+(LISP:DEFUN FORMAT-TAB (COLON ATSIGN PARMS)
+
+   (* ;; "Tabulation ~T")
+
+   [WITH-FORMAT-PARAMETERS
+    PARMS
+    ((COLNUM 1)
+     (COLINC 1))
+    (IF COLON
+        THEN (LISP:WHEN *FORMAT-JUSTIFICATION* (FORMAT-ERROR 
+                                                        "~:T not allowed under vanilla justification"
+                                                          ))
+              (LISP:UNLESS (XP::XP-STRUCTURE-P *STANDARD-OUTPUT*)
+                     (FORMAT-ERROR "Can't PPRINT-TAB a non-XP stream"))
+              (LISP:IF (EQ *FORMAT-INCOMPATIBLE-JUSTIFICATION* :JUSTIFY)
+                  (FORMAT-ERROR 
+                         "Pretty-printer directive and ~<...~:;...~> in same format string")
+                  (SETQ *FORMAT-INCOMPATIBLE-JUSTIFICATION* :XP))
+              (LISP:IF ATSIGN
+                  (XP:PPRINT-TAB :SECTION-RELATIVE COLNUM COLINC)
+                  (XP:PPRINT-TAB :SECTION COLNUM COLINC))
+      ELSE
+      (LET ((POSITION (POSITION *STANDARD-OUTPUT*))
+            SPACES)
+           (IF ATSIGN
+               THEN (SETQ SPACES COLNUM)
+                     [IF POSITION
+                         THEN (IF (NOT (ZEROP COLINC))
+                                      THEN (LISP:MULTIPLE-VALUE-BIND (Q R)
+                                                      (LISP:CEILING (+ POSITION COLNUM)
+                                                             COLINC)
+                                                      (LISP:DECF SPACES R]
+             ELSE (IF POSITION
+                          THEN [IF (< POSITION COLNUM)
+                                       THEN (SETQ SPACES (- COLNUM POSITION))
+                                     ELSE (IF (ZEROP COLINC)
+                                                  THEN (SETQ SPACES 0)
+                                                ELSE (LISP:MULTIPLE-VALUE-BIND
+                                                          (Q R)
+                                                          (LISP:CEILING (- POSITION COLNUM)
+                                                                 COLINC)
+                                                          (SETQ SPACES (IF (ZEROP R)
+                                                                           THEN COLINC
+                                                                         ELSE (- R]
+                        ELSE (SETQ SPACES 2)))
+           (LISP:DOTIMES (S SPACES)
+               (LISP:WRITE-CHAR #\Space *STANDARD-OUTPUT*))])
+
+(LISP:DEFUN FORMAT-TERPRI (COLON ATSIGN PARMS)
+
+   (* ;; "Newline ~&")
+
+   (LISP:WHEN (OR COLON ATSIGN)
+          (FORMAT-ERROR "Flags not allowed"))
+   (WITH-FORMAT-PARAMETERS PARMS ((REPEAT-COUNT 1))
+          (LISP:DOTIMES (I REPEAT-COUNT)
+              (LISP:TERPRI *STANDARD-OUTPUT*))))
+
+(LISP:DEFUN FORMAT-FRESHLINE (COLON ATSIGN PARMS)
+
+   (* ;; "Fresh-line ~%%")
+
+   (LISP:WHEN (OR COLON ATSIGN)
+          (FORMAT-ERROR "Flags not allowed"))
+   (WITH-FORMAT-PARAMETERS PARMS ((REPEAT-COUNT 1))
+          (LISP:FRESH-LINE *STANDARD-OUTPUT*)
+          (LISP:DOTIMES (I (LISP:1- REPEAT-COUNT))
+              (LISP:TERPRI *STANDARD-OUTPUT*))))
+
+(LISP:DEFUN FORMAT-SKIP-ARGUMENTS (COLON ATSIGN PARMS)
+
+   (* ;; "Skip arguments (relative goto) ~*")
+
+   [LISP:FLET [(RECONS? (L)
+                      (COND
+                         ((OR (NOT XP::*CIRCULARITY-HASH-TABLE*)
+                              (EQ L *FORMAT-ARGUMENTS*))
+                          L)
+                         [(TAILP *FORMAT-ARGUMENTS* L)
+
+                          (* ;; "We've gone backwards and need to recons")
+
+                          (LISP:DO* ((RESULT (CONS (CAR L)
+                                                   NIL))
+                                     (RP RESULT (CDR RP))
+                                     (LP (CDR L)
+                                         (CDR LP)))
+                                    ((EQ LP *FORMAT-ARGUMENTS*)
+                                     (RPLACD RP LP)
+                                     RESULT)
+                              (RPLACD RP (CONS (CAR LP)
+                                               NIL)))]
+                         (T L]
+          (WITH-FORMAT-PARAMETERS PARMS ((LISP:COUNT (LISP:IF ATSIGN
+                                                             0
+                                                             1)))
+                 (COND
+                    [ATSIGN (LISP:WHEN (OR (MINUSP LISP:COUNT)
+                                           (> LISP:COUNT (LISP:LENGTH *FORMAT-ORIGINAL-ARGUMENTS*)))
+                                   (FORMAT-ERROR "Illegal to go to non-existant argument"))
+                           (SETQ *FORMAT-ARGUMENTS* (RECONS? (LISP:NTHCDR LISP:COUNT 
+                                                                    *FORMAT-ORIGINAL-ARGUMENTS*]
+                    [COLON (LET ((CDRS (- (LISP:LENGTH *FORMAT-ORIGINAL-ARGUMENTS*)
+                                          (LISP:LENGTH *FORMAT-ARGUMENTS*)
+                                          LISP:COUNT)))
+                                (LISP:IF (MINUSP CDRS)
+                                    (FORMAT-ERROR "Skip to nonexistant argument")
+                                    (SETQ *FORMAT-ARGUMENTS* (RECONS? (LISP:NTHCDR CDRS 
+                                                                          *FORMAT-ORIGINAL-ARGUMENTS*
+                                                                             ))))]
+                    (T (LISP:IF (> LISP:COUNT (LISP:LENGTH *FORMAT-ARGUMENTS*))
+                           (FORMAT-ERROR "Skip to nonexistant argument")
+                           (SETQ *FORMAT-ARGUMENTS* (LISP:NTHCDR LISP:COUNT *FORMAT-ARGUMENTS*)))])
+
+(LISP:DEFUN FORMAT-PAGE (COLON ATSIGN PARMS)
+
+   (* ;; " Page  ~|")
+
+   (LISP:WHEN (OR COLON ATSIGN)
+          (FORMAT-ERROR "Flags not allowed"))
+   (WITH-FORMAT-PARAMETERS PARMS ((REPEAT-COUNT 1))
+          (LISP:DOTIMES (I REPEAT-COUNT)
+              (LISP:WRITE-CHAR #\Page))))
+
+(LISP:DEFUN FORMAT-TILDE (COLON ATSIGN PARMS)
+
+   (* ;; "Print a tilde ~~")
+
+   (LISP:WHEN (OR COLON ATSIGN)
+          (FORMAT-ERROR "Flags not allowed"))
+   (WITH-FORMAT-PARAMETERS PARMS ((REPEAT-COUNT 1))
+          (LISP:DOTIMES (I REPEAT-COUNT)
+              (LISP:WRITE-CHAR #\~))))
+
+(LISP:DEFUN FORMAT-DOLLARS (COLON ATSIGN PARMS)
+
+   (* ;; "Dollars floating-point format ~$")
+
+   [WITH-FORMAT-PARAMETERS PARMS ((D 2)
+                                      (N 1)
+                                      (FW 0)
+                                      (PAD #\Space))
+          (LET* ((LISP:NUMBER (POP-FORMAT-ARG))
+                 (SIGNSTR (LISP:IF (MINUSP LISP:NUMBER)
+                              "-"
+                              (LISP:IF ATSIGN
+                                  "+"
+                                  "")))
+                 (*PRINT-ESCAPE* NIL))
+                (LISP:MULTIPLE-VALUE-BIND (STR NUMLENGTH IG2 IG3 POINTPLACE)
+                       (FLONUM-TO-STRING (ABS LISP:NUMBER)
+                              NIL D NIL)
+                       (DECLARE (IGNORE IG2 IG3))
+                       (LISP:WHEN COLON (WRITE-STRING* SIGNSTR))
+                       (LISP:DOTIMES [I (- FW NUMLENGTH (LISP:LENGTH SIGNSTR)
+                                           (MAX 0 (- N POINTPLACE]
+                           (LISP:WRITE-CHAR PAD))
+                       (LISP:UNLESS COLON (WRITE-STRING* SIGNSTR))
+                       (LISP:DOTIMES (I (- N POINTPLACE))
+                           (LISP:WRITE-CHAR #\0))
+                       (WRITE-STRING* STR])
+
+(LISP:DEFUN FORMAT-INDIRECTION (COLON ATSIGN PARMS)
+
+   (* ;; "Indirection ~?")
+
+   (LISP:WHEN COLON (FORMAT-ERROR "Colon modifier not allowed"))
+   (LISP:WHEN PARMS (FORMAT-ERROR "Parameters not allowed"))
+   [LET ((STRING (POP-FORMAT-ARG)))
+
+        (* ;; "I don't understand; it should obviously be legal to pass a FORMATTER-generated function as an indirect %"string%" argument, but CLtL2 says no.")
+
+        (LISP:UNLESS (LISP:STRINGP STRING)
+               (FORMAT-ERROR "Indirected control string is not a string"))
+        (FORMAT-WITH-CONTROL-STRING STRING (LET (*FORMAT-INCOMPATIBLE-JUSTIFICATION*)
+
+                                                    (* ;; 
+                                  "New foramt string, so new scope for incompatible justifications")
+
+                                                    (LISP:IF ATSIGN
+                                                        (SUB-FORMAT 0 *FORMAT-LENGTH*)
+                                                        (LET ((*FORMAT-ARGUMENTS* (POP-FORMAT-ARG
+                                                                                   )))
+                                                             (SUB-FORMAT 0 *FORMAT-LENGTH*)))])
+
+(LISP:DEFUN FORMAT-ESCAPE (COLON ATSIGN PARMS)
+
+   (* ;; "Up and Out (Escape) ~^")
+
+   (* ;; "I THINK this does the right thing under a ~<...~:> logical-block; we'll see...")
+
+   (LISP:WHEN ATSIGN (FORMAT-ERROR "FORMAT command ~~~:[~;:~]@^ is undefined" COLON))
+   (LISP:WHEN (AND COLON (NOT *FORMAT-COLON-ITERATION*))
+          (FORMAT-ERROR "FORMAT command ~~:^ is illegal outside a ~~:{...~~}"))
+   (LISP:WHEN (LISP:IF (LISP:FIRST PARMS)
+                  (LISP:IF (LISP:SECOND PARMS)
+                      (LISP:IF (LISP:THIRD PARMS)
+                          (LISP:TYPECASE (LISP:SECOND PARMS)
+                              (INTEGER (<= (LISP:FIRST PARMS)
+                                           (LISP:SECOND PARMS)
+                                           (LISP:THIRD PARMS)))
+                              (LISP:CHARACTER (LISP:CHAR< (LISP:FIRST PARMS)
+                                                     (LISP:SECOND PARMS)
+                                                     (LISP:THIRD PARMS)))
+                              (T NIL))
+                          (EQUAL (LISP:FIRST PARMS)
+                                 (LISP:SECOND PARMS)))
+                      (ZEROP (LISP:FIRST PARMS)))
+                  (NOT (LISP:IF COLON
+                           *OUTER-FORMAT-ARGUMENTS*
+                           *FORMAT-ARGUMENTS*)))
+
+       (* ;; "(THROW (IF IL:COLON 'IL:FORMAT-COLON-ESCAPE 'IL:FORMAT-ESCAPE) NIL)")
+
+       (LISP:THROW (LISP:IF COLON
+                       'FORMAT-COLON-ESCAPE
+                       (LISP:IF *FORMAT-COLON-ITERATION*
+                           'FORMAT-ESCAPE
+                           'FORMAT-COLON-ESCAPE))
+              NIL)))
+
+(LISP:DEFUN FORMAT-SEMICOLON-ERROR (COLON ATSIGN PARAMS)
+   (DECLARE (IGNORE COLON ATSIGN PARAMS))
+   (FORMAT-ERROR "Unexpected semicolon (probably a missing ~~ somewhere)."))
+
+(LISP:DEFUN FORMAT-CONDITION (COLON ATSIGN PARMS)
+   (LISP:WHEN PARMS
+       (LISP:PUSH (POP PARMS)
+              *FORMAT-ARGUMENTS*)
+       (LISP:UNLESS (NULL PARMS)
+              (FORMAT-ERROR "Too many parameters to ~[")))
+   (NEXTCHAR)
+   (COND
+      (COLON (LISP:WHEN ATSIGN (FORMAT-ERROR "~~:@[ undefined"))
+             (FORMAT-BOOLEAN-CONDITION))
+      (ATSIGN (FORMAT-FUNNY-CONDITION))
+      (T (FORMAT-UNTAGGED-CONDITION))))
+
+(LISP:DEFUN FORMAT-ITERATION (COLON ATSIGN PARMS)
+
+   (* ;; "Iteration ~{ ... ~}")
+
+   [WITH-FORMAT-PARAMETERS PARMS ((MAX-ITER -1))
+          (NEXTCHAR)
+          (LISP:MULTIPLE-VALUE-BIND (PREV TILDE END-PARMS END-COLON END-ATSIGN)
+                 (FORMAT-FIND-COMMAND '(#\}))
+                 (LISP:WHEN (OR END-ATSIGN END-PARMS)
+                        (FORMAT-ERROR "Illegal terminator for ~~{"))
+                 (LISP:IF (= PREV TILDE)
+                     (LET ((STRING (POP-FORMAT-ARG)))
+
+                          (* ;; "Use an argument as the control string if ~{~} is empty")
+
+                          (LISP:UNLESS (LISP:STRINGP STRING)
+                                 (FORMAT-ERROR "Control string is not a string"))
+                          (FORMAT-WITH-CONTROL-STRING STRING (FORMAT-DO-ITERATION 0 
+                                                                        *FORMAT-LENGTH* MAX-ITER 
+                                                                        COLON ATSIGN END-COLON)))
+                     (FORMAT-DO-ITERATION PREV TILDE MAX-ITER COLON ATSIGN END-COLON))])
+
+(LISP:DEFUN FORMAT-JUSTIFICATION (COLON ATSIGN PARMS)
+   [LISP:MULTIPLE-VALUE-BIND
+    (PREV TILDE ENDPARMS ENDCOLON ENDATSIGN)
+    (FORMAT-FIND-COMMAND '(#\>))
+    (LISP:IF ENDCOLON
+        (PROGN 
+               (* ;; "May as well trap a few errors early")
+
+               (LISP:WHEN PARMS
+                   (SETQ *FORMAT-INDEX* PREV)
+                   (FORMAT-ERROR "Logical-block does not accept parameters"))
+               (LISP:WHEN ENDPARMS (FORMAT-ERROR "Logical-block close does not accept parameters"
+                                          ))
+               (LISP:WHEN *FORMAT-JUSTIFICATION* (FORMAT-ERROR 
+                                                   "~<...~:> not allowed under vanilla justification"
+                                                        ))
+               (FORMAT-CHECK-JUSTIFY)
+               (FORMAT-PPRINT-LOGICAL-BLOCK COLON ATSIGN ENDATSIGN (LISP:1+ PREV)
+                      TILDE))
+        [WITH-FORMAT-PARAMETERS PARMS ((MINCOL 0)
+                                           (COLINC 1)
+                                           (MINPAD 0)
+                                           (PADCHAR #\Space))
+               (LISP:UNLESS (AND (LISP:INTEGERP MINCOL)
+                                 (NOT (MINUSP MINCOL)))
+                      (FORMAT-ERROR "Mincol must be a non-negative integer - ~S" MINCOL))
+               (LISP:UNLESS (AND (LISP:INTEGERP COLINC)
+                                 (LISP:PLUSP COLINC))
+                      (FORMAT-ERROR "Colinc must be a positive integer - ~S" COLINC))
+               (LISP:UNLESS (AND (LISP:INTEGERP MINPAD)
+                                 (NOT (MINUSP MINPAD)))
+                      (FORMAT-ERROR "Minpad must be a non-negative integer - ~S" MINPAD))
+               (LISP:UNLESS (LISP:CHARACTERP PADCHAR)
+                      (FORMAT-ERROR "Padchar must be a character - ~S" PADCHAR))
+               (SETQ *FORMAT-INDEX* PREV)
+               (NEXTCHAR)
+               (LISP:MULTIPLE-VALUE-BIND (SPECIAL-ARG SPECIAL-PARMS SEGMENTS NUMSEGS NUMCHARS)
+                      (FORMAT-GET-SEGMENTS)
+                      (LISP:IF (EQ *FORMAT-INCOMPATIBLE-JUSTIFICATION* :XP)
+                          (FORMAT-ERROR 
+                                 "Pretty-printer directive and ~<...~:;...~> in same format string")
+                          (SETQ *FORMAT-INCOMPATIBLE-JUSTIFICATION* :JUSTIFY))
+                      (LET* ((*FORMAT-JUSTIFICATION* T)
+                             [PADSEGS (LISP:IF (= NUMSEGS 1)
+                                          (LISP:IF (AND COLON ATSIGN)
+                                              2
+                                              1)
+                                          (+ (LISP:IF COLON
+                                                 1
+                                                 0)
+                                             (LISP:1- NUMSEGS)
+                                             (LISP:IF ATSIGN
+                                                 1
+                                                 0)))]
+                             (WIDTH (FORMAT-ROUND-COLUMNS (+ NUMCHARS (LISP:* MINPAD PADSEGS))
+                                           MINCOL COLINC))
+                             (SPACES (MAKE-PAD-SEGS (- WIDTH NUMCHARS)
+                                            PADSEGS)))
+                            (LISP:IF (= NUMSEGS 1)
+                                [COND
+                                   ((AND ATSIGN (NOT COLON))
+                                    (LISP:PUSH '0 SPACES))
+                                   ((OR (AND COLON (NOT ATSIGN))
+                                        (AND (NOT ATSIGN)
+                                             (NOT COLON)))
+                                    (NCONC SPACES '(0]
+                                (PROGN (LISP:IF (OR (AND COLON (NOT ATSIGN))
+                                                    (AND (NOT ATSIGN)
+                                                         (NOT COLON)))
+                                           (NCONC SPACES '(0)))
+                                       (LISP:IF (OR (AND ATSIGN (NOT COLON))
+                                                    (AND (NOT ATSIGN)
+                                                         (NOT COLON)))
+                                           (LISP:PUSH '0 SPACES))))
+                            (LISP:WHEN SPECIAL-ARG
+                                [WITH-FORMAT-PARAMETERS SPECIAL-PARMS ((SPARE 0)
+                                                                           (LINEL (OR (LINELENGTH)
+                                                                                      72)))
+                                       (LET ((POS (OR (CHARPOS *STANDARD-OUTPUT*)
+                                                      0)))
+                                            (LISP:WHEN (> (+ POS WIDTH SPARE)
+                                                          LINEL)
+                                                   (WRITE-STRING* SPECIAL-ARG])
+                            (LISP:DO ((SEGS SEGMENTS (CDR SEGS))
+                                      (SPCS SPACES (CDR SPCS)))
+                                     ((NULL SEGS)
+                                      (LISP:DOTIMES (I (CAR SPCS))
+                                          (LISP:WRITE-CHAR PADCHAR)))
+                                (LISP:DOTIMES (I (CAR SPCS))
+                                    (LISP:WRITE-CHAR PADCHAR))
+                                (WRITE-STRING* (CAR SEGS)))])])
+
+(LISP:DEFUN FORMAT-CAPITALIZATION (COLON ATSIGN PARMS)
+
+   (* ;; "Capitalize ~(")
+
+   (LISP:WHEN PARMS (FORMAT-ERROR "No parameters allowed to ~~("))
+   (NEXTCHAR)
+   [LISP:MULTIPLE-VALUE-BIND (PREV TILDE END-PARMS END-COLON END-ATSIGN)
+          (FORMAT-FIND-COMMAND '(#\)))
+          (LISP:WHEN (OR END-PARMS END-COLON END-ATSIGN)
+                 (FORMAT-ERROR "Flags or parameters not allowed"))
+
+          (* ;; "The messy CL:CATCH nesting below and the funky ESCAPE and SUB-ESCAPE stuff is to record any escape attempts done during the processing of the stuff to be capitalized, so the escape can be continued after doing the WRITE-STRING*.  This can ALMOST be done with an UNWIND-PROTECT, but not quite.")
+
+          (LET* [(ESCAPE NIL)
+                 (STRING (FORMAT-STRINGIFY-OUTPUT (SETQ ESCAPE 'FORMAT-COLON-ESCAPE)
+                                (LISP:CATCH 'FORMAT-COLON-ESCAPE
+                                    (LET ((SUB-ESCAPE 'FORMAT-ESCAPE))
+                                         (LISP:CATCH 'FORMAT-ESCAPE
+                                             (SUB-FORMAT PREV TILDE)
+                                             (SETQ SUB-ESCAPE NIL))
+                                         (LISP:SETQ ESCAPE SUB-ESCAPE)))]
+                [WRITE-STRING* (COND
+                                  ((AND ATSIGN COLON)
+                                   (LISP:NSTRING-UPCASE STRING))
+                                  (COLON (LISP:NSTRING-CAPITALIZE STRING))
+                                  [ATSIGN                    (* ; "Capitalize the first word only")
+                                         (LET ((STRLEN (LISP:LENGTH STRING)))
+                                              (LISP:NSTRING-DOWNCASE STRING)
+                                              (LISP:DO ((I 0 (LISP:1+ I)))
+                                                       ((OR (<= STRLEN I)
+                                                            (LISP:ALPHA-CHAR-P (LISP:CHAR STRING I)))
+                                                        (LISP:SETF (LISP:CHAR STRING I)
+                                                               (LISP:CHAR-UPCASE (LISP:CHAR STRING I)
+                                                                      ))
+                                                        STRING))]
+                                  (T (LISP:NSTRING-DOWNCASE STRING]
+                (AND ESCAPE (LISP:THROW ESCAPE NIL])
+
+(LISP:DEFUN FORMAT-NEWLINE (COLON ATSIGN PARMS)
+   (LISP:WHEN PARMS (FORMAT-ERROR "Parameters not allowed"))
+   (COND
+      (COLON (LISP:WHEN ATSIGN (FORMAT-ERROR "~:@<newline> is undefined")))
+      (ATSIGN (LISP:TERPRI *STANDARD-OUTPUT*)
+             (FORMAT-EAT-WHITESPACE))
+      (T (FORMAT-EAT-WHITESPACE))))
+
+(LISP:DEFUN FORMAT-JUST-WRITE (COLON ATSIGN PARMS)
+
+   (* ;; "Unless I'm REALLY confused, *PRINT-LEVEL* wil be handled correctly without major magic.")
+
+   [COND
+      (PARMS (FORMAT-ERROR "Parameters not allowed"))
+      ((AND *FORMAT-JUSTIFICATION* (OR (NOT *CLTL2-PEDANTIC*)
+                                       COLON *PRINT-PRETTY*))
+
+       (* ;; "Minor extension; CLtL2 says ~W barfs under ~<...~> regardless.  I think ~W should be OK under it unless it will force pretty-printing")
+
+       (FORMAT-ERROR "~W not allowed under vanilla justification"))
+      (T 
+         (* ;; "We don't use FORMAT-CHECK-JUSTIFY here because of the *CLTL2-PEDANTIC* check")
+
+         (LISP:IF (AND (EQ *FORMAT-INCOMPATIBLE-JUSTIFICATION* :JUSTIFY)
+                       (OR (NOT *CLTL2-PEDANTIC*)
+                           COLON *PRINT-PRETTY*))
+             (FORMAT-ERROR "Pretty-printer directive and ~<...~:;...~> in same format string")
+             (SETQ *FORMAT-INCOMPATIBLE-JUSTIFICATION* :XP))
+         (WRITE (POP-FORMAT-ARG)
+                :PRETTY
+                (OR *PRINT-PRETTY* COLON)
+                :LEVEL
+                (LISP:IF ATSIGN
+                    NIL
+                    *PRINT-LEVEL*)
+                :LENGTH
+                (LISP:IF ATSIGN
+                    NIL
+                    *PRINT-LENGTH*)])
+
+(LISP:DEFUN FORMAT-PPRINT-NEWLINE (COLON ATSIGN PARMS)
+   [COND
+      (PARMS (FORMAT-ERROR "Parameters not allowed"))
+      (*FORMAT-JUSTIFICATION* (FORMAT-ERROR "~_ not allowed under vanilla justification"))
+      (T (FORMAT-CHECK-JUSTIFY)
+         (LISP:IF COLON
+             (LISP:IF ATSIGN
+                 (XP:PPRINT-NEWLINE :MANDATORY)
+                 (XP:PPRINT-NEWLINE :FILL))
+             (LISP:IF ATSIGN
+                 (XP:PPRINT-NEWLINE :MISER)
+                 (XP:PPRINT-NEWLINE :LINEAR)))])
+
+(LISP:DEFUN FORMAT-PPRINT-INDENT (COLON ATSIGN PARMS)
+   [COND
+      (ATSIGN (FORMAT-ERROR "@ flag not allowed"))
+      (*FORMAT-JUSTIFICATION* (FORMAT-ERROR "~I not allowed under vanilla justification"))
+      (T (FORMAT-CHECK-JUSTIFY)
+         (WITH-FORMAT-PARAMETERS PARMS ((N 0))
+                (LISP:IF COLON
+                    (XP:PPRINT-INDENT :CURRENT N)
+                    (XP:PPRINT-INDENT :BLOCK N))])
+
+(LISP:DEFUN FORMAT-CALL-FUNCTION (COLON ATSIGN PARMS)
+
+   (* ;; "First eat the leading /")
+
+   (NEXTCHAR)
+
+   (* ;; "Then find the function name, being paranoid about package-qualifiers")
+
+   (LET ((CLOSING/ (FORMAT-FIND-CHAR #\/ *FORMAT-INDEX* *FORMAT-LENGTH*))
+         AFTER-COLONS BEFORE-COLONS FN-TO-CALL)
+        (LISP:UNLESS CLOSING/ (FORMAT-ERROR "Missing closing /"))
+
+        (* ;; "Move AFTER-COLONS to after the colon seperator ")
+
+        (LISP:WHEN (SETQ AFTER-COLONS (FORMAT-FIND-CHAR #\: *FORMAT-INDEX* CLOSING/))
+            (SETQ BEFORE-COLONS AFTER-COLONS)
+            (LISP:WHEN (EQL #\: (LISP:CHAR *FORMAT-CONTROL-STRING* (LISP:INCF AFTER-COLONS)))
+                (LISP:WHEN (EQL #\: (LISP:CHAR *FORMAT-CONTROL-STRING* (LISP:INCF AFTER-COLONS)))
+                       (FORMAT-ERROR "Too many colons in function-name"))))
+
+        (* ;; "Look up the function symbol")
+
+        [SETQ FN-TO-CALL (LISP:IF BEFORE-COLONS
+                             [LISP:FIND-SYMBOL (LISP:STRING-UPCASE (LISP:SUBSEQ 
+                                                                          *FORMAT-CONTROL-STRING* 
+                                                                          :START AFTER-COLONS :END 
+                                                                          CLOSING/))
+                                    (LISP:FIND-PACKAGE (LISP:STRING-UPCASE (LISP:SUBSEQ 
+                                                                              *FORMAT-CONTROL-STRING*
+                                                                                  :START 
+                                                                                  *FORMAT-INDEX* :END
+                                                                                  BEFORE-COLONS]
+                             (LISP:FIND-SYMBOL (LISP:STRING-UPCASE (LISP:SUBSEQ 
+                                                                          *FORMAT-CONTROL-STRING* 
+                                                                          :START *FORMAT-INDEX* :END
+                                                                          CLOSING/)
+                                                      (LISP:FIND-PACKAGE "USER"))))]
+
+        (* ;; "And call the damned thing (bumping past the argument in the control string first)")
+
+        (SETQ *FORMAT-INDEX* (ADD1 CLOSING/))
+        (LISP:APPLY FN-TO-CALL *STANDARD-OUTPUT* (POP-FORMAT-ARG)
+               COLON ATSIGN PARMS)))
+
+
+
+(* ;; "Direct support for top-level entries")
+
+
+(LISP:DEFUN FORMAT-ROUND-COLUMNS (WIDTH MINCOL COLINC)
+
+   (* ;; "Determine the actual width to be used for a field requiring WIDTH characters according to the following rule: If WIDTH is less than or equal to MINCOL, use WIDTH as the actual width.  Otherwise, round up to MINCOL + k * COLINC for the smallest possible positive integer k.")
+
+   (LISP:IF (> WIDTH MINCOL)
+       WIDTH
+       (+ WIDTH (LISP:* COLINC (LISP:CEILING (- MINCOL WIDTH)
+                                      COLINC)))))
+
+(LISP:DEFUN FORMAT-EAT-WHITESPACE ()
+
+   (* ;; "Continue control string on next line ~<newline>")
+
+   (NEXTCHAR)
+   [SETQ *FORMAT-INDEX* (LET ((NEXT-NON-WHITE (LISP:POSITION-IF-NOT (FUNCTION WHITESPACE-CHAR-P)
+                                                     *FORMAT-CONTROL-STRING* :START *FORMAT-INDEX*)))
+                             (LISP:IF NEXT-NON-WHITE
+                                 (LISP:1- NEXT-NON-WHITE)
+                                 (LISP:LENGTH *FORMAT-CONTROL-STRING*))])
+
+(LISP:DEFUN FORMAT-PRINT-NAMED-CHARACTER (CHAR LONGP)
+   [LET* ((CH (LISP:CODE-CHAR (LISP:CHAR-CODE CHAR)))
+          (NAME (LISP:CHAR-NAME CH)))                        (* ; 
+                                            "The calls to CODE-CHAR and CHAR-CODE strip funny bits")
+         (COND
+            [NAME (WRITE-STRING* (LISP:STRING-CAPITALIZE (LISP:PRINC-TO-STRING NAME]
+            [(<= 0 (LISP:CHAR-CODE CHAR)
+                 31)                                         (* ; 
+                                                           "Print control characters as '^' <char>")
+             (LISP:WRITE-CHAR #\^)
+             (LISP:WRITE-CHAR (LISP:CODE-CHAR (+ 64 (LISP:CHAR-CODE CHAR]
+            (T (LISP:WRITE-CHAR CH])
+
+(LISP:DEFUN FORMAT-ADD-COMMAS (STRING COMMACHAR COMMA-INTERVAL)
+
+   (* ;; "Insert commas after every COMMA-INTERVALth digit, scanning from right to left. Signs don't count in the final length.")
+
+   (LISP:DO* ((LENGTH (LISP:LENGTH (THE STRING STRING)))
+              (NEW-LENGTH (+ LENGTH (LISP:FLOOR (- LENGTH (LISP:IF (OR (EQL (LISP:CHAR STRING 0)
+                                                                            #\+)
+                                                                       (EQL (LISP:CHAR STRING 0)
+                                                                            #\-))
+                                                              2
+                                                              1))
+                                           COMMA-INTERVAL)))
+              (NEW-STRING (LISP:MAKE-STRING NEW-LENGTH :INITIAL-ELEMENT COMMACHAR)
+                     (LISP:REPLACE (THE STRING NEW-STRING)
+                            (THE STRING STRING)
+                            :START1
+                            (MAX 0 (- NEW-POS COMMA-INTERVAL))
+                            :END1 NEW-POS :START2 (MAX 0 (- POS COMMA-INTERVAL))
+                            :END2 POS))
+              (POS LENGTH (- POS COMMA-INTERVAL))
+              (NEW-POS NEW-LENGTH (- NEW-POS COMMA-INTERVAL 1)))
+             ((NOT (LISP:PLUSP POS))
+
+              (* ;; "If there was a sign, put it back now")
+
+              (LISP:IF (OR (EQL (LISP:CHAR STRING 0)
+                                #\+)
+                           (EQL (LISP:CHAR STRING 0)
+                                #\-))
+                  (LISP:SETF (LISP:CHAR NEW-STRING 0)
+                         (LISP:CHAR STRING 0)))
+              NEW-STRING)))
+
+(LISP:DEFUN FORMAT-WRITE-FIELD (STRING MINCOL COLINC MINPAD PADCHAR PADLEFT)
+
+   (* ;; "Output a string in a field at MINCOL wide, padding with PADCHAR.  Pads on the left if PADLEFT is true, else on the right.  If the length of the string plus the minimum permissible padding, MINPAD, is greater than MINCOL, the actual field size is rounded up to MINCOL + k * COLINC for the smallest possible positive integer k.")
+
+   (LISP:UNLESS (AND (LISP:INTEGERP MINCOL)
+                     (NOT (MINUSP MINCOL)))
+          (FORMAT-ERROR "Mincol must be a non-negative integer - ~S" MINCOL))
+   (LISP:UNLESS (AND (LISP:INTEGERP COLINC)
+                     (LISP:PLUSP COLINC))
+          (FORMAT-ERROR "Colinc must be a positive integer - ~S" COLINC))
+   (LISP:UNLESS (AND (LISP:INTEGERP MINPAD)
+                     (NOT (MINUSP MINPAD)))
+          (FORMAT-ERROR "Minpad must be a non-negative integer - ~S" MINPAD))
+   (LISP:UNLESS (LISP:CHARACTERP PADCHAR)
+          (FORMAT-ERROR "Padchar must be a character - ~S" PADCHAR))
+   [LET* ((STRLEN (LISP:LENGTH (THE STRING STRING)))
+          (WIDTH (FORMAT-ROUND-COLUMNS (+ STRLEN MINPAD)
+                        MINCOL COLINC)))
+         (COND
+            (PADLEFT (LISP:DOTIMES (I (- WIDTH STRLEN))
+                         (LISP:WRITE-CHAR PADCHAR))
+                   (WRITE-STRING* STRING))
+            (T (WRITE-STRING* STRING)
+               (LISP:DOTIMES (I (- WIDTH STRLEN))
+                   (LISP:WRITE-CHAR PADCHAR))])
+
+(LISP:DEFUN FORMAT-PRINT-NUMBER (NUMBER RADIX PRINT-COMMAS-P PRINT-SIGN-P PARMS)
+
+   (* ;; "This functions does most of the work for the numeric printing directives.  The parameters are interpreted as defined for ~D.")
+
+   [WITH-FORMAT-PARAMETERS PARMS ((MINCOL 0)
+                                      (PADCHAR #\Space)
+                                      (COMMACHAR #\,)
+                                      (COMMA-INTERVAL 3))    (* ; 
+                                                           "comma-interval is an XCL extension.")
+          (LET* ((*PRINT-BASE* RADIX)
+                 (*PRINT-RADIX* NIL)
+                 (*PRINT-ESCAPE* NIL)
+                 (TEXT (LISP:PRINC-TO-STRING NUMBER)))
+                (LISP:IF (LISP:INTEGERP NUMBER)
+                    (PROGN 
+                           (* ;; "colinc = 1, minpad = 0, padleft = t ")
+
+                           (FORMAT-WRITE-FIELD (LISP:IF (AND (LISP:PLUSP NUMBER)
+                                                                 PRINT-SIGN-P)
+                                                       (LISP:IF PRINT-COMMAS-P
+                                                           (LISP:CONCATENATE 'STRING "+"
+                                                                  (FORMAT-ADD-COMMAS TEXT 
+                                                                         COMMACHAR COMMA-INTERVAL))
+                                                           (LISP:CONCATENATE 'STRING "+" TEXT))
+                                                       (LISP:IF PRINT-COMMAS-P
+                                                           (FORMAT-ADD-COMMAS TEXT COMMACHAR 
+                                                                  COMMA-INTERVAL)
+                                                           TEXT))
+                                  MINCOL 1 0 PADCHAR T))
+                    (WRITE-STRING* TEXT))])
+
+(LISP:DEFUN FORMAT-PRINT-SMALL-CARDINAL (N)
+   [LISP:MULTIPLE-VALUE-BIND (HUNDREDS REM)
+          (LISP:TRUNCATE N 100)
+          (LISP:WHEN (LISP:PLUSP HUNDREDS)
+              (WRITE-STRING* (LISP:SVREF CARDINAL-ONES HUNDREDS))
+              (WRITE-STRING* " hundred")
+              (LISP:WHEN (LISP:PLUSP REM)
+                     (LISP:WRITE-CHAR #\Space)))
+          (LISP:WHEN (LISP:PLUSP REM)
+              [LISP:MULTIPLE-VALUE-BIND (TENS ONES)
+                     (LISP:TRUNCATE REM 10)
+                     (COND
+                        [(< 1 TENS)
+                         (WRITE-STRING* (LISP:SVREF CARDINAL-TENS TENS))
+                         (LISP:WHEN (LISP:PLUSP ONES)
+                             (LISP:WRITE-CHAR #\-)
+                             (WRITE-STRING* (LISP:SVREF CARDINAL-ONES ONES)))]
+                        ((= TENS 1)
+                         (WRITE-STRING* (LISP:SVREF CARDINAL-TEENS ONES)))
+                        ((LISP:PLUSP ONES)
+                         (WRITE-STRING* (LISP:SVREF CARDINAL-ONES ONES])])
+
+(LISP:DEFUN FORMAT-PRINT-CARDINAL (N &OPTIONAL ERR)
+   [COND
+      ((MINUSP N)
+       (WRITE-STRING* "negative ")
+       (FORMAT-PRINT-CARDINAL-AUX (- N)
+              0
+              (OR ERR N)))
+      ((ZEROP N)
+       (WRITE-STRING* "zero"))
+      (T (FORMAT-PRINT-CARDINAL-AUX N 0 (OR ERR N])
+
+(LISP:DEFUN FORMAT-PRINT-CARDINAL-AUX (N PERIOD ERR)
+   [LISP:MULTIPLE-VALUE-BIND (BEYOND HERE)
+          (LISP:TRUNCATE N 1000)
+          (LISP:UNLESS (<= PERIOD 10)
+                 (FORMAT-ERROR "Number too large to print in English: ~:D" ERR))
+          (LISP:UNLESS (ZEROP BEYOND)
+              (FORMAT-PRINT-CARDINAL-AUX BEYOND (LISP:1+ PERIOD)
+                     ERR))
+          (LISP:UNLESS (ZEROP HERE)
+              (LISP:UNLESS (ZEROP BEYOND)
+                     (LISP:WRITE-CHAR #\Space))
+              (FORMAT-PRINT-SMALL-CARDINAL HERE)
+              (WRITE-STRING* (LISP:SVREF CARDINAL-PERIODS PERIOD)))])
+
+(LISP:DEFUN FORMAT-PRINT-ORDINAL (N)
+   (LISP:WHEN (MINUSP N)
+          (WRITE-STRING* "negative "))
+   [LET ((LISP:NUMBER (ABS N)))
+        (LISP:MULTIPLE-VALUE-BIND (TOP BOT)
+               (LISP:TRUNCATE LISP:NUMBER 100)
+               (LISP:UNLESS (ZEROP TOP)
+                   (FORMAT-PRINT-CARDINAL (- LISP:NUMBER BOT)
+                          LISP:NUMBER))
+               (LISP:WHEN (AND (LISP:PLUSP TOP)
+                               (LISP:PLUSP BOT))
+                      (LISP:WRITE-CHAR #\Space))
+               (LISP:MULTIPLE-VALUE-BIND (TENS ONES)
+                      (LISP:TRUNCATE BOT 10)
+                      (COND
+                         ((= BOT 12)
+                          (WRITE-STRING* "twelfth"))
+                         ((= TENS 1)
+                          (WRITE-STRING* (LISP:SVREF CARDINAL-TEENS ONES))
+                          (WRITE-STRING* "th"))
+                         ((AND (ZEROP TENS)
+                               (LISP:PLUSP ONES))
+                          (WRITE-STRING* (LISP:SVREF ORDINAL-ONES ONES)))
+                         ((AND (ZEROP ONES)
+                               (LISP:PLUSP TENS))
+                          (WRITE-STRING* (LISP:SVREF ORDINAL-TENS TENS)))
+                         ((LISP:PLUSP BOT)
+                          (WRITE-STRING* (LISP:SVREF CARDINAL-TENS TENS))
+                          (LISP:WRITE-CHAR #\-)
+                          (WRITE-STRING* (LISP:SVREF ORDINAL-ONES ONES)))
+                         ((LISP:PLUSP LISP:NUMBER)
+                          (WRITE-STRING* "th"))
+                         (T (WRITE-STRING* "zeroeth"])
+
+(LISP:DEFUN FORMAT-PRINT-OLD-ROMAN (N)
+
+   (* ;; "Print Roman numerals")
+
+   (LISP:UNLESS (< 0 N 5000)
+          (FORMAT-ERROR "Number too large to print in old Roman numerals: ~:D" N))
+   (LISP:DO [(CHAR-LIST '(#\D #\C #\L #\X #\V #\I)
+                    (CDR CHAR-LIST))
+             (VAL-LIST '(500 100 50 10 5 1)
+                    (CDR VAL-LIST))
+             (CUR-CHAR #\M (CAR CHAR-LIST))
+             (CUR-VAL 1000 (CAR VAL-LIST))
+             (START N (LISP:DO [(I START (PROGN (LISP:WRITE-CHAR CUR-CHAR)
+                                                (- I CUR-VAL]
+                               ((< I CUR-VAL)
+                                I))]
+            ((ZEROP START))))
+
+(LISP:DEFUN FORMAT-PRINT-ROMAN (N)
+   (LISP:UNLESS (< 0 N 4000)
+          (FORMAT-ERROR "Number too large to print in Roman numerals: ~:D" N))
+   (LISP:DO [(CHAR-LIST '(#\D #\C #\L #\X #\V #\I)
+                    (CDR CHAR-LIST))
+             (VAL-LIST '(500 100 50 10 5 1)
+                    (CDR VAL-LIST))
+             (SUB-CHARS '(#\C #\X #\X #\I #\I)
+                    (CDR SUB-CHARS))
+             (SUB-VAL '(100 10 10 1 1 0)
+                    (CDR SUB-VAL))
+             (CUR-CHAR #\M (CAR CHAR-LIST))
+             (CUR-VAL 1000 (CAR VAL-LIST))
+             (CUR-SUB-CHAR #\C (CAR SUB-CHARS))
+             (CUR-SUB-VAL 100 (CAR SUB-VAL))
+             (START N (LISP:DO [(I START (PROGN (LISP:WRITE-CHAR CUR-CHAR)
+                                                (- I CUR-VAL]
+                               ((< I CUR-VAL)
+                                (COND
+                                   ((<= (- CUR-VAL CUR-SUB-VAL)
+                                        I)
+                                    (LISP:WRITE-CHAR CUR-SUB-CHAR)
+                                    (LISP:WRITE-CHAR CUR-CHAR)
+                                    (- I (- CUR-VAL CUR-SUB-VAL)))
+                                   (T I))))]
+            ((ZEROP START))))
+
+(LISP:DEFUN FORMAT-PRINT-DECIMAL (COLON ATSIGN PARMS)
+
+   (* ;; "Decimal ~D")
+
+   (FORMAT-PRINT-NUMBER (POP-FORMAT-ARG)
+          10 COLON ATSIGN PARMS))
+
+(LISP:DEFUN FORMAT-PRINT-RADIX-AUX (LISP:NUMBER COLON ATSIGN)
+   (LISP:IF (TYPEP LISP:NUMBER 'INTEGER)
+       (LISP:IF ATSIGN
+           (LISP:IF COLON
+               (FORMAT-PRINT-OLD-ROMAN LISP:NUMBER)
+               (FORMAT-PRINT-ROMAN LISP:NUMBER))
+           (LISP:IF COLON
+               (FORMAT-PRINT-ORDINAL LISP:NUMBER)
+               (FORMAT-PRINT-CARDINAL LISP:NUMBER)))
+       (FORMAT-ERROR "Non-integer ~S can't be FORMATted ~~~:[~;:~]~:[~;@~]R" LISP:NUMBER COLON 
+              ATSIGN)))
+
+(LISP:DEFUN FORMAT-FIXED-AUX (NUMBER W D K OVF PAD ATSIGN)
+   (LISP:IF (NOT (OR W D K))
+       (PROGN 
+              (* ;; "Code snarfed from Spice printer OUTPUT-FLOAT")
+
+              (LISP:WHEN (MINUSP NUMBER)
+                  (LISP:WRITE-CHAR #\-)
+                  (LISP:SETQ NUMBER (- NUMBER)))
+
+              (* ;; 
+            "When number is reasonable size, use FLONUM-TO-STRING, otherwise punt and PRINC it")
+
+              (LISP:IF (AND (>= NUMBER 0.001)
+                            (<= NUMBER 1.0E+7))
+                  (LISP:MULTIPLE-VALUE-BIND (STR LEN LPOINT TPOINT)
+                         (FLONUM-TO-STRING NUMBER)
+                         (LISP:WHEN LPOINT (LISP:WRITE-CHAR #\0))
+                         (WRITE-STRING* STR)
+                         (LISP:WHEN TPOINT (LISP:WRITE-CHAR #\0)))
+                  (LISP:PRINC NUMBER)))
+       [LET ((SPACELEFT W))
+            (LISP:WHEN (AND W (OR ATSIGN (MINUSP NUMBER)))
+                   (LISP:DECF SPACELEFT))
+            (LISP:MULTIPLE-VALUE-BIND (STR LEN LPOINT TPOINT)
+                   (FLONUM-TO-STRING (ABS NUMBER)
+                          SPACELEFT D K)
+
+                   (* ;; 
+         "if caller specifically requested no fraction digits, suppress the optional trailing zero")
+
+                   (LISP:WHEN (AND D (ZEROP D))
+                          (SETQ TPOINT NIL))
+                   (LISP:WHEN W
+                       (LISP:DECF SPACELEFT LEN)
+
+                       (* ;; "optional leading zero force at least one digit")
+
+                       (LISP:WHEN LPOINT
+                           (LISP:IF (OR (> SPACELEFT 0)
+                                        TPOINT)
+                               (LISP:DECF SPACELEFT)
+                               (SETQ LPOINT NIL)))
+
+                       (* ;; "optional trailing zero")
+
+                       (LISP:WHEN TPOINT
+                           (LISP:IF (> SPACELEFT 0)
+                               (LISP:DECF SPACELEFT)
+                               (SETQ TPOINT NIL))))
+                   (COND
+                      ((AND W (< SPACELEFT 0)
+                            OVF)
+
+                       (* ;; "field width overflow")
+
+                       (LISP:DOTIMES (I W)
+                           (LISP:WRITE-CHAR OVF)))
+                      (T (LISP:WHEN W
+                             (LISP:DOTIMES (I SPACELEFT)
+                                 (LISP:WRITE-CHAR PAD)))
+                         (LISP:IF (MINUSP NUMBER)
+                             (LISP:WRITE-CHAR #\-)
+                             (LISP:IF ATSIGN (LISP:WRITE-CHAR #\+)))
+                         (LISP:WHEN LPOINT (LISP:WRITE-CHAR #\0))
+                         (WRITE-STRING* STR)
+                         (LISP:WHEN TPOINT (LISP:WRITE-CHAR #\0]))
+
+(LISP:DEFUN FORMAT-EXPONENT-MARKER (LISP:NUMBER)
+   (LISP:IF (TYPEP LISP:NUMBER *READ-DEFAULT-FLOAT-FORMAT*)
+       #\E
+       (LISP:ETYPECASE LISP:NUMBER
+           (LISP:SHORT-FLOAT #\S)
+           (LISP:SINGLE-FLOAT #\F))))
+
+(LISP:DEFUN FORMAT-EXP-AUX (NUMBER W D E K OVF PAD MARKER ATSIGN)
+
+   (* ;; "Here we prevent the scale factor from shifting all significance out of a number to the right.  We allow insignificant zeroes to be shifted in to the left right, athough it is an error to specify k and d such that this occurs.  Perhaps we should detect both these conditions and flag them as errors.  As for now, we let the user get away with it, and merely guarantee that at least one significant digit will appear.")
+
+   (LISP:IF (NOT (OR W D))
+       (LISP:PRIN1 NUMBER)
+       [LISP:MULTIPLE-VALUE-BIND
+        (NUM EXPT)
+        (SCALE-EXPONENT (ABS NUMBER))
+        (LET* ((EXPT (- EXPT K))
+               (ESTR (LISP:PRINC-TO-STRING (ABS EXPT)))
+               (ELEN (LISP:IF E
+                         (MAX (LISP:LENGTH ESTR)
+                              E)
+                         (LISP:LENGTH ESTR)))
+               (FDIG (LISP:IF D
+                         (LISP:IF (LISP:PLUSP K)
+                             (LISP:1+ (- D K))
+                             D)
+                         NIL))
+               (FMIN (LISP:IF (MINUSP K)
+                         (- 1 K)
+                         NIL))
+               (SPACELEFT (LISP:IF W
+                              (- W 2 ELEN)
+                              NIL)))
+              (LISP:WHEN (OR ATSIGN (MINUSP NUMBER))
+                     (LISP:DECF SPACELEFT))
+              (LISP:IF (AND W E OVF (> ELEN E))
+                  (PROGN 
+                         (* ;; "exponent overflow")
+
+                         (LISP:DOTIMES (I W)
+                             (LISP:WRITE-CHAR OVF)))
+                  [LISP:MULTIPLE-VALUE-BIND (FSTR FLEN LPOINT TPOINT)
+                         (FLONUM-TO-STRING NUM SPACELEFT FDIG K FMIN)
+                         (LISP:WHEN W
+                             (LISP:DECF SPACELEFT FLEN)
+                             (LISP:WHEN LPOINT
+                                 (LISP:IF (> SPACELEFT 0)
+                                     (LISP:DECF SPACELEFT)
+                                     (SETQ LPOINT NIL))))
+                         (COND
+                            ((AND W (< SPACELEFT 0)
+                                  OVF)
+
+                             (* ;; "significand overflow")
+
+                             (LISP:DOTIMES (I W)
+                                 (LISP:WRITE-CHAR OVF)))
+                            (T (LISP:WHEN W
+                                   (LISP:DOTIMES (I SPACELEFT)
+                                       (LISP:WRITE-CHAR PAD)))
+                               (LISP:IF (MINUSP NUMBER)
+                                   (LISP:WRITE-CHAR #\-)
+                                   (LISP:IF ATSIGN (LISP:WRITE-CHAR #\+)))
+                               (LISP:WHEN LPOINT (LISP:WRITE-CHAR #\0))
+                               (WRITE-STRING* FSTR)
+
+                               (* ;; "(cl:when tpoint (cl:write-char #\0))")
+
+                               (LISP:WRITE-CHAR (LISP:IF MARKER
+                                                    MARKER
+                                                    (FORMAT-EXPONENT-MARKER NUMBER)))
+                               (LISP:WRITE-CHAR (LISP:IF (MINUSP EXPT)
+                                                    #\-
+                                                    #\+))
+                               (LISP:WHEN E
+
+                                   (* ;; "zero-fill before exponent if necessary")
+
+                                   (LISP:DOTIMES (I (- E (LISP:LENGTH ESTR)))
+                                       (LISP:WRITE-CHAR #\0)))
+                               (WRITE-STRING* ESTR])]))
+
+(LISP:DEFUN FORMAT-GENERAL-AUX (LISP:NUMBER W D E K OVF PAD MARKER ATSIGN)
+   [LISP:MULTIPLE-VALUE-BIND (IGNORE N)
+          (SCALE-EXPONENT (ABS LISP:NUMBER))
+          (DECLARE (IGNORE IGNORE))
+
+          (* ;; "Default d if omitted.  The procedure is taken directly from the definition given in the manual, and is not very efficient, since we generate the digits twice. Future maintainers are encouraged to improve on this.")
+
+          (LISP:UNLESS D
+              [LISP:MULTIPLE-VALUE-BIND (STR LEN)
+                     (FLONUM-TO-STRING (ABS LISP:NUMBER))
+                     (DECLARE (IGNORE STR))
+                     (LET [(Q (LISP:IF (= LEN 1)
+                                  1
+                                  (LISP:1- LEN))]
+                          (SETQ D (MAX Q (MIN N 7])
+          (LET* ((EE (LISP:IF E
+                         (+ E 2)
+                         4))
+                 (WW (LISP:IF W
+                         (- W EE)
+                         NIL))
+                 (DD (- D N)))
+                (COND
+                   ((<= 0 DD D)
+                    (FORMAT-FIXED-AUX LISP:NUMBER WW DD NIL OVF PAD ATSIGN)
+                    (LISP:DOTIMES (I EE)
+                        (LISP:WRITE-CHAR #\Space)))
+                   (T (FORMAT-EXP-AUX LISP:NUMBER W D E (OR K 1)
+                             OVF PAD MARKER ATSIGN])
+
+(LISP:DEFUN FORMAT-UNTAGGED-CONDITION ()
+
+   (* ;; "~[")
+
+   [LET ((TEST (POP-FORMAT-ARG)))
+        (LISP:UNLESS (LISP:INTEGERP TEST)
+               (FORMAT-ERROR "Argument to ~~[ must be integer - ~S" TEST))
+        (LISP:DO ((LISP:COUNT 0 (LISP:1+ LISP:COUNT)))
+                 [(= LISP:COUNT TEST)
+                  (LISP:MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN CMD)
+                         (FORMAT-FIND-COMMAND '(#\; #\]))
+                         (DECLARE (IGNORE COLON))
+                         (LISP:WHEN ATSIGN (FORMAT-ERROR "Atsign flag not allowed"))
+                         (LISP:WHEN PARMS (FORMAT-ERROR "No parameters allowed"))
+                         (SUB-FORMAT PREV TILDE)
+                         (LISP:UNLESS (LISP:CHAR= CMD #\])
+                             (FORMAT-FIND-COMMAND '(#\])))]
+            (LISP:MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN CMD)
+                   (FORMAT-FIND-COMMAND '(#\; #\]))
+                   (DECLARE (IGNORE PREV TILDE))
+                   (LISP:WHEN ATSIGN (FORMAT-ERROR "Atsign flag not allowed"))
+                   (LISP:WHEN PARMS (FORMAT-ERROR "Parameters not allowed"))
+                   (LISP:WHEN (LISP:CHAR= CMD #\])
+                          (RETURN))
+                   (LISP:WHEN COLON
+                       (NEXTCHAR)
+                       [LISP:MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN CMD)
+                              (FORMAT-FIND-COMMAND '(#\; #\]))
+                              (DECLARE (IGNORE PARMS COLON ATSIGN))
+                              (SUB-FORMAT PREV TILDE)
+                              (LISP:UNLESS (LISP:CHAR= CMD #\])
+                                  (FORMAT-FIND-COMMAND '(#\])))]
+                       (RETURN))
+                   (NEXTCHAR)))])
+
+(LISP:DEFUN FORMAT-FUNNY-CONDITION ()
+
+   (* ;; "~@[ ")
+
+   (LISP:MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN)
+          (FORMAT-FIND-COMMAND '(#\]))
+          (LISP:WHEN (OR COLON ATSIGN PARMS)
+                 (FORMAT-ERROR "Flags or arguments not allowed"))
+          (LISP:IF *FORMAT-ARGUMENTS*
+              (LISP:IF (CAR *FORMAT-ARGUMENTS*)
+                  (SUB-FORMAT PREV TILDE)
+                  (LISP:POP *FORMAT-ARGUMENTS*))
+              (FORMAT-ERROR "Missing argument"))))
+
+(LISP:DEFUN FORMAT-BOOLEAN-CONDITION ()
+
+   (* ;; "~:[")
+
+   [LISP:MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN)
+          (FORMAT-FIND-COMMAND '(#\;))
+          (LISP:WHEN (OR PARMS COLON ATSIGN)
+                 (FORMAT-ERROR "Flags or parameters not allowed"))
+          (NEXTCHAR)
+          (LISP:IF (POP-FORMAT-ARG)
+              (LISP:MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN)
+                     (FORMAT-FIND-COMMAND '(#\]))
+                     (LISP:WHEN (OR COLON ATSIGN PARMS)
+                            (FORMAT-ERROR "Flags or parameters not allowed"))
+                     (SUB-FORMAT PREV TILDE))
+              [PROGN (SUB-FORMAT PREV TILDE)
+                     (FORMAT-FIND-COMMAND '(#\]])])
+
+(LISP:DEFUN FORMAT-DO-ITERATION (START END MAX-ITER COLON ATSIGN AT-LEAST-ONCE-P)
+
+   (* ;; "The two catch tags FORMAT-ESCAPE and FORMAT-COLON-ESCAPE are needed here to correctly implement ~^ and ~:^.  The former aborts only the current iteration, but the latter aborts the entire iteration process.")
+
+   [LET ((*FORMAT-COLON-ITERATION* COLON))
+        (LISP:CATCH 'FORMAT-COLON-ESCAPE
+            (LISP:CATCH 'FORMAT-ESCAPE
+                [LISP:FLET [(REALLY-ITERATE (ERRMSG)
+                                   (LISP:DO ((LISP:COUNT 0 (LISP:1+ LISP:COUNT)))
+                                            [(OR (= LISP:COUNT MAX-ITER)
+                                                 (AND (NULL *FORMAT-ARGUMENTS*)
+                                                      (LISP:IF (= LISP:COUNT 0)
+                                                          (NOT AT-LEAST-ONCE-P)
+                                                          T)]
+                                       (LISP:CATCH 'FORMAT-ESCAPE
+                                           (LISP:IF COLON
+                                               (LET* ((*FORMAT-ORIGINAL-ARGUMENTS* (POP-FORMAT-ARG
+                                                                                    ))
+                                                      (*OUTER-FORMAT-ARGUMENTS* *FORMAT-ARGUMENTS*)
+                                                      (*FORMAT-ARGUMENTS* *FORMAT-ORIGINAL-ARGUMENTS*
+                                                             ))
+                                                     (LISP:UNLESS (LISP:LISTP *FORMAT-ARGUMENTS*)
+                                                            (FORMAT-ERROR ERRMSG))
+                                                     (SUB-FORMAT START END))
+                                               (SUB-FORMAT START END))))]
+                       (LISP:IF ATSIGN
+                           (REALLY-ITERATE "Argument must be a list")
+                           (LET* ((*FORMAT-ORIGINAL-ARGUMENTS* (POP-FORMAT-ARG))
+                                  (*FORMAT-ARGUMENTS* *FORMAT-ORIGINAL-ARGUMENTS*))
+                                 (LISP:UNLESS (LISP:LISTP *FORMAT-ARGUMENTS*)
+                                        (FORMAT-ERROR "Argument must be a list"))
+                                 (REALLY-ITERATE "Argument must be a list of lists")))]))])
+
+(LISP:DEFUN FORMAT-GET-TRAILING-SEGMENTS ()
+
+   (* ;; "Parses a list of clauses delimited by ~ and terminated by ~>.  Recursively invoke SUB-FORMAT to process them, and return a list of the results, the length of this list, and the total number of characters in the strings composing the list.")
+
+   (NEXTCHAR)
+   [LISP:MULTIPLE-VALUE-BIND (PREV TILDE COLON ATSIGN PARMS CMD)
+          (FORMAT-FIND-COMMAND '(#\; #\>))
+          (LISP:WHEN COLON (FORMAT-ERROR "~~:; allowed only after first segment in ~~<"))
+          (LISP:WHEN (OR ATSIGN PARMS)
+                 (FORMAT-ERROR "Flags and parameters not allowed"))
+          (LET [(STR (LISP:CATCH 'FORMAT-ESCAPE
+                         (FORMAT-STRINGIFY-OUTPUT (SUB-FORMAT PREV TILDE)))]
+               (LISP:IF STR
+                   (LISP:IF (LISP:CHAR= CMD #\;)
+                       [LISP:MULTIPLE-VALUE-BIND (SEGMENTS NUMSEGS NUMCHARS)
+                              (FORMAT-GET-TRAILING-SEGMENTS)
+                              (LISP:VALUES (CONS STR SEGMENTS)
+                                     (LISP:1+ NUMSEGS)
+                                     (+ NUMCHARS (LISP:LENGTH STR]
+                       (LISP:VALUES (LIST STR)
+                              1
+                              (LISP:LENGTH STR)))
+                   (LISP:VALUES NIL 0 0))])
+
+(LISP:DEFUN FORMAT-GET-SEGMENTS ()
+
+   (* ;; "Gets the first segment, which is treated specially.  Call FORMAT-GET-TRAILING-SEGMENTS to get the rest.")
+
+   [LISP:MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN CMD)
+          (FORMAT-FIND-COMMAND '(#\; #\>))
+          (LISP:WHEN ATSIGN (FORMAT-ERROR "Atsign flag not allowed"))
+          (LET [(FIRST-SEG (FORMAT-STRINGIFY-OUTPUT (SUB-FORMAT PREV TILDE]
+               (LISP:IF (LISP:CHAR= CMD #\;)
+                   [LISP:MULTIPLE-VALUE-BIND (SEGMENTS NUMSEGS NUMCHARS)
+                          (FORMAT-GET-TRAILING-SEGMENTS)
+                          (LISP:IF COLON
+                              (LISP:VALUES FIRST-SEG PARMS SEGMENTS NUMSEGS NUMCHARS)
+                              (LISP:VALUES NIL NIL (CONS FIRST-SEG SEGMENTS)
+                                     (LISP:1+ NUMSEGS)
+                                     (+ (LISP:LENGTH FIRST-SEG)
+                                        NUMCHARS)))]
+                   (LISP:VALUES NIL NIL (LIST FIRST-SEG)
+                          1
+                          (LISP:LENGTH FIRST-SEG)))])
+
+(LISP:DEFUN FORMAT-PPRINT-LOGICAL-BLOCK (COLON ATSIGN ENDATSIGN START END)
+
+(* ;;; "The amusement potential is near-infinite here; what we're doing is setting up the traditional format argument-eating mechanism to work like PPRINT-POP")
+
+   [LET ((*FORMAT-LOGICAL-BLOCK* (LISP:IF ENDATSIGN
+                                     :FILL
+                                     T))
+         (*FORMAT-INDEX* START)
+         (PREFIX (LISP:IF COLON "("))
+         (SUFFIX (LISP:IF COLON ")"))
+         PER-LINE-PREFIX?)
+
+        (* ;; "First grind through the string finding segments; when we're finished, START and END will point to the body, PREFIX, SUFFIX, and PER-LINE-PREFIX? will be set right")
+
+        [LISP:MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN CMD)
+               (FORMAT-FIND-COMMAND '(#\; #\>))
+               (IF (LISP:CHAR= CMD #\;)
+                   THEN                                  (* ; "At least two segments")
+                         (LISP:WHEN PARMS (FORMAT-ERROR 
+                                                 "Parameters not allowed for logical-block seperator"
+                                                 ))
+                         (LISP:WHEN COLON (FORMAT-ERROR 
+                                                 "Colon not allowed for logical-block seperator"))
+                         (SETQ PREFIX (LISP:SUBSEQ *FORMAT-CONTROL-STRING* PREV TILDE))
+                         (LISP:WHEN ATSIGN (SETQ PER-LINE-PREFIX? T))
+                         (SETQ START (LISP:1+ *FORMAT-INDEX*))
+                         [LISP:MULTIPLE-VALUE-SETQ (PREV TILDE PARMS COLON ATSIGN CMD)
+                                (FORMAT-FIND-COMMAND '(#\; #\>]
+                         (IF (LISP:CHAR= CMD #\;)
+                             THEN                        (* ; "At least three segments")
+                                   (LISP:WHEN PARMS (FORMAT-ERROR 
+                                                 "Parameters not allowed for logical-block seperator"
+                                                           ))
+                                   (LISP:WHEN COLON (FORMAT-ERROR 
+                                                      "Colon not allowed for logical-block seperator"
+                                                           ))
+                                   (LISP:WHEN ATSIGN (FORMAT-ERROR 
+                                                "Atsign not allowed for this logical-block seperator"
+                                                            ))
+                                   (SETQ SUFFIX (LISP:SUBSEQ *FORMAT-CONTROL-STRING* PREV TILDE))
+                                   (SETQ START (LISP:1+ *FORMAT-INDEX*))
+                                   [LISP:MULTIPLE-VALUE-SETQ (PREV TILDE PARMS COLON ATSIGN CMD)
+                                          (FORMAT-FIND-COMMAND '(#\; #\>]
+                                   (LISP:WHEN (LISP:CHAR= CMD #\;)
+                                          (FORMAT-ERROR 
+                                             "No more than three segments allowed in a logical-block"
+                                                 ]
+
+        (* ;; 
+      "We are supposedly ready to do it.  The code below is a massively hacked macroexpansion of")
+
+        (* ;; "(PPRINT-LOGICAL-BLOCK (*STANDARD-OUTPUT* *FORMAT-ARGUMENTS* :PREFIX PREFIX :PER-LINE-PREFIX PER-LINE-PREFIX? :SUFFIX SUFFIX) (SUB-FORMAT START END))")
+
+        (XP::MAYBE-INITIATE-XP-PRINTING
+         #'[LISP:LAMBDA (*STANDARD-OUTPUT* ARGLIST)
+                  (LET* ((*FORMAT-ORIGINAL-ARGUMENTS* ARGLIST)
+                         (*FORMAT-ARGUMENTS* *FORMAT-ORIGINAL-ARGUMENTS*))
+
+                        (* ;; "NOTE:  the LET below is not a LET* for a reason; CIRCLE-CHECK must depend on the unbound value of XP::*CURRENT-LENGTH*, according to the convoluted code of XP::PPRINT-LOGICAL-BLOCK+.  Yeesh...")
+
+                        (LET ((CIRCLE-CHECK (LISP:IF ATSIGN
+                                                (LISP:PLUSP XP::*CURRENT-LENGTH*)
+                                                T))
+                              (XP::*CURRENT-LEVEL* (LISP:1+ XP::*CURRENT-LEVEL*))
+                              (XP::*CURRENT-LENGTH* -1)
+                              (XP::*PARENTS* XP::*PARENTS*))
+                             (LISP:UNLESS (XP::CHECK-BLOCK-ABBREVIATION *STANDARD-OUTPUT* 
+                                                 *FORMAT-ARGUMENTS* CIRCLE-CHECK)
+                                 (LISP:CATCH 'XP::LOGICAL-BLOCK
+                                     (XP::START-BLOCK *STANDARD-OUTPUT* PREFIX (NOT (NULL 
+                                                                                     PER-LINE-PREFIX?
+                                                                                          ))
+                                            SUFFIX)
+                                     (LISP:UNWIND-PROTECT
+                                         (SUB-FORMAT START END)
+                                         (XP::END-BLOCK *STANDARD-OUTPUT* SUFFIX))))]
+         *STANDARD-OUTPUT*
+         (LISP:IF ATSIGN
+             *FORMAT-ARGUMENTS*
+             (POP-FORMAT-ARG))])
+
+(LISP:DEFUN FORMAT-CHECK-JUSTIFY ()
+   (LISP:IF (EQ *FORMAT-INCOMPATIBLE-JUSTIFICATION* :JUSTIFY)
+       (FORMAT-ERROR "Pretty-printer directive and ~<...~:;...~> in same format string")
+       (SETQ *FORMAT-INCOMPATIBLE-JUSTIFICATION* :XP)))
+
+(LISP:DEFUN CHARPOS (STREAM)
+   (LISP:UNLESS (STREAMP STREAM)
+          (LISP:ERROR "CHARPOS: ~A isn't a stream" STREAM))
+   (fetch (STREAM CHARPOSITION) of STREAM))
+
+(LISP:DEFUN WHITESPACE-CHAR-P (CH)
+   (LISP:MEMBER CH '(#\Tab #\Page #\Space #\Backspace #\Newline #\Linefeed)
+          :TEST
+          (FUNCTION EQL)))
+
+(LISP:DEFUN MAKE-PAD-SEGS (SPACES PADDINGS)
+
+   (* ;; "Given the total number of SPACES needed for padding, and the number of padding segments needed (PADDINGS) , returns a list of such segments.  We try to allocate the spaces equally to each segment.  When this is not possible, we allocate the left-over spaces randomly, to improve the appearance of many successive lines of justified text.")
+
+   (* ;; "Query: Is this right?  Perhaps consistency might be better for the kind of applications ~<~> is used for.")
+
+   (LISP:DO* ([EXTRA-SPACE NIL (AND (LISP:PLUSP EXTRA-SPACES)
+                                      (< (RAND 0 (FLOAT 1))
+                                         (/ SEGS EXTRA-SPACES]
+              (RESULT NIL (CONS (LISP:IF EXTRA-SPACE
+                                      (LISP:1+ MIN-SPACE)
+                                      MIN-SPACE)
+                                  RESULT))
+              (MIN-SPACE (LISP:TRUNCATE SPACES PADDINGS))
+              (EXTRA-SPACES (- SPACES (LISP:* PADDINGS MIN-SPACE))
+                     (LISP:IF EXTRA-SPACE
+                         (LISP:1- EXTRA-SPACES)
+                         EXTRA-SPACES))
+              (SEGS PADDINGS (LISP:1- SEGS)))
+             ((ZEROP SEGS)
+              RESULT)))
+
+(LISP:DEFUN FORMAT-LOGICAL-FILL (STRING STREAM START END FIRST?)
+
+   (* ;; "Output STRING's characters between START and END to STREAM; blank sequences in STRING are followed by fill-style conditional newlines.  If FIRST? is true, the last directive was a ~<NEWLINE> and doesn't get one.")
+
+   (LISP:DO ((CP START (LISP:INCF CP))
+             (C))
+            ((IGEQ CP END))
+       (IF (LISP:CHAR= (SETQ C (LISP:CHAR STRING CP))
+                      #\Space)
+           THEN 
+
+                 (* ;; "Look for the end of this run of spaces; when you find it or the end of the sequence, check FIRST? and do the newline.  Go to a little trouble to only look at things in string once.")
+
+                 (LISP:WRITE-CHAR #\Space STREAM)
+                 (LISP:INCF CP)
+                 (LISP:DO NIL
+                          ((OR (IGEQ CP END)
+                               (NOT (LISP:CHAR= (SETQ C (LISP:CHAR STRING CP))
+                                           #\Space)))
+                           (LISP:UNLESS FIRST? (XP:PPRINT-NEWLINE :FILL))
+                           (SETQ FIRST? NIL)
+                           (LISP:WHEN (NOT (LISP:CHAR= C #\Space))
+                                  (LISP:WRITE-CHAR C STREAM)))
+                     (LISP:WRITE-CHAR #\Space STREAM)
+                     (LISP:INCF CP))
+         ELSE (LISP:WRITE-CHAR C STREAM))))
+
+(DEFMACRO NAME-ARRAY (CONTENTS)
+   `(LISP:MAKE-ARRAY ,(LENGTH CONTENTS)
+           :ELEMENT-TYPE T :INITIAL-CONTENTS ',CONTENTS))
+
+(LISP:DEFVAR *FORMAT-ARGUMENTS* NIL
+   "List of FORMAT args yet unprocessed")
+
+(LISP:DEFVAR *OUTER-FORMAT-ARGUMENTS* NIL
+   "Bound by FORMAT-DO-ITERATION so FORMAT-ESCAPE can see if there are any arguments left outside the ones *FORMAT-ARGUMENTS* are bound to"
+)
+
+(LISP:DEFVAR *FORMAT-CONTROL-STRING* NIL
+   "Bound to FORMAT control string")
+
+(LISP:DEFVAR *FORMAT-DISPATCH-TABLE*
+   (MAKE-DISPATCH-VECTOR (#\B FORMAT-PRINT-BINARY)
+          (#\O FORMAT-PRINT-OCTAL)
+          (#\D FORMAT-PRINT-DECIMAL)
+          (#\X FORMAT-PRINT-HEXADECIMAL)
+          (#\R FORMAT-PRINT-RADIX)
+          (#\F FORMAT-FIXED)
+          (#\E FORMAT-EXPONENTIAL)
+          (#\G FORMAT-GENERAL-FLOAT)
+          (#\A FORMAT-PRINC)
+          (#\C FORMAT-PRINT-CHARACTER)
+          (#\P FORMAT-PLURAL)
+          (#\S FORMAT-PRIN1)
+          (#\T FORMAT-TAB)
+          (#\% FORMAT-TERPRI)
+          (#\& FORMAT-FRESHLINE)
+          (#\* FORMAT-SKIP-ARGUMENTS)
+          (#\| FORMAT-PAGE)
+          (#\~ FORMAT-TILDE)
+          (#\$ FORMAT-DOLLARS)
+          (#\? FORMAT-INDIRECTION)
+          (#\^ FORMAT-ESCAPE)
+          (#\; FORMAT-SEMICOLON-ERROR)
+          (#\[ FORMAT-CONDITION)
+          (#\{ FORMAT-ITERATION)
+          (#\< FORMAT-JUSTIFICATION)
+          (#\( FORMAT-CAPITALIZATION)
+          (#\Newline FORMAT-NEWLINE)
+          (#\W FORMAT-JUST-WRITE)
+          (#\_ FORMAT-PPRINT-NEWLINE)
+          (#\I FORMAT-PPRINT-INDENT)
+          (#\/ FORMAT-CALL-FUNCTION))
+   "Table of functions called by SUB-FORMAT to process ~foo stuff")
+
+(LISP:DEFVAR *FORMAT-INDEX* NIL
+   "Index into current control string")
+
+(LISP:DEFVAR *FORMAT-LENGTH* NIL
+   "Length of current control string")
+
+(LISP:DEFVAR *FORMAT-ORIGINAL-ARGUMENTS* NIL
+   "List of original FORMAT arguments")
+
+(LISP:DEFVAR *FORMAT-LOGICAL-BLOCK* NIL
+   "Bound to T under FORMAT-PPRINT-LOGICAL-BLOCK")
+
+(LISP:DEFVAR *FORMAT-JUSTIFICATION* NIL
+   "Bound to T under FORMAT-JUSTIFICATION")
+
+(LISP:DEFVAR *FORMAT-INCOMPATIBLE-JUSTIFICATION* NIL
+   "Bound by CL:FORMAT and FORMAT-INDIRECTION; set to :XP by ~_ and friends, set to :JUSTIFY by ~<...~:;...~>"
+)
+
+(LISP:DEFVAR *FORMAT-COLON-ITERATION* NIL
+   "Bound in FORMAT-DO-ITERATION to let FORMAT-ESCAPE know whether it is under a ~:{ or not")
+
+(LISP:DEFVAR CARDINAL-ONES (NAME-ARRAY (NIL "one" "two" "three" "four" "five" "six" "seven"
+                                                      "eight" "nine"))
+                               "Table of strings used by ~R")
+
+(LISP:DEFVAR CARDINAL-TENS (NAME-ARRAY (NIL NIL "twenty" "thirty" "forty" "fifty" "sixty"
+                                                      "seventy" "eighty" "ninety"))
+                               "Table of strings used by ~R")
+
+(LISP:DEFVAR CARDINAL-TEENS (NAME-ARRAY ("ten" "eleven" "twelve" "thirteen" "fourteen" 
+                                                       "fifteen" "sixteen" "seventeen" "eighteen" 
+                                                       "nineteen"))
+                                "Table of strings used by ~R")
+
+(LISP:DEFVAR CARDINAL-PERIODS
+   (NAME-ARRAY ("" " thousand" " million" " billion" " trillion" " quadrillion" " quintillion" 
+                       " sextillion" " septillion" " octillion" " nonillion" " decillion"))
+   "Table of strings used by ~R")
+
+(LISP:DEFVAR ORDINAL-ONES (NAME-ARRAY (NIL "first" "second" "third" "fourth" "fifth" 
+                                                     "sixth" "seventh" "eighth" "ninth"))
+                              "Table of strings used by ~R")
+
+(LISP:DEFVAR ORDINAL-TENS (NAME-ARRAY (NIL "tenth" "twentieth" "thirtieth" "fourtieth" 
+                                                     "fiftieth" "sixtieth" "seventieth" "eightieth" 
+                                                     "ninetieth"))
+                              "Table of strings used by ~R")
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA )
+)
+
+
+
+(* ;; "Arrange to use the correct compiler.")
+
+
+(PUTPROPS CMLFORMAT FILETYPE LISP:COMPILE-FILE)
+(PUTPROPS CMLFORMAT COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1991 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/CLTL2/CMLFORMAT.LCOM b/CLTL2/CMLFORMAT.LCOM
new file mode 100644
index 00000000..5f3fb20d
Binary files /dev/null and b/CLTL2/CMLFORMAT.LCOM differ
diff --git a/CLTL2/CMLHASH b/CLTL2/CMLHASH
new file mode 100644
index 00000000..61b5b759
--- /dev/null
+++ b/CLTL2/CMLHASH
@@ -0,0 +1,361 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
+(IL:FILECREATED " 2-Apr-92 13:37:38" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLHASH.;6| 16577  
+
+      IL:|changes| IL:|to:|  (IL:FUNCTIONS CL:WITH-HASH-TABLE-ITERATOR)
+                             (IL:VARS IL:CMLHASHCOMS)
+
+      IL:|previous| IL:|date:| " 1-Apr-92 13:16:01" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLHASH.;4|
+)
+
+
+; Copyright (c) 1985, 1986, 1987, 1989, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CMLHASHCOMS)
+
+(IL:RPAQQ IL:CMLHASHCOMS (
+                              (IL:* IL:|;;| "External interface")
+
+                              (IL:FUNCTIONS MAKE-HASH-TABLE GETHASH MAPHASH HASH-TABLE-COUNT 
+                                     HASH-TABLE-P SXHASH)
+                              (XCL:OPTIMIZERS GETHASH HASH-TABLE-COUNT HASH-TABLE-P)
+                              (IL:SETFS GETHASH)
+                              (IL:FUNCTIONS CL:HASH-TABLE-REHASH-SIZE CL:HASH-TABLE-REHASH-THRESHOLD
+                                     CL:HASH-TABLE-SIZE CL:HASH-TABLE-TEST 
+                                     CL:WITH-HASH-TABLE-ITERATOR)
+                              (XCL:OPTIMIZERS CL:HASH-TABLE-REHASH-SIZE CL:HASH-TABLE-SIZE 
+                                     CL:HASH-TABLE-TEST)
+                              
+                              (IL:* IL:|;;| "Internal interface")
+
+                              (IL:FUNCTIONS EQLHASHBITSFN SXHASH-PATHNAME)
+                              (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES SXHASH-MAX)
+                                     (IL:FUNCTIONS SXHASH-LIST SXHASH-STRING SXHASH-BIT-VECTOR 
+                                            SXHASH-ROT))
+                              
+                              (IL:* IL:|;;| "UFN for the SXHASH opcode (a MISCN)")
+
+                              (IL:FNS SXHASH-UFN EQLHASHBITSFN-UFN %SXHASH)
+                              (IL:FUNCTIONS CL::%SXHASH-EQUALP SXHASH-EQUALP-STRING)
+                              (XCL:OPTIMIZERS SXHASH EQLHASHBITSFN)
+                              (XCL:OPTIMIZERS IL:STRINGHASHBITS IL:STRING-EQUAL-HASHBITS)
+                              (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                                     IL:CMLHASH)))
+
+
+
+(IL:* IL:|;;| "External interface")
+
+
+(DEFUN MAKE-HASH-TABLE (&KEY (TEST 'EQL)
+                                 (SIZE 65)
+                                 REHASH-SIZE REHASH-THRESHOLD)
+                                                       (IL:* IL:\; "Edited 23-Mar-92 16:27 by jrb:")
+
+   (IL:* IL:|;;| "Creates and returns a hash table.  See manual for details.")
+
+   (IF (NOT (SYMBOLP TEST))
+       (COND
+          ((%EQCODEP TEST 'EQ)
+           (SETQ TEST 'EQ))
+          ((%EQCODEP TEST 'EQL)
+           (SETQ TEST 'EQL))
+          ((%EQCODEP TEST 'EQUAL)
+           (SETQ TEST 'EQUAL))
+          ((%EQCODEP TEST 'EQUALP)
+           (SETQ TEST 'EQUALP))))
+   (ECASE TEST
+       (EQ (IL:HASHARRAY SIZE REHASH-SIZE))
+       (EQL (IL:HASHARRAY SIZE REHASH-SIZE 'EQLHASHBITSFN 'EQL))
+       (EQUAL (IL:HASHARRAY SIZE REHASH-SIZE 'SXHASH 'EQUAL))
+       (EQUALP 
+
+          (IL:* IL:|;;| "NOTE: CL::%SXHASH-EQUALP has no microcode/C support and is hence SLOW")
+
+          (IL:HASHARRAY SIZE REHASH-SIZE 'CL::%SXHASH-EQUALP 'EQUALP))))
+
+(DEFUN GETHASH (KEY HASHTABLE &OPTIONAL DEFAULT)
+   (IL:GETHASH KEY HASHTABLE DEFAULT T))
+
+(DEFUN MAPHASH (FN HASH-TABLE)
+   "Call function with each key/value pair in the hash-table"
+   (IL:MAPHASH HASH-TABLE #'(LAMBDA (VALUE KEY)
+                                   (FUNCALL FN KEY VALUE)))
+   NIL)
+
+(DEFUN HASH-TABLE-COUNT (HASH-TABLE)
+   (IL:HARRAYPROP HASH-TABLE 'IL:NUMKEYS))
+
+(DEFUN HASH-TABLE-P (OBJECT)
+   (IL:TYPENAMEP OBJECT 'IL:HARRAYP))
+
+(DEFUN SXHASH (OBJECT)
+   (IL:MISCN SXHASH OBJECT))
+
+(XCL:DEFOPTIMIZER GETHASH (KEY HASHTABLE &OPTIONAL DEFAULT XCL:&CONTEXT CONTEXT)
+                              (IF (EQ 1 (COMPILER:CONTEXT-VALUES-USED CONTEXT))
+                                  (IF DEFAULT
+                                      `(IL:GETHASH ,KEY ,HASHTABLE ,DEFAULT)
+                                      `(IL:GETHASH ,KEY ,HASHTABLE))
+                                  'COMPILER:PASS))
+
+(XCL:DEFOPTIMIZER HASH-TABLE-COUNT (HASH-TABLE)
+                                       `(IL:HARRAYPROP ,HASH-TABLE 'IL:NUMKEYS))
+
+(XCL:DEFOPTIMIZER HASH-TABLE-P (OBJECT)
+                                   `(IL:TYPENAMEP ,OBJECT 'IL:HARRAYP))
+
+(DEFSETF GETHASH PUTHASH)
+
+(DEFUN CL:HASH-TABLE-REHASH-SIZE (HASH-TABLE)
+   (IL:HARRAYPROP HASH-TABLE 'IL:OVERFLOW))
+
+(DEFUN CL:HASH-TABLE-REHASH-THRESHOLD (HASH-TABLE)
+   1)
+
+(DEFUN CL:HASH-TABLE-SIZE (HASH-TABLE)
+   (IL:HARRAYSIZE HASH-TABLE))
+
+(DEFUN CL:HASH-TABLE-TEST (HASH-TABLE)         (IL:* IL:\; "Edited 22-Mar-92 20:47 by jrb:")
+   (LET ((CL::TEST (IL:HARRAYPROP HASH-TABLE 'IL:EQUIVFN)))
+        (CASE CL::TEST
+            ((NIL) 'EQ)
+            (T CL::TEST))))
+
+(DEFMACRO CL:WITH-HASH-TABLE-ITERATOR ((CL::MNAME HASH-TABLE)
+                                           &REST CL::FORMS)
+   (LET ((IL:HA (GENSYM))
+         (IL:LASTSLOT (GENSYM))
+         (IL:NULLVALUE (GENSYM))
+         (IL:SLOT (GENSYM))
+         (IL:V (GENSYM)))
+
+        (IL:* IL:|;;| "The code below is actually this stuff, macroexpanded to remove references to the IL:HARRAYP record and all the grossly internal stuff in it, which aren't normally in the sysout")
+
+        (IL:* IL:|;;| "`(LET* ((,IL:HA (IL:\\\\DTEST ,HASH-TABLE 'IL:HARRAYP)) (,IL:LASTSLOT (IL:|fetch| (IL:HASHSLOT IL:NEXTSLOT) IL:|of| (IL:\\\\HASHSLOT (IL:|fetch| IL:HARRAYPBASE IL:|of| ,IL:HA) (IL:|fetch| (IL:HARRAYP IL:LASTINDEX) IL:|of| ,IL:HA)))) (,IL:NULLVALUE IL:\\\\HASH.NULL.VALUE) ,IL:SLOT ,IL:V) (FLET ((,MNAME ( (IL:|until| (EQ (IL:SETQ ,IL:SLOT (IF ,IL:SLOT (IL:|fetch| (IL:HASHSLOT IL:NEXTSLOT) IL:|of| ,IL:SLOT) (IL:|fetch| IL:HARRAYPBASE IL:|of| ,IL:HA))) ,IL:LASTSLOT) IL:|when| (IL:SETQ ,IL:V (IL:|fetch| (IL:HASHSLOT IL:VALUE) IL:|of| ,IL:SLOT)) IL:|do| (RETURN (VALUES T (IL:|fetch| (IL:HASHSLOT IL:KEY) IL:|of| ,IL:SLOT) (AND (IL:NEQ ,IL:V ,IL:NULLVALUE) ,IL:V))) IL:|finally| (RETURN NIL)))) ,@FORMS))")
+
+        `(LET* ((,IL:HA (IL:\\DTEST ,HASH-TABLE 'IL:HARRAYP))
+                (,IL:LASTSLOT (IL:\\ADDBASE (IL:\\ADDBASE (IL:FETCHFIELD '(IL:HARRAYP 2 IL:POINTER)
+                                                                 ,IL:HA)
+                                                   (IL:LLSH (IL:FETCHFIELD '(IL:HARRAYP 1
+                                                                                   (IL:BITS . 15))
+                                                                   ,IL:HA)
+                                                          2))
+                                     4))
+                (,IL:NULLVALUE IL:\\HASH.NULL.VALUE)
+                ,IL:SLOT
+                ,IL:V)
+               (FLET ((,CL::MNAME NIL (IL:|until| (EQ (IL:SETQ ,IL:SLOT
+                                                           (IF ,IL:SLOT
+                                                               (IL:\\ADDBASE ,IL:SLOT 4)
+                                                               (IL:FETCHFIELD '(IL:HARRAYP 2 
+                                                                                      IL:POINTER)
+                                                                      ,IL:HA)))
+                                                          ,IL:LASTSLOT)
+                                         IL:|when| (IL:SETQ ,IL:V (IL:FETCHFIELD
+                                                                       '(NIL 2 IL:POINTER)
+                                                                       ,IL:SLOT))
+                                         IL:|do| (RETURN (VALUES T (IL:FETCHFIELD
+                                                                        '(NIL 0 IL:POINTER)
+                                                                        ,IL:SLOT)
+                                                                    (AND (IL:NEQ ,IL:V ,IL:NULLVALUE)
+                                                                         ,IL:V)))
+                                         IL:|finally| (RETURN NIL))))
+                     ,@CL::FORMS))))
+
+(XCL:DEFOPTIMIZER CL:HASH-TABLE-REHASH-SIZE (HASH-TABLE)
+                                                `(IL:HARRAYPROP ,HASH-TABLE 'IL:OVERFLOW))
+
+(XCL:DEFOPTIMIZER CL:HASH-TABLE-SIZE (HASH-TABLE)
+                                         `(IL:HARRAYSIZE ,HASH-TABLE))
+
+(XCL:DEFOPTIMIZER CL:HASH-TABLE-TEST (HASH-TABLE)
+                                         `(LET ((CL::TEST (IL:HARRAYPROP ,HASH-TABLE 'IL:EQUIVFN)))
+                                               (CASE CL::TEST
+                                                   ((NIL) 'EQ)
+                                                   (T CL::TEST))))
+
+
+
+(IL:* IL:|;;| "Internal interface")
+
+
+(DEFUN EQLHASHBITSFN (OBJ)
+   (IL:MISCN EQLHASHBITSFN OBJ))
+
+(DEFUN SXHASH-PATHNAME (PATHNAME)
+   (LET ((HASH (SXHASH-ROT (LOGXOR (%SXHASH (IL:%PATHNAME-HOST PATHNAME))
+                                      (%SXHASH (IL:%PATHNAME-DEVICE PATHNAME))))))
+        (SETQ HASH (SXHASH-ROT (LOGXOR HASH (%SXHASH (IL:%PATHNAME-TYPE PATHNAME)))))
+        (SETQ HASH (SXHASH-ROT (LOGXOR HASH (%SXHASH (IL:%PATHNAME-VERSION PATHNAME)))))
+        (SETQ HASH (SXHASH-ROT (LOGXOR HASH (%SXHASH (IL:%PATHNAME-DIRECTORY PATHNAME)))))
+        (SETQ HASH (SXHASH-ROT (LOGXOR HASH (%SXHASH (IL:%PATHNAME-NAME PATHNAME)))))))
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFCONSTANT SXHASH-MAX 13)
+
+
+(DEFMACRO SXHASH-LIST (LIST)
+   `(DO ((LIST ,LIST (CDR LIST))
+         (INDEX 0 (1+ INDEX))
+         (HASH 0))
+        ((OR (NOT (CONSP LIST))
+             (EQ INDEX SXHASH-MAX))
+         HASH)
+      (SETQ HASH (SXHASH-ROT (LOGXOR HASH (%SXHASH (CAR LIST)))))))
+
+(DEFMACRO SXHASH-STRING (STRING)                         (IL:* IL:\; 
+                                                         "Returns hash value for a general string.")
+   `(DO ((I 0 (1+ I))
+         (LENGTH (MIN (LENGTH ,STRING)
+                      SXHASH-MAX))
+         (HASH 0))
+        ((EQ I LENGTH)
+         HASH)
+
+      (IL:* IL:|;;| "the spice code had a fairly general \"rotate X within integerlength of most-positive-fixnum bits, but (a) it was slow and (b) it was buggy anyway, since it assumed that most-positive-fixnum was 1 less than a power of two.")
+
+      (SETQ HASH (SXHASH-ROT (LOGXOR HASH (CHAR-INT (AREF ,STRING I)))))))
+
+(DEFMACRO SXHASH-BIT-VECTOR (BIT-VECTOR)
+   `(DO ((I 0 (1+ I))
+         (LENGTH (MIN (LENGTH ,BIT-VECTOR)
+                      16))
+         (HASH 0))
+        ((EQ I LENGTH)
+         HASH)
+      (SETQ HASH (+ (ASH HASH 1)
+                    (AREF ,BIT-VECTOR I)))))
+
+(DEFMACRO SXHASH-ROT (X)
+   `(LET ((X ,X))
+         (DPB X (BYTE 9 7)
+              (LDB (BYTE 7 9)
+                   X))))
+)
+
+
+
+(IL:* IL:|;;| "UFN for the SXHASH opcode (a MISCN)")
+
+(IL:DEFINEQ
+
+(SXHASH-UFN
+  (IL:LAMBDA (IL:INDEX IL:ARGCOUNT IL:ARG-PTR)      (IL:* IL:\; "Edited 23-Feb-89 19:45 by jds")
+
+    (IL:* IL:|;;| 
+  "This is the UFN for the CL:SXHASH MISCN sub-opcode.  That MISCN is being implemented on Suns.")
+
+    (%SXHASH (IL:\\GETBASEPTR IL:ARG-PTR 0))))
+
+(EQLHASHBITSFN-UFN
+  (IL:LAMBDA (IL:INDEX IL:ARGCOUNT IL:ARG-PTR)      (IL:* IL:\; "Edited 23-Feb-89 18:10 by jds")
+    (LET ((OBJ (IL:\\GETBASEPTR IL:ARG-PTR 0)))
+         (TYPECASE OBJ
+             (CHARACTER (CHAR-INT OBJ))
+             (INTEGER (LOGAND OBJ 65535))
+             (FLOAT (LOGXOR (IL:|fetch| (IL:FLOATP IL:HIWORD) IL:|of| OBJ)
+                           (IL:|fetch| (IL:FLOATP IL:LOWORD) IL:|of| OBJ)))
+             (RATIO (LOGXOR (EQLHASHBITSFN (NUMERATOR OBJ))
+                           (EQLHASHBITSFN (DENOMINATOR OBJ))))
+             (COMPLEX (LOGXOR (EQLHASHBITSFN (REALPART OBJ))
+                             (EQLHASHBITSFN (IMAGPART OBJ))))
+             (T (IL:\\EQHASHINGBITS OBJ))))))
+
+(%SXHASH
+  (IL:LAMBDA (OBJECT)                               (IL:* IL:\; "Edited 23-Feb-89 19:42 by jds")
+    (COND
+       ((SYMBOLP OBJECT)
+        (IL:\\EQHASHINGBITS OBJECT))
+       ((LISTP OBJECT)
+        (SXHASH-LIST OBJECT))
+       ((NUMBERP OBJECT)
+        (TYPECASE OBJECT
+            (INTEGER (LOGAND OBJECT MOST-POSITIVE-FIXNUM))
+            (FLOAT (LOGXOR (IL:|fetch| (IL:FLOATP IL:HIWORD) IL:|of| OBJECT)
+                          (IL:|fetch| (IL:FLOATP IL:LOWORD) IL:|of| OBJECT)))
+            (RATIO (LOGXOR (%SXHASH (NUMERATOR OBJECT))
+                          (%SXHASH (DENOMINATOR OBJECT))))
+            (COMPLEX (LOGXOR (%SXHASH (REALPART OBJECT))
+                            (%SXHASH (IMAGPART OBJECT))))))
+       ((STRINGP OBJECT)
+        (SXHASH-STRING OBJECT))
+       ((BIT-VECTOR-P OBJECT)
+        (SXHASH-BIT-VECTOR OBJECT))
+       ((PATHNAMEP OBJECT)
+        (SXHASH-PATHNAME OBJECT))
+       (T (IL:\\EQHASHINGBITS OBJECT)))))
+)
+
+(DEFUN CL::%SXHASH-EQUALP (CL::OBJECT)         (IL:* IL:\; "Edited 23-Mar-92 16:17 by jrb:")
+   (COND
+      ((SYMBOLP CL::OBJECT)
+       (IL:\\EQHASHINGBITS CL::OBJECT))
+      ((LISTP CL::OBJECT)
+       (SXHASH-LIST CL::OBJECT))
+      ((NUMBERP CL::OBJECT)
+
+       (IL:* IL:|;;| "Hacks for numbers for hash key purposes:")
+
+       (IL:* IL:|;;| "FLOATs that can be coerced to integer are")
+
+       (IL:* IL:|;;| "RATIOs are coerecd to floats (it would be better to coerce non-integral FLOATs to RATIOs, but a real pain in the ass; this is probably good enough...)")
+
+       (TYPECASE CL::OBJECT
+           (INTEGER (LOGAND CL::OBJECT MOST-POSITIVE-FIXNUM))
+           (FLOAT (IF (= CL::OBJECT (FLOOR CL::OBJECT))
+                      (MULTIPLE-VALUE-BIND (CL::MANT EXP CL::SIGN)
+                             (INTEGER-DECODE-FLOAT CL::OBJECT)
+                             (SETQ CL::OBJECT (ASH CL::MANT EXP))
+                             (WHEN (MINUSP CL::SIGN)
+                                 (SETQ CL::OBJECT (IL:IMINUS CL::OBJECT)))
+                             (LOGAND CL::OBJECT MOST-POSITIVE-FIXNUM))
+                      (LOGXOR (IL:|fetch| (IL:FLOATP IL:HIWORD) IL:|of| CL::OBJECT)
+                             (IL:|fetch| (IL:FLOATP IL:LOWORD) IL:|of| CL::OBJECT))))
+           (RATIO (LET ((CL::F (COERCE CL::OBJECT 'FLOAT)))
+                       (LOGXOR (IL:|fetch| (IL:FLOATP IL:HIWORD) IL:|of| CL::F)
+                              (IL:|fetch| (IL:FLOATP IL:LOWORD) IL:|of| CL::F))))
+           (COMPLEX (LOGXOR (%SXHASH (REALPART CL::OBJECT))
+                           (%SXHASH (IMAGPART CL::OBJECT))))))
+      ((STRINGP CL::OBJECT)
+       (SXHASH-EQUALP-STRING CL::OBJECT))
+      ((BIT-VECTOR-P CL::OBJECT)
+       (SXHASH-BIT-VECTOR CL::OBJECT))
+      ((PATHNAMEP CL::OBJECT)
+       (SXHASH-PATHNAME CL::OBJECT))
+      (T (IL:\\EQHASHINGBITS CL::OBJECT))))
+
+(DEFMACRO SXHASH-EQUALP-STRING (STRING)
+
+   (IL:* IL:|;;| "Returns EQUALP hash value for a string")
+
+   `(DO ((I 0 (1+ I))
+         (LENGTH (MIN (LENGTH ,STRING)
+                      SXHASH-MAX))
+         (HASH 0))
+        ((EQ I LENGTH)
+         HASH)
+
+      (IL:* IL:|;;| "the spice code had a fairly general \"rotate X within integerlength of most-positive-fixnum bits, but (a) it was slow and (b) it was buggy anyway, since it assumed that most-positive-fixnum was 1 less than a power of two.")
+
+      (SETQ HASH (SXHASH-ROT (LOGXOR HASH (IL:%CHAR-UPCASE-CODE (CHAR-CODE (AREF ,STRING I))))))))
+
+(XCL:DEFOPTIMIZER SXHASH (OBJECT)
+                             `(IL:MISCN SXHASH ,OBJECT))
+
+(XCL:DEFOPTIMIZER EQLHASHBITSFN (OBJECT)
+                                    `(IL:MISCN EQLHASHBITSFN ,OBJECT))
+
+(XCL:DEFOPTIMIZER IL:STRINGHASHBITS (STRING)
+                                        `(IL:MISCN IL:STRINGHASHBITS ,STRING))
+
+(XCL:DEFOPTIMIZER IL:STRING-EQUAL-HASHBITS (STRING)
+                                               `(IL:MISCN IL:STRING-EQUAL-HASHBITS ,STRING))
+
+(IL:PUTPROPS IL:CMLHASH IL:FILETYPE COMPILE-FILE)
+
+(IL:PUTPROPS IL:CMLHASH IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
+(IL:PUTPROPS IL:CMLHASH IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1989 1990 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL (11187 13240 (SXHASH-UFN 11200 . 11499) (EQLHASHBITSFN-UFN 11501 . 12240) (%SXHASH 
+12242 . 13238)))))
+IL:STOP
diff --git a/CLTL2/CMLHASH.LCOM b/CLTL2/CMLHASH.LCOM
new file mode 100644
index 00000000..3f7a2117
Binary files /dev/null and b/CLTL2/CMLHASH.LCOM differ
diff --git a/CLTL2/CMLLOAD b/CLTL2/CMLLOAD
new file mode 100644
index 00000000..10faf3a9
--- /dev/null
+++ b/CLTL2/CMLLOAD
@@ -0,0 +1,128 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+(FILECREATED "18-Oct-93 14:18:07" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLLOAD.;2" 6602   
+
+      |previous| |date:| "15-Dec-92 21:27:17" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLLOAD.;1")
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT CMLLOADCOMS)
+
+(RPAQQ CMLLOADCOMS ((VARIABLES LISP:*LOAD-PRINT* *LOAD-VERBOSE* LISP:*LOAD-PATHNAME* 
+                               LISP:*LOAD-TRUENAME* XCL::*DEFAULT-SOURCE-IO-PACKAGE*)
+                        (FUNCTIONS LISP::DEFAULT-IO-PACKAGE LISP:LOAD LISP::\\OPENSTREAM-WITH-DEFAULT
+                               )
+                        (FNS \\CML-LOAD)
+                        (PROP FILETYPE CMLLOAD)))
+
+(LISP:DEFVAR LISP:*LOAD-PRINT* NIL
+   "Default value for :PRINT in LOAD")
+
+(LISP:DEFVAR *LOAD-VERBOSE* T
+   "Default for VERBOSE keyword to LOAD.")
+
+(LISP:DEFVAR LISP:*LOAD-PATHNAME* NIL
+   "LOAD binds this to the pathname of the file being loaded")
+
+(LISP:DEFVAR LISP:*LOAD-TRUENAME* NIL
+   "LOAD binds this to the truename of the file being loaded")
+
+(LISP:DEFVAR XCL::*DEFAULT-SOURCE-IO-PACKAGE* (LISP:FIND-PACKAGE "CL-USER"))
+
+(LISP:DEFUN LISP::DEFAULT-IO-PACKAGE (LISP::P)           (* \; "Edited 15-Dec-92 16:06 by jrb:")
+
+   (* |;;| "P is the argument given to the :PACKAGE keyword for any of the functions that get their package defaulted (CL:LOAD, CL:COMPILE-FILE).  The intent is that if P is supplied it is an absolute override; if not we fall back on CLtL2 if XCL:*CLTL2-PEDANTIC* is on; if that doesn't work we try XCL::*DEFAULT-SOURCE-IO-PACKAGE* and we punt if THAT loses.")
+
+   (COND
+      ((NULL LISP::P)
+       (COND
+          (*CLTL2-PEDANTIC* *PACKAGE*)
+          ((LISP:FIND-PACKAGE XCL::*DEFAULT-SOURCE-IO-PACKAGE*))
+          (T (LISP:CERROR "Use current *PACKAGE*" 
+                    "The value of XCL::*DEFAULT-SOURCE-IO-PACKAGE*, ~s, does not name a package" 
+                    XCL::*DEFAULT-SOURCE-IO-PACKAGE*)
+             *PACKAGE*)))
+      ((LISP:FIND-PACKAGE LISP::P))
+      (T (LISP:CERROR "Use current *PACKAGE*" "~s does not name a package" LISP::P)
+         *PACKAGE*)))
+
+(LISP:DEFUN LISP:LOAD (FILENAME &KEY ((:VERBOSE *LOAD-VERBOSE*)
+                                          *LOAD-VERBOSE*)
+                                 ((:PRINT LISP:*LOAD-PRINT*)
+                                  LISP:*LOAD-PRINT*)
+                                 (IF-DOES-NOT-EXIST :ERROR)
+                                 (LOADFLG NIL)
+                                 (PACKAGE NIL))            (* \; "Edited 15-Dec-92 16:06 by jrb:")
+   "Loads the file named by Filename into the Lisp environment."
+   (LET* ((LISP:*LOAD-PATHNAME* (LISP:IF (STREAMP FILENAME)
+                                    (IGNORE-ERRORS (PATHNAME FILENAME))
+
+                                 (* |;;| "If the current connected directory is \"{DSK}<tmp>\", (CL:LOAD \"{CORE}FOO\") should load \"{CORE}FOO\" rather than \"{CORE}<tmp>FOO\".  Thus we call MERGE-PATHNAMES iff HOST field is not specified in FILENAME. ")
+
+                                    (LISP:IF (LISP:IF (LISP:PATHNAMEP FILENAME)
+                                                 (LISP:PATHNAME-HOST FILENAME)
+                                                 (FILENAMEFIELD FILENAME 'HOST))
+                                        (PATHNAME FILENAME)
+                                        (LISP:MERGE-PATHNAMES (PATHNAME FILENAME)
+                                               *DEFAULT-PATHNAME-DEFAULTS*))))
+          (LISP:*LOAD-TRUENAME* (AND LISP:*LOAD-PATHNAME* (LISP:TRUENAME LISP:*LOAD-PATHNAME*)))
+          (STREAM (OR (STREAMP FILENAME)
+                      (|if| (NULL IF-DOES-NOT-EXIST)
+                          |then| (CONDITION-CASE (OPENSTREAM LISP:*LOAD-PATHNAME* 'INPUT
+                                                            'OLD LOADPARAMETERS)
+                                            (XCL:FILE-NOT-FOUND NIL 
+
+                                                   (* |;;| 
+                              "Spec says return NIL if file not found and IF-DOES-NOT-EXIST is NIL")
+
+                                                   (LISP:RETURN-FROM LISP:LOAD NIL)))
+                        |else| (OPENSTREAM LISP:*LOAD-PATHNAME* 'INPUT 'OLD LOADPARAMETERS)))))
+         (LISP:UNWIND-PROTECT
+             (\\LOAD-STREAM STREAM (LISP:INTERN (STRING LOADFLG)
+                                          (LISP:FIND-PACKAGE "INTERLISP"))
+                    LISP:*LOAD-PRINT*
+                    (AND *LOAD-VERBOSE* *TERMINAL-IO*)
+                    PACKAGE)
+             (LISP:CLOSE STREAM))))
+
+(LISP:DEFUN LISP::\\OPENSTREAM-WITH-DEFAULT (LISP::FILENAME)
+   (DECLARE (LISP:SPECIAL LOADPARAMATERS))
+
+   (* |;;| "If the current connected directory is \"{DSK}<tmp>\", (CL:LOAD \"{CORE}FOO\") should load \"{CORE}FOO\" rather than \"{CORE}<tmp>FOO\".  Thus we call MERGE-PATHNAMES iff HOST field is not specified in FILENAME. ")
+
+   (LISP:IF (NULL (LISP:IF (LISP:PATHNAMEP LISP::FILENAME)
+                      (LISP:PATHNAME-HOST LISP::FILENAME)
+                      (FILENAMEFIELD LISP::FILENAME 'HOST)))
+       (OPENSTREAM (LISP:MERGE-PATHNAMES (PATHNAME LISP::FILENAME)
+                          *DEFAULT-PATHNAME-DEFAULTS*)
+              'INPUT
+              'OLD LOADPARAMETERS)
+       (OPENSTREAM LISP::FILENAME 'INPUT 'OLD LOADPARAMETERS)))
+(DEFINEQ
+
+(\\CML-LOAD
+  (LAMBDA (STREAM PRINTFLG LOAD-VERBOSE-STREAM PACKAGE)      (* \; "Edited  1-Aug-91 10:57 by jrb:")
+
+    (* |;;| "Loads a \"Common Lisp file\" a la CL:LOAD.  Currently only do this if file starts with semi-colon.  PACKAGE overrides the default (USER).")
+
+    (LET ((*PACKAGE* PACKAGE)
+          (*READTABLE* CMLRDTBL)
+          (FULL (FULLNAME STREAM))
+          (EOF-MARK "EOF")
+          EXPR)
+         (|until| (EQ EOF-MARK (SETQ EXPR (LISP:READ STREAM NIL EOF-MARK)))
+            |do| (COND
+                        (PRINTFLG (PRINT (LISP:EVAL EXPR)
+                                         T))
+                        (T (LISP:EVAL EXPR))))
+         (|if| LOAD-VERBOSE-STREAM
+             |then| (LISP:FORMAT LOAD-VERBOSE-STREAM "; Finished loading ~A, ~D bytes read~&" 
+                               FULL (GETFILEPTR STREAM)))
+         FULL)))
+)
+
+(PUTPROPS CMLLOAD FILETYPE LISP:COMPILE-FILE)
+(PUTPROPS CMLLOAD COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 1993))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (5526 6430 (\\CML-LOAD 5536 . 6428)))))
+STOP
diff --git a/CLTL2/CMLLOAD.LCOM b/CLTL2/CMLLOAD.LCOM
new file mode 100644
index 00000000..2ae6c446
Binary files /dev/null and b/CLTL2/CMLLOAD.LCOM differ
diff --git a/CLTL2/CMLMACROS b/CLTL2/CMLMACROS
new file mode 100644
index 00000000..337744a7
--- /dev/null
+++ b/CLTL2/CMLMACROS
@@ -0,0 +1,253 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 14:19:04" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLMACROS.;2" 12700  
+
+      previous date%: "12-Jan-92 12:41:41" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLMACROS.;1")
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLMACROSCOMS)
+
+(RPAQQ CMLMACROSCOMS
+       [(FNS CLISPEXPANSION GLOBAL-MACRO-FUNCTION LOCAL-MACRO-FUNCTION LOCAL-SYMBOL-FUNCTION 
+             \INTERLISP-NLAMBDA-MACRO LISP:MACRO-FUNCTION LISP:MACROEXPAND LISP:MACROEXPAND-1 
+             SETF-MACRO-FUNCTION)
+        (APPENDVARS (COMPILERMACROPROPS DMACRO BYTEMACRO MACRO))
+        (ADDVARS (GLOBALVARS COMPILERMACROPROPS))
+        (PROP MACRO *)
+        (FUNCTIONS LISP:MACROLET)
+        (SETFS LISP:MACRO-FUNCTION)
+        (PROP FILETYPE CMLMACROS)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML)
+                                                                             (LAMA LISP:MACROEXPAND-1
+                                                                                   LISP:MACROEXPAND 
+                                                                                  LISP:MACRO-FUNCTION
+                                                                                   ])
+(DEFINEQ
+
+(CLISPEXPANSION
+  [LAMBDA (X ENV)                                            (* ; "Edited  4-Dec-86 01:19 by lmm")
+
+    (* ;; "the macro function for all CLISP words. Expand X as a clisp macro.")
+
+    (LISP:VALUES (do (LET ((NOSPELLFLG T)
+                               (LISPXHIST NIL)
+                               (VARS NIL)
+                               (COP (COPY X)))
+                              (DECLARE (LISP:SPECIAL NOSPELLFLG VARS LISPXHIST))
+                                                             (* ; 
+                                                        "make a copy so dwim doesn't muck with it!")
+                              [COND
+                                 ((GETPROP (CAR X)
+                                         'CLISPWORD)
+                                  (DWIMIFY0? COP COP COP NIL NIL NIL 'VARSBOUND)
+                                  (COND
+                                     ((NOT (LISP:EQUAL COP X))
+                                                             (* ; "made a change")
+                                      (RETURN COP))
+                                     ((SETQ COP (GETHASH COP CLISPARRAY))
+                                      (RETURN COP]
+                              (LISP:CERROR "Try expanding again." "Can't CLISP expand expression ~S."
+                                     X)))
+           T])
+
+(GLOBAL-MACRO-FUNCTION
+  [LAMBDA (X ENV)                                            (* ; "Edited 22-Apr-87 19:07 by Pavel")
+    (LET (MD)
+         (COND
+            [(AND (TYPEP ENV 'COMPILER:ENV)
+                  (LISP:MULTIPLE-VALUE-BIND (KIND EXPN-FN)
+                         (COMPILER:ENV-FBOUNDP ENV X)
+                         (AND (EQ KIND :MACRO)
+                              EXPN-FN]
+            ((GET X 'MACRO-FN))
+            ((LISP:SPECIAL-FORM-P X)
+             NIL)
+            [[AND [NOT (FMEMB (ARGTYPE X)
+                              '(0 2]
+                  (FIND PROP IN COMPILERMACROPROPS
+                     SUCHTHAT (AND (SETQ MD (GETPROP X PROP))
+                                       (NOT (OR (LITATOM MD)
+                                                (FMEMB (CAR MD)
+                                                       '(APPLY APPLY*]
+             `(LAMBDA (FORM ENV)
+                (MACROEXPANSION FORM ',MD]
+            ((AND (NOT (GETD X))
+                  (GETPROP X 'CLISPWORD))
+             (FUNCTION CLISPEXPANSION))
+            ((FMEMB (ARGTYPE X)
+                    '(1 3))
+             (FUNCTION \INTERLISP-NLAMBDA-MACRO])
+
+(LOCAL-MACRO-FUNCTION
+  [LAMBDA (X ENV)                                            (* ; "Edited 13-Apr-87 11:16 by Pavel")
+    (AND ENV (LISP:TYPECASE ENV
+                 (ENVIRONMENT                                (* ; "Interpreter's environments")
+                    (LET ((FN-DEFN (LISP:GETF (ENVIRONMENT-FUNCTIONS ENV)
+                                          X)))
+                         (AND FN-DEFN (EQ (CAR FN-DEFN)
+                                          :MACRO)
+                              (CDR FN-DEFN))))
+                 (COMPILER:ENV                               (* ; "Compiler's environments.")
+                    (LISP:MULTIPLE-VALUE-BIND (KIND EXPN-FN)
+                           (COMPILER:ENV-FBOUNDP ENV X :LEXICAL-ONLY T)
+                           (AND (EQ KIND :MACRO)
+                                EXPN-FN))))])
+
+(LOCAL-SYMBOL-FUNCTION
+  [LAMBDA (X ENV)                                            (* ; "Edited 31-Jul-87 18:06 by amd")
+    (AND ENV (LISP:TYPECASE ENV
+                 (ENVIRONMENT                                (* ; "Interpreter's environments")
+                    (LET ((FN-DEFN (LISP:GETF (ENVIRONMENT-FUNCTIONS ENV)
+                                          X)))
+                         (AND FN-DEFN (EQ (CAR FN-DEFN)
+                                          :FUNCTION)
+                              (CDR FN-DEFN))))
+                 (COMPILER:ENV                               (* ; "Compiler's environments.")
+                    (LISP:MULTIPLE-VALUE-BIND (KIND FN)
+                           (COMPILER:ENV-FBOUNDP ENV X :LEXICAL-ONLY T)
+                           (AND (EQ KIND :FUNCTION)
+                                FN))))])
+
+(\INTERLISP-NLAMBDA-MACRO
+  [LAMBDA (X ENV)                                            (* lmm " 7-May-86 17:24")
+    `(LISP:FUNCALL (FUNCTION ,(CAR X))
+            ,@(SELECTQ (ARGTYPE (CAR X))
+                  (1 (MAPCAR (CDR X)
+                            (FUNCTION KWOTE)))
+                  (3 (LIST (KWOTE (CDR X))))
+                  (SHOULDNT])
+
+(LISP:MACRO-FUNCTION
+  [LISP:LAMBDA (LISP::X LISP::ENV)                           (* ; "Edited 12-Jan-92 11:45 by bane")
+         (AND (LISP:SYMBOLP LISP::X)
+              (NOT (LOCAL-SYMBOL-FUNCTION LISP::X LISP::ENV))
+              (OR (LOCAL-MACRO-FUNCTION LISP::X LISP::ENV)
+                  (GLOBAL-MACRO-FUNCTION LISP::X LISP::ENV])
+
+(LISP:MACROEXPAND
+  [LISP:LAMBDA (LISP::FORM &OPTIONAL LISP::ENV)              (* ; "Edited 13-Feb-87 23:47 by Pavel")
+
+(* ;;; "If FORM is a macro call, then the form is expanded until the result is not a macro. Returns as multiple values, the form after any expansion has been done and T if expansion was done, or NIL otherwise. Env is the lexical environment to expand in, which defaults to the null environment.")
+
+         (PROG (LISP::FLAG)
+               (LISP:MULTIPLE-VALUE-SETQ (LISP::FORM LISP::FLAG)
+                      (LISP:MACROEXPAND-1 LISP::FORM LISP::ENV))
+               (LISP:UNLESS LISP::FLAG
+                   (RETURN (LISP:VALUES LISP::FORM NIL)))
+           LISP:LOOP
+               (LISP:MULTIPLE-VALUE-SETQ (LISP::FORM LISP::FLAG)
+                      (LISP:MACROEXPAND-1 LISP::FORM LISP::ENV))
+               (LISP:IF LISP::FLAG
+                   (GO LISP:LOOP)
+                   (RETURN (LISP:VALUES LISP::FORM T)))])
+
+(LISP:MACROEXPAND-1
+  [LISP:LAMBDA (LISP::FORM &OPTIONAL LISP::ENV)              (* ; "Edited 13-Feb-87 23:49 by Pavel")
+
+(* ;;; "If form is a macro, expands it once. Returns two values, the expanded form and a T-or-NIL flag indicating whether the form was, in fact, a macro. Env is the lexical environment to expand in, which defaults to the null environment.")
+
+         (COND
+            [(AND (LISP:CONSP LISP::FORM)
+                  (LISP:SYMBOLP (CAR LISP::FORM)))
+             (LET ((LISP::DEF (LISP:MACRO-FUNCTION (CAR LISP::FORM)
+                                     LISP::ENV)))
+                  (COND
+                     (LISP::DEF (LISP:IF [NOT (EQ LISP::FORM (LISP:SETQ LISP::FORM
+                                                                    (LISP:FUNCALL *MACROEXPAND-HOOK*
+                                                                           LISP::DEF LISP::FORM 
+                                                                           LISP::ENV]
+                                    (LISP:VALUES LISP::FORM T)
+                                    (LISP:VALUES LISP::FORM NIL)))
+                     (T (LISP:VALUES LISP::FORM NIL]
+            (T (LISP:VALUES LISP::FORM NIL])
+
+(SETF-MACRO-FUNCTION
+  [LAMBDA (X BODY)                                           (* ; "Edited 13-Feb-87 13:26 by Pavel")
+
+    (* ;; "the SETF function for MACRO-FUNCTION ")
+
+    (* ;; "NOTE: If you change this, be sure to change the undoable version on CMLUNDO!")
+
+    (PROG1 (LISP:SETF (GET X 'MACRO-FN)
+                  BODY)
+        (AND (GETD X)
+             (SELECTQ (ARGTYPE X)
+                 ((1 3)                                      (* ; 
+                                                         "Leave Interlisp nlambda definition alone")
+                      )
+                 (PUTD X NIL))))])
+)
+
+(APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO)
+
+(ADDTOVAR GLOBALVARS COMPILERMACROPROPS)
+
+(PUTPROPS * MACRO ((X . Y)
+                           'X))
+
+(DEFMACRO LISP:MACROLET (LISP::MACRODEFS &BODY LISP::BODY &ENVIRONMENT LISP::ENV)
+   (DECLARE (SPECVARS *BYTECOMPILER-IS-EXPANDING*))
+
+   (* ;; "This macro for the old interpreter and compiler only.  The new interpreter has a special-form definition.  When the new compiler is expanding, we simply return a disguised version of the form.")
+
+   [IF (AND *BYTECOMPILER-IS-EXPANDING* *BYTECOMPILER-OPTIMIZE-MACROLET*)
+       THEN (LET ((LISP::NEW-ENV (COMPILER::MAKE-CHILD-ENV LISP::ENV)))
+                     (DECLARE (LISP:SPECIAL *BC-MACRO-ENVIRONMENT*))
+                     [FOR LISP::FN IN LISP::MACRODEFS
+                        DO (COMPILER::ENV-BIND-FUNCTION LISP::NEW-ENV (CAR LISP::FN)
+                                      :MACRO
+                                      (COMPILER::CRACK-DEFMACRO (CONS 'DEFMACRO LISP::FN]
+                     (LISP:SETQ *BC-MACRO-ENVIRONMENT* LISP::NEW-ENV)
+                     (CONS 'LISP:LOCALLY LISP::BODY))
+     ELSEIF (TYPEP LISP::ENV 'COMPILER:ENV)
+       THEN `(SI::%%MACROLET ,LISP::MACRODEFS ,@LISP::BODY)
+     ELSE
+     (LET (LISP::NEW-ENV LISP::FUNCTIONS)
+
+          (* ;; 
+   "We parse and handle the declarations here, so they'll take effect in the new child environment")
+
+          (LISP:MULTIPLE-VALUE-BIND
+           (LISP::BODY LISP::SPECIALS)
+           (\REMOVE-DECLS LISP::BODY (LISP:SETQ LISP::NEW-ENV (\MAKE-CHILD-ENVIRONMENT LISP::ENV)))
+           (LISP:SETQ LISP::FUNCTIONS (ENVIRONMENT-FUNCTIONS LISP::NEW-ENV))
+           (FOR LISP::FN IN LISP::MACRODEFS
+              DO (LISP:SETQ LISP::FUNCTIONS
+                            (LIST* (CAR LISP::FN)
+                                   [CONS :MACRO `(LISP:LAMBDA (SI::$$MACRO-FORM 
+                                                                     SI::$$MACRO-ENVIRONMENT)
+                                                        (LISP:BLOCK ,(CAR LISP::FN)
+                                                            ,(PARSE-DEFMACRO (CADR LISP::FN)
+                                                                    'SI::$$MACRO-FORM
+                                                                    (CDDR LISP::FN)
+                                                                    (CAR LISP::FN)
+                                                                    NIL :ENVIRONMENT 
+                                                                    'SI::$$MACRO-ENVIRONMENT))]
+                                   LISP::FUNCTIONS)))
+           (LISP:SETF (ENVIRONMENT-FUNCTIONS LISP::NEW-ENV)
+                  LISP::FUNCTIONS)
+           (WALK-FORM (CONS 'LISP:LOCALLY LISP::BODY)
+                  :ENVIRONMENT LISP::NEW-ENV])
+
+(LISP:DEFSETF LISP:MACRO-FUNCTION SETF-MACRO-FUNCTION)
+
+(PUTPROPS CMLMACROS FILETYPE LISP:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA LISP:MACROEXPAND-1 LISP:MACROEXPAND LISP:MACRO-FUNCTION)
+)
+(PUTPROPS CMLMACROS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (1472 9378 (CLISPEXPANSION 1482 . 2890) (GLOBAL-MACRO-FUNCTION 2892 . 4085) (
+LOCAL-MACRO-FUNCTION 4087 . 4949) (LOCAL-SYMBOL-FUNCTION 4951 . 5808) (\INTERLISP-NLAMBDA-MACRO 5810
+ . 6169) (LISP:MACRO-FUNCTION 6171 . 6530) (LISP:MACROEXPAND 6532 . 7504) (LISP:MACROEXPAND-1 7506 . 
+8736) (SETF-MACRO-FUNCTION 8738 . 9376)))))
+STOP
diff --git a/CLTL2/CMLMACROS.LCOM b/CLTL2/CMLMACROS.LCOM
new file mode 100644
index 00000000..70f1ce34
Binary files /dev/null and b/CLTL2/CMLMACROS.LCOM differ
diff --git a/CLTL2/CMLMISCIO b/CLTL2/CMLMISCIO
new file mode 100644
index 00000000..06c9a028
--- /dev/null
+++ b/CLTL2/CMLMISCIO
@@ -0,0 +1,163 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+(FILECREATED "18-Oct-93 14:20:56" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLMISCIO.;2" 6473   
+
+      |previous| |date:| "25-Oct-91 22:41:18" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLMISCIO.;1"
+)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT CMLMISCIOCOMS)
+
+(RPAQQ CMLMISCIOCOMS
+       (
+        (* |;;| "Random leftover IO functions")
+
+        
+        (* |;;| "[JDS 2/3/88: Removed FRESH-LINE from here, since it's also in CMLPRINT. AR #9601]")
+
+        (FUNCTIONS LISP:Y-OR-N-P LISP:YES-OR-NO-P)
+        
+        (* |;;| "JRB - stuff that handles CL:*PRINT-READABLY*")
+
+        (FUNCTIONS HANDLE-PRINT-READABLY LISP::CHECK-READABLY)
+        (FUNCTIONS LISP:PRINT-UNREADABLE-OBJECT LISP:WITH-STANDARD-IO-SYNTAX)
+        
+        (* |;;| "Arrange to use the proper compiler")
+
+        (PROP FILETYPE CMLMISCIO)))
+
+
+
+(* |;;| "Random leftover IO functions")
+
+
+
+
+(* |;;| "[JDS 2/3/88: Removed FRESH-LINE from here, since it's also in CMLPRINT. AR #9601]")
+
+
+(LISP:DEFUN LISP:Y-OR-N-P (&OPTIONAL FORMAT-STRING &REST ARGUMENTS)
+   (COND
+      (FORMAT-STRING (LISP:FRESH-LINE)
+             (LISP:APPLY (FUNCTION LISP:FORMAT)
+                    *QUERY-IO* FORMAT-STRING ARGUMENTS)))
+   (LISP:FLET ((LISP::READ-CHAR-NOW NIL (RESETFORM (CONTROL T)
+                                                 (LISP:READ-CHAR *QUERY-IO*))))
+          (LISP:DO ((LISP::RESPONSE (LISP::READ-CHAR-NOW)
+                           (LISP::READ-CHAR-NOW)))
+                   ((OR (LISP:CHAR-EQUAL LISP::RESPONSE #\Y)
+                        (LISP:CHAR-EQUAL LISP::RESPONSE #\N))
+                    (LISP:FRESH-LINE)
+                    (LISP:CHAR-EQUAL LISP::RESPONSE #\Y))
+              (LISP:FORMAT *QUERY-IO* "~&Please type either Y or N: "))))
+
+(LISP:DEFUN LISP:YES-OR-NO-P (&OPTIONAL LISP::FORMAT-STRING &REST LISP::ARGUMENTS)
+   (LISP:WHEN LISP::FORMAT-STRING
+       (LISP:FRESH-LINE *QUERY-IO*)
+       (LISP:APPLY #'LISP:FORMAT *QUERY-IO* LISP::FORMAT-STRING LISP::ARGUMENTS))
+   (LISP:DO ((LISP::RESPONSE (LISP:READ-LINE *QUERY-IO*)
+                    (LISP:READ-LINE *QUERY-IO*)))
+            ((OR (STRING-EQUAL LISP::RESPONSE "YES")
+                 (STRING-EQUAL LISP::RESPONSE "NO"))
+             (STRING-EQUAL LISP::RESPONSE "YES"))
+       (LISP:FORMAT *QUERY-IO* "Please type either YES or NO: ")))
+
+
+
+(* |;;| "JRB - stuff that handles CL:*PRINT-READABLY*")
+
+
+(LISP:DEFUN HANDLE-PRINT-READABLY ()
+
+   (* |;;| "Strategy: when *PRINT-READABLY* is on, all CL top-level printing functions go through a function that rebinds all the printer control variables (like WRITE or WRITE-TO-STRING).  Calling HANDLE-PRINT-READABLY sets the control variables so output is printed readably; it also sets *PRINT-READABLY* to a magic value so functions like FORMAT and WRITE-STRING will know it's OK to write constant strings without munging them.")
+
+   (SETQ *PRINT-ESCAPE* T)
+   (SETQ *PRINT-LEVEL* NIL)
+   (SETQ *PRINT-LENGTH* NIL)
+   (SETQ *PRINT-GENSYM* T)
+   (SETQ *PRINT-ARRAY* T)
+   (SETQ *PRINT-CIRCLE* T)
+   (SETQ XCL:*PRINT-STRUCTURE* T)
+   (SETQ LISP:*PRINT-READABLY* 'XCL::PRINTING-READABLY))
+
+(LISP:DEFUN LISP::CHECK-READABLY (XCL::THING &OPTIONAL LISP::WHERE)
+   (LISP:WHEN LISP:*PRINT-READABLY*
+       (LET (LISP:*PRINT-READABLY*)
+            (CONDITIONS:RESTART-CASE (LISP:ERROR 'LISP::PRINT-NOT-READABLE :THING XCL::THING :WHERE 
+                                            LISP::WHERE)
+                   (XCL::PRINT-IT-ANYWAY NIL :REPORT (LISP:LAMBDA (STREAM)
+                                                              (LISP:PRINC "Print it anyway " STREAM))
+                          :FILTER
+                          (LISP:LAMBDA NIL (TYPEP XCL:*CURRENT-CONDITION* 
+                                                    'LISP::PRINT-NOT-READABLE)))))))
+
+(DEFMACRO LISP:PRINT-UNREADABLE-OBJECT ((LISP::OBJECT STREAM &KEY TYPE LISP:IDENTITY)
+                                            &BODY LISP::BODY)
+   (LET ((LISP::O (LISP:GENSYM))
+         (LISP::S (LISP:GENSYM))
+         (LISP::SPACE? (LISP:GENSYM)))
+        `(LET ((,LISP::O ,LISP::OBJECT)
+               (,LISP::S ,STREAM)
+               ,LISP::SPACE?)
+              (LISP::CHECK-READABLY ,LISP::O)
+              (WRITE-STRING* "#<" ,LISP::S)
+              ,@(LISP:WHEN TYPE
+                    `((LISP:WHEN ,TYPE
+                          (LISP:SETQ ,LISP::SPACE? T)
+                          (WRITE (LISP:TYPE-OF ,LISP::O)
+                                 ,LISP::S))))
+              ,@(LISP:WHEN LISP::BODY
+                    `((LISP:WHEN ,LISP::SPACE?
+                          (LISP:WRITE-CHAR #\Space ,LISP::S))
+                      (PROGN ,@LISP::BODY (LISP:SETQ ,LISP::SPACE? T))))
+              ,@(LISP:WHEN LISP:IDENTITY
+                    `((LISP:WHEN ,LISP:IDENTITY
+                          (LISP:WHEN ,LISP::SPACE?
+                              (LISP:WRITE-CHAR #\Space ,LISP::S))
+                          (WRITE-STRING* "@ " ,LISP::S)
+                          (\\PRINTADDR ,LISP::O ,LISP::S))))
+              (LISP:WRITE-CHAR #\> ,LISP::S)
+              NIL)))
+
+(DEFMACRO LISP:WITH-STANDARD-IO-SYNTAX (&BODY LISP::BODY)
+   `(LET ((*PACKAGE* (LISP:FIND-PACKAGE "COMMON-LISP-USER"))
+          (*PRINT-ARRAY* T)
+          (*PRINT-BASE* 10)
+          (*PRINT-CASE* :UPCASE)
+          (*PRINT-CIRCLE* NIL)
+          (*PRINT-ESCAPE* T)
+          (*PRINT-GENSYM* T)
+          (*PRINT-LENGTH* NIL)
+          (*PRINT-LEVEL* NIL)
+          (*PRINT-PRETTY* NIL)
+          (*PRINT-RADIX* NIL)
+          (LISP:*PRINT-READABLY* T)
+          (*READ-BASE* 10)
+          (*READ-DEFAULT-FLOAT-FORMAT* 'LISP:SINGLE-FLOAT)
+          (LISP:*READ-EVAL* T)
+          (*READ-SUPPRESS* NIL)
+          (*READTABLE* (FIND-READTABLE "LISP"))
+
+          (* |;;| "XP-specific variables")
+
+          (XP:*PRINT-LINES* NIL)
+          (XP:*PRINT-MISER-WIDTH* NIL)
+          (XP:*PRINT-PPRINT-DISPATCH* NIL)
+          (XP:*PRINT-RIGHT-MARGIN* NIL)
+
+          (* |;;| "XCL-specific variables")
+
+          (XCL:*PRINT-STRUCTURE* T))
+         ,@LISP::BODY))
+
+
+
+(* |;;| "Arrange to use the proper compiler")
+
+
+(PUTPROPS CMLMISCIO FILETYPE LISP:COMPILE-FILE)
+(PUTPROPS CMLMISCIO COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1993))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/CLTL2/CMLMISCIO.LCOM b/CLTL2/CMLMISCIO.LCOM
new file mode 100644
index 00000000..9ddae767
Binary files /dev/null and b/CLTL2/CMLMISCIO.LCOM differ
diff --git a/CLTL2/CMLMODULES b/CLTL2/CMLMODULES
new file mode 100644
index 00000000..69f80abd
--- /dev/null
+++ b/CLTL2/CMLMODULES
@@ -0,0 +1,26 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
+(IL:FILECREATED "22-May-91 09:10:07" IL:|{DSK}<new>sources>lispcore>sources>CMLMODULES.;2| 2865   
+
+      IL:|previous| IL:|date:| "12-Jun-90 16:56:18" 
+IL:|{DSK}<new>sources>lispcore>sources>CMLMODULES.;1|)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CMLMODULESCOMS)
+
+(IL:RPAQQ IL:CMLMODULESCOMS ((IL:VARIABLES *MODULES*) (IL:FUNCTIONS PROVIDE REQUIRE) (IL:PROP IL:FILETYPE IL:CMLMODULES) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:CMLMODULES)))
+
+(DEFVAR *MODULES* NIL "A list of all modules currently provided to the system.")
+
+(DEFUN PROVIDE (MODULE-NAME) "Declare that module-name is provided to the system." (DECLARE (SPECIAL *MODULES*)) (IF (SYMBOLP MODULE-NAME) (SETQ MODULE-NAME (SYMBOL-NAME MODULE-NAME))) (PUSHNEW MODULE-NAME *MODULES* :TEST (FUNCTION STRING=)) MODULE-NAME)
+
+(DEFUN REQUIRE (MODULE-NAME &OPTIONAL (PATHNAME NIL)) "Declare that module-name is needed.  If already loaded do nothing.  If not, load using the pathname, which is a single pathname or list of pathnames.  If pathname is not provided use the system default paths (*default-pathname-defaults* and directories)." (DECLARE (SPECIAL *MODULES* *DEFAULT-PATHNAME-DEFAULTS* IL:DIRECTORIES IL:*COMPILED-EXTENSIONS*)) (UNLESS (MEMBER MODULE-NAME *MODULES* :TEST (FUNCTION STRING=)) (LET (PATHNAMES) (LABELS ((TRY (PATHNAME) (OR (IL:* IL:\; "first look for a compiled file") (TRY-MANY PATHNAME IL:*COMPILED-EXTENSIONS*) (IL:* IL:\; "then for a source file") (TRY-MANY PATHNAME (LIST NIL)) (CERROR "Don't load file ~S~*." "Can't find file ~S for required module ~S." PATHNAME MODULE-NAME))) (TRY-MANY (PATHNAME TYPES) (IL:* IL:|;;| "look first on connected directory, then IL:DIRECTORIES") (DOLIST (DIRECTORY (CONS *DEFAULT-PATHNAME-DEFAULTS* IL:DIRECTORIES)) (DOLIST (TYPE TYPES) (WHEN (TRY-ONE (MERGE-PATHNAMES PATHNAME (MAKE-PATHNAME :TYPE TYPE :DEFAULTS DIRECTORY))) (RETURN-FROM TRY-MANY T))))) (TRY-ONE (PATHNAME) (IL:* IL:|;;| "don't try any pathname more than once") (UNLESS (MEMBER PATHNAME PATHNAMES :TEST (QUOTE EQUAL)) (PUSH PATHNAME PATHNAMES) (WHEN (PROBE-FILE PATHNAME) (UNLESS (FIND (IL:PACKFILENAME (QUOTE IL:DIRECTORY) (FORMAT NIL "{~a}~a" (PATHNAME-HOST PATHNAME) (PATHNAME-DIRECTORY PATHNAME)) (QUOTE IL:BODY) (PATHNAME-NAME PATHNAME) (QUOTE IL:VERSION) (PATHNAME-VERSION PATHNAME)) IL:LOADEDFILELST) (LOAD PATHNAME)) T)))) (DOLIST (PATHNAME (ETYPECASE PATHNAME (NULL (LIST MODULE-NAME)) ((OR SYMBOL STRING PATHNAME) (LIST PATHNAME)) (LIST PATHNAME)) T) (TRY PATHNAME))))))
+
+(IL:PUTPROPS IL:CMLMODULES IL:FILETYPE :COMPILE-FILE)
+
+(IL:PUTPROPS IL:CMLMODULES IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
+(IL:PUTPROPS IL:CMLMODULES IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/CMLMODULES.DFASL b/CLTL2/CMLMODULES.DFASL
new file mode 100644
index 00000000..f1a916ab
Binary files /dev/null and b/CLTL2/CMLMODULES.DFASL differ
diff --git a/CLTL2/CMLMVS b/CLTL2/CMLMVS
new file mode 100644
index 00000000..7ff68aed
--- /dev/null
+++ b/CLTL2/CMLMVS
@@ -0,0 +1,69 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "24-Mar-92 14:05:50" {DSK}<usr>local>lde>lispcore>sources>CMLMVS.;2 4265   
+
+      changes to%:  (VARS CMLMVSCOMS) (FUNCTIONS CL:NTH-VALUE)
+
+      previous date%: "16-May-90 13:35:04" {DSK}<usr>local>lde>lispcore>sources>CMLMVS.;1)
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLMVSCOMS)
+
+(RPAQQ CMLMVSCOMS ((* ; "Interpreter and compiler support for multiple values.  See LLMVS for runtime support") (FNS CL:MULTIPLE-VALUE-CALL RETVALUES) (PROP DMACRO CL:MULTIPLE-VALUE-CALL) (FUNCTIONS CL:MULTIPLE-VALUE-BIND CL:MULTIPLE-VALUE-LIST CL:MULTIPLE-VALUE-PROG1 CL:MULTIPLE-VALUE-SETQ CL:NTH-VALUE) (VARS (NEW-ADVISETEMPLATE (QUOTE (ADV-PROG (!VALUE !OTHER-VALUES) (CL:MULTIPLE-VALUE-SETQ (!VALUE . !OTHER-VALUES) (ADV-PROG NIL (ADV-RETURN DEF))) (ADV-RETURN (CL:VALUES-LIST (CONS !VALUE !OTHER-VALUES))))))) (PROP FILETYPE CMLMVS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA CL:MULTIPLE-VALUE-CALL) (NLAML) (LAMA)))))
+
+
+
+(* ; "Interpreter and compiler support for multiple values.  See LLMVS for runtime support")
+
+(DEFINEQ
+
+(CL:MULTIPLE-VALUE-CALL
+  [NLAMBDA FORMS
+    (DECLARE (LOCALVARS . T))                                (* ; "Edited 16-Dec-86 15:35 by bvm:")
+          
+          (* ;; "for interpreted calls only.  Note that CL:APPLY will compile ok here, because this is in return context, so UNBIND doesn't get in the way.")
+
+    (CL:APPLY (\EVAL (CAR FORMS))
+           (for X in (CDR FORMS) join (CL:MULTIPLE-VALUE-LIST (\EVAL X])
+
+(RETVALUES
+  [LAMBDA (POS VALUES FLG)                                   (* bvm%: "10-Nov-86 18:13")
+    (LET ((P (\STACKARGPTR POS)))
+         (COND
+            ((fetch (FX INVALIDP) of (SETQ P (fetch (FX CLINK) of P)))
+             (LISPERROR "ILLEGAL RETURN" VALUES)))
+         (\SMASHRETURN NIL P)
+         (AND FLG (RELSTK POS))
+         (CL:VALUES-LIST VALUES])
+)
+
+(PUTPROPS CL:MULTIPLE-VALUE-CALL DMACRO (DEFMACRO (FN &BODY BODY) (* ;; "How to compile special form MULTIPLE-VALUE-CALL --- for benefit of macro writers, handle some degenerate cases and let the rest turn into an APPLY.  This is not an OPTIMIZER because pavcompiler intercepts it for its own use.") (COND ((AND (LISTP FN) (MEMB (CAR FN) (QUOTE (FUNCTION LISP:FUNCTION))) (MEMB (CADR FN) (QUOTE (LIST CL:VALUES)))) (if (NULL (CDR BODY)) then (* ; "only one source of values.  Either sole arg is the result itself, or a list of its values is") (CONS (if (EQ (CADR FN) (QUOTE LIST)) then (QUOTE \MVLIST) else (QUOTE PROGN)) BODY) else (* ; "Produce a list consisting of all args spread.  This is either the result itself, or to be spread as values") (BQUOTE ((\, (if (EQ (CADR FN) (QUOTE LIST)) then (QUOTE PROGN) else (QUOTE CL:VALUES-LIST))) (NCONC (\,@ (for F in BODY collect (BQUOTE (\MVLIST (\, F)))))))))) (T (BQUOTE (APPLY (\, FN) (NCONC (\,@ (for F in BODY collect (BQUOTE (\MVLIST (\, F))))))))))))
+
+(DEFMACRO CL:MULTIPLE-VALUE-BIND (VARS VALUES-FORM &REST FORMS) (BQUOTE (DESTRUCTURING-BIND (\, VARS) (CL:MULTIPLE-VALUE-LIST (\, VALUES-FORM)) (\,@ FORMS))))
+
+(DEFMACRO CL:MULTIPLE-VALUE-LIST (FORM) (BQUOTE (CL:MULTIPLE-VALUE-CALL (FUNCTION LIST) (\, FORM))))
+
+(DEFMACRO CL:MULTIPLE-VALUE-PROG1 (FORM . OTHER-FORMS) (BQUOTE (CL:VALUES-LIST (PROG1 (CL:MULTIPLE-VALUE-LIST (\, FORM)) (\,@ OTHER-FORMS)))))
+
+(DEFMACRO CL:MULTIPLE-VALUE-SETQ (VARIABLES FORM) (LET ((LIST (GENSYM))) (BQUOTE (LET (((\, LIST) (CL:MULTIPLE-VALUE-LIST (\, FORM)))) (DESTRUCTURING-SETQ (\, VARIABLES) (\, LIST)) (CAR (\, LIST))))))
+
+(DEFMACRO CL:NTH-VALUE (CL::N CL::FORM) (BQUOTE (CL:NTH (\, CL::N) (CL:MULTIPLE-VALUE-LIST (\, CL::FORM)))))
+
+(RPAQQ NEW-ADVISETEMPLATE (ADV-PROG (!VALUE !OTHER-VALUES) (CL:MULTIPLE-VALUE-SETQ (!VALUE . !OTHER-VALUES) (ADV-PROG NIL (ADV-RETURN DEF))) (ADV-RETURN (CL:VALUES-LIST (CONS !VALUE !OTHER-VALUES)))))
+
+(PUTPROPS CMLMVS FILETYPE CL:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA CL:MULTIPLE-VALUE-CALL)
+
+(ADDTOVAR NLAML)
+
+(ADDTOVAR LAMA)
+)
+(PUTPROPS CMLMVS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990 1992))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (1215 2052 (CL:MULTIPLE-VALUE-CALL 1225 . 1662) (RETVALUES 1664 . 2050)))))
+STOP
diff --git a/CLTL2/CMLMVS.LCOM b/CLTL2/CMLMVS.LCOM
new file mode 100644
index 00000000..e83aca83
Binary files /dev/null and b/CLTL2/CMLMVS.LCOM differ
diff --git a/CLTL2/CMLPACKAGE b/CLTL2/CMLPACKAGE
new file mode 100644
index 00000000..7a103860
--- /dev/null
+++ b/CLTL2/CMLPACKAGE
@@ -0,0 +1,143 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
+(il:filecreated "14-Jun-90 17:33:55" il:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLPACKAGE.;3| 22253  
+
+      il:|previous| il:|date:| "16-May-90 14:12:37" il:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLPACKAGE.;2|
+)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
+
+(il:prettycomprint il:cmlpackagecoms)
+
+(il:rpaqq il:cmlpackagecoms ((il:* il:|;;;| "This is the second part of the package system, the first is in LLPACKAGE, which is loaded during the init") (il:setfs symbol-package) (il:functions il:dwim-symbol-package escape-colons-proceed make-external-proceed make-internal-proceed ugly-symbol-proceed) (il:declare\: il:donteval@load il:docopy (il:addvars (il:dwimuserforms (il:dwim-symbol-package)))) (il:* il:|;;| "User friendly symbol error resolving functions") (il:structures read-conflict missing-external-symbol missing-package) (il:variables *preferred-reading-symbols*) (il:functions il:resolve-reader-conflict il:resolve-missing-external-symbol il:resolve-missing-package) (il:structures package-error symbol-conflict use-conflict export-conflict export-missing import-conflict unintern-conflict) (il:functions il:resolve-use-package-conflict il:resolve-export-conflict il:resolve-export-missing il:resolve-import-conflict il:resolve-unintern-conflict) (il:structures symbol-colon-error) (il:functions il:\\invalid.symbol (il:* il:\; "Also defined (w/o the error condition or proceed case) in LLREAD.")) (il:* il:|;;| "Symbol inspector") (il:functions il:symbol-inspect-fetchfn il:symbol-inspect-storefn) (il:p (let ((il:form (quote ((il:function symbolp) (il:name il:value il:plist package) il:symbol-inspect-fetchfn il:symbol-inspect-storefn nil nil nil "Symbol inspector")))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form))))) (il:* il:|;;| "Package inspector") (il:functions il:package-inspect-fetchfn il:package-inspect-storefn) (il:p (let ((il:form (quote ((il:function packagep) (il:name il:nicknames il:use-list il:internal-symbols il:external-symbols il:shadowing-symbols) il:package-inspect-fetchfn il:package-inspect-storefn nil nil nil "Package inspector")))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form))))) (il:* il:|;;| "Package-hashtable inspector") (il:functions il:package-hashtable-inspect-fetchfn il:package-hashtable-inspect-storefn) (il:p (let ((il:form (quote ((il:function lisp::package-hashtable-p) (il:size il:free il:deleted il:contents) il:package-hashtable-inspect-fetchfn il:package-hashtable-inspect-storefn)))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form))))) (il:* il:|;;| "Package's Prefix accessor and setfs (Edited by TT 14-June-90 for AR#11112)") (il:functions package-prefix setf-package-prefix) (il:setfs package-prefix) (il:prop (il:filetype il:makefile-environment) il:cmlpackage) (il:declare\: il:donteval@load il:doeval@compile il:dontcopy il:compilervars (il:addvars (il:nlama) (il:nlaml) (il:lama))))
+)
+
+
+
+(il:* il:|;;;| 
+"This is the second part of the package system, the first is in LLPACKAGE, which is loaded during the init"
+)
+
+
+(defsetf symbol-package il:setf-symbol-package)
+
+(defun il:dwim-symbol-package nil (declare (special il:faultx il:faultapplyflg)) (il:* il:|;;| "This is placed on DWIMUSERFORMS to attempt corrections where the typed symbol is in the wrong package.") (let ((il:sym (or (car (il:listp il:faultx)) il:faultx)) il:others) (cond ((and (il:litatom il:sym) (cdr (il:setq il:others (find-all-symbols (symbol-name il:sym)))) (il:setq il:others (il:|for| il:x il:|in| il:others il:|collect| il:x il:|when| (and (il:neq il:x il:sym) (not (keywordp il:x)) (il:|if| (and (il:litatom il:faultx) (not il:faultapplyflg)) il:|then| (il:* il:\; "Error is uba") (boundp il:x) il:|else| (fboundp il:x)))))) (il:|for| il:choice il:|in| il:others il:|when| (il:fixspell1 il:sym il:choice nil t (and (cdr il:others) (quote il:mustapprove))) il:|do| (il:* il:|;;| "Normally there is only one choice, and we offer it.  If there is more than one choice, probably should do something like a menu.  This is quick and dirty--ask user for each in turn and require approval so that it doesn't choose the first automatically.") (return (il:|if| (il:listp il:faultx) il:|then| (il:* il:\; "SYM = (CAR FAULTX)") (il:/rplaca il:faultx il:choice) il:|else| il:choice)))))))
+
+(define-proceed-function escape-colons-proceed :condition symbol-colon-error :report "Treat the extra colon(s) as if they were escaped")
+
+(define-proceed-function make-external-proceed :condition missing-external-symbol :report "Return a new external symbol by that name" (condition *current-condition*))
+
+(define-proceed-function make-internal-proceed :condition missing-external-symbol :report "Return a new internal symbol by that name")
+
+(define-proceed-function ugly-symbol-proceed :condition missing-package)
+(il:declare\: il:donteval@load il:docopy 
+
+(il:addtovar il:dwimuserforms (il:dwim-symbol-package))
+)
+
+
+
+(il:* il:|;;| "User friendly symbol error resolving functions")
+
+
+(define-condition read-conflict (read-error) (name packages) (:report (lambda (condition stream) (quote (format stream "Symbols named ~a exist in packages:~{~a ~}" (read-conflict-name condition) (mapcar (function package-name) (read-conflict-packages condition)))) (format stream "Symbols named ~A exists in packages:" (read-conflict-name condition)) (dolist (pkg (read-conflict-packages condition)) (princ " " stream) (princ (package-name pkg) stream)))))
+
+(define-condition missing-external-symbol (read-error) (name package) (:report (lambda (condition stream) (format stream "External symbol ~a not found in package ~a" (missing-external-symbol-name condition) (package-name (missing-external-symbol-package condition))))))
+
+(define-condition missing-package (read-error) (package-name symbol-name external) (:report (lambda (condition stream) (format stream "Can't find package ~a to look up symbol ~a" (missing-package-package-name condition) (missing-package-symbol-name condition)))))
+
+(defvar *preferred-reading-symbols* (quote (il:append il:apply il:apropos il:array il:arrayp il:assoc il:atan il:atom il:block il:break il:char il:character il:close il:common il:compile il:compile-file il:cos il:count il:defstruct il:delete il:describe il:directory il:do il:documentation il:elt il:equal il:error il:eval il:every il:exp il:expt il:fill-pointer il:find il:first il:floatp il:floor il:format il:function il:gcd il:gensym il:gethash il:if il:intersection il:keyword il:labels il:lambda il:ldiff il:length il:listp il:load il:locally il:log il:loop il:map il:mapc il:mapcar il:mapcon il:maphash il:maplist il:member il:merge il:mismatch il:mod il:namestring il:notany il:notevery il:nth il:number il:numberp il:numerator il:pop il:position il:prin1 il:print il:push il:pushnew il:rational il:read il:readtable il:remove il:replace il:rest il:reverse il:search il:second il:setq il:signed-byte il:simple-string il:sin il:some il:sort il:sqrt il:stringp il:structure il:sublis il:subseq il:subst il:symbol il:tan il:terpri trace il:union il:unless il:values il:variable il:vector il:when il:zerop il:* il:***)) "List of symbols whose lookup is preferred by the litatom to symbol converter.  Initially it contains a list of symbols which are conflicting but are always qualified in old sources.")
+
+(defun il:resolve-reader-conflict (il:ilsym il:clsym il:clsymwhere) "Reader finds unqualified symbol that exists in both InterLisp and Lisp.  Checks *PREFERRED-READING-SYMBOLS* list against names." (declare (special *preferred-reading-symbols*)) (il:* il:|;;| "CAUTION: Do not attempt to move the namestring check from \\NEW.READ.SYMBOL into this function as RESOLVE-READER-CONFLICT has a dummy definition in the INIT.  Also, namestring resolutions must be made during the time that packages are turned off in the beginning of the INIT.") (cond ((not (eq il:clsymwhere :external)) (il:* il:\; "Will not resolve internal (therefore private) symbols from LISP") il:ilsym) (t (let ((il:ilpreferred (member il:ilsym *preferred-reading-symbols* :test (quote eq))) (il:clpreferred (member il:clsym *preferred-reading-symbols* :test (quote eq)))) (cond ((and il:ilpreferred (not il:clpreferred)) il:ilsym) ((and il:clpreferred (not il:ilpreferred)) il:clsym) (t (il:* il:\; "Raise the signal") (restart-case (error (quote read-conflict) :name (symbol-name il:ilsym) :packages (list (find-package "LISP") (find-package "INTERLISP"))) (prefer-clsym-proceed nil :condition read-conflict :report (lambda (stream) (format stream "Return the LISP symbol ~A; make it preferred" il:clsym)) il:clsym) (prefer-ilsym-proceed nil :condition read-conflict :report (lambda (stream) (format stream "Return the INTERLISP symbol ~A; make it preferred" il:ilsym)) (setq *preferred-reading-symbols* (remove il:clsym *preferred-reading-symbols* :test (function eq))) (push il:ilsym *preferred-reading-symbols*) il:ilsym) (return-ilsym-proceed nil :condition read-conflict :report (lambda (stream) (format stream "Just return the INTERLISP symbol ~A" il:ilsym)) il:ilsym))))))))
+
+(defun il:resolve-missing-external-symbol (il:name package) "Handle missing external symbols in a package during read." (let ((il:my-condition (make-condition (quote missing-external-symbol) :name il:name :package package))) (flet ((il:filter nil (eq *current-condition* il:my-condition))) (restart-case (error il:my-condition) (make-external-proceed nil :filter il:filter :report (lambda (stream) (format stream "Return a new external symbol in package ~A named ~A" (package-name package) il:name)) (let ((il:symbol (intern il:name package))) (export il:symbol package) il:symbol)) (make-internal-proceed nil :filter il:filter :report (lambda (stream) (format stream "Return a new internal symbol in package ~A named ~A" (package-name package) il:name)) (intern il:name package))))))
+
+(defun il:resolve-missing-package (package-name symbol-name externalp) (let ((il:my-condition (make-condition (quote missing-package) :package-name package-name :symbol-name symbol-name :external externalp))) (flet ((il:filter nil (eq *current-condition* il:my-condition))) (restart-case (error il:my-condition) (new-package-proceed nil :filter il:filter :report (lambda (stream) (format stream "Return new symbol named ~A made in new package ~A" symbol-name package-name)) (let* ((package (make-package (missing-package-package-name il:my-condition))) (symbol (intern (missing-package-symbol-name il:my-condition) package))) (when (missing-package-external il:my-condition) (export symbol package)) symbol)) (ugly-symbol-proceed nil :filter il:filter :report (lambda (stream) (format stream "Return new ugly symbol |~a~a~a| made in current package ~a" package-name (if externalp ":" "::") symbol-name (package-name *package*))) :interactive (lambda nil (list *package*)) (intern (il:concat (missing-package-package-name il:my-condition) (if (missing-package-external il:my-condition) ":" "::") (missing-package-symbol-name il:my-condition)) *package*))))))
+
+(define-condition package-error (error) (package))
+
+(define-condition symbol-conflict (package-error) (symbols))
+
+(define-condition use-conflict (symbol-conflict) (used-package) (:report (lambda (condition *standard-output*) (format t "Package ~a using ~a results in name conflicts for symbols:~%~{~s ~}" (package-name (use-conflict-package condition)) (package-name (use-conflict-used-package condition)) (use-conflict-symbols condition)))))
+
+(define-condition export-conflict (symbol-conflict) (exported-symbols packages) (:report (lambda (condition *standard-output*) (format t "Exporting these symbols from the ~a package:~%~{~s ~}~%results in name conflicts with package(s):~%~{~a ~}~%" (package-name (export-conflict-package condition)) (export-conflict-symbols condition) (mapcar (function package-name) (export-conflict-packages condition))))))
+
+(define-condition export-missing (package-error) (symbols) (:report (lambda (condition *standard-output*) (format t "These symbols aren't in package ~a; can't export them from it:~%~{~s ~}" (package-name (export-missing-package condition)) (export-missing-symbols condition)))))
+
+(define-condition import-conflict (symbol-conflict) nil (:report (lambda (condition *standard-output*) (format t "Importing these symbols into package ~a causes a name conflict:~%~{~s ~}" (package-name (import-conflict-package condition)) (import-conflict-symbols condition)))))
+
+(define-condition unintern-conflict (symbol-conflict) (symbol) (:report (lambda (condition *standard-output*) (format t "Uninterning symbol ~s causes a name conflict among these symbols:~%~{~s ~}" (unintern-conflict-symbol condition) (unintern-conflict-symbols condition)))))
+
+(defun il:resolve-use-package-conflict (used-package symbols package) "Handle a conflict from use-package." (setq symbols (sort symbols (quote string<))) (let ((my-condition (make-condition (quote use-conflict) :package package :symbols symbols :used-package used-package))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (shadow-use-conflicts-proceed nil :filter filter :report (lambda (stream) (format stream "Shadow conflicting symbols from ~A in ~A" (package-name used-package) (package-name package))) (dolist (symbol symbols) (shadow symbol package))) (unintern-user-proceed nil :filter filter :report (lambda (stream) (format stream "Unintern all conflicting symbols from ~A (DANGEROUS)" (package-name package))) (dolist (symbol symbols) (il:moby-unintern symbol package))) (unintern-usee-proceed nil :filter filter :report (lambda (stream) (format stream "Unintern all conflicting symbols from ~A (VERY DANGEROUS)" (package-name used-package))) (dolist (symbol symbols) (il:moby-unintern (find-symbol (symbol-name symbol) used-package) used-package))) (abort nil :filter filter :report (lambda (stream) (format stream "Abort making package ~a use ~a" (package-name package) (package-name used-package))) (il:retfrom (quote use-package) nil))))))
+
+(defun il:resolve-export-conflict (package symbols packages exported-symbols) "Handle a conflict raised by export." (il:setq symbols (sort symbols (quote string<))) (setq packages (sort packages (function (lambda (a b) (string< (package-name a) (package-name b)))))) (let ((my-condition (make-condition (quote export-conflict) :package package :symbols symbols :exported-symbols exported-symbols :packages packages))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (unintern-proceed nil :filter filter :report (lambda (stream) (format stream "Unintern all conflicting symbols in package~P~{ ~a~} (DANGEROUS)" (if (null (rest packages)) 0 1) (mapcar (function package-name) packages))) (dolist (package packages exported-symbols) (dolist (symbol symbols) (il:moby-unintern (find-symbol (symbol-name symbol) package) package)))) (abort nil :filter filter :report (lambda (stream) (format stream "Abort exporting the symbols from package ~a" (package-name package))) (il:retfrom (quote export) nil))))))
+
+(defun il:resolve-export-missing (package symbols) "Handle missing symbols needed to export." (setq symbols (sort symbols (quote string<))) (let ((my-condition (quote export-missing) :package package :symbols symbols (make-condition))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (import-proceed nil :filter filter :report (lambda (stream) (format stream "Import missing symbols into ~A, then export them" package)) (import symbols package)) (abort nil :filter filter :report (lambda (stream) (format stream "Abort export from package ~A" package)) (il:retfrom (quote export) nil))))))
+
+(defun il:resolve-import-conflict (package symbols) "Handle conflict signalled by import.  Returning from here does shadowing import." (setq symbols (sort symbols (quote string<))) (let ((my-condition (make-condition (quote import-conflict) :package package :symbols symbols))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (shadowing-import-proceed nil :filter filter :report (lambda (stream) (format stream "Import symbols into ~S with ~S instead" (package-name package) (quote shadowing-import))) nil) (abort nil :filter filter :report (lambda (stream) (format stream "Abort import into package ~S" (package-name package))) (il:retfrom (quote import) nil))))))
+
+(defun il:resolve-unintern-conflict (symbol symbols package) "Handle a conflict noted by unintern." (setq symbols (sort symbols (quote string<))) (let ((my-condition (make-condition (quote unintern-conflict) :symbol symbol :symbols symbols :package package))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (shadowing-import-proceed (symbol-to-import) :filter filter :report (lambda (stream) (format stream "Choose symbol and ~S it to hide conflicts in package ~S" (quote shadowing-import) (package-name package))) :interactive (lambda nil (loop (let ((symbol (il:menu (il:create il:menu il:title il:_ "Choose symbol to shadowing-import" il:items il:_ symbols il:centerflg il:_ t)))) (when (member symbol symbols :test (function eq)) (return (list symbol)))))) (shadowing-import symbol-to-import package) (il:retfrom (quote il:resolve-unintern-conflict) t)) (abort nil :filter filter :report (lambda (stream) (format stream "Abort unintern of symbol ~s from package ~s" symbol (package-name package))) (il:retfrom (quote unintern) nil))))))
+
+(define-condition symbol-colon-error (read-error) (name) (:report (lambda (condition *standard-output*) (format t "Invalid symbol syntax in \"~A\"" (symbol-colon-error-name condition)))))
+
+(defun il:\\invalid.symbol (base len ncolons package extrasegments) (il:* il:|;;;| "Called when scanning a symbol that has more than 2 colons, or more than 1 non-consecutive colon.  If return from here, will read the symbol as though the extra colons were escaped.") (declare (special il:\\fatpnamestringp) (il:* il:\; "This ain't my fault, honest.")) (let ((my-condition (make-condition (quote symbol-colon-error) :name (il:concat (if (and package (not (eq package il:*keyword-package*))) (if (stringp package) package (package-name package)) "") (case ncolons (1 ":") (2 "::") (t "")) (il:\\getbasestring base 0 len il:\\fatpnamestringp))))) (restart-case (error my-condition) (escape-colons-proceed nil :filter (lambda nil (eq *current-condition* my-condition)) :report "Treat the extra colon(s) as if they were escaped" nil))))
+
+
+
+(il:* il:|;;| "Symbol inspector")
+
+
+(defun il:symbol-inspect-fetchfn (il:object il:property) (case il:property (il:name (symbol-name il:object)) (il:value (if (boundp il:object) (symbol-value il:object) (quote il:nobind))) (il:plist (symbol-plist il:object)) (package (symbol-package il:object))))
+
+(defun il:symbol-inspect-storefn (il:object il:property il:value) (case il:property (il:name (il:promptprint "Can't set symbol name")) (il:value (setf (symbol-value il:object) il:value)) (il:plist (setf (symbol-plist il:object) il:value)) (package (setf (symbol-package il:object) il:value))))
+
+(let ((il:form (quote ((il:function symbolp) (il:name il:value il:plist package) il:symbol-inspect-fetchfn il:symbol-inspect-storefn nil nil nil "Symbol inspector")))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form))))
+
+
+
+(il:* il:|;;| "Package inspector")
+
+
+(defun il:package-inspect-fetchfn (il:object il:property) (case il:property (il:name (lisp::%package-name il:object)) (il:nicknames (lisp::%package-nicknames il:object)) (il:use-list (lisp::%package-use-list il:object)) (il:internal-symbols (lisp::%package-internal-symbols il:object)) (il:external-symbols (lisp::%package-external-symbols il:object)) (il:shadowing-symbols (lisp::%package-shadowing-symbols il:object))))
+
+(defun il:package-inspect-storefn (il:object il:property il:value) (il:promptprint "Can't set the fields of a package"))
+
+(let ((il:form (quote ((il:function packagep) (il:name il:nicknames il:use-list il:internal-symbols il:external-symbols il:shadowing-symbols) il:package-inspect-fetchfn il:package-inspect-storefn nil nil nil "Package inspector")))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form))))
+
+
+
+(il:* il:|;;| "Package-hashtable inspector")
+
+
+(defun il:package-hashtable-inspect-fetchfn (il:object il:property) (case il:property (il:size (lisp::package-hashtable-size il:object)) (il:free (lisp::package-hashtable-free il:object)) (il:deleted (lisp::package-hashtable-deleted il:object)) (il:contents (lisp::package-hashtable-table il:object))))
+
+(defun il:package-hashtable-inspect-storefn (il:object il:property il:value) (il:promptprint "Can't set the fields of a package-hashtable"))
+
+(let ((il:form (quote ((il:function lisp::package-hashtable-p) (il:size il:free il:deleted il:contents) il:package-hashtable-inspect-fetchfn il:package-hashtable-inspect-storefn)))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form))))
+
+
+
+(il:* il:|;;| "Package's Prefix accessor and setfs (Edited by TT 14-June-90 for AR#11112)")
+
+
+(defun package-prefix (package) (il:* il:\; "Edited by TT (14-June-90 : for AR#111122)") (lisp::%package-namesymbol (il:\\packagify package)))
+
+(defun setf-package-prefix (package prefix) (il:* il:\; "Edited by TT (14-June-90 : for AR#111122)") (if (symbolp prefix) (setf (lisp::%package-namesymbol (il:\\packagify package)) prefix) (if (stringp prefix) (setf (lisp::%package-namesymbol (il:\\packagify package)) (intern prefix)) (error "~S must be symbol or string." prefix))))
+
+(defsetf package-prefix setf-package-prefix)
+
+(il:putprops il:cmlpackage il:filetype :compile-file)
+
+(il:putprops il:cmlpackage il:makefile-environment (:readtable "XCL" :package "XCL"))
+(il:declare\: il:donteval@load il:doeval@compile il:dontcopy il:compilervars 
+
+(il:addtovar il:nlama )
+
+(il:addtovar il:nlaml )
+
+(il:addtovar il:lama )
+)
+(il:putprops il:cmlpackage il:copyright ("Venue & Xerox Corporation" 1986 1987 1988 1990))
+(il:declare\: il:dontcopy
+  (il:filemap (nil)))
+il:stop
diff --git a/CLTL2/CMLPACKAGE.DFASL b/CLTL2/CMLPACKAGE.DFASL
new file mode 100644
index 00000000..3a2cb9e0
Binary files /dev/null and b/CLTL2/CMLPACKAGE.DFASL differ
diff --git a/CLTL2/CMLPATHNAME b/CLTL2/CMLPATHNAME
new file mode 100644
index 00000000..68e42783
--- /dev/null
+++ b/CLTL2/CMLPATHNAME
@@ -0,0 +1,245 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "25-Oct-91 16:21:24" {DSK}<usr>local>lde>lispcore>sources>CMLPATHNAME.;3 56939  
+
+      changes to%:  (FNS %%PRINT-PATHNAME %%PRINT-LP)
+
+      previous date%: " 3-Sep-91 15:54:13" {DSK}<usr>local>lde>lispcore>sources>CMLPATHNAME.;2)
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLPATHNAMECOMS)
+
+(RPAQQ CMLPATHNAMECOMS ((* ;; "Common Lisp pathname functions") (PROP FILETYPE CMLPATHNAME) (COMS (* ;; "useful macros") (FUNCTIONS %%MAKE-LP %%MERGE-DIRECTORY-LISTS %%WILD-NAME %%COMPONENT-STRING %%UNPACKFILE1)) (STRUCTURES PATHNAME DIRECTORY-COMPONENT CL:LOGICAL-PATHNAME) (DECLARE%: DONTCOPY EVAL@COMPILE (RECORDS PATHNAMECASE)) (FNS %%PARSE-DIRECTORY-PATH %%PRINT-LP %%PRINT-PATHNAME CL:MAKE-PATHNAME %%PRINT-DIRECTORY-COMPONENT) (FUNCTIONS CL:PATHNAME-HOST CL:PATHNAME-DEVICE CL:PATHNAME-DIRECTORY CL:PATHNAME-NAME CL:PATHNAME-TYPE CL:PATHNAME-VERSION) (FNS PATHNAME CL:MERGE-PATHNAMES FILE-NAME CL:HOST-NAMESTRING CL:ENOUGH-NAMESTRING %%NUMERIC-STRING-P) (FUNCTIONS CL:NAMESTRING CL:PARSE-NAMESTRING PARSE-NAMESTRING1 CL:TRUENAME) (FUNCTIONS %%MAKE-PATHNAME) (FUNCTIONS %%PATHNAME-EQUAL %%DIRECTORY-COMPONENT-EQUAL) (FUNCTIONS %%INITIALIZE-DEFAULT-PATHNAME) (VARIABLES *DEFAULT-PATHNAME-DEFAULTS* CL::*LOGICAL-PATHNAME-TRANSLATION-TABLE* CL::LOGICAL-WORD-BITTABLE \HOSTTOPATHNAMECASE) (COMS (* ;; "Interlisp-D compatibility") (FUNCTIONS INTERLISP-NAMESTRING UNPACKPATHNAME.STRING)) (FUNCTIONS CL:FILE-NAMESTRING CL:DIRECTORY-NAMESTRING) (COMS (* ;; "Backward compatibility with old directory-components (superceded by CLtL2 list-structured components)") (FUNCTIONS %%CONVERT-DIRECTORY-COMPONENT)) (COMS (* ;; "Funky pattern matcher for logical pathname support") (FUNCTIONS CL::MATCH&MAP CL::MM1 CL::MATCH-DIRECTORY-LISTS CL::MDL1) (* ;; "Direct logical pathname support") (DEFINE-TYPES CL::LOGICAL-HOSTS) (FUNCTIONS CL::DEF-LOGICAL-HOST CL::UNDEFINE-LOGICAL-HOST) (FUNCTIONS CL:LOGICAL-PATHNAME-TRANSLATIONS CL::UNDOABLY-SETF-LOGICAL-PATHNAME-TRANSLATIONS) (SETFS CL:LOGICAL-PATHNAME-TRANSLATIONS) (PROP :UNDOABLE-SETF-INVERSE CL:LOGICAL-PATHNAME-TRANSLATIONS) (FUNCTIONS CL::LOGICAL-HOST-P CL::MUNG-PATHNAME-ELT CL:LOGICAL-PATHNAME CL:PATHNAME-MATCH-P CL:TRANSLATE-LOGICAL-PATHNAME CL:TRANSLATE-PATHNAME CL:LOAD-LOGICAL-PATHNAME-TRANSLATIONS CL:WILD-PATHNAME-P) (FUNCTIONS LOOKUP-PATHNAMECASE REGISTER-PATHNAMECASE UNREGISTER-PATHNAMECASE) (FNS UNPACKLOGICALNAME.STRING)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME))) (FNS FLIP-MONOCASE FLIP-MONOCASE-STRING) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES PATHNAME %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME %%PRINT-LP)))))
+
+
+
+(* ;; "Common Lisp pathname functions")
+
+
+(PUTPROPS CMLPATHNAME FILETYPE CL:COMPILE-FILE)
+
+
+
+(* ;; "useful macros")
+
+
+(CL:DEFUN %%MAKE-LP (HOST DEVICE DIRECTORY NAME TYPE VERSION) (%%%%MAKE-LP :HOST HOST :DEVICE :UNSPECIFIC :DIRECTORY DIRECTORY :NAME NAME :TYPE TYPE :VERSION VERSION))
+
+(CL:DEFUN %%MERGE-DIRECTORY-LISTS (DIRLIST DEFAULTS) (* ;; "DIRLIST is a CLtL2-style directory list, DEFAULTS may or may not be; they need to be merged") (COND ((OR (EQUAL DEFAULTS (QUOTE (:ABSOLUTE :WILD-INFERIORS))) (EQUAL DEFAULTS (QUOTE (:ABSOLUTE :WILD)))) DIRLIST) ((AND (EQ (CAR DIRLIST) :RELATIVE) (CL:CONSP DEFAULTS)) (APPEND DEFAULTS (CDR DIRLIST))) (DIRLIST) (DEFAULTS)))
+
+(DEFMACRO %%WILD-NAME (STRING) (BQUOTE (LET ((S (\, STRING))) (CL:IF (STRING-EQUAL S "*") :WILD (CL:IF (STRING-EQUAL S "") NIL S)))))
+
+(DEFMACRO %%COMPONENT-STRING (COMPONENT) (BQUOTE (MKSTRING (OR (\, COMPONENT) ""))))
+
+(DEFMACRO %%UNPACKFILE1 (NAM ST END FILE PACKFLG ONEFIELDFLG VAL) (BQUOTE (if (NOT (\, ONEFIELDFLG)) then (SETQ (\, VAL) (CONS (COND ((\, PACKFLG) (SUBATOM (\, FILE) (\, ST) (\, END))) (T (OR (SUBSTRING (\, FILE) (\, ST) (\, END)) ""))) (CONS (\, NAM) (\, VAL)))) elseif (EQMEMB (\, NAM) (\, ONEFIELDFLG)) then (RETURN (COND ((\, PACKFLG) (SUBATOM (\, FILE) (\, ST) (\, END))) (T (OR (SUBSTRING (\, FILE) (\, ST) (\, END)) "")))))))
+
+(CL:DEFSTRUCT (PATHNAME (:CONC-NAME %%PATHNAME-) (:PRINT-FUNCTION %%PRINT-PATHNAME) (:CONSTRUCTOR %%%%MAKE-PATHNAME) (:PREDICATE CL:PATHNAMEP)) HOST DEVICE DIRECTORY NAME TYPE VERSION)
+
+(CL:DEFSTRUCT (DIRECTORY-COMPONENT (:CONC-NAME %%DIRECTORY-COMPONENT-) (:PRINT-FUNCTION %%PRINT-DIRECTORY-COMPONENT) (:CONSTRUCTOR %%MAKE-DIRECTORY-COMPONENT) (:PREDICATE %%DIRECTORY-COMPONENT-P)) TYPE PATH)
+
+(CL:DEFSTRUCT (CL:LOGICAL-PATHNAME (:SYSTEM-INCLUDE PATHNAME) (:PRINT-FUNCTION %%PRINT-LP) (:CONSTRUCTOR %%%%MAKE-LP) (:PREDICATE CL::LOGICAL-PATHNAME-P)))
+(DECLARE%: DONTCOPY EVAL@COMPILE 
+(DECLARE%: EVAL@COMPILE
+
+(RECORD PATHNAMECASE (HOST-NAME STRING-COMPARE LOCAL-TO-COMMON COMMON-TO-LOCAL))
+)
+)
+(DEFINEQ
+
+(%%PARSE-DIRECTORY-PATH
+(LAMBDA (PS) (* ; "Edited 17-Jun-91 09:19 by jrb:") (* ;; "Seperates a directory string into a list of its component directory strings with the CLtL2-apropos atoms inserted") (IF (STRINGP PS) THEN (LET ((REM (SUBSTRING PS 1)) TAIL POINT PIECE) (CL:FLET ((MUNG-PIECE (P) (COND ((CL:STRING= P "*") :WILD) ((CL:STRING= P "**") :WILD-INFERIORS) ((CL:STRING= P "..") :BACK) (T P)))) (while (SETQ POINT (STRPOSL (CONSTANT (MAKEBITTABLE (QUOTE (/ > ;)))) REM)) do (SETQ PIECE (SUBSTRING REM 1 (CL:1- POINT))) (push TAIL (MUNG-PIECE PIECE)) (SETQ REM (SUBSTRING REM (CL:1+ POINT) NIL REM)) finally (CL:WHEN REM (push TAIL (MUNG-PIECE REM))))) (CL:NREVERSE TAIL)) else PS))
+)
+
+(%%PRINT-LP
+(CL:LAMBDA (S STREAM D) (DECLARE (IGNORE D)) (* ; "Edited 25-Oct-91 16:08 by jrb:") (CL:WHEN (AND CL:*PRINT-READABLY* (NOT CL:*READ-EVAL*)) (CL::CHECK-READABLY S "its print-method when *READ-EVAL* is NIL")) (CL:FORMAT STREAM "#.(LOGICAL-PATHNAME ~S)" (CL:NAMESTRING S)))
+)
+
+(%%PRINT-PATHNAME
+(CL:LAMBDA (S STREAM D) (* ; "Edited 25-Oct-91 15:49 by jrb:") (DECLARE (IGNORE D)) (CL:FORMAT STREAM "~:[~;#P~]~S" *PRINT-ESCAPE* (CL:NAMESTRING S)))
+)
+
+(CL:MAKE-PATHNAME
+(CL:LAMBDA (&KEY DEFAULTS (HOST NIL HOSTP) (DEVICE NIL DEVICEP) (DIRECTORY NIL DIRECTORYP) (NAME NIL NAMEP) (TYPE NIL TYPEP) (VERSION NIL VERSIONP) (CASE :LOCAL) (CL::LOGICAL NIL)) (* ; "Edited  3-Aug-91 15:25 by jrb:") (* ;; "Create a pathname from host, device, directory, name, type and version.  If any field is omitted, it is obtained from defaults as though by merge-pathnames.") (* ;; "Under Medley, as of CLtL2, the following are the legal inputs and resulting contents of pathname slots:") (* ;; "Host: NIL|:UNSPECIFIC|string => NIL|:UNSPECIFIC|string") (* ;; "Device: NIL|:UNSPECIFIC|string => NIL|:UNSPECIFIC|string") (* ;; "Directory: NIL|string|:WILD|:UNSPECIFIC|CLtL2-style list => NIL|:UNSPECIFIC|CLtL2-style list") (* ;; "    (DIRECTORY-COMPONENT objects are recognized and converted to lists)") (* ;; "Name: NIL|string|:WILD|:UNSPECIFIC => NIL|string|:WILD|:UNSPECIFIC") (* ;; "Type: NIL|string|:WILD|:UNSPECIFIC => NIL|string|:WILD|:UNSPECIFIC") (* ;; "Version: NIL|positive-integer|:WILD|:NEWEST|:UNSPECIFIC => NIL|positive-integer|:WILD|:NEWEST|:UNSPECIFIC") (CL:FLET ((CL::PARSE-DIRECTORY-STRING (CL::DS) (LET ((CL::DL (%%PARSE-DIRECTORY-PATH CL::DS))) (CASE (CL:CHAR CL::DS (CL:1- (CL:LENGTH CL::DS))) ((#\> #\/) (* ;; "MAKE-PATHNAME does not accept :SUBDIRECTORY argument.  Thus a subdirectory and a relative directory is indicated with the trail directory delimiter.") (COND (DEFAULTS (%%MERGE-DIRECTORY-LISTS (CONS :RELATIVE CL::DL) (%%PATHNAME-DIRECTORY DEFAULTS))) (T (CONS :RELATIVE CL::DL)))) (T (CONS :ABSOLUTE CL::DL)))))) (CL:WHEN DEFAULTS (CL:SETQ DEFAULTS (PATHNAME DEFAULTS)) (CL:UNLESS HOSTP (SETQ HOST (%%PATHNAME-HOST DEFAULTS))) (CL:UNLESS DEVICEP (SETQ DEVICE (%%PATHNAME-DEVICE DEFAULTS))) (CL:UNLESS DIRECTORYP (SETQ DIRECTORY (%%PATHNAME-DIRECTORY DEFAULTS))) (CL:UNLESS NAMEP (SETQ NAME (%%PATHNAME-NAME DEFAULTS))) (CL:UNLESS TYPEP (SETQ TYPE (%%PATHNAME-TYPE DEFAULTS))) (CL:UNLESS VERSIONP (SETQ VERSION (%%PATHNAME-VERSION DEFAULTS)))) (CL:UNLESS (OR HOSTP HOST) (SETQ HOST (%%PATHNAME-HOST *DEFAULT-PATHNAME-DEFAULTS*))) (* ;; "Handle the :COMMON CASE here") (CL:WHEN (EQ CASE :COMMON) (LET ((COMMON-TO-LOCAL (fetch (PATHNAMECASE COMMON-TO-LOCAL) of (LOOKUP-PATHNAMECASE HOST)))) (CL:WHEN (AND HOSTP (CL:STRINGP HOST)) (SETQ HOST (CL:FUNCALL COMMON-TO-LOCAL HOST))) (CL:WHEN (AND DEVICEP (CL:STRINGP DEVICE)) (SETQ DEVICE (CL:FUNCALL COMMON-TO-LOCAL DEVICE))) (CL:WHEN DIRECTORYP (CL:WHEN (CL:STRINGP DIRECTORY) (CL:SETQ DIRECTORY (CL::PARSE-DIRECTORY-STRING DIRECTORY))) (CL:WHEN (LISTP DIRECTORY) (SETQ DIRECTORY (MAPCAR DIRECTORY (CL:FUNCTION (LAMBDA (X) (CL:IF (CL:STRINGP X) (CL:FUNCALL COMMON-TO-LOCAL X) X))))))) (CL:WHEN (AND NAMEP (CL:STRINGP NAME)) (SETQ NAME (CL:FUNCALL COMMON-TO-LOCAL NAME))) (CL:WHEN (AND TYPEP (CL:STRINGP TYPE)) (SETQ TYPE (CL:FUNCALL COMMON-TO-LOCAL TYPE))))) (CL:FUNCALL (CL:IF (OR CL::LOGICAL (AND (NOT *CLTL2-PEDANTIC*) (CL::LOGICAL-HOST-P HOST))) (QUOTE %%MAKE-LP) (QUOTE %%MAKE-PATHNAME)) (CL:IF (STRINGP HOST) (COERCE HOST (QUOTE CL:SIMPLE-STRING)) HOST) (CL:IF (STRINGP DEVICE) (COERCE DEVICE (QUOTE CL:SIMPLE-STRING)) DEVICE) (CL:IF DIRECTORY (PROGN (* ;; "Hopefully from now on, the only things users should find in PATHNAME-DIRECTORY are:") (* ;; "NIL") (* ;; ":UNSPECIFIC") (* ;; "A CLtL2-style list (CAR of :ABSOLUTE or :RELATIVE, followed by elements in the path)") (CL:WHEN (CL:SYMBOLP DIRECTORY) (SETQ DIRECTORY (SELECTQ DIRECTORY (:WILD (QUOTE (:ABSOLUTE :WILD-INFERIORS))) (:UNSPECIFIC DIRECTORY) (CL:IF *CLTL2-PEDANTIC* (ERROR "Symbol as :DIRECTORY component" DIRECTORY) (STRING DIRECTORY))))) (CL:TYPECASE DIRECTORY (LIST (CL:IF DEFAULTS (%%MERGE-DIRECTORY-LISTS DIRECTORY (%%PATHNAME-DIRECTORY DEFAULTS)) DIRECTORY)) (DIRECTORY-COMPONENT (%%CONVERT-DIRECTORY-COMPONENT DIRECTORY)) (STRING (CL:WHEN (CL:PLUSP (CL:LENGTH DIRECTORY)) (CONS (CASE (CL:CHAR DIRECTORY (CL:1- (CL:LENGTH DIRECTORY))) ((#\/ #\>) :RELATIVE) (CL:OTHERWISE :ABSOLUTE)) (%%PARSE-DIRECTORY-PATH DIRECTORY)))) (T DIRECTORY))) DIRECTORY) (CL:IF (STRINGP NAME) (COERCE NAME (QUOTE CL:SIMPLE-STRING)) NAME) (CL:IF (STRINGP TYPE) (COERCE TYPE (QUOTE CL:SIMPLE-STRING)) TYPE) VERSION)))
+)
+
+(%%PRINT-DIRECTORY-COMPONENT
+(LISP:LAMBDA (S STREAM D) (DECLARE (IGNORE D)) (* ; "Edited  7-Mar-90 17:59 by nm") (* %| "(CL:FORMAT STREAM %"#.(~S ~S)%" (QUOTE DIRECTORY-COMPONENT) (CASE (%%%%DIRECTORY-COMPONENT-TYPE S) ((:SUBDIRECTORY :RELATIVE) (CL:CONCATENATE (QUOTE STRING) (%%%%DIRECTORY-COMPONENT-PATH S) %">%")) (T (CL:CONCATENATE (QUOTE STRING) (CL:FIRST \FILENAME.SYNTAX) (%%%%DIRECTORY-COMPONENT-PATH S) (CL:SECOND \FILENAME.SYNTAX)))))") (LET ((PATH (%%DIRECTORY-COMPONENT-PATH S))) (LISP:FORMAT STREAM "~A" (CASE (%%DIRECTORY-COMPONENT-TYPE S) ((:SUBDIRECTORY :RELATIVE) (LISP:CONCATENATE (QUOTE STRING) PATH ">")) (T (LISP:IF (EQ PATH :WILD) (LISP:CONCATENATE (QUOTE STRING) (LISP:FIRST \FILENAME.SYNTAX) "*" (LISP:SECOND \FILENAME.SYNTAX)) (LISP:CONCATENATE (QUOTE STRING) (LISP:FIRST \FILENAME.SYNTAX) PATH (LISP:SECOND \FILENAME.SYNTAX))))))))
+)
+)
+
+(CL:DEFUN CL:PATHNAME-HOST (PATHNAME &KEY CASE) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the host slot of it; if CASE is :COMMON, hoses it through the LOCAL-TO-COMMON conversion function first") (LET ((CL::PN (PATHNAME PATHNAME))) (CL:IF (AND (EQ CASE :COMMON) (CL:STRINGP (%%PATHNAME-HOST CL::PN))) (CL:FUNCALL (fetch (PATHNAMECASE LOCAL-TO-COMMON) of (LOOKUP-PATHNAMECASE (%%PATHNAME-HOST CL::PN))) (%%PATHNAME-HOST CL::PN)) (%%PATHNAME-HOST CL::PN))))
+
+(CL:DEFUN CL:PATHNAME-DEVICE (PATHNAME &KEY CASE) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the device slot of it") (LET ((CL::PN (PATHNAME PATHNAME))) (CL:IF (AND (EQ CASE :COMMON) (CL:STRINGP (%%PATHNAME-DEVICE CL::PN))) (CL:FUNCALL (fetch (PATHNAMECASE LOCAL-TO-COMMON) of (LOOKUP-PATHNAMECASE (%%PATHNAME-HOST CL::PN))) (%%PATHNAME-DEVICE CL::PN)) (%%PATHNAME-DEVICE CL::PN))))
+
+(CL:DEFUN CL:PATHNAME-DIRECTORY (PATHNAME &KEY CASE) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the directory slot of it") (LET* ((CL::PN (PATHNAME PATHNAME)) (CL::PD (%%PATHNAME-DIRECTORY CL::PN))) (CL:IF (AND (EQ CASE :COMMON) (CL:CONSP CL::PD)) (LET ((CL::PF (fetch (PATHNAMECASE LOCAL-TO-COMMON) of (LOOKUP-PATHNAMECASE (%%PATHNAME-HOST CL::PN))))) (CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (CL::X) (CL:IF (CL:STRINGP CL::X) (CL:FUNCALL CL::PF CL::X) CL::X))) CL::PD)) CL::PD)))
+
+(CL:DEFUN CL:PATHNAME-NAME (PATHNAME &KEY CASE) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the name slot of it") (LET ((CL::PN (PATHNAME PATHNAME))) (CL:IF (AND (EQ CASE :COMMON) (CL:STRINGP (%%PATHNAME-NAME CL::PN))) (CL:FUNCALL (fetch (PATHNAMECASE LOCAL-TO-COMMON) of (LOOKUP-PATHNAMECASE (%%PATHNAME-HOST CL::PN))) (%%PATHNAME-NAME CL::PN)) (%%PATHNAME-NAME CL::PN))))
+
+(CL:DEFUN CL:PATHNAME-TYPE (PATHNAME &KEY CASE) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the type slot of it") (LET ((CL::PN (PATHNAME PATHNAME))) (CL:IF (AND (EQ CASE :COMMON) (CL:STRINGP (%%PATHNAME-TYPE CL::PN))) (CL:FUNCALL (fetch (PATHNAMECASE LOCAL-TO-COMMON) of (LOOKUP-PATHNAMECASE (%%PATHNAME-HOST CL::PN))) (%%PATHNAME-TYPE CL::PN)) (%%PATHNAME-TYPE CL::PN))))
+
+(CL:DEFUN CL:PATHNAME-VERSION (PATHNAME) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the version slot of it") (%%PATHNAME-VERSION (PATHNAME PATHNAME)))
+(DEFINEQ
+
+(PATHNAME
+(LISP:LAMBDA (THING) (* hdj " 2-Apr-86 11:01") (* ;; "Turns Thing into a pathname.  Thing may be a string, symbol, stream, or pathname.") (LISP:VALUES (LISP:PARSE-NAMESTRING THING)))
+)
+
+(CL:MERGE-PATHNAMES
+(CL:LAMBDA (PATHNAME &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*) (DEFAULT-VERSION :NEWEST LISP::VERSION-SPECIFIED-P)) (* ; "Edited  3-Jun-91 20:56 by jrb:") (* ;;; "Merge-Pathnames -- Public Returns a new pathname whose fields are the same as the fields in PATHNAME except that NIL fields are filled in from defaults.  Type and Version field are only done if name field has to be done (see manual for explanation). Fills in unspecified slots of Pathname from Defaults (defaults to *default-pathname-defaults*).  If the version remains unspecified, gets it from Default-Version.") (LET* ((PATH (PATHNAME PATHNAME)) (DEFAULT-PATH (PATHNAME DEFAULTS)) (HOST (OR (%%PATHNAME-HOST PATH) (%%PATHNAME-HOST DEFAULT-PATH))) (NAME (%%PATHNAME-NAME PATH)) (DEVICE (%%PATHNAME-DEVICE PATH)) (DIR (%%PATHNAME-DIRECTORY PATH)) (DEFAULT-DIR (%%PATHNAME-DIRECTORY DEFAULT-PATH)) DIREND DEFAULT-TYPE) (%%MAKE-PATHNAME HOST (OR DEVICE (%%PATHNAME-DEVICE DEFAULT-PATH)) (OR (AND DIR DEFAULT-DIR (IF (CL:CONSP DIR) THEN (%%MERGE-DIRECTORY-LISTS DIR DEFAULT-DIR))) DIR DEFAULT-DIR) (OR NAME (%%PATHNAME-NAME DEFAULT-PATH)) (OR (%%PATHNAME-TYPE PATH) (%%PATHNAME-TYPE DEFAULT-PATH)) (OR (%%PATHNAME-VERSION PATH) (CL:IF NAME (CL:IF LISP::VERSION-SPECIFIED-P DEFAULT-VERSION :NEWEST) (OR (%%PATHNAME-VERSION DEFAULT-PATH) (CL:IF LISP::VERSION-SPECIFIED-P DEFAULT-VERSION :NEWEST)))))))
+)
+
+(FILE-NAME
+(LISP:LAMBDA (FILE) (* hdj " 9-Oct-86 15:12") (LET ((NAME (FULLNAME FILE))) (if (STREAMP NAME) then "" else (MKSTRING NAME))))
+)
+
+(LISP:HOST-NAMESTRING
+(LISP:LAMBDA (PATHNAME) (* hdj "11-Jun-86 11:29") (* ;; "Returns the host part of PATHNAME as a string.") (%%COMPONENT-STRING (%%PATHNAME-HOST (PATHNAME PATHNAME))))
+)
+
+(CL:ENOUGH-NAMESTRING
+(CL:LAMBDA (PATHNAME &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*)) (* ; "Edited  2-Aug-91 09:21 by jrb:") (* ;; "Enough-Namestring returns a string which uniquely identifies PATHNAME w.r.t.  DEFAULTS.") (CL:FLET ((CL::MUNG-SLOT (CL::X) (* ; "Map :UNSPECIFIC to NIL for printing") (CL:IF (EQ CL::X :UNSPECIFIC) NIL CL::X))) (LET* ((*PRINT-BASE* 10) (PATH (PATHNAME PATHNAME)) (DEFAULT-PATHNAME (PATHNAME DEFAULTS)) (HOST (CL::MUNG-SLOT (%%PATHNAME-HOST PATH))) (DEVICE (CL::MUNG-SLOT (%%PATHNAME-DEVICE PATH))) (DIRECTORY (CL::MUNG-SLOT (%%PATHNAME-DIRECTORY PATH))) (NAME (CL::MUNG-SLOT (%%PATHNAME-NAME PATH))) (TYPE (CL::MUNG-SLOT (%%PATHNAME-TYPE PATH))) (VERSION (CL::MUNG-SLOT (%%PATHNAME-VERSION PATH))) (RESULT "") (CL::HOST-HEAD "{") (CL::HOST-TAIL "}") (CL::DIR-HEAD (CL:FIRST \FILENAME.SYNTAX)) (CL::DIR-TAIL (CL:SECOND \FILENAME.SYNTAX)) (CL::VER-HEAD (CL:THIRD \FILENAME.SYNTAX))) (CL:WHEN (CL::LOGICAL-PATHNAME-P PATH) (CL:UNLESS (CL::LOGICAL-PATHNAME-P DEFAULT-PATHNAME) (CL:ERROR "Can't merge ~s with ~s" PATH DEFAULT-PATHNAME)) (CL:SETQ CL::HOST-HEAD "" CL::HOST-TAIL ":" CL::DIR-HEAD ";" CL::DIR-TAIL ";" CL::VER-HEAD ".")) (CL:FLET ((CL::MUNG-DIR-LIST (CL::X) (LIST (CL::MUNG-PATHNAME-ELT CL::X) CL::DIR-TAIL))) (CL:WHEN (AND HOST (CL:STRING-NOT-EQUAL HOST (%%COMPONENT-STRING (CL::MUNG-SLOT (%%PATHNAME-HOST DEFAULT-PATHNAME))))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) CL::HOST-HEAD (CL:PRINC-TO-STRING HOST) CL::HOST-TAIL))) (CL:WHEN (AND DEVICE (CL:STRING-NOT-EQUAL DEVICE (%%COMPONENT-STRING (CL::MUNG-SLOT (%%PATHNAME-DEVICE DEFAULT-PATHNAME))))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CL:PRINC-TO-STRING DEVICE) ":"))) (CL:WHEN (AND DIRECTORY (NOT (CL:EQUAL DIRECTORY (CL::MUNG-SLOT (%%PATHNAME-DIRECTORY DEFAULT-PATHNAME))))) (CL:SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CONCATLIST (CASE (CL:FIRST DIRECTORY) (:RELATIVE (CL:MAPCAN (CL:FUNCTION CL::MUNG-DIR-LIST) (CDR DIRECTORY))) (:ABSOLUTE (CL:IF (AND (EQ (CL:SECOND DIRECTORY) :WILD-INFERIORS) (NULL (CDDR DIRECTORY))) NIL (CONS CL::DIR-HEAD (CL:MAPCAN (CL:FUNCTION CL::MUNG-DIR-LIST) (CDR DIRECTORY)))))))))) (CL:WHEN (AND NAME (CL:STRING-NOT-EQUAL NAME (%%COMPONENT-STRING (CL::MUNG-SLOT (%%PATHNAME-NAME DEFAULT-PATHNAME))))) (CL:SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CL:PRINC-TO-STRING NAME)))) (CL:WHEN (AND TYPE (CL:STRING-NOT-EQUAL TYPE (%%COMPONENT-STRING (CL::MUNG-SLOT (%%PATHNAME-TYPE DEFAULT-PATHNAME))))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT "." (CL:PRINC-TO-STRING TYPE)))) (CL:WHEN (AND VERSION (CL:STRING-NOT-EQUAL (CL:PRINC-TO-STRING VERSION) (CL::MUNG-SLOT (%%PATHNAME-VERSION DEFAULT-PATHNAME)))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CASE VERSION (:WILD (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) CL::VER-HEAD "*")) ((:NEWEST NIL) "") (CL:OTHERWISE (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) CL::VER-HEAD (CL:PRINC-TO-STRING VERSION))))))) RESULT))))
+)
+
+(%%NUMERIC-STRING-P
+(LAMBDA (STRING) (* hdj "28-Jul-86 12:25") (AND (LISP:STRINGP STRING) (for CHAR instring STRING do (if (OR (ILESSP CHAR (CHARCODE 0)) (IGREATERP CHAR (CHARCODE 9))) then (RETURN NIL)) finally (RETURN T))))
+)
+)
+
+(CL:DEFUN CL:NAMESTRING (PATHNAME) (* ;;; "Returns the full form of PATHNAME as a string.") (CL:WHEN (AND (STREAMP PATHNAME) (NOT (fetch (STREAM NAMEDP) of PATHNAME))) (* ; "unnamed streams have the empty string as name.") (CL:RETURN-FROM CL:NAMESTRING "")) (CL:FLET ((CL::MUNG-SLOT (CL::X) (* ; "Map :UNSPECIFIC to NIL for printing") (CL:IF (EQ CL::X :UNSPECIFIC) NIL CL::X)) (CL::MPE (CL::X) (LIST (CL::MUNG-PATHNAME-ELT CL::X) (CL:SECOND \FILENAME.SYNTAX)))) (LET* ((PATHNAME (PATHNAME PATHNAME)) (CL::HOST (CL::MUNG-SLOT (%%PATHNAME-HOST PATHNAME))) (CL::DEVICE (CL::MUNG-SLOT (%%PATHNAME-DEVICE PATHNAME))) (CL:DIRECTORY (CL::MUNG-SLOT (%%PATHNAME-DIRECTORY PATHNAME))) (CL::NAME (CL::MUNG-SLOT (%%PATHNAME-NAME PATHNAME))) (TYPE (CL::MUNG-SLOT (%%PATHNAME-TYPE PATHNAME))) (CL::VERSION (CL::MUNG-SLOT (%%PATHNAME-VERSION PATHNAME))) (CL::HOST-HEAD "{") (CL::HOST-TAIL "}") (CL::DIR-HEAD (CL:FIRST \FILENAME.SYNTAX)) (CL::DIR-TAIL (CL:SECOND \FILENAME.SYNTAX)) (CL::VER-HEAD (CL:THIRD \FILENAME.SYNTAX))) (CL:FLET ((CL::MPE (CL::X) (LIST (CL::MUNG-PATHNAME-ELT CL::X) CL::DIR-TAIL))) (CL:WHEN (CL::LOGICAL-PATHNAME-P PATHNAME) (CL:SETQ CL::HOST-HEAD "" CL::HOST-TAIL ":" CL::DIR-HEAD ";" CL::DIR-TAIL ";" CL::VER-HEAD (AND CL::VERSION "."))) (CONCATLIST (NCONC (CL:WHEN CL::HOST (LIST CL::HOST-HEAD (CL:IF (EQ CL::HOST :WILD) "*" CL::HOST) CL::HOST-TAIL)) (CL:WHEN CL::DEVICE (LIST (CL:IF (EQ :WILD CL::DEVICE) "*" CL::DEVICE) ":")) (CL:WHEN CL:DIRECTORY (CL:ECASE (CL:FIRST CL:DIRECTORY) (:RELATIVE (CL:MAPCAN (CL:FUNCTION CL::MPE) (CDR CL:DIRECTORY))) (:ABSOLUTE (CL:IF (AND (EQ (CL:SECOND CL:DIRECTORY) :WILD-INFERIORS) (NULL (CDDR CL:DIRECTORY))) NIL (CONS CL::DIR-HEAD (CL:MAPCAN (CL:FUNCTION CL::MPE) (CDR CL:DIRECTORY))))))) (CL:WHEN CL::NAME (LIST (CL:IF (EQ CL::NAME :WILD) "*" CL::NAME))) (CL:WHEN TYPE (LIST "." (CL:IF (EQ TYPE :WILD) "*" TYPE))) (CL:WHEN (AND CL::VERSION (OR (NOT (EQ CL::VERSION (QUOTE :NEWEST))) CL::NAME TYPE)) (COND ((AND (EQ \MACHINETYPE \MAIKO) (STREQUAL "UNIX" (U-CASE (MKSTRING CL::HOST)))) (* ; "{UNIX} device on Maiko breaks the Interlisp-D original file naming convention.  The trail semicolonn is regarded as a part of the file name rather than a %"highest versioned%" file!   Thus, if :newest, we have to elimit the semicolon.") (CASE CL::VERSION ((:WILD) (LIST CL::VER-HEAD) "*") ((:NEWEST) (LIST "")) (T (LIST CL::VER-HEAD CL::VERSION)))) (T (LIST CL::VER-HEAD (CASE CL::VERSION ((:WILD) "*") ((:NEWEST) (CL:IF (CL::LOGICAL-PATHNAME-P PATHNAME) CL::VERSION "")) (T CL::VERSION))))))))))))
+
+(CL:DEFUN CL:PARSE-NAMESTRING (THING &OPTIONAL HOST DEFAULTS &KEY (START 0) END (JUNK-ALLOWED NIL) (CL::LOGICAL NIL)) (* ;;; "Parses a string representation of a pathname into a pathname.  For details on the other silly arguments see the manual.  NOTE that this version ignores JUNK-ALLOWED (because UNPACKFILENAME a.k.a. PARSE-NAMESTRING1 will parse anything)") (DECLARE (IGNORE JUNK-ALLOWED)) (CL:ETYPECASE THING (STRING NIL) (PATHNAME (CL:RETURN-FROM CL:PARSE-NAMESTRING (CL:VALUES THING START))) (STREAM (CL:IF (XCL:SYNONYM-STREAM-P THING) (CL:RETURN-FROM CL:PARSE-NAMESTRING (CL:PARSE-NAMESTRING (CL:SYMBOL-VALUE (CL:SYNONYM-STREAM-SYMBOL THING)))) (SETQ THING (FILE-NAME THING)))) (CL:SYMBOL (CL:WHEN *CLTL2-PEDANTIC* (XCL::SYMBOL-AS-PATHNAME THING (QUOTE CL:PARSE-NAMESTRING))) (SETQ THING (CL:SYMBOL-NAME THING)))) (CL:UNLESS END (SETQ END (CL:LENGTH THING))) (* ;; "The defaulting code below is a little odd; if :LOGICAL is specified T, we do NOT default the host from *DEFAULT-PATHNAME-DEFAULTS* unless it is a LOGICAL-PATHNAME") (CL:UNLESS HOST (CL:SETQ HOST (OR (AND DEFAULTS (%%PATHNAME-HOST DEFAULTS)) (AND (OR (NOT CL::LOGICAL) (CL::LOGICAL-PATHNAME-P *DEFAULT-PATHNAME-DEFAULTS*)) (%%PATHNAME-HOST *DEFAULT-PATHNAME-DEFAULTS*))))) (CL:UNLESS CL::LOGICAL (CL:SETQ CL::LOGICAL (OR (CL::LOGICAL-HOST-P HOST) (CL::LOGICAL-PATHNAME-P DEFAULTS)))) (LET* ((PATH-STRING (SUBSTRING THING (+ 1 START) END)) (PATH-LIST (CL:IF CL::LOGICAL (UNPACKLOGICALNAME.STRING (U-CASE PATH-STRING) (U-CASE HOST)) (UNPACKFILENAME.STRING PATH-STRING NIL NIL NIL NIL T)))) (CL:VALUES (CL:MAKE-PATHNAME :HOST (%%WILD-NAME (LISTGET PATH-LIST (QUOTE HOST))) :DEVICE (%%WILD-NAME (LISTGET PATH-LIST (QUOTE DEVICE))) :DIRECTORY (LET ((CL:DIRECTORY (LISTGET PATH-LIST (QUOTE DIRECTORY))) (LISP::SUBDIRECTORY (LISTGET PATH-LIST (QUOTE SUBDIRECTORY))) (LISP::RELATIVEDIRECTORY (LISTGET PATH-LIST (QUOTE RELATIVEDIRECTORY)))) (COND (CL:DIRECTORY (CONS :ABSOLUTE (%%PARSE-DIRECTORY-PATH CL:DIRECTORY))) (LISP::SUBDIRECTORY (CONS :RELATIVE (%%PARSE-DIRECTORY-PATH LISP::SUBDIRECTORY))) (LISP::RELATIVEDIRECTORY (CONS :RELATIVE (%%PARSE-DIRECTORY-PATH LISP::RELATIVEDIRECTORY))) (T NIL))) :NAME (%%WILD-NAME (LISTGET PATH-LIST (QUOTE NAME))) :TYPE (%%WILD-NAME (LISTGET PATH-LIST (QUOTE EXTENSION))) :VERSION (LET ((VERSION (LISTGET PATH-LIST (QUOTE VERSION)))) (CL:IF (CL:EQUAL VERSION "") :NEWEST (CL:IF (CL:EQUAL VERSION "*") :WILD (MKATOM VERSION)))) :LOGICAL CL::LOGICAL) END)))
+
+(CL:DEFUN PARSE-NAMESTRING1 (FILE) (* ;;; "Given a string or atom representation of a file name, unpack it into its component parts") (* ;;; "crudely hacked from UNPACKFILENAME.STRING") (PROG ((POS 1) TEM TEM2 BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND PACKFLG DIRFLG ONEFIELDFLG) (COND ((NULL FILE) (RETURN (CONS (SUB1 POS) NIL))) ((OR (LITATOM FILE) (CL:STRINGP FILE) (NUMBERP FILE))) ((type? STREAM FILE) (* ; "For streams, use full name.  If anonymous, fake it") (SETQ FILE (OR (ffetch FULLFILENAME of FILE) (RETURN (CONS (SUB1 POS) (LIST (QUOTE NAME) FILE)))))) (T (\ILLEGAL.ARG FILE))) (COND ((SELCHARQ (NTHCHARCODE FILE 1) ({ (* ; "normal use in Interlisp-D") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE }) FILE 2) 0)))) (%[ (* ; "some Xerox and Arpanet systems use `[' for host") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]") FILE 2) 0)))) (%( (* ; "this is the standard for Xerox product file servers") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")") FILE 2) 0)))) NIL) (%%UNPACKFILE1 (QUOTE HOST) 2 TEM FILE PACKFLG ONEFIELDFLG VAL) (COND ((EQ TEM -1) (RETURN (CONS (SUB1 POS) (DREVERSE VAL))))) (SETQ POS (IPLUS TEM 2)) (SETQ HOSTP T))) (COND ((SETQ TEM (LASTCHPOS (CHARCODE %:) FILE POS)) (SETQ TEM (SUB1 TEM)) (%%UNPACKFILE1 (QUOTE DEVICE) POS TEM FILE PACKFLG ONEFIELDFLG VAL) (SETQ POS (PLUS TEM 2)) (SETQ HOSTP T))) (COND ((EQ DIRFLG (QUOTE RETURN)) (LET ((TYPE (QUOTE DIRECTORY)) (START (SELCHARQ (NTHCHARCODE FILE POS) (NIL (RETURN (CONS (SUB1 POS) (DREVERSE VAL)))) ((/ <) (ADD1 POS)) POS)) END) (SETQ END (SELCHARQ (NTHCHARCODE FILE -1) ((/ >) (COND ((AND (EQ START POS) (NOT HOSTP)) (* ; "Didn't start with a directory delimiter, but it ends with one, so this must be a subdirectory") (SETQ TYPE (QUOTE SUBDIRECTORY)))) -2) (PROGN -1))) (%%UNPACKFILE1 TYPE START END FILE PACKFLG ONEFIELDFLG VAL)) (RETURN (CONS (SUB1 POS) (DREVERSE VAL)))) ((SELCHARQ (NTHCHARCODE FILE POS) (/ (* ; "unix and the `xerox standard' use / for delimiter") (SETQ TEM (LASTCHPOS (CHARCODE /) FILE (ADD1 POS)))) ((< >) (* ; "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>.  Jericho uses >>") (SETQ TEM (LASTCHPOS (CHARCODE >) FILE (ADD1 POS)))) NIL) (%%UNPACKFILE1 (QUOTE DIRECTORY) (ADD1 POS) (SUB1 TEM) FILE PACKFLG ONEFIELDFLG VAL) (SETQ POS (ADD1 TEM)) (SETQ HOSTP T))) (OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS))) (RETURN (CONS (SUB1 POS) (DREVERSE VAL)))) NAMELP (SELCHARQ CODE ((%. ! ; NIL) (* ; "NAME and SUBDIRECTORY fields definitely terminated by now") (COND ((AND (EQ CODE (CHARCODE %.)) (NOT BEYONDNAME) (SETQ TEM2 (STRPOS "." FILE (ADD1 TEM))) (SETQ TEM2 (NTHCHAR FILE (ADD1 TEM2))) (NOT (FIXP TEM2))) (* ;; "If there's another dot followed by something other than a numeric extension, then ignore this dot, since we'll get another chance") (GO NEXTCHAR))) (COND (SUBDIREND (%%UNPACKFILE1 (QUOTE SUBDIRECTORY) POS (SUB1 SUBDIREND) FILE PACKFLG ONEFIELDFLG VAL) (SETQ POS (ADD1 SUBDIREND)) (SETQ SUBDIREND) (COND ((AND (NULL CODE) (EQ POS TEM)) (* ; "Nothing follows the subdirectory;  null name is NOT implied") (RETURN (CONS (SUB1 POS) (DREVERSE VAL))))))) (%%UNPACKFILE1 (COND ((NOT BEYONDNAME) (COND ((NEQ CODE (CHARCODE %.)) (SETQQ BEYONDEXT ;))) (SETQQ BEYONDNAME NAME)) ((NOT BEYONDEXT) (SETQ BEYONDEXT (COND ((NEQ CODE (CHARCODE %.)) (QUOTE ;)) (T T))) (QUOTE TYPE)) (T (SELCHARQ (AND (EQ BEYONDEXT (QUOTE ;)) (NTHCHARCODE FILE POS)) (P (QUOTE PROTECTION)) (A (add POS 1) (QUOTE ACCOUNT)) ((T S) (QUOTE TEMPORARY)) (QUOTE VERSION)))) POS (SUB1 TEM) FILE PACKFLG ONEFIELDFLG VAL) (COND ((NULL CODE) (* ; "End of string") (RETURN (CONS (SUB1 POS) (DREVERSE VAL))))) (SETQ POS (ADD1 TEM))) (%' (* ; "Quoter") (add TEM 1)) ((/ >) (* ; "Subdirectory terminating character") (COND ((AND (NOT HOSTP) (NOT BEYONDNAME) DIRFLG) (* ; "Ok to treat this as a subdirectory") (SETQ SUBDIREND TEM)))) NIL) NEXTCHAR (SETQ CODE (NTHCHARCODE FILE (add TEM 1))) (GO NAMELP)))
+
+(CL:DEFUN CL:TRUENAME (PATHNAME) (* ;;; "Return the pathname for the actual file described by the pathname.  An error is signaled if no such file exists.  PATHNAME can be a pathname, string, symbol, or stream.  Synonym streams are followed to their sources") (if (STREAMP PATHNAME) then (COND ((XCL:SYNONYM-STREAM-P PATHNAME) (CL:RETURN-FROM CL:TRUENAME (CL:TRUENAME (CL:SYMBOL-VALUE (CL:SYNONYM-STREAM-SYMBOL PATHNAME))))) ((NOT (fetch (STREAM NAMEDP) of PATHNAME)) (* ; "let's catch this case, rather than have the message 'The file %"%" does not exist' appear.") (CL:ERROR "The stream ~S has no corresponding named file." PATHNAME)))) (LET ((RESULT (CL:PROBE-FILE PATHNAME))) (CL:UNLESS RESULT (CL:ERROR "The file ~S does not exist." (CL:NAMESTRING PATHNAME))) RESULT))
+
+(CL:DEFUN %%MAKE-PATHNAME (HOST DEVICE DIRECTORY NAME TYPE VERSION) (%%%%MAKE-PATHNAME :HOST HOST :DEVICE DEVICE :DIRECTORY DIRECTORY :NAME NAME :TYPE TYPE :VERSION VERSION))
+
+(CL:DEFUN %%PATHNAME-EQUAL (PATHNAME1 PATHNAME2) (* ;; "RASH assumption below: HOST name comparison is ALWAYS case-insensitive") (AND (STRING-EQUAL (%%PATHNAME-HOST PATHNAME1) (%%PATHNAME-HOST PATHNAME2)) (LET ((STRING-COMPARE (OR (FETCH (PATHNAMECASE STRING-COMPARE) OF (LOOKUP-PATHNAMECASE (%%PATHNAME-HOST PATHNAME1))) (QUOTE EQUAL)))) (AND (CL:FUNCALL STRING-COMPARE (%%PATHNAME-DEVICE PATHNAME1) (%%PATHNAME-DEVICE PATHNAME2)) (CL:FUNCALL STRING-COMPARE (%%PATHNAME-NAME PATHNAME1) (%%PATHNAME-NAME PATHNAME2)) (CL:FUNCALL STRING-COMPARE (%%PATHNAME-TYPE PATHNAME1) (%%PATHNAME-TYPE PATHNAME2)) (OR (EQUAL (%%PATHNAME-VERSION PATHNAME1) (%%PATHNAME-VERSION PATHNAME2)) (AND (OR (STRINGP (%%PATHNAME-VERSION PATHNAME1)) (CL:SYMBOLP (%%PATHNAME-VERSION PATHNAME1))) (OR (STRINGP (%%PATHNAME-VERSION PATHNAME2)) (CL:SYMBOLP (%%PATHNAME-VERSION PATHNAME2))) (CL:FUNCALL STRING-COMPARE (%%PATHNAME-VERSION PATHNAME1) (%%PATHNAME-VERSION PATHNAME2)))) (OR (AND (LISTP (%%PATHNAME-DIRECTORY PATHNAME1)) (LISTP (%%PATHNAME-DIRECTORY PATHNAME2)) (CL:EVERY STRING-COMPARE (%%PATHNAME-DIRECTORY PATHNAME1) (%%PATHNAME-DIRECTORY PATHNAME2))) (EQUAL (%%PATHNAME-DIRECTORY PATHNAME1) (%%PATHNAME-DIRECTORY PATHNAME2)))))))
+
+(CL:DEFUN %%DIRECTORY-COMPONENT-EQUAL (COMPONENT1 COMPONENT2) (CL:IF (AND (%%DIRECTORY-COMPONENT-P COMPONENT1) (%%DIRECTORY-COMPONENT-P COMPONENT2)) (AND (CL:EQUAL (%%DIRECTORY-COMPONENT-TYPE COMPONENT1) (%%DIRECTORY-COMPONENT-TYPE COMPONENT2)) (CL:EQUAL (%%DIRECTORY-COMPONENT-PATH COMPONENT1) (%%DIRECTORY-COMPONENT-PATH COMPONENT2))) (CL:EQUAL COMPONENT1 COMPONENT2)))
+
+(CL:DEFUN %%INITIALIZE-DEFAULT-PATHNAME NIL (* ;; "This mess used to have *DEFAULT-PATHNAME-DEFAULTS* declared as a GLOBALVAR.  The problem with that was that the BYTECOMPILER leaves the GLOBALVAR declaration in the environment as a side effect, which screws anything compiled afterwards.  *SIGH*... ") (DECLARE (GLOBALVARS \CONNECTED.DIRECTORY)) (if (NOT (BOUNDP (QUOTE \CONNECTED.DIRECTORY))) then (SETQ \CONNECTED.DIRECTORY (QUOTE {DSK}))) (SETTOPVAL (QUOTE *DEFAULT-PATHNAME-DEFAULTS*) (CL:PARSE-NAMESTRING \CONNECTED.DIRECTORY (FILENAMEFIELD \CONNECTED.DIRECTORY (QUOTE HOST)))) (CL:SETF (%%PATHNAME-VERSION (GETTOPVAL (QUOTE *DEFAULT-PATHNAME-DEFAULTS*))) :NEWEST) (GETTOPVAL (QUOTE *DEFAULT-PATHNAME-DEFAULTS*)))
+
+(CL:DEFVAR *DEFAULT-PATHNAME-DEFAULTS*)
+
+(CL:DEFVAR CL::*LOGICAL-PATHNAME-TRANSLATION-TABLE* (CL:MAKE-HASH-TABLE :TEST (CL:FUNCTION CL:EQUAL)))
+
+(CL:DEFCONSTANT CL::LOGICAL-WORD-BITTABLE (MAKEBITTABLE (MAPCAR (QUOTE (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 0 1 2 3 4 5 6 7 8 9 - *)) (CL:FUNCTION CHARCODE)) T))
+
+(CL:DEFVAR \HOSTTOPATHNAMECASE (* ;; "Assoc list relating hosts and their case preferences") (LIST (create PATHNAMECASE HOST-NAME _ (QUOTE DSK) STRING-COMPARE _ (QUOTE STRING-EQUAL) LOCAL-TO-COMMON _ (QUOTE FLIP-MONOCASE) COMMON-TO-LOCAL _ (QUOTE FLIP-MONOCASE)) (create PATHNAMECASE HOST-NAME _ (QUOTE CORE) STRING-COMPARE _ (QUOTE STRING-EQUAL) LOCAL-TO-COMMON _ (QUOTE FLIP-MONOCASE) COMMON-TO-LOCAL _ (QUOTE FLIP-MONOCASE)) (create PATHNAMECASE HOST-NAME _ (QUOTE UNIX) STRING-COMPARE _ (QUOTE CL:STRING=) LOCAL-TO-COMMON _ (QUOTE FLIP-MONOCASE) COMMON-TO-LOCAL _ (QUOTE FLIP-MONOCASE)) (create PATHNAMECASE HOST-NAME _ (QUOTE FLOPPY) STRING-COMPARE _ (QUOTE STRING-EQUAL) LOCAL-TO-COMMON _ (QUOTE FLIP-MONOCASE) COMMON-TO-LOCAL _ (QUOTE FLIP-MONOCASE))))
+
+
+
+(* ;; "Interlisp-D compatibility")
+
+
+(CL:DEFUN INTERLISP-NAMESTRING (PATHNAME) (* ;;; "Returns the full form of PATHNAME as an Interlisp string.") (MKSTRING (CL:NAMESTRING PATHNAME)))
+
+(CL:DEFUN UNPACKPATHNAME.STRING (FILE &OPTIONAL ONEFIELDFLG DIRFLG ATOMFLG) (* ;; "Simulate the action of UNPACKFILENAME.STRING on a pathname") (* ;; "") (DECLARE (IGNORE DIRFLG)) (if ONEFIELDFLG then (AND (CL:CONSP ONEFIELDFLG) (SETQ ONEFIELDFLG (CAR (CL:INTERSECTION ONEFIELDFLG (QUOTE (HOST DEVICE DIRECTORY NAME EXTENSION VERSION)))))) (LET ((RESULT (CASE ONEFIELDFLG (HOST (CL:PATHNAME-HOST FILE)) (DEVICE (CL:PATHNAME-DEVICE FILE)) (DIRECTORY (CL:PATHNAME-DIRECTORY FILE)) (NAME (CL:PATHNAME-NAME FILE)) (EXTENSION (CL:PATHNAME-TYPE FILE)) (VERSION (CL:PATHNAME-VERSION FILE)) (CL:OTHERWISE NIL)))) (if ATOMFLG then (MKATOM RESULT) else RESULT)) else (LET ((COMPONENT)) (APPEND (if (SETQ COMPONENT (CL:PATHNAME-HOST FILE)) then (LIST (QUOTE HOST) (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT) COMPONENT)) (if (SETQ COMPONENT (CL:PATHNAME-DEVICE FILE)) then (LIST (QUOTE DEVICE) (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT))) (if (SETQ COMPONENT (CL:PATHNAME-DIRECTORY FILE)) then (LIST (QUOTE DIRECTORY) (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT))) (if (SETQ COMPONENT (CL:PATHNAME-NAME FILE)) then (LIST (QUOTE NAME) (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT))) (if (SETQ COMPONENT (CL:PATHNAME-TYPE FILE)) then (LIST (QUOTE EXTENSION) (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT))) (if (SETQ COMPONENT (CL:PATHNAME-VERSION FILE)) then (LIST (QUOTE VERSION) (if ATOMFLG then (MKATOM COMPONENT) else (MKSTRING COMPONENT))))))))
+
+(CL:DEFUN CL:FILE-NAMESTRING (PATHNAME) (LET* ((*PRINT-BASE* 10) (*PRINT-RADIX* NIL) (PATH (PATHNAME PATHNAME)) (NAME (CL::MUNG-PATHNAME-ELT (%%PATHNAME-NAME PATH))) (TYPE (CL::MUNG-PATHNAME-ELT (%%PATHNAME-TYPE PATH))) (RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) (MKSTRING (%%COMPONENT-STRING NAME)) "." (MKSTRING (%%COMPONENT-STRING TYPE)))) (VERSION (%%PATHNAME-VERSION PATH)) (CL::LOGICAL? (CL::LOGICAL-PATHNAME-P PATH))) (CL:WHEN (AND VERSION (NOT (EQ VERSION :UNSPECIFIC))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CL:IF CL::LOGICAL? "." (CL:THIRD \FILENAME.SYNTAX)) (CASE VERSION (:WILD "*") (:NEWEST (CL:IF CL::LOGICAL? "NEWEST")) (CL:OTHERWISE (CL:PRINC-TO-STRING VERSION)))))) RESULT))
+
+(CL:DEFUN CL:DIRECTORY-NAMESTRING (PATHNAME) (* ;; "Returns the directory part of PATHNAME as a string.") (LET ((CL::DL (CL:PATHNAME-DIRECTORY PATHNAME))) (CASE CL::DL ((:UNSPECIFIC NIL) "") (CL:OTHERWISE (LET ((CL::SEPERATOR (CL:IF (CL::LOGICAL-PATHNAME-P PATHNAME) ";" (CL:SECOND \FILENAME.SYNTAX)))) (CL:LABELS ((CL::CRUNCH-ELEMENTS (CL::L) (CL:IF (NULL (CDR CL::L)) (CL::MUNG-PATHNAME-ELT (CAR CL::L)) (CL:CONCATENATE (QUOTE STRING) (CL::MUNG-PATHNAME-ELT (CAR CL::L)) CL::SEPERATOR (CL::CRUNCH-ELEMENTS (CDR CL::L)))))) (CL:CONCATENATE (QUOTE STRING) (CL::CRUNCH-ELEMENTS (CDR CL::DL)) (AND (EQ (CAR CL::DL) :RELATIVE) CL::SEPERATOR))))))))
+
+
+
+(* ;; 
+"Backward compatibility with old directory-components (superceded by CLtL2 list-structured components)"
+)
+
+
+(CL:DEFUN %%CONVERT-DIRECTORY-COMPONENT (DC) (* ;; "Takes a DIRECTORY-COMPONENT and returns a CLtL2-style structured directory list") (SELECTQ (%%DIRECTORY-COMPONENT-TYPE DC) (:RELATIVE (LET ((PDP (%%PARSE-DIRECTORY-PATH (%%DIRECTORY-COMPONENT-PATH DC)))) (IF (LISTP PDP) THEN (CONS :RELATIVE PDP) ELSE (LIST :RELATIVE PDP)))) (:DIRECTORY (LET ((PDP (%%PARSE-DIRECTORY-PATH (%%DIRECTORY-COMPONENT-PATH DC)))) (IF (LISTP PDP) THEN (CONS :ABSOLUTE PDP) ELSE (LIST :ABSOLUTE PDP)))) (ERROR "Funky directory-component type" (%%DIRECTORY-COMPONENT-TYPE DC))))
+
+
+
+(* ;; "Funky pattern matcher for logical pathname support")
+
+
+(CL:DEFUN CL::MATCH&MAP (CL::PAT CL::STR) (* ;; "PAT and STR are strings; PAT contains one or more * wildcards.The result, *MAP* is a list of (startchar . endchar) pairs of the pieces of STR that match the wildcards in PAT. (< endchar startchar) means that wildcard matched the null string") (LET ((CL::*MAP* NIL)) (DECLARE (CL:SPECIAL CL::*MAP*)) (AND (CL::MM1 CL::PAT 0 CL::STR 0) CL::*MAP*)))
+
+(CL:DEFUN CL::MM1 (CL::PAT CL::PP CL::STR CL::SP) (COND ((AND (>= CL::PP (CL:LENGTH CL::PAT)) (>= CL::SP (CL:LENGTH CL::STR)))) ((OR (>= CL::PP (CL:LENGTH CL::PAT)) (>= CL::SP (CL:LENGTH CL::STR))) NIL) ((EQL (CL:CHAR CL::PAT CL::PP) #\*) (LET ((CL::STAREND CL::SP) (CL::PP+1 (CL:1+ CL::PP)) CL::MATCHED?) (CL:IF (EQ CL::PP+1 (CL:LENGTH CL::PAT)) (CL:SETQ CL::MATCHED? T CL::STAREND (CL:LENGTH CL::STR)) (WHILE (AND (< CL::STAREND (CL:LENGTH CL::STR)) (NULL (CL:SETQ CL::MATCHED? (CL::MM1 CL::PAT CL::PP+1 CL::STR CL::STAREND)))) DO (CL:INCF CL::STAREND))) (CL:IF CL::MATCHED? (CL:PUSH (CONS CL::SP CL::STAREND) CL::*MAP*)))) ((AND (EQL (CL:CHAR CL::PAT CL::PP) (CL:CHAR CL::STR CL::SP)) (CL::MM1 CL::PAT (CL:1+ CL::PP) CL::STR (CL:1+ CL::SP))))))
+
+(CL:DEFUN CL::MATCH-DIRECTORY-LISTS (CL::P CL::W) (CL:IF (AND (OR (CL:EQUAL CL::W (QUOTE (:ABSOLUTE :WILD-INFERIORS))) (CL:EQUAL CL::W (QUOTE (:RELATIVE :WILD-INFERIORS)))) (EQ (CAR CL::P) (CAR CL::W))) (CL:VALUES T (LIST (CONS 1 (CL:LENGTH CL::P)))) (LET ((CL::*MAP* NIL)) (DECLARE (CL:SPECIAL CL::*MAP*)) (CL:IF (CL::MDL1 CL::P 0 CL::W) (CL:VALUES T CL::*MAP*)))))
+
+(CL:DEFUN CL::MDL1 (CL::P CL::PL CL::W) (COND ((AND (NULL CL::P) (NULL CL::W))) ((OR (NULL CL::P) (NULL CL::W)) NIL) ((EQ (CAR CL::W) :WILD) (AND (CL::MDL1 (CDR CL::P) (CL:1+ CL::PL) (CDR CL::W)) (CL:PUSH (CONS CL::PL (CL:1+ CL::PL)) CL::*MAP*))) ((CL:EQUAL (CAR CL::P) (CAR CL::W)) (CL::MDL1 (CDR CL::P) (CL:1+ CL::PL) (CDR CL::W))) ((EQ (CAR CL::W) :WILD-INFERIORS) (LET ((CL::PS CL::PL) CL::MATCHED) (CL:IF (NULL (CDR CL::W)) (CL:PUSH (CONS CL::PL (+ CL::PL (CL:LENGTH CL::P))) CL::*MAP*) (PROGN (WHILE (AND CL::P (NULL (CL:SETQ CL::MATCHED (CL::MDL1 CL::P CL::PL (CDR CL::W))))) DO (CL:INCF CL::PL) (CL:POP CL::P)) (CL:IF CL::MATCHED (CL:PUSH (CONS CL::PS CL::PL) CL::*MAP*)))))) ((AND (CL:STRINGP (CAR CL::P)) (CL:STRINGP (CAR CL::W))) (LET ((CL::MM (CL::MATCH&MAP (CAR CL::W) (CAR CL::P)))) (CL:WHEN (AND CL::MM (CL::MDL1 (CDR CL::P) (CL:1+ CL::PL) (CDR CL::W))) (CL:PUSH (CONS CL::PL CL::MM) CL::*MAP*))))))
+
+
+
+(* ;; "Direct logical pathname support")
+
+
+(DEF-DEFINE-TYPE CL::LOGICAL-HOSTS "Logical hosts" :UNDEFINER CL::UNDEFINE-LOGICAL-HOST)
+
+(DEFDEFINER CL::DEF-LOGICAL-HOST CL::LOGICAL-HOSTS (CL::HOST &REST CL::TRANSFORMS) (BQUOTE (CL:SETF (CL:LOGICAL-PATHNAME-TRANSLATIONS (\, CL::HOST)) (QUOTE (\, CL::TRANSFORMS)))))
+
+(CL:DEFUN CL::UNDEFINE-LOGICAL-HOST (CL::HOST) (CL:SETF (CL:LOGICAL-PATHNAME-TRANSLATIONS CL::HOST) NIL))
+
+(CL:DEFUN CL:LOGICAL-PATHNAME-TRANSLATIONS (CL::HOST) (COND ((AND (CL:STRINGP CL::HOST) (CL:GETHASH (U-CASE CL::HOST) CL::*LOGICAL-PATHNAME-TRANSLATION-TABLE*))) (T (CL:ERROR "Not a logical host:~s" CL::HOST))))
+
+(CL:DEFUN CL::UNDOABLY-SETF-LOGICAL-PATHNAME-TRANSLATIONS (CL::HOST CL::TRANSLATIONS) (UNDOABLY-SETF (CL:GETHASH (U-CASE CL::HOST) CL::*LOGICAL-PATHNAME-TRANSLATION-TABLE*) CL::TRANSLATIONS))
+
+(CL:DEFSETF CL:LOGICAL-PATHNAME-TRANSLATIONS (CL::HOST) (CL::TRANSLATIONS) (BQUOTE (CL:SETF (CL:GETHASH (U-CASE (\, CL::HOST)) CL::*LOGICAL-PATHNAME-TRANSLATION-TABLE*) (\, CL::TRANSLATIONS))))
+
+(PUTPROPS CL:LOGICAL-PATHNAME-TRANSLATIONS :UNDOABLE-SETF-INVERSE CL::UNDOABLY-SETF-LOGICAL-PATHNAME-TRANSLATIONS)
+
+(CL:DEFUN CL::LOGICAL-HOST-P (CL::HOST) (AND (CL:GETHASH (U-CASE CL::HOST) CL::*LOGICAL-PATHNAME-TRANSLATION-TABLE*) T))
+
+(CL:DEFUN CL::MUNG-PATHNAME-ELT (CL::X) (CASE CL::X (:WILD "*") (:WILD-INFERIORS "**") (:BACK "..") (:UNSPECIFIC NIL) (T CL::X)))
+
+(CL:DEFUN CL:LOGICAL-PATHNAME (PATHNAME) (CL:FLET ((CL::LOGICAL-PATHNAME-STREAM-P (CL::S) (CL::LOGICAL-PATHNAME-P (PATHNAME CL::S)))) (CL:ETYPECASE PATHNAME (CL:LOGICAL-PATHNAME PATHNAME) ((AND STREAM (SATISFIES CL::LOGICAL-PATHNAME-STREAM-P)) (PATHNAME PATHNAME)) ((OR CL:SYMBOL STRING) (CL:WHEN (CL:SYMBOLP PATHNAME) (CL:WHEN (OR *CLTL2-PEDANTIC* (NULL PATHNAME)) (XCL::SYMBOL-AS-PATHNAME PATHNAME (QUOTE CL:LOGICAL-PATHNAME))) (CL:SETQ PATHNAME (CL:SYMBOL-NAME PATHNAME))) (CL:PARSE-NAMESTRING PATHNAME NIL NIL :LOGICAL T)))))
+
+(CL:DEFUN CL:PATHNAME-MATCH-P (PATHNAME CL::WILDNAME) (* ;; "Minor extension; if a match fails, return (VALUES NIL :keyword) where :keyword points to the slot that failed.  The messy nested IF below allows the mulitple-values to return") (CL:SETQ PATHNAME (PATHNAME PATHNAME)) (CL:SETQ CL::WILDNAME (PATHNAME CL::WILDNAME)) (LET ((CL::UPCASE? T)) (CL:FLET ((CL::MATCH-SIMPLE-SLOTS (CL::P CL::W) (COND ((NULL CL::W)) ((EQ CL::W :WILD)) ((EQ CL::W :UNSPECIFIC) (EQ CL::P :UNSPECIFIC)) ((CL:EQUAL CL::W CL::P)) ((CL:STRINGP CL::W) (AND (CL:STRINGP CL::P) (OR (AND CL::UPCASE? (STRING-EQUAL CL::P CL::W)) (CL::MATCH&MAP (CL:IF CL::UPCASE? (U-CASE-STRINGS CL::W) CL::W) (CL:IF CL::UPCASE? (U-CASE-STRINGS CL::P) CL::P)))))))) (CL:IF (CL::MATCH-SIMPLE-SLOTS (%%PATHNAME-HOST PATHNAME) (%%PATHNAME-HOST CL::WILDNAME)) (PROGN (CL:SETQ CL::UPCASE? (EQ (QUOTE STRING-EQUAL) (FETCH (PATHNAMECASE STRING-COMPARE) OF (LOOKUP-PATHNAMECASE (CL:PATHNAME-HOST PATHNAME))))) (CL:IF (CL::MATCH-SIMPLE-SLOTS (%%PATHNAME-DEVICE PATHNAME) (%%PATHNAME-DEVICE CL::WILDNAME)) (CL:IF (CL::MATCH-SIMPLE-SLOTS (%%PATHNAME-NAME PATHNAME) (%%PATHNAME-NAME CL::WILDNAME)) (CL:IF (CL::MATCH-SIMPLE-SLOTS (%%PATHNAME-TYPE PATHNAME) (%%PATHNAME-TYPE CL::WILDNAME)) (CL:IF (CL::MATCH-SIMPLE-SLOTS (%%PATHNAME-VERSION PATHNAME) (%%PATHNAME-VERSION CL::WILDNAME) :VERSION) (LET ((CL::P (%%PATHNAME-DIRECTORY PATHNAME)) (CL::W (%%PATHNAME-DIRECTORY CL::WILDNAME))) (COND ((NULL CL::W)) ((AND (EQ CL::W :UNSPECIFIC) (EQ CL::P :UNSPECIFIC))) ((AND (CL:LISTP CL::P) (CL:LISTP CL::W) (CL::MATCH-DIRECTORY-LISTS (CL:IF CL::UPCASE? (U-CASE-STRINGS CL::P) CL::P) (CL:IF CL::UPCASE? (U-CASE-STRINGS CL::W) CL::W)))) (T (CL:VALUES NIL :DIRECTORY)))) (CL:VALUES NIL :VERSION)) (CL:VALUES NIL :TYPE)) (CL:VALUES NIL :NAME)) (CL:VALUES NIL :DEVICE))) (CL:VALUES NIL :HOST)))))
+
+(CL:DEFUN CL:TRANSLATE-LOGICAL-PATHNAME (PATHNAME &KEY &ALLOW-OTHER-KEYS) (CL:ETYPECASE PATHNAME (PATHNAME) (STREAM (CL:SETQ PATHNAME (PATHNAME PATHNAME))) ((OR CL:SYMBOL STRING) (CL:WHEN (CL:SYMBOLP PATHNAME) (CL:WHEN (OR *CLTL2-PEDANTIC* (NULL PATHNAME)) (XCL::SYMBOL-AS-PATHNAME PATHNAME (QUOTE CL:TRANSLATE-LOGICAL-PATHNAME))) (CL:SETQ PATHNAME (CL:SYMBOL-NAME PATHNAME))) (* ;; "Minor hackish extension here.  If PATHNAME is a string and it begins with %"mumble:%" where mumble is a known logical hostname, try parsing it as a logical pathname string") (CL:SETQ PATHNAME (U-CASE PATHNAME)) (LET* ((CL::COLONLOC (STRPOSL CL::LOGICAL-WORD-BITTABLE PATHNAME)) (CL::HOSTNAME (AND CL::COLONLOC (CL:EQUAL (SUBSTRING PATHNAME CL::COLONLOC CL::COLONLOC) ":") (SUBSTRING PATHNAME 1 (CL:1- CL::COLONLOC))))) (CL:SETQ PATHNAME (CL:IF (CL::LOGICAL-HOST-P CL::HOSTNAME) (CL:PARSE-NAMESTRING PATHNAME CL::HOSTNAME) (PATHNAME PATHNAME)))))) (WHILE (CL::LOGICAL-PATHNAME-P PATHNAME) DO (FOR CL::TR IN (CL:LOGICAL-PATHNAME-TRANSLATIONS (CL:PATHNAME-HOST PATHNAME)) BIND CL::LPN WHEN (CL:PATHNAME-MATCH-P PATHNAME (CL:SETQ CL::LPN (CL:LOGICAL-PATHNAME (CAR CL::TR)))) DO (CL:SETQ PATHNAME (CL:TRANSLATE-PATHNAME PATHNAME CL::LPN (CADR CL::TR))) (RETURN NIL) FINALLY (CL:ERROR "~S doesn't match any LOGICAL-PATHNAME-TRANSLATIONS" PATHNAME))) PATHNAME)
+
+(CL:DEFUN CL:TRANSLATE-PATHNAME (CL::SOURCE CL::FROM-WILDNAME CL::TO-WILDNAME) (CL:SETQ CL::SOURCE (PATHNAME CL::SOURCE) CL::FROM-WILDNAME (PATHNAME CL::FROM-WILDNAME)) (CL:UNLESS (CL:PATHNAME-MATCH-P CL::SOURCE CL::FROM-WILDNAME) (CL:ERROR "~S doesn't match ~S in TRANSLATE-PATHNAME" CL::SOURCE CL::FROM-WILDNAME)) (CL:SETQ CL::TO-WILDNAME (PATHNAME CL::TO-WILDNAME)) (* ;; "NOTE: this mess currently does nothing about case mangling; this must be handled somewhere") (* ;; "This mess translates according to the suggested implementation in CLtL2: corresponding parts of pathnames are merged seperately and directory components are merged by order,not by correspondence of subdirectory entry") (* ;; "Example: (TRANSLATE-PATHNAME %"/foo/bar/baz%" %"/foo/*a*/*%" %"/a/*/*/c*%") => #P%"/a/b/r/cbaz%"") (* ;; "Two fairly obvious restrictions on the above are imposed:") (* ;; "A :WILD-INFERIORS matching multiple directory levels will not be used to fill in a :WILD or a * wildcard") (* ;; "Anything matching NIL will not fill in a :WILD or a :WILD-INFERIORS") (CL:LABELS ((CL::MERGE-FROM-MAP (CL:MAP CL::S CL::TW) (* ;; "Some sort of funky loop here walking down the map and picking chunks out of s and gluing them into tw") (LET ((CL::TS 0) CL::TP (CL::RESULT "")) (WHILE (AND CL:MAP (CL:SETQ CL::TP (CL:POSITION #\* CL::TW :START CL::TS))) DO (DESTRUCTURING-BIND (CL::SS . CL::SE) (CL:POP CL:MAP) (CL:IF (<= CL::SS CL::SE) (CL:SETQ CL::RESULT (CL:CONCATENATE (QUOTE STRING) CL::RESULT (AND (< CL::TS CL::TP) (CL:SUBSEQ CL::TW CL::TS CL::TP)) (CL:SUBSEQ CL::S CL::SS CL::SE)))) (CL:SETQ CL::TS (CL:1+ CL::TP)))) (CL:IF (< CL::TS (CL:LENGTH CL::TW)) (CL:SETQ CL::RESULT (CL:CONCATENATE (QUOTE STRING) CL::RESULT (CL:SUBSEQ CL::TW CL::TS)))) (CL:VALUES CL::RESULT CL:MAP))) (CL::MERGE-STRINGY-SLOT (CL::S CL::FW CL::TW) (COND ((OR (NULL CL::TW) (EQ CL::TW :WILD)) CL::S) ((AND (CL:STRINGP CL::TW) (STRPOS "*" CL::TW)) (CL:IF (CL:STRINGP CL::S) (LET ((CL:MAP (COND ((OR (EQ CL::FW :WILD) (AND (CL:STRINGP CL::FW) (CL:STRING= CL::S CL::FW))) (BQUOTE ((0 \, (CL:LENGTH CL::S))))) ((STRPOS "*" CL::FW) (CL::MATCH&MAP CL::FW CL::S))))) (CL:IF (NULL CL:MAP) (CL:ERROR "From-wildname piece and source piece don't match" CL::FW CL::S) (CL::MERGE-FROM-MAP CL:MAP CL::S CL::TW))) (CL:ERROR "Can't take anything from ~s to translate" CL::S))) (T CL::TW)))) (CL:MACROLET ((CL::CALL-WITH-THREE (CL::FETCHER) (BQUOTE (CL::MERGE-STRINGY-SLOT ((\, CL::FETCHER) CL::SOURCE) ((\, CL::FETCHER) CL::FROM-WILDNAME) ((\, CL::FETCHER) CL::TO-WILDNAME))))) (CL:MAKE-PATHNAME :HOST (CL::CALL-WITH-THREE CL:PATHNAME-HOST) :DEVICE (CL::CALL-WITH-THREE CL:PATHNAME-DEVICE) :NAME (CL::CALL-WITH-THREE CL:PATHNAME-NAME) :TYPE (CL::CALL-WITH-THREE CL:PATHNAME-TYPE) :VERSION (CL::CALL-WITH-THREE CL:PATHNAME-VERSION) :DIRECTORY (LET ((CL::S (CL:PATHNAME-DIRECTORY CL::SOURCE)) (CL::FW (CL:PATHNAME-DIRECTORY CL::FROM-WILDNAME)) (CL::TW (CL:PATHNAME-DIRECTORY CL::TO-WILDNAME)) CL::PIECES CL::RESULT) (COND ((OR (NULL CL::TW) (CL:EQUAL CL::TW (QUOTE (:ABSOLUTE :WILD-INFERIORS)))) CL::S) ((OR (NOT (CL:LISTP CL::TW)) (CL:EVERY (CL:FUNCTION (CL:LAMBDA (CL::X) (AND (NOT (EQ CL::X :WILD)) (NOT (EQ CL::X :WILD-INFERIORS)) (OR (NOT (CL:STRINGP CL::X)) (NOT (STRPOS "*" CL::X)))))) (CDR CL::TW))) CL::TW) (T (CL:UNLESS (CL:CONSP CL::S) (CL:ERROR "Can't take anything from ~s to translate" CL::S)) (CL:WHEN (OR (NOT (CL:CONSP CL::FW)) (EQ CL::FW (QUOTE (:ABSOLUTE :WILD-INFERIORS)))) (CL:ERROR "Can't map this mess: ~s" CL::FW)) (* ;; "Well, we seem to have a sane set of directories; let's try and make some sense of them") (CL:FLET ((CL::POP-A-PIECE NIL (CL:WHEN (NULL CL::PIECES) (CL:ERROR "Ran out of wildcards in TRANSLATE-PATHNAME")) (DESTRUCTURING-BIND (CL:ELT . CL:MAP) (CAR CL::PIECES) (COND ((CL:NUMBERP CL:MAP) (CL:POP CL::PIECES) (COND ((EQ CL:ELT CL:MAP) NIL) ((EQ CL:ELT (CL:1- CL:MAP)) (CL:ELT CL::S CL:ELT)) (T (CL:SUBSEQ CL::S CL:ELT CL:MAP)))) (T (DESTRUCTURING-BIND (CL::SS . CL::SE) (CL:POP CL:MAP) (PROG1 (CL:IF (< CL::SE CL::SS) NIL (CL:SUBSEQ (CL:ELT CL::S CL:ELT) CL::SS CL::SE)) (CL:IF (NULL CL:MAP) (CL:POP CL::PIECES) (CL:POP (CDAR CL::PIECES)))))))))) (CL:MULTIPLE-VALUE-SETQ (CL::RESULT CL::PIECES) (CL::MATCH-DIRECTORY-LISTS CL::S CL::FW)) (CL:IF CL::RESULT (CL:SETQ CL::RESULT NIL) (CL:ERROR "How can these not match?  They matched a minute ago:~S ~S" CL::S CL::FW)) (* ;; "OK; PIECES is a list of references to parts of S.  They are either (start-element . end-element) or (start-element (map . pair)...).  We now walk TP, filling in its wild elements from PIECES") (CL:DO* ((CL::TP (CDR CL::TW) (CDR CL::TP)) (CL::TF (CAR CL::TP) (CAR CL::TP)) (CL::PP) (CL::STARPOS) (CL::OLDSTAR) (CL::ELTLIST)) ((NULL CL::TP) (CONS (CAR CL::S) (CL:NREVERSE CL::RESULT))) (COND ((EQ CL::TF :WILD-INFERIORS) (COND ((CL:CONSP (CL:SETQ CL::PP (CL::POP-A-PIECE))) (CL:DOLIST (CL::P CL::PP) (CL:PUSH CL::P CL::RESULT))) ((NULL CL::PP) (CL:ERROR "NIL can't match :WILD-INFERIORS")) (T (CL:PUSH CL::PP CL::RESULT)))) ((EQ CL::TF :WILD) (COND ((CL:CONSP (CL:SETQ CL::PP (CL::POP-A-PIECE))) (CL:ERROR "Multiple directory levels ~s can't match :WILD" CL::PP)) ((NULL CL::PP) (CL:ERROR "NIL can't match :WILD-INFERIORS")) (T (CL:PUSH CL::PP CL::RESULT)))) ((CL:SETQ CL::STARPOS (CL:POSITION #\* CL::TF)) (CL:SETQ CL::ELTLIST NIL) (CL:SETQ CL::OLDSTAR 0) (WHILE CL::STARPOS DO (CL:PUSH (CL:SUBSEQ CL::TF CL::OLDSTAR CL::STARPOS) CL::ELTLIST) (CL:WHEN (NULL (CAR CL::ELTLIST)) (CL:POP CL::ELTLIST)) (CL:PUSH (CL:SETQ CL::PP (CL::POP-A-PIECE)) CL::ELTLIST) (CL:WHEN (CL:LISTP CL::PP) (CL:ERROR "Can't match *: ~s" CL::PP)) (CL:SETQ CL::OLDSTAR (CL:1+ CL::STARPOS)) (CL:SETQ CL::STARPOS (CL:POSITION #\* CL::TF :START CL::OLDSTAR)) FINALLY (CL:IF (< CL::OLDSTAR (CL:LENGTH CL::TF)) (CL:PUSH (CL:SUBSEQ CL::TF CL::OLDSTAR) CL::ELTLIST)) (CL:PUSH (CL:APPLY (CL:FUNCTION CL:CONCATENATE) (CONS (QUOTE STRING) (CL:NREVERSE CL::ELTLIST))) CL::RESULT))) (T (CL:PUSH CL::TF CL::RESULT))))))))))))
+
+(CL:DEFUN CL:LOAD-LOGICAL-PATHNAME-TRANSLATIONS (CL::HOST) (CL:UNLESS (CL:STRINGP CL::HOST) (CL:ERROR "~S not a string" CL::HOST)) (CL:UNLESS (CL::LOGICAL-HOST-P CL::HOST) (CL:DOLIST (CL::PLACE (QUOTE ("LOGICAL-HOSTS" "{DSK}~/LOGICAL-HOSTS" "{DSK}/usr/local/lde/LOGICAL-HOSTS"))) (* ;; "We'll look in 1) the current directory 2) the user's home directory 3) {DSK}<usr>local>lde> for a file named LOGICAL-HOSTS which is then LOADed; it may contain (SETF (LOGICAL-PATHNAME-TRANSLATIONS host) '((trans lations))) forms or LOGICAL-HOSTS filecom forms") (CL:WHEN (CL:PROBE-FILE CL::PLACE) (CL:LOAD CL::PLACE) (CL:IF (CL::LOGICAL-HOST-P CL::HOST) (CL:RETURN-FROM CL:LOAD-LOGICAL-PATHNAME-TRANSLATIONS T)))) (CL:ERROR "Found no translations for ~s" CL::HOST)))
+
+(CL:DEFUN CL:WILD-PATHNAME-P (PATHNAME &OPTIONAL CL::FIELD-KEY) (CL:SETQ PATHNAME (PATHNAME PATHNAME)) (CL:FLET ((CL::WILD-VALUE (CL::V) (OR (EQ CL::V :WILD) (AND (CL:STRINGP CL::V) (STRPOS "*" CL::V) T))) (CL::WILD-DIR-VALUE (CL::V) (OR (EQ CL::V :WILD) (EQ CL::V :WILD-INFERIORS) (AND (CL:STRINGP CL::V) (STRPOS "*" CL::V) T)))) (CL:ECASE CL::FIELD-KEY (:HOST (CL::WILD-VALUE (CL:PATHNAME-HOST PATHNAME))) (:DEVICE (CL::WILD-VALUE (CL:PATHNAME-DEVICE PATHNAME))) (:NAME (CL::WILD-VALUE (CL:PATHNAME-NAME PATHNAME))) (:TYPE (CL::WILD-VALUE (CL:PATHNAME-TYPE PATHNAME))) (:VERSION (CL::WILD-VALUE (CL:PATHNAME-VERSION PATHNAME))) (:DIRECTORY (AND (CL:CONSP (CL:PATHNAME-DIRECTORY PATHNAME)) (CL:SOME (CL:FUNCTION CL::WILD-DIR-VALUE) (CL:PATHNAME-DIRECTORY PATHNAME)))) ((NIL) (OR (CL::WILD-VALUE (CL:PATHNAME-HOST PATHNAME)) (CL::WILD-VALUE (CL:PATHNAME-DEVICE PATHNAME)) (CL::WILD-VALUE (CL:PATHNAME-NAME PATHNAME)) (CL::WILD-VALUE (CL:PATHNAME-TYPE PATHNAME)) (CL::WILD-VALUE (CL:PATHNAME-VERSION PATHNAME)) (AND (CL:CONSP (CL:PATHNAME-DIRECTORY PATHNAME)) (CL:SOME (CL:FUNCTION CL::WILD-DIR-VALUE) (CL:PATHNAME-DIRECTORY PATHNAME))))))))
+
+(CL:DEFUN LOOKUP-PATHNAMECASE (HOST) (* ;; "Returns a PATHNAMECASE record corresponding to HOST; also registers HOST on \HOSTTOPATHNAMECASE list.  Default registration is case-sensitive comparison and monocase-string case inversion.  The initial value of \HOSTTOPATHNAMECASE will handle the most common devices (DSK, UNIX, FLOPPY), and we have special hacks checking for NS and PUP hosts, so users should only have to register stuff like TCP and NFS devices.") (CL:FLET ((LOOKITUP (HOST) (COND ((FASSOC HOST \HOSTTOPATHNAMECASE)) ((OR (STRPOS ":" HOST) (ETHERHOSTNUMBER HOST)) (PUSH \HOSTTOPATHNAMECASE (create PATHNAMECASE HOST-NAME _ HOST STRING-COMPARE _ (QUOTE STRING-EQUAL) LOCAL-TO-COMMON _ (QUOTE FLIP-MONOCASE-STRING) COMMON-TO-LOCAL _ (QUOTE FLIP-MONOCASE-STRING))) (CAR \HOSTTOPATHNAMECASE))))) (* ;; "The perverse structure is here to try and avoid calling CANONICAL.HOSTNAME unless absolutely necessary; it's SLOW") (IF (OR (EQ HOST :WILD) (STRPOS "*" HOST)) THEN (CONSTANT (create PATHNAMECASE HOST-NAME _ NIL STRING-COMPARE _ (QUOTE CL:STRING=) LOCAL-TO-COMMON _ (QUOTE CL:IDENTITY) COMMON-TO-LOCAL _ (QUOTE CL:IDENTITY))) ELSE (SETQ HOST (U-CASE HOST)) (IF (CL::LOGICAL-HOST-P HOST) THEN (CONSTANT (create PATHNAMECASE HOST-NAME _ NIL STRING-COMPARE _ (QUOTE STRING-EQUAL) LOCAL-TO-COMMON _ (QUOTE CL:IDENTITY) COMMON-TO-LOCAL _ (CL:FUNCTION (LAMBDA (X) (if (STRINGP X) then (U-CASE X) else X))))) ELSE (SETQ HOST (MKATOM HOST)) (LET (CH) (COND ((LOOKITUP HOST)) ((AND (SETQ CH (CANONICAL.HOSTNAME HOST)) (LOOKITUP CH))) (T (* ; "Punt and assume case-sensitivity") (PUSH \HOSTTOPATHNAMECASE (create PATHNAMECASE HOST-NAME _ HOST STRING-COMPARE _ (QUOTE EQUAL) LOCAL-TO-COMMON _ (QUOTE FLIP-MONOCASE-STRING) COMMON-TO-LOCAL _ (QUOTE FLIP-MONOCASE-STRING))) (CAR \HOSTTOPATHNAMECASE))))))))
+
+(CL:DEFUN REGISTER-PATHNAMECASE (HOST/DEVICE &KEY (STRING-COMPARE (QUOTE CL:STRING=) S-P) (LOCAL-TO-COMMON (QUOTE FLIP-MONOCASE-STRING) L-P) (COMMON-TO-LOCAL (QUOTE FLIP-MONOCASE-STRING) C-P) CASE-INSENSITIVE) (SETQ HOST/DEVICE (OR (CANONICAL.HOSTNAME HOST/DEVICE) (MKATOM HOST/DEVICE))) (CL:WHEN CASE-INSENSITIVE (CL:UNLESS S-P (SETQ STRING-COMPARE (QUOTE STRING-EQUAL))) (CL:UNLESS L-P (SETQ LOCAL-TO-COMMON (QUOTE FLIP-MONOCASE-STRING))) (CL:UNLESS C-P (SETQ COMMON-TO-LOCAL (QUOTE FLIP-MONOCASE-STRING)))) (LET ((OLDREC (FASSOC HOST/DEVICE \HOSTTOPATHNAMECASE))) (IF OLDREC THEN (REPLACE (PATHNAMECASE STRING-COMPARE) OF OLDREC WITH STRING-COMPARE) (REPLACE (PATHNAMECASE LOCAL-TO-COMMON) OF OLDREC WITH LOCAL-TO-COMMON) (REPLACE (PATHNAMECASE COMMON-TO-LOCAL) OF OLDREC WITH COMMON-TO-LOCAL) ELSE (PUSH \HOSTTOPATHNAMECASE (create PATHNAMECASE HOST-NAME _ HOST/DEVICE STRING-COMPARE _ STRING-COMPARE LOCAL-TO-COMMON _ LOCAL-TO-COMMON COMMON-TO-LOCAL _ COMMON-TO-LOCAL)))))
+
+(CL:DEFUN UNREGISTER-PATHNAMECASE (HOST/DEVICE) (SETQ \HOSTTOPATHNAMECASE (CL:DELETE HOST/DEVICE \HOSTTOPATHNAMECASE :KEY (CL:FUNCTION CAR))))
+(DEFINEQ
+
+(UNPACKLOGICALNAME.STRING
+(LAMBDA (STRING HOST) (* ; "Edited  3-Aug-91 09:45 by jrb:") (* ;;; "Unpacks the logical-pathname string STRING into a plist similar to that produced by UNPACKFILENAME.STRING") (LET ((RESULT (LIST (QUOTE HOST) HOST (QUOTE DEVICE) :UNSPECIFIC)) (TBL CL::LOGICAL-WORD-BITTABLE) DELIM DIR) (SETQ STRING (U-CASE STRING)) (SETQ DELIM (STRPOSL TBL STRING)) (* ;; "First check for HOST:") (CL:FLET ((GRAB-PIECE (TAG) (* ;; "Conventions:") (* ;; "DELIM == (CL:1+ (CL:LENGTH STRING)) - string contains no delimiters and will be the last piece") (* ;; "DELIM == NIL - string is empty") (IF (= DELIM (CL:1+ (CL:LENGTH STRING))) THEN (LISTPUT RESULT TAG STRING) (SETQ STRING "") (SETQ DELIM NIL) ELSE (LISTPUT RESULT TAG (SUBSTRING STRING 1 (CL:1- DELIM))) (IF (SUBSTRING STRING (CL:1+ DELIM) NIL STRING) THEN (SETQ DELIM (OR (STRPOSL TBL STRING) (CL:1+ (CL:LENGTH STRING)))) ELSE (SETQ STRING "") (SETQ DELIM NIL))))) (CL:WHEN (AND DELIM (EQUAL (SUBSTRING STRING DELIM DELIM) ":")) (GRAB-PIECE (QUOTE HOST))) (CL:WHEN (AND HOST (NOT (EQUAL HOST (LISTGET RESULT (QUOTE HOST))))) (CL:ERROR "Host argument ~s doesn't match logical pathname string host ~s" HOST (LISTGET RESULT (QUOTE HOST)))) (* ;; "Then [;]{DIRECTORY ;}*") (CL:WHEN (AND DELIM (EQUAL (SUBSTRING STRING DELIM DELIM) ";")) (SETQ DIR (CL:IF (EQ DELIM 1) (QUOTE DIRECTORY) (QUOTE RELATIVEDIRECTORY))) (WHILE (AND (SETQ DELIM (STRPOSL TBL STRING (CL:1+ DELIM))) (EQUAL (SUBSTRING STRING DELIM DELIM) ";")) BIND WHERE2 _ DELIM DO (SETQ WHERE2 DELIM) FINALLY (PROGN (LISTPUT RESULT DIR (SUBSTRING STRING (CL:IF (EQ DIR (QUOTE DIRECTORY)) 2 1) (CL:1- WHERE2))) (IF (= WHERE2 (CL:LENGTH STRING)) THEN (SETQ STRING "") (SETQ DELIM NIL) ELSE (SUBSTRING STRING (CL:1+ WHERE2) NIL STRING) (SETQ DELIM (STRPOSL TBL STRING)))))) (* ;; "Then [NAME] [ . TYPE [ .VERSION]]") (CL:WHEN DELIM (GRAB-PIECE (QUOTE NAME))) (CL:WHEN DELIM (GRAB-PIECE (QUOTE EXTENSION)) (CL:WHEN (NOT (EQUAL STRING "")) (LISTPUT RESULT (QUOTE VERSION) (CL:IF (EQUAL STRING "NEWEST") :NEWEST STRING)) (SETQ STRING "") (SETQ DELIM NIL)))) (CL:WHEN (AND (NULL DELIM) (NOT (EQUAL STRING ""))) (LISTPUT RESULT (QUOTE NAME) STRING)) RESULT))
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(%%INITIALIZE-DEFAULT-PATHNAME)
+)
+(DEFINEQ
+
+(FLIP-MONOCASE
+(LAMBDA (X) (* ; "Edited  6-Aug-91 19:53 by jrb:") (if (OR (U-CASEP X) (L-CASEP X)) then (FLIP-CASE X) else X))
+)
+
+(FLIP-MONOCASE-STRING
+(LAMBDA (X) (if (STRINGP X) then (FLIP-MONOCASE X) else X)))
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA)
+
+(ADDTOVAR NLAML)
+
+(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES PATHNAME %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME %%PRINT-LP)
+)
+(PUTPROPS CMLPATHNAME COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (4941 11158 (%%PARSE-DIRECTORY-PATH 4951 . 5645) (%%PRINT-LP 5647 . 5935) (
+%%PRINT-PATHNAME 5937 . 6111) (CL:MAKE-PATHNAME 6113 . 10290) (%%PRINT-DIRECTORY-COMPONENT 10292 . 
+11156)) (13546 18731 (PATHNAME 13556 . 13754) (CL:MERGE-PATHNAMES 13756 . 15149) (FILE-NAME 15151 . 
+15294) (CL:HOST-NAMESTRING 15296 . 15489) (CL:ENOUGH-NAMESTRING 15491 . 18496) (%%NUMERIC-STRING-P 
+18498 . 18729)) (54067 56258 (UNPACKLOGICALNAME.STRING 54077 . 56256)) (56327 56559 (FLIP-MONOCASE 
+56337 . 56469) (FLIP-MONOCASE-STRING 56471 . 56557)))))
+STOP
diff --git a/CLTL2/CMLPATHNAME.LCOM b/CLTL2/CMLPATHNAME.LCOM
new file mode 100644
index 00000000..476ae279
Binary files /dev/null and b/CLTL2/CMLPATHNAME.LCOM differ
diff --git a/CLTL2/CMLPRINT b/CLTL2/CMLPRINT
new file mode 100644
index 00000000..ca61fcfb
--- /dev/null
+++ b/CLTL2/CMLPRINT
@@ -0,0 +1,363 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 14:35:18" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLPRINT.;2" 16374  
+
+      previous date%: " 8-Jul-92 17:21:55" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLPRINT.;1")
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLPRINTCOMS)
+
+(RPAQQ CMLPRINTCOMS
+       [(FNS WRITE LISP:WRITE-CHAR LISP:PRIN1 LISP:PRINT LISP:TERPRI LISP:FRESH-LINE 
+             LISP:FINISH-OUTPUT LISP:FORCE-OUTPUT LISP:CLEAR-OUTPUT LISP:PPRINT LISP:PRINC)
+        (FUNCTIONS \WRITE1)
+        (FNS LISP:WRITE-TO-STRING LISP:PRIN1-TO-STRING LISP:PRINC-TO-STRING)
+        (FNS WRITE-STRING*)
+        (FUNCTIONS LISP:WRITE-STRING LISP:WRITE-LINE)
+        (INITVARS (XCL:*PRINT-STRUCTURE*))
+        (VARIABLES LISP:*PRINT-READABLY*)
+        (PROP FILETYPE CMLPRINT)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML)
+                      (LAMA LISP:WRITE-TO-STRING LISP:PRINC LISP:PPRINT LISP:PRINT LISP:PRIN1 
+                            LISP:WRITE-CHAR WRITE])
+(DEFINEQ
+
+(WRITE
+  (LISP:LAMBDA (OBJECT &KEY (STREAM *STANDARD-OUTPUT*)
+                      ((:ESCAPE *PRINT-ESCAPE*)
+                       *PRINT-ESCAPE*)
+                      ((:RADIX *PRINT-RADIX*)
+                       *PRINT-RADIX*)
+                      ((:BASE *PRINT-BASE*)
+                       *PRINT-BASE*)
+                      ((:LEVEL *PRINT-LEVEL*)
+                       *PRINT-LEVEL*)
+                      ((:LENGTH *PRINT-LENGTH*)
+                       *PRINT-LENGTH*)
+                      ((:CASE *PRINT-CASE*)
+                       *PRINT-CASE*)
+                      ((:GENSYM *PRINT-GENSYM*)
+                       *PRINT-GENSYM*)
+                      ((:ARRAY *PRINT-ARRAY*)
+                       *PRINT-ARRAY*)
+                      ((:PRETTY *PRINT-PRETTY*)
+                       *PRINT-PRETTY*)
+                      ((:CIRCLE *PRINT-CIRCLE*)
+                       *PRINT-CIRCLE*)
+                      ((:PPRINT-DISPATCH XP:*PRINT-PPRINT-DISPATCH*)
+                       XP:*PRINT-PPRINT-DISPATCH*)
+                      ((:RIGHT-MARGIN XP:*PRINT-RIGHT-MARGIN*)
+                       XP:*PRINT-RIGHT-MARGIN*)
+                      ((:LINES XP:*PRINT-LINES*)
+                       XP:*PRINT-LINES*)
+                      ((:MISER-WIDTH XP:*PRINT-MISER-WIDTH*)
+                       XP:*PRINT-MISER-WIDTH*)
+                      ((:READABLY LISP:*PRINT-READABLY*)
+                       LISP:*PRINT-READABLY*))               (* ; "Edited 11-Oct-91 23:23 by jrb:")
+         (DECLARE (LISP:SPECIAL *PRINT-ESCAPE* *PRINT-RADIX* *PRINT-BASE* *PRINT-LEVEL* 
+                             *PRINT-LENGTH* *PRINT-CASE* *PRINT-GENSYM* *PRINT-ARRAY* *PRINT-PRETTY*
+                             *PRINT-CIRCLE* XP:*PRINT-PPRINT-DISPATCH* XP:*PRINT-RIGHT-MARGIN* 
+                             XP:*PRINT-LINES* XP:*PRINT-MISER-WIDTH* LISP:*PRINT-READABLY* 
+                             *PRINT-CIRCLE-HASHTABLE* *PRINT-CIRCLE-NUMBER* THERE-ARE-CIRCLES))
+                                                             (* ; 
+                                                "Make sure STREAM ends up as an appropriate stream")
+         (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
+         (LISP:WHEN LISP:*PRINT-READABLY* (HANDLE-PRINT-READABLY))
+         [COND
+            [*PRINT-PRETTY* (COND
+                               ((XP::XP-STRUCTURE-P STREAM)
+                                (XP::WRITE+ OBJECT STREAM))
+                               (T (XP::MAYBE-INITIATE-XP-PRINTING #'(LISP:LAMBDA (LISP::S LISP::O)
+                                                                           (XP::WRITE+ LISP::O 
+                                                                                  LISP::S))
+                                         STREAM OBJECT]
+            ((OR (NOT *PRINT-CIRCLE*)
+                 *PRINT-CIRCLE-HASHTABLE*)
+             (\WRITE1 OBJECT STREAM))
+            (T (LET ((*PRINT-CIRCLE-NUMBER* 1)
+                     (*PRINT-CIRCLE-HASHTABLE* (LISP:MAKE-HASH-TABLE))
+                     THERE-ARE-CIRCLES)
+                    (DECLARE (LISP:SPECIAL *PRINT-CIRCLE-NUMBER* *PRINT-CIRCLE-HASHTABLE* 
+                                        THERE-ARE-CIRCLES))
+                    (PRINT-CIRCLE-SCAN OBJECT)
+                    (COND
+                       ((NOT THERE-ARE-CIRCLES)
+                        (LISP:SETQ *PRINT-CIRCLE-HASHTABLE* NIL)))
+                    (\WRITE1 OBJECT STREAM]
+         OBJECT))
+
+(LISP:WRITE-CHAR
+  (LISP:LAMBDA (CHARACTER &OPTIONAL STREAM)                  (* ; "Edited 11-Oct-91 23:44 by jrb:")
+         (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
+         [COND
+            ((AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
+             (XP::WRITE-CHAR+ CHARACTER STREAM))
+            [LISP:*PRINT-READABLY* (LET ((*PRINT-ESCAPE* T))
+                                        (\OUTCHAR STREAM (LISP:CHAR-INT CHARACTER]
+            (T (\OUTCHAR STREAM (LISP:CHAR-INT CHARACTER]
+         CHARACTER))
+
+(LISP:PRIN1
+  (LISP:LAMBDA (OBJECT &OPTIONAL OUTPUT-STREAM)              (* ; "Edited 20-Feb-87 16:58 by bvm:")
+         (WRITE OBJECT :STREAM OUTPUT-STREAM :ESCAPE T)))
+
+(LISP:PRINT
+  (LISP:LAMBDA (OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (* ; "Edited 20-Oct-91 21:16 by jrb:")
+         (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
+
+         (* ;; "The *PRINT-READABLY* case is forced through PRIN1 which goes through WRITE which rebinds everything as necessary")
+
+         (COND
+            [(AND *PRINT-PRETTY* (NOT LISP:*PRINT-READABLY*))
+             (COND
+                ((XP::XP-STRUCTURE-P STREAM)
+                 (XP::PPRINT-NEWLINE+ :UNCONDITIONAL STREAM)
+                 (LET ((*PRINT-ESCAPE* T))
+                      (XP::BASIC-WRITE OBJECT STREAM)
+                      (XP::WRITE-CHAR++ #\Space STREAM)))
+                (T (XP::MAYBE-INITIATE-XP-PRINTING #'(LISP:LAMBDA (LISP::S LISP::O)
+                                                            (XP::WRITE+ LISP::O LISP::S))
+                          STREAM OBJECT]
+            (T (TERPRI STREAM)
+               (LISP:PRIN1 OBJECT STREAM)
+               (SPACES 1 STREAM)))
+         OBJECT))
+
+(LISP:TERPRI
+  [LAMBDA (STREAM)                                           (* ; "Edited 20-Sep-91 13:56 by jrb:")
+
+    (* ;; "The clause *PRINT-PRETTY* is not necessary here: if a TERPRI is the first printing operation in a pretty-print sequence, it will be ignored anyway.")
+
+    (COND
+       ((AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
+        (XP::PPRINT-NEWLINE+ :UNCONDITIONAL STREAM))
+       (T (TERPRI (OR STREAM *STANDARD-OUTPUT*])
+
+(LISP:FRESH-LINE
+  [LAMBDA (STREAM)                                           (* ; "Edited 20-Sep-91 13:57 by jrb:")
+    (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
+    (COND
+       ((AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
+        (XP::ATTEMPT-TO-OUTPUT STREAM T T)                   (* ; "ok because we want newline")
+        (LISP:WHEN (NOT (LISP:ZEROP (XP::LP<-BP STREAM)))
+            (XP::PPRINT-NEWLINE+ :FRESH STREAM)
+            T))
+       (T (FRESHLINE STREAM])
+
+(LISP:FINISH-OUTPUT
+  [LAMBDA (STREAM)                                           (* ; "Edited 20-Sep-91 14:01 by jrb:")
+    (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
+    (LISP:IF (XP::XP-STRUCTURE-P STREAM)
+           (XP::ATTEMPT-TO-OUTPUT STREAM T T))
+    (FORCEOUTPUT STREAM T)
+    NIL])
+
+(LISP:FORCE-OUTPUT
+  [LAMBDA (STREAM)                                           (* ; "Edited 20-Sep-91 14:01 by jrb:")
+    (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
+    (LISP:IF (XP::XP-STRUCTURE-P STREAM)
+           (XP::ATTEMPT-TO-OUTPUT STREAM T T))
+    (FORCEOUTPUT STREAM)
+    NIL])
+
+(LISP:CLEAR-OUTPUT
+  [LAMBDA (STREAM)                                           (* ; "Edited 20-Sep-91 13:14 by jrb:")
+    (LISP:IF [XP::XP-STRUCTURE-P (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT]
+        (LET ((XP::*LOCATING-CIRCULARITIES* 0))              (* ; "hack to prevent visible output")
+             (XP::ATTEMPT-TO-OUTPUT STREAM T T)))
+    NIL])
+
+(LISP:PPRINT
+  (LISP:LAMBDA (OBJECT &OPTIONAL (OUTPUT-STREAM *STANDARD-OUTPUT*))
+                                                             (* lmm " 4-May-86 03:19")
+         (TERPRI OUTPUT-STREAM)
+         (WRITE OBJECT :STREAM OUTPUT-STREAM :ESCAPE T :PRETTY T)
+         (LISP:VALUES)))
+
+(LISP:PRINC
+  (LISP:LAMBDA (OBJECT &OPTIONAL OUTPUT-STREAM)              (* ; "Edited 20-Feb-87 16:59 by bvm:")
+         (WRITE OBJECT :STREAM OUTPUT-STREAM :ESCAPE NIL)))
+)
+
+(LISP:DEFUN \WRITE1 (OBJECT STREAM)
+
+   (* ;; "This used to be where we decided if we were pretty-printing or not; the conditionality was a little strange:")
+
+   (* ;; "(CL:IF (AND *PRINT-PRETTY* (OR (NOT *PRINT-CIRCLE*) (NOT *PRINT-CIRCLE-HASHTABLE*)) *PRINT-ESCAPE*) (pretty-print-using-IL:PRINTDEF) (just-print))")
+
+   (* ;; "I don't remember why *PRINT-ESCAPE* was tested; I suspect PRINTDEF forces it on.  Anyway, we're not using PRINTDEF any more here, I hope.")
+
+   (* ;; "otherwise just print it all on one line")
+
+   (LET (\THISFILELINELENGTH)
+        (DECLARE (LISP:SPECIAL \THISFILELINELENGTH))
+
+        (* ;; "CommonLisp streams do not observe line length")
+
+        (\PRINDATUM OBJECT (\GETSTREAM STREAM 'OUTPUT)
+               0)))
+(DEFINEQ
+
+(LISP:WRITE-TO-STRING
+  (LISP:LAMBDA (OBJECT &KEY ((:ESCAPE *PRINT-ESCAPE*)
+                             *PRINT-ESCAPE*)
+                      ((:RADIX *PRINT-RADIX*)
+                       *PRINT-RADIX*)
+                      ((:BASE *PRINT-BASE*)
+                       *PRINT-BASE*)
+                      ((:CIRCLE *PRINT-CIRCLE*)
+                       *PRINT-CIRCLE*)
+                      ((:PRETTY *PRINT-PRETTY*)
+                       *PRINT-PRETTY*)
+                      ((:LEVEL *PRINT-LEVEL*)
+                       *PRINT-LEVEL*)
+                      ((:LENGTH *PRINT-LENGTH*)
+                       *PRINT-LENGTH*)
+                      ((:CASE *PRINT-CASE*)
+                       *PRINT-CASE*)
+                      ((:ARRAY *PRINT-ARRAY*)
+                       *PRINT-ARRAY*)
+                      ((:GENSYM *PRINT-GENSYM*)
+                       *PRINT-GENSYM*)
+                      ((:PPRINT-DISPATCH XP:*PRINT-PPRINT-DISPATCH*)
+                       XP:*PRINT-PPRINT-DISPATCH*)
+                      ((:RIGHT-MARGIN XP:*PRINT-RIGHT-MARGIN*)
+                       XP:*PRINT-RIGHT-MARGIN*)
+                      ((:LINES XP:*PRINT-LINES*)
+                       XP:*PRINT-LINES*)
+                      ((:MISER-WIDTH XP:*PRINT-MISER-WIDTH*)
+                       XP:*PRINT-MISER-WIDTH*)
+                      ((:READABLY LISP:*PRINT-READABLY*)
+                       LISP:*PRINT-READABLY*))               (* ; "Edited 11-Oct-91 23:58 by jrb:")
+         "Returns the printed representation of OBJECT as a string."
+         (LISP:WHEN LISP:*PRINT-READABLY* (HANDLE-PRINT-READABLY))
+         (LISP:IF *PRINT-PRETTY*
+             (LISP:WITH-OUTPUT-TO-STRING (LISP::S)
+                    (WRITE OBJECT :STREAM LISP::S))
+             (\PRINDATUM.TO.STRING OBJECT))))
+
+(LISP:PRIN1-TO-STRING
+  [LAMBDA (OBJECT)                                           (* ; "Edited 20-Oct-91 21:25 by jrb:")
+
+(* ;;; "Produces a string consisting of the output of (PRIN1 OBJECT)")
+
+    (LET ((*PRINT-ESCAPE* T))
+
+         (* ;; 
+"We force the *PRINT-READABLY* case through WRITE-TO-STRING to let it rebind the control variables ")
+
+         (COND
+            (LISP:*PRINT-READABLY* (LISP:WRITE-TO-STRING OBJECT))
+            (*PRINT-PRETTY* (LISP:WITH-OUTPUT-TO-STRING (LISP::S)
+                                   (WRITE OBJECT :STREAM LISP::S)))
+            (T (\PRINDATUM.TO.STRING OBJECT])
+
+(LISP:PRINC-TO-STRING
+  [LAMBDA (OBJECT)                                           (* ; "Edited 20-Oct-91 21:24 by jrb:")
+
+(* ;;; 
+"A lot like MKSTRING, but not quite.  Produces a string consisting of the output of (PRINC OBJECT)")
+
+    (LET ((*PRINT-ESCAPE* NIL))
+
+         (* ;; 
+"We force the *PRINT-READABLY* case through WRITE-TO-STRING to let it rebind the control variables ")
+
+         (COND
+            (LISP:*PRINT-READABLY* (LISP:WRITE-TO-STRING OBJECT))
+            (*PRINT-PRETTY* (LISP:WITH-OUTPUT-TO-STRING (LISP::S)
+                                   (WRITE OBJECT :STREAM LISP::S)))
+            (T (\PRINDATUM.TO.STRING OBJECT])
+)
+(DEFINEQ
+
+(WRITE-STRING*
+  [LAMBDA (STRING STREAM START END)                          (* ; "Edited 21-Oct-91 13:20 by jrb:")
+    (OR STREAM (SETQ STREAM *STANDARD-OUTPUT*))
+    (LISP:UNLESS (EQ LISP:*PRINT-READABLY* 'XCL::PRINTING-READABLY)
+        (LISP::CHECK-READABLY STRING 'WRITE-STRING*))
+    (LISP:IF (AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
+        (XP::WRITE-STRING+ STRING STREAM START END)
+        [LET ((STRING-LENGTH (LISP:LENGTH STRING)))
+             (OR START (SETQ START 0))
+             (LISP:CHECK-TYPE STRING STRING)
+             (LISP:WHEN (NULL END)
+                    (SETQ END STRING-LENGTH))
+             (LISP:ASSERT (AND (<= 0 START STRING-LENGTH)
+                               (<= START END STRING-LENGTH))
+                    '(START END)
+                    "Start (~D) or end (~D) argument out of bounds." START END)
+
+             (* ;; "The following comes mainly from \PRINSTRING...")
+
+             (LET ((CHARS-TO-PRINT (- END START))
+                   \THISFILELINELENGTH)
+                  (DECLARE (SPECVARS \THISFILELINELENGTH))
+                  (LISP:WHEN (LISP:PLUSP CHARS-TO-PRINT)
+                      (.SPACECHECK. STREAM CHARS-TO-PRINT)
+
+                      (* ;; "Essentially (for x instring string do (\outchar strm x)).")
+
+                      (LISP:DO [(FATP (ffetch (STRINGP FATSTRINGP) of STRING))
+                                (BASE (ffetch (STRINGP BASE) of STRING))
+                                (OFFSET (IPLUS START (ffetch (STRINGP OFFST) of STRING))
+                                       (ADD1 OFFSET))
+                                (END (IPLUS END (ffetch (STRINGP OFFST) of STRING]
+                               ((>= OFFSET END))
+                          (\OUTCHAR STREAM (LISP:IF FATP
+                                               (\GETBASEFAT BASE OFFSET)
+                                               (\GETBASETHIN BASE OFFSET)))))])
+    STRING])
+)
+
+(LISP:DEFUN LISP:WRITE-STRING (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*)
+                                         &KEY
+                                         (START 0)
+                                         (END (LISP:LENGTH STRING)))
+                                                             (* ; "Edited  6-May-92 13:23 by jrb:")
+   (WRITE-STRING* STRING (\GETSTREAM STREAM 'OUTPUT)
+          START END)
+   STRING)
+
+(LISP:DEFUN LISP:WRITE-LINE (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*)
+                                       &KEY
+                                       (LISP::START 0)
+                                       LISP::END)
+   (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
+   (LISP:UNLESS (EQ LISP:*PRINT-READABLY* 'XCL::PRINTING-READABLY)
+       (LISP::CHECK-READABLY STRING 'LISP:WRITE-LINE))
+   (COND
+      ((AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
+       (PROGN (XP::WRITE-STRING+ STRING STREAM LISP::START LISP::END)
+              (XP::PPRINT-NEWLINE+ :UNCONDITIONAL STREAM)))
+      (T (WRITE-STRING* STRING STREAM LISP::START LISP::END)
+         (LISP:TERPRI STREAM)))
+   STRING)
+
+(RPAQ? XCL:*PRINT-STRUCTURE* )
+
+(LISP:DEFVAR LISP:*PRINT-READABLY* NIL)
+
+(PUTPROPS CMLPRINT FILETYPE :FAKE-COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA LISP:WRITE-TO-STRING LISP:PRINC LISP:PPRINT LISP:PRINT LISP:PRIN1 LISP:WRITE-CHAR
+                         WRITE)
+)
+(PUTPROPS CMLPRINT COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (1214 8835 (WRITE 1224 . 4704) (LISP:WRITE-CHAR 4706 . 5230) (LISP:PRIN1 5232 . 5413) 
+(LISP:PRINT 5415 . 6424) (LISP:TERPRI 6426 . 6882) (LISP:FRESH-LINE 6884 . 7373) (LISP:FINISH-OUTPUT 
+7375 . 7675) (LISP:FORCE-OUTPUT 7677 . 7974) (LISP:CLEAR-OUTPUT 7976 . 8342) (LISP:PPRINT 8344 . 8646)
+ (LISP:PRINC 8648 . 8833)) (9611 12737 (LISP:WRITE-TO-STRING 9621 . 11419) (LISP:PRIN1-TO-STRING 11421
+ . 12054) (LISP:PRINC-TO-STRING 12056 . 12735)) (12738 14726 (WRITE-STRING* 12748 . 14724)))))
+STOP
diff --git a/CLTL2/CMLPRINT.LCOM b/CLTL2/CMLPRINT.LCOM
new file mode 100644
index 00000000..8b090044
Binary files /dev/null and b/CLTL2/CMLPRINT.LCOM differ
diff --git a/CLTL2/CMLPROGV b/CLTL2/CMLPROGV
new file mode 100644
index 00000000..1dc8907d
--- /dev/null
+++ b/CLTL2/CMLPROGV
@@ -0,0 +1,104 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 14:37:11" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLPROGV.;2" 5917   
+
+      previous date%: " 3-Sep-91 17:48:59" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLPROGV.;1")
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLPROGVCOMS)
+
+(RPAQQ CMLPROGVCOMS ((FNS \DO.PROGV \DO.PROGV.SETUP.FRAME.AND.EXECUTE)
+                         (SPECIAL-FORMS LISP:PROGV)
+                         (PROP DMACRO LISP:PROGV)
+                         (PROP FILETYPE CMLPROGV)))
+(DEFINEQ
+
+(\DO.PROGV
+  [LAMBDA (VARS VALUES FNTOCALL)                             (* ; "Edited 21-Jan-91 17:10 by jds")
+
+    (* ;; "call FNTOCALL after binding VARS to VALUES")
+
+    (DECLARE (LOCALVARS . T))
+    (LET ((NVARS 0)
+          NTSIZE NNILS TMP)
+         (for VAR in VARS do 
+
+                                        (* ;; "Count number of vars to bind, check their validity")
+
+                                        (CHECK-BINDABLE VAR)
+                                        (add NVARS 1))
+         (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE
+                                                           (CEIL [ADD1 (UNFOLD NVARS (CONSTANT (
+                                                                                    WORDSPERNAMEENTRY
+                                                                                                ]
+                                                                 WORDSPERQUAD))
+                                                    (FOLDHI (fetch (FNHEADER OVERHEADWORDS)
+                                                               of T)
+                                                           WORDSPERCELL)
+                                                    (SUB1 CELLSPERQUAD)))
+                (\DO.PROGV.SETUP.FRAME.AND.EXECUTE NNILS NVARS NTSIZE VARS VALUES))
+         (LISP:FUNCALL FNTOCALL])
+
+(\DO.PROGV.SETUP.FRAME.AND.EXECUTE
+  [LAMBDA (NNILS NVARS NTSIZE VARS VALUES)                   (* ; "Edited 30-Jan-91 19:02 by jds")
+    (DECLARE (LOCALVARS . T))
+    (PROG ((CALLER (\MYALINK))
+           NILSTART NT HEADER)
+
+(* ;;; "Create a nametable inside CALLER where \DO.PROGV pushed all those NILs")
+
+          (SETQ HEADER (fetch (FX FNHEADER) of CALLER))
+                                                             (* ; 
+                                                        "The function header of code for \DO.PROGV")
+          (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch (FX NEXTBLOCK)
+                                                                             of CALLER)
+                                                                    (UNFOLD NNILS WORDSPERCELL)))
+                                              (UNFOLD NVARS WORDSPERCELL))
+                                       WORDSPERQUAD)))
+
+     (* ;; "Address of our synthesized nametable: beginning of NIL's, not counting additional PVARs we are about to bind, rounded up to quadword")
+
+          (for VAR in VARS as VAR# from (FOLDLO (IDIFFERENCE NILSTART
+                                                                       (fetch (FX FIRSTPVAR)
+                                                                          of CALLER))
+                                                               WORDSPERCELL) as NT1
+             from (fetch (FNHEADER OVERHEADWORDS) of T) by (CONSTANT (
+                                                                                    WORDSPERNAMEENTRY
+                                                                                      )) as
+                                                                                         NT2
+             from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
+                             NTSIZE) by (CONSTANT (WORDSPERNTOFFSETENTRY)) as VALUEOFF
+             from NILSTART by WORDSPERCELL do [PUTBASEPTR \STACKSPACE VALUEOFF
+                                                                 (COND
+                                                                    (VALUES (pop VALUES))
+                                                                    (T 'NOBIND]
+                                                         (SETSTKNAME-RAW NT NT1 (\ATOMVALINDEX VAR))
+                                                         (SETSTKNTOFFSET-RAW NT NT2 PVARCODE VAR#))
+
+(* ;;; "now fix up header of NT")
+
+          (replace (FNHEADER FRAMENAME) of NT with '\PROGV)
+          (replace (FNHEADER NTSIZE) of NT with NTSIZE)
+          (replace (FX NAMETABLE) of CALLER with NT])
+)
+
+(DEFINE-SPECIAL-FORM LISP:PROGV (LISP::VARIABLES LISP:VALUES &REST LISP::$$PROGV-FORMS 
+                                           &ENVIRONMENT LISP::$$PROGV-ENVIRONMENT)
+
+   (* ;; "$$PROGV-FORMS and $$PROGV-ENVIRONMENT are named this wierd way because the interpreter is still compiled with the ByteCompiler and those variables will eventually be made special by that compiler.  They can get normal names whenever the new compiler starts being used on this file.")
+
+   [\DO.PROGV (LISP:EVAL LISP::VARIABLES LISP::$$PROGV-ENVIRONMENT)
+          (LISP:EVAL LISP:VALUES LISP::$$PROGV-ENVIRONMENT)
+          #'(LISP:LAMBDA NIL (\EVAL-PROGN LISP::$$PROGV-FORMS LISP::$$PROGV-ENVIRONMENT])
+
+(PUTPROPS LISP:PROGV DMACRO [(VARIABLES VALUES . FORMS)
+                                     (\DO.PROGV VARIABLES VALUES #'(LAMBDA NIL . FORMS])
+
+(PUTPROPS CMLPROGV FILETYPE LISP:COMPILE-FILE)
+(PUTPROPS CMLPROGV COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (639 4897 (\DO.PROGV 649 . 2064) (\DO.PROGV.SETUP.FRAME.AND.EXECUTE 2066 . 4895)))))
+STOP
diff --git a/CLTL2/CMLPROGV.LCOM b/CLTL2/CMLPROGV.LCOM
new file mode 100644
index 00000000..0a92cc54
Binary files /dev/null and b/CLTL2/CMLPROGV.LCOM differ
diff --git a/CLTL2/CMLREAD b/CLTL2/CMLREAD
new file mode 100644
index 00000000..7dbce25e
--- /dev/null
+++ b/CLTL2/CMLREAD
@@ -0,0 +1,334 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED " 8-Jun-90 14:17:52" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLREAD.;3| 15466  
+
+      changes to%:  (FNS CL:READ-FROM-STRING)
+
+      previous date%: "16-May-90 14:23:07" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLREAD.;2|)
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLREADCOMS)
+
+(RPAQQ CMLREADCOMS [(COMS 
+                              (* ;; "Misc Common Lisp reader functions")
+
+                              (FNS CL:COPY-READTABLE)
+                              (FNS CL:READ-LINE CL:READ-CHAR CL:UNREAD-CHAR CL:PEEK-CHAR CL:LISTEN 
+                                   CL:READ-CHAR-NO-HANG CL:CLEAR-INPUT CL:READ-FROM-STRING 
+                                   CL:READ-BYTE CL:WRITE-BYTE)
+                                                             (* ; 
+                                                      "must turn off packed version of CLISP infix")
+                              (VARS [CLISPCHARS (LDIFFERENCE CLISPCHARS '(- *]
+                                    (CLISPCHARRAY (MAKEBITTABLE CLISPCHARS))
+                                    (DWIMINMACROSFLG))
+                              (VARIABLES *READ-DEFAULT-FLOAT-FORMAT*)
+                              (GLOBALVARS CMLRDTBL READ-LINE-RDTBL))
+                        [COMS 
+                              (* ;; "Crude means to aid reading and printing things in same reader environment.  There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup")
+
+                              (RECORDS READER-ENVIRONMENT)
+                              (FUNCTIONS WITH-READER-ENVIRONMENT)
+                              (ADDVARS (SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*))
+                              (PROP INFO WITH-READER-ENVIRONMENT)
+                              (GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*)
+                              (INITVARS (*COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT 
+                                                                               REPACKAGE _
+                                                                               (CL:FIND-PACKAGE
+                                                                                "USER")
+                                                                               REREADTABLE _ CMLRDTBL
+                                                                               REBASE _ 10]
+                        (PROP FILETYPE CMLREAD)
+                        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+                               (ADDVARS (NLAMA)
+                                      (NLAML)
+                                      (LAMA CL:READ-BYTE CL:READ-FROM-STRING CL:CLEAR-INPUT 
+                                            CL:READ-CHAR-NO-HANG CL:PEEK-CHAR CL:UNREAD-CHAR 
+                                            CL:READ-CHAR CL:READ-LINE CL:COPY-READTABLE])
+
+
+
+(* ;; "Misc Common Lisp reader functions")
+
+(DEFINEQ
+
+(CL:COPY-READTABLE
+  [CL:LAMBDA (&OPTIONAL (FROM-READTABLE *READTABLE*)
+                    TO-READTABLE)                            (* bvm%: "13-Oct-86 15:21")
+                                                             (* ; 
+                 "If FROM-READTABLE is NIL, then a copy of a standard Common Lisp readtable is made.")
+         (if (AND (NULL FROM-READTABLE)
+                  (NULL TO-READTABLE))
+             then                                            (* ; "just make a brand new one")
+                  (CMLRDTBL)
+           else (SETQ FROM-READTABLE (\DTEST (OR FROM-READTABLE (CMLRDTBL))
+                                            'READTABLEP))
+                (if TO-READTABLE
+                    then (RESETREADTABLE (\DTEST TO-READTABLE 'READTABLEP)
+                                FROM-READTABLE)
+                         TO-READTABLE
+                  else (COPYREADTABLE FROM-READTABLE])
+)
+(DEFINEQ
+
+(CL:READ-LINE
+  [CL:LAMBDA (&OPTIONAL STREAM (EOF-ERRORP T)
+                    EOF-VALUE RECURSIVE-P)                   (* ; "Edited 31-Mar-87 18:36 by bvm:")
+          
+          (* ;; 
+         "Returns a line of text read from the STREAM as a string, discarding the newline character.")
+
+         (CL:SETQ STREAM (\GETSTREAM STREAM 'INPUT))
+         (if (AND (NULL EOF-ERRORP)
+                  (NULL RECURSIVE-P)
+                  (\EOFP STREAM))
+             then EOF-VALUE
+           else (LET ((RESULT (RSTRING STREAM READ-LINE-RDTBL)))
+                     (if (\EOFP STREAM)
+                         then (CL:VALUES RESULT T)
+                       else                                  (* ; "consume the eol")
+                            (READCCODE STREAM)
+                            (CL:VALUES RESULT NIL])
+
+(CL:READ-CHAR
+  [CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)
+                    (EOF-ERRORP T)
+                    EOF-VALUE RECURSIVE-P)                   (* ; "Edited 14-Dec-86 20:41 by bvm:")
+          
+          (* ;; "Inputs a character from STREAM and returns it.")
+
+         (LET [(STREAM (\GETSTREAM STREAM 'INPUT]
+              (COND
+                 ((AND (NOT EOF-ERRORP)
+                       (NOT RECURSIVE-P)
+                       (\EOFP STREAM))
+                  EOF-VALUE)
+                 (T (CL:CODE-CHAR (READCCODE STREAM])
+
+(CL:UNREAD-CHAR
+  (CL:LAMBDA (CHARACTER &OPTIONAL (INPUT-STREAM *STANDARD-INPUT*))
+                                                             (* bvm%: "13-Oct-86 15:44")
+          
+          (* ;; "Puts the CHARACTER back on the front of the input STREAM.  According to the manual, `One may apply UNREAD-CHAR only to the character most recently read from INPUT-STREAM.'")
+
+         (\BACKCHAR (\GETSTREAM INPUT-STREAM 'INPUT))
+         NIL))
+
+(CL:PEEK-CHAR
+  [CL:LAMBDA (&OPTIONAL (PEEK-TYPE NIL)
+                    (STREAM *STANDARD-INPUT*)
+                    (EOF-ERRORP T)
+                    EOF-VALUE RECURSIVE-P)                   (* ; "Edited 14-Apr-87 14:39 by bvm:")
+          
+          (* ;; "Peeks at the next character in the input Stream.  See manual for details.")
+
+         (DECLARE (IGNORE RECURSIVE-P))
+         (LET ((STREAM (\GETSTREAM STREAM 'INPUT))
+               (\RefillBufferFn '\PEEKREFILL)
+               CL:CHAR)
+              (DECLARE (CL:SPECIAL \RefillBufferFn))
+              (SELECTQ PEEK-TYPE
+                  (NIL                                       (* ; "standard case--return next char.  \peekccode to terminal requires the binding of \RefillBufferFn above")
+                       (if (SETQ CL:CHAR (\PEEKCCODE STREAM (NULL EOF-ERRORP)))
+                           then (CL:CODE-CHAR CL:CHAR)
+                         else EOF-VALUE))
+                  (T                                         (* ; "skip whitespace before peeking")
+                     (if (SETQ CL:CHAR (SKIPSEPRCODES STREAM))
+                         then (CL:CODE-CHAR CL:CHAR)
+                       elseif EOF-ERRORP
+                         then (\EOF.ACTION STREAM)
+                       else EOF-VALUE))
+                  (if (CL:CHARACTERP PEEK-TYPE)
+                      then (LET ((DESIREDCHAR (CL:CHAR-CODE PEEK-TYPE))
+                                 (NOERROR (NULL EOF-ERRORP)))
+                                (until (EQ (SETQ CL:CHAR (\PEEKCCODE STREAM NOERROR))
+                                           DESIREDCHAR) do (if (NULL CL:CHAR)
+                                                               then (RETURN EOF-VALUE))
+                                                           (READCCODE STREAM)
+                                   finally (RETURN PEEK-TYPE)))
+                    else (\ILLEGAL.ARG PEEK-TYPE])
+
+(CL:LISTEN
+  (CL:LAMBDA (&OPTIONAL STREAM)                              (* ; "Edited 14-Apr-87 16:49 by bvm:")
+          
+          (* ;; "Returns T if a character is available on the given STREAM ")
+
+         (READP (\GETSTREAM STREAM 'INPUT)
+                T)))
+
+(CL:READ-CHAR-NO-HANG
+  (CL:LAMBDA (&OPTIONAL STREAM (EOF-ERRORP T)
+                    EOF-VALUE RECURSIVE-P)                   (* ; "Edited 14-Apr-87 16:40 by bvm:")
+          
+          (* ;; "Returns the next character from the STREAM if one is available, or NIL.  However, if STREAM is at eof, do eof handling.")
+
+         (COND
+            ((READP STREAM T)                                (* ; "there is input, get it")
+             (CL:READ-CHAR STREAM EOF-ERRORP EOF-VALUE RECURSIVE-P))
+            ((NOT (EOFP STREAM))                             (* ; 
+                                               "there could be more input, so don't wait, return NIL")
+             NIL)
+            (EOF-ERRORP (\EOF.ACTION STREAM))
+            (T EOF-VALUE))))
+
+(CL:CLEAR-INPUT
+  [CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*))           (* bvm%: "13-Oct-86 15:46")
+          
+          (* ;; "Clears any buffered input associated with the Stream.")
+
+         (CLEARBUF (\GETSTREAM STREAM 'INPUT])
+
+(CL:READ-FROM-STRING
+  [CL:LAMBDA (STRING &OPTIONAL EOF-ERROR-P EOF-VALUE &KEY START END PRESERVE-WHITESPACE)
+                                                           (* ; "Edited  8-Jun-90 14:15 by ymasuda")
+         (LET [(STREAM (OPENSTRINGSTREAM (COND
+                                            [END (SUBSTRING STRING 1 (IMIN END (NCHARS STRING]
+                                            (T (MKSTRING STRING]
+              (COND
+                 (START (SETFILEPTR STREAM START)))
+              (CL:VALUES (CL:IF PRESERVE-WHITESPACE
+                             (CL:READ-PRESERVING-WHITESPACE STREAM EOF-ERROR-P EOF-VALUE)
+                             (CL:READ STREAM EOF-ERROR-P EOF-VALUE))
+                     (\GETFILEPTR STREAM])
+
+(CL:READ-BYTE
+  [CL:LAMBDA (BINARY-INPUT-STREAM &OPTIONAL (EOF-ERRORP T)
+                    EOF-VALUE)                               (* bvm%: "13-Oct-86 15:49")
+          
+          (* ;; "Returns the next byte of the BINARY-INPUT-STREAM")
+
+         (LET [(STREAM (\GETSTREAM BINARY-INPUT-STREAM 'INPUT]
+              (CL:IF (AND (NOT EOF-ERRORP)
+                          (\EOFP STREAM))
+                     EOF-VALUE
+                     (\BIN STREAM])
+
+(CL:WRITE-BYTE
+  (CL:LAMBDA (INTEGER BINARY-OUTPUT-STREAM)                  (* bvm%: "13-Oct-86 15:49")
+          
+          (* ;; "Outputs the INTEGER to the binary BINARY-OUTPUT-STREAM")
+
+         (BOUT BINARY-OUTPUT-STREAM INTEGER)
+         INTEGER))
+)
+
+
+
+(* ; "must turn off packed version of CLISP infix")
+
+
+(RPAQ CLISPCHARS (LDIFFERENCE CLISPCHARS '(- *)))
+
+(RPAQ CLISPCHARRAY (MAKEBITTABLE CLISPCHARS))
+
+(RPAQQ DWIMINMACROSFLG NIL)
+
+(CL:DEFVAR *READ-DEFAULT-FLOAT-FORMAT* 'CL:SINGLE-FLOAT)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS CMLRDTBL READ-LINE-RDTBL)
+)
+
+
+
+(* ;; 
+"Crude means to aid reading and printing things in same reader environment.  There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup"
+)
+
+(DECLARE%: EVAL@COMPILE
+
+(DATATYPE READER-ENVIRONMENT (REPACKAGE REREADTABLE REBASE RESPEC))
+)
+
+(/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER)
+       '((READER-ENVIRONMENT 0 POINTER)
+         (READER-ENVIRONMENT 2 POINTER)
+         (READER-ENVIRONMENT 4 POINTER)
+         (READER-ENVIRONMENT 6 POINTER))
+       '8)
+
+(DEFMACRO WITH-READER-ENVIRONMENT (ENV . BODY)
+   `((CL:LAMBDA (E)
+            (LET ((*PACKAGE* (ffetch (READER-ENVIRONMENT REPACKAGE) of E))
+                  (*READTABLE* (ffetch (READER-ENVIRONMENT REREADTABLE) of E))
+                  (*READ-BASE* (ffetch (READER-ENVIRONMENT REBASE) of E))
+                  (*PRINT-BASE* (ffetch (READER-ENVIRONMENT REBASE) of E)))
+                 ,@BODY))
+     (\DTEST ,ENV 'READER-ENVIRONMENT)))
+
+(ADDTOVAR SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)
+
+(PUTPROPS WITH-READER-ENVIRONMENT INFO EVAL)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*)
+)
+
+(RPAQ? *COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE _ (CL:FIND-PACKAGE
+                                                                                  "USER")
+                                                 REREADTABLE _ CMLRDTBL REBASE _ 10))
+
+(PUTPROPS CMLREAD FILETYPE CL:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA CL:READ-BYTE CL:READ-FROM-STRING CL:CLEAR-INPUT CL:READ-CHAR-NO-HANG CL:PEEK-CHAR
+                         CL:UNREAD-CHAR CL:READ-CHAR CL:READ-LINE CL:COPY-READTABLE)
+)
+(PRETTYCOMPRINT CMLREADCOMS)
+
+(RPAQQ CMLREADCOMS 
+       [(COMS 
+              (* ;; "Misc Common Lisp reader functions")
+
+              (FNS CL:COPY-READTABLE)
+              (FNS CL:READ-LINE CL:READ-CHAR CL:UNREAD-CHAR CL:PEEK-CHAR CL:LISTEN 
+                   CL:READ-CHAR-NO-HANG CL:CLEAR-INPUT CL:READ-FROM-STRING CL:READ-BYTE CL:WRITE-BYTE
+                   )
+                                                             (* ; 
+                                                      "must turn off packed version of CLISP infix")
+              (VARS [CLISPCHARS (LDIFFERENCE CLISPCHARS '(- *]
+                    (CLISPCHARRAY (MAKEBITTABLE CLISPCHARS))
+                    (DWIMINMACROSFLG))
+              (VARIABLES *READ-DEFAULT-FLOAT-FORMAT*)
+              (GLOBALVARS CMLRDTBL READ-LINE-RDTBL))
+        [COMS 
+              (* ;; "Crude means to aid reading and printing things in same reader environment.  There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup")
+
+              (RECORDS READER-ENVIRONMENT)
+              (FUNCTIONS WITH-READER-ENVIRONMENT)
+              (ADDVARS (SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*))
+              (PROP INFO WITH-READER-ENVIRONMENT)
+              (GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*)
+              (INITVARS (*COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE _
+                                                               (CL:FIND-PACKAGE "USER")
+                                                               REREADTABLE _ CMLRDTBL REBASE _ 10]
+        (PROP FILETYPE CMLREAD)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML)
+                      (LAMA CL:WRITE-BYTE CL:READ-BYTE CL:READ-FROM-STRING CL:CLEAR-INPUT 
+                            CL:READ-CHAR-NO-HANG CL:LISTEN CL:PEEK-CHAR CL:UNREAD-CHAR CL:READ-CHAR 
+                            CL:READ-LINE CL:COPY-READTABLE])
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA CL:WRITE-BYTE CL:READ-BYTE CL:READ-FROM-STRING CL:CLEAR-INPUT CL:READ-CHAR-NO-HANG
+                         CL:LISTEN CL:PEEK-CHAR CL:UNREAD-CHAR CL:READ-CHAR CL:READ-LINE 
+                         CL:COPY-READTABLE)
+)
+(PUTPROPS CMLREAD COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (3113 4089 (CL:COPY-READTABLE 3123 . 4087)) (4090 10834 (CL:READ-LINE 4100 . 4967) (
+CL:READ-CHAR 4969 . 5534) (CL:UNREAD-CHAR 5536 . 5995) (CL:PEEK-CHAR 5997 . 8003) (CL:LISTEN 8005 . 
+8285) (CL:READ-CHAR-NO-HANG 8287 . 9076) (CL:CLEAR-INPUT 9078 . 9330) (CL:READ-FROM-STRING 9332 . 
+10087) (CL:READ-BYTE 10089 . 10561) (CL:WRITE-BYTE 10563 . 10832)))))
+STOP
diff --git a/CLTL2/CMLREAD.LCOM b/CLTL2/CMLREAD.LCOM
new file mode 100644
index 00000000..98381f31
Binary files /dev/null and b/CLTL2/CMLREAD.LCOM differ
diff --git a/CLTL2/CMLREADTABLE b/CLTL2/CMLREADTABLE
new file mode 100644
index 00000000..9d6f574b
--- /dev/null
+++ b/CLTL2/CMLREADTABLE
@@ -0,0 +1,156 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "25-Oct-91 16:19:12" {DSK}<usr>local>lde>lispcore>sources>CMLREADTABLE.;3 21290  
+
+      changes to%:  (VARS CMLREADTABLECOMS) (VARIABLES CL:*READ-EVAL*) (FUNCTIONS HASH-DOT)
+
+      previous date%: "15-Aug-91 23:36:53" {DSK}<usr>local>lde>lispcore>sources>CMLREADTABLE.;2)
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLREADTABLECOMS)
+
+(RPAQQ CMLREADTABLECOMS ((COMS (* ; "Common Lisp readtable interface functions ") (FUNCTIONS HASH-LEFT-PAD-INITIAL-CONTENTS CL:SET-SYNTAX-FROM-CHAR CL:GET-DISPATCH-MACRO-CHARACTER CL:GET-MACRO-CHARACTER CL:MAKE-DISPATCH-MACRO-CHARACTER CL:SET-DISPATCH-MACRO-CHARACTER CL:SET-MACRO-CHARACTER CL:READTABLE-CASE CL::SET-READTABLE-CASE) (SETFS CL:READTABLE-CASE) (FUNCTIONS DO-DISPATCH-MACRO FIND-MACRO-FUNCTION CL-MACRO-WRAPPED-P CL-UNWRAP-MACRO CL-WRAP-MACRO IL-MACRO-WRAPPED-P IL-UNWRAP-MACRO IL-WRAP-MACRO)) (COMS (* ; "hash macro sub functions") (FUNCTIONS HASH-LEFTPAREN HASH-A HASH-B HASH-BACKSLASH HASH-C HASH-COLON HASH-COMMA HASH-DOT HASH-DOUBLEQUOTE HASH-ILLEGAL-HASH-CHAR HASH-LEFTANGLE HASH-MINUS HASH-NO-PARAMETER-ERROR HASH-O HASH-P HASH-PLUS HASH-QUOTE HASH-R HASH-S HASH-STAR HASH-VBAR HASH-X HASH-EQUAL HASH-NUMBER-SIGN HASH-STRUCTURE-SMASH HASH-STRUCTURE-LOOKUP) (* ; "Temporary") (VARIABLES *READ-SUPPRESS* CL:*READ-EVAL*)) (COMS (* ; "Common Lisp default readtables") (FNS CMLRDTBL INIT-CML-READTABLES SET-DEFAULT-HASHMACRO-SETTINGS CMLREADSEMI) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INIT-CML-READTABLES)))) (PROP FILETYPE CMLREADTABLE)))
+
+
+
+(* ; "Common Lisp readtable interface functions ")
+
+
+(CL:DEFUN HASH-LEFT-PAD-INITIAL-CONTENTS (SIZE IVAL-LIST) (LET ((PADLENGTH (- SIZE (LENGTH IVAL-LIST)))) (COND ((> PADLENGTH 0) (APPEND IVAL-LIST (CL:MAKE-LIST PADLENGTH :INITIAL-ELEMENT (CAR (LAST IVAL-LIST))))) (T (CL:ERROR "Values list too long for #~D()" SIZE)))))
+
+(CL:DEFUN CL:SET-SYNTAX-FROM-CHAR (TO-CHAR FROM-CHAR &OPTIONAL (TO-READTABLE *READTABLE*) (FROM-READTABLE CMLRDTBL)) (SETSYNTAX (CL:CHAR-CODE TO-CHAR) (GETSYNTAX (CL:CHAR-CODE FROM-CHAR) FROM-READTABLE) TO-READTABLE) T)
+
+(CL:DEFUN CL:GET-DISPATCH-MACRO-CHARACTER (DISP-CHAR SUB-CHAR &OPTIONAL (READTABLE *READTABLE*)) (CL:WHEN (AND RTP (NULL READTABLE)) (SETQ READTABLE (FIND-READTABLE "LISP"))) (CDR (ASSOC SUB-CHAR (CDR (ASSOC DISP-CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE))))))
+
+(CL:DEFUN CL:GET-MACRO-CHARACTER (CHAR &OPTIONAL (READTABLE *READTABLE* RTP)) (CL:WHEN (AND RTP (NULL READTABLE)) (SETQ READTABLE (FIND-READTABLE "LISP"))) (* ;;; "insures entry is Common Lisp form - (MACRO {FIRST,ALWAYS} (LAMBDA (STREAM READTABLE) (FUNCALL <function> '<char> STREAM))))") (LET ((TABENTRY (GETSYNTAX (CL:CHAR-CODE CHAR) READTABLE)) NON-TERMINATING-P) (AND (CL:CONSP TABENTRY) (EQ (CAR TABENTRY) (QUOTE MACRO)) (CL:CONSP (CDR TABENTRY)) (FMEMB (CADR TABENTRY) (QUOTE (ALWAYS FIRST))) (SETQ NON-TERMINATING-P (CADR TABENTRY)) (CL:CONSP (SETQ TABENTRY (CDDR TABENTRY))) (NULL (CDR TABENTRY)) (CL:VALUES (FIND-MACRO-FUNCTION (CAR TABENTRY)) (NEQ NON-TERMINATING-P (QUOTE ALWAYS))))))
+
+(CL:DEFUN CL:MAKE-DISPATCH-MACRO-CHARACTER (CHAR &OPTIONAL NON-TERMINATING (READTABLE *READTABLE*)) (SETSYNTAX (CL:CHAR-CODE CHAR) (BQUOTE (MACRO (\, (CL:IF NON-TERMINATING (QUOTE FIRST) (QUOTE ALWAYS))) (LAMBDA (STREAM READTABLE Z) (DO-DISPATCH-MACRO (\, CHAR) STREAM READTABLE)))) READTABLE) T)
+
+(CL:DEFUN CL:SET-DISPATCH-MACRO-CHARACTER (DISP-CHAR SUB-CHAR FUNCTION &OPTIONAL (READTABLE *READTABLE*)) (CL:IF (CL:DIGIT-CHAR-P SUB-CHAR) (CL:ERROR "Digit ~S illegal as a sub-character for a dispatching macro" SUB-CHAR)) (SETQ SUB-CHAR (CL:CHAR-UPCASE SUB-CHAR)) (LET ((DISP-TABLE (OR (ASSOC DISP-CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE)) (LET ((NEWTABLE (LIST DISP-CHAR))) (push (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE) NEWTABLE) NEWTABLE))) DISP-CONS) (if (SETQ DISP-CONS (ASSOC SUB-CHAR (CDR DISP-TABLE))) then (CL:SETF (CDR DISP-CONS) FUNCTION) else (push (CDR DISP-TABLE) (CONS SUB-CHAR FUNCTION))) T))
+
+(CL:DEFUN CL:SET-MACRO-CHARACTER (CHAR FUNCTION &OPTIONAL NON-TERMINATING (READTABLE *READTABLE*)) (SETSYNTAX (CL:CHAR-CODE CHAR) (BQUOTE (MACRO (\, (CL:IF NON-TERMINATING (QUOTE FIRST) (QUOTE ALWAYS))) (\, (COND ((IL-MACRO-WRAPPED-P FUNCTION) (IL-UNWRAP-MACRO FUNCTION)) (T (CL-WRAP-MACRO FUNCTION CHAR)))))) READTABLE) T)
+
+(CL:DEFUN CL:READTABLE-CASE (CL:READTABLE) (CL:IF (fetch (READTABLEP CASEINSENSITIVE) of CL:READTABLE) (CL:IF (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) :DOWNCASE :UPCASE) (CL:IF (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) :INVERT :PRESERVE)))
+
+(CL:DEFUN CL::SET-READTABLE-CASE (CL:READTABLE CL::NEW-CASE) (CL:ECASE CL::NEW-CASE (:PRESERVE (CL:SETF (fetch (READTABLEP CASEINSENSITIVE) of CL:READTABLE) NIL (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) NIL)) (:UPCASE (CL:SETF (fetch (READTABLEP CASEINSENSITIVE) of CL:READTABLE) T (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) NIL)) (:DOWNCASE (CL:SETF (fetch (READTABLEP CASEINSENSITIVE) of CL:READTABLE) T (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) T)) (:INVERT (CL:SETF (fetch (READTABLEP CASEINSENSITIVE) of CL:READTABLE) NIL (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) T))) CL::NEW-CASE)
+
+(CL:DEFSETF CL:READTABLE-CASE CL::SET-READTABLE-CASE)
+
+(CL:DEFUN DO-DISPATCH-MACRO (CHAR STREAM RDTBL) (LET ((*READTABLE* RDTBL) (DISP-TABLE (CDR (ASSOC CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of RDTBL)))) INDEX NEXTCHAR) (COND ((NOT DISP-TABLE) (CL:ERROR "~S is not a dispatch macro character" CHAR)) (T (* ; "DISPATCHMACRODEFS is a list of A-lists") (while (DIGITCHARP (SETQ NEXTCHAR (READCCODE STREAM RDTBL))) do (* ; "read the optional numeric arg") (SETQ INDEX (+ (TIMES (OR INDEX 0) 10) (- NEXTCHAR (CHARCODE 0))))) (LET* ((DISP-CHARACTER (CL:CHAR-UPCASE (CL:CODE-CHAR NEXTCHAR))) (DISP-FUNCTION (CDR (ASSOC DISP-CHARACTER DISP-TABLE)))) (if DISP-FUNCTION then (CL:FUNCALL DISP-FUNCTION STREAM DISP-CHARACTER INDEX) else (CL:IF *READ-SUPPRESS* (PROGN (* ; "Attempt to ignore it") (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (CL:ERROR "Undefined dispatch character ~S for dispatch macro character ~S" DISP-CHARACTER CHAR))))))))
+
+(CL:DEFUN FIND-MACRO-FUNCTION (FORM) (COND ((CL-MACRO-WRAPPED-P FORM) (CL-UNWRAP-MACRO FORM)) ((CL:FUNCTIONP FORM) (IL-WRAP-MACRO FORM))))
+
+(CL:DEFUN CL-MACRO-WRAPPED-P (FORM) (* ;;; "Predicate that checks for forms built by CL-WRAP-MACRO") (AND (CL:CONSP FORM) (EQ (CAR FORM) (QUOTE CL:LAMBDA)) (CL:CONSP (CDR FORM)) (CL:EQUAL (CADR FORM) (QUOTE (STREAM READTABLE Z))) (CL:CONSP (CDDR FORM)) (NULL (CDDDR FORM)) (CL:CONSP (CADDR FORM)) (EQ (CAADDR FORM) (QUOTE CL:FUNCALL))))
+
+(CL:DEFUN CL-UNWRAP-MACRO (FORM) (* ;;; "Fetches CL function out wrapped by CL-WRAP-MACRO") (CADR (CADR (CADDR FORM))))
+
+(CL:DEFUN CL-WRAP-MACRO (FN CHAR) (* ;;; "Wraps a form around a CL readmacro to make it acceptable as an IL readmacro") (BQUOTE (CL:LAMBDA (STREAM READTABLE Z) (CL:FUNCALL (QUOTE (\, FN)) STREAM (\, CHAR)))))
+
+(CL:DEFUN IL-MACRO-WRAPPED-P (FORM) (* ;;; "Predicate that checks for forms built by IL-WRAP-MACRO") (AND (CL:CONSP FORM) (EQ (CAR FORM) (QUOTE CL:LAMBDA)) (CL:CONSP (CDR FORM)) (EQUAL (CADR FORM) (QUOTE (STREAM CHAR))) (CL:CONSP (SETQ FORM (CDDR FORM))) (NULL (CDR FORM)) (CL:CONSP (SETQ FORM (CAR FORM))) (EQ (CAR FORM) (QUOTE CL:FUNCALL)) (EQ (CADDR FORM) (QUOTE STREAM))))
+
+(CL:DEFUN IL-UNWRAP-MACRO (FORM) (CADR (CADR (CADDR FORM))))
+
+(CL:DEFUN IL-WRAP-MACRO (FORM) (* ;;; "Wraps a form around an IL readmacro to make it acceptable as a CL readmacro") (BQUOTE (CL:LAMBDA (STREAM CHAR) (CL:FUNCALL (QUOTE (\, FORM)) STREAM))))
+
+
+
+(* ; "hash macro sub functions")
+
+
+(CL:DEFUN HASH-LEFTPAREN (STREAM CHAR INDEX) (LET ((CONTENTS (CL:READ-DELIMITED-LIST #\) STREAM T))) (COND (*READ-SUPPRESS* NIL) (\INBQUOTE (* ;; "We are inside a back-quote - generate %",(coerce ',contents 'vector)%"") (CL:WHEN INDEX (CL:CERROR "Ignore the explicit length" "Explicit length not allowed in backquoted vectors:~%%#~D~S" INDEX CONTENTS)) (LIST (QUOTE \,) (BQUOTE (COERCE (\, (LIST (QUOTE BQUOTE) CONTENTS)) (QUOTE CL:VECTOR))))) (INDEX (IF (<= (LENGTH CONTENTS) INDEX) THEN (LET ((VEC (CL:MAKE-ARRAY INDEX :INITIAL-ELEMENT (CAR (LAST CONTENTS))))) (LET ((XCL-USER::T0 (LENGTH CONTENTS)) (I 0)) (CL:BLOCK NIL (LET NIL (CL:TAGBODY LOOPTAG0015 (COND ((>= I XCL-USER::T0) (RETURN NIL))) (CL:SETF (CL:AREF VEC I) (POP CONTENTS)) (CL:INCF I) (GO LOOPTAG0015))))) VEC) ELSE (CL:ERROR "Values list too long for #~D()" INDEX))) (T (CL:MAKE-ARRAY (LENGTH CONTENTS) :INITIAL-CONTENTS CONTENTS)))))
+
+(CL:DEFUN HASH-A (STREAM CHAR PARAM) (LET ((CONTENTS (CL:READ STREAM T NIL T))) (COND (*READ-SUPPRESS* NIL) (T (CL:MAKE-ARRAY (ESTIMATE-DIMENSIONALITY PARAM CONTENTS) :INITIAL-CONTENTS CONTENTS)))))
+
+(CL:DEFUN HASH-B (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (READNUMBERINBASE STREAM 2))))
+
+(CL:DEFUN HASH-BACKSLASH (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CHARACTER.READ STREAM) NIL) (T (CL:IF (OR (NULL PARAM) (AND (TYPEP PARAM (QUOTE CL:FIXNUM)) (>= PARAM 0) (< PARAM LISP:CHAR-FONT-LIMIT))) (CHARACTER.READ STREAM) (CL:ERROR "Illegal font specifier ~S for #\" PARAM)))))
+
+(CL:DEFUN HASH-C (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (DESTRUCTURING-BIND (NUM DEN) (CL:READ STREAM T NIL T) (COMPLEX NUM DEN)))))
+
+(CL:DEFUN HASH-COLON (STREAM CHAR PARAM) (* ; "Uninterned symbol.") (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:MAKE-SYMBOL (READ-EXTENDED-TOKEN STREAM *READTABLE* T)))))
+
+(CL:DEFUN HASH-COMMA (STREAM CHAR PARAM) (* ;;; "If the compiler is reading, then wrap up the form in a special data object to be noticed by FASL later.  If it's not the compiler, then treat exactly like #.") (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) ((NULL CL:*READ-EVAL*) (ERROR "#, encountered on ~S with *READ-EVAL* NIL" STREAM)) (T (CL:WHEN *CLTL2-PEDANTIC* (CL:CERROR "Read it anyway" "#, encountered on ~S with *CLTL2-PEDANTIC* non-NIL" STREAM)) (HASH-NO-PARAMETER-ERROR CHAR PARAM) (LET ((FORM (CL:READ STREAM T NIL T))) (IF COMPILER::*COMPILER-IS-READING* THEN (COMPILER::MAKE-EVAL-WHEN-LOAD :FORM FORM) ELSEIF (FETCH (READTABLEP COMMONLISP) OF *READTABLE*) THEN (CL:EVAL FORM) ELSE (EVAL FORM))))))
+
+(CL:DEFUN HASH-DOT (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:UNLESS CL:*READ-EVAL* (CL:CERROR "Read and eval anyway" "#. with *READ-EVAL* NIL on ~s" STREAM)) (COND ((fetch (READTABLEP COMMONLISP) of *READTABLE*) (CL:EVAL (CL:READ STREAM T NIL T))) (T (EVAL (CL:READ STREAM T NIL T)))))))
+
+(CL:DEFUN HASH-DOUBLEQUOTE (STREAM CHAR PARAM) (* ;;; "An extension to Common Lisp.  This reads a normal string but ignores CR's and any whitespace immediately following them.") (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (RSTRING STREAM *READTABLE* (QUOTE SKIP)))))
+
+(CL:DEFUN HASH-ILLEGAL-HASH-CHAR (STREAM CHAR PARAM) (CL:ERROR "Illegal hash macro character ~S" CHAR))
+
+(CL:DEFUN HASH-LEFTANGLE (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:ERROR "Unreadable object #<~A>" (CL:READ STREAM T NIL T)))
+
+(CL:DEFUN HASH-MINUS (STREAM CHAR PARAM) (* ;; "When *READ-SUPPRESS* is true, we want to simply skip over the two forms (the feature expression and the controlled expression).  Otherwise, we read the feature expression and, when it applies to us, skip over the controlled expression.  In any case, we never return a value.") (COND (*READ-SUPPRESS* (* ; "Skip two forms.") (CL:READ STREAM T NIL T) (CL:READ STREAM T NIL T)) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:WHEN (CMLREAD.FEATURE.PARSER (LET ((*PACKAGE* *KEYWORD-PACKAGE*)) (CL:READ STREAM T NIL T))) (LET ((*READ-SUPPRESS* T)) (CL:READ STREAM T NIL T))))) (CL:VALUES))
+
+(CL:DEFUN HASH-NO-PARAMETER-ERROR (CHAR PARAM) (CL:WHEN PARAM (CL:ERROR "Parameter ~D not allowed with hash macro ~S" PARAM CHAR)))
+
+(CL:DEFUN HASH-O (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (READNUMBERINBASE STREAM 8))))
+
+(CL:DEFUN HASH-P (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (PATHNAME (CL:READ STREAM T NIL T)))))
+
+(CL:DEFUN HASH-PLUS (STREAM CHAR PARAM) (* ;; "When *READ-SUPPRESS* is true, we want to simply skip over the two forms (the feature expression and the controlled expression).  Otherwise, we read the feature expression and, unless it applies to us, skip over the controlled expression.  In any case, we never return a value.") (COND (*READ-SUPPRESS* (* ; "Skip two forms.") (CL:READ STREAM T NIL T) (CL:READ STREAM T NIL T)) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:UNLESS (CMLREAD.FEATURE.PARSER (LET ((*PACKAGE* *KEYWORD-PACKAGE*)) (CL:READ STREAM T NIL T))) (LET ((*READ-SUPPRESS* T)) (CL:READ STREAM T NIL T))))) (CL:VALUES))
+
+(CL:DEFUN HASH-QUOTE (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (LIST (QUOTE CL:FUNCTION) (CL:READ STREAM T NIL T)))))
+
+(CL:DEFUN HASH-R (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (PARAM (READNUMBERINBASE STREAM PARAM)) (T (CL:ERROR "No base supplied for #R"))))
+
+(CL:DEFUN HASH-S (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CREATE-STRUCTURE (CL:READ STREAM T NIL T)))))
+
+(CL:DEFUN HASH-STAR (STREAM CHAR PARAM) (DECLARE (IGNORE CHAR)) (IF (EQ (PEEKC STREAM) (QUOTE %()) THEN (* ; "It's a bitmap.") (IF *READ-SUPPRESS* THEN (CL:READ STREAM NIL NIL T) (CL:READ STREAM NIL NIL T) ELSEIF PARAM THEN (CL:ERROR "Unexpected parameter ~S given in #* bitmap syntax." PARAM) ELSE (FINISH-READING-BITMAP STREAM)) ELSE (* ; "It's a bit-vector.") (LET* ((CONTENTS (READ-EXTENDED-TOKEN STREAM)) (LEN (NCHARS CONTENTS))) (IF *READ-SUPPRESS* THEN NIL ELSEIF (AND (EQ LEN 0) PARAM (NEQ PARAM 0)) THEN (CL:ERROR "No contents specified for bit vector #~A*" PARAM) ELSEIF (AND PARAM (> LEN PARAM)) THEN (CL:ERROR "Bit vector contents longer than specified length in #~A*~A" PARAM CONTENTS) ELSE (LET ((BITARRAY (CL:MAKE-ARRAY (OR PARAM LEN) :ELEMENT-TYPE (QUOTE BIT) :INITIAL-ELEMENT (IF (AND PARAM (> PARAM LEN 0)) THEN (SELCHARQ (NTHCHARCODE CONTENTS -1) (0 0) (1 1) (CL:ERROR "Illegal bit vector element in #~A*~A" PARAM CONTENTS)) ELSE 0)))) (CL:DOTIMES (I LEN) (CL:SETF (CL:AREF BITARRAY I) (SELCHARQ (NTHCHARCODE CONTENTS (CL:1+ I)) (0 0) (1 1) (CL:ERROR "Illegal bit vector element in #~A*~A" PARAM CONTENTS)))) BITARRAY)))))
+
+(CL:DEFUN HASH-VBAR (STREAM CHAR PARAM) (OR *READ-SUPPRESS* (HASH-NO-PARAMETER-ERROR CHAR PARAM)) (LET ((*READ-SUPPRESS* T)) (SKIP.HASH.COMMENT STREAM *READTABLE*) (CL:VALUES)))
+
+(CL:DEFUN HASH-X (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (READNUMBERINBASE STREAM 16))))
+
+(CL:DEFUN HASH-EQUAL (STREAM CHAR PARAM) (CL:IF *READ-SUPPRESS* (CL:VALUES) (PROGN (CL:IF (NULL PARAM) (CL:ERROR "#= encountered")) (CL:IF (CL:ASSOC PARAM *CIRCLE-READ-LIST*) (CL:ERROR "#~D= seen twice in same context")) (LET ((NEWNODE (CONS PARAM NIL))) (CL:PUSH NEWNODE *CIRCLE-READ-LIST*) (CL:SETF (CDR NEWNODE) (CL:READ STREAM T NIL T))))))
+
+(CL:DEFUN HASH-NUMBER-SIGN (STREAM CHAR PARAM) (CL:IF *READ-SUPPRESS* NIL (LET ((CIRCLE-PART (CL:ASSOC PARAM *CIRCLE-READ-LIST*))) (COND (CIRCLE-PART) (T (CL:ERROR "#~D# encountered before #~D=" PARAM PARAM))))))
+
+(CL:DEFUN HASH-STRUCTURE-SMASH (THING) (CL:TYPECASE THING (CONS (CL:IF (HASH-STRUCTURE-LOOKUP (CAR THING)) (CL:SETF (CAR THING) (CDAR THING)) (HASH-STRUCTURE-SMASH (CAR THING))) (CL:IF (HASH-STRUCTURE-LOOKUP (CDR THING)) (CL:SETF (CDR THING) (CDDR THING)) (HASH-STRUCTURE-SMASH (CDR THING)))) ((CL:ARRAY T) (LET* ((ASIZE (CL:ARRAY-TOTAL-SIZE THING)) (VARRAY (CL:IF (> (CL:ARRAY-RANK THING) 1) (CL:MAKE-ARRAY ASIZE :DISPLACED-TO THING) THING)) SLOTCONTENTS) (CL:DOTIMES (X ASIZE) (CL:SETQ SLOTCONTENTS (CL:AREF VARRAY X)) (CL:IF (HASH-STRUCTURE-LOOKUP SLOTCONTENTS) (CL:SETF (CL:AREF VARRAY X) (CDR SLOTCONTENTS)) (HASH-STRUCTURE-SMASH SLOTCONTENTS))))) (LISP::STRUCTURE-OBJECT (LET (SLOTCONTENTS) (CL:DOLIST (DESCR (LISP::STRUCTURE-POINTER-SLOTS (CL:TYPE-OF THING))) (CL:SETQ SLOTCONTENTS (FETCHFIELD DESCR THING)) (CL:IF (HASH-STRUCTURE-LOOKUP SLOTCONTENTS) (REPLACEFIELD DESCR THING (CDR SLOTCONTENTS)) (HASH-STRUCTURE-SMASH SLOTCONTENTS)))))))
+
+(CL:DEFUN HASH-STRUCTURE-LOOKUP (SLOTCONTENTS) (AND (CL:CONSP SLOTCONTENTS) (MEMQ SLOTCONTENTS *CIRCLE-READ-LIST*)))
+
+
+
+(* ; "Temporary")
+
+
+(CL:DEFVAR *READ-SUPPRESS* NIL)
+
+(CL:DEFVAR CL:*READ-EVAL* T)
+
+
+
+(* ; "Common Lisp default readtables")
+
+(DEFINEQ
+
+(CMLRDTBL
+(LAMBDA NIL (* ; "Edited  3-Apr-91 11:22 by jrb:") (* ;; "Creates a vanilla common-lisp read table") (PROG ((TBL (COPYREADTABLE (QUOTE ORIG)))) (* ;; "First reset the table") (for I from 0 to \MAXTHINCHAR do (SETSYNTAX I (QUOTE OTHER) TBL)) (* ;; "Install the goodies") (SETSEPR (CHARCODE (SPACE CR ^L LF TAB)) 1 TBL) (SETSYNTAX (CHARCODE "'") (QUOTE (MACRO ALWAYS READQUOTE)) TBL) (* ;; "Note that in cml, most of these macros are terminating, even though it would be nicer for us if they were not") (SETSYNTAX (CHARCODE ";") (QUOTE (MACRO ALWAYS CMLREADSEMI)) TBL) (SETSYNTAX (CHARCODE ")") (QUOTE RIGHTPAREN) TBL) (SETSYNTAX (CHARCODE "(") (QUOTE LEFTPAREN) TBL) (* ;; "These two PROPS == CL:READTABLE-CASE :UPCASE") (READTABLEPROP TBL (QUOTE CASEINSENSITIVE) T) (READTABLEPROP TBL (QUOTE LOWER/FLIPCASE) NIL) (READTABLEPROP TBL (QUOTE COMMONLISP) T) (READTABLEPROP TBL (QUOTE COMMONNUMSYNTAX) T) (READTABLEPROP TBL (QUOTE USESILPACKAGE) NIL) (READTABLEPROP TBL (QUOTE ESCAPECHAR) (CHARCODE "\")) (READTABLEPROP TBL (QUOTE MULTIPLE-ESCAPECHAR) (CHARCODE "|")) (if *PACKAGE* then (READTABLEPROP TBL (QUOTE PACKAGECHAR) (CHARCODE ":"))) (SET-DEFAULT-HASHMACRO-SETTINGS TBL) (SETSYNTAX (CHARCODE %") (QUOTE STRINGDELIM) TBL) (SETSYNTAX (CHARCODE "`") (QUOTE (MACRO ALWAYS READBQUOTE)) TBL) (SETSYNTAX (CHARCODE ",") (QUOTE (MACRO ALWAYS READBQUOTECOMMA)) TBL) (RETURN TBL)))
+)
+
+(INIT-CML-READTABLES
+(LAMBDA NIL (* ; "Edited 16-Jan-87 15:47 by bvm:") (DECLARE (GLOBALVARS CMLRDTBL *COMMON-LISP-READ-ENVIRONMENT* READ-LINE-RDTBL)) (READTABLEPROP (SETQ CMLRDTBL (CMLRDTBL)) (QUOTE NAME) "LISP") (SETQ *COMMON-LISP-READ-ENVIRONMENT* (MAKE-READER-ENVIRONMENT (LISP:FIND-PACKAGE "USER") CMLRDTBL 10)) (LET ((FILETBL (COPYREADTABLE CMLRDTBL))) (* ; "Make one for files that has font indicators as seprs") (for I from 1 to 26 do (SETSYNTAX I (QUOTE SEPRCHAR) FILETBL)) (READTABLEPROP FILETBL (QUOTE NAME) "XCL")) (PROGN (* ; "Read table to make READ-LINE work easily") (SETQ READ-LINE-RDTBL (COPYREADTABLE (QUOTE ORIG))) (for I from 0 to \MAXTHINCHAR do (SETSYNTAX I (QUOTE OTHER) READ-LINE-RDTBL)) (SETBRK (CHARCODE (EOL)) NIL READ-LINE-RDTBL)))
+)
+
+(SET-DEFAULT-HASHMACRO-SETTINGS
+(LAMBDA (RDTBL) (* ; "Edited  3-Apr-91 11:23 by jrb:") (READTABLEPROP RDTBL (QUOTE HASHMACROCHAR) (CHARCODE "#")) (LISP:MAKE-DISPATCH-MACRO-CHARACTER #\# T RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\( (QUOTE HASH-LEFTPAREN) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\' (QUOTE HASH-QUOTE) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\. (QUOTE HASH-DOT) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\, (QUOTE HASH-COMMA) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\\ (QUOTE HASH-BACKSLASH) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\* (QUOTE HASH-STAR) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\: (QUOTE HASH-COLON) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\O (QUOTE HASH-O) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\B (QUOTE HASH-B) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\X (QUOTE HASH-X) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\R (QUOTE HASH-R) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\A (QUOTE HASH-A) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\S (QUOTE HASH-S) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\C (QUOTE HASH-C) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\P (QUOTE HASH-P) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\+ (QUOTE HASH-PLUS) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\- (QUOTE HASH-MINUS) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\| (QUOTE HASH-VBAR) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\< (QUOTE HASH-LEFTANGLE) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\" (QUOTE HASH-DOUBLEQUOTE) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\= (QUOTE HASH-EQUAL) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\# (QUOTE HASH-NUMBER-SIGN) RDTBL) RDTBL)
+)
+
+(CMLREADSEMI
+(LAMBDA (STREAM RDTBL) (* bvm%: "13-Oct-86 15:53") (* ;;; "Read and discard through end of line") (until (EQ (READCCODE STREAM) (CHARCODE NEWLINE)) do NIL) (LISP:VALUES))
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(INIT-CML-READTABLES)
+)
+
+(PUTPROPS CMLREADTABLE FILETYPE CL:COMPILE-FILE)
+(PUTPROPS CMLREADTABLE COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (17000 21075 (CMLRDTBL 17010 . 18400) (INIT-CML-READTABLES 18402 . 19168) (
+SET-DEFAULT-HASHMACRO-SETTINGS 19170 . 20882) (CMLREADSEMI 20884 . 21073)))))
+STOP
diff --git a/CLTL2/CMLREADTABLE.LCOM b/CLTL2/CMLREADTABLE.LCOM
new file mode 100644
index 00000000..34469789
Binary files /dev/null and b/CLTL2/CMLREADTABLE.LCOM differ
diff --git a/CLTL2/CMLSEQBASICS b/CLTL2/CMLSEQBASICS
new file mode 100644
index 00000000..4fb37f40
--- /dev/null
+++ b/CLTL2/CMLSEQBASICS
@@ -0,0 +1,198 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 14:37:58" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLSEQBASICS.;2" 10546  
+
+      previous date%: "29-Aug-91 16:36:55" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLSEQBASICS.;1"
+)
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLSEQBASICSCOMS)
+
+(RPAQQ CMLSEQBASICSCOMS
+       ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES CMLSEQCOMMON))
+        (FUNCTIONS LISP:CONCATENATE LISP:COPY-SEQ LISP:ELT LISP:LENGTH LISP:MAKE-SEQUENCE 
+               LISP:NREVERSE LISP:REVERSE LISP:SUBSEQ %%SETELT)
+        (FUNCTIONS MAKE-SEQUENCE-OF-TYPE)
+        (SETFS LISP:ELT LISP:SUBSEQ)
+        (PROPS (CMLSEQBASICS FILETYPE))
+        (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (LOCALVARS . T))))
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+
+(FILESLOAD CMLSEQCOMMON)
+)
+
+(LISP:DEFUN LISP:CONCATENATE (RESULT-TYPE &REST SEQUENCES)
+   [LET [(RESULT (MAKE-SEQUENCE-OF-TYPE RESULT-TYPE (LET ((CNT 0))
+                                                             (LISP:DOLIST (SEQ SEQUENCES CNT)
+                                                                 (SETQ CNT (+ CNT (LISP:LENGTH
+                                                                                   SEQ))))]
+        (SEQ-DISPATCH RESULT [LET ((TAIL RESULT))
+                                  (LISP:DOLIST (SEQUENCE SEQUENCES RESULT)
+                                      [SEQ-DISPATCH SEQUENCE (LISP:DOLIST (ELEMENT SEQUENCE)
+                                                                 (RPLACA TAIL ELEMENT)
+                                                                 (SETQ TAIL (CDR TAIL)))
+                                             (LISP:DOTIMES (I (VECTOR-LENGTH SEQUENCE))
+                                                 (RPLACA TAIL (LISP:AREF SEQUENCE I))
+                                                 (SETQ TAIL (CDR TAIL)))])]
+               (LET ((INDEX 0))
+                    (LISP:DOLIST (SEQUENCE SEQUENCES RESULT)
+                        [SEQ-DISPATCH SEQUENCE (LISP:DOLIST (ELEMENT SEQUENCE)
+                                                   (LISP:SETF (LISP:AREF RESULT INDEX)
+                                                          ELEMENT)
+                                                   (SETQ INDEX (LISP:1+ INDEX)))
+                               (LISP:DOTIMES (I (VECTOR-LENGTH SEQUENCE))
+                                   (LISP:SETF (LISP:AREF RESULT INDEX)
+                                          (LISP:AREF SEQUENCE I))
+                                   (SETQ INDEX (LISP:1+ INDEX)))])])
+
+(LISP:DEFUN LISP:COPY-SEQ (SEQUENCE)
+   "Returns a copy of SEQUENCE which is EQUALP to SEQUENCE but not EQ."
+   [LET ((LENGTH (LISP:LENGTH SEQUENCE)))
+        (SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE 0 LENGTH (INDEX CURRENT COPY TAIL)
+                                      COPY
+                                      (COLLECT-ITEM CURRENT COPY TAIL))
+               (LET [(COPY (MAKE-VECTOR LENGTH :ELEMENT-TYPE (LISP:ARRAY-ELEMENT-TYPE SEQUENCE]
+                    (COPY-VECTOR-SUBSEQ SEQUENCE 0 LENGTH COPY 0 LENGTH])
+
+(LISP:DEFUN LISP:ELT (SEQUENCE INDEX)
+                                                             (* amd " 5-Jun-86 17:48")
+   (LISP:IF (NOT (< -1 INDEX (LISP:LENGTH SEQUENCE)))
+       (LISP:ERROR 'INDEX-BOUNDS-ERROR :NAME SEQUENCE :INDEX INDEX))
+   (SEQ-DISPATCH SEQUENCE (LISP:NTH INDEX SEQUENCE)
+          (LISP:AREF SEQUENCE INDEX)))
+
+(LISP:DEFUN LISP:LENGTH (SEQUENCE)
+   (SEQ-DISPATCH SEQUENCE [LET ((SIZE 0)
+                                (REST SEQUENCE))
+                               (LISP:LOOP (LISP:IF (NOT (LISP:CONSP REST))
+                                                 (RETURN SIZE))
+                                      (SETQ REST (CDR REST))
+                                      (SETQ SIZE (LISP:1+ SIZE]
+          (VECTOR-LENGTH SEQUENCE)))
+
+(LISP:DEFUN LISP:MAKE-SEQUENCE (TYPE LENGTH &KEY (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P))
+   "Make a sequnce of the specified type"
+   (LISP:IF (EQ TYPE 'LIST)
+       (LISP:MAKE-LIST LENGTH :INITIAL-ELEMENT INITIAL-ELEMENT)
+       (LET ((VECTOR (MAKE-SEQUENCE-OF-TYPE TYPE LENGTH)))
+            (LISP:IF INITIAL-ELEMENT-P (FILL-VECTOR-SUBSEQ VECTOR 0 LENGTH INITIAL-ELEMENT))
+            VECTOR)))
+
+(LISP:DEFUN LISP:NREVERSE (SEQUENCE)
+   "Returns a sequence of the same elements in reverse order (the argument is destroyed)."
+   [SEQ-DISPATCH SEQUENCE [LET ((REST SEQUENCE)
+                                LIST-HEAD RESULT)
+                               (LISP:LOOP (LISP:IF (NOT (LISP:CONSP (SETQ LIST-HEAD REST)))
+                                                 (RETURN RESULT))
+                                      (SETQ REST (CDR REST))
+                                      (SETQ RESULT (RPLACD LIST-HEAD RESULT]
+          (LET ((LENGTH (VECTOR-LENGTH SEQUENCE)))
+               (LISP:DO ((LEFT-INDEX 0 (LISP:1+ LEFT-INDEX))
+                         (RIGHT-INDEX (LISP:1- LENGTH)
+                                (LISP:1- RIGHT-INDEX))
+                         (HALF-LENGTH (LRSH LENGTH 1)))
+                        ((EQL LEFT-INDEX HALF-LENGTH)
+                         SEQUENCE)
+                   (LISP:ROTATEF (LISP:AREF SEQUENCE LEFT-INDEX)
+                          (LISP:AREF SEQUENCE RIGHT-INDEX)))])
+
+(LISP:DEFUN LISP:REVERSE (SEQUENCE)
+   "Returns a new sequence containing the same elements but in reverse order."
+   [SEQ-DISPATCH SEQUENCE [LET ((REST SEQUENCE)
+                                RESULT)
+                               (LISP:LOOP (LISP:IF (NOT (LISP:CONSP REST))
+                                                 (RETURN RESULT))
+                                      (LISP:PUSH (CAR REST)
+                                             RESULT)
+                                      (SETQ REST (CDR REST]
+          (LET ((LENGTH (VECTOR-LENGTH SEQUENCE)))
+               (LISP:DO ((RESULT (MAKE-VECTOR LENGTH :ELEMENT-TYPE (LISP:ARRAY-ELEMENT-TYPE SEQUENCE)
+                                        ))
+                         (FORWARD-INDEX 0 (LISP:1+ FORWARD-INDEX))
+                         (BACKWARD-INDEX (LISP:1- LENGTH)
+                                (LISP:1- BACKWARD-INDEX)))
+                        ((EQL FORWARD-INDEX LENGTH)
+                         RESULT)
+                   (LISP:SETF (LISP:AREF RESULT FORWARD-INDEX)
+                          (LISP:AREF SEQUENCE BACKWARD-INDEX)))])
+
+(LISP:DEFUN LISP:SUBSEQ (SEQUENCE START &OPTIONAL END)
+   [LET ((LENGTH (LISP:LENGTH SEQUENCE)))
+        (LISP:IF (NULL END)
+               (SETQ END LENGTH))
+        (CHECK-SUBSEQ SEQUENCE START END LENGTH)
+        (SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT COPY TAIL)
+                                      COPY
+                                      (COLLECT-ITEM CURRENT COPY TAIL))
+               (LET [(COPY (MAKE-VECTOR (- END START)
+                                  :ELEMENT-TYPE
+                                  (LISP:ARRAY-ELEMENT-TYPE SEQUENCE]
+                    (COPY-VECTOR-SUBSEQ SEQUENCE START END COPY 0])
+
+(LISP:DEFUN %%SETELT (SEQUENCE INDEX NEWVAL)
+   (LISP:IF (NOT (< -1 INDEX (LISP:LENGTH SEQUENCE)))
+       (LISP:ERROR 'INDEX-BOUNDS-ERROR :NAME SEQUENCE :INDEX INDEX))
+   (SEQ-DISPATCH SEQUENCE (LISP:SETF (LISP:NTH INDEX SEQUENCE)
+                                 NEWVAL)
+          (LISP:SETF (LISP:AREF SEQUENCE INDEX)
+                 NEWVAL)))
+
+(LISP:DEFUN MAKE-SEQUENCE-OF-TYPE (TYPE LENGTH)
+   [LET ((BROAD-TYPE (TYPE-SPECIFIER TYPE))
+         TYPE-LENGTH)
+        (LISP:IF (EQ BROAD-TYPE 'LIST)
+            (LISP:MAKE-LIST LENGTH)
+            [LET [(ELEMENT-TYPE (CASE BROAD-TYPE
+                                    ((LISP:SIMPLE-STRING STRING) 
+                                       (SETQ TYPE-LENGTH (AND (LISP:CONSP TYPE)
+                                                              (LISP:SECOND TYPE)))
+                                       'LISP:STRING-CHAR)
+                                    ((LISP:SIMPLE-BIT-VECTOR LISP:BIT-VECTOR) 
+                                       (SETQ TYPE-LENGTH (AND (LISP:CONSP TYPE)
+                                                              (LISP:SECOND TYPE)))
+                                       'BIT)
+                                    (LISP:SIMPLE-VECTOR 
+                                       (SETQ TYPE-LENGTH (AND (LISP:CONSP TYPE)
+                                                              (LISP:SECOND TYPE)))
+                                       T)
+                                    ((LISP:ARRAY LISP:VECTOR LISP:SIMPLE-ARRAY) 
+                                       (LISP:IF (LISP:CONSP TYPE)
+                                           (LET ((ELT-TYPE (CADR TYPE)))
+                                                (SETQ TYPE-LENGTH (LISP:THIRD TYPE))
+                                                (LISP:IF (LISP:CONSP TYPE-LENGTH)
+                                                    (SETQ TYPE-LENGTH (CAR TYPE-LENGTH)))
+                                                (LISP:IF [AND ELT-TYPE (NOT (EQ ELT-TYPE 'LISP:*]
+                                                    ELT-TYPE
+                                                    T))
+                                           T)))]
+                 (LISP:IF (AND (LISP:INTEGERP TYPE-LENGTH)
+                               (NOT (EQUAL TYPE-LENGTH LENGTH)))
+                        (LISP:ERROR "~D is not the length of type ~s" LENGTH TYPE))
+                 (LISP:IF ELEMENT-TYPE
+                     (MAKE-VECTOR LENGTH :ELEMENT-TYPE ELEMENT-TYPE)
+                     (LET ((EXPANDER (LISP::TYPE-EXPANDER BROAD-TYPE)))
+                          (LISP:IF EXPANDER
+                              (MAKE-SEQUENCE-OF-TYPE (LISP::TYPE-EXPAND TYPE EXPANDER)
+                                     LENGTH)
+                              (LISP:ERROR "~S is a bad type specifier for sequences." TYPE))))])])
+
+(LISP:DEFSETF LISP:ELT %%SETELT)
+
+(LISP:DEFSETF LISP:SUBSEQ (SEQUENCE START &OPTIONAL END) (NEW-SEQUENCE)
+   `(PROGN (LISP:REPLACE ,SEQUENCE ,NEW-SEQUENCE :START1 ,START :END1 ,END)
+           ,NEW-SEQUENCE))
+
+(PUTPROPS CMLSEQBASICS FILETYPE LISP:COMPILE-FILE)
+(DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(PUTPROPS CMLSEQBASICS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/CLTL2/CMLSEQBASICS.LCOM b/CLTL2/CMLSEQBASICS.LCOM
new file mode 100644
index 00000000..573b6df1
Binary files /dev/null and b/CLTL2/CMLSEQBASICS.LCOM differ
diff --git a/CLTL2/CMLSEQCOMMON b/CLTL2/CMLSEQCOMMON
new file mode 100644
index 00000000..591bb468
--- /dev/null
+++ b/CLTL2/CMLSEQCOMMON
@@ -0,0 +1,53 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+(FILECREATED " 6-Sep-91 14:19:03" {DSK}<new>venue>sources>CMLSEQCOMMON.;3 5402   
+
+      changes to%:  (OPTIMIZERS CL:COMPLEMENT) (VARS CMLSEQCOMMONCOMS) (FUNCTIONS CL:COMPLEMENT)
+
+      previous date%: "16-May-90 14:28:05" {DSK}<new>sources>lispcore>sources>CMLSEQCOMMON.;1)
+
+
+(* ; "
+Copyright (c) 1986, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLSEQCOMMONCOMS)
+
+(RPAQQ CMLSEQCOMMONCOMS ((FUNCTIONS CHECK-SUBSEQ COLLECT-ITEM COPY-VECTOR-SUBSEQ FILL-VECTOR-SUBSEQ MAKE-SEQUENCE-LIKE SEQ-DISPATCH TYPE-SPECIFIER) (FUNCTIONS BACKWARD-LIST-LOOP BACKWARD-VECTOR-LOOP FORWARD-LIST-LOOP FORWARD-VECTOR-LOOP) (FUNCTIONS CL:COMPLEMENT) (OPTIMIZERS CL:COMPLEMENT) (PROP FILETYPE CMLSEQCOMMON) (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (LOCALVARS . T))))
+
+(DEFMACRO CHECK-SUBSEQ (SEQ START END LENGTH) (BQUOTE (CL:IF (NOT (<= 0 (\, START) (\, END) (\, LENGTH))) (CL:ERROR "Illegal subsequence for ~S.~%%Start is ~D. End is ~D" (\, SEQ) (\, START) (\, END)))))
+
+(DEFMACRO COLLECT-ITEM (ITEM HEAD TAIL) (BQUOTE (CL:IF (\, TAIL) (RPLACD (\, TAIL) (SETQ (\, TAIL) (LIST (\, ITEM)))) (SETQ (\, HEAD) (SETQ (\, TAIL) (LIST (\, ITEM)))))))
+
+(DEFMACRO COPY-VECTOR-SUBSEQ (FROM-VECTOR START-FROM END-FROM TO-VECTOR START-TO END-TO) "Copy one vector subsequence to another" (BQUOTE (CL:DO ((FROM-INDEX (\, START-FROM) (CL:1+ FROM-INDEX)) (TO-INDEX (\, START-TO) (CL:1+ TO-INDEX))) ((\, (CL:IF END-FROM (BQUOTE (EQL FROM-INDEX (\, END-FROM))) (BQUOTE (EQL TO-INDEX (\, END-TO))))) (\, TO-VECTOR)) (CL:SETF (CL:AREF (\, TO-VECTOR) TO-INDEX) (CL:AREF (\, FROM-VECTOR) FROM-INDEX)))))
+
+(DEFMACRO FILL-VECTOR-SUBSEQ (VECTOR START END NEWVALUE) (BQUOTE (CL:DO ((INDEX (\, START) (CL:1+ INDEX))) ((EQL INDEX (\, END)) (\, VECTOR)) (CL:SETF (CL:AREF (\, VECTOR) INDEX) (\, NEWVALUE)))))
+
+(DEFMACRO MAKE-SEQUENCE-LIKE (SEQUENCE LENGTH) "Returns a sequence of the same type as SEQUENCE and the given LENGTH." (BQUOTE (LET ((SEQ (\, SEQUENCE))) (CL:ETYPECASE SEQ (LIST (CL:MAKE-LIST (\, LENGTH))) (STRING (CL:MAKE-STRING (\, LENGTH))) (CL:VECTOR (MAKE-VECTOR (\, LENGTH) :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE SEQ)))))))
+
+(DEFMACRO SEQ-DISPATCH (SEQUENCE LIST-FORM VECTOR-FORM) (BQUOTE (CL:ETYPECASE (\, SEQUENCE) (LIST (\, LIST-FORM)) (CL:VECTOR (\, VECTOR-FORM)))))
+
+(DEFMACRO TYPE-SPECIFIER (TYPE) "Returns the broad class of which TYPE is a specific subclass." (BQUOTE (CL:IF (CL:ATOM (\, TYPE)) (\, TYPE) (CAR (\, TYPE)))))
+
+(DEFMACRO BACKWARD-LIST-LOOP (SEQUENCE START END LOCAL-VARS RETURN-FORM &REST BODY) (LET ((INDEX-VAR (CAR LOCAL-VARS)) (CURRENT-ELEMENT-VAR (CADR LOCAL-VARS)) (OTHER-VARS (CDDR LOCAL-VARS))) (BQUOTE (CL:DO (((\, INDEX-VAR) (CL:1- (\, END)) (CL:1- (\, INDEX-VAR))) %%SUBSEQ (\, CURRENT-ELEMENT-VAR) (\,@ OTHER-VARS)) ((< (\, INDEX-VAR) (\, START)) (\, RETURN-FORM)) (SETQ %%SUBSEQ (CL:NTHCDR (\, INDEX-VAR) (\, SEQUENCE))) (SETQ (\, CURRENT-ELEMENT-VAR) (CAR %%SUBSEQ)) (\,@ BODY)))))
+
+(DEFMACRO BACKWARD-VECTOR-LOOP (SEQUENCE START END LOCAL-VARS RETURN-FORM &REST BODY) (LET ((INDEX-VAR (CAR LOCAL-VARS)) (CURRENT-ELEMENT-VAR (CADR LOCAL-VARS)) (OTHER-VARS (CDDR LOCAL-VARS))) (BQUOTE (CL:DO (((\, INDEX-VAR) (CL:1- (\, END)) (CL:1- (\, INDEX-VAR))) (\, CURRENT-ELEMENT-VAR) (\,@ OTHER-VARS)) ((< (\, INDEX-VAR) (\, START)) (\, RETURN-FORM)) (SETQ (\, CURRENT-ELEMENT-VAR) (CL:AREF (\, SEQUENCE) (\, INDEX-VAR))) (\,@ BODY)))))
+
+(DEFMACRO FORWARD-LIST-LOOP (SEQUENCE START END LOCAL-VARS RETURN-FORM &REST BODY) (LET ((INDEX-VAR (CAR LOCAL-VARS)) (CURRENT-ELEMENT-VAR (CADR LOCAL-VARS)) (OTHER-VARS (CDDR LOCAL-VARS))) (BQUOTE (CL:DO ((%%SUBSEQ (CL:NTHCDR (\, START) (\, SEQUENCE)) (CDR %%SUBSEQ)) ((\, INDEX-VAR) (\, START) (CL:1+ (\, INDEX-VAR))) (\, CURRENT-ELEMENT-VAR) (\,@ OTHER-VARS)) ((EQL (\, INDEX-VAR) (\, END)) (\, RETURN-FORM)) (SETQ (\, CURRENT-ELEMENT-VAR) (CAR %%SUBSEQ)) (\,@ BODY)))))
+
+(DEFMACRO FORWARD-VECTOR-LOOP (SEQUENCE START END LOCAL-VARS RETURN-FORM &REST BODY) "Canonical forward loop for vectors" (LET ((INDEX-VAR (CAR LOCAL-VARS)) (CURRENT-ELEMENT-VAR (CADR LOCAL-VARS)) (OTHER-VARS (CDDR LOCAL-VARS))) (BQUOTE (CL:DO (((\, INDEX-VAR) (\, START) (CL:1+ (\, INDEX-VAR))) (\, CURRENT-ELEMENT-VAR) (\,@ OTHER-VARS)) ((EQL (\, INDEX-VAR) (\, END)) (\, RETURN-FORM)) (SETQ (\, CURRENT-ELEMENT-VAR) (CL:AREF (\, SEQUENCE) (\, INDEX-VAR))) (\,@ BODY)))))
+
+(CL:DEFUN CL:COMPLEMENT (CL::FN) (CL:FUNCTION (CL:LAMBDA (&REST CL::ARGUMENTS) (NOT (CL:APPLY CL::FN CL::ARGUMENTS)))))
+
+(DEFOPTIMIZER CL:COMPLEMENT (CL::FN &ENVIRONMENT CL::ENV) (* ;; "If we can find the argument list for FN and it's a simple one (it will be 99%% of the time), we can build a decent COMPLEMENT that doesn't do the extra &REST and APPLY") (LET (CL::FN-NAME CL::FN-ARG-LIST) (CL:IF (AND (CL:CONSP CL::FN) (OR (EQ (CAR CL::FN) (QUOTE QUOTE)) (EQ (CAR CL::FN) (QUOTE CL:FUNCTION))) (CL:SYMBOLP (CL:SETQ CL::FN-NAME (CADR CL::FN))) (CL:CONSP (CL:SETQ CL::FN-ARG-LIST (CAR (NLSETQ (SMARTARGLIST CL::FN-NAME)))))) (BQUOTE (CL:FUNCTION (CL:LAMBDA (\, CL::FN-ARG-LIST) (NOT ((\, CL::FN-NAME) (\,@ CL::FN-ARG-LIST)))))) (QUOTE COMPILER:PASS))))
+
+(PUTPROPS CMLSEQCOMMON FILETYPE CL:COMPILE-FILE)
+(DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(PUTPROPS CMLSEQCOMMON COPYRIGHT ("Venue & Xerox Corporation" 1986 1990 1991))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/CLTL2/CMLSEQCOMMON.LCOM b/CLTL2/CMLSEQCOMMON.LCOM
new file mode 100644
index 00000000..58371b22
Binary files /dev/null and b/CLTL2/CMLSEQCOMMON.LCOM differ
diff --git a/CLTL2/CMLSEQMAPPERS b/CLTL2/CMLSEQMAPPERS
new file mode 100644
index 00000000..b72b2eeb
--- /dev/null
+++ b/CLTL2/CMLSEQMAPPERS
@@ -0,0 +1,115 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "29-Aug-91 16:51:48" {DSK}<new>sources>lispcore>sources>CMLSEQMAPPERS.;2 14225  
+
+      changes to%:  (FUNCTIONS REDUCE-FROM-END REDUCE-FROM-START CL:REDUCE)
+
+      previous date%: "16-May-90 14:31:36" {DSK}<new>sources>lispcore>sources>CMLSEQMAPPERS.;1)
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLSEQMAPPERSCOMS)
+
+(RPAQQ CMLSEQMAPPERSCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES CMLSEQCOMMON)) (FUNCTIONS %%FILL-SLICE %%MAP-FOR-EFFECT %%MAP-FOR-EFFECT-MULTIPLE %%MAP-FOR-EFFECT-SINGLE %%MAP-FOR-RESULT-MULTIPLE %%MAP-FOR-RESULT-SINGLE %%MIN-SEQUENCE-LENGTH CL:MAP) (* ;; "For compatibility with old optimizers") (FUNCTIONS %%MAP-SINGLE-FOR-EFFECT %%MAP-SINGLE-TO-LIST %%MAP-SINGLE-TO-SIMPLE %%MAP-TO-LIST %%MAP-TO-SIMPLE) (OPTIMIZERS CL:MAP) (FUNCTIONS %%SOME-MULTIPLE %%SOME-SINGLE %%EVERY-MULTIPLE %%EVERY-SINGLE %%NOTANY-MULTIPLE %%NOTANY-SINGLE %%NOTEVERY-MULTIPLE %%NOTEVERY-SINGLE CL:SOME CL:EVERY CL:NOTANY CL:NOTEVERY) (* ;; "For compatibility with old optimizers") (P (MOVD (QUOTE %%SOME-SINGLE) (QUOTE %%SINGLE-SOME)) (MOVD (QUOTE %%EVERY-SINGLE) (QUOTE %%SINGLE-EVERY)) (MOVD (QUOTE %%NOTEVERY-SINGLE) (QUOTE %%SINGLE-NOTEVERY)) (MOVD (QUOTE %%NOTANY-SINGLE) (QUOTE %%SINGLE-NOTANY))) (OPTIMIZERS CL:SOME CL:EVERY CL:NOTANY CL:NOTEVERY) (FUNCTIONS REDUCE-FROM-END REDUCE-FROM-START CL:REDUCE) (PROP FILETYPE CMLSEQMAPPERS) (DECLARE%: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T))))
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+
+(FILESLOAD CMLSEQCOMMON)
+)
+
+(DEFMACRO %%FILL-SLICE (INDEX SLICE SEQUENCES) (BQUOTE (CL:DO ((%%SUBSLICE (\, SLICE) (CDR %%SUBSLICE)) (%%SUBSEQ (\, SEQUENCES) (CDR %%SUBSEQ)) %%SEQUENCE) ((NULL %%SUBSEQ) (\, SLICE)) (SETQ %%SEQUENCE (CAR %%SUBSEQ)) (RPLACA %%SUBSLICE (SEQ-DISPATCH %%SEQUENCE (PROG1 (CAR %%SEQUENCE) (RPLACA %%SUBSEQ (CDR %%SEQUENCE))) (CL:AREF %%SEQUENCE (\, INDEX)))))))
+
+(CL:DEFUN %%MAP-FOR-EFFECT (FUNCTION SEQUENCE &REST MORE-SEQUENCES) (CL:IF (NULL MORE-SEQUENCES) (%%MAP-FOR-EFFECT-SINGLE FUNCTION SEQUENCE) (%%MAP-FOR-EFFECT-MULTIPLE FUNCTION (CONS SEQUENCE MORE-SEQUENCES))))
+
+(CL:DEFUN %%MAP-FOR-EFFECT-MULTIPLE (FUNCTION SEQUENCES) (LET ((MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES)))) (CL:DOTIMES (I MIN-LENGTH) (CL:APPLY FUNCTION (%%FILL-SLICE I ELT-SLICE SEQUENCES)))))
+
+(CL:DEFUN %%MAP-FOR-EFFECT-SINGLE (FUNCTION SEQUENCE) (SEQ-DISPATCH SEQUENCE (CL:DOLIST (ELT SEQUENCE) (CL:FUNCALL FUNCTION ELT)) (CL:DOTIMES (I (VECTOR-LENGTH SEQUENCE)) (CL:FUNCALL FUNCTION (CL:AREF SEQUENCE I)))))
+
+(CL:DEFUN %%MAP-FOR-RESULT-MULTIPLE (RESULT-TYPE FUNCTION SEQUENCES) (LET* ((MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES))) (RESULT (MAKE-SEQUENCE-OF-TYPE RESULT-TYPE MIN-LENGTH))) (SEQ-DISPATCH RESULT (CL:DO ((SUBRESULT RESULT (CDR SUBRESULT)) (INDEX 0 (CL:1+ INDEX))) ((EQL INDEX MIN-LENGTH) RESULT) (RPLACA SUBRESULT (CL:APPLY FUNCTION (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES)))) (CL:DO ((INDEX 0 (CL:1+ INDEX))) ((EQL INDEX MIN-LENGTH) RESULT) (CL:SETF (CL:AREF RESULT INDEX) (CL:APPLY FUNCTION (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES)))))))
+
+(CL:DEFUN %%MAP-FOR-RESULT-SINGLE (RESULT-TYPE FUNCTION SEQUENCE) (LET* ((LENGTH (CL:LENGTH SEQUENCE)) (RESULT (MAKE-SEQUENCE-OF-TYPE RESULT-TYPE LENGTH))) (SEQ-DISPATCH SEQUENCE (SEQ-DISPATCH RESULT (CL:DO ((SUBSEQ SEQUENCE (CDR SUBSEQ)) (SUBRESULT RESULT (CDR SUBRESULT))) ((NULL SUBSEQ)) (RPLACA SUBRESULT (CL:FUNCALL FUNCTION (CAR SUBSEQ)))) (CL:DO ((SUBSEQ SEQUENCE (CDR SUBSEQ)) (INDEX 0 (CL:1+ INDEX))) ((NULL SUBSEQ)) (CL:SETF (CL:AREF RESULT INDEX) (CL:FUNCALL FUNCTION (CAR SUBSEQ))))) (SEQ-DISPATCH RESULT (CL:DO ((INDEX 0 (CL:1+ INDEX)) (SUBRESULT RESULT (CDR SUBRESULT))) ((EQL INDEX LENGTH)) (RPLACA SUBRESULT (CL:FUNCALL FUNCTION (CL:AREF SEQUENCE INDEX)))) (CL:DO ((INDEX 0 (CL:1+ INDEX))) ((EQL INDEX LENGTH)) (CL:SETF (CL:AREF RESULT INDEX) (CL:FUNCALL FUNCTION (CL:AREF SEQUENCE INDEX)))))) RESULT))
+
+(DEFMACRO %%MIN-SEQUENCE-LENGTH (SEQUENCES) (BQUOTE (CL:DO ((MIN-LENGTH (CL:LENGTH (CAR (\, SEQUENCES)))) (SUBSEQ (CDR (\, SEQUENCES)) (CDR SUBSEQ)) NEXT-LENGTH) ((NULL SUBSEQ) MIN-LENGTH) (SETQ NEXT-LENGTH (CL:LENGTH (CAR SUBSEQ))) (CL:IF (< NEXT-LENGTH MIN-LENGTH) (SETQ MIN-LENGTH NEXT-LENGTH)))))
+
+(CL:DEFUN CL:MAP (RESULT-TYPE FUNCTION SEQUENCE &REST MORE-SEQUENCES) "FUNCTION must take as many arguments as there are sequences provided.  The result is a sequence such that element i is the result of applying FUNCTION to element i of each of the argument sequences." (CL:IF (NULL RESULT-TYPE) (CL:IF (NULL MORE-SEQUENCES) (%%MAP-FOR-EFFECT-SINGLE FUNCTION SEQUENCE) (%%MAP-FOR-EFFECT-MULTIPLE FUNCTION (CONS SEQUENCE MORE-SEQUENCES))) (CL:IF (NULL MORE-SEQUENCES) (%%MAP-FOR-RESULT-SINGLE RESULT-TYPE FUNCTION SEQUENCE) (%%MAP-FOR-RESULT-MULTIPLE RESULT-TYPE FUNCTION (CONS SEQUENCE MORE-SEQUENCES)))))
+
+
+
+(* ;; "For compatibility with old optimizers")
+
+
+(CL:DEFUN %%MAP-SINGLE-FOR-EFFECT (FUNCTION SEQUENCE) (%%MAP-FOR-EFFECT-SINGLE FUNCTION SEQUENCE))
+
+(CL:DEFUN %%MAP-SINGLE-TO-LIST (FUNCTION SEQUENCE) (%%MAP-FOR-RESULT-SINGLE (QUOTE LIST) FUNCTION SEQUENCE))
+
+(CL:DEFUN %%MAP-SINGLE-TO-SIMPLE (RESULT-TYPE FUNCTION SEQUENCE) (%%MAP-FOR-RESULT-SINGLE RESULT-TYPE FUNCTION SEQUENCE))
+
+(CL:DEFUN %%MAP-TO-LIST (FUNCTION SEQUENCE &REST MORE-SEQUENCES) (CL:IF (NULL MORE-SEQUENCES) (%%MAP-FOR-RESULT-SINGLE (QUOTE LIST) FUNCTION SEQUENCE) (%%MAP-FOR-RESULT-MULTIPLE (QUOTE LIST) FUNCTION (CONS SEQUENCE MORE-SEQUENCES))))
+
+(CL:DEFUN %%MAP-TO-SIMPLE (RESULT-TYPE FUNCTION SEQUENCE &REST MORE-SEQUENCES) (CL:IF (NULL MORE-SEQUENCES) (%%MAP-FOR-RESULT-SINGLE RESULT-TYPE FUNCTION SEQUENCE) (%%MAP-FOR-RESULT-MULTIPLE RESULT-TYPE FUNCTION (CONS SEQUENCE MORE-SEQUENCES))))
+
+(DEFOPTIMIZER CL:MAP (RESULT-TYPE FUNCTION FIRST-SEQUNCE &REST MORE-SEQUENCES) (CL:IF (AND (NULL MORE-SEQUENCES) (CL:CONSTANTP RESULT-TYPE)) (CL:IF (NULL (EVAL RESULT-TYPE)) (BQUOTE (%%MAP-FOR-EFFECT-SINGLE (\, FUNCTION) (\, FIRST-SEQUNCE))) (BQUOTE (%%MAP-FOR-RESULT-SINGLE (\, RESULT-TYPE) (\, FUNCTION) (\, FIRST-SEQUNCE)))) (QUOTE COMPILER:PASS)))
+
+(CL:DEFUN %%SOME-MULTIPLE (PREDICATE SEQUENCES) (LET ((MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES)))) (CL:DO ((INDEX 0 (CL:1+ INDEX)) PREDICATE-RESULT) ((EQL INDEX MIN-LENGTH)) (SETQ PREDICATE-RESULT (CL:APPLY PREDICATE (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES))) (CL:IF PREDICATE-RESULT (RETURN PREDICATE-RESULT)))))
+
+(CL:DEFUN %%SOME-SINGLE (PREDICATE SEQUENCE) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE 0 LENGTH (INDEX CURRENT PREDICATE-RESULT) NIL (SETQ PREDICATE-RESULT (CL:FUNCALL PREDICATE CURRENT)) (CL:IF PREDICATE-RESULT (RETURN PREDICATE-RESULT))) (FORWARD-VECTOR-LOOP SEQUENCE 0 LENGTH (INDEX CURRENT PREDICATE-RESULT) NIL (SETQ PREDICATE-RESULT (CL:FUNCALL PREDICATE CURRENT)) (CL:IF PREDICATE-RESULT (RETURN PREDICATE-RESULT))))))
+
+(CL:DEFUN %%EVERY-MULTIPLE (PREDICATE SEQUENCES) (LET ((MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES)))) (CL:DOTIMES (INDEX MIN-LENGTH T) (CL:IF (NULL (CL:APPLY PREDICATE (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES))) (RETURN NIL)))))
+
+(CL:DEFUN %%EVERY-SINGLE (PREDICATE FIRST-SEQUENCE) (SEQ-DISPATCH FIRST-SEQUENCE (CL:DOLIST (ELT FIRST-SEQUENCE T) (CL:IF (NULL (CL:FUNCALL PREDICATE ELT)) (RETURN NIL))) (CL:DOTIMES (INDEX (VECTOR-LENGTH FIRST-SEQUENCE) T) (CL:IF (NULL (CL:FUNCALL PREDICATE (CL:AREF FIRST-SEQUENCE INDEX))) (RETURN NIL)))))
+
+(CL:DEFUN %%NOTANY-MULTIPLE (PREDICATE SEQUENCES) (LET ((MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES)))) (CL:DOTIMES (INDEX MIN-LENGTH T) (CL:IF (CL:APPLY PREDICATE (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES)) (RETURN NIL)))))
+
+(CL:DEFUN %%NOTANY-SINGLE (PREDICATE FIRST-SEQUENCE) (SEQ-DISPATCH FIRST-SEQUENCE (CL:DOLIST (ELT FIRST-SEQUENCE T) (CL:IF (CL:FUNCALL PREDICATE ELT) (RETURN NIL))) (CL:DOTIMES (I (VECTOR-LENGTH FIRST-SEQUENCE) T) (CL:IF (CL:FUNCALL PREDICATE (CL:AREF FIRST-SEQUENCE I)) (RETURN NIL)))))
+
+(CL:DEFUN %%NOTEVERY-MULTIPLE (PREDICATE SEQUENCES) (LET ((MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES)))) (CL:DOTIMES (INDEX MIN-LENGTH) (CL:IF (NULL (CL:APPLY PREDICATE (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES))) (RETURN T)))))
+
+(CL:DEFUN %%NOTEVERY-SINGLE (PREDICATE FIRST-SEQUENCE) (SEQ-DISPATCH FIRST-SEQUENCE (CL:DOLIST (ELT FIRST-SEQUENCE) (CL:IF (NULL (CL:FUNCALL PREDICATE ELT)) (RETURN T))) (CL:DOTIMES (I (VECTOR-LENGTH FIRST-SEQUENCE)) (CL:IF (NULL (CL:FUNCALL PREDICATE (CL:AREF FIRST-SEQUENCE I))) (RETURN T)))))
+
+(CL:DEFUN CL:SOME (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on.  SOME returns the first non-() value encountered, or () if the end of a sequence is reached." (CL:IF (NULL MORE-SEQUENCES) (%%SOME-SINGLE PREDICATE FIRST-SEQUENCE) (%%SOME-MULTIPLE PREDICATE (CONS FIRST-SEQUENCE MORE-SEQUENCES))))
+
+(CL:DEFUN CL:EVERY (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on.  EVERY returns () as soon as any invocation of PREDICATE returns (), or T if every invocation is non-()." (CL:IF (NULL MORE-SEQUENCES) (%%EVERY-SINGLE PREDICATE FIRST-SEQUENCE) (%%EVERY-MULTIPLE PREDICATE (CONS FIRST-SEQUENCE MORE-SEQUENCES))))
+
+(CL:DEFUN CL:NOTANY (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on.  NOTANY returns () as soon as any invocation of PREDICATE returns a non-() value, or T if the end of a sequence is reached." (CL:IF (NULL MORE-SEQUENCES) (%%NOTANY-SINGLE PREDICATE FIRST-SEQUENCE) (%%NOTANY-MULTIPLE PREDICATE (CONS FIRST-SEQUENCE MORE-SEQUENCES))))
+
+(CL:DEFUN CL:NOTEVERY (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on.  NOTEVERY returns T as soon as any invocation of PREDICATE returns (), or () if every invocation is non-()." (CL:IF (NULL MORE-SEQUENCES) (%%NOTEVERY-SINGLE PREDICATE FIRST-SEQUENCE) (%%NOTEVERY-MULTIPLE PREDICATE (CONS FIRST-SEQUENCE MORE-SEQUENCES))))
+
+
+
+(* ;; "For compatibility with old optimizers")
+
+
+(MOVD (QUOTE %%SOME-SINGLE) (QUOTE %%SINGLE-SOME))
+
+(MOVD (QUOTE %%EVERY-SINGLE) (QUOTE %%SINGLE-EVERY))
+
+(MOVD (QUOTE %%NOTEVERY-SINGLE) (QUOTE %%SINGLE-NOTEVERY))
+
+(MOVD (QUOTE %%NOTANY-SINGLE) (QUOTE %%SINGLE-NOTANY))
+
+(DEFOPTIMIZER CL:SOME (PREDICATE SEQUENCE &REST MORE-SEQUENCES) (COND ((NULL MORE-SEQUENCES) (BQUOTE (%%SOME-SINGLE (\, PREDICATE) (\, SEQUENCE)))) (T (QUOTE COMPILER:PASS))))
+
+(DEFOPTIMIZER CL:EVERY (PREDICATE SEQUENCE &REST MORE-SEQUENCES) (COND ((NULL MORE-SEQUENCES) (BQUOTE (%%EVERY-SINGLE (\, PREDICATE) (\, SEQUENCE)))) (T (QUOTE COMPILER:PASS))))
+
+(DEFOPTIMIZER CL:NOTANY (PREDICATE SEQUENCE &REST MORE-SEQUENCES) (COND ((NULL MORE-SEQUENCES) (BQUOTE (%%NOTANY-SINGLE (\, PREDICATE) (\, SEQUENCE)))) (T (QUOTE COMPILER:PASS))))
+
+(DEFOPTIMIZER CL:NOTEVERY (PREDICATE SEQUENCE &REST MORE-SEQUENCES) (COND ((NULL MORE-SEQUENCES) (BQUOTE (%%NOTEVERY-SINGLE (\, PREDICATE) (\, SEQUENCE)))) (T (QUOTE COMPILER:PASS))))
+
+(CL:DEFUN REDUCE-FROM-END (FUNCTION SEQUENCE START END INITIAL-VALUE &OPTIONAL KEY) "Backward reduction" (CL:IF KEY (SEQ-DISPATCH SEQUENCE (BACKWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION (CL:FUNCALL KEY CURRENT) ACCUMULATOR))) (BACKWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION (CL:FUNCALL KEY CURRENT) ACCUMULATOR)))) (SEQ-DISPATCH SEQUENCE (BACKWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION CURRENT ACCUMULATOR))) (BACKWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION CURRENT ACCUMULATOR))))))
+
+(CL:DEFUN REDUCE-FROM-START (FUNCTION SEQUENCE START END INITIAL-VALUE &OPTIONAL KEY) (CL:IF KEY (SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION ACCUMULATOR (CL:FUNCALL KEY CURRENT)))) (FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION ACCUMULATOR (CL:FUNCALL KEY CURRENT))))) (SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION ACCUMULATOR CURRENT))) (FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION ACCUMULATOR CURRENT))))))
+
+(CL:DEFUN CL:REDUCE (FUNCTION SEQUENCE &KEY (START 0) END FROM-END (INITIAL-VALUE NIL INITIAL-VALUE-P) (KEY (QUOTE CL:IDENTITY) KEY-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF INITIAL-VALUE-P (CL:IF FROM-END (REDUCE-FROM-END FUNCTION SEQUENCE START END INITIAL-VALUE (AND KEY-P KEY)) (REDUCE-FROM-START FUNCTION SEQUENCE START END INITIAL-VALUE (AND KEY-P KEY))) (CASE (- END START) (0 (CL:FUNCALL FUNCTION)) (1 (CL:FUNCALL KEY (CL:ELT SEQUENCE START))) (T (CL:IF FROM-END (REDUCE-FROM-END FUNCTION SEQUENCE START (CL:1- END) (CL:FUNCALL KEY (CL:ELT SEQUENCE (CL:1- END))) (AND KEY-P KEY)) (REDUCE-FROM-START FUNCTION SEQUENCE (CL:1+ START) END (CL:FUNCALL KEY (CL:ELT SEQUENCE START)) (AND KEY-P KEY))))))))
+
+(PUTPROPS CMLSEQMAPPERS FILETYPE CL:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(PUTPROPS CMLSEQMAPPERS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/CLTL2/CMLSEQMAPPERS.LCOM b/CLTL2/CMLSEQMAPPERS.LCOM
new file mode 100644
index 00000000..215fc529
Binary files /dev/null and b/CLTL2/CMLSEQMAPPERS.LCOM differ
diff --git a/CLTL2/CMLSEQMODIFY b/CLTL2/CMLSEQMODIFY
new file mode 100644
index 00000000..d23f7b63
--- /dev/null
+++ b/CLTL2/CMLSEQMODIFY
@@ -0,0 +1,143 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "29-Aug-91 16:38:18" {DSK}<new>sources>lispcore>sources>CMLSEQMODIFY.;2 34278  
+
+      changes to%:  (VARS CMLSEQMODIFYCOMS) (FUNCTIONS CL:MAP-INTO CL::MAP-INTO-SINGLE CL::MAP-INTO-MULTIPLE)
+
+      previous date%: "16-May-90 14:33:28" {DSK}<new>sources>lispcore>sources>CMLSEQMODIFY.;1)
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLSEQMODIFYCOMS)
+
+(RPAQQ CMLSEQMODIFYCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES CMLSEQCOMMON)) (FUNCTIONS CL:FILL CL:REPLACE) (FUNCTIONS %%DESTRUCTIVE-RESULT-VECTOR) (FUNCTIONS SIMPLE-REMOVE-MACRO SIMPLE-REMOVE SIMPLE-REMOVE-IF SIMPLE-REMOVE-IF-NOT COMPLEX-REMOVE-MACRO COMPLEX-REMOVE COMPLEX-REMOVE-IF COMPLEX-REMOVE-IF-NOT CL:REMOVE CL:REMOVE-IF CL:REMOVE-IF-NOT) (FUNCTIONS SIMPLE-DELETE-MACRO SIMPLE-DELETE SIMPLE-DELETE-IF SIMPLE-DELETE-IF-NOT COMPLEX-DELETE-MACRO COMPLEX-DELETE COMPLEX-DELETE-IF COMPLEX-DELETE-IF-NOT CL:DELETE CL:DELETE-IF CL:DELETE-IF-NOT) (FUNCTIONS SIMPLE-REMOVE-DUPLICATES COMPLEX-REMOVE-DUPLICATES CL:REMOVE-DUPLICATES) (FUNCTIONS SIMPLE-DELETE-DUPLICATES COMPLEX-DELETE-DUPLICATES CL:DELETE-DUPLICATES) (FUNCTIONS SIMPLE-SUBSTITUTE-MACRO SIMPLE-SUBSTITUTE SIMPLE-SUBSTITUTE-IF SIMPLE-SUBSTITUTE-IF-NOT COMPLEX-SUBSTITUTE-MACRO COMPLEX-SUBSTITUTE COMPLEX-SUBSTITUTE-IF COMPLEX-SUBSTITUTE-IF-NOT CL:SUBSTITUTE CL:SUBSTITUTE-IF CL:SUBSTITUTE-IF-NOT) (FUNCTIONS SIMPLE-NSUBSTITUTE-MACRO SIMPLE-NSUBSTITUTE SIMPLE-NSUBSTITUTE-IF SIMPLE-NSUBSTITUTE-IF-NOT COMPLEX-NSUBSTITUTE-MACRO COMPLEX-NSUBSTITUTE COMPLEX-NSUBSTITUTE-IF COMPLEX-NSUBSTITUTE-IF-NOT CL:NSUBSTITUTE CL:NSUBSTITUTE-IF CL:NSUBSTITUTE-IF-NOT) (FUNCTIONS CL:MAP-INTO CL::MAP-INTO-SINGLE CL::MAP-INTO-MULTIPLE) (PROP FILETYPE CMLSEQMODIFY) (DECLARE%: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE (LOCALVARS . T))))
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+
+(FILESLOAD CMLSEQCOMMON)
+)
+
+(CL:DEFUN CL:FILL (SEQUENCE ITEM &KEY (START 0) END) "Replace the specified elements of SEQUENCE with ITEM." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT) SEQUENCE (RPLACA %%SUBSEQ ITEM)) (FILL-VECTOR-SUBSEQ SEQUENCE START END ITEM))))
+
+(CL:DEFUN CL:REPLACE (SEQUENCE1 SEQUENCE2 &KEY (START1 0) END1 (START2 0) END2) (LET ((LENGTH1 (CL:LENGTH SEQUENCE1)) (LENGTH2 (CL:LENGTH SEQUENCE2))) (CL:IF (NULL END1) (SETQ END1 LENGTH1)) (CL:IF (NULL END2) (SETQ END2 LENGTH2)) (CHECK-SUBSEQ SEQUENCE1 START1 END1 LENGTH1) (CHECK-SUBSEQ SEQUENCE2 START2 END2 LENGTH2) (LET ((SUBLEN1 (- END1 START1)) (SUBLEN2 (- END2 START2))) (* ; "Make equal length") (CL:IF (< SUBLEN1 SUBLEN2) (SETQ END2 (+ START2 SUBLEN1)) (SETQ END1 (+ START1 SUBLEN2))) (* ; "Check for overlap") (CL:WHEN (AND (EQ SEQUENCE1 SEQUENCE2) (> START1 START2) (< START1 END2)) (SETQ SEQUENCE2 (CL:SUBSEQ SEQUENCE2 START2 END2)) (SETQ START2 0) (SETQ END2 (- END2 START2))) (SEQ-DISPATCH SEQUENCE1 (SEQ-DISPATCH SEQUENCE2 (CL:DO ((SUBSEQ1 (CL:NTHCDR START1 SEQUENCE1) (CDR SUBSEQ1)) (SUBSEQ2 (CL:NTHCDR START2 SEQUENCE2) (CDR SUBSEQ2)) (INDEX1 START1 (CL:1+ INDEX1))) ((EQL INDEX1 END1)) (RPLACA SUBSEQ1 (CAR SUBSEQ2))) (CL:DO ((SUBSEQ1 (CL:NTHCDR START1 SEQUENCE1) (CDR SUBSEQ1)) (INDEX1 START1 (CL:1+ INDEX1)) (INDEX2 START2 (CL:1+ INDEX2))) ((EQL INDEX1 END1)) (RPLACA SUBSEQ1 (CL:AREF SEQUENCE2 INDEX2)))) (SEQ-DISPATCH SEQUENCE2 (CL:DO ((SUBSEQ2 (CL:NTHCDR START2 SEQUENCE2) (CDR SUBSEQ2)) (INDEX1 START1 (CL:1+ INDEX1))) ((EQL INDEX1 END1)) (CL:SETF (CL:AREF SEQUENCE1 INDEX1) (CAR SUBSEQ2))) (CL:DO ((INDEX1 START1 (CL:1+ INDEX1)) (INDEX2 START2 (CL:1+ INDEX2))) ((EQL INDEX1 END1)) (CL:SETF (CL:AREF SEQUENCE1 INDEX1) (CL:AREF SEQUENCE2 INDEX2))))) SEQUENCE1)))
+
+(CL:DEFUN %%DESTRUCTIVE-RESULT-VECTOR (VECTOR START) (CL:IF (CL:ARRAY-HAS-FILL-POINTER-P VECTOR) VECTOR (LET ((RESULT (CL:MAKE-ARRAY (VECTOR-LENGTH VECTOR) :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE VECTOR) :FILL-POINTER T))) (COPY-VECTOR VECTOR RESULT :END1 START))))
+
+(DEFMACRO SIMPLE-REMOVE-MACRO (SEQUENCE START END TEST-FORM) (BQUOTE (SEQ-DISPATCH (\, SEQUENCE) (LET ((RESULT-HEAD (CL:SUBSEQ (\, SEQUENCE) 0 (\, START))) (RESULT-TAIL (CL:NTHCDR (\, END) (\, SEQUENCE))) (RESULT-MIDDLE (FORWARD-LIST-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT NEW-LIST TAIL) NEW-LIST (CL:IF (NOT (\, TEST-FORM)) (COLLECT-ITEM CURRENT NEW-LIST TAIL))))) (NCONC RESULT-HEAD RESULT-MIDDLE RESULT-TAIL)) (LET* ((LENGTH (VECTOR-LENGTH (\, SEQUENCE))) (RESULT (CL:MAKE-ARRAY LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE (\, SEQUENCE)) :FILL-POINTER T)) (NUMBER-OF-MATCHES 0)) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) 0 (\, START) RESULT 0) (FORWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT (SLOW-INDEX (\, START))) NIL (COND ((NOT (\, TEST-FORM)) (CL:SETF (CL:AREF RESULT SLOW-INDEX) CURRENT) (CL:INCF SLOW-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES)))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) (\, END) LENGTH RESULT (- (\, END) NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT))))
+
+(CL:DEFUN SIMPLE-REMOVE (ITEM SEQUENCE START END) (SIMPLE-REMOVE-MACRO SEQUENCE START END (EQL ITEM CURRENT)))
+
+(CL:DEFUN SIMPLE-REMOVE-IF (TEST SEQUENCE START END) (SIMPLE-REMOVE-MACRO SEQUENCE START END (CL:FUNCALL TEST CURRENT)))
+
+(CL:DEFUN SIMPLE-REMOVE-IF-NOT (TEST SEQUENCE START END) (SIMPLE-REMOVE-MACRO SEQUENCE START END (NOT (CL:FUNCALL TEST CURRENT))))
+
+(DEFMACRO COMPLEX-REMOVE-MACRO (SEQUENCE START END FROM-END KEY COUNT TEST-FORM) (BQUOTE (LET ((NUMBER-OF-MATCHES 0)) (SEQ-DISPATCH (\, SEQUENCE) (LET ((RESULT-HEAD (CL:SUBSEQ (\, SEQUENCE) 0 (\, START))) (RESULT-TAIL (CL:NTHCDR (\, END) (\, SEQUENCE))) (RESULT-MIDDLE (CL:IF (NULL (AND (\, FROM-END) (\, COUNT))) (FORWARD-LIST-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT NEW-LIST TAIL) NEW-LIST (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) (COLLECT-ITEM CURRENT NEW-LIST TAIL)) (T (CL:INCF NUMBER-OF-MATCHES)))) (BACKWARD-LIST-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT NEW-LIST) NEW-LIST (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) (CL:PUSH CURRENT NEW-LIST)) (T (CL:INCF NUMBER-OF-MATCHES))))))) (NCONC RESULT-HEAD RESULT-MIDDLE RESULT-TAIL)) (LET* ((LENGTH (VECTOR-LENGTH (\, SEQUENCE))) (RESULT (CL:MAKE-ARRAY LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE (\, SEQUENCE)) :FILL-POINTER T))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) 0 (\, START) RESULT 0) (CL:IF (NULL (AND (\, FROM-END) (\, COUNT))) (FORWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT (RESULT-INDEX (\, START))) NIL (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:INCF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES)))) (BACKWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT (RESULT-INDEX (CL:1- (\, END)))) (AND (> NUMBER-OF-MATCHES 0) (COPY-VECTOR-SUBSEQ RESULT (+ (\, START) NUMBER-OF-MATCHES) (\, END) RESULT (\, START) (- (\, END) NUMBER-OF-MATCHES))) (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:DECF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES))))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) (\, END) LENGTH RESULT (- (\, END) NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT)))))
+
+(CL:DEFUN COMPLEX-REMOVE (ITEM SEQUENCE START END FROM-END KEY COUNT TEST TEST-NOT-P) (COMPLEX-REMOVE-MACRO SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P (NOT (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT))) (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT)))))
+
+(CL:DEFUN COMPLEX-REMOVE-IF (TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-REMOVE-MACRO SEQUENCE START END FROM-END KEY COUNT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT))))
+
+(CL:DEFUN COMPLEX-REMOVE-IF-NOT (TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-REMOVE-MACRO SEQUENCE START END FROM-END KEY COUNT (NOT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT)))))
+
+(CL:DEFUN CL:REMOVE (ITEM SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P) (TEST (QUOTE EQL) TEST-P) (TEST-NOT NIL TEST-NOT-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P COUNT TEST-P TEST-NOT-P) (COMPLEX-REMOVE ITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-REMOVE ITEM SEQUENCE START END))))
+
+(CL:DEFUN CL:REMOVE-IF (TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-REMOVE-IF TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-REMOVE-IF TEST SEQUENCE START END))))
+
+(CL:DEFUN CL:REMOVE-IF-NOT (TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-REMOVE-IF-NOT TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-REMOVE-IF-NOT TEST SEQUENCE START END))))
+
+(DEFMACRO SIMPLE-DELETE-MACRO (SEQUENCE START END TEST-FORM) (BQUOTE (SEQ-DISPATCH (\, SEQUENCE) (LET ((HANDLE (CONS NIL (\, SEQUENCE)))) (FORWARD-LIST-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT (PREVIOUS (CL:NTHCDR (\, START) HANDLE))) (CDR HANDLE) (CL:IF (NOT (\, TEST-FORM)) (SETQ PREVIOUS (CDR PREVIOUS)) (RPLACD PREVIOUS (CDR %%SUBSEQ))))) (LET ((LENGTH (VECTOR-LENGTH (\, SEQUENCE))) (NUMBER-OF-MATCHES 0) (RESULT (%%DESTRUCTIVE-RESULT-VECTOR (\, SEQUENCE) (\, START)))) (FORWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT (SLOW-INDEX (\, START))) NIL (COND ((NOT (\, TEST-FORM)) (CL:SETF (CL:AREF RESULT SLOW-INDEX) CURRENT) (CL:INCF SLOW-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES)))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) (\, END) LENGTH RESULT (- (\, END) NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT))))
+
+(CL:DEFUN SIMPLE-DELETE (ITEM SEQUENCE START END) (SIMPLE-DELETE-MACRO SEQUENCE START END (EQL ITEM CURRENT)))
+
+(CL:DEFUN SIMPLE-DELETE-IF (TEST SEQUENCE START END) (SIMPLE-DELETE-MACRO SEQUENCE START END (CL:FUNCALL TEST CURRENT)))
+
+(CL:DEFUN SIMPLE-DELETE-IF-NOT (TEST SEQUENCE START END) (SIMPLE-DELETE-MACRO SEQUENCE START END (NOT (CL:FUNCALL TEST CURRENT))))
+
+(DEFMACRO COMPLEX-DELETE-MACRO (SEQUENCE START END FROM-END KEY COUNT TEST-FORM) (BQUOTE (LET ((NUMBER-OF-MATCHES 0)) (SEQ-DISPATCH (\, SEQUENCE) (LET ((HANDLE (CONS NIL (\, SEQUENCE)))) (CL:IF (NULL (AND (\, FROM-END) (\, COUNT))) (CL:DO ((PREVIOUS (CL:NTHCDR (\, START) HANDLE)) (%%SUBSEQ (CL:NTHCDR (\, START) (\, SEQUENCE)) (CDR %%SUBSEQ)) (INDEX (\, START) (CL:1+ INDEX)) CURRENT) ((OR (EQL INDEX (\, END)) (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT)))) (CDR HANDLE)) (SETQ CURRENT (CAR %%SUBSEQ)) (COND ((NOT (\, TEST-FORM)) (SETQ PREVIOUS (CDR PREVIOUS))) (T (RPLACD PREVIOUS (CDR %%SUBSEQ)) (CL:INCF NUMBER-OF-MATCHES)))) (CL:DO ((INDEX (CL:1- (\, END)) (CL:1- INDEX)) (LAST (CL:NTHCDR (\, END) (\, SEQUENCE))) PREVIOUS CURRENT) ((OR (< INDEX (\, START)) (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT)))) (CDR HANDLE)) (SETQ PREVIOUS (CL:NTHCDR INDEX HANDLE)) (SETQ CURRENT (CADR PREVIOUS)) (COND ((NOT (\, TEST-FORM)) (SETQ LAST (CDR PREVIOUS))) (T (RPLACD PREVIOUS LAST) (CL:INCF NUMBER-OF-MATCHES)))))) (LET ((LENGTH (VECTOR-LENGTH (\, SEQUENCE))) (RESULT (%%DESTRUCTIVE-RESULT-VECTOR (\, SEQUENCE) (\, START)))) (CL:IF (NULL (AND (\, FROM-END) (\, COUNT))) (FORWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT (SLOW-INDEX (\, START))) NIL (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) (CL:SETF (CL:AREF RESULT SLOW-INDEX) CURRENT) (CL:INCF SLOW-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES)))) (BACKWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT (SLOW-INDEX (CL:1- (\, END)))) (AND (> NUMBER-OF-MATCHES 0) (COPY-VECTOR-SUBSEQ RESULT (+ (\, START) NUMBER-OF-MATCHES) (\, END) RESULT (\, START) (- (\, END) NUMBER-OF-MATCHES))) (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) (CL:SETF (CL:AREF RESULT SLOW-INDEX) CURRENT) (CL:DECF SLOW-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES))))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) (\, END) LENGTH RESULT (- (\, END) NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT)))))
+
+(CL:DEFUN COMPLEX-DELETE (ITEM SEQUENCE START END FROM-END KEY COUNT TEST TEST-NOT-P) (COMPLEX-DELETE-MACRO SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P (NOT (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT))) (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT)))))
+
+(CL:DEFUN COMPLEX-DELETE-IF (TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-DELETE-MACRO SEQUENCE START END FROM-END KEY COUNT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT))))
+
+(CL:DEFUN COMPLEX-DELETE-IF-NOT (TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-DELETE-MACRO SEQUENCE START END FROM-END KEY COUNT (NOT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT)))))
+
+(CL:DEFUN CL:DELETE (ITEM SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P) (TEST (QUOTE EQL) TEST-P) (TEST-NOT NIL TEST-NOT-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P COUNT TEST-P TEST-NOT-P) (COMPLEX-DELETE ITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-DELETE ITEM SEQUENCE START END))))
+
+(CL:DEFUN CL:DELETE-IF (TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-DELETE-IF TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-DELETE-IF TEST SEQUENCE START END))))
+
+(CL:DEFUN CL:DELETE-IF-NOT (TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-DELETE-IF-NOT TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-DELETE-IF-NOT TEST SEQUENCE START END))))
+
+(CL:DEFUN SIMPLE-REMOVE-DUPLICATES (SEQUENCE START END) (SIMPLE-REMOVE-MACRO SEQUENCE START END (SIMPLE-POSITION CURRENT SEQUENCE (CL:1+ INDEX) END)))
+
+(CL:DEFUN COMPLEX-REMOVE-DUPLICATES (SEQUENCE START END FROM-END KEY TEST TEST-NOT-P) (SEQ-DISPATCH SEQUENCE (LET ((RESULT-HEAD (CL:SUBSEQ SEQUENCE 0 START)) (RESULT-TAIL (CL:NTHCDR END SEQUENCE)) (RESULT-MIDDLE (CL:IF (NULL FROM-END) (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT NEW-LIST TAIL) NEW-LIST (CL:IF (NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE (CL:1+ INDEX) END NIL KEY TEST TEST-NOT-P)) (COLLECT-ITEM CURRENT NEW-LIST TAIL))) (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT NEW-LIST TAIL) NEW-LIST (CL:IF (NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE START INDEX NIL KEY TEST TEST-NOT-P)) (COLLECT-ITEM CURRENT NEW-LIST TAIL)))))) (NCONC RESULT-HEAD RESULT-MIDDLE RESULT-TAIL)) (LET* ((LENGTH (VECTOR-LENGTH SEQUENCE)) (RESULT (CL:MAKE-ARRAY LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE SEQUENCE) :FILL-POINTER T)) (NUMBER-OF-MATCHES 0)) (COPY-VECTOR-SUBSEQ SEQUENCE 0 START RESULT 0) (CL:IF (NULL FROM-END) (FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (RESULT-INDEX START) TEST-RESULT) NIL (COND ((NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE (CL:1+ INDEX) END NIL KEY TEST TEST-NOT-P)) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:INCF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES)))) (FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (RESULT-INDEX START) TEST-RESULT) NIL (COND ((NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE START INDEX NIL KEY TEST TEST-NOT-P)) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:INCF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES))))) (COPY-VECTOR-SUBSEQ SEQUENCE END LENGTH RESULT (- END NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT)))
+
+(CL:DEFUN CL:REMOVE-DUPLICATES (SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) (KEY (QUOTE CL:IDENTITY) KEY-P) (TEST (QUOTE EQL) TEST-P) (TEST-NOT NIL TEST-NOT-P)) "The elements of Sequence are examined, and if any two match, one is discarded.  The resulting sequence is returned." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P TEST-P TEST-NOT-P) (COMPLEX-REMOVE-DUPLICATES SEQUENCE START END FROM-END KEY (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-REMOVE-DUPLICATES SEQUENCE START END))))
+
+(CL:DEFUN SIMPLE-DELETE-DUPLICATES (SEQUENCE START END) (SEQ-DISPATCH SEQUENCE (LET ((HANDLE (CONS NIL SEQUENCE))) (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT (PREVIOUS (CL:NTHCDR START HANDLE))) (CDR HANDLE) (CL:IF (NOT (SIMPLE-POSITION CURRENT (CDR %%SUBSEQ) 0 (- END INDEX 1))) (SETQ PREVIOUS (CDR PREVIOUS)) (RPLACD PREVIOUS (CDR %%SUBSEQ))))) (LET ((LENGTH (VECTOR-LENGTH SEQUENCE)) (NUMBER-OF-MATCHES 0) (RESULT (%%DESTRUCTIVE-RESULT-VECTOR SEQUENCE START))) (FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (SLOW-INDEX START)) NIL (COND ((NOT (SIMPLE-POSITION CURRENT SEQUENCE (CL:1+ INDEX) END)) (CL:SETF (CL:AREF RESULT SLOW-INDEX) CURRENT) (CL:INCF SLOW-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES)))) (COPY-VECTOR-SUBSEQ SEQUENCE END LENGTH RESULT (- END NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT)))
+
+(CL:DEFUN COMPLEX-DELETE-DUPLICATES (SEQUENCE START END FROM-END KEY TEST TEST-NOT-P) (SEQ-DISPATCH SEQUENCE (LET ((HANDLE (CONS NIL SEQUENCE))) (CL:IF (NULL FROM-END) (CL:DO ((PREVIOUS (CL:NTHCDR START HANDLE)) (%%SUBSEQ (CL:NTHCDR START SEQUENCE) (CDR %%SUBSEQ)) (INDEX START (CL:1+ INDEX))) ((EQL INDEX END) (CDR HANDLE)) (CL:IF (NOT (COMPLEX-POSITION (CL:FUNCALL KEY (CAR %%SUBSEQ)) (CDR %%SUBSEQ) 0 (- END INDEX 1) NIL KEY TEST TEST-NOT-P)) (SETQ PREVIOUS (CDR PREVIOUS)) (RPLACD PREVIOUS (CDR %%SUBSEQ)))) (CL:DO ((NUMBER-OF-MATCHES 0) (PREVIOUS (CL:NTHCDR START HANDLE)) (%%SUBSEQ (CL:NTHCDR START SEQUENCE) (CDR %%SUBSEQ)) (INDEX START (CL:1+ INDEX))) ((EQL INDEX END) (CDR HANDLE)) (COND ((NOT (COMPLEX-POSITION (CL:FUNCALL KEY (CAR %%SUBSEQ)) SEQUENCE START (- INDEX NUMBER-OF-MATCHES) NIL KEY TEST TEST-NOT-P)) (SETQ PREVIOUS (CDR PREVIOUS))) (T (RPLACD PREVIOUS (CDR %%SUBSEQ)) (CL:INCF NUMBER-OF-MATCHES)))))) (LET ((LENGTH (VECTOR-LENGTH SEQUENCE)) (NUMBER-OF-MATCHES 0) (RESULT (%%DESTRUCTIVE-RESULT-VECTOR SEQUENCE START))) (CL:IF (NULL FROM-END) (FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (RESULT-INDEX START) TEST-RESULT) NIL (COND ((NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE (CL:1+ INDEX) END NIL KEY TEST TEST-NOT-P)) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:INCF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES)))) (FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (RESULT-INDEX START) TEST-RESULT) NIL (COND ((NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE START INDEX NIL KEY TEST TEST-NOT-P)) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:INCF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES))))) (COPY-VECTOR-SUBSEQ SEQUENCE END LENGTH RESULT (- END NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT)))
+
+(CL:DEFUN CL:DELETE-DUPLICATES (SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) (KEY (QUOTE CL:IDENTITY) KEY-P) (TEST (QUOTE EQL) TEST-P) (TEST-NOT NIL TEST-NOT-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P TEST-P TEST-NOT-P) (COMPLEX-DELETE-DUPLICATES SEQUENCE START END FROM-END KEY (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-DELETE-DUPLICATES SEQUENCE START END))))
+
+(DEFMACRO SIMPLE-SUBSTITUTE-MACRO (NEWITEM SEQUENCE START END TEST-FORM) (BQUOTE (SEQ-DISPATCH (\, SEQUENCE) (LET ((RESULT-HEAD (CL:SUBSEQ (\, SEQUENCE) 0 (\, START))) (RESULT-TAIL (CL:NTHCDR (\, END) (\, SEQUENCE))) (RESULT-MIDDLE (FORWARD-LIST-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT NEW-LIST TAIL NEW-ELEMENT) NEW-LIST (SETQ NEW-ELEMENT (CL:IF (\, TEST-FORM) (\, NEWITEM) CURRENT)) (COLLECT-ITEM NEW-ELEMENT NEW-LIST TAIL)))) (NCONC RESULT-HEAD RESULT-MIDDLE RESULT-TAIL)) (LET* ((LENGTH (VECTOR-LENGTH (\, SEQUENCE))) (RESULT (MAKE-VECTOR LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE (\, SEQUENCE))))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) 0 (\, START) RESULT 0) (FORWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT) NIL (CL:SETF (CL:AREF RESULT INDEX) (CL:IF (\, TEST-FORM) (\, NEWITEM) CURRENT))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) (\, END) LENGTH RESULT (\, END)) RESULT))))
+
+(CL:DEFUN SIMPLE-SUBSTITUTE (NEWITEM OLDITEM SEQUENCE START END) (SIMPLE-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END (EQL OLDITEM CURRENT)))
+
+(CL:DEFUN SIMPLE-SUBSTITUTE-IF (NEWITEM TEST SEQUENCE START END) (SIMPLE-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END (CL:FUNCALL TEST CURRENT)))
+
+(CL:DEFUN SIMPLE-SUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE START END) (SIMPLE-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END (NOT (CL:FUNCALL TEST CURRENT))))
+
+(DEFMACRO COMPLEX-SUBSTITUTE-MACRO (NEWITEM SEQUENCE START END FROM-END KEY COUNT TEST-FORM) (BQUOTE (LET ((NUMBER-OF-MATCHES 0)) (SEQ-DISPATCH (\, SEQUENCE) (LET ((RESULT-HEAD (CL:SUBSEQ (\, SEQUENCE) 0 (\, START))) (RESULT-TAIL (CL:NTHCDR (\, END) (\, SEQUENCE))) (RESULT-MIDDLE (CL:IF (NULL (AND (\, FROM-END) (\, COUNT))) (FORWARD-LIST-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT NEW-LIST TAIL NEW-ELEMENT) NEW-LIST (SETQ NEW-ELEMENT (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) CURRENT) (T (CL:INCF NUMBER-OF-MATCHES) (\, NEWITEM)))) (COLLECT-ITEM NEW-ELEMENT NEW-LIST TAIL)) (BACKWARD-LIST-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT NEW-LIST NEW-ELEMENT) NEW-LIST (SETQ NEW-ELEMENT (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) CURRENT) (T (CL:INCF NUMBER-OF-MATCHES) (\, NEWITEM)))) (CL:PUSH NEW-ELEMENT NEW-LIST))))) (NCONC RESULT-HEAD RESULT-MIDDLE RESULT-TAIL)) (LET* ((LENGTH (VECTOR-LENGTH (\, SEQUENCE))) (RESULT (MAKE-VECTOR LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE (\, SEQUENCE))))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) 0 (\, START) RESULT 0) (CL:IF (NULL (\, FROM-END)) (FORWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT) NIL (CL:SETF (CL:AREF RESULT INDEX) (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) CURRENT) (T (CL:INCF NUMBER-OF-MATCHES) (\, NEWITEM))))) (BACKWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT) NIL (CL:SETF (CL:AREF RESULT INDEX) (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) CURRENT) (T (CL:INCF NUMBER-OF-MATCHES) (\, NEWITEM)))))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) (\, END) LENGTH RESULT (\, END)) RESULT)))))
+
+(CL:DEFUN COMPLEX-SUBSTITUTE (NEWITEM OLDITEM SEQUENCE START END FROM-END KEY COUNT TEST TEST-NOT-P) (COMPLEX-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P (NOT (CL:FUNCALL TEST OLDITEM (CL:FUNCALL KEY CURRENT))) (CL:FUNCALL TEST OLDITEM (CL:FUNCALL KEY CURRENT)))))
+
+(CL:DEFUN COMPLEX-SUBSTITUTE-IF (NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT))))
+
+(CL:DEFUN COMPLEX-SUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (NOT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT)))))
+
+(CL:DEFUN CL:SUBSTITUTE (NEWITEM OLDITEM SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P) (TEST (QUOTE EQL) TEST-P) (TEST-NOT NIL TEST-NOT-P)) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P COUNT TEST-P TEST-NOT-P) (COMPLEX-SUBSTITUTE NEWITEM OLDITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-SUBSTITUTE NEWITEM OLDITEM SEQUENCE START END))))
+
+(CL:DEFUN CL:SUBSTITUTE-IF (NEWITEM TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P)) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-SUBSTITUTE-IF NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-SUBSTITUTE-IF NEWITEM TEST SEQUENCE START END))))
+
+(CL:DEFUN CL:SUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P)) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-SUBSTITUTE-IF-NOT NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-SUBSTITUTE-IF-NOT NEWITEM TEST SEQUENCE START END))))
+
+(DEFMACRO SIMPLE-NSUBSTITUTE-MACRO (NEWITEM SEQUENCE START END TEST-FORM) (BQUOTE (SEQ-DISPATCH (\, SEQUENCE) (FORWARD-LIST-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT NEW-LIST TAIL NEW-ELEMENT) (\, SEQUENCE) (CL:IF (\, TEST-FORM) (RPLACA %%SUBSEQ (\, NEWITEM)))) (FORWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT) (\, SEQUENCE) (CL:IF (\, TEST-FORM) (CL:SETF (CL:AREF (\, SEQUENCE) INDEX) (\, NEWITEM)))))))
+
+(CL:DEFUN SIMPLE-NSUBSTITUTE (NEWITEM OLDITEM SEQUENCE START END) (SIMPLE-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END (EQL OLDITEM CURRENT)))
+
+(CL:DEFUN SIMPLE-NSUBSTITUTE-IF (NEWITEM TEST SEQUENCE START END) (SIMPLE-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END (CL:FUNCALL TEST CURRENT)))
+
+(CL:DEFUN SIMPLE-NSUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE START END) (SIMPLE-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END (NOT (CL:FUNCALL TEST CURRENT))))
+
+(DEFMACRO COMPLEX-NSUBSTITUTE-MACRO (NEWITEM SEQUENCE START END FROM-END KEY COUNT TEST-FORM) (BQUOTE (LET ((NUMBER-OF-MATCHES 0)) (SEQ-DISPATCH (\, SEQUENCE) (CL:IF (NULL (AND (\, FROM-END) (\, COUNT))) (CL:DO ((%%SUBSEQ (CL:NTHCDR (\, START) (\, SEQUENCE)) (CDR %%SUBSEQ)) (INDEX (\, START) (CL:1+ INDEX)) CURRENT) ((OR (EQL INDEX (\, END)) (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT)))) (\, SEQUENCE)) (SETQ CURRENT (CAR %%SUBSEQ)) (CL:IF (AND (\, TEST-FORM) (CL:INCF NUMBER-OF-MATCHES)) (RPLACA %%SUBSEQ (\, NEWITEM)))) (CL:DO ((INDEX (CL:1- (\, END)) (CL:1- INDEX)) %%SUBSEQ CURRENT) ((OR (< INDEX (\, START)) (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT)))) (\, SEQUENCE)) (SETQ %%SUBSEQ (CL:NTHCDR INDEX (\, SEQUENCE))) (SETQ CURRENT (CAR %%SUBSEQ)) (CL:IF (AND (\, TEST-FORM) (CL:INCF NUMBER-OF-MATCHES)) (RPLACA %%SUBSEQ (\, NEWITEM))))) (LET ((LENGTH (VECTOR-LENGTH (\, SEQUENCE)))) (CL:IF (NULL (\, FROM-END)) (CL:DO ((INDEX (\, START) (CL:1+ INDEX)) CURRENT) ((OR (EQL INDEX (\, END)) (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT)))) (\, SEQUENCE)) (SETQ CURRENT (CL:AREF (\, SEQUENCE) INDEX)) (CL:IF (AND (\, TEST-FORM) (CL:INCF NUMBER-OF-MATCHES)) (CL:SETF (CL:AREF (\, SEQUENCE) INDEX) (\, NEWITEM)))) (CL:DO ((INDEX (CL:1- (\, END)) (CL:1- INDEX)) CURRENT) ((OR (< INDEX (\, START)) (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT)))) (\, SEQUENCE)) (SETQ CURRENT (CL:AREF (\, SEQUENCE) INDEX)) (CL:IF (AND (\, TEST-FORM) (CL:INCF NUMBER-OF-MATCHES)) (CL:SETF (CL:AREF (\, SEQUENCE) INDEX) (\, NEWITEM))))))))))
+
+(CL:DEFUN COMPLEX-NSUBSTITUTE (NEWITEM OLDITEM SEQUENCE START END FROM-END KEY COUNT TEST TEST-NOT-P) (COMPLEX-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P (NOT (CL:FUNCALL TEST OLDITEM (CL:FUNCALL KEY CURRENT))) (CL:FUNCALL TEST OLDITEM (CL:FUNCALL KEY CURRENT)))))
+
+(CL:DEFUN COMPLEX-NSUBSTITUTE-IF (NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT))))
+
+(CL:DEFUN COMPLEX-NSUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (NOT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT)))))
+
+(CL:DEFUN CL:NSUBSTITUTE (NEWITEM OLDITEM SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P) (TEST (QUOTE EQL) TEST-P) (TEST-NOT NIL TEST-NOT-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P COUNT TEST-P TEST-NOT-P) (COMPLEX-NSUBSTITUTE NEWITEM OLDITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-NSUBSTITUTE NEWITEM OLDITEM SEQUENCE START END))))
+
+(CL:DEFUN CL:NSUBSTITUTE-IF (NEWITEM TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P)) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-NSUBSTITUTE-IF NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-NSUBSTITUTE-IF NEWITEM TEST SEQUENCE START END))))
+
+(CL:DEFUN CL:NSUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P)) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-NSUBSTITUTE-IF-NOT NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-NSUBSTITUTE-IF-NOT NEWITEM TEST SEQUENCE START END))))
+
+(CL:DEFUN CL:MAP-INTO (CL::RESULT-SEQUENCE CL:FUNCTION &REST CL::SEQUENCES) (* ;; "This is going to need work analogous to MAP; tomorrow...") (CL:IF (CDR CL::SEQUENCES) (CL::MAP-INTO-MULTIPLE CL::RESULT-SEQUENCE CL:FUNCTION CL::SEQUENCES) (CL::MAP-INTO-SINGLE CL::RESULT-SEQUENCE CL:FUNCTION (CAR CL::SEQUENCES))))
+
+(CL:DEFUN CL::MAP-INTO-SINGLE (CL::RESULT-SEQUENCE CL:FUNCTION SEQUENCE) (* ;; "Code borrowed from %%MAP-FOR-RESULT-SINGLE; needed changes to handle possible fill-pointer adjustment of RESULT-SEQUENCE") (LET (LENGTH) (SEQ-DISPATCH CL::RESULT-SEQUENCE (PROGN (CL:SETQ LENGTH (MIN (CL:LENGTH CL::RESULT-SEQUENCE) (CL:LENGTH SEQUENCE))) (SEQ-DISPATCH SEQUENCE (CL:DO ((SUBSEQ SEQUENCE (CDR SUBSEQ)) (SUBRESULT CL::RESULT-SEQUENCE (CDR SUBRESULT))) ((OR (NULL SUBSEQ) (NULL SUBRESULT))) (RPLACA SUBRESULT (CL:FUNCALL CL:FUNCTION (CAR SUBSEQ)))) (CL:DO ((INDEX 0 (CL:1+ INDEX)) (SUBRESULT CL::RESULT-SEQUENCE (CDR SUBRESULT))) ((EQL INDEX LENGTH)) (RPLACA SUBRESULT (CL:FUNCALL CL:FUNCTION (CL:AREF SEQUENCE INDEX)))))) (PROGN (* ;; "The actual length we want to do is (min (length sequence) (array-total-size result-sequence)), because RESULT-SEQUENCE might have a fill-pointer; if it does, we'll adjust it here.") (CL:SETQ LENGTH (MIN (CL:ARRAY-TOTAL-SIZE CL::RESULT-SEQUENCE) (CL:LENGTH SEQUENCE))) (CL:WHEN (CL:ARRAY-HAS-FILL-POINTER-P CL::RESULT-SEQUENCE) (CL:SETF (CL:FILL-POINTER CL::RESULT-SEQUENCE) LENGTH)) (SEQ-DISPATCH SEQUENCE (CL:DO ((SUBSEQ SEQUENCE (CDR SUBSEQ)) (INDEX 0 (CL:1+ INDEX))) ((OR (NULL SUBSEQ) (EQL INDEX LENGTH))) (CL:SETF (CL:AREF CL::RESULT-SEQUENCE INDEX) (CL:FUNCALL CL:FUNCTION (CAR SUBSEQ)))) (CL:DO ((INDEX 0 (CL:1+ INDEX))) ((EQL INDEX LENGTH)) (CL:SETF (CL:AREF CL::RESULT-SEQUENCE INDEX) (CL:FUNCALL CL:FUNCTION (CL:AREF SEQUENCE INDEX))))))) CL::RESULT-SEQUENCE))
+
+(CL:DEFUN CL::MAP-INTO-MULTIPLE (CL::RESULT-SEQUENCE CL:FUNCTION CL::SEQUENCES) (* ;; "Code taken from %%MAP-FOR-RESULT-MULTIPLE and munged to handle case of fill-pointer in RESULT-SEQUENCE") (LET* ((MIN-LENGTH (%%MIN-SEQUENCE-LENGTH CL::SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH CL::SEQUENCES)))) (SEQ-DISPATCH CL::RESULT-SEQUENCE (PROGN (CL:SETQ MIN-LENGTH (MIN MIN-LENGTH (CL:LENGTH CL::RESULT-SEQUENCE))) (CL:DO ((SUBRESULT CL::RESULT-SEQUENCE (CDR SUBRESULT)) (INDEX 0 (CL:1+ INDEX))) ((EQL INDEX MIN-LENGTH) CL::RESULT-SEQUENCE) (RPLACA SUBRESULT (CL:APPLY CL:FUNCTION (%%FILL-SLICE INDEX ELT-SLICE CL::SEQUENCES))))) (PROGN (CL:SETQ MIN-LENGTH (MIN MIN-LENGTH (CL:ARRAY-TOTAL-SIZE CL::RESULT-SEQUENCE))) (CL:IF (CL:ARRAY-HAS-FILL-POINTER-P CL::RESULT-SEQUENCE) (CL:SETF (CL:FILL-POINTER CL::RESULT-SEQUENCE) MIN-LENGTH)) (CL:DO ((INDEX 0 (CL:1+ INDEX))) ((EQL INDEX MIN-LENGTH) CL::RESULT-SEQUENCE) (CL:SETF (CL:AREF CL::RESULT-SEQUENCE INDEX) (CL:APPLY CL:FUNCTION (%%FILL-SLICE INDEX ELT-SLICE CL::SEQUENCES))))))))
+
+(PUTPROPS CMLSEQMODIFY FILETYPE CL:COMPILE-FILE)
+(DECLARE%: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(PUTPROPS CMLSEQMODIFY COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/CLTL2/CMLSEQMODIFY.LCOM b/CLTL2/CMLSEQMODIFY.LCOM
new file mode 100644
index 00000000..aaddb384
Binary files /dev/null and b/CLTL2/CMLSEQMODIFY.LCOM differ
diff --git a/CLTL2/CMLSETF b/CLTL2/CMLSETF
new file mode 100644
index 00000000..5287877b
--- /dev/null
+++ b/CLTL2/CMLSETF
@@ -0,0 +1,227 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
+(IL:FILECREATED "14-Feb-92 13:26:45" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSETF.;4| 35330  
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:CMLSETFCOMS) (IL:FUNCTIONS ROTATEF CL::ROTATEF-INTERNAL CL::MV-LET* SETF GET-SETF-METHOD-MULTIPLE-VALUE PSETF SHIFTF CL::SHIFTF-INTERNAL)
+
+      IL:|previous| IL:|date:| " 4-Jan-92 15:22:54" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSETF.;2|
+)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CMLSETFCOMS)
+
+(IL:RPAQQ IL:CMLSETFCOMS ((IL:FUNCTIONS GET-SETF-METHOD GET-SIMPLE-SETF-METHOD GET-SETF-METHOD-MULTIPLE-VALUE CL::DEFUN-SETF-METHOD) (IL:DEFINE-TYPES IL:SETFS) (IL:FUNCTIONS DEFSETF DEFINE-MODIFY-MACRO DEFINE-SETF-METHOD) (IL:COMS (IL:* IL:|;;| "Support for defstruct and friends ") (IL:FUNCTIONS DEFINE-SHARED-SETF-MACRO DEFINE-SHARED-SETF GET-SHARED-SETF-METHOD)) (IL:FUNCTIONS SETF SETF-ERROR) (IL:FUNCTIONS PSETF SHIFTF ROTATEF POP REMF) (IL:* IL:|;;| "A little suppost stuff to make writing the undoable versions easier") (IL:FUNCTIONS CL::SHIFTF-INTERNAL CL::ROTATEF-INTERNAL) (IL:* IL:|;;| "A little support macro to make ROTATEF prettier") (IL:FUNCTIONS CL::MV-LET*) (IL:FUNCTIONS INCF DECF) (IL:FUNCTIONS MAYBE-MAKE-BINDING-FORM COUNT-OCCURRENCES CL::SETF-NAME-P XCL::DEFUN-SETF-NAME XCL::SET-DEFUN-SETF) (IL:FUNCTIONS PUSH PUSHNEW) (IL:SETFS CAR CDR CAAAAR CAAADR CAAAR CAADAR CAADDR CAADR CAAR CADAAR CADADR CADAR CADDAR CADDDR CADDR CADR CDAAAR CDAADR CDAAR CDADAR CDADDR CDADR CDAR CDDAAR CDDADR CDDAR CDDDAR CDDDDR CDDDR CDDR FIRST SECOND THIRD FOURTH FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH REST NTHCDR NTH GETF APPLY LDB MASK-FIELD CHAR-BIT THE CL:FDEFINITION) (IL:COMS (IL:* IL:\; "Some IL setfs, for no especially good reason") (IL:SETFS IL:GETHASH) (IL:FUNCTIONS IL:%SET-IL-GETHASH)) (IL:PROP IL:PROPTYPE :SETF-METHOD-EXPANDER :SETF-INVERSE :SHARED-SETF-INVERSE) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLSETF) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA)))))
+
+(DEFUN GET-SETF-METHOD (FORM &OPTIONAL ENVIRONMENT) (LET (TEMP) (COND ((SYMBOLP FORM) (IL:* IL:|;;| "Symbols have a simple, constant SETF method.") (VALUES NIL NIL (LIST (SETQ TEMP (IL:GENSYM))) (IL:BQUOTE (SETQ (IL:\\\, FORM) (IL:\\\, TEMP))) FORM)) ((NOT (CONSP FORM)) (IL:* IL:\; "Syntax error") (SETF-ERROR FORM)) ((SETQ TEMP (IL:LOCAL-MACRO-FUNCTION (CAR FORM) ENVIRONMENT)) (IL:* IL:|;;| "Lexical macros cannot have SETF methods defined upon them, so just expand this and try again.") (GET-SETF-METHOD (FUNCALL TEMP FORM ENVIRONMENT) ENVIRONMENT)) ((SETQ TEMP (OR (GET (CAR FORM) (QUOTE :SETF-INVERSE)) (GET (CAR FORM) (QUOTE IL:SETF-INVERSE)) (GET (CAR FORM) (QUOTE IL:SETFN)))) (GET-SIMPLE-SETF-METHOD FORM TEMP)) ((SETQ TEMP (GET (CAR FORM) (QUOTE :SHARED-SETF-INVERSE))) (GET-SHARED-SETF-METHOD FORM TEMP)) ((SETQ TEMP (OR (GET (CAR FORM) (QUOTE :SETF-METHOD-EXPANDER)) (GET (CAR FORM) (QUOTE IL:SETF-METHOD-EXPANDER)))) (IL:* IL:|;;| "Do check number of the Store Variables") (MULTIPLE-VALUE-BIND (TEMPS VALUES STORES SETTER GETTER) (FUNCALL TEMP FORM ENVIRONMENT) (WHEN (/= (LENGTH STORES) 1) (WARN "SETF method contains more than one store variable. Only top of the elements was accepted.") (SETQ STORES (LIST (CAR STORES)))) (VALUES TEMPS VALUES STORES SETTER GETTER))) (T (MULTIPLE-VALUE-BIND (EXPANSION DONE) (MACROEXPAND-1 FORM ENVIRONMENT) (IF (AND DONE (NOT (EQ EXPANSION FORM))) (GET-SETF-METHOD EXPANSION ENVIRONMENT) (CL::DEFUN-SETF-METHOD FORM ENVIRONMENT)))))))
+
+(DEFUN GET-SIMPLE-SETF-METHOD (FORM SETF-INVERSE) (IL:* IL:|;;| "Produce SETF method for a form that has a setf-inverse.  Five values to return are: temp vars, values to bind them to, store temp var, store form, access form; the latter two are expressions that can use any of them temp vars.") (LET ((NEW-VAR (IL:GENSYM)) VARS VALS ARGS SETF-INVERSE-FORM GET-FORM) (SETQ ARGS (MAPCAR (FUNCTION (LAMBDA (ARG) (COND ((IF (CONSP ARG) (EQ (CAR ARG) (QUOTE QUOTE)) (CONSTANTP ARG)) (IL:* IL:|;;| "We don't need gensym for this constant argument.  The test is a little more conservative than CL:CONSTANTP because it's not obvious that it's ok to evaluate a \"constant expression\" multiple times and get the same EQ object every time.") ARG) (T (IL:* IL:|;;| "Anything else might be side-effected, so will need to bind") (PUSH ARG VALS) (LET ((G (IL:GENSYM))) (PUSH G VARS) G))))) (CDR FORM))) (SETQ SETF-INVERSE-FORM (MACROEXPAND-1 (IL:BQUOTE ((IL:\\\, SETF-INVERSE) (IL:\\\,@ ARGS) (IL:\\\, NEW-VAR))))) (SETQ GET-FORM (MACROEXPAND-1 (IL:BQUOTE ((IL:\\\, (CAR FORM)) (IL:\\\,@ ARGS))))) (IL:* IL:|;;| "ARGS is now the arguments to FORM with gensyms substituted for the non-constant expressions") (VALUES (SETQ VARS (NREVERSE VARS)) (SETQ VALS (NREVERSE VALS)) (LIST NEW-VAR) SETF-INVERSE-FORM GET-FORM)))
+
+(DEFUN GET-SETF-METHOD-MULTIPLE-VALUE (FORM &OPTIONAL ENVIRONMENT) (IL:* IL:\; "Edited  6-Feb-92 15:31 by jrb:") (LET (TEMP) (COND ((SYMBOLP FORM) (IL:* IL:|;;| "Symbols have a simple, constant SETF method.") (VALUES NIL NIL (LIST (SETQ TEMP (IL:GENSYM))) (IL:BQUOTE (SETQ (IL:\\\, FORM) (IL:\\\, TEMP))) FORM)) ((NOT (CONSP FORM)) (IL:* IL:\; "Syntax error") (SETF-ERROR FORM)) ((SETQ TEMP (IL:LOCAL-MACRO-FUNCTION (CAR FORM) ENVIRONMENT)) (IL:* IL:|;;| "Lexical macros cannot have SETF methods defined upon them, so just expand this and try again.") (GET-SETF-METHOD (FUNCALL TEMP FORM ENVIRONMENT) ENVIRONMENT)) ((SETQ TEMP (OR (GET (CAR FORM) (QUOTE :SETF-INVERSE)) (GET (CAR FORM) (QUOTE IL:SETF-INVERSE)) (GET (CAR FORM) (QUOTE IL:SETFN)))) (GET-SIMPLE-SETF-METHOD FORM TEMP)) ((SETQ TEMP (GET (CAR FORM) (QUOTE :SHARED-SETF-INVERSE))) (GET-SHARED-SETF-METHOD FORM TEMP)) ((SETQ TEMP (OR (GET (CAR FORM) (QUOTE :SETF-METHOD-EXPANDER)) (GET (CAR FORM) (QUOTE IL:SETF-METHOD-EXPANDER)))) (IL:* IL:|;;| "Does not check the number of Store Variables.") (FUNCALL TEMP FORM ENVIRONMENT)) (T (MULTIPLE-VALUE-BIND (EXPANSION DONE) (MACROEXPAND-1 FORM ENVIRONMENT) (IF (AND DONE (NOT (EQ EXPANSION FORM))) (GET-SETF-METHOD EXPANSION ENVIRONMENT) (CL::DEFUN-SETF-METHOD FORM ENVIRONMENT)))))))
+
+(DEFUN CL::DEFUN-SETF-METHOD (CL::FORM CL::ENVIRONMENT) (IL:* IL:|;;| "This doesn't need to do anything special with the ENVIRONMENT; all special search necessary is done by #'(SETF ,(CAR FORM))") (LET* ((CL::NEWVAL (GENSYM)) (CL::LET-LIST (MAPCAR (FUNCTION (LAMBDA (CL::X) (LIST (GENSYM) CL::X))) (CDR CL::FORM))) (CL::TEMPS (MAPCAR (FUNCTION CAR) CL::LET-LIST))) (VALUES CL::TEMPS (CDR CL::FORM) (LIST CL::NEWVAL) (IL:BQUOTE (FUNCALL (FUNCTION (SETF (IL:\\\, (CAR CL::FORM)))) (IL:\\\, CL::NEWVAL) (IL:\\\,@ CL::TEMPS))) (CONS (CAR CL::FORM) CL::TEMPS))))
+
+(XCL:DEF-DEFINE-TYPE IL:SETFS "Common Lisp SETF definitions")
+
+(XCL:DEFDEFINER (DEFSETF (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFSETF (IL:\\\, NAME) "Inverse function")))))) IL:SETFS (NAME &REST REST &ENVIRONMENT ENV) (IL:* IL:|;;;| "Associates a SETF update function or macro with the specified access function or macro") (COND ((NULL REST) (ERROR "No body for DEFSETF of ~A" NAME)) ((AND (LISTP (CAR REST)) (CDR REST) (LISTP (CADR REST))) (IL:* IL:|;;| "The complex form:") (IL:* IL:|;;| "(defsetf access-fn args (store-var) {decl | doc}* {form}*)") (XCL:DESTRUCTURING-BIND (ARG-LIST (STORE-VAR &REST OTHERS) &BODY BODY) REST (IF OTHERS (CERROR "Ignore the extra items in the list." "Currently only one new-value variable is allowed in DEFSETF.")) (LET ((WHOLE-VAR (XCL:PACK (LIST NAME "-setf-form") (SYMBOL-PACKAGE NAME))) (ENVIRONMENT (XCL:PACK (LIST NAME "-setf-env") (SYMBOL-PACKAGE NAME))) (EXPANDER (XCL:PACK (LIST NAME "-setf-expander") (SYMBOL-PACKAGE NAME)))) (MULTIPLE-VALUE-BIND (CODE DECLS DOC) (IL:PARSE-DEFMACRO ARG-LIST WHOLE-VAR BODY NAME ENV :ENVIRONMENT ENVIRONMENT) (IL:BQUOTE (PROGN (EVAL-WHEN (EVAL COMPILE LOAD) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, EXPANDER))) (FUNCTION (LAMBDA (ACCESS-FORM (IL:\\\, ENVIRONMENT)) (LET* ((DUMMIES (MAPCAR (FUNCTION (LAMBDA (X) (IL:GENSYM))) (CDR ACCESS-FORM))) ((IL:\\\, WHOLE-VAR) (CONS (CAR ACCESS-FORM) DUMMIES)) ((IL:\\\, STORE-VAR) (IL:GENSYM))) (VALUES DUMMIES (CDR ACCESS-FORM) (LIST (IL:\\\, STORE-VAR)) (BLOCK (IL:\\\, NAME) (IL:\\\, CODE)) (IL:\\\, WHOLE-VAR)))))) (SET-SETF-METHOD-EXPANDER (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, EXPANDER)))) (IL:\\\,@ (AND DOC (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE SETF)) (IL:\\\, DOC)))))))))))) ((SYMBOLP (CAR REST)) (IL:* IL:|;;| "The short form:") (IL:* IL:|;;| "(defsetf access-fn update-fn [doc])") (LET ((UPDATE-FN (CAR REST)) (DOC (CADR REST))) (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD COMPILE EVAL) (SET-SETF-INVERSE (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, UPDATE-FN)))) (IL:\\\,@ (AND DOC (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE SETF)) (IL:\\\, DOC)))))))))) (T (ERROR "Ill-formed DEFSETF for ~S." NAME))))
+
+(XCL:DEFDEFINER (DEFINE-MODIFY-MACRO (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFINE-MODIFY-MACRO (IL:\\\, NAME) (IL:\\\,@ (XCL::%MAKE-FUNCTION-PROTOTYPE)))))))) IL:FUNCTIONS (NAME LAMBDA-LIST FUNCTION &OPTIONAL DOC-STRING) "Creates a new read-modify-write macro like PUSH or INCF." (LET ((OTHER-ARGS NIL) (REST-ARG NIL)) (DO ((LL LAMBDA-LIST (CDR LL)) (ARG NIL)) ((NULL LL)) (SETQ ARG (CAR LL)) (COND ((EQ ARG (QUOTE &OPTIONAL))) ((EQ ARG (QUOTE &REST)) (SETQ REST-ARG (CADR LL)) (RETURN NIL)) ((SYMBOLP ARG) (PUSH ARG OTHER-ARGS)) (T (PUSH (CAR ARG) OTHER-ARGS)))) (SETQ OTHER-ARGS (NREVERSE OTHER-ARGS)) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) (SI::%$$MODIFY-MACRO-FORM (IL:\\\,@ LAMBDA-LIST) &ENVIRONMENT SI::%$$MODIFY-MACRO-ENVIRONMENT) (IL:\\\, DOC-STRING) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVALS SETTER GETTER) (GET-SETF-METHOD SI::%$$MODIFY-MACRO-FORM SI::%$$MODIFY-MACRO-ENVIRONMENT) (IL:BQUOTE ((IL:\\\, (QUOTE LET*)) ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS)) ((IL:\\\, (CAR NEWVALS)) (IL:\\\, (IL:\\\, (IF REST-ARG (IL:BQUOTE (LIST* (QUOTE (IL:\\\, FUNCTION)) GETTER (IL:\\\,@ OTHER-ARGS) (IL:\\\, REST-ARG))) (IL:BQUOTE (LIST (QUOTE (IL:\\\, FUNCTION)) GETTER (IL:\\\,@ OTHER-ARGS)))))))) (IL:\\\, SETTER))))))))
+
+(XCL:DEFDEFINER (DEFINE-SETF-METHOD (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFINE-SETF-METHOD (IL:\\\, NAME) ("Arg list") "Body")))))) IL:SETFS (NAME LAMBDA-LIST &ENVIRONMENT ENV &BODY BODY) (LET ((WHOLE (XCL:PACK (LIST "whole-" NAME) (SYMBOL-PACKAGE NAME))) (ENVIRONMENT (XCL:PACK (LIST "env-" NAME) (SYMBOL-PACKAGE NAME))) (EXPANDER (XCL:PACK (LIST "setf-expander-" NAME) (SYMBOL-PACKAGE NAME)))) (MULTIPLE-VALUE-BIND (NEWBODY LOCAL-DECS DOC) (IL:PARSE-DEFMACRO LAMBDA-LIST WHOLE BODY NAME ENV :ENVIRONMENT ENVIRONMENT :ERROR-STRING "Setf expander for ~S cannot be called with ~S args.") (IL:BQUOTE (EVAL-WHEN (EVAL COMPILE LOAD) (DEFUN (IL:\\\, EXPANDER) ((IL:\\\, WHOLE) (IL:\\\, ENVIRONMENT)) (IL:\\\,@ LOCAL-DECS) (BLOCK (IL:\\\, NAME) (IL:\\\, NEWBODY))) (SET-SETF-METHOD-EXPANDER (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, EXPANDER))) (IL:\\\,@ (AND DOC (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE SETF)) (IL:\\\, DOC)))))))))))
+
+
+
+(IL:* IL:|;;| "Support for defstruct and friends ")
+
+
+(XCL:DEFDEFINER DEFINE-SHARED-SETF-MACRO IL:FUNCTIONS (NAME ACCESSOR ARG-LIST STORE-VAR &BODY BODY &ENVIRONMENT ENV) (IL:* IL:|;;;| "Defines a shared SETF update function for a family of accessores -- used by defstruct") (IF (NOT (AND (CONSP STORE-VAR) (EQ 1 (LENGTH STORE-VAR)))) (ERROR "Store-var should be a list of one element: ~s" STORE-VAR)) (MULTIPLE-VALUE-BIND (CODE DECLS DOC) (XCL:PARSE-BODY BODY ENV T) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) ((IL:\\\, ACCESSOR) (IL:\\\,@ ARG-LIST) (IL:\\\,@ STORE-VAR)) (IL:\\\,@ DOC) (IL:\\\,@ DECLS) (IL:\\\,@ CODE)))))
+
+(XCL:DEFDEFINER DEFINE-SHARED-SETF IL:SETFS (NAME SHARED-EXPANDER &OPTIONAL DOC) (IL:* IL:|;;;| "Associates a shared SETF update macro with the specified accessor function -- used by defstruct") (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD COMPILE EVAL) (SET-SHARED-SETF-INVERSE (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, SHARED-EXPANDER)))) (IL:\\\,@ (AND DOC (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE SETF)) (IL:\\\, DOC)))))))))
+
+(DEFUN GET-SHARED-SETF-METHOD (FORM SHARED-SETF-INVERSE) (IL:* IL:|;;| "Produce SETF method for a form that has a shared-setf-inverse.  Five values to return are: temp vars, values to bind them to, store temp var, store form, access form; the latter two are expressions that can use any of them temp vars.") (LET ((NEW-VAR (IL:GENSYM)) VARS VALS ARGS SHARED-SETF-INVERSE-FORM GET-FORM) (SETQ ARGS (MAPCAR (FUNCTION (LAMBDA (ARG) (COND ((IF (CONSP ARG) (EQ (CAR ARG) (QUOTE QUOTE)) (CONSTANTP ARG)) (IL:* IL:|;;| "We don't need gensym for this constant argument.  The test is a little more conservative than CL:CONSTANTP because it's not obvious that it's ok to evaluate a \"constant expression\" multiple times and get the same EQ object every time.") ARG) (T (IL:* IL:|;;| "Anything else might be side-effected, so will need to bind") (PUSH ARG VALS) (LET ((G (IL:GENSYM))) (PUSH G VARS) G))))) (CDR FORM))) (SETQ SHARED-SETF-INVERSE-FORM (MACROEXPAND-1 (IL:BQUOTE ((IL:\\\, SHARED-SETF-INVERSE) (IL:\\\, (CAR FORM)) (IL:\\\,@ ARGS) (IL:\\\, NEW-VAR))))) (SETQ GET-FORM (MACROEXPAND-1 (IL:BQUOTE ((IL:\\\, (CAR FORM)) (IL:\\\,@ ARGS))))) (IL:* IL:|;;| "ARGS is now the arguments to FORM with gensyms substituted for the non-constant expressions") (VALUES (SETQ VARS (NREVERSE VARS)) (SETQ VALS (NREVERSE VALS)) (LIST NEW-VAR) SHARED-SETF-INVERSE-FORM GET-FORM)))
+
+(DEFMACRO SETF (PLACE NEW-VALUE &REST OTHERS &ENVIRONMENT ENV) (IL:* IL:|;;;| "Takes pairs of arguments like SETQ. The first is a place and the second is the value that is supposed to go into that place. Returns the last value. The place argument may be any of the access forms for which SETF knows a corresponding setting form.") (IL:* IL:|;;;| "We short-circuit the normal SETF-method mechanism for two very common special cases, so as to produce much simpler and more efficient code.  The two cases are symbols and forms with simple inverses.") (COND (OTHERS (IL:BQUOTE (PROGN (SETF (IL:\\\, PLACE) (IL:\\\, NEW-VALUE)) (SETF (IL:\\\,@ OTHERS))))) (T (PROG (TEMP) LP (COND ((SYMBOLP PLACE) (RETURN (IL:BQUOTE (SETQ (IL:\\\, PLACE) (IL:\\\, NEW-VALUE))))) ((OR (NOT (CONSP PLACE)) (NOT (SYMBOLP (CAR PLACE)))) (SETF-ERROR PLACE)) ((SETQ TEMP (IL:LOCAL-MACRO-FUNCTION (CAR PLACE) ENV)) (IL:* IL:|;;| "Before looking for an inverse, we have to macroexpand until it isn't a reference to a lexical macro, since those can't have SETF methods.") (SETQ PLACE (FUNCALL TEMP PLACE ENV))) ((SETQ TEMP (OR (GET (CAR PLACE) (QUOTE :SETF-INVERSE)) (GET (CAR PLACE) (QUOTE IL:SETF-INVERSE)) (GET (CAR PLACE) (QUOTE IL:SETFN)))) (RETURN (IL:BQUOTE ((IL:\\\, TEMP) (IL:\\\,@ (CDR PLACE)) (IL:\\\, NEW-VALUE))))) ((SETQ TEMP (GET (CAR PLACE) (QUOTE :SHARED-SETF-INVERSE))) (RETURN (IL:BQUOTE ((IL:\\\, TEMP) (IL:\\\, (CAR PLACE)) (IL:\\\,@ (CDR PLACE)) (IL:\\\, NEW-VALUE))))) ((OR (GET (CAR PLACE) (QUOTE :SETF-METHOD-EXPANDER)) (GET (CAR PLACE) (QUOTE IL:SETF-METHOD-EXPANDER))) (IL:* IL:|;;| "General setf hair") (RETURN (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVALS SETTER GETTER) (GET-SETF-METHOD-MULTIPLE-VALUE PLACE ENV) (IF (NULL (CDR NEWVALS)) (IL:BQUOTE ((IL:\\\, (QUOTE LET*)) ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS)) ((IL:\\\, (CAR NEWVALS)) (IL:\\\, NEW-VALUE))) (IL:\\\, SETTER))) (IL:* IL:|;;| "It's one of those multiple-value jobbers...") (IL:BQUOTE (LET* ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS))) (MULTIPLE-VALUE-BIND (IL:\\\, NEWVALS) (IL:\\\, NEW-VALUE) (IL:\\\, SETTER)))))))) ((MULTIPLE-VALUE-BIND (EXPANSION DONE) (MACROEXPAND-1 PLACE ENV) (IL:* IL:|;;| "Try macro expanding") (WHEN (AND DONE (NOT (EQ EXPANSION PLACE))) (SETQ PLACE EXPANSION)))) (T (IL:* IL:|;;| "Nothing worked; we have to assume there's a (defun (setf mumble)...) out there somewhere") (RETURN (LET ((NEW-VALUE-TEMP (GENSYM)) (LET-LIST (MAPCAR (FUNCTION (LAMBDA (X) (LIST (GENSYM) X))) (CDR PLACE)))) (IL:BQUOTE (LET ((IL:\\\,@ LET-LIST) ((IL:\\\, NEW-VALUE-TEMP) (IL:\\\, NEW-VALUE))) (FUNCALL (FUNCTION (SETF (IL:\\\, (CAR PLACE)))) (IL:\\\, NEW-VALUE-TEMP) (IL:\\\,@ (MAPCAR (FUNCTION CAR) LET-LIST))))))))) (GO LP)))))
+
+(DEFUN SETF-ERROR (FN &OPTIONAL FORM) (IL:* IL:|;;| "Common error routine for invalid SETF's.  FN is the thing we tried to find a setf method for, FORM is its parent (not supplied when the form is a non-list).") (ERROR "~S is not a known location specifier for SETF." FN))
+
+(DEFMACRO PSETF (&REST ARGS &ENVIRONMENT ENV) (IL:* IL:|;;| "This is to SETF as PSETQ is to SETQ.  Args are alternating place expressions and values to go into those places.  All of the subforms and values are determined, left to right, and only then are the locations updated.  Returns NIL.\"") (DO ((A ARGS (CDDR A)) (LET-LIST NIL) (MV-SET-LIST NIL) (SETF-LIST NIL)) ((ATOM A) (IL:BQUOTE ((IL:\\\, (QUOTE LET)) (IL:\\\, (REVERSE LET-LIST)) (IL:\\\,@ (REVERSE MV-SET-LIST)) (IL:\\\,@ (REVERSE SETF-LIST)) NIL))) (IF (ATOM (CDR A)) (ERROR "Odd number of args to PSETF.")) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD-MULTIPLE-VALUE (CAR A) ENV) (DECLARE (IGNORE GETTER)) (DO* ((D DUMMIES (CDR D)) (V VALS (CDR V))) ((NULL D)) (PUSH (LIST (CAR D) (CAR V)) LET-LIST)) (IF (CDR NEWVAL) (PROGN (SETQ LET-LIST (APPEND NEWVAL LET-LIST)) (PUSH (IL:BQUOTE (MULTIPLE-VALUE-SETQ (IL:\\\, NEWVAL) (IL:\\\, (CADR A)))) MV-SET-LIST)) (PUSH (LIST (CAR NEWVAL) (CADR A)) LET-LIST)) (PUSH SETTER SETF-LIST))))
+
+(DEFMACRO SHIFTF (&REST ARGS &ENVIRONMENT ENV) (IL:* IL:|;;| "Assigns to each place the value of the form to its right, returns old value of 1st") (IL:* IL:|;;| "CLtL2 is ambiguous on whether multiple-values from the first form should be returned or not.  Consistencty votes yes, expediency votes no; I choose consistency (screw the New Jersey design philosophy!).") (COND ((OR (NULL ARGS) (NULL (CDR ARGS))) (ERROR "SHIFTF needs at least two arguments")) (T (CL::SHIFTF-INTERNAL ARGS ENV (QUOTE GET-SETF-METHOD-MULTIPLE-VALUE)))))
+
+(DEFMACRO ROTATEF (&REST ARGS &ENVIRONMENT ENV) (IL:* IL:|;;| "Assigns to each place the value of the form to its right; last gets first. Returns NIL.") (IL:* IL:|;;| "forms evaluated in order") (COND ((NULL ARGS) NIL) ((NULL (CDR ARGS)) (IL:BQUOTE (PROGN (IL:\\\, (CAR ARGS)) NIL))) (T (CL::ROTATEF-INTERNAL ARGS ENV (QUOTE GET-SETF-METHOD-MULTIPLE-VALUE)))))
+
+(DEFMACRO POP (PLACE &ENVIRONMENT ENV) "Pops one item off the front of PLACE and returns it." (IF (SYMBOLP PLACE) (IL:BQUOTE (PROG1 (CAR (IL:\\\, PLACE)) (SETQ (IL:\\\, PLACE) (CDR (IL:\\\, PLACE))))) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (IL:BQUOTE ((IL:\\\, (QUOTE LET*)) ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS)) (IL:\\\, (LIST (CAR NEWVAL) GETTER))) (PROG1 (CAR (IL:\\\, (CAR NEWVAL))) (SETQ (IL:\\\, (CAR NEWVAL)) (CDR (IL:\\\, (CAR NEWVAL)))) (IL:\\\, SETTER)))))))
+
+(DEFMACRO REMF (PLACE INDICATOR &ENVIRONMENT ENV) "Destructively remove INDICATOR from PLACE, returning T if it was present, NIL if not" (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (LET ((IND-TEMP (IL:GENSYM)) (LOCAL1 (IL:GENSYM)) (LOCAL2 (IL:GENSYM))) (IL:BQUOTE ((IL:\\\, (QUOTE LET*)) ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS)) ((IL:\\\, (CAR NEWVAL)) (IL:\\\, GETTER)) ((IL:\\\, IND-TEMP) (IL:\\\, INDICATOR))) (DO (((IL:\\\, LOCAL1) (IL:\\\, (CAR NEWVAL)) (CDDR (IL:\\\, LOCAL1))) ((IL:\\\, LOCAL2) NIL (IL:\\\, LOCAL1))) ((ATOM (IL:\\\, LOCAL1)) NIL) (COND ((ATOM (CDR (IL:\\\, LOCAL1))) (ERROR "Odd-length property list in REMF.")) ((EQ (CAR (IL:\\\, LOCAL1)) (IL:\\\, IND-TEMP)) (COND ((IL:\\\, LOCAL2) (RPLACD (CDR (IL:\\\, LOCAL2)) (CDDR (IL:\\\, LOCAL1))) (RETURN T)) (T (SETQ (IL:\\\, (CAR NEWVAL)) (CDDR (IL:\\\, (CAR NEWVAL)))) (IL:\\\, SETTER) (RETURN T)))))))))))
+
+
+
+(IL:* IL:|;;| "A little suppost stuff to make writing the undoable versions easier")
+
+
+(DEFUN CL::SHIFTF-INTERNAL (CL::ARGS CL::ENV CL::SETF-METHOD-GETTER) (IL:* IL:\; "Edited 11-Feb-92 15:45 by jrb:") (LET (CL::LET-LIST CL::MV-SET-LIST CL::SETF-LIST CL::GETTER) (FLET ((CL::BIND-LETS (CL::DUMMIES CL::VALS) (DO ((CL::D CL::DUMMIES (CDR CL::D)) (CL::V CL::VALS (CDR CL::V))) ((NULL CL::D)) (PUSH (LIST (CAR CL::D) (CAR CL::V)) CL::LET-LIST))) (CL::HANDLE-GETTER (CL::NEXT-VAR CL::GETTER) (SETQ CL::LET-LIST (APPEND CL::NEXT-VAR CL::LET-LIST)) (PUSH (IF (CDR CL::NEXT-VAR) (IL:BQUOTE (MULTIPLE-VALUE-SETQ (IL:\\\, CL::NEXT-VAR) (IL:\\\, CL::GETTER))) (IL:BQUOTE (SETQ (IL:\\\, (CAR CL::NEXT-VAR)) (IL:\\\, CL::GETTER)))) CL::MV-SET-LIST))) (MULTIPLE-VALUE-BIND (CL::DUMMIES CL::VALS CL::FIRST-NEWVAL CL::SETTER CL::FIRST-GETTER) (FUNCALL CL::SETF-METHOD-GETTER (CAR CL::ARGS) CL::ENV) (CL::BIND-LETS CL::DUMMIES CL::VALS) (PUSH CL::SETTER CL::SETF-LIST) (DO* ((CL::A (CDR CL::ARGS) (CDR CL::A)) (CL::NEXT-VAR CL::FIRST-NEWVAL) (CL::DUMMIES) (CL::VALS) (CL::NEWVAL) (CL::SETTER)) ((ATOM (CDR CL::A)) (CL::HANDLE-GETTER CL::NEXT-VAR (CAR CL::A)) (IL:BQUOTE (LET* (IL:\\\, (REVERSE CL::LET-LIST)) (MULTIPLE-VALUE-PROG1 (IL:\\\, CL::FIRST-GETTER) (IL:\\\,@ (REVERSE CL::MV-SET-LIST)) (IL:\\\,@ (REVERSE CL::SETF-LIST)))))) (MULTIPLE-VALUE-SETQ (CL::DUMMIES CL::VALS CL::NEWVAL CL::SETTER CL::GETTER) (FUNCALL CL::SETF-METHOD-GETTER (CAR CL::A) CL::ENV)) (CL::BIND-LETS CL::DUMMIES CL::VALS) (CL::HANDLE-GETTER CL::NEXT-VAR CL::GETTER) (PUSH CL::SETTER CL::SETF-LIST) (SETQ CL::NEXT-VAR CL::NEWVAL))))))
+
+(DEFUN CL::ROTATEF-INTERNAL (CL::ARGS CL::ENV CL::SETF-METHOD-GETTER) (IL:* IL:\; "Edited 12-Feb-92 13:10 by jrb:") (DO ((CL::A CL::ARGS (CDR CL::A)) (CL::LET-LIST NIL) (CL::SETF-LIST NIL) (CL::NEXT-VAR NIL) (CL::FIX-ME NIL)) ((ATOM CL::A) (SETF (FIRST CL::FIX-ME) (IF (CDR CL::NEXT-VAR) CL::NEXT-VAR (CAR CL::NEXT-VAR))) (IL:BQUOTE (CL::MV-LET* (IL:\\\, (REVERSE CL::LET-LIST)) (IL:\\\,@ (REVERSE CL::SETF-LIST)) NIL))) (MULTIPLE-VALUE-BIND (CL::DUMMIES CL::VALS CL::NEWVAL CL::SETTER CL::GETTER) (FUNCALL CL::SETF-METHOD-GETTER (CAR CL::A) CL::ENV) (DO ((CL::D CL::DUMMIES (CDR CL::D)) (CL::V CL::VALS (CDR CL::V))) ((NULL CL::D)) (PUSH (LIST (CAR CL::D) (CAR CL::V)) CL::LET-LIST)) (PUSH (LIST (IF (CDR CL::NEXT-VAR) CL::NEXT-VAR (CAR CL::NEXT-VAR)) CL::GETTER) CL::LET-LIST) (UNLESS CL::FIX-ME (SETQ CL::FIX-ME (CAR CL::LET-LIST))) (PUSH CL::SETTER CL::SETF-LIST) (SETQ CL::NEXT-VAR CL::NEWVAL))))
+
+
+
+(IL:* IL:|;;| "A little support macro to make ROTATEF prettier")
+
+
+(DEFMACRO CL::MV-LET* (CL::BINDING-LIST &REST CL::FORMS) (IF (NULL CL::BINDING-LIST) (IL:BQUOTE (LAMBDA NIL (IL:\\\,@ CL::FORMS))) (LABELS ((CL::MUNCH-CLAUSE (CL::BINDING-LIST) (LET ((CL::CLAUSE (POP CL::BINDING-LIST))) (IF (CONSP (CAR CL::CLAUSE)) (IL:BQUOTE (MULTIPLE-VALUE-BIND (IL:\\\, (CAR CL::CLAUSE)) (IL:\\\, (CADR CL::CLAUSE)) (IL:\\\,@ (IF CL::BINDING-LIST (LIST (CL::MUNCH-CLAUSE CL::BINDING-LIST)) CL::FORMS)))) (IL:BQUOTE ((LAMBDA ((IL:\\\, (CAR CL::CLAUSE))) (IL:\\\,@ (IF CL::BINDING-LIST (LIST (CL::MUNCH-CLAUSE CL::BINDING-LIST)) CL::FORMS))) (IL:\\\, (CADR CL::CLAUSE)))))))) (CL::MUNCH-CLAUSE CL::BINDING-LIST))))
+
+(DEFINE-MODIFY-MACRO INCF (&OPTIONAL (DELTA 1)) + "The first argument is some location holding a number.  This number is
+  incremented by the second argument, DELTA, which defaults to 1.")
+
+(DEFINE-MODIFY-MACRO DECF (&OPTIONAL (DELTA 1)) - "The first argument is some location holding a number.  This number is
+  decremented by the second argument, DELTA, which defaults to 1.")
+
+(DEFUN MAYBE-MAKE-BINDING-FORM (NEWVAL-FORM DUMMIES VALS NEWVAR SETTER GETTER) (IL:* IL:|;;| "For use in SETF-like forms to produce their final expression without using the NEWVAR gensym where possible.  DUMMIES thru GETTER are the five values returned from the SETF method.  NEWVAL-FORM is an expression to which the (sole) NEWVAR is logically to be bound, written in terms of the GETTER form.  If it looks like there are no side-effect problems, we substitute NEWVAL-FORM into SETTER; otherwise we return a binding form that returns SETTER correctly.") (IF (OR DUMMIES (> (COUNT-OCCURRENCES (CAR NEWVAR) SETTER) 1)) (IL:* IL:\; " have to do messy binding form") (IL:BQUOTE ((IL:\\\, (QUOTE LET*)) ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS)) ((IL:\\\, (CAR NEWVAR)) (IL:\\\, NEWVAL-FORM))) (IL:\\\, SETTER))) (IL:* IL:\; "No temp vars, setter used only once, so nothing can be side-effected, so store it directly") (SUBST NEWVAL-FORM (CAR NEWVAR) SETTER)))
+
+(DEFUN COUNT-OCCURRENCES (SYMBOL FORM) (COND ((CONSP FORM) (+ (COUNT-OCCURRENCES SYMBOL (CAR FORM)) (COUNT-OCCURRENCES SYMBOL (CDR FORM)))) ((EQ SYMBOL FORM) 1) (T 0)))
+
+(DEFMACRO CL::SETF-NAME-P (CL::THING) (IL:BQUOTE (AND (CONSP (IL:\\\, CL::THING)) (EQ (CAR (IL:\\\, CL::THING)) (QUOTE SETF)) (CONSP (CDR (IL:\\\, CL::THING))) (SYMBOLP (CADR (IL:\\\, CL::THING))))))
+
+(DEFUN XCL::DEFUN-SETF-NAME (XCL::REAL-NAME) (XCL:PACK (LIST XCL::REAL-NAME "-defun-setf") (SYMBOL-PACKAGE XCL::REAL-NAME)))
+
+(DEFUN XCL::SET-DEFUN-SETF (XCL::NAME XCL::DEFUN-SETF-FN) (REMPROP XCL::NAME (QUOTE IL:SETF-METHOD-EXPANDER)) (REMPROP XCL::NAME :SETF-METHOD-EXPANDER) (REMPROP XCL::NAME :SETF-INVERSE) (SETF (GET XCL::NAME :SETF-DEFUN) XCL::DEFUN-SETF-FN))
+
+(DEFMACRO PUSH (OBJ PLACE &ENVIRONMENT ENV) "Conses OBJ onto PLACE, returning the modified list." (IF (SYMBOLP PLACE) (IL:BQUOTE (SETQ (IL:\\\, PLACE) (CONS (IL:\\\, OBJ) (IL:\\\, PLACE)))) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (MAYBE-MAKE-BINDING-FORM (IL:BQUOTE (CONS (IL:\\\, OBJ) (IL:\\\, GETTER))) DUMMIES VALS NEWVAL SETTER GETTER))))
+
+(DEFMACRO PUSHNEW (OBJ PLACE &REST KEYS &ENVIRONMENT ENV) "Conses OBJ onto PLACE unless its already there, using :TEST if necessary" (IF (SYMBOLP PLACE) (IL:BQUOTE (SETQ (IL:\\\, PLACE) (ADJOIN (IL:\\\, OBJ) (IL:\\\, PLACE) (IL:\\\,@ KEYS)))) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (MAYBE-MAKE-BINDING-FORM (IL:BQUOTE (ADJOIN (IL:\\\, OBJ) (IL:\\\, GETTER) (IL:\\\,@ KEYS))) DUMMIES VALS NEWVAL SETTER GETTER))))
+
+(DEFSETF CAR (X) (V) (IL:BQUOTE (CAR (RPLACA (IL:\\\, X) (IL:\\\, V)))))
+
+(DEFSETF CDR (X) (V) (IL:BQUOTE (CDR (RPLACD (IL:\\\, X) (IL:\\\, V)))))
+
+(DEFSETF CAAAAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CAAAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CAAADR (X) (V) (IL:BQUOTE (CAR (RPLACA (CAADR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CAAAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CAAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CAADAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CADAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CAADDR (X) (V) (IL:BQUOTE (CAR (RPLACA (CADDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CAADR (X) (V) (IL:BQUOTE (CAR (RPLACA (CADR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CAAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CADAAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDAAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CADADR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDADR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CADAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CADDAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CADDDR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CADDR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CADR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDAAAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CAAAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDAADR (X) (V) (IL:BQUOTE (CDR (RPLACD (CAADR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDAAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CAAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDADAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CADAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDADDR (X) (V) (IL:BQUOTE (CDR (RPLACD (CADDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDADR (X) (V) (IL:BQUOTE (CDR (RPLACD (CADR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDDAAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDAAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDDADR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDADR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDDAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDDDAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDDAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDDDDR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDDDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDDDR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDDR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF FIRST (X) (V) (IL:BQUOTE (CAR (RPLACA (IL:\\\, X) (IL:\\\, V)))))
+
+(DEFSETF SECOND (X) (V) (IL:BQUOTE (CAR (RPLACA (CDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF THIRD (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF FOURTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF FIFTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDDDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF SIXTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDR (CDDDDR (IL:\\\, X))) (IL:\\\, V)))))
+
+(DEFSETF SEVENTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDR (CDDDDR (IL:\\\, X))) (IL:\\\, V)))))
+
+(DEFSETF EIGHTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDDR (CDDDDR (IL:\\\, X))) (IL:\\\, V)))))
+
+(DEFSETF NINTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDDDR (CDDDDR (IL:\\\, X))) (IL:\\\, V)))))
+
+(DEFSETF TENTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDR (CDDDDR (CDDDDR (IL:\\\, X)))) (IL:\\\, V)))))
+
+(DEFSETF REST (X) (V) (IL:BQUOTE (CDR (RPLACD (IL:\\\, X) (IL:\\\, V)))))
+
+(DEFSETF NTHCDR (N LIST) (NEWVAL) (IL:BQUOTE (CDR (RPLACD (NTHCDR (1- (IL:\\\, N)) (IL:\\\, LIST)) (IL:\\\, NEWVAL)))))
+
+(DEFSETF NTH %SET-NTH)
+
+(DEFINE-SETF-METHOD GETF (PLACE PROP &OPTIONAL DEFAULT &ENVIRONMENT ENV) (MULTIPLE-VALUE-BIND (TEMPS VALUES STORES SET GET) (GET-SETF-METHOD PLACE ENV) (LET ((NEWVAL (IL:GENSYM)) (PTEMP (IL:GENSYM)) (DEF-TEMP (IL:GENSYM))) (VALUES (IL:BQUOTE ((IL:\\\,@ TEMPS) (IL:\\\, (CAR STORES)) (IL:\\\, PTEMP) (IL:\\\,@ (IF DEFAULT (IL:BQUOTE ((IL:\\\, DEF-TEMP))))))) (IL:BQUOTE ((IL:\\\,@ VALUES) (IL:\\\, GET) (IL:\\\, PROP) (IL:\\\,@ (IF DEFAULT (IL:BQUOTE ((IL:\\\, DEFAULT))))))) (IL:BQUOTE ((IL:\\\, NEWVAL))) (IL:BQUOTE (COND ((NULL (IL:\\\, (CAR STORES))) (LET* (IL:\\\, (LIST (APPEND STORES (IL:BQUOTE ((LIST (IL:\\\, PTEMP) (IL:\\\, NEWVAL))))))) (IL:\\\, SET)) (IL:\\\, NEWVAL)) (T (IL:LISTPUT (IL:\\\, (CAR STORES)) (IL:\\\, PTEMP) (IL:\\\, NEWVAL))))) (IL:BQUOTE (GETF (IL:\\\, (CAR STORES)) (IL:\\\, PTEMP) (IL:\\\,@ (IF DEFAULT (IL:BQUOTE ((IL:\\\, DEF-TEMP)))))))))))
+
+(DEFINE-SETF-METHOD APPLY (FN &REST ARGS &ENVIRONMENT ENV) (IF (AND (CONSP FN) (EQ (LENGTH FN) 2) (MEMBER (FIRST FN) (QUOTE (FUNCTION IL:FUNCTION QUOTE)) :TEST (FUNCTION EQ)) (SYMBOLP (SECOND FN))) (SETQ FN (SECOND FN)) (ERROR "Setf of Apply is only defined for function args of form #'symbol.")) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD (CONS FN ARGS) ENV) (IL:* IL:|;;| "Make sure the place is one that we can handle.") (UNLESS (AND (EQ (CAR (LAST ARGS)) (CAR (LAST VALS))) (EQ (CAR (LAST GETTER)) (CAR (LAST DUMMIES))) (EQ (CAR (LAST SETTER)) (CAR (LAST DUMMIES)))) (ERROR "Apply of ~S not understood as a location for Setf." FN)) (VALUES DUMMIES VALS NEWVAL (IL:BQUOTE (APPLY (FUNCTION (IL:\\\, (CAR SETTER))) (IL:\\\,@ (CDR SETTER)))) (IL:BQUOTE (APPLY (FUNCTION (IL:\\\, (CAR GETTER))) (IL:\\\,@ (CDR GETTER)))))))
+
+(DEFINE-SETF-METHOD LDB (BYTESPEC PLACE &ENVIRONMENT ENV) "The first argument is a byte specifier.  The second is any place form
+  acceptable to SETF.  Replaces the specified byte of the number in this
+  place with bits from the low-order end of the new value." (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (LET ((BTEMP (IL:GENSYM)) (GNUVAL (IL:GENSYM))) (VALUES (CONS BTEMP DUMMIES) (CONS BYTESPEC VALS) (LIST GNUVAL) (IL:BQUOTE (LET (((IL:\\\, (CAR NEWVAL)) (DPB (IL:\\\, GNUVAL) (IL:\\\, BTEMP) (IL:\\\, GETTER)))) (IL:\\\, SETTER) (IL:\\\, GNUVAL))) (IL:BQUOTE (LDB (IL:\\\, BTEMP) (IL:\\\, GETTER)))))))
+
+(DEFINE-SETF-METHOD MASK-FIELD (BYTESPEC PLACE &ENVIRONMENT ENV) "The first argument is a byte specifier.  The second is any place form
+  acceptable to SETF.  Replaces the specified byte of the number in this place
+  with bits from the corresponding position in the new value." (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE) (LET ((BTEMP (IL:GENSYM)) (GNUVAL (IL:GENSYM))) (VALUES (CONS BTEMP DUMMIES) (CONS BYTESPEC VALS) (LIST GNUVAL) (IL:BQUOTE (LET (((IL:\\\, (CAR NEWVAL)) (DEPOSIT-FIELD (IL:\\\, GNUVAL) (IL:\\\, BTEMP) (IL:\\\, GETTER)))) (IL:\\\, SETTER) (IL:\\\, GNUVAL))) (IL:BQUOTE (MASK-FIELD (IL:\\\, BTEMP) (IL:\\\, GETTER)))))))
+
+(DEFINE-SETF-METHOD CHAR-BIT (PLACE BIT-NAME &ENVIRONMENT ENV) "The first argument is any place form acceptable to SETF.  Replaces the
+  specified bit of the character in this place with the new value." (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (LET ((BTEMP (IL:GENSYM)) (GNUVAL (IL:GENSYM))) (VALUES (IL:BQUOTE ((IL:\\\,@ DUMMIES) (IL:\\\, BTEMP))) (IL:BQUOTE ((IL:\\\,@ VALS) (IL:\\\, BIT-NAME))) (LIST GNUVAL) (IL:BQUOTE (LET (((IL:\\\, (CAR NEWVAL)) (SET-CHAR-BIT (IL:\\\, GETTER) (IL:\\\, BTEMP) (IL:\\\, GNUVAL)))) (IL:\\\, SETTER) (IL:\\\, GNUVAL))) (IL:BQUOTE (CHAR-BIT (IL:\\\, GETTER) (IL:\\\, BTEMP)))))))
+
+(DEFINE-SETF-METHOD THE (TYPE PLACE &ENVIRONMENT ENV) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (VALUES DUMMIES VALS NEWVAL (SUBST (IL:BQUOTE (THE (IL:\\\, TYPE) (IL:\\\, (CAR NEWVAL)))) (CAR NEWVAL) SETTER) (IL:BQUOTE (THE (IL:\\\, TYPE) (IL:\\\, GETTER))))))
+
+(DEFSETF CL:FDEFINITION CL::SET-FDEFINITION)
+
+
+
+(IL:* IL:\; "Some IL setfs, for no especially good reason")
+
+
+(DEFSETF IL:GETHASH IL:%SET-IL-GETHASH)
+
+(DEFMACRO IL:%SET-IL-GETHASH (KEY HASH-TABLE &OPTIONAL NEWVALUE) (IL:* IL:|;;| "SETF inverse for IL:GETHASH.  Tricky parts are that args to IL:PUTHASH are in wrong order, and IL:GETHASH might default its second arg (yuck, let's flush that), in which case the third arg is absent and the second is the new value.") (COND ((NOT NEWVALUE) (IL:* IL:\; "Defaulted hash table") (IL:BQUOTE (IL:PUTHASH (IL:\\\, KEY) (IL:\\\, HASH-TABLE)))) ((OR (IL:CONSTANTEXPRESSIONP NEWVALUE) (AND (SYMBOLP NEWVALUE) (SYMBOLP HASH-TABLE))) (IL:* IL:\; "Ok to swap args") (IL:BQUOTE (IL:PUTHASH (IL:\\\, KEY) (IL:\\\, NEWVALUE) (IL:\\\, HASH-TABLE)))) (T (IL:BQUOTE (LET (IL:$$GETHASH-TABLE) (DECLARE (IL:LOCALVARS IL:$$GETHASH-TABLE)) (IL:PUTHASH (IL:\\\, KEY) (PROGN (IL:SETQ IL:$$GETHASH-TABLE (IL:\\\, HASH-TABLE)) (IL:\\\, NEWVALUE)) IL:$$GETHASH-TABLE))))))
+
+(IL:PUTPROPS :SETF-METHOD-EXPANDER IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS :SETF-INVERSE IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS :SHARED-SETF-INVERSE IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS IL:CMLSETF IL:FILETYPE :COMPILE-FILE)
+
+(IL:PUTPROPS IL:CMLSETF IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA)
+
+(IL:ADDTOVAR IL:NLAML)
+
+(IL:ADDTOVAR IL:LAMA)
+)
+(IL:PUTPROPS IL:CMLSETF IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/CMLSETF.DFASL b/CLTL2/CMLSETF.DFASL
new file mode 100644
index 00000000..f0e66873
Binary files /dev/null and b/CLTL2/CMLSETF.DFASL differ
diff --git a/CLTL2/CMLSMARTARGS b/CLTL2/CMLSMARTARGS
new file mode 100644
index 00000000..e01eb303
--- /dev/null
+++ b/CLTL2/CMLSMARTARGS
@@ -0,0 +1,752 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 15:15:10" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLSMARTARGS.;2" 36820  
+
+      previous date%: "13-Apr-92 16:26:44" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLSMARTARGS.;1"
+)
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLSMARTARGSCOMS)
+
+(RPAQQ CMLSMARTARGSCOMS
+       ((VARS *CL-ARGINFO-LIST* *XCL-ARGINFO-LIST*)
+        (FUNCTIONS ARGINFO-MUNG CLSMARTEN)
+        [DECLARE%: DONTEVAL@LOAD DOCOPY (P (CLSMARTEN *CL-ARGINFO-LIST*)
+                                           (CLSMARTEN *XCL-ARGINFO-LIST*)
+                                           (SETQ *CL-ARGINFO-LIST* (SETQ *XCL-ARGINFO-LIST*
+                                                                         'NOBIND]
+        (PROP FILETYPE CMLSMARTARGS)))
+
+(RPAQQ *CL-ARGINFO-LIST*
+       (((LISP:* +)
+         &REST NUMBERS)
+        ((- / LISP:/= < <= = > >= MAX MIN)
+         LISP:NUMBER &REST MORE-NUMBERS)
+        ((LISP:1+ LISP:1- ABS LISP:ACOS LISP:ACOSH LISP:ASIN LISP:ASINH LISP:ATANH LISP:CONJUGATE 
+                LISP:COSH LISP:EXP LISP:IMAGPART MINUSP LISP:PHASE LISP:PLUSP LISP:RATIONAL 
+                LISP:RATIONALIZE LISP:REALPART LISP:SIGNUM LISP:SINH LISP:SQRT LISP:TANH LISP:ZEROP)
+         LISP:NUMBER)
+        (LISP:ACONS KEY DATUM A-LIST)
+        ((LISP:ADJOIN LISP:MEMBER)
+         ITEM LIST &KEY :TEST :TEST-NOT :KEY)
+        (LISP:ADJUST-ARRAY LISP:ARRAY NEW-DIMENSIONS &KEY :ELEMENT-TYPE :INITIAL-ELEMENT 
+               :INITIAL-CONTENTS :FILL-POINTER :DISPLACED-TO :DISPLACED-INDEX-OFFSET :FATP 
+               :DISPLACED-TO-BASE)
+        ((LISP:ADJUSTABLE-ARRAY-P LISP:ARRAY-DIMENSIONS LISP:ARRAY-ELEMENT-TYPE 
+                LISP:ARRAY-HAS-FILL-POINTER-P LISP:ARRAY-RANK LISP:ARRAY-TOTAL-SIZE)
+         LISP:ARRAY)
+        ((LISP:ALPHA-CHAR-P LISP:ALPHANUMERICP LISP:BOTH-CASE-P LISP:CHAR-BITS LISP:CHAR-CODE 
+                LISP:CHAR-DOWNCASE LISP:CHAR-FONT LISP:CHAR-INT LISP:CHAR-NAME LISP:CHAR-UPCASE 
+                LISP:GRAPHIC-CHAR-P LISP:LOWER-CASE-P LISP:STANDARD-CHAR-P LISP:STRING-CHAR-P 
+                LISP:UPPER-CASE-P)
+         LISP:CHAR)
+        ((AND OR PROGN)
+         (CURLYLIST FORM)
+         #\*)
+        ((LISP:APPEND NCONC)
+         &REST LISTS)
+        (LISP:APPLY LISP:FUNCTION ARG &REST MORE-ARGS)
+        (LISP:APPLYHOOK LISP:FUNCTION ARGS EVALHOOKFN APPLYHOOKFN &OPTIONAL ENV)
+        ((LISP:APROPOS LISP:APROPOS-LIST)
+         STRING &OPTIONAL PACKAGE)
+        ((LISP:AREF LISP:ARRAY-IN-BOUNDS-P LISP:ARRAY-ROW-MAJOR-INDEX)
+         LISP:ARRAY &REST SUBSCRIPTS)
+        (LISP:ARRAY-DIMENSION LISP:ARRAY AXIS-NUMBER)
+        ((LISP:ARRAYP LISP:ATOM LISP:BIT-VECTOR-P LISP:CHARACTER LISP:CHARACTERP LISP:COMMONP 
+                LISP:COMPILED-FUNCTION-P LISP:COMPLEXP LISP:CONSP LISP:CONSTANTP LISP:COPY-TREE 
+                LISP:DESCRIBE LISP:ENDP LISP:FLOATP LISP:FUNCTIONP LISP:HASH-TABLE-P LISP:IDENTITY 
+                INSPECT LISP:INTEGERP LISP:KEYWORDP LISP:LISTP NULL LISP:NUMBERP LISP:PACKAGEP 
+                LISP:PATHNAMEP LISP:PRIN1-TO-STRING LISP:PRINC-TO-STRING LISP:RANDOM-STATE-P 
+                LISP:RATIONALP READTABLEP LISP:SIMPLE-BIT-VECTOR-P LISP:SIMPLE-STRING-P 
+                LISP:SIMPLE-VECTOR-P STREAMP LISP:STRINGP LISP:SXHASH LISP:SYMBOLP LISP:TYPE-OF 
+                LISP:VECTORP)
+         OBJECT)
+        (LISP:ASH INTEGER LISP:COUNT)
+        [LISP:ASSERT TEST-FORM (SQUARELIST ((CURLYLIST* PLACE))
+                                      (SQUARELIST STRING (CURLYLIST* ARG]
+        ((LISP:ASSOC LISP:RASSOC)
+         ITEM A-LIST &KEY :TEST :TEST-NOT :KEY)
+        ((LISP:ASSOC-IF LISP:ASSOC-IF-NOT LISP:RASSOC-IF LISP:RASSOC-IF-NOT)
+         PREDICATE A-LIST &KEY :KEY)
+        (LISP:ATAN Y &OPTIONAL X)
+        (BIT BIT-ARRAY &REST SUBSCRIPTS)
+        ((LISP:BIT-AND LISP:BIT-EQV LISP:BIT-IOR LISP:BIT-XOR)
+         BIT-ARRAY1 BIT-ARRAY-2 &OPTIONAL RESULT-BIT-ARRAY)
+        ((LISP:BIT-ANDC1 LISP:BIT-ANDC2 LISP:BIT-NAND LISP:BIT-NOR LISP:BIT-ORC1 LISP:BIT-ORC2)
+         BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL RESULT-BIT-ARRAY)
+        (LISP:BIT-NOT BIT-ARRAY &OPTIONAL RESULT-BIT-ARRAY)
+        (LISP:BLOCK NAME
+            (CURLYLIST FORM)
+            #\*)
+        (LISP:BOOLE OP INTEGER1 INTEGER2)
+        ((BOUNDP LISP:FBOUNDP LISP:FMAKUNBOUND LISP:MAKE-SYNONYM-STREAM LISP:MAKUNBOUND 
+                LISP:SPECIAL-FORM-P LISP:SYMBOL-FUNCTION LISP:SYMBOL-PLIST LISP:SYMBOL-VALUE)
+         LISP:SYMBOL)
+        (LISP:BREAK &OPTIONAL FORMAT-STRING &REST ARGS)
+        ((LISP:BUTLAST LISP:NBUTLAST)
+         LIST &OPTIONAL N)
+        (BYTE SIZE LISP:POSITION)
+        ((LISP:BYTE-POSITION BYTE-SIZE)
+         BYTESPEC)
+        ((CAAAAR CAAADR CAAAR CAADAR CAADDR CAADR CAAR CADAAR CADADR CADAR CADDAR CADDDR CADDR CADR 
+                CAR CDAAAR CDAADR CDAAR CDADAR CDADDR CDADR CDAR CDDAAR CDDADR CDDAR CDDDAR CDDDDR 
+                CDDDR CDDR CDR LISP:EIGHTH LISP:FIFTH LISP:FIRST LISP:FOURTH LISP:LIST-LENGTH 
+                LISP:NINTH LISP:REST LISP:SECOND LISP:SEVENTH LISP:SIXTH LISP:TENTH LISP:THIRD)
+         LIST)
+        [(CASE LISP:ECASE)
+         KEYFORM
+         (CURLYLIST* ((CURLYLIST ((CURLYLIST* KEY))
+                             #\| KEY)
+                      (CURLYLIST* FORM]
+        (LISP:CATCH TAG
+            (CURLYLIST FORM)
+            #\*)
+        [LISP:CCASE KEYPLACE (CURLYLIST* ((CURLYLIST ((CURLYLIST* KEY))
+                                                 #\| KEY)
+                                          (CURLYLIST* FORM]
+        ((LISP:CEILING LISP:FCEILING LISP:FFLOOR LISP:FLOOR LISP:FROUND LISP:FTRUNCATE ROUND 
+                LISP:TRUNCATE)
+         LISP:NUMBER &OPTIONAL DIVISOR)
+        (LISP:CERROR CONTINUE-FORMAT-STRING ERROR-FORMAT-STRING &REST ARGS)
+        (LISP:CHAR STRING INDEX)
+        (LISP:CHAR-BIT LISP:CHAR NAME)
+        ((LISP:CHAR-EQUAL LISP:CHAR-GREATERP LISP:CHAR-LESSP LISP:CHAR-NOT-EQUAL 
+                LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-LESSP LISP:CHAR/= LISP:CHAR< LISP:CHAR<= 
+                LISP:CHAR= LISP:CHAR> LISP:CHAR>=)
+         LISP:CHARACTER &REST MORE-CHARACTERS)
+        (LISP:CHECK-TYPE PLACE TYPESPEC &OPTIONAL STRING)
+        ((LISP:CIS LISP:COS LISP:SIN LISP:TAN)
+         RADIANS)
+        ((LISP:CLEAR-INPUT LISP:LISTEN)
+         &OPTIONAL INPUT-STREAM)
+        ((LISP:CLEAR-OUTPUT LISP:FINISH-OUTPUT LISP:FORCE-OUTPUT LISP:FRESH-LINE LISP:TERPRI)
+         &OPTIONAL OUTPUT-STREAM)
+        (LISP:CLOSE STREAM &KEY :ABORT)
+        ((CLRHASH LISP:HASH-TABLE-COUNT)
+         LISP:HASH-TABLE)
+        (LISP:CODE-CHAR CODE &OPTIONAL BITS FONT)
+        (COERCE OBJECT RESULT-TYPE)
+        (LISP:COMPILE NAME &OPTIONAL DEFINITION &KEY :LAP)
+        (LISP:COMPILE-FILE INPUT-PATHNAME &KEY :OUTPUT-FILE :ERROR-FILE :ERRORS-TO-TERMINAL :LAP-FILE
+               :LOAD :FILE-MANAGER-FORMAT :PROCESS-ENTIRE-FILE)
+        (LISP:COMPILER-LET ((CURLYLIST VAR #\| (VAR VALUE))
+                            #\*)
+               (CURLYLIST FORM)
+               #\*)
+        (COMPLEX LISP:REALPART &OPTIONAL IMAGPART)
+        (LISP:COMPUTE-RESTARTS &OPTIONAL CONDITION)
+        (LISP:CONCATENATE RESULT-TYPE &REST SEQUENCES)
+        (COND (CURLYLIST (TEST (CURLYLIST FORM)
+                               #\*))
+              #\*)
+        ((CONS LISP:NRECONC LISP:REVAPPEND RPLACA RPLACD)
+         X Y)
+        ((LISP:COPY-ALIST LISP:COPY-LIST LISP:VALUES-LIST)
+         LIST)
+        (LISP:COPY-READTABLE &OPTIONAL FROM-READTABLE TO-READTABLE)
+        ((LISP:COPY-SEQ LISP:LENGTH LISP:NREVERSE LISP:REVERSE)
+         SEQUENCE)
+        (LISP:COPY-SYMBOL SYM &OPTIONAL COPY-PROPS)
+        ((LISP:COUNT LISP:FIND LISP:POSITION)
+         ITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :KEY)
+        ((LISP:COUNT-IF LISP:COUNT-IF-NOT LISP:FIND-IF LISP:FIND-IF-NOT LISP:POSITION-IF 
+                LISP:POSITION-IF-NOT)
+         TEST SEQUENCE &KEY :FROM-END :START :END :KEY)
+        [LISP:CTYPECASE KEYPLACE (CURLYLIST* (TYPE (CURLYLIST* FORM]
+        ((LISP:DECF LISP:INCF)
+         PLACE
+         (SQUARELIST DELTA))
+        (LISP:DECLAIM (CURLYLIST* DECL-SPEC)
+               #\*)
+        (DECLARE (CURLYLIST DECL-SPEC)
+               #\*)
+        ((LISP:DECODE-FLOAT LISP:FLOAT-DIGITS LISP:FLOAT-PRECISION LISP:FLOAT-RADIX 
+                LISP:INTEGER-DECODE-FLOAT)
+         FLOAT)
+        (LISP:DECODE-UNIVERSAL-TIME UNIVERSAL-TIME &OPTIONAL TIME-ZONE)
+        ((LISP:DEFCONSTANT LISP:DEFPARAMETER)
+         NAME INITIAL-VALUE (SQUARELIST LISP:DOCUMENTATION))
+        (DEFINE-CONDITION NAME ((CURLYLIST PARENT-TYPE)
+                                #\*)
+               (SQUARELIST ((CURLYLIST SLOT-SPECIFIER)
+                            #\*)
+                      (CURLYLIST OPTION)
+                      #\*))
+        (LISP:DEFINE-MODIFY-MACRO NAME LAMBDA-LIST LISP:FUNCTION (SQUARELIST DOC-STRING))
+        (LISP:DEFINE-SETF-METHOD ACCESS-FN LAMBDA-LIST (CURLYLIST LISP:DECLARATION #\| DOC-STRING)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        ((DEFMACRO LISP:DEFTYPE LISP:DEFUN)
+         NAME LAMBDA-LIST (CURLYLIST* LISP:DECLARATION #\| DOC-STRING)
+         (CURLYLIST* FORM))
+        (DEFPACKAGE DEFINED-PACKAGE-NAME (CURLYLIST OPTION)
+               #\*)
+        (LISP:DEFSETF ACCESS-FN (CURLYLIST UPDATE-FN (SQUARELIST DOC-STRING)
+                                       #\| LAMBDA-LIST (STORE-VARIABLE)
+                                       (CURLYLIST LISP:DECLARATION #\| DOC-STRING)
+                                       #\*
+                                       (CURLYLIST FORM)
+                                       #\*))
+        (LISP:DEFSTRUCT NAME-AND-OPTIONS (SQUARELIST DOC-STRING)
+               (CURLYLIST SLOT-DESCRIPTION)
+               #\+)
+        (LISP:DEFVAR NAME (SQUARELIST INITIAL-VALUE (SQUARELIST LISP:DOCUMENTATION)))
+        ((LISP:DELETE LISP:REMOVE)
+         ITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY)
+        ((LISP:DELETE-DUPLICATES LISP:REMOVE-DUPLICATES)
+         SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :KEY)
+        ((LISP:DELETE-FILE LISP:FILE-AUTHOR LISP:FILE-WRITE-DATE LISP:PROBE-FILE)
+         FILE)
+        ((LISP:DELETE-IF LISP:DELETE-IF-NOT LISP:REMOVE-IF LISP:REMOVE-IF-NOT)
+         TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY)
+        ((LISP:DENOMINATOR LISP:NUMERATOR)
+         LISP:RATIONAL)
+        ((LISP:DEPOSIT-FIELD DPB)
+         NEWBYTE BYTESPEC INTEGER)
+        (DESTRUCTURING-BIND BIND-PATTERN VALUE &BODY BODY)
+        (LISP:DIGIT-CHAR WEIGHT &OPTIONAL RADIX FONT)
+        (LISP:DIGIT-CHAR-P LISP:CHAR &OPTIONAL RADIX)
+        ((LISP:DIRECTORY LISP:DIRECTORY-NAMESTRING LISP:FILE-NAMESTRING LISP:HOST-NAMESTRING 
+                LISP:NAMESTRING PATHNAME LISP:PATHNAME-DEVICE LISP:PATHNAME-DIRECTORY 
+                LISP:PATHNAME-HOST LISP:PATHNAME-NAME LISP:PATHNAME-TYPE LISP:PATHNAME-VERSION 
+                LISP:TRUENAME)
+         PATHNAME)
+        (LISP:DISASSEMBLE NAME-OR-COMPILED-FUNCTION)
+        ((LISP:DO LISP:DO*)
+         [(CURLYLIST* VAR #\| (VAR (SQUARELIST INIT (SQUARELIST LISP:STEP]
+         (END-TEST (CURLYLIST* RESULT))
+         (CURLYLIST* LISP:DECLARATION)
+         (CURLYLIST* TAG #\| STATEMENT))
+        (LISP:DO-ALL-SYMBOLS (VAR (SQUARELIST RESULT-FORM))
+               (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST TAG #\| STATEMENT)
+               #\*)
+        ((LISP:DO-EXTERNAL-SYMBOLS LISP:DO-SYMBOLS)
+         (VAR (SQUARELIST PACKAGE (SQUARELIST RESULT-FORM)))
+         (CURLYLIST LISP:DECLARATION)
+         #\*
+         (CURLYLIST TAG #\| STATEMENT)
+         #\*)
+        (LISP:DOCUMENTATION LISP:SYMBOL DOC-TYPE)
+        (LISP:DOLIST (VAR LISTFORM (SQUARELIST RESULTFORM))
+            (CURLYLIST LISP:DECLARATION)
+            #\*
+            (CURLYLIST TAG #\| STATEMENT)
+            #\*)
+        (LISP:DOTIMES (VAR COUNTFORM (SQUARELIST RESULTFORM))
+            (CURLYLIST LISP:DECLARATION)
+            #\*
+            (CURLYLIST TAG #\| STATEMENT)
+            #\*)
+        (DRIBBLE &OPTIONAL PATHNAME)
+        (ED &OPTIONAL NAME OPTIONS #\= ((CURLYLIST "FILEPKGTYPE" #\| :DISPLAY #\| :NEW)
+                                        #\*))
+        (LISP:ELT SEQUENCE INDEX)
+        (LISP:ENCODE-UNIVERSAL-TIME LISP:SECOND MINUTE HOUR DATE MONTH YEAR &OPTIONAL TIME-ZONE)
+        (LISP:ENOUGH-NAMESTRING PATHNAME &OPTIONAL DEFAULTS)
+        ((EQ EQL LISP:EQUAL LISP:EQUALP)
+         X Y)
+        ((LISP:ERROR LISP:WARN)
+         FORMAT-STRING &REST ARGS)
+        ((LISP:ETYPECASE LISP:TYPECASE)
+         KEYFORM
+         (CURLYLIST (TYPE (CURLYLIST FORM)
+                          #\*))
+         #\*)
+        ((LISP:EVAL LISP:GET-SETF-METHOD LISP:GET-SETF-METHOD-MULTIPLE-VALUE)
+         FORM)
+        (LISP:EVAL-WHEN ((CURLYLIST SITUATION)
+                         #\*)
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:EVALHOOK FORM EVALHOOKFN APPLYHOOKFN &OPTIONAL ENV)
+        ((EVENP LISP:INT-CHAR LISP:INTEGER-LENGTH LISP:ISQRT LISP:LOGCOUNT LOGNOT ODDP)
+         INTEGER)
+        ((LISP:EVERY LISP:NOTANY LISP:NOTEVERY LISP:SOME)
+         PREDICATE SEQUENCE &REST MORE-SEQUENCES)
+        ((EXPORT IMPORT LISP:SHADOW LISP:SHADOWING-IMPORT LISP:UNEXPORT)
+         SYMBOLS &OPTIONAL PACKAGE)
+        (LISP:EXPT BASE-NUMBER POWER-NUMBER)
+        (LISP:FILE-LENGTH FILE-STREAM)
+        (LISP:FILE-POSITION FILE-STREAM &OPTIONAL LISP:POSITION)
+        (LISP:FILL SEQUENCE ITEM &KEY :START :END)
+        ((LISP:FILL-POINTER LISP:VECTOR-POP)
+         LISP:VECTOR)
+        (LISP:FIND-ALL-SYMBOLS STRING-OR-SYMBOL)
+        ((LISP:FIND-PACKAGE LISP:NAME-CHAR)
+         NAME)
+        (LISP:FIND-RESTART RESTART-IDENTIFIER &OPTIONAL CONDITION)
+        ((LISP:FIND-SYMBOL LISP:INTERN)
+         STRING &OPTIONAL PACKAGE)
+        ((LISP:FLET LISP:LABELS)
+         ((CURLYLIST (NAME LAMBDA-LIST (CURLYLIST LISP:DECLARATION #\| DOC-STRING)
+                           #\*
+                           (CURLYLIST FORM)
+                           #\*))
+          #\*)
+         (CURLYLIST FORM)
+         #\*)
+        (FLOAT LISP:NUMBER &OPTIONAL OTHER)
+        (LISP:FLOAT-SIGN FLOAT1 &OPTIONAL FLOAT2)
+        (LISP:FORMAT DESTINATION CONTROL-STRING &REST ARGUMENTS)
+        (LISP:FUNCALL FN &REST ARGUMENTS)
+        #'FN
+        ((LISP:GCD LOGAND LISP:LOGEQV LISP:LOGIOR LOGXOR)
+         &REST INTEGERS)
+        (LISP:GENSYM &OPTIONAL X)
+        (LISP:GENTEMP &OPTIONAL PREFIX PACKAGE)
+        (GET LISP:SYMBOL INDICATOR &OPTIONAL DEFAULT)
+        ((LISP:GET-DECODED-TIME LISP:GET-INTERNAL-REAL-TIME LISP:GET-INTERNAL-RUN-TIME 
+                LISP:GET-UNIVERSAL-TIME LISP:LISP-IMPLEMENTATION-TYPE 
+                LISP:LISP-IMPLEMENTATION-VERSION LISP:LIST-ALL-PACKAGES LISP:LONG-SITE-NAME 
+                LISP:MACHINE-INSTANCE LISP:MACHINE-TYPE LISP:MACHINE-VERSION 
+                LISP:MAKE-STRING-OUTPUT-STREAM LISP:SHORT-SITE-NAME LISP:SOFTWARE-TYPE 
+                LISP:SOFTWARE-VERSION))
+        (LISP:GET-DISPATCH-MACRO-CHARACTER DISP-CHAR SUB-CHAR &OPTIONAL LISP:READTABLE)
+        (LISP:GET-MACRO-CHARACTER LISP:CHAR &OPTIONAL LISP:READTABLE)
+        (LISP:GET-OUTPUT-STREAM-STRING STRING-OUTPUT-STREAM)
+        (LISP:GET-PROPERTIES PLACE INDICATOR-LIST)
+        (LISP:GETF PLACE INDICATOR &OPTIONAL DEFAULT)
+        (LISP:GETHASH KEY LISP:HASH-TABLE &OPTIONAL DEFAULT)
+        (GO TAG)
+        (HANDLER-BIND ((CURLYLIST (TYPE HANDLER))
+                       #\*)
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:HANDLER-CASE EXPRESSION (CURLYLIST (TYPESPEC ((SQUARELIST VAR))
+                                                        (CURLYLIST FORM)
+                                                        #\*))
+               #\*)
+        (IGNORE-ERRORS &BODY FORMS)
+        (LISP:IF TEST
+            THEN
+            (SQUARELIST ELSE))
+        (LISP:IN-PACKAGE NAME)
+        (LISP:IN-PACKAGE LISP:PACKAGE-NAME &KEY :NICKNAMES :USE)
+        ((LISP:INPUT-STREAM-P LISP:OUTPUT-STREAM-P LISP:STREAM-ELEMENT-TYPE)
+         STREAM)
+        (LISP:INVOKE-RESTART RESTART-IDENTIFIER &REST ARGUMENTS)
+        ((LISP:INTERSECTION LISP:NINTERSECTION LISP:NSET-DIFFERENCE LISP:NSET-EXCLUSIVE-OR 
+                LISP:NUNION LISP:SET-DIFFERENCE LISP:SET-EXCLUSIVE-OR LISP:SUBSETP LISP:UNION)
+         LIST1 LIST2 &KEY :TEST :TEST-NOT :KEY)
+        (LAST LIST &OPTIONAL N)
+        (LISP:LCM &REST INTEGERS)
+        ((LDB LISP:LDB-TEST LISP:MASK-FIELD)
+         BYTESPEC INTEGER)
+        (LISP:LDIFF LIST SUBLIST)
+        ((LET LET*)
+         ((CURLYLIST VAR #\| (VAR (SQUARELIST VALUE)))
+          #\*)
+         (CURLYLIST LISP:DECLARATION)
+         #\*
+         (CURLYLIST FORM)
+         #\*)
+        ((LIST LISP:VALUES)
+         &REST ARGS)
+        (LIST* ARG &REST OTHERS)
+        (LISP:LOAD FILENAME &KEY :VERBOSE :PRINT :IF-DOES-NOT-EXIST :PACKAGE :LOADFLG)
+        (LISP:LOCALLY (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:LOG LISP:NUMBER &OPTIONAL BASE)
+        ((LISP:LOGANDC1 LISP:LOGANDC2 LISP:LOGNAND LISP:LOGNOR LISP:LOGORC1 LISP:LOGORC2 LISP:LOGTEST
+                )
+         INTEGER1 INTEGER2)
+        (LISP:LOGBITP INDEX INTEGER)
+        (LISP:LOOP (CURLYLIST LISP::LOOP-CLAUSE)
+               #\*
+               (CURLYLIST TAG #\| EXPR)
+               #\*)
+        (LISP:MACRO-FUNCTION SYMBOL &OPTIONAL ENV)
+        ((LISP:MACROEXPAND LISP:MACROEXPAND-1)
+         FORM &OPTIONAL ENV)
+        (LISP:MACROLET ((CURLYLIST (NAME VARLIST (CURLYLIST LISP:DECLARATION #\| DOC-STRING)
+                                         #\*
+                                         (CURLYLIST FORM)
+                                         #\*))
+                        #\*)
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:MAKE-ARRAY DIMENSIONS &KEY :ELEMENT-TYPE :INITIAL-ELEMENT :INITIAL-CONTENTS :ADJUSTABLE
+               :FILL-POINTER :DISPLACED-TO :DISPLACED-INDEX-OFFSET :FATP :EXTENDABLE :READ-ONLY-P 
+               :DISPLACED-TO-BASE)
+        ((LISP:MAKE-BROADCAST-STREAM LISP:MAKE-CONCATENATED-STREAM)
+         &REST STREAMS)
+        (LISP:MAKE-CHAR LISP:CHAR &OPTIONAL BITS FONT)
+        (MAKE-CONDITION TYPE &REST SLOT-INITIALIZATIONS)
+        (LISP:MAKE-DISPATCH-MACRO-CHARACTER LISP:CHAR &OPTIONAL NON-TERMINATING-P LISP:READTABLE)
+        ((LISP:MAKE-ECHO-STREAM LISP:MAKE-TWO-WAY-STREAM)
+         INPUT-STREAM OUTPUT-STREAM)
+        (LISP:MAKE-HASH-TABLE &KEY :TEST :SIZE :REHASH-SIZE :REHASH-THRESHOLD)
+        (LISP:MAKE-LIST SIZE &KEY :INITIAL-ELEMENT)
+        (LISP:MAKE-PACKAGE LISP:PACKAGE-NAME &KEY :NICKNAMES :USE :PREFIX-NAME :INTERNAL-SYMBOLS 
+               :EXTERNAL-SYMBOLS :EXTERNAL-ONLY)
+        (LISP:MAKE-PATHNAME &KEY :HOST :DEVICE :DIRECTORY :NAME :TYPE :VERSION :DEFAULTS :CASE)
+        (LISP:MAKE-RANDOM-STATE &OPTIONAL STATE)
+        (LISP:MAKE-SEQUENCE TYPE SIZE &KEY :INITIAL-ELEMENT)
+        (LISP:MAKE-STRING SIZE &KEY :INITIAL-ELEMENT :ELEMENT-TYPE)
+        (LISP:MAKE-STRING-INPUT-STREAM STRING &OPTIONAL START END)
+        (LISP:MAKE-STRING-OUTPUT-STREAM &KEY :ELEMENT-TYPE)
+        (LISP:MAKE-SYMBOL PRINT-NAME)
+        (MAKE-VECTOR LISP:LENGTH &OPTIONAL TYPE INITIAL-VALUE)
+        (LISP:MAP RESULT-TYPE LISP:FUNCTION SEQUENCE &REST MORE-SEQUENCES)
+        (LISP:MAP-INTO RESULT-SEQUENCE FUNCTION &REST SEQUENCES)
+        ((LISP:MAPC LISP:MAPCAN LISP:MAPCAR LISP:MAPCON LISP:MAPL LISP:MAPLIST)
+         LISP:FUNCTION LIST &REST MORE-LISTS)
+        (LISP:MAPHASH LISP:FUNCTION LISP:HASH-TABLE)
+        ((LISP:MEMBER-IF LISP:MEMBER-IF-NOT)
+         PREDICATE LIST &KEY :KEY)
+        (LISP:MERGE RESULT-TYPE SEQUENCE1 SEQUENCE2 PREDICATE &KEY :KEY)
+        (LISP:MERGE-PATHNAMES PATHNAME &OPTIONAL DEFAULTS DEFAULT-VERSION)
+        ((LISP:MISMATCH LISP:SEARCH)
+         SEQUENCE1 SEQUENCE2 &KEY :FROM-END :TEST :TEST-NOT :KEY :START1 :START2 :END1 :END2)
+        ((LISP:MOD LISP:REM)
+         LISP:NUMBER DIVISOR)
+        (LISP:MULTIPLE-VALUE-BIND ((CURLYLIST VAR)
+                                   #\*)
+               VALUES-FORM
+               (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:MULTIPLE-VALUE-CALL LISP:FUNCTION (CURLYLIST FORM)
+               #\*)
+        ((LISP:MULTIPLE-VALUE-LIST LISP:STEP)
+         FORM)
+        (LISP:MULTIPLE-VALUE-PROG1 FORM (CURLYLIST FORM)
+               #\*)
+        (LISP:MULTIPLE-VALUE-SETQ VARIABLES FORM)
+        ((NOT STRING)
+         X)
+        ((LISP:NSTRING-CAPITALIZE LISP:NSTRING-DOWNCASE LISP:NSTRING-UPCASE LISP:STRING-CAPITALIZE 
+                LISP:STRING-DOWNCASE LISP:STRING-UPCASE)
+         STRING &KEY :START :END)
+        ((LISP:NSUBLIS LISP:SUBLIS)
+         ALIST TREE &KEY :TEST :TEST-NOT :KEY)
+        ((LISP:NSUBST LISP:SUBST)
+         NEW OLD TREE &KEY :TEST :TEST-NOT :KEY)
+        ((LISP:NSUBST-IF LISP:NSUBST-IF-NOT LISP:SUBST-IF LISP:SUBST-IF-NOT)
+         NEW TEST TREE &KEY :KEY)
+        ((LISP:NSUBSTITUTE LISP:SUBSTITUTE)
+         NEWITEM OLDITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY)
+        ((LISP:NSUBSTITUTE-IF LISP:NSUBSTITUTE-IF-NOT LISP:SUBSTITUTE-IF LISP:SUBSTITUTE-IF-NOT)
+         NEWITEM TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY)
+        ((LISP:NTH LISP:NTHCDR)
+         N LIST)
+        (LISP:NTH-VALUE N FORM)
+        (OPEN FILENAME &KEY :DIRECTION :ELEMENT-TYPE :IF-EXISTS :IF-DOES-NOT-EXIST :EXTERNAL-FORMAT)
+        ((LISP:PACKAGE-NAME LISP:PACKAGE-NICKNAMES LISP:PACKAGE-SHADOWING-SYMBOLS 
+                LISP:PACKAGE-USE-LIST LISP:PACKAGE-USED-BY-LIST)
+         PACKAGE)
+        (LISP:PAIRLIS KEYS DATA &OPTIONAL A-LIST)
+        (LISP:PARSE-INTEGER STRING &KEY :START :END :RADIX :JUNK-ALLOWED)
+        (LISP:PARSE-NAMESTRING THING &OPTIONAL HOST DEFAULTS &KEY :START :END :JUNK-ALLOWED)
+        ((LISP:PATHNAME-HOST LISP:PATHNAME-DEVICE LISP:PATHNAME-DIRECTORY LISP:PATHNAME-NAME 
+                LISP:PATHNAME-TYPE)
+         PATHNAME &KEY :CASE)
+        (LISP:PEEK-CHAR &OPTIONAL PEEK-TYPE INPUT-STREAM EOF-ERROR-P EOF-VALUE RECURSIVE-P)
+        (LISP:POP PLACE)
+        ((LISP:PPRINT LISP:PRIN1 LISP:PRINC LISP:PRINT)
+         OBJECT &OPTIONAL OUTPUT-STREAM)
+        (LISP:PRINT-UNREADABLE-OBJECT (LISP::OBJECT STREAM &KEY :TYPE :IDENTITY)
+               (CURLYLIST DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:PROCLAIM DECL-SPEC)
+        ((PROG PROG*)
+         ((CURLYLIST VAR #\| (VAR (SQUARELIST INIT)))
+          #\*)
+         (CURLYLIST LISP:DECLARATION)
+         #\*
+         (CURLYLIST TAG #\| STATEMENT)
+         #\*)
+        (PROG1 LISP:FIRST
+            (CURLYLIST FORM)
+            #\*)
+        (PROG2 LISP:FIRST LISP:SECOND (CURLYLIST FORM)
+               #\*)
+        (LISP:PROGV SYMBOLS LISP:VALUES
+            (CURLYLIST FORM)
+            #\*)
+        (LISP:PROVIDE MODULE-NAME)
+        ((LISP:PSETF LISP:SETF)
+         (CURLYLIST PLACE NEWVALUE)
+         #\*)
+        ((LISP:PSETQ LISP:SETQ)
+         (CURLYLIST VAR FORM)
+         #\*)
+        (LISP:PUSH ITEM PLACE)
+        (LISP:PUSHNEW ITEM LIST &KEY :TEST :TEST-NOT :KEY)
+        'OBJECT
+        (LISP:RANDOM LISP:NUMBER &OPTIONAL STATE)
+        ((LISP:READ LISP:READ-CHAR LISP:READ-CHAR-NO-HANG LISP:READ-LINE)
+         &OPTIONAL INPUT-STREAM EOF-ERROR-P EOF-VALUE RECURSIVE-P)
+        (LISP:READ-BYTE BINARY-INPUT-STREAM &OPTIONAL EOF-ERROR-P EOF-VALUE)
+        (LISP:READ-DELIMITED-LIST LISP:CHAR &OPTIONAL INPUT-STREAM RECURSIVE-P)
+        (LISP:READ-FROM-STRING STRING &OPTIONAL EOF-ERROR-P EOF-VALUE &KEY :START :END 
+               :PRESERVE-WHITESPACE)
+        (LISP:READ-PRESERVING-WHITESPACE &OPTIONAL IN-STREAM EOF-ERROR-P EOF-VALUE RECURSIVE-P)
+        (LISP:REDUCE LISP:FUNCTION SEQUENCE &KEY :FROM-END :START :END :INITIAL-VALUE)
+        (LISP:REMF PLACE INDICATOR)
+        (REMHASH KEY LISP:HASH-TABLE)
+        (REMPROP LISP:SYMBOL INDICATOR)
+        (LISP:RENAME-FILE FILE NEW-NAME)
+        (LISP:RENAME-PACKAGE PACKAGE NEW-NAME &OPTIONAL NEW-NICKNAMES)
+        (LISP:REPLACE SEQUENCE1 SEQUENCE2 &KEY :START1 :END1 :START2 :END2)
+        (LISP:REQUIRE MODULE-NAME &OPTIONAL PATHNAME)
+        (LISP:RESTART-BIND ((CURLYLIST (NAME FUNCTION (CURLYLIST KEYWORD VALUE)
+                                             #\*))
+                            #\*)
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:RESTART-CASE EXPRESSION (CURLYLIST (CASE-NAME ARG-LIST (CURLYLIST KEYWORD VALUE)
+                                                        #\*
+                                                        (CURLYLIST FORM)
+                                                        #\*))
+               #\*)
+        (RETURN (SQUARELIST RESULT))
+        (LISP:RETURN-FROM NAME (SQUARELIST RESULT))
+        (LISP:ROTATEF (CURLYLIST PLACE)
+               #\*)
+        (LISP:SBIT SIMPLE-BIT-ARRAY &REST SUBSCRIPTS)
+        (LISP:SCALE-FLOAT FLOAT INTEGER)
+        (LISP:SCHAR LISP:SIMPLE-STRING INDEX)
+        (SET LISP:SYMBOL VALUE)
+        (LISP:SET-CHAR-BIT LISP:CHAR NAME NEWVALUE)
+        (LISP:SET-DISPATCH-MACRO-CHARACTER DISP-CHAR SUB-CHAR LISP:FUNCTION &OPTIONAL LISP:READTABLE)
+        (LISP:SET-MACRO-CHARACTER LISP:CHAR LISP:FUNCTION &OPTIONAL NON-TERMINATING-P LISP:READTABLE)
+        (LISP:SET-SYNTAX-FROM-CHAR TO-CHAR FROM-CHAR &OPTIONAL TO-READTABLE FROM-READTABLE)
+        (LISP:SHIFTF (CURLYLIST PLACE)
+               #\+ NEWVALUE)
+        (SIGNAL DATUM &REST ARGUMENTS)
+        (LISP:SLEEP SECONDS)
+        ((LISP:SORT LISP:STABLE-SORT)
+         SEQUENCE PREDICATE &KEY :KEY)
+        ((STORE-VALUE USE-VALUE)
+         NEW-VALUE &OPTIONAL CONDITION)
+        (LISP:STREAM-EXTERNAL-FORMAT STREAM)
+        ((STRING-EQUAL LISP:STRING-GREATERP LISP:STRING-LESSP LISP:STRING-NOT-EQUAL 
+                LISP:STRING-NOT-GREATERP LISP:STRING-NOT-LESSP LISP:STRING/= LISP:STRING< 
+                LISP:STRING<= LISP:STRING= LISP:STRING> LISP:STRING>=)
+         STRING1 STRING2 &KEY :START1 :END1 :START2 :END2)
+        ((LISP:STRING-LEFT-TRIM LISP:STRING-RIGHT-TRIM LISP:STRING-TRIM)
+         CHARACTER-BAG STRING)
+        (LISP:SUBSEQ SEQUENCE START &OPTIONAL END)
+        (LISP:SUBTYPEP TYPE1 TYPE2)
+        (LISP:SVREF LISP:SIMPLE-VECTOR INDEX)
+        (LISP::SYMBOL-MACROLET ((CURLYLIST (LISP::VAR LISP::EXPANSION))
+                                #\*)
+               (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST LISP::FORM)
+               #\*)
+        ((LISP:SYMBOL-NAME LISP:SYMBOL-PACKAGE)
+         SYM)
+        (LISP:TAGBODY (CURLYLIST TAG #\| STATEMENT)
+               #\*)
+        (TAILP SUBLIST LIST)
+        (THE VALUE-TYPE FORM)
+        (LISP:THROW TAG RESULT)
+        (TIME FORM &KEY :REPEAT :OUTPUT :DATA-TYPES)
+        ((TRACE UNTRACE)
+         (CURLYLIST FUNCTION-NAME)
+         #\*)
+        (LISP:TRANSLATE-PATHNAME PATHNAME &KEY)
+        (LISP:TRANSLATE-PATHNAME LISP::SOURCE LISP::FROM-WILDNAME LISP::TO-WILDNAME &KEY)
+        (LISP:TREE-EQUAL X Y &KEY :TEST :TEST-NOT)
+        (TYPEP OBJECT TYPE)
+        (LISP:UNINTERN LISP:SYMBOL &OPTIONAL PACKAGE)
+        ((LISP:UNLESS LISP:WHEN)
+         TEST
+         (CURLYLIST FORM)
+         #\*)
+        (LISP:UNREAD-CHAR LISP:CHARACTER &OPTIONAL INPUT-STREAM)
+        (LISP:UNUSE-PACKAGE PACKAGES-TO-UNUSE &OPTIONAL PACKAGE)
+        (LISP:UNWIND-PROTECT
+            PROTECTED-FORM
+            (CURLYLIST CLEANUP-FORM)
+            #\*)
+        (LISP:USE-PACKAGE PACKAGES-TO-USE &OPTIONAL PACKAGE)
+        (LISP:USER-HOMEDIR-PATHNAME &OPTIONAL HOST)
+        (LISP:VECTOR &REST OBJECTS)
+        (LISP:VECTOR-PUSH NEW-ELEMENT LISP:VECTOR)
+        (LISP:VECTOR-PUSH-EXTEND NEW-ELEMENT LISP:VECTOR &OPTIONAL EXTENSION)
+        (LISP:WILD-PATHNAME-P PATHNAME &OPTIONAL LISP::FIELD-KEY)
+        (LISP:WITH-COMPILATION-UNIT ((CURLYLIST LISP::OPTION-NAME LISP::OPTION-VALUE)
+                                     #\*)
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:WITH-CONDITION-RESTARTS CONDITION-FORM RESTARTS-FORM (CURLYLIST DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:WITH-INPUT-FROM-STRING (VAR STRING (CURLYLIST LISP:KEYWORD VALUE)
+                                          #\*)
+               (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:WITH-HASH-TABLE-ITERATOR (LISP::MNAME LISP:HASH-TABLE)
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:WITH-OPEN-FILE (STREAM FILENAME (CURLYLIST OPTIONS)
+                                    #\*)
+               (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:WITH-OPEN-STREAM (VAR STREAM)
+               (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:WITH-OUTPUT-TO-STRING (VAR (SQUARELIST STRING (SQUARELIST ":ELEMENT-TYPE" TYPE)))
+               (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:WITH-PACKAGE-ITERATOR (MNAME PACKAGE-LIST (CURLYLIST LISP::SYMBOL-TYPE)
+                                           #\+)
+               (CURLYLIST LISP::FORM)
+               #\*)
+        (LISP:WITH-SIMPLE-RESTART (NAME FORMAT-STRING (CURLYLIST FORMAT-ARGUMENT)
+                                        #\*)
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:WITH-STANDARD-IO-SYNTAX (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (WRITE OBJECT &KEY :STREAM :ESCAPE :RADIX :BASE :CIRCLE :PRETTY :LEVEL :LENGTH :CASE :GENSYM
+               :ARRAY :READABLY :RIGHT-MARGIN :MISER-WIDTH :LINES :PPRINT-DISPATCH)
+        (LISP:WRITE-BYTE INTEGER BINARY-OUTPUT-STREAM)
+        (LISP:WRITE-CHAR LISP:CHARACTER &OPTIONAL OUTPUT-STREAM)
+        ((LISP:WRITE-LINE LISP:WRITE-STRING)
+         STRING &OPTIONAL OUTPUT-STREAM &KEY :START :END)
+        (LISP:WRITE-TO-STRING OBJECT &KEY :ESCAPE :RADIX :BASE :CIRCLE :PRETTY :LEVEL :LENGTH :CASE 
+               :GENSYM :ARRAY :READABLY :RIGHT-MARGIN :MISER-WIDTH :LINES :PPRINT-DISPATCH)
+        ((LISP:Y-OR-N-P LISP:YES-OR-NO-P)
+         &OPTIONAL FORMAT-STRING &REST ARGUMENTS)))
+
+(RPAQQ *XCL-ARGINFO-LIST*
+       ((ADD-EXEC &KEY :PROFILE :REGION :TTY :EXEC :ID)
+        (ASET NEWVALUE ARRAY &REST INDICES)
+        (CATCH-ABORT PRINT-FORM &BODY FORMS)
+        (CONDITION-CASE FORM (CURLYLIST (TYPE ((SQUARELIST VAR))
+                                              (CURLYLIST FORM)
+                                              #\*))
+               #\*)
+        ((CONDITION-HANDLER CONDITION-REPORTER)
+         TYPE)
+        (COMPILER:COPY-ENV-WITH-FUNCTION ENVIRONMENT FUNCTION &OPTIONAL KIND EXP-FN)
+        (COMPILER:COPY-ENV-WITH-VARIABLE ENVIRONMENT VARIABLE &OPTIONAL KIND)
+        (DEBUG &OPTIONAL DATUM &REST ARGUMENTS)
+        (DEF-DEFINE-TYPE NAME DESCRIPTION-STRING &KEY :UNDEFINER)
+        (DEFAULT-PROCEED-TEST PROCEED-CASE-NAME)
+        (DEFCOMMAND NAME ARGUMENT-LIST &REST BODY)
+        (DEFDEFINER (CURLYLIST NAME #\| (NAME (CURLYLIST OPTION-CLAUSE)
+                                              #\*))
+               TYPE ARGLIST &BODY BODY)
+        (DEFGLOBALPARAMETER NAME INITIAL-VALUE &OPTIONAL DOC-STRING)
+        (DEFGLOBALVAR NAME &OPTIONAL INITIAL-VALUE DOC-STRING)
+        (DEFINE-PROCEED-FUNCTION NAME (SQUARELIST KEYWORD VALUE)
+               #\* &REST VARIABLES)
+        (DEFINLINE NAME ARG-LIST &BODY BODY)
+        (DEFOPTIMIZER FORM-NAME (SQUARELIST OPT-NAME)
+               (SQUARELIST ARG-LIST (SQUARELIST DECL #\| DOC-STRING)
+                      #\*)
+               BODY)
+        ((XCL:DO-INTERNAL-SYMBOLS DO-LOCAL-SYMBOLS)
+         (VAR (SQUARELIST PACKAGE (SQUARELIST RESULT-FORM)))
+         (CURLYLIST LISP:DECLARATION)
+         #\*
+         (CURLYLIST TAG #\| STATEMENT)
+         #\*)
+        (EXEC &KEY :TOP-LEVEL-P :WINDOW :TITLE :COMMAND-TABLES :ENVIRONMENT :PROMPT :FUNCTION 
+              :PROFILE :ID)
+        (EXEC-EVAL FORM &OPTIONAL ENVIRONMENT &KEY :PROMPT :ID :TYPE)
+        (EXEC-FORMAT CONTROL-STRING &REST ARGUMENTS)
+        ((EXTENDABLE-ARRAY-P READ-ONLY-ARRAY-P)
+         ARRAY)
+        (FILL-VECTOR VECTOR VALUE &KEY :START :END)
+        (GLOBALIZE NAMESTRINGS &OPTIONAL PACKAGE)
+        (INVOKE-PROCEED-CASE PROCEED-CASE &REST VALUES)
+        (COMPILER:MAKE-CONTEXT &KEY :TOP-LEVEL-P :VALUES-USED :PREDICATE-P)
+        (PARSE-BODY BODY ENVIRONMENT &OPTIONAL DOC-STRING-ALLOWED?)
+        (PROCEED-CASE FORM (CURLYLIST (PROCEED-FUNCTION-NAME ARGLIST (SQUARELIST KEYWORD VALUE)
+                                             #\*
+                                             (CURLYLIST BODY-FORM)
+                                             #\*))
+               #\*)
+        ((XCL:SET-DEFAULT-EXEC-TYPE XCL:SET-EXEC-TYPE)
+         NAME)
+        (UNDOABLY (CURLYLIST FORMS))
+        (UNDOABLY-SETF (CURLYLIST PLACE VALUE)
+               #\*)))
+
+(LISP:DEFUN ARGINFO-MUNG (LST)
+
+   (* ;; "Flattens list elements of LST into a single top-level list of characters and words, recognizing special directives (SQUARELIST . things) and (CURLYLIST . things) to mean turn it into [things] and {things}, respectively.")
+
+   [FOR THING IN LST JOIN (COND
+                                         [(LISP:CONSP THING)
+                                          (CASE (CAR THING)
+                                              (SQUARELIST (CONS #\[ (NCONC1 (ARGINFO-MUNG
+                                                                             (CDR THING))
+                                                                           #\])))
+                                              (CURLYLIST (CONS #\{ (NCONC1 (ARGINFO-MUNG
+                                                                            (CDR THING))
+                                                                          #\})))
+                                              (CURLYLIST* (CONS #\{ (NCONC (ARGINFO-MUNG
+                                                                            (CDR THING))
+                                                                           (LIST #\} #\*))))
+                                              (LISP:OTHERWISE (CONS #\( (NCONC1 (ARGINFO-MUNG
+                                                                                 THING)
+                                                                               #\)))))]
+                                         (T (LIST THING])
+
+(LISP:DEFUN CLSMARTEN (FNLIST)
+
+   (* ;; "Transfer arg info from entries in FNLIST to the ARGNAMES props of those fns that need it.  Format of an entry in FNLIST is (Functions . StylizedArgInfo), where Functions can be a symbol or list of symbols.")
+
+   [LET ((NOSPELLFLG T))                                     (* ; 
+                                                           "Tell SMARTARGLIST not to try too hard")
+        (DECLARE (LISP:SPECIAL NOSPELLFLG))
+        (LISP:DOLIST (PAIR FNLIST)
+            [LET (NEWARGS KNOWNARGS)
+                 (LISP:DOLIST [FN (OR (LISTP (CAR PAIR))
+                                      (LIST (CAR PAIR]
+                     (LISP:UNLESS (AND [SETQ KNOWNARGS (NLSETQ (SMARTARGLIST
+                                                                FN
+                                                                (MEMB (ARGTYPE FN)
+                                                                      '(0 2]
+                                       (LISP:LISTP (SETQ KNOWNARGS (CAR KNOWNARGS)))
+                                       (NOT (LISP:MACRO-FUNCTION FN)))
+
+                         (* ;; "Only do this for fns for which SMARTARGLIST doesn't know the answer (something other than an atomic arglist) already.  Also ignore macros to override arglists provided by DEFMACRO.  The ARGTYPE check means try EXPLAINFLG=T in the case where the function is already defined as a lambda (don't want to do that for macros, since SMARTARGLIST would then fake something out of a macro/dmacro prop).  Format of ARGNAMES prop for this kind of guy is (NIL PrettyArgs . InterlispArgs).")
+
+                         (LISP:SETF (GET FN 'ARGNAMES)
+                                (LIST* NIL [OR NEWARGS (SETQ NEWARGS (ARGINFO-MUNG (CDR PAIR]
+                                       KNOWNARGS))))])])
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(CLSMARTEN *CL-ARGINFO-LIST*)
+
+(CLSMARTEN *XCL-ARGINFO-LIST*)
+
+(SETQ *CL-ARGINFO-LIST* (SETQ *XCL-ARGINFO-LIST* 'NOBIND))
+)
+
+(PUTPROPS CMLSMARTARGS FILETYPE :COMPILE-FILE)
+(PUTPROPS CMLSMARTARGS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1991 1992 1993)
+)
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/CLTL2/CMLSMARTARGS.DFASL b/CLTL2/CMLSMARTARGS.DFASL
new file mode 100644
index 00000000..ca706834
Binary files /dev/null and b/CLTL2/CMLSMARTARGS.DFASL differ
diff --git a/CLTL2/CMLSTRING b/CLTL2/CMLSTRING
new file mode 100644
index 00000000..d911eee6
--- /dev/null
+++ b/CLTL2/CMLSTRING
@@ -0,0 +1,567 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 15:18:00" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLSTRING.;2" 30461  
+
+      previous date%: "29-Aug-91 22:57:51" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLSTRING.;1")
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLSTRINGCOMS)
+
+(RPAQQ CMLSTRINGCOMS
+       (
+        (* ;; "run-time support ")
+
+        (FUNCTIONS LISP::SIMPLE-STRING= LISP::SIMPLE-STRING-EQUAL)
+        (FUNCTIONS %%STRING-BASE-COMPARE %%STRING-BASE-COMPARE-EQUAL %%STRING-UPCASE 
+               %%STRING-DOWNCASE)
+        
+        (* ;; "User entry points ")
+
+        (FUNCTIONS LISP:MAKE-STRING LISP:NSTRING-CAPITALIZE LISP:NSTRING-DOWNCASE LISP:NSTRING-UPCASE
+               STRING LISP:STRING-CAPITALIZE LISP:STRING-DOWNCASE STRING-EQUAL LISP:STRING-GREATERP 
+               LISP:STRING-LEFT-TRIM LISP:STRING-LESSP LISP:STRING-NOT-EQUAL LISP:STRING-NOT-GREATERP
+               LISP:STRING-NOT-LESSP LISP:STRING-RIGHT-TRIM LISP:STRING-TRIM LISP:STRING-UPCASE 
+               LISP:STRING/= LISP:STRING< LISP:STRING<= LISP:STRING= LISP:STRING> LISP:STRING>=)
+        (OPTIMIZERS LISP:STRING= STRING-EQUAL)
+        
+        (* ;; "Internal macros  ")
+
+        (DECLARE%: DONTCOPY DOEVAL@COMPILE (FUNCTIONS WITH-ONE-STRING WITH-ONE-STRING-ONLY 
+                                                  WITH-STRING WITH-TWO-UNPACKED-STRINGS 
+                                                  %%UNPACK-STRING %%ADJUST-FOR-OFFSET %%CHECK-BOUNDS
+                                                  %%PARSE-STRING-ARGS %%STRING-LENGTH))
+        
+        (* ;; "Compiler options")
+
+        (PROP FILETYPE CMLSTRING)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))))
+
+
+
+(* ;; "run-time support ")
+
+
+(LISP:DEFUN LISP::SIMPLE-STRING= (STRING1 STRING2)
+   [LET ((END1 (%%STRING-LENGTH STRING1))
+         (END2 (%%STRING-LENGTH STRING2)))
+        (LISP:IF (EQ END1 END2)
+            (LET (BASE1 BASE2 OFFSET1 OFFSET2 TYPENUMBER1 TYPENUMBER2)
+                 (%%UNPACK-STRING STRING1 BASE1 OFFSET1 TYPENUMBER1)
+                 (%%UNPACK-STRING STRING2 BASE2 OFFSET2 TYPENUMBER2)
+                 (LISP:IF (NOT (EQ 0 OFFSET1))
+                     (SETQ END1 (+ END1 OFFSET1)))
+                 (LISP:IF (NOT (EQ 0 OFFSET2))
+                     (SETQ END2 (+ END2 OFFSET2)))
+                 (EQ END1 (%%STRING-BASE-COMPARE BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 OFFSET1 END1
+                                 OFFSET2 END2))))])
+
+(LISP:DEFUN LISP::SIMPLE-STRING-EQUAL (STRING1 STRING2)
+   [LET ((END1 (%%STRING-LENGTH STRING1))
+         (END2 (%%STRING-LENGTH STRING2)))
+        (LISP:IF (EQ END1 END2)
+            (LET (BASE1 BASE2 OFFSET1 OFFSET2 TYPENUMBER1 TYPENUMBER2)
+                 (%%UNPACK-STRING STRING1 BASE1 OFFSET1 TYPENUMBER1)
+                 (%%UNPACK-STRING STRING2 BASE2 OFFSET2 TYPENUMBER2)
+                 (LISP:IF (NOT (EQ 0 OFFSET1))
+                     (SETQ END1 (+ END1 OFFSET1)))
+                 (LISP:IF (NOT (EQ 0 OFFSET2))
+                     (SETQ END2 (+ END2 OFFSET2)))
+                 (EQ END1 (%%STRING-BASE-COMPARE-EQUAL BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
+                                 OFFSET1 END1 OFFSET2 END2))))])
+
+(LISP:DEFUN %%STRING-BASE-COMPARE (BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2)
+
+   (* ;; "Return index into base1 of first inequality ")
+
+   (* ;; "Can use eq for character comparisons because they are immediate datatypes. Can use eq for numeric equality since Indices are always in the fixnum range")
+
+   (LISP:IF (EQ START1 START2)
+       (LISP:DO ((INDEX START1 (LISP:1+ INDEX))
+                 (ENDINDEX (MIN END1 END2)))
+                ([OR (EQ INDEX ENDINDEX)
+                     (NOT (EQ (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                              (%%ARRAY-READ BASE2 TYPENUMBER2 INDEX]
+                 INDEX))
+       (LISP:DO [(INDEX1 START1 (LISP:1+ INDEX1))
+                 (INDEX2 START2 (LISP:1+ INDEX2))
+                 (ENDINDEX (MIN END1 (+ START1 (- END2 START2]
+                ([OR (EQ INDEX1 ENDINDEX)
+                     (NOT (EQ (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX1)
+                              (%%ARRAY-READ BASE2 TYPENUMBER2 INDEX2]
+                 INDEX1))))
+
+(LISP:DEFUN %%STRING-BASE-COMPARE-EQUAL (BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 
+                                                   END2)
+
+   (* ;; "Return index into base1 of first case insensitive  inequality ")
+
+   (* ;; "Can use eq for character comparisons because they are immediate datatypes. ")
+
+   (* ;; "Char-upcase has been expanded out and simplified below.")
+
+   (LISP:IF (EQ START1 START2)
+       (LISP:DO ((INDEX START1 (LISP:1+ INDEX))
+                 (ENDINDEX (MIN END1 END2)))
+                ([OR (EQ INDEX ENDINDEX)
+                     (NOT (EQ (%%CHAR-UPCASE-CODE (\LOLOC (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)))
+                              (%%CHAR-UPCASE-CODE (\LOLOC (%%ARRAY-READ BASE2 TYPENUMBER2 INDEX]
+                 INDEX))
+       (LISP:DO [(INDEX1 START1 (LISP:1+ INDEX1))
+                 (INDEX2 START2 (LISP:1+ INDEX2))
+                 (ENDINDEX (MIN END1 (+ START1 (- END2 START2]
+                ([OR (EQ INDEX1 ENDINDEX)
+                     (NOT (EQ (%%CHAR-UPCASE-CODE (\LOLOC (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX1)))
+                              (%%CHAR-UPCASE-CODE (\LOLOC (%%ARRAY-READ BASE2 TYPENUMBER2 INDEX2]
+                 INDEX1))))
+
+(LISP:DEFUN %%STRING-UPCASE (STRING START END)
+
+   (* ;; "Assumes string is a string. Start and end define a subsequence. Destructively upcases string and returns it ")
+
+   (LET ((BASE (%%ARRAY-BASE STRING))
+         (OFFSET (%%ARRAY-OFFSET STRING))
+         (TYPENUMBER (%%ARRAY-TYPE-NUMBER STRING)))
+        (%%ADJUST-FOR-OFFSET START END OFFSET)
+        (LISP:DO ((INDEX START (LISP:1+ INDEX)))
+                 ((EQ INDEX END)
+                  STRING)
+            (%%ARRAY-WRITE (LISP:CHAR-UPCASE (%%ARRAY-READ BASE TYPENUMBER INDEX))
+                   BASE TYPENUMBER INDEX))))
+
+(LISP:DEFUN %%STRING-DOWNCASE (STRING START END)
+
+   (* ;; "Assumes string is a string. Start and end define a subsequence. Destructively downcases string and returns it ")
+
+   (LET ((BASE (%%ARRAY-BASE STRING))
+         (OFFSET (%%ARRAY-OFFSET STRING))
+         (TYPENUMBER (%%ARRAY-TYPE-NUMBER STRING)))
+        (%%ADJUST-FOR-OFFSET START END OFFSET)
+        (LISP:DO ((INDEX START (LISP:1+ INDEX)))
+                 ((EQ INDEX END)
+                  STRING)
+            (%%ARRAY-WRITE (LISP:CHAR-DOWNCASE (%%ARRAY-READ BASE TYPENUMBER INDEX))
+                   BASE TYPENUMBER INDEX))))
+
+
+
+(* ;; "User entry points ")
+
+
+(LISP:DEFUN LISP:MAKE-STRING (SIZE &KEY (ELEMENT-TYPE 'LISP:CHARACTER)
+                                       (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P)
+                                       FATP)
+   "Makes a simple string"
+   (LET ((STRING (MAKE-VECTOR SIZE :ELEMENT-TYPE ELEMENT-TYPE :FATP FATP)))
+        (LISP:IF INITIAL-ELEMENT-P (FILL-ARRAY STRING INITIAL-ELEMENT))
+        STRING))
+
+(LISP:DEFUN LISP:NSTRING-CAPITALIZE (STRING &KEY START END)
+   "Given a string, returns it with the first letter of every word in uppercase and all other letters in lowercase. A word is defined to be a sequence of alphanumeric characters delimited by non-alphanumeric characters"
+   [WITH-ONE-STRING-ONLY STRING START END (LISP:DO ((INDEX START (LISP:1+ INDEX))
+                                                        (ALPHA-P NIL)
+                                                        (WAS-ALPHA-P NIL ALPHA-P)
+                                                        CHAR)
+                                                       ((EQ INDEX END)
+                                                        STRING)
+                                                  (SETQ CHAR (LISP:CHAR STRING INDEX))
+                                                  (SETQ ALPHA-P (LISP:ALPHANUMERICP CHAR))
+                                                  (LISP:SETF (LISP:CHAR STRING INDEX)
+                                                         (LISP:IF (AND ALPHA-P (NOT WAS-ALPHA-P))
+                                                             (LISP:CHAR-UPCASE CHAR)
+                                                             (LISP:CHAR-DOWNCASE CHAR))))])
+
+(LISP:DEFUN LISP:NSTRING-DOWNCASE (STRING &KEY START END)
+   "Given a string, returns that string with all uppercase alphabetic characters converted to lowercase."
+   (WITH-ONE-STRING-ONLY STRING START END (%%STRING-DOWNCASE STRING START END)))
+
+(LISP:DEFUN LISP:NSTRING-UPCASE (STRING &KEY START END)
+   "Given a string, returns that string with all lower case alphabetic characters converted to uppercase."
+   (WITH-ONE-STRING-ONLY STRING START END (%%STRING-UPCASE STRING START END)))
+
+(LISP:DEFUN STRING (X)
+   "Coerces X into a string. If X is a string, X is returned. If X is a symbol, X's pname is returned. If X is a character then a one element string containing that character is returned. If X cannot be coerced into a string, an error occurs."
+   (LISP:TYPECASE X
+       (STRING X)
+       (LISP:SYMBOL (LISP:SYMBOL-NAME X))
+       (LISP:CHARACTER (LISP:MAKE-STRING 1 :INITIAL-ELEMENT X))
+       (LISP:OTHERWISE (LISP:ERROR "~S cannot be coerced into a string" X))))
+
+(LISP:DEFUN LISP:STRING-CAPITALIZE (STRING &KEY START END)
+   "Given a string, returns a new string that is a copy of it with the first letter of every word in uppercase and all other letters in lowercase. A word is defined to be a sequence of alphanumeric characters delimited by non-alphanumeric characters"
+   (WITH-ONE-STRING STRING START END (LET ((NEW-STRING (LISP:MAKE-STRING SLEN)))
+                                              (LISP:DOTIMES (INDEX START)
+                                                  (LISP:SETF (LISP:SCHAR NEW-STRING INDEX)
+                                                         (LISP:CHAR STRING INDEX)))
+                                              (LISP:DO ((INDEX START (LISP:1+ INDEX))
+                                                        (ALPHA-P NIL)
+                                                        (WAS-ALPHA-P NIL ALPHA-P)
+                                                        CHAR)
+                                                       ((EQ INDEX END))
+                                                  (SETQ CHAR (LISP:CHAR STRING INDEX))
+                                                  (SETQ ALPHA-P (LISP:ALPHANUMERICP CHAR))
+                                                  (LISP:SETF (LISP:SCHAR NEW-STRING INDEX)
+                                                         (LISP:IF (AND ALPHA-P (NOT WAS-ALPHA-P))
+                                                             (LISP:CHAR-UPCASE CHAR)
+                                                             (LISP:CHAR-DOWNCASE CHAR))))
+                                              (LISP:DO ((INDEX END (LISP:1+ INDEX)))
+                                                       ((EQ INDEX SLEN))
+                                                  (LISP:SETF (LISP:SCHAR NEW-STRING INDEX)
+                                                         (LISP:CHAR STRING INDEX)))
+                                              NEW-STRING)))
+
+(LISP:DEFUN LISP:STRING-DOWNCASE (STRING &KEY START END)
+   "Given a string, returns a new string that is a copy of it with all uppercase case alphabetic characters converted to lowercase."
+   (WITH-ONE-STRING STRING START END (%%STRING-DOWNCASE (COPY-VECTOR STRING (
+                                                                                   LISP:MAKE-STRING
+                                                                                     SLEN))
+                                                START END)))
+
+(LISP:DEFUN STRING-EQUAL (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "Compare two strings for case insensitive equality"
+   (LISP:IF (OR START1 END1 START2 END2)
+       [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2
+              (LISP:IF (EQ SLEN1 SLEN2)
+                  (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2
+                         (EQ END1 (%%STRING-BASE-COMPARE-EQUAL BASE1 TYPENUMBER1 BASE2 
+                                         TYPENUMBER2 START1 END1 START2 END2))))]
+       (LISP::SIMPLE-STRING-EQUAL STRING1 STRING2)))
+
+(LISP:DEFUN LISP:STRING-GREATERP (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "Case insensitive version of STRING>"
+   [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2
+                 (LET* ((INDEX (%%STRING-BASE-COMPARE-EQUAL BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
+                                      START1 END1 START2 END2))
+                        (REL-INDEX (- INDEX START1)))
+                       (COND
+                          ((EQ REL-INDEX SLEN2)
+                           (LISP:IF (> SLEN1 SLEN2)
+                                  (- INDEX OFFSET1)))
+                          ((EQ INDEX END1)
+                           NIL)
+                          ((LISP:CHAR-GREATERP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
+                           (- INDEX OFFSET1])
+
+(LISP:DEFUN LISP:STRING-LEFT-TRIM (CHAR-BAG STRING)
+   "Trim only on left"
+   (WITH-STRING STRING (LET [(LEFT-END (LISP:DO ((INDEX 0 (LISP:1+ INDEX)))
+                                                    ((OR (EQ INDEX SLEN)
+                                                         (NOT (LISP:FIND (LISP:CHAR STRING INDEX)
+                                                                     CHAR-BAG)))
+                                                     INDEX))]
+                                (LISP:SUBSEQ STRING LEFT-END SLEN))))
+
+(LISP:DEFUN LISP:STRING-LESSP (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "Case insensitive version of STRING<"
+   [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2
+                 (LET* ((INDEX (%%STRING-BASE-COMPARE-EQUAL BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
+                                      START1 END1 START2 END2))
+                        (REL-INDEX (- INDEX START1)))
+                       (COND
+                          ((EQ INDEX END1)
+                           (LISP:IF (< SLEN1 SLEN2)
+                                  (- INDEX OFFSET1)))
+                          ((EQ (- INDEX START1)
+                               SLEN2)
+                           NIL)
+                          ((LISP:CHAR-LESSP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
+                           (- INDEX OFFSET1])
+
+(LISP:DEFUN LISP:STRING-NOT-EQUAL (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "Compare two string for case insensitive equality"
+   [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2
+                 (LET ((INDEX (%%STRING-BASE-COMPARE-EQUAL BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
+                                     START1 END1 START2 END2)))
+                      (LISP:IF (AND (EQ INDEX END1)
+                                    (EQ SLEN1 SLEN2))
+                          NIL
+                          (- INDEX OFFSET1))])
+
+(LISP:DEFUN LISP:STRING-NOT-GREATERP (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "Case insensitive version of STRING<="
+   [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2
+                 (LET* ((INDEX (%%STRING-BASE-COMPARE-EQUAL BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
+                                      START1 END1 START2 END2))
+                        (REL-INDEX (- INDEX START1)))
+                       (COND
+                          ((EQ INDEX END1)
+                           (- INDEX OFFSET1))
+                          ((EQ (- INDEX START1)
+                               SLEN2)
+                           NIL)
+                          ((LISP:CHAR-NOT-GREATERP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
+                           (- INDEX OFFSET1])
+
+(LISP:DEFUN LISP:STRING-NOT-LESSP (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "Case insensitive version of STRING>="
+   [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2
+                 (LET* ((INDEX (%%STRING-BASE-COMPARE-EQUAL BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
+                                      START1 END1 START2 END2))
+                        (REL-INDEX (- INDEX START1)))
+                       (COND
+                          ((EQ REL-INDEX SLEN2)
+                           (- INDEX OFFSET1))
+                          ((EQ INDEX END1)
+                           NIL)
+                          ((LISP:CHAR-NOT-LESSP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
+                           (- INDEX OFFSET1])
+
+(LISP:DEFUN LISP:STRING-RIGHT-TRIM (CHAR-BAG STRING)
+   "Trim only on right"
+   (WITH-STRING STRING (LET [(RIGHT-END (LISP:DO ((INDEX (LISP:1- SLEN)
+                                                             (LISP:1- INDEX)))
+                                                     ((OR (< INDEX 0)
+                                                          (NOT (LISP:FIND (LISP:CHAR STRING INDEX)
+                                                                      CHAR-BAG)))
+                                                      (LISP:1+ INDEX)))]
+                                (LISP:SUBSEQ STRING 0 RIGHT-END))))
+
+(LISP:DEFUN LISP:STRING-TRIM (CHAR-BAG STRING)
+
+   (* ;; "Given a set of characters (a list or string) and a string, returns a copy of the string with the characters in the set removed from both ends.")
+
+   (WITH-STRING STRING (LET* [(LEFT-END (LISP:DO ((INDEX 0 (LISP:1+ INDEX)))
+                                                     ((OR (EQ INDEX SLEN)
+                                                          (NOT (LISP:FIND (LISP:CHAR STRING INDEX)
+                                                                      CHAR-BAG)))
+                                                      INDEX)))
+                                  (RIGHT-END (LISP:DO ((INDEX (LISP:1- SLEN)
+                                                              (LISP:1- INDEX)))
+                                                      ((OR (< INDEX LEFT-END)
+                                                           (NOT (LISP:FIND (LISP:CHAR STRING INDEX)
+                                                                       CHAR-BAG)))
+                                                       (LISP:1+ INDEX)))]
+                                 (LISP:SUBSEQ STRING LEFT-END RIGHT-END))))
+
+(LISP:DEFUN LISP:STRING-UPCASE (STRING &KEY START END)
+   "Given a string, returns a new string that is a copy of it with all lower case alphabetic characters converted to uppercase."
+   (WITH-ONE-STRING STRING START END (%%STRING-UPCASE (COPY-VECTOR STRING (LISP:MAKE-STRING
+                                                                                   SLEN))
+                                                START END)))
+
+(LISP:DEFUN LISP:STRING/= (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "Compare two strings for case sensitive inequality"
+   [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2
+                 (LET ((INDEX (%%STRING-BASE-COMPARE BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 
+                                     END1 START2 END2)))
+                      (LISP:IF (AND (EQ INDEX END1)
+                                    (EQ SLEN1 SLEN2))
+                          NIL
+                          (- INDEX OFFSET1))])
+
+(LISP:DEFUN LISP:STRING< (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "A string A is less than a string B if in the first position in which they differ the character of A is less than the corresponding character of B according to char< or if string A is a proper prefix of string B (of shorter length and matching in all the characters of A). Returns either NIL or an index into STRING1"
+   [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2
+                 (LET* ((INDEX (%%STRING-BASE-COMPARE BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1
+                                      END1 START2 END2))
+                        (REL-INDEX (- INDEX START1)))
+                       (COND
+                          ((EQ INDEX END1)
+                           (LISP:IF (< SLEN1 SLEN2)
+                                  (- INDEX OFFSET1)))
+                          ((EQ (- INDEX START1)
+                               SLEN2)
+                           NIL)
+                          ((LISP:CHAR< (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
+                           (- INDEX OFFSET1])
+
+(LISP:DEFUN LISP:STRING<= (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2
+                 (LET* ((INDEX (%%STRING-BASE-COMPARE BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1
+                                      END1 START2 END2))
+                        (REL-INDEX (- INDEX START1)))
+                       (COND
+                          ((EQ INDEX END1)
+                           (- INDEX OFFSET1))
+                          ((EQ (- INDEX START1)
+                               SLEN2)
+                           NIL)
+                          ((LISP:CHAR<= (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
+                           (- INDEX OFFSET1])
+
+(LISP:DEFUN LISP:STRING= (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "Compare two strings for case sensitive equality"
+   (LISP:IF (OR START1 END1 START2 END2)
+       [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2
+              (LISP:IF (EQ SLEN1 SLEN2)
+                  (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2
+                         (EQ END1 (%%STRING-BASE-COMPARE BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
+                                         START1 END1 START2 END2))))]
+       (LISP::SIMPLE-STRING= STRING1 STRING2)))
+
+(LISP:DEFUN LISP:STRING> (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2
+                 (LET* ((INDEX (%%STRING-BASE-COMPARE BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1
+                                      END1 START2 END2))
+                        (REL-INDEX (- INDEX START1)))
+                       (COND
+                          ((EQ REL-INDEX SLEN2)
+                           (LISP:IF (> SLEN1 SLEN2)
+                                  (- INDEX OFFSET1)))
+                          ((EQ INDEX END1)
+                           NIL)
+                          ((LISP:CHAR> (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
+                           (- INDEX OFFSET1])
+
+(LISP:DEFUN LISP:STRING>= (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2
+                 (LET* ((INDEX (%%STRING-BASE-COMPARE BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1
+                                      END1 START2 END2))
+                        (REL-INDEX (- INDEX START1)))
+                       (COND
+                          ((EQ REL-INDEX SLEN2)
+                           (- INDEX OFFSET1))
+                          ((EQ INDEX END1)
+                           NIL)
+                          ((LISP:CHAR>= (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
+                           (- INDEX OFFSET1])
+
+(DEFOPTIMIZER LISP:STRING= (STRING1 STRING2 &REST OPTIONS)
+                               (LISP:IF OPTIONS
+                                   'COMPILER:PASS
+                                   `(LISP::SIMPLE-STRING= ,STRING1 ,STRING2)))
+
+(DEFOPTIMIZER STRING-EQUAL (STRING1 STRING2 &REST OPTIONS)
+                               (LISP:IF OPTIONS
+                                   'COMPILER:PASS
+                                   `(LISP::SIMPLE-STRING-EQUAL ,STRING1 ,STRING2)))
+
+
+
+(* ;; "Internal macros  ")
+
+(DECLARE%: DONTCOPY DOEVAL@COMPILE 
+
+(DEFMACRO WITH-ONE-STRING (STRING START END &REST FORMS)
+   "WITH-ONE-STRING is used to set up string operations. The keywords are parsed, and STRING is coerced into a string. SLEN is bound to the string length"
+   `(LET [(SLEN (VECTOR-LENGTH (SETQ ,STRING (STRING ,STRING]
+         (%%CHECK-BOUNDS ,START ,END SLEN)
+         ,@FORMS))
+
+(DEFMACRO WITH-ONE-STRING-ONLY (STRING START END &REST FORMS)
+
+   (* ;; "Like WITH-ONE-STRING but only strings allowed")
+
+   `(PROGN (LISP:IF (NOT (LISP:STRINGP ,STRING))
+               (LISP:ERROR 'CONDITIONS:SIMPLE-TYPE-ERROR :EXPECTED-TYPE 'STRING :CULPRIT ,STRING))
+           (LET [(SLEN (VECTOR-LENGTH ,STRING]
+                (%%CHECK-BOUNDS ,START ,END SLEN)
+                ,@FORMS)))
+
+(DEFMACRO WITH-STRING (STRING &REST FORMS)
+
+   (* ;; "WITH-STRING is like WITH-ONE-STRING, but doesn't process keywords")
+
+   `(LET [(SLEN (VECTOR-LENGTH (SETQ ,STRING (STRING ,STRING]
+         ,@FORMS))
+
+(DEFMACRO WITH-TWO-UNPACKED-STRINGS (STRING1 STRING2 START1 END1 START2 END2 &REST FORMS)
+
+   (* ;; "Used to set up string comparison operations. String1 and string2 are unpacked and start1, end1, start2, end2 are adjusted for non-zero offsets. Base1 and base2, typenumber1, typenumber2 , offset1 and offset2 are bound to the appropriate unpacked quantities")
+
+   `(LET (BASE1 BASE2 OFFSET1 OFFSET2 TYPENUMBER1 TYPENUMBER2)
+         (%%UNPACK-STRING ,STRING1 BASE1 OFFSET1 TYPENUMBER1)
+         (%%UNPACK-STRING ,STRING2 BASE2 OFFSET2 TYPENUMBER2)
+         (%%ADJUST-FOR-OFFSET ,START1 ,END1 OFFSET1)
+         (%%ADJUST-FOR-OFFSET ,START2 ,END2 OFFSET2)
+         ,@FORMS))
+
+(DEFMACRO %%UNPACK-STRING (OBJECT BASE OFFSET TYPENUMBER &OPTIONAL LENGTH)
+   `[COND
+       [(LISP:SYMBOLP ,OBJECT)
+        (SETQ ,BASE (fetch (LITATOM PNAMEBASE) of ,OBJECT))
+        (SETQ ,OFFSET 1)
+        (SETQ ,TYPENUMBER (LISP:IF (fetch (LITATOM FATPNAMEP) of ,OBJECT)
+                              %%FAT-CHAR-TYPENUMBER
+                              %%THIN-CHAR-TYPENUMBER))
+        ,@(LISP:IF LENGTH
+              `[(SETQ ,LENGTH (fetch (LITATOM PNAMELENGTH) of ,OBJECT])]
+       (T [COND
+             [(%%ONED-ARRAY-P ,OBJECT)
+              (SETQ ,BASE (fetch (ARRAY-HEADER BASE) of ,OBJECT))
+              (SETQ ,OFFSET (fetch (ARRAY-HEADER OFFSET) of ,OBJECT))
+              (SETQ ,TYPENUMBER (fetch (ARRAY-HEADER TYPE-NUMBER) of ,OBJECT]
+             (T (SETQ ,BASE (%%ARRAY-BASE ,OBJECT))
+                (SETQ ,OFFSET (%%ARRAY-OFFSET ,OBJECT))
+                (SETQ ,TYPENUMBER (%%ARRAY-TYPE-NUMBER ,OBJECT]
+          ,@(LISP:IF LENGTH
+                `[(SETQ ,LENGTH (fetch (ARRAY-HEADER FILL-POINTER) of ,OBJECT])])
+
+(DEFMACRO %%ADJUST-FOR-OFFSET (START END OFFSET)
+   `(LISP:WHEN (NOT (EQ 0 ,OFFSET))
+        (SETQ ,START (+ ,START ,OFFSET))
+        (SETQ ,END (+ ,END ,OFFSET))))
+
+(DEFMACRO %%CHECK-BOUNDS (START END LENGTH)
+   `[PROGN [COND
+              ((NULL ,END)
+               (SETQ ,END ,LENGTH))
+              ((> ,END ,LENGTH)
+               (LISP:ERROR "End out of bounds: ~S" ,END]
+           (COND
+              ((NULL ,START)
+               (SETQ ,START 0))
+              ((NOT (<= 0 ,START ,END))
+               (LISP:ERROR "Improper substring bounds: ~s ~s" ,START ,END])
+
+(DEFMACRO %%PARSE-STRING-ARGS (STRING1 STRING2 START1 END1 START2 END2 &REST FORMS)
+
+   (* ;; "Used to set up string comparison operations. The keywords are defaulted, bounds are checked and  Slen1 and Slen1 are bound to substring lengths%"")
+
+   `(LET [(SLEN1 (%%STRING-LENGTH ,STRING1))
+          (SLEN2 (%%STRING-LENGTH ,STRING2]
+         (%%CHECK-BOUNDS ,START1 ,END1 SLEN1)
+         (%%CHECK-BOUNDS ,START2 ,END2 SLEN2)
+         (SETQ SLEN1 (- ,END1 ,START1))
+         (SETQ SLEN2 (- ,END2 ,START2))
+         ,@FORMS))
+
+(DEFMACRO %%STRING-LENGTH (STRING)
+   `(COND
+       ((%%STRINGP ,STRING)
+        (fetch (ARRAY-HEADER FILL-POINTER) of ,STRING))
+       ((LISP:SYMBOLP ,STRING)
+        (fetch (LITATOM PNAMELENGTH) of ,STRING))
+       [(LISP:CHARACTERP ,STRING)
+        (VECTOR-LENGTH (SETQ ,STRING (STRING ,STRING]
+       (T (LISP:ERROR 'XCL:TYPE-MISMATCH :EXPECTED-TYPE '(OR STRING LISP:SYMBOL LISP:CHARACTER)
+                 :NAME
+                 ,STRING :VALUE ,STRING :MESSAGE "a string, symbol or character"))))
+)
+
+
+
+(* ;; "Compiler options")
+
+
+(PUTPROPS CMLSTRING FILETYPE LISP:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(PUTPROPS CMLSTRING COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1991 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/CLTL2/CMLSTRING.LCOM b/CLTL2/CMLSTRING.LCOM
new file mode 100644
index 00000000..ce68294f
Binary files /dev/null and b/CLTL2/CMLSTRING.LCOM differ
diff --git a/CLTL2/CMLTIME b/CLTL2/CMLTIME
new file mode 100644
index 00000000..915f075d
--- /dev/null
+++ b/CLTL2/CMLTIME
@@ -0,0 +1,280 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+(FILECREATED "18-Oct-93 15:20:26" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLTIME.;2" 15445  
+
+      |previous| |date:| " 3-Sep-91 17:50:39" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLTIME.;1")
+
+
+; Copyright (c) 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT CMLTIMECOMS)
+
+(RPAQQ CMLTIMECOMS
+       (
+
+(* |;;;| "Common Lisp Time Functions")
+
+        (FUNCTIONS %CONVERT-INTERNAL-TIME-TO-CLUT)
+        (CONSTANTS (LISP:INTERNAL-TIME-UNITS-PER-SECOND 1000))
+        (FNS LISP:GET-INTERNAL-REAL-TIME LISP:GET-INTERNAL-RUN-TIME LISP:GET-UNIVERSAL-TIME 
+             LISP:GET-DECODED-TIME LISP:DECODE-UNIVERSAL-TIME LISP:ENCODE-UNIVERSAL-TIME LISP:SLEEP)
+        (PROP FILETYPE CMLTIME)
+        (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML)
+                      (LAMA LISP:SLEEP LISP:ENCODE-UNIVERSAL-TIME LISP:DECODE-UNIVERSAL-TIME 
+                            LISP:GET-DECODED-TIME LISP:GET-UNIVERSAL-TIME LISP:GET-INTERNAL-RUN-TIME)
+                      ))))
+
+
+
+(* |;;;| "Common Lisp Time Functions")
+
+
+(DEFMACRO %CONVERT-INTERNAL-TIME-TO-CLUT (TIME)
+
+   (* |;;| "Converts from Interlisp-D internal time format to Common Lisp Universal Time")
+
+   `(+ ,TIME (LISP:* 365 24 60 60)
+       MAX.FIXP 1))
+(DECLARE\: EVAL@COMPILE 
+
+(RPAQQ LISP:INTERNAL-TIME-UNITS-PER-SECOND 1000)
+
+
+(CONSTANTS (LISP:INTERNAL-TIME-UNITS-PER-SECOND 1000))
+)
+(DEFINEQ
+
+(LISP:GET-INTERNAL-REAL-TIME
+  (LAMBDA NIL                                              (* |hdj| "18-Jul-86 12:05")
+
+(* |;;;| "The current time is returned as a single integer in Internal Time format.  (Internal Time format = time in milliseconds for us.) This time is relative to an arbitrary time base, but the difference between the values of two calls to this function will be the amount of elapsed real time between the two calls, measured in the units defined by INTERNAL-TIME-UNITS-PER-SECOND")
+
+    (CLOCK 0)))
+
+(LISP:GET-INTERNAL-RUN-TIME
+  (LISP:LAMBDA NIL                                         (* |hdj| "18-Jul-86 12:06")
+
+(* |;;;| "The current run time is returned as a single integer in Internal Time format.  (Internal Time format = time in milliseconds for us.) The precise meaning of this quantity is implementation-dependent;  it may measure real time, run time, CPU cycles, or some other quantity.  The intent is that the difference between the values of two calls to this function be the amount of time between the two calls during which the computational effort was expended on behalf of the executing program.")
+
+         (CLOCK 2)))
+
+(LISP:GET-UNIVERSAL-TIME
+  (LISP:LAMBDA NIL                                         (* |hdj| "18-Jul-86 12:02")
+
+(* |;;;| "The current time of day is returned as a single integer in Universal Time format.")
+
+         (%CONVERT-INTERNAL-TIME-TO-CLUT (DAYTIME))))
+
+(LISP:GET-DECODED-TIME
+  (LISP:LAMBDA NIL                                         (* |hdj| "18-Jul-86 12:08")
+
+(* |;;;| "The current time is returned in Decoded Time format.  Nine values are returned: SECOND, MINUTE, HOUR, DATE, MONTH, YEAR, DAY-OF-WEEK, DAYLIGHT-SAVING-TIME-P, and TIME-ZONE.")
+
+         (LISP:DECODE-UNIVERSAL-TIME (LISP:GET-UNIVERSAL-TIME))))
+
+(LISP:DECODE-UNIVERSAL-TIME
+  (LISP:LAMBDA (UNIVERSAL-TIME &OPTIONAL (TIME-ZONE |\\TimeZoneComp| TIME-ZONE-SUPPLIEDP))
+                                                             (* |kbr:| " 7-Aug-86 10:21")
+
+(* |;;;| "The time specified by UNIVERSAL-TIME in Universal Time format is converted to Decoded Time format.  Nine values are returned: SECOND, MINUTE, HOUR, DATE, MONTH, YEAR, DAY-OF-WEEK, DAYLIGHT-SAVING-TIME-P, and TIME-ZONE.")
+
+         (PROG (CHECKDLS TIME MONTH SEC HR TOTALDAYS DAYS LEAP400 LEAP100 LEAP4 YEAR YDAY WDAY MIN 
+                      DLS)
+
+          (* |;;| "Page 446 of the silver book: If you don't specify TIME-ZONE it defaults to the current time zone adjusted for daylight savings time.  If you provide TIME-ZONE explicitly, no adjustment for daylight savings time is is performed.")
+
+               (SETQ CHECKDLS (AND (NOT TIME-ZONE-SUPPLIEDP)
+                                   |\\DayLightSavings|))
+               (LISP:MULTIPLE-VALUE-SETQ (TIME SEC)
+                      (LISP:FLOOR UNIVERSAL-TIME 60))
+               (LISP:MULTIPLE-VALUE-SETQ (TIME MIN)
+                      (LISP:FLOOR TIME 60))
+               (LISP:MULTIPLE-VALUE-SETQ (TOTALDAYS HR)
+                      (LISP:FLOOR (- TIME TIME-ZONE)
+                             24))
+           DTLOOP
+               
+
+          (* |;;| "LEAP400 = number of 400 year blocks till Jan 1, 2000 Note: The algorithm still works correctly for dates after Jan 1, 2000 .  LEAP400 will be negative but not wrong.  (Any Jan 1 a year a multiple of 400 would do nicely.  Jan 1, 2000 just happens to be close by.)")
+
+               (LISP:MULTIPLE-VALUE-SETQ (LEAP400 DAYS)
+                      (LISP:FLOOR (- 36524 TOTALDAYS)
+                             (+ 36525 (LISP:* 3 36524))))    (* \; 
+                                    "LEAP100 = number of 100 year blocks till the 400 year blocks.")
+               (LISP:MULTIPLE-VALUE-SETQ (LEAP100 DAYS)
+                      (LISP:FLOOR DAYS 36524))               (* \; 
+                                        "LEAP4 = number of 4 year blocks till the 100 year blocks.")
+               (LISP:MULTIPLE-VALUE-SETQ (LEAP4 DAYS)
+                      (LISP:FLOOR DAYS (+ 366 (LISP:* 3 365))))
+
+          (* |;;| "Date of answer will be (+ (* 146097 LEAP400) (* 36524 LEAP100) (* 1461 LEAP4) DAYS) days before Jan 1, 2000")
+
+               (SETQ YEAR (- 2000 (LISP:* 400 LEAP400)
+                             (LISP:* 100 LEAP100)
+                             (LISP:* 4 LEAP4)
+                             (CDR (\\DTSCAN DAYS '((1096 . 4)
+                                                   (731 . 3)
+                                                   (366 . 2)
+                                                   (1 . 1)
+                                                   (0 . 0))))))
+
+          (* |;;| "YDAY is the ordinal of day as it would appear in a leap year.  We thus have Jan 1 = day 0, Feb 29 = day 59, Mar 1 = day 60, and Dec 31 = day 365.")
+
+               (SETQ YDAY (- (CDR (\\DTSCAN DAYS (COND
+                                                    ((AND (EQ (LISP:MOD YEAR 100)
+                                                              0)
+                                                          (NOT (EQ (LISP:MOD YEAR 400)
+                                                                   0)))
+                                                     '((1402 . 1460)
+                                                       (1096 . 1461)
+                                                       (1037 . 1095)
+                                                       (731 . 1096)
+                                                       (672 . 730)
+                                                       (366 . 731)
+                                                       (307 . 365)
+                                                       (1 . 366)
+                                                       (0 . 0)))
+                                                    (T '((1096 . 1461)
+                                                         (1037 . 1095)
+                                                         (731 . 1096)
+                                                         (672 . 730)
+                                                         (366 . 731)
+                                                         (307 . 365)
+                                                         (1 . 366)
+                                                         (0 . 0))))))
+                             DAYS))
+               (SETQ WDAY (LISP:MOD TOTALDAYS 7))
+               (COND
+                  ((AND CHECKDLS (SETQ DLS (\\ISDST? YDAY HR WDAY)))
+
+                   (* |;;| "This date is during daylight savings, so add 1 hour.  Third arg is day of the week, which we determine by taking days mod 7 plus offset.  Monday = zero in this scheme.  Jan 1 1900 was a Monday=0 so offset is 0")
+
+                   (COND
+                      ((> (SETQ HR (LISP:1+ HR))
+                          23)
+
+                       (* |;;| "overflowed into the next day.  This case is too hard (we might have overflowed the month, for example), so just go back and recompute")
+
+                       (SETQ TOTALDAYS (LISP:1+ TOTALDAYS))
+                       (SETQ HR 0)
+                       (SETQ CHECKDLS NIL)
+                       (GO DTLOOP)))))
+               (SETQ MONTH (\\DTSCAN YDAY '((335 . 12)
+                                            (305 . 11)
+                                            (274 . 10)
+                                            (244 . 9)
+                                            (213 . 8)
+                                            (182 . 7)
+                                            (152 . 6)
+                                            (121 . 5)
+                                            (91 . 4)
+                                            (60 . 3)
+                                            (31 . 2)
+                                            (0 . 1))))       (* \; 
+                             "Now return (SECOND MINUTE HOUR DAY MONTH YEAR WEEKDAY DAYLIGHT ZONE)")
+               (RETURN (LISP:VALUES SEC MIN HR (LISP:1+ (- YDAY (CAR MONTH)))
+                              (CDR MONTH)
+                              YEAR WDAY DLS TIME-ZONE)))))
+
+(LISP:ENCODE-UNIVERSAL-TIME
+  (LISP:LAMBDA (SECOND MINUTE HOUR DATE MONTH YEAR &OPTIONAL TIME-ZONE)
+                                                             (* \; "Edited 27-Oct-87 19:11 by bvm:")
+
+(* |;;;| "The time specified by the given components of Decoded Time format is encoded into Universal Time format and returned.  If you don't specify TIME-ZONE, it defaults to the current time zone adjusted for daylight saving time.  If you provide TIME-ZONE explicitly, no adjustment for daylight saving time is performed.")
+
+         (PROG (YDAY DAYSSINCEDAY0)
+
+          (* |;;| "From pages 444 and 445 of the silver book and Lucid testing, here are three examples of ENCODE-UNIVERSAL-TIME usage known to be correct and which should be rechecked by anyone who edits this function: (ENCODE-UNIVERSAL-TIME 1 0 0 1 1 1900 0) = 1 (ENCODE-UNIVERSAL-TIME 1 0 0 1 1 1976 0) = 2398291201 (ENCODE-UNIVERSAL-TIME 0 0 0 1 1 3000 0) = 34712668800")
+
+          (* |;;| 
+        "If the YEAR is between 0 and 99 we have to figure out what the `obvious' year is.")
+
+               (SETQ YEAR (LISP:IF (< YEAR 100)
+                              (LISP:MULTIPLE-VALUE-BIND
+                               (SEC MIN HOUR DAY MONTH NOW-YEAR)
+                               (LISP:GET-DECODED-TIME)
+                               (DECLARE (IGNORE SEC MIN HOUR DAY MONTH))
+                               (LISP:DO ((Y (+ YEAR (LISP:* 100 (LISP:1- (LISP:TRUNCATE NOW-YEAR 100)
+                                                                       )))
+                                            (+ Y 100)))
+                                        ((<= (ABS (- Y NOW-YEAR))
+                                             50)
+                                         Y)))
+                              YEAR))
+               (SETQ YDAY (+ (SELECTQ MONTH
+                                 (1 0)
+                                 (2 31)
+                                 (3 59)
+                                 (4 90)
+                                 (5 120)
+                                 (6 151)
+                                 (7 181)
+                                 (8 212)
+                                 (9 243)
+                                 (10 273)
+                                 (11 304)
+                                 (12 334)
+                                 NIL)
+                             (SUB1 DATE)))
+               (SETQ DAYSSINCEDAY0 (+ YDAY (TIMES 365 (SETQ YEAR (IDIFFERENCE YEAR 1900)))
+                                      (IQUOTIENT (SUB1 YEAR)
+                                             4)))
+               (|if| (> MONTH 2)
+                   |then|                                (* \; "After February 28")
+                         (|add| YDAY 1)                  (* \; 
+                                                           "Day-of-year is based on 366-day year")
+                         (|if| (AND (EQ 0 (IREMAINDER YEAR 4))
+                                        (OR (NOT (EQ (IREMAINDER YEAR 100)
+                                                     0))
+                                            (EQ (IREMAINDER YEAR 400)
+                                                0)))
+                             |then|                      (* \; 
+                                            "It is a leap year, so real day count also incremented")
+                                   (|add| DAYSSINCEDAY0 1)))
+
+          (* |;;| "This is almost right - now correct for 100/400 leap year rule. 1900 is magically handled by above formula, and 2000 is a leap year, so we only need to do this for years after 2100.")
+
+               (FOR I FROM 200 TO YEAR BY 100
+                  UNLESS (OR (= I YEAR)
+                                 (EQ (IREMAINDER I 400)
+                                     100)) DO (LISP:DECF DAYSSINCEDAY0))
+               (SETQ HOUR (+ HOUR (TIMES 24 DAYSSINCEDAY0)
+                             (COND
+                                (TIME-ZONE TIME-ZONE)
+                                ((AND |\\DayLightSavings| (\\ISDST? YDAY HOUR (IREMAINDER 
+                                                                                     DAYSSINCEDAY0 7)
+                                                                 ))
+
+                                 (* |;;| "Subtract one to go from daylight to standard time.  Weekday argument (IREMAINDER DAYSSINCEDAY0 7) to \\ISDST?  is based on day 0 = Jan 1, 1900, which was a Monday = 0")
+
+                                 (SUB1 |\\TimeZoneComp|))
+                                (T |\\TimeZoneComp|))))
+               (RETURN (+ SECOND (TIMES 60 (+ MINUTE (TIMES 60 HOUR))))))))
+
+(LISP:SLEEP
+  (LISP:LAMBDA (LISP::SECONDS)                               (* \; "Edited 24-Apr-87 15:28 by jrb:")
+
+(* |;;;| "(SLEEP N) causes execution to cease and become dormant for approximately N seconds of real time, whereupon execution is resumed.  The argument may be any non-negative non-complex number.  SLEEP returns NIL.")
+
+         (DISMISS (ROUND (LISP:* LISP::SECONDS 1000)))
+         NIL))
+)
+
+(PUTPROPS CMLTIME FILETYPE LISP:COMPILE-FILE)
+(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA LISP:SLEEP LISP:ENCODE-UNIVERSAL-TIME LISP:DECODE-UNIVERSAL-TIME 
+                         LISP:GET-DECODED-TIME LISP:GET-UNIVERSAL-TIME LISP:GET-INTERNAL-RUN-TIME)
+)
+(PUTPROPS CMLTIME COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1993))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (1558 14987 (LISP:GET-INTERNAL-REAL-TIME 1568 . 2100) (LISP:GET-INTERNAL-RUN-TIME 2102
+ . 2752) (LISP:GET-UNIVERSAL-TIME 2754 . 3033) (LISP:GET-DECODED-TIME 3035 . 3419) (
+LISP:DECODE-UNIVERSAL-TIME 3421 . 9799) (LISP:ENCODE-UNIVERSAL-TIME 9801 . 14566) (LISP:SLEEP 14568 . 
+14985)))))
+STOP
diff --git a/CLTL2/CMLTIME.LCOM b/CLTL2/CMLTIME.LCOM
new file mode 100644
index 00000000..248c4ac5
Binary files /dev/null and b/CLTL2/CMLTIME.LCOM differ
diff --git a/CLTL2/CMLTYPES b/CLTL2/CMLTYPES
new file mode 100644
index 00000000..df088b2c
--- /dev/null
+++ b/CLTL2/CMLTYPES
@@ -0,0 +1,376 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
+(IL:FILECREATED " 8-Feb-93 16:55:40" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLTYPES.;9| 46967  
+
+      IL:|changes| IL:|to:|  (IL:TYPES ARRAY SIMPLE-ARRAY)
+
+      IL:|previous| IL:|date:| " 1-Apr-92 12:17:57" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>CMLTYPES.;8|)
+
+
+; Copyright (c) 1985, 1986, 1987, 1988, 1990, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CMLTYPESCOMS)
+
+(IL:RPAQQ IL:CMLTYPESCOMS ((IL:* IL:|;;;| "Implementation of Common Lisp type system.  ") (IL:* IL:|;;;| "implementation by Greg Nuyens ,Larry Masinter and Jan Pedersen.") (IL:* IL:|;;;| "Predicates") (IL:FUNCTIONS COMMONP) (IL:* IL:|;;;| "Typep and friends") (IL:VARIABLES *TYPEP-HASH-TABLE*) (IL:FUNCTIONS TYPEP TYPE-OF COERCE TYPECASE) (IL:FUNCTIONS %VALID-TYPE-P) (XCL:OPTIMIZERS TYPEP COERCE) (IL:* IL:|;;;| "for DEFTYPE") (IL:DEFINE-TYPES IL:TYPES) (IL:FUNCTIONS DEFTYPE TYPE-EXPAND TYPE-EXPANDER SETF-TYPE-EXPANDER) (IL:SETFS TYPE-EXPANDER) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:* IL:|;;| "There is still code out there that calls the IL: versions") (IL:P (IL:MOVD (QUOTE TYPE-EXPAND) (QUOTE IL:TYPE-EXPAND)) (IL:MOVD (QUOTE TYPE-EXPANDER) (QUOTE IL:TYPE-EXPANDER)))) (IL:* IL:|;;;| "Support functions") (IL:FUNCTIONS ARRAY-TYPE SYMBOL-TYPE XCL:FALSE XCL:TRUE %RANGE-TYPE) (IL:FUNCTIONS NUMBERP FLOATP CL:REALP) (XCL:OPTIMIZERS NUMBERP FLOATP CL:REALP XCL:FALSE XCL:TRUE) (IL:* IL:|;;;| "For TYPEP") (IL:FUNCTIONS %TYPEP-PRED BIGNUMP) (IL:* IL:|;;;| "for SUBTYPEP ") (IL:VARIABLES %NO-SUPER-TYPE *COMMON-LISP-BASE-TYPES* *BASE-TYPE-LATTICE*) (IL:FUNCTIONS SUBTYPEP SUBTYPEP-TYPE-EXPAND SI::DATATYPE-P SI::SUB-DATATYPE-P EQUAL-DIMENSIONS COMPLETE-ARRAY-TYPE-DIMENSIONS COMPLETE-META-EXPRESSION-DEFAULTS RANGE<= BASE-SUBTYPEP EQUAL-ELEMENT-TYPE USEFUL-TYPE-EXPANSION-P) (IL:* IL:|;;;| "Basic deftypes") (IL:TYPES ATOM BIGNUM BIT CHARACTER CONS DOUBLE-FLOAT EQL FIXNUM STREAM FLOAT FUNCTION HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT MEMBER MOD NULL NUMBER PACKAGE CL:REAL SHORT-FLOAT SIGNED-BYTE STANDARD-CHAR STRING-CHAR CL:BASE-CHARACTER CL:EXTENDED-CHARACTER SINGLE-FLOAT SYMBOL UNSIGNED-BYTE RATIONAL READTABLE COMMON COMPILED-FUNCTION SEQUENCE) (IL:* IL:|;;;| "Array Types") (IL:TYPES ARRAY VECTOR STRING SIMPLE-STRING SIMPLE-ARRAY SIMPLE-VECTOR BIT-VECTOR SIMPLE-BIT-VECTOR CL:BASE-STRING CL:SIMPLE-BASE-STRING) (IL:* IL:|;;;| "Stream types required by CLtL2") (IL:TYPES CL:BROADCAST-STREAM CL:CONCATENATED-STREAM CL:ECHO-STREAM CL:SYNONYM-STREAM CL:STRING-STREAM CL:FILE-STREAM CL:TWO-WAY-STREAM) (IL:* IL:|;;;| "Fast predicates for typep") (IL:DEFINE-TYPES TYPEP) (IL:FUNCTIONS DEFTYPEP) (TYPEP LIST SEQUENCE MEMBER ARRAY SIMPLE-ARRAY VECTOR SIMPLE-VECTOR COMPLEX INTEGER MOD SIGNED-BYTE UNSIGNED-BYTE RATIONAL FLOAT STRING SIMPLE-STRING BIT-VECTOR SIMPLE-BIT-VECTOR EQL CL:REAL) (IL:* IL:|;;;| "for TYPE-OF Interlisp types that have different common Lisp names") (IL:PROP CMLTYPE IL:CHARACTER IL:FIXP IL:FLOATP IL:GENERAL-ARRAY IL:LISTP IL:LITATOM IL:ONED-ARRAY IL:SMALLP IL:HARRAYP IL:TWOD-ARRAY) (IL:PROP CMLSUBTYPE-DESCRIMINATOR SYMBOL ARRAY) (IL:* IL:|;;;| "tell the filepkg what to do with the type-expander property") (IL:PROP IL:PROPTYPE :TYPE-EXPANDER IL:TYPE-EXPANDER) (IL:* IL:|;;;| "Compiler options") (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLTYPES) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T))))
+
+
+
+(IL:* IL:|;;;| "Implementation of Common Lisp type system.  ")
+
+
+
+
+(IL:* IL:|;;;| "implementation by Greg Nuyens ,Larry Masinter and Jan Pedersen.")
+
+
+
+
+(IL:* IL:|;;;| "Predicates")
+
+
+(DEFUN COMMONP (OBJECT) (TYPEP OBJECT (QUOTE COMMON)))
+
+
+
+(IL:* IL:|;;;| "Typep and friends")
+
+
+(DEFPARAMETER *TYPEP-HASH-TABLE* (MAKE-HASH-TABLE :TEST (QUOTE EQ)))
+
+(DEFUN TYPEP (OBJECT TYPE) (IL:* IL:|;;| "Check if OBJECT is of type TYPE") (LET* ((SYMBOL-TYPE (IF (CONSP TYPE) (CAR TYPE) TYPE)) (FN (GETHASH SYMBOL-TYPE *TYPEP-HASH-TABLE*))) (IF FN (IF (CONSP TYPE) (FUNCALL FN OBJECT (CDR TYPE)) (FUNCALL FN OBJECT)) (IL:* IL:|;;| "Expand the type") (IF (CONSP TYPE) (CASE SYMBOL-TYPE (SATISFIES (FUNCALL (CADR TYPE) OBJECT)) ((:DATATYPE IL:DATATYPE) (IL:TYPENAMEP OBJECT (CADR TYPE))) (NOT (NOT (TYPEP OBJECT (CADR TYPE)))) (AND (DOLIST (SUB-TYPE (CDR TYPE) T) (IF (NOT (TYPEP OBJECT SUB-TYPE)) (RETURN NIL)))) (OR (DOLIST (SUB-TYPE (CDR TYPE) NIL) (IF (TYPEP OBJECT SUB-TYPE) (RETURN T)))) (OTHERWISE (LET ((EXPANDER (TYPE-EXPANDER SYMBOL-TYPE))) (IF EXPANDER (TYPEP OBJECT (FUNCALL EXPANDER TYPE)) (ERROR "Unknown type expression: ~s" TYPE))))) (CASE SYMBOL-TYPE ((T) T) ((NIL) NIL) (OTHERWISE (LET ((EXPANDER (TYPE-EXPANDER SYMBOL-TYPE))) (IF EXPANDER (TYPEP OBJECT (FUNCALL EXPANDER (LIST TYPE))) (ERROR "Unknown type expression: ~s" TYPE)))))))))
+
+(DEFUN TYPE-OF (X) (LET ((TYPENAME (IL:\\INDEXATOMPNAME (IL:|fetch| IL:DTDNAME IL:|of| (IL:\\GETDTD (IL:NTYPX X)))))) (SETQ TYPENAME (OR (GET TYPENAME (QUOTE CMLTYPE)) TYPENAME)) (OR (LET ((D (GET TYPENAME (QUOTE CMLSUBTYPE-DESCRIMINATOR)))) (AND D (FUNCALL D X))) TYPENAME)))
+
+(DEFUN COERCE (OBJECT RESULT-TYPE) (IL:* IL:|;;| "Coerce object to result-type if possible") (IF (TYPEP OBJECT RESULT-TYPE) OBJECT (COND ((EQ RESULT-TYPE (QUOTE CHARACTER)) (CHARACTER OBJECT)) ((MEMBER RESULT-TYPE (QUOTE (FLOAT SINGLE-FLOAT SHORT-FLOAT LONG-FLOAT DOUBLE-FLOAT)) :TEST (FUNCTION EQ)) (FLOAT OBJECT)) ((EQ (IF (CONSP RESULT-TYPE) (CAR RESULT-TYPE) RESULT-TYPE) (QUOTE COMPLEX)) (IF (CONSP RESULT-TYPE) (LET ((SUBTYPE (CADR RESULT-TYPE))) (IF (COMPLEXP OBJECT) (COMPLEX (COERCE (REALPART OBJECT) SUBTYPE) (COERCE (IMAGPART OBJECT) SUBTYPE)) (COMPLEX (COERCE OBJECT SUBTYPE)))) (COMPLEX OBJECT))) ((TYPEP OBJECT (QUOTE SEQUENCE)) (MAP RESULT-TYPE (QUOTE IDENTITY) OBJECT)) (T (ERROR "Cannot coerce ~S to type: ~S" OBJECT RESULT-TYPE)))))
+
+(DEFMACRO TYPECASE (KEYFORM &REST FORMS) "Type dispatch, order is important, more specific types should appear first" (IL:BQUOTE (LET (($$TYPE-VALUE (IL:\\\, KEYFORM))) (COND (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (FORM) (LET ((PRED (IF (MEMBER (CAR FORM) (QUOTE (OTHERWISE T)) :TEST (FUNCTION EQ)) T (IL:BQUOTE (TYPEP $$TYPE-VALUE (QUOTE (IL:\\\, (CAR FORM))))))) (FORM (IF (NULL (CDR FORM)) (QUOTE (NIL)) (CDR FORM)))) (IL:BQUOTE ((IL:\\\, PRED) (IL:\\\,@ FORM)))))) FORMS))))))
+
+(DEFUN %VALID-TYPE-P (TYPE) (IF (CONSP TYPE) (CASE (CAR TYPE) (SATISFIES T) ((OR AND) (EVERY (QUOTE %VALID-TYPE-P) (CDR TYPE))) (NOT (%VALID-TYPE-P (CADR TYPE))) ((:DATATYPE IL:DATATYPE) T) (OTHERWISE (AND (TYPE-EXPANDER TYPE) T))) (OR (AND (TYPE-EXPANDER TYPE) T) (EQ TYPE T) (NULL TYPE))))
+
+(XCL:DEFOPTIMIZER TYPEP (OBJ TYPE) (IF (CONSTANTP TYPE) (LET ((TYPE-EXPR (EVAL TYPE))) (IF (%VALID-TYPE-P TYPE-EXPR) (IL:BQUOTE ((IL:\\\, (%TYPEP-PRED TYPE-EXPR)) (IL:\\\, OBJ))) (PROGN (WARN "Can't optimize (typep ~s ~s); type not known." OBJ TYPE) (QUOTE COMPILER:PASS)))) (QUOTE COMPILER:PASS)))
+
+(XCL:DEFOPTIMIZER COERCE (OBJECT RESULT-TYPE) (IL:* IL:|;;| "Open code the simple coerce cases ") (IF (CONSTANTP RESULT-TYPE) (CASE (EVAL RESULT-TYPE) (CHARACTER (IL:BQUOTE (CHARACTER (IL:\\\, OBJECT)))) ((FLOAT SINGLE-FLOAT SHORT-FLOAT LONG-FLOAT DOUBLE-FLOAT) (IL:BQUOTE (FLOAT (IL:\\\, OBJECT)))) (OTHERWISE (QUOTE COMPILER:PASS))) (QUOTE COMPILER:PASS)))
+
+
+
+(IL:* IL:|;;;| "for DEFTYPE")
+
+
+(XCL:DEF-DEFINE-TYPE IL:TYPES "Common Lisp type definitions")
+
+(XCL:DEFDEFINER (DEFTYPE (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFTYPE (IL:\\\, NAME) ("Arg list") "Body")))))) IL:TYPES (NAME DEFTYPE-ARGS &BODY BODY) (UNLESS (AND NAME (SYMBOLP NAME)) (ERROR "Illegal name used in DEFTYPE: ~S" NAME)) (LET ((EXPANDER-NAME (XCL:PACK (LIST "type-expand-" NAME) (SYMBOL-PACKAGE NAME)))) (MULTIPLE-VALUE-BIND (PARSED-BODY DECLS DOCSTRING) (IL:PARSE-DEFMACRO DEFTYPE-ARGS (QUOTE SI::%$$TYPE-FORM) BODY NAME NIL :DEFAULT-DEFAULT (QUOTE (QUOTE *))) (IL:BQUOTE (EVAL-WHEN (EVAL COMPILE LOAD) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, EXPANDER-NAME))) (FUNCTION (LAMBDA (SI::%$$TYPE-FORM) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\, PARSED-BODY))))) (SETF (TYPE-EXPANDER (QUOTE (IL:\\\, NAME))) (QUOTE (IL:\\\, EXPANDER-NAME))) (IL:\\\,@ (AND DOCSTRING (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE TYPE)) (IL:\\\, DOCSTRING)))))) (IL:\\\,@ (IF (NULL DEFTYPE-ARGS) (LET ((TYPEP-NAME (XCL:PACK (LIST "typep-evaluate-" NAME) (SYMBOL-PACKAGE NAME)))) (IL:BQUOTE ((EVAL-WHEN (LOAD) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, TYPEP-NAME))) (FUNCTION (LAMBDA (SI::%$$OBJECT) (TYPEP SI::%$$OBJECT (QUOTE (IL:\\\, NAME)))))) (PUTHASH (QUOTE (IL:\\\, NAME)) *TYPEP-HASH-TABLE* (QUOTE (IL:\\\, TYPEP-NAME)))) (EVAL-WHEN (EVAL) (PUTHASH (QUOTE (IL:\\\, NAME)) *TYPEP-HASH-TABLE* NIL))))))))))))
+
+(DEFUN TYPE-EXPAND (FORM &OPTIONAL (EXPANDER (TYPE-EXPANDER FORM))) (IL:* IL:|;;| "Expands a type form according to deftypes in effect.  The caller must ensure there is an expander for the form ") (IF EXPANDER (VALUES (FUNCALL EXPANDER (ETYPECASE FORM (SYMBOL (LIST FORM)) (CONS FORM))) T) (VALUES FORM NIL)))
+
+(DEFUN TYPE-EXPANDER (TYPE) (LET* ((SYMBOL-TYPE (ETYPECASE TYPE (SYMBOL TYPE) (CONS (CAR TYPE)))) (EXPANDER (OR (GET SYMBOL-TYPE (QUOTE :TYPE-EXPANDER)) (GET SYMBOL-TYPE (QUOTE IL:TYPE-EXPANDER))))) (IF (AND (NULL EXPANDER) (SYMBOLP TYPE) (SI::DATATYPE-P TYPE)) (IL:* IL:|;;| "Install a deftype") (LET ((DEFTYPE-FORM (IL:BQUOTE (DEFTYPE (IL:\\\, TYPE) NIL (QUOTE (:DATATYPE (IL:\\\, TYPE))))))) (IF (FBOUNDP (QUOTE XCL:COMPILE-FORM)) (IL:* IL:|;;| "Compile form on the fly") (XCL:COMPILE-FORM DEFTYPE-FORM) (LET ((IL:DFNFLG NIL) (IL:FILEPKGFLG NIL) (IL:* IL:|;;| "DFNFLG nil makes sure this has an effect and filepkgflg nil makes sure it isn't remembered.")) (EVAL DEFTYPE-FORM))) (TYPE-EXPANDER TYPE)) EXPANDER)))
+
+(DEFMACRO SETF-TYPE-EXPANDER (SYMBOL EXPANDER) (IL:BQUOTE (SETF (GET (IL:\\\, SYMBOL) (QUOTE :TYPE-EXPANDER)) (IL:\\\, EXPANDER))))
+
+(DEFSETF TYPE-EXPANDER SETF-TYPE-EXPANDER)
+(IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD 
+
+(IL:MOVD (QUOTE TYPE-EXPAND) (QUOTE IL:TYPE-EXPAND))
+
+(IL:MOVD (QUOTE TYPE-EXPANDER) (QUOTE IL:TYPE-EXPANDER))
+)
+
+
+
+(IL:* IL:|;;;| "Support functions")
+
+
+(DEFUN ARRAY-TYPE (ARRAY) (LET ((RANK (ARRAY-RANK ARRAY))) (IF (XCL:SIMPLE-ARRAY-P ARRAY) (IF (EQ 1 RANK) (LET ((SIZE (ARRAY-TOTAL-SIZE ARRAY))) (COND ((SIMPLE-STRING-P ARRAY) (LIST (QUOTE SIMPLE-STRING) SIZE)) ((SIMPLE-BIT-VECTOR-P ARRAY) (LIST (QUOTE SIMPLE-BIT-VECTOR) SIZE)) (T (LET ((ELT-TYPE (ARRAY-ELEMENT-TYPE ARRAY))) (IF (EQ ELT-TYPE T) (LIST (QUOTE SIMPLE-VECTOR) SIZE) (LIST (QUOTE SIMPLE-ARRAY) ELT-TYPE (LIST SIZE))))))) (LIST (QUOTE SIMPLE-ARRAY) (ARRAY-ELEMENT-TYPE ARRAY) (ARRAY-DIMENSIONS ARRAY))) (IF (EQ 1 RANK) (LET ((SIZE (ARRAY-TOTAL-SIZE ARRAY))) (COND ((STRINGP ARRAY) (LIST (QUOTE STRING) SIZE)) ((BIT-VECTOR-P ARRAY) (LIST (QUOTE BIT-VECTOR) SIZE)) (T (LIST (QUOTE VECTOR) (ARRAY-ELEMENT-TYPE ARRAY) SIZE)))) (LIST (QUOTE ARRAY) (ARRAY-ELEMENT-TYPE ARRAY) (ARRAY-DIMENSIONS ARRAY))))))
+
+(DEFUN SYMBOL-TYPE (SYMBOL) (IF (KEYWORDP SYMBOL) (QUOTE KEYWORD) (QUOTE SYMBOL)))
+
+(DEFUN XCL:FALSE NIL NIL)
+
+(DEFUN XCL:TRUE NIL T)
+
+(DEFUN %RANGE-TYPE (BASE-TYPE LOW HIGH RANGE-LIST) (IL:* IL:|;;| "Returns a type form discriminating basetype.  Rangelist is a list of (decreasing) subranges of the full range of basetype (represented as a list of low, high and subtype).  If low and high fall within its range, a form is returned which discriminates on the subtype, and checks the range.  If low and high are exactly the range of the subtype then no range checking form is returned.") (COND ((AND (EQ LOW (QUOTE *)) (EQ HIGH (QUOTE *))) BASE-TYPE) ((OR (EQ LOW (QUOTE *)) (EQ HIGH (QUOTE *))) (IL:BQUOTE (AND (IL:\\\, BASE-TYPE) (SATISFIES (LAMBDA (X) (IL:\\\,@ (IF (NOT (EQ LOW (QUOTE *))) (IL:BQUOTE (((IL:\\\, (COND ((CONSP LOW) (SETQ LOW (CAR LOW)) (QUOTE <)) (T (QUOTE <=)))) (IL:\\\, LOW) X))))) (IL:\\\,@ (IF (NOT (EQ HIGH (QUOTE *))) (IL:BQUOTE (((IL:\\\, (COND ((CONSP HIGH) (SETQ HIGH (CAR HIGH)) (QUOTE <)) (T (QUOTE <=)))) X (IL:\\\, HIGH))))))))))) (T (DOLIST (X RANGE-LIST (IL:BQUOTE (AND (IL:\\\, BASE-TYPE) (SATISFIES (LAMBDA (X) (AND ((IL:\\\, (COND ((CONSP LOW) (SETQ LOW (CAR LOW)) (QUOTE <)) (T (QUOTE <=)))) (IL:\\\, LOW) X) ((IL:\\\, (COND ((CONSP HIGH) (SETQ HIGH (CAR HIGH)) (QUOTE <)) (T (QUOTE <=)))) X (IL:\\\, HIGH)))))))) (IL:* IL:|;;| "If the limits are exactly the range specified in the rangelist, then return the corresponding type (since no range-check will be required in the result).") (IF (AND (EQUAL LOW (CAR X)) (EQUAL HIGH (CADR X))) (RETURN (CADDR X))) (IL:* IL:|;;| "If the limits are within the range, then remember the basetype.") (IF (<= (CAR X) (IF (CONSP LOW) (1+ (CAR LOW)) LOW) (IF (CONSP HIGH) (1- (CAR HIGH)) HIGH) (CADR X)) (SETQ BASE-TYPE (CADDR X)))))))
+
+(DEFUN NUMBERP (X) (AND (IL:NUMBERP X) T))
+
+(DEFUN FLOATP (X) (AND (IL:FLOATP X) T))
+
+(DEFUN CL:REALP (CL::X) (TYPEP CL::X (QUOTE CL:REAL)))
+
+(XCL:DEFOPTIMIZER NUMBERP (X) (IL:BQUOTE (AND (IL:NUMBERP (IL:\\\, X)) T)))
+
+(XCL:DEFOPTIMIZER FLOATP (X) (IL:BQUOTE (AND (IL:FLOATP (IL:\\\, X)) T)))
+
+(XCL:DEFOPTIMIZER CL:REALP (CL::X) (IL:BQUOTE (TYPEP (IL:\\\, CL::X) (QUOTE CL:REAL))))
+
+(XCL:DEFOPTIMIZER XCL:FALSE (&BODY IL:FORMS) (IL:BQUOTE (PROG1 NIL (IL:\\\,@ IL:FORMS))))
+
+(XCL:DEFOPTIMIZER XCL:TRUE (&BODY XCL::FORMS) (IL:BQUOTE (PROG1 T (IL:\\\,@ XCL::FORMS))))
+
+
+
+(IL:* IL:|;;;| "For TYPEP")
+
+
+(DEFUN %TYPEP-PRED (TYPE) (IL:* IL:|;;| "returns the predicate of one argument that determines this type.") (COND ((CONSP TYPE) (CASE (CAR TYPE) (SATISFIES (CADR TYPE)) ((:DATATYPE IL:DATATYPE) (IL:BQUOTE (LAMBDA (SI::%$$OBJECT) (IL:TYPENAMEP SI::%$$OBJECT (QUOTE (IL:\\\, (CADR TYPE))))))) ((AND OR NOT) (IL:BQUOTE (LAMBDA (SI::%$$OBJECT) ((IL:\\\, (CAR TYPE)) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (SUBTYPE) (LIST (%TYPEP-PRED SUBTYPE) (QUOTE SI::%$$OBJECT)))) (CDR TYPE))))))) (OTHERWISE (LET ((EXPANDER (TYPE-EXPANDER (CAR TYPE)))) (IF EXPANDER (%TYPEP-PRED (FUNCALL EXPANDER TYPE)) (CERROR "Look again for a deftype on ~S." "No type definition for ~S. Specify one with DEFTYPE." TYPE)))))) (T (COND ((EQ TYPE T) (QUOTE XCL:TRUE)) ((EQ TYPE NIL) (QUOTE XCL:FALSE)) (T (LET ((EXPANDER (TYPE-EXPANDER TYPE))) (COND (EXPANDER (%TYPEP-PRED (FUNCALL EXPANDER (LIST TYPE)))) (T (IL:* IL:|;;| "there is no deftype on this  non-list type. ") (LOOP (IF (TYPE-EXPANDER TYPE) (RETURN NIL)) (CERROR "Use the deftype you have specified." "No type definition for ~S. Specify one with DEFTYPE." TYPE)) (%TYPEP-PRED TYPE)))))))))
+
+(DEFUN BIGNUMP (X) (OR (IL:TYPENAMEP X (QUOTE IL:FIXP)) (IL:TYPENAMEP X (QUOTE BIGNUM))))
+
+
+
+(IL:* IL:|;;;| "for SUBTYPEP ")
+
+
+(DEFCONSTANT %NO-SUPER-TYPE 0 "the value in the dtdsupertype field which indicates no super type.")
+
+(DEFCONSTANT *COMMON-LISP-BASE-TYPES* (IL:* IL:|;;| "The types which are known to be disjoint from any type explicitly handled by subtypep.") (QUOTE ((IL:* IL:|;;| "The only types that need to be in this list are types on page 43 that expand into a satisfies or datatype clause, i.e. any type that expands into something that base-subtypep doesn't know to handle, e.g. satisfies.") ARRAY ATOM CL:BASE-CHARACTER BIGNUM (IL:* IL:\; "even though bignum expands into a datatype, that datatype is not a subdatatype of integer, etc. so must be explicitly handled.") CHARACTER COMMON COMPLEX COMPILED-FUNCTION CONS IL:DATATYPE (IL:* IL:\; "this is only here for back-compatibility.  The first global recompile, this can go.") :DATATYPE CL:EXTENDED-CHARACTER FLOAT FUNCTION HASH-TABLE INTEGER KEYWORD NIL NULL NUMBER PACKAGE PATHNAME RANDOM-STATE RATIO (IL:* IL:\; "same comment for ratio as bignum.") RATIONAL READTABLE SIMPLE-ARRAY STANDARD-CHAR STREAM STRING-CHAR SYMBOL T)))
+
+(DEFCONSTANT *BASE-TYPE-LATTICE* (QUOTE ((NUMBER CL:REAL RATIONAL INTEGER RATIO FIXNUM BIGNUM COMPLEX FLOAT) (CL:REAL RATIONAL INTEGER RATIO FIXNUM BIGNUM FLOAT) (RATIONAL INTEGER RATIO FIXNUM BIGNUM) (INTEGER FIXNUM BIGNUM) (CHARACTER STRING-CHAR CL:BASE-CHARACTER CL:EXTENDED-CHARACTER STANDARD-CHAR) (STRING-CHAR CL:BASE-CHARACTER CL:EXTENDED-CHARACTER STANDARD-CHAR) (CL:EXTENDED-CHARACTER CL:BASE-CHARACTER STANDARD-CHAR) (CL:BASE-CHARACTER STANDARD-CHAR) (LIST NULL) (SYMBOL KEYWORD NULL) (ARRAY SIMPLE-ARRAY) (FUNCTION COMPILED-FUNCTION) (NIL) (IL:DATATYPE :DATATYPE) (IL:* IL:\; "the presence of il:datatype is for back compatibility.") (:DATATYPE IL:DATATYPE))) "the lattice which tells the (base) subtypes of any base type.")
+
+(DEFUN SUBTYPEP (TYPE1 TYPE2) (IL:* IL:|;;| "Returns T if type1 is a subtype of type2.  If second value is nil, couldn't decide.") (IF (EQUAL TYPE1 TYPE2) (IL:* IL:|;;| "no need to complete any further recursion, so just return success.") (VALUES T T) (CASE (IF (CONSP TYPE1) (CAR TYPE1) TYPE1) (AND (IL:* IL:|;;| "(subtypep '(and t1 t2 ...) 't3) <= (or (subtypep 't1 't3) (subtypep 't2 't3) ...  ) because '(and t1 t2 ...) denotes the intersection of types t1, t2, ...") (IL:* IL:|;;| "Even if none of the conjuncts is a subtype, we still can't return (NIL T) because the intersection might still be a subtype.") (LET ((RESULT NIL) CERTAINTY CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SETQ CERTAINTY (DOLIST (TYPE1-CONJUNCT (CDR TYPE1) NIL) (MULTIPLE-VALUE-SETQ (CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SUBTYPEP TYPE1-CONJUNCT TYPE2)) (WHEN CONJUNCT-RESULT (SETQ RESULT T) (IF CONJUNCT-CERTAINTY (RETURN T))))) (VALUES RESULT CERTAINTY))) (OR (IL:* IL:|;;| "(subtypep '(or t1 t2 ...) 't3) <=> (and (subtypep 't1 't3) (subtypep 't2 't3) ...)") (LET ((RESULT T) CERTAINTY (LOOP-CERTAINTY T) CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SETQ CERTAINTY (DOLIST (TYPE1-CONJUNCT (CDR TYPE1) LOOP-CERTAINTY) (IL:* IL:|;;| "returns t only if every conjunct clause is a certain subtype, or if one conjunct clause is certainly not a subtype") (MULTIPLE-VALUE-SETQ (CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SUBTYPEP TYPE1-CONJUNCT TYPE2)) (COND ((NULL CONJUNCT-RESULT) (SETQ RESULT NIL) (IF CONJUNCT-CERTAINTY (RETURN T) (IL:* IL:|;;| "else continue to look for a more cetain result") (SETQ LOOP-CERTAINTY NIL))) (T (IF (NULL CONJUNCT-CERTAINTY) (SETQ LOOP-CERTAINTY NIL)))))) (VALUES RESULT CERTAINTY))) (OTHERWISE (IL:* IL:|;;| "Try to expand type1") (MULTIPLE-VALUE-BIND (NEW-TYPE1 EXPANDED?) (SUBTYPEP-TYPE-EXPAND TYPE1) (IF (USEFUL-TYPE-EXPANSION-P NEW-TYPE1 EXPANDED?) (SUBTYPEP NEW-TYPE1 TYPE2) (IL:* IL:|;;| "We now have a base type for type1, there is nothing further to be done with it, by itself.  So we check for special cases in type2") (CASE (IF (CONSP TYPE2) (CAR TYPE2) TYPE2) (AND (IL:* IL:|;;| " (subtypep 't1 '(and t2 t3 ...)) <=> (and (subtypep 't1 't2) (subtypep 't1 't3) ...) because '(and t2 t3 ...) denotes the intersection of types t2, t3, ...") (LET ((RESULT T) CERTAINTY (LOOP-CERTAINTY T) CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SETQ CERTAINTY (DOLIST (TYPE2-CONJUNCT (CDR TYPE2) LOOP-CERTAINTY) (MULTIPLE-VALUE-SETQ (CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SUBTYPEP TYPE1 TYPE2-CONJUNCT)) (COND ((NULL CONJUNCT-RESULT) (SETQ RESULT NIL) (IF CONJUNCT-CERTAINTY (RETURN T) (IL:* IL:|;;| "else continue to look for a more cetain result") (SETQ LOOP-CERTAINTY NIL))) (T (IF (NULL CONJUNCT-CERTAINTY) (SETQ LOOP-CERTAINTY NIL)))))) (VALUES RESULT CERTAINTY))) (OR (IL:* IL:|;;| "(subtypep 't1 '(or t2 t3 ...)) <=> (or (subtypep 't1 't2) (subtypep 't1 't3) ...  ) because '(or t1 t2 ...) denotes the union of types t1, t2, ...") (IL:* IL:|;;| "We can't ever return (values nil t) because the t2..tn might form a partition of t1, i.e.") (IL:* IL:|;;| "(deftype evenp nil '(and integer (satisfies %evenp)))") (IL:* IL:|;;| "(deftype oddp nil '(and integer (satisfies %oddp)))") (IL:* IL:|;;| "(subtypep 'integer '(or evenp oddp)) is true, but the satisfies makes it undecidable, so we must return (nil nil).") (LET ((RESULT NIL) CERTAINTY CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SETQ CERTAINTY (DOLIST (TYPE2-CONJUNCT (CDR TYPE2) NIL) (MULTIPLE-VALUE-SETQ (CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SUBTYPEP TYPE1 TYPE2-CONJUNCT)) (WHEN CONJUNCT-RESULT (SETQ RESULT T) (IF CONJUNCT-CERTAINTY (RETURN T))))) (VALUES RESULT CERTAINTY))) (OTHERWISE (IL:* IL:|;;| "try to expand type2.") (MULTIPLE-VALUE-BIND (NEW-TYPE2 EXPANDED?) (SUBTYPEP-TYPE-EXPAND TYPE2) (IF (USEFUL-TYPE-EXPANSION-P NEW-TYPE2 EXPANDED?) (SUBTYPEP TYPE1 NEW-TYPE2) (IL:* IL:|;;| "we have now handled everything but base types.  There is no further expansion etc, to be done.") (BASE-SUBTYPEP TYPE1 TYPE2)))))))))))
+
+(DEFUN SUBTYPEP-TYPE-EXPAND (TYPE) (IL:* IL:|;;| "Like type-expand, except it doesn't expand base-types.") (IF (MEMBER (IF (CONSP TYPE) (CAR TYPE) TYPE) *COMMON-LISP-BASE-TYPES* :TEST (FUNCTION EQ)) (VALUES TYPE NIL) (TYPE-EXPAND TYPE)))
+
+(DEFUN SI::DATATYPE-P (SI::NAME) (IL:* IL:|;;| "Returns T if name is a datatype known to the XAIE type system") (AND (IL:\\TYPENUMBERFROMNAME SI::NAME) T))
+
+(DEFUN SI::SUB-DATATYPE-P (TYPE1 TYPE2) (IL:* IL:|;;| "Returns T if type2 is a (not necessarily proper) supertype of type1.") (DO* ((TYPE-NUMBER-1 (IL:\\TYPENUMBERFROMNAME TYPE1)) (TYPE-NUMBER-2 (IL:\\TYPENUMBERFROMNAME TYPE2)) (SUPER-TYPE-NUMBER TYPE-NUMBER-1 (IL:|fetch| IL:DTDSUPERTYPE IL:|of| (IL:\\GETDTD SUPER-TYPE-NUMBER)))) ((EQ %NO-SUPER-TYPE SUPER-TYPE-NUMBER) (IL:* IL:|;;| "we didn't find type2 on type1's super chain so return NIL  ") NIL) (IF (EQ SUPER-TYPE-NUMBER TYPE-NUMBER-2) (RETURN T))))
+
+(DEFUN EQUAL-DIMENSIONS (DIMS1 DIMS2) (IL:* IL:|;;| "Says if dims1 and dims2 are the same in each dimension (allowing for wildcard's (*'s)).") (OR (EQ DIMS1 (QUOTE *)) (EQ DIMS2 (QUOTE *)) (AND (EQUAL (LENGTH DIMS1) (LENGTH DIMS2)) (DO ((DIM1 DIMS1 (CDR DIM1)) (DIM2 DIMS2 (CDR DIM2))) ((NULL DIM1) T) (IF (NOT (OR (EQ (CAR DIM1) (QUOTE *)) (EQ (CAR DIM2) (QUOTE *)) (EQ (CAR DIM1) (CAR DIM2)))) (RETURN NIL))))))
+
+(DEFUN COMPLETE-ARRAY-TYPE-DIMENSIONS (DIMENSIONS) (ETYPECASE DIMENSIONS (CONS DIMENSIONS) ((OR NULL (MEMBER *)) (QUOTE *)) (INTEGER (MAKE-LIST DIMENSIONS :INITIAL-ELEMENT (QUOTE *)))))
+
+(DEFUN COMPLETE-META-EXPRESSION-DEFAULTS (TYPE) (IL:* IL:|;;| "given a type expression finishes the defaults the same way as the type-expander.") (LET ((LIST-TYPE (IF (LISTP TYPE) TYPE (LIST TYPE)))) (CASE (CAR LIST-TYPE) ((SIMPLE-ARRAY ARRAY) (CL:DESTRUCTURING-BIND (ARRAY-TYPE &OPTIONAL (ELEMENT-TYPE (QUOTE *)) (DIMENSIONS (QUOTE *))) LIST-TYPE (LIST ARRAY-TYPE ELEMENT-TYPE (COMPLETE-ARRAY-TYPE-DIMENSIONS DIMENSIONS)))) ((INTEGER FLOAT RATIONAL) (CL:DESTRUCTURING-BIND (NUMERIC-TYPE &OPTIONAL (LOWER (QUOTE *)) (HIGHER (QUOTE *))) LIST-TYPE (LIST NUMERIC-TYPE LOWER HIGHER))) (COMPLEX (CL:DESTRUCTURING-BIND (NUMERIC-TYPE &OPTIONAL (ELEMENT-TYPE (QUOTE *))) LIST-TYPE (LIST NUMERIC-TYPE ELEMENT-TYPE))) (T TYPE))))
+
+(DEFUN RANGE<= (LOW2 LOW1 HIGH1 HIGH2 TYPE1 TYPE2) (IL:* IL:|;;;| "Returns t if bound1 is less than or equal bound2, allowing for wildcards. ") (IF (EQ TYPE1 (QUOTE INTEGER)) (COND ((CONSP LOW1) (SETQ LOW1 (+ (CAR LOW1) 1))) ((CONSP HIGH1) (SETQ HIGH1 (- (CAR HIGH1) 1))))) (IF (EQ TYPE2 (QUOTE INTEGER)) (COND ((CONSP LOW2) (SETQ LOW2 (+ (CAR LOW2) 1))) ((CONSP HIGH2) (SETQ HIGH2 (- (CAR HIGH2) 1))))) (AND (IL:* IL:|;;| "check the low bounds") (COND ((EQ LOW2 (QUOTE *)) T) ((EQ LOW1 (QUOTE *)) NIL) (T (IF (CONSP LOW2) (IF (CONSP LOW1) (<= (CAR LOW2) (CAR LOW1)) (< (CAR LOW2) LOW1)) (IF (CONSP LOW1) (<= LOW2 (CAR LOW1)) (<= LOW2 LOW1))))) (IL:* IL:|;;| "Check the high bounds") (COND ((EQ HIGH2 (QUOTE *)) T) ((EQ HIGH1 (QUOTE *)) NIL) (T (IF (CONSP HIGH2) (IF (CONSP HIGH1) (>= (CAR HIGH2) (CAR HIGH1)) (> (CAR HIGH2) HIGH1)) (IF (CONSP HIGH1) (>= HIGH2 (CAR HIGH1)) (>= HIGH2 HIGH1)))))))
+
+(DEFUN BASE-SUBTYPEP (TYPE1 TYPE2) (IL:* IL:|;;| "Contains subtypep's special cases for base types.") (LET ((SYMBOL-TYPE1 (IF (CONSP TYPE1) (CAR TYPE1) TYPE1)) (SYMBOL-TYPE2 (IF (CONSP TYPE2) (CAR TYPE2) TYPE2))) (COND ((OR (EQ TYPE1 NIL) (EQ TYPE2 T) (EQUAL TYPE1 TYPE2)) (VALUES T T)) ((EQ TYPE2 (QUOTE COMMON)) (IL:* IL:\; "Common does not list it's subtypes in the lattice, since their presence indicates that they are in COMMON.") (IF (MEMBER SYMBOL-TYPE1 *COMMON-LISP-BASE-TYPES* :TEST (FUNCTION EQ)) (IL:* IL:|;;| "then this is part of common. Note this will include structures etc.") (VALUES T T) (VALUES NIL T))) ((OR (NOT (MEMBER SYMBOL-TYPE1 *COMMON-LISP-BASE-TYPES* :TEST (FUNCTION EQ))) (NOT (MEMBER SYMBOL-TYPE2 *COMMON-LISP-BASE-TYPES* :TEST (FUNCTION EQ)))) (IL:* IL:\; "one of the types is something we can't reason about (for instance a user defined type that expands into satisfies.)") (VALUES NIL NIL)) (IL:* IL:|;;| "from this point on, we are only dealing with Common Lisp base types.") ((EQ TYPE1 T) (IL:* IL:\; "t is not a subtype of anything but t, and that's checked above).") (VALUES NIL T)) ((EQ TYPE2 NIL) (IL:* IL:\; "nil is not a supertype of anything but nil, and that's checked above).") (VALUES NIL T)) ((EQ TYPE2 (QUOTE ATOM)) (IL:* IL:|;;| "this case could be explicitly added to the type lattice.  But if someone adds a base type, then they would have to remember to add it as a sub type of atom, (which they wouldn't.)") (IF (EQ TYPE1 (QUOTE CONS)) (IL:* IL:\; "this is the only base type that isn't a subtype of atom.") (VALUES NIL T) (VALUES T T))) ((NOT (OR (EQ SYMBOL-TYPE1 SYMBOL-TYPE2) (MEMBER SYMBOL-TYPE1 (ASSOC SYMBOL-TYPE2 *BASE-TYPE-LATTICE* :TEST (FUNCTION EQ)) :TEST (FUNCTION EQ)))) (IL:* IL:|;;| "since we are now dealing with only base types, we can make sure that type1 (without its arguments) is a subtype of type2, before checking the constraints on the arguments.") (VALUES NIL T)) (T (IL:* IL:|;;| "Now check the constraints on the type arguments.") (LET ((TYPE1 (COMPLETE-META-EXPRESSION-DEFAULTS TYPE1)) (TYPE2 (COMPLETE-META-EXPRESSION-DEFAULTS TYPE2))) (CASE (IF (CONSP TYPE1) (CAR TYPE1) TYPE1) ((ARRAY SIMPLE-ARRAY) (IL:* IL:|;;| "the type will look like (simple-array element-type dimensions)") (CL:DESTRUCTURING-BIND (ARRAY-TYPE1 ELEMENT-TYPE-1 DIMS-1) TYPE1 (CL:DESTRUCTURING-BIND (ARRAY-TYPE2 ELEMENT-TYPE-2 DIMS-2) TYPE2 (IF (AND (EQUAL-ELEMENT-TYPE ELEMENT-TYPE-1 ELEMENT-TYPE-2) (EQUAL-DIMENSIONS DIMS-1 DIMS-2)) (VALUES T T) (VALUES NIL T))))) ((:DATATYPE IL:DATATYPE) (IL:* IL:|;;| "we wouldn't have made it here if they weren't both datatypes, since only datatype is a subtype of datatype in the lattice.") (VALUES (SI::SUB-DATATYPE-P (CADR TYPE1) (CADR TYPE2)) T)) ((INTEGER RATIONAL FLOAT) (CASE TYPE2 (NUMBER (IL:* IL:|;;| "number doesn't take ranges, there's nothing  to verify.") (VALUES T T)) (OTHERWISE (CL:DESTRUCTURING-BIND (NUMERIC-TYPE1 LOW1 HIGH1) TYPE1 (CL:DESTRUCTURING-BIND (NUMERIC-TYPE2 LOW2 HIGH2) TYPE2 (IF (RANGE<= LOW2 LOW1 HIGH1 HIGH2 NUMERIC-TYPE1 NUMERIC-TYPE2) (VALUES T T) (VALUES NIL T))))))) (COMPLEX (CASE TYPE2 (NUMBER (VALUES T T)) (OTHERWISE (IL:* IL:|;;| "typep2 must be complex") (LET ((ELT-TYPE1 (CADR TYPE1)) (ELT-TYPE2 (CADR TYPE2))) (COND ((EQ ELT-TYPE2 (QUOTE *)) (VALUES T T)) ((EQ ELT-TYPE1 (QUOTE *)) (VALUES NIL T)) (T (SUBTYPEP ELT-TYPE1 ELT-TYPE2))))))) (OTHERWISE (IL:* IL:|;;| "these are two base types.  the lattice said they are subtypes, and there are no special rules on the arguments, so the result is (t t) if they are equal") (VALUES T T))))))))
+
+(DEFUN EQUAL-ELEMENT-TYPE (ELEMENT-TYPE-1 ELEMENT-TYPE-2) (IL:* IL:|;;| "returns t if they are element types for compatible array types.") (COND ((EQ ELEMENT-TYPE-2 (QUOTE *)) T) ((EQ ELEMENT-TYPE-1 (QUOTE *)) NIL) (T (EQUAL (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE-1) (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE-2)))))
+
+(DEFUN USEFUL-TYPE-EXPANSION-P (EXPANSION EXPANDED) (IL:* IL:|;;| "a type expansion only gained information if some expansion happened and the result isn't solely a satisfies form.") (AND EXPANDED (NOT (AND (CONSP EXPANSION) (EQ (CAR EXPANSION) (QUOTE SATISFIES))))))
+
+
+
+(IL:* IL:|;;;| "Basic deftypes")
+
+
+(DEFTYPE ATOM NIL (QUOTE (SATISFIES ATOM)))
+
+(DEFTYPE BIGNUM NIL (QUOTE (SATISFIES BIGNUMP)))
+
+(DEFTYPE BIT NIL (QUOTE (INTEGER 0 1)))
+
+(DEFTYPE CHARACTER NIL (QUOTE (SATISFIES CHARACTERP)))
+
+(DEFTYPE CONS NIL (QUOTE (:DATATYPE IL:LISTP)))
+
+(DEFTYPE DOUBLE-FLOAT (&OPTIONAL LOW HIGH) (IL:BQUOTE (FLOAT (IL:\\\, LOW) (IL:\\\, HIGH))))
+
+(DEFTYPE EQL (CL::VALUE) (IL:BQUOTE (SATISFIES (LAMBDA (CL::X) (EQL CL::X (QUOTE (IL:\\\, CL::VALUE)))))))
+
+(DEFTYPE FIXNUM NIL (IL:BQUOTE (INTEGER (IL:\\\, MOST-NEGATIVE-FIXNUM) (IL:\\\, MOST-POSITIVE-FIXNUM))))
+
+(DEFTYPE STREAM NIL (QUOTE (:DATATYPE STREAM)))
+
+(DEFTYPE FLOAT (&OPTIONAL LOW HIGH) (%RANGE-TYPE (QUOTE (:DATATYPE IL:FLOATP)) LOW HIGH))
+
+(DEFTYPE FUNCTION NIL (QUOTE (SATISFIES FUNCTIONP)))
+
+(DEFTYPE HASH-TABLE NIL (QUOTE (:DATATYPE IL:HARRAYP)))
+
+(DEFTYPE INTEGER (&OPTIONAL LOW HIGH) (%RANGE-TYPE (QUOTE (SATISFIES INTEGERP)) LOW HIGH (IL:BQUOTE (((IL:\\\, IL:MIN.INTEGER) (IL:\\\, IL:MAX.INTEGER) (SATISFIES INTEGERP)) ((IL:\\\, IL:MIN.FIXP) (IL:\\\, IL:MAX.FIXP) (OR (SATISFIES IL:SMALLP) (:DATATYPE IL:FIXP))) ((IL:\\\, IL:MIN.SMALLP) (IL:\\\, IL:MAX.SMALLP) (SATISFIES IL:SMALLP)) (0 1 (MEMBER 0 1))))))
+
+(DEFTYPE KEYWORD NIL (QUOTE (SATISFIES KEYWORDP)))
+
+(DEFTYPE LIST (&OPTIONAL TYPE) (IF (EQ TYPE (QUOTE *)) (QUOTE (OR NULL CONS)) (IL:BQUOTE (AND LIST (SATISFIES (LAMBDA (X) (EVERY (FUNCTION (LAMBDA (ELEMENT) (TYPEP ELEMENT (QUOTE (IL:\\\, TYPE))))) X)))))))
+
+(DEFTYPE LONG-FLOAT (&OPTIONAL LOW HIGH) (IL:BQUOTE (FLOAT (IL:\\\, LOW) (IL:\\\, HIGH))))
+
+(DEFTYPE MEMBER (&REST VALUES) (IL:BQUOTE (SATISFIES (LAMBDA (X) (MEMBER X (QUOTE (IL:\\\, VALUES)))))))
+
+(DEFTYPE MOD (N) (IL:BQUOTE (INTEGER 0 (IL:\\\, (1- N)))))
+
+(DEFTYPE NULL NIL (QUOTE (SATISFIES NULL)))
+
+(DEFTYPE NUMBER NIL (QUOTE (SATISFIES NUMBERP)))
+
+(DEFTYPE PACKAGE NIL (QUOTE (:DATATYPE PACKAGE)))
+
+(DEFTYPE CL:REAL (&OPTIONAL CL::LOW CL::HIGH) (IL:* IL:|;;| "This is true in our implementation, but CLtL2 does not require it (it is legal for other things to be REAL; we just don't have any).") (%RANGE-TYPE (QUOTE (OR RATIONAL FLOAT)) CL::LOW CL::HIGH))
+
+(DEFTYPE SHORT-FLOAT (&OPTIONAL LOW HIGH) (IL:BQUOTE (FLOAT (IL:\\\, LOW) (IL:\\\, HIGH))))
+
+(DEFTYPE SIGNED-BYTE (&OPTIONAL S) (IF (EQ S (QUOTE *)) (QUOTE INTEGER) (LET ((SIZE (EXPT 2 (1- S)))) (IL:BQUOTE (INTEGER (IL:\\\, (- SIZE)) (IL:\\\, (1- SIZE)))))))
+
+(DEFTYPE STANDARD-CHAR NIL (QUOTE (SATISFIES STANDARD-CHAR-P)))
+
+(DEFTYPE STRING-CHAR NIL (QUOTE (AND CHARACTER (SATISFIES STRING-CHAR-P))))
+
+(DEFTYPE CL:BASE-CHARACTER NIL (QUOTE (SATISFIES CL::BASE-CHARACTER-P)))
+
+(DEFTYPE CL:EXTENDED-CHARACTER NIL (QUOTE (SATISFIES CL::EXTENDED-CHARACTER-P)))
+
+(DEFTYPE SINGLE-FLOAT (&OPTIONAL LOW HIGH) (IL:BQUOTE (FLOAT (IL:\\\, LOW) (IL:\\\, HIGH))))
+
+(DEFTYPE SYMBOL NIL (QUOTE (:DATATYPE IL:LITATOM)))
+
+(DEFTYPE UNSIGNED-BYTE (&OPTIONAL S) (IF (EQ S (QUOTE *)) (QUOTE (INTEGER 0 *)) (IL:BQUOTE (INTEGER 0 ((IL:\\\, (EXPT 2 S)))))))
+
+(DEFTYPE RATIONAL (&OPTIONAL LOW HIGH) (%RANGE-TYPE (QUOTE (OR RATIO INTEGER)) LOW HIGH))
+
+(DEFTYPE READTABLE NIL (QUOTE (:DATATYPE READTABLEP)))
+
+(DEFTYPE COMMON NIL (IL:* IL:|;;| "This is a hack.  (You can tell, because it uses TYPE-OF.)  However, it is correct.  (Note that even though subtypep uses expanders, there is no danger of  a loop because it quits when it reachs a satisfies clause.)") (IL:BQUOTE (SATISFIES (LAMBDA (OBJ) (VALUES (SUBTYPEP (TYPE-OF OBJ) (QUOTE COMMON)))))))
+
+(DEFTYPE COMPILED-FUNCTION NIL (QUOTE (SATISFIES COMPILED-FUNCTION-P)))
+
+(DEFTYPE SEQUENCE (&OPTIONAL TYPE) (IL:* IL:|;;| "Larry's dubious extension, that I can't remove because he wrote code that relies on it.  Actually the extension is somewhat useful, but confusing.  (it simulates the DECL facility for saying (LIST user-type).)") (IF (EQ TYPE (QUOTE *)) (QUOTE (OR VECTOR LIST)) (IL:BQUOTE (AND SEQUENCE (SATISFIES (LAMBDA (X) (EVERY (FUNCTION (LAMBDA (ELEMENT) (TYPEP ELEMENT (QUOTE (IL:\\\, TYPE))))) X)))))))
+
+
+
+(IL:* IL:|;;;| "Array Types")
+
+
+(DEFTYPE ARRAY (&OPTIONAL ELEMENT-TYPE DIMENSIONS) (IL:* IL:|;;;| "This type definition should not return anything other than satisfies.  Other array types are determined in terms of this one, (for subtypep's sake) so this  one must bottom out.") (LET ((CANONICAL-ET (IF (EQ ELEMENT-TYPE (QUOTE *)) (QUOTE *) (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE)))) (IF (TYPEP DIMENSIONS (QUOTE FIXNUM)) (SETQ DIMENSIONS (MAKE-LIST DIMENSIONS :INITIAL-ELEMENT (QUOTE *)))) (COND ((EQ DIMENSIONS (QUOTE *)) (IF (EQ CANONICAL-ET (QUOTE *)) (QUOTE (SATISFIES ARRAYP)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (ARRAYP X) (EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET))))))))) ((EQ (LENGTH DIMENSIONS) 1) (LET ((SIZE (CAR DIMENSIONS))) (COND ((EQ CANONICAL-ET (QUOTE *)) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES VECTORP)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (VECTORP X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))) ((EQ CANONICAL-ET (QUOTE CL:BASE-CHARACTER)) (IL:* IL:|;;| "CL:BASE-CHARACTER is the canonical type for CL:BASE-CHARACTER, CHARACTER, and STRING-CHAR.  For typing purposes, they have to explicitly say CL:BASE-CHARACTER to recognize only thin strings.") (IF (EQ ELEMENT-TYPE (QUOTE CL:BASE-CHARACTER)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (STRINGP X) (IL:%THIN-STRING-ARRAY-P X) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))))) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES STRINGP)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (STRINGP X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE))))))))) ((EQ CANONICAL-ET (QUOTE CL:EXTENDED-CHARACTER)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (STRINGP X) (IL:%FAT-STRING-ARRAY-P X) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE))))))))))) ((OR (EQ CANONICAL-ET (QUOTE BIT)) (EQUAL CANONICAL-ET (QUOTE (UNSIGNED-BYTE 1)))) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES BIT-VECTOR-P)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (BIT-VECTOR-P X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))) (T (IL:* IL:|;;| "vector of explicit element-type") (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (VECTORP X) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))) (EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET))))))))))) ((EVERY (FUNCTION (LAMBDA (DIM) (EQ DIM (QUOTE *)))) DIMENSIONS) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (ARRAYP X) (EQ (ARRAY-RANK X) (IL:\\\, (LENGTH DIMENSIONS))) (IL:\\\,@ (IF (NOT (EQ CANONICAL-ET (QUOTE *))) (IL:BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET)))))))))))) ((EVERY (FUNCTION (LAMBDA (DIM) (OR (EQ DIM (QUOTE *)) (TYPEP DIM (QUOTE FIXNUM))))) DIMENSIONS) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (ARRAYP X) (EQ (ARRAY-RANK X) (IL:\\\, (LENGTH DIMENSIONS))) (IL:\\\,@ (DO ((DIM-SPEC DIMENSIONS (CDR DIM-SPEC)) (DIM 0 (1+ DIM)) FORMS) ((NULL DIM-SPEC) FORMS) (IF (NOT (EQ (CAR DIM-SPEC) (QUOTE *))) (PUSH (IL:BQUOTE (EQ (ARRAY-DIMENSION X (IL:\\\, DIM)) (IL:\\\, (CAR DIM-SPEC)))) FORMS)))) (IL:\\\,@ (IF (NOT (EQ CANONICAL-ET (QUOTE *))) (IL:BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET)))))))))))) (T (ERROR "Bad (final) array type designator: ~S" (IL:BQUOTE (ARRAY (IL:\\\, CANONICAL-ET) (IL:\\\, DIMENSIONS))))))))
+
+(DEFTYPE VECTOR (&OPTIONAL ELEMENT-TYPE SIZE) (IL:* IL:|;;| "this type must be defined in terms of array so that subtypep can reason(?) about them.") (IL:BQUOTE (ARRAY (IL:\\\, ELEMENT-TYPE) ((IL:\\\, SIZE)))))
+
+(DEFTYPE STRING (&OPTIONAL SIZE) (IL:BQUOTE (ARRAY STRING-CHAR ((IL:\\\, SIZE)))))
+
+(DEFTYPE SIMPLE-STRING (&OPTIONAL SIZE) (IL:BQUOTE (SIMPLE-ARRAY STRING-CHAR ((IL:\\\, SIZE)))))
+
+(DEFTYPE SIMPLE-ARRAY (&OPTIONAL ELEMENT-TYPE DIMENSIONS) (IL:* IL:|;;| "Simple-array type expander") (LET ((CANONICAL-ET (IF (EQ ELEMENT-TYPE (QUOTE *)) (QUOTE *) (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE)))) (IF (TYPEP DIMENSIONS (QUOTE FIXNUM)) (SETQ DIMENSIONS (MAKE-LIST DIMENSIONS :INITIAL-ELEMENT (QUOTE *)))) (IL:* IL:|;;| "at this point, dimensions is always a list of integers or *'s, and element-type is a canonical type.") (COND ((EQ DIMENSIONS (QUOTE *)) (IF (EQ CANONICAL-ET (QUOTE *)) (QUOTE (SATISFIES XCL:SIMPLE-ARRAY-P)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (XCL:SIMPLE-ARRAY-P X) (EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET))))))))) ((EQ (LENGTH DIMENSIONS) 1) (LET ((SIZE (CAR DIMENSIONS))) (COND ((EQ CANONICAL-ET (QUOTE CL:BASE-CHARACTER)) (IF (EQ ELEMENT-TYPE (QUOTE CL:BASE-CHARACTER)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (SIMPLE-STRING-P X) (IL:%THIN-STRING-ARRAY-P X) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))))) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES SIMPLE-STRING-P)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (SIMPLE-STRING-P X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE))))))))) ((EQ CANONICAL-ET (QUOTE CL:EXTENDED-CHARACTER)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (SIMPLE-STRING-P X) (IL:%FAT-STRING-ARRAY-P X) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE))))))))))) ((OR (EQ CANONICAL-ET (QUOTE BIT)) (EQUAL CANONICAL-ET (QUOTE (UNSIGNED-BYTE 1)))) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES SIMPLE-BIT-VECTOR-P)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (SIMPLE-BIT-VECTOR-P X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))) ((EQ CANONICAL-ET T) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES SIMPLE-VECTOR-P)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (SIMPLE-VECTOR-P X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))) (T (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (XCL:SIMPLE-ARRAY-P X) (EQ 1 (ARRAY-RANK X)) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))) (IL:\\\,@ (IF (NOT (EQ CANONICAL-ET (QUOTE *))) (IL:BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET))))))))))))))) ((EVERY (FUNCTION (LAMBDA (DIM) (EQ DIM (QUOTE *)))) DIMENSIONS) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (XCL:SIMPLE-ARRAY-P X) (EQ (ARRAY-RANK X) (IL:\\\, (LENGTH DIMENSIONS))) (IL:\\\,@ (IF (NOT (EQ CANONICAL-ET (QUOTE *))) (IL:BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET)))))))))))) ((EVERY (FUNCTION (LAMBDA (DIM) (OR (EQ DIM (QUOTE *)) (TYPEP DIM (QUOTE FIXNUM))))) DIMENSIONS) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (XCL:SIMPLE-ARRAY-P X) (EQ (ARRAY-RANK X) (IL:\\\, (LENGTH DIMENSIONS))) (IL:\\\,@ (DO ((DIM-SPEC DIMENSIONS (CDR DIM-SPEC)) (DIM 0 (1+ DIM)) FORMS) ((NULL DIM-SPEC) FORMS) (IF (NOT (EQ (CAR DIM-SPEC) (QUOTE *))) (PUSH (IL:BQUOTE (EQ (ARRAY-DIMENSION X (IL:\\\, DIM)) (IL:\\\, (CAR DIM-SPEC)))) FORMS)))) (IL:\\\,@ (IF (NOT (EQ CANONICAL-ET (QUOTE *))) (IL:BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET)))))))))))) (T (ERROR "Bad (final) array type designator: ~S" (IL:BQUOTE (SIMPLE-ARRAY (IL:\\\, CANONICAL-ET) (IL:\\\, DIMENSIONS))))))))
+
+(DEFTYPE SIMPLE-VECTOR (&OPTIONAL SIZE) (IL:BQUOTE (SIMPLE-ARRAY T ((IL:\\\, SIZE)))))
+
+(DEFTYPE BIT-VECTOR (&OPTIONAL SIZE) (IL:BQUOTE (ARRAY (UNSIGNED-BYTE 1) ((IL:\\\, SIZE)))))
+
+(DEFTYPE SIMPLE-BIT-VECTOR (&OPTIONAL SIZE) (IL:BQUOTE (SIMPLE-ARRAY (UNSIGNED-BYTE 1) ((IL:\\\, SIZE)))))
+
+(DEFTYPE CL:BASE-STRING (&OPTIONAL CL::SIZE) (IL:BQUOTE (ARRAY CL:BASE-CHARACTER ((IL:\\\, CL::SIZE)))))
+
+(DEFTYPE CL:SIMPLE-BASE-STRING (&OPTIONAL CL::SIZE) (IL:BQUOTE (SIMPLE-ARRAY CL:BASE-CHARACTER ((IL:\\\, CL::SIZE)))))
+
+
+
+(IL:* IL:|;;;| "Stream types required by CLtL2")
+
+
+(DEFTYPE CL:BROADCAST-STREAM NIL (IL:BQUOTE (AND STREAM (SATISFIES XCL:BROADCAST-STREAM-P))))
+
+(DEFTYPE CL:CONCATENATED-STREAM NIL (QUOTE (AND STREAM (SATISFIES XCL:CONCATENATED-STREAM-P))))
+
+(DEFTYPE CL:ECHO-STREAM NIL (QUOTE (AND STREAM (SATISFIES XCL:ECHO-STREAM-P))))
+
+(DEFTYPE CL:SYNONYM-STREAM NIL (QUOTE (AND STREAM (SATISFIES XCL:SYNONYM-STREAM-P))))
+
+(DEFTYPE CL:STRING-STREAM NIL (QUOTE (AND STREAM (SATISFIES XCL:STRING-STREAM-P))))
+
+(DEFTYPE CL:FILE-STREAM NIL (QUOTE (AND STREAM (SATISFIES CL::FILE-STREAM-P))))
+
+(DEFTYPE CL:TWO-WAY-STREAM NIL (QUOTE (AND STREAM (SATISFIES XCL:TWO-WAY-STREAM-P))))
+
+
+
+(IL:* IL:|;;;| "Fast predicates for typep")
+
+
+(XCL:DEF-DEFINE-TYPE TYPEP "Typep evaluator for a type")
+
+(XCL:DEFDEFINER DEFTYPEP TYPEP (NAME TYPE-ARGS OBJECT-ARG &BODY BODY) (IL:* IL:|;;;| "The comment below is not necessarily true for deftype, so until the PavCompiler groks deftype, leave the eval-when alone.") (IL:* IL:|;;| "The EVAL-WHEN below should be a PROGN as soon as the old ByteCompiler/COMPILE-FILE hack is done away with.  The PavCompiler understands DEFMACRO's correctly and doesn't side-effect the environment.") (UNLESS (AND NAME (SYMBOLP NAME)) (ERROR "Illegal name used in DEFTYPEP: ~S" NAME)) (MULTIPLE-VALUE-BIND (PARSED-BODY DECLS DOCSTRING) (IL:PARSE-DEFMACRO TYPE-ARGS (QUOTE SI::%$$TYPE-ARGS) BODY NAME NIL :DEFAULT-DEFAULT (QUOTE (QUOTE *)) :PATH (QUOTE SI::%$$TYPE-ARGS)) (LET ((TYPEP-NAME (XCL:PACK (LIST "typep-evaluate-" NAME) (SYMBOL-PACKAGE NAME)))) (IL:* IL:|;;| "the eval-when insures  that the functions in the hash table are always  compiled") (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, TYPEP-NAME))) (FUNCTION (LAMBDA (SI::%$$OBJECT &OPTIONAL SI::%$$TYPE-ARGS) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (LET (((IL:\\\, (CAR OBJECT-ARG)) SI::%$$OBJECT)) (IL:\\\, PARSED-BODY)))))) (SETF (GETHASH (QUOTE (IL:\\\, NAME)) *TYPEP-HASH-TABLE*) (QUOTE (IL:\\\, TYPEP-NAME))) (IL:\\\,@ (AND DOCSTRING (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE TYPEP)) (IL:\\\, DOCSTRING))))))) (EVAL-WHEN (EVAL) (IL:* IL:|;;| "With redefinition, clear the hash table") (SETF (GETHASH (QUOTE (IL:\\\, NAME)) *TYPEP-HASH-TABLE*) NIL)))))))
+
+(DEFTYPEP LIST (&OPTIONAL ELEMENT-TYPE) (OBJECT) (AND (LISTP OBJECT) (IF (EQ ELEMENT-TYPE (QUOTE *)) T (DOLIST (L OBJECT T) (IF (NOT (TYPEP L ELEMENT-TYPE)) (RETURN NIL))))))
+
+(DEFTYPEP SEQUENCE (&OPTIONAL ELEMENT-TYPE) (OBJECT) (AND (TYPEP OBJECT (QUOTE SEQUENCE)) (IF (EQ ELEMENT-TYPE (QUOTE *)) T (EVERY (FUNCTION (LAMBDA (S) (TYPEP S ELEMENT-TYPE))) OBJECT))))
+
+(DEFTYPEP MEMBER (&REST VALUES) (OBJECT) (MEMBER OBJECT VALUES))
+
+(DEFTYPEP ARRAY (&OPTIONAL ELEMENT-TYPE DIMS) (OBJECT) (IF (NOT (EQ ELEMENT-TYPE (QUOTE *))) (SETQ ELEMENT-TYPE (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))) (AND (ARRAYP OBJECT) (IF (EQ ELEMENT-TYPE (QUOTE *)) T (SUBTYPEP (ARRAY-ELEMENT-TYPE OBJECT) ELEMENT-TYPE)) (COND ((EQ DIMS (QUOTE *)) T) ((TYPEP DIMS (QUOTE FIXNUM)) (EQ (ARRAY-RANK OBJECT) DIMS)) (T (IL:* IL:|;;| "Must be a cons") (AND (EQ (ARRAY-RANK OBJECT) (LENGTH DIMS)) (DO ((I 0 (1+ I)) (D DIMS (CDR D))) ((NULL D) T) (IF (AND (TYPEP (CAR D) (QUOTE FIXNUM)) (NOT (EQ (ARRAY-DIMENSION OBJECT I) (CAR D)))) (RETURN NIL))))))))
+
+(DEFTYPEP SIMPLE-ARRAY (&OPTIONAL ELEMENT-TYPE DIMS) (OBJECT) (IF (NOT (EQ ELEMENT-TYPE (QUOTE *))) (SETQ ELEMENT-TYPE (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))) (AND (XCL:SIMPLE-ARRAY-P OBJECT) (IF (EQ ELEMENT-TYPE (QUOTE *)) T (EQUAL (ARRAY-ELEMENT-TYPE OBJECT) ELEMENT-TYPE)) (COND ((EQ DIMS (QUOTE *)) T) ((TYPEP DIMS (QUOTE FIXNUM)) (EQ (ARRAY-RANK OBJECT) DIMS)) (T (IL:* IL:|;;| "Must be a cons") (AND (EQ (ARRAY-RANK OBJECT) (LENGTH DIMS)) (DO ((I 0 (1+ I)) (D DIMS (CDR D))) ((NULL D) T) (IF (AND (TYPEP (CAR D) (QUOTE FIXNUM)) (NOT (EQ (ARRAY-DIMENSION OBJECT I) (CAR D)))) (RETURN NIL))))))))
+
+(DEFTYPEP VECTOR (&OPTIONAL ELEMENT-TYPE SIZE) (OBJECT) (IF (NOT (EQ ELEMENT-TYPE (QUOTE *))) (SETQ ELEMENT-TYPE (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))) (AND (VECTORP OBJECT) (IF (EQ ELEMENT-TYPE (QUOTE *)) T (EQUAL (ARRAY-ELEMENT-TYPE OBJECT) ELEMENT-TYPE)) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
+
+(DEFTYPEP SIMPLE-VECTOR (&OPTIONAL SIZE) (OBJECT) (AND (SIMPLE-VECTOR-P OBJECT) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
+
+(DEFTYPEP COMPLEX (&OPTIONAL TYPE) (OBJECT) (AND (COMPLEXP OBJECT) (IF (EQ TYPE (QUOTE *)) T (AND (TYPEP (REALPART OBJECT) TYPE) (TYPEP (IMAGPART OBJECT) TYPE)))))
+
+(DEFTYPEP INTEGER (&OPTIONAL LOW HIGH) (OBJECT) (AND (INTEGERP OBJECT) (COND ((EQ LOW (QUOTE *)) T) ((CONSP LOW) (> OBJECT (CAR LOW))) (T (>= OBJECT LOW))) (COND ((EQ HIGH (QUOTE *)) T) ((CONSP HIGH) (> (CAR HIGH) OBJECT)) (T (>= HIGH OBJECT)))))
+
+(DEFTYPEP MOD (&OPTIONAL N) (OBJECT) (AND (INTEGERP OBJECT) (>= OBJECT 0) (IF (EQ N (QUOTE *)) T (> N OBJECT))))
+
+(DEFTYPEP SIGNED-BYTE (&OPTIONAL S) (OBJECT) (AND (INTEGERP OBJECT) (IF (EQ S (QUOTE *)) T (LET ((BOUND (ASH 1 (1- S)))) (AND (>= OBJECT (- BOUND)) (> BOUND OBJECT))))))
+
+(DEFTYPEP UNSIGNED-BYTE (&OPTIONAL S) (OBJECT) (AND (INTEGERP OBJECT) (>= OBJECT 0) (IF (EQ S (QUOTE *)) T (> (ASH 1 S) OBJECT))))
+
+(DEFTYPEP RATIONAL (&OPTIONAL LOW HIGH) (OBJECT) (AND (RATIONALP OBJECT) (COND ((EQ LOW (QUOTE *)) T) ((CONSP LOW) (> OBJECT (CAR LOW))) (T (>= OBJECT LOW))) (COND ((EQ HIGH (QUOTE *)) T) ((CONSP HIGH) (> (CAR HIGH) OBJECT)) (T (>= HIGH OBJECT)))))
+
+(DEFTYPEP FLOAT (&OPTIONAL LOW HIGH) (OBJECT) (AND (FLOATP OBJECT) (COND ((EQ LOW (QUOTE *)) T) ((CONSP LOW) (> OBJECT (CAR LOW))) (T (>= OBJECT LOW))) (COND ((EQ HIGH (QUOTE *)) T) ((CONSP HIGH) (> (CAR HIGH) OBJECT)) (T (>= HIGH OBJECT)))))
+
+(DEFTYPEP STRING (&OPTIONAL SIZE) (OBJECT) (AND (STRINGP OBJECT) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
+
+(DEFTYPEP SIMPLE-STRING (&OPTIONAL SIZE) (OBJECT) (AND (SIMPLE-STRING-P OBJECT) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
+
+(DEFTYPEP BIT-VECTOR (&OPTIONAL SIZE) (OBJECT) (AND (BIT-VECTOR-P OBJECT) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
+
+(DEFTYPEP SIMPLE-BIT-VECTOR (&OPTIONAL SIZE) (OBJECT) (AND (SIMPLE-BIT-VECTOR-P OBJECT) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
+
+(DEFTYPEP EQL (CL::VALUE) (CL::OBJECT) (EQL CL::OBJECT CL::VALUE))
+
+(DEFTYPEP CL:REAL (&OPTIONAL CL::LOW CL::HIGH) (CL::OBJECT) (AND (OR (RATIONAL CL::OBJECT) (FLOATP CL::OBJECT)) (COND ((EQ CL::LOW (QUOTE *)) T) ((CONSP CL::LOW) (> CL::OBJECT (CAR CL::LOW))) (T (>= CL::OBJECT CL::LOW))) (COND ((EQ CL::HIGH (QUOTE *)) T) ((CONSP CL::HIGH) (> (CAR CL::HIGH) CL::OBJECT)) (T (>= CL::HIGH CL::OBJECT)))))
+
+
+
+(IL:* IL:|;;;| "for TYPE-OF Interlisp types that have different common Lisp names")
+
+
+(IL:PUTPROPS IL:CHARACTER CMLTYPE CHARACTER)
+
+(IL:PUTPROPS IL:FIXP CMLTYPE BIGNUM)
+
+(IL:PUTPROPS IL:FLOATP CMLTYPE SINGLE-FLOAT)
+
+(IL:PUTPROPS IL:GENERAL-ARRAY CMLTYPE ARRAY)
+
+(IL:PUTPROPS IL:LISTP CMLTYPE CONS)
+
+(IL:PUTPROPS IL:LITATOM CMLTYPE SYMBOL)
+
+(IL:PUTPROPS IL:ONED-ARRAY CMLTYPE ARRAY)
+
+(IL:PUTPROPS IL:SMALLP CMLTYPE FIXNUM)
+
+(IL:PUTPROPS IL:HARRAYP CMLTYPE HASH-TABLE)
+
+(IL:PUTPROPS IL:TWOD-ARRAY CMLTYPE ARRAY)
+
+(IL:PUTPROPS SYMBOL CMLSUBTYPE-DESCRIMINATOR SYMBOL-TYPE)
+
+(IL:PUTPROPS ARRAY CMLSUBTYPE-DESCRIMINATOR ARRAY-TYPE)
+
+
+
+(IL:* IL:|;;;| "tell the filepkg what to do with the type-expander property")
+
+
+(IL:PUTPROPS :TYPE-EXPANDER IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS IL:TYPE-EXPANDER IL:PROPTYPE IGNORE)
+
+
+
+(IL:* IL:|;;;| "Compiler options")
+
+
+(IL:PUTPROPS IL:CMLTYPES IL:FILETYPE COMPILE-FILE)
+
+(IL:PUTPROPS IL:CMLTYPES IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY 
+(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
+
+(IL:LOCALVARS . T)
+)
+)
+(IL:PUTPROPS IL:CMLTYPES IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1992 1993)
+)
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/CMLTYPES.LCOM b/CLTL2/CMLTYPES.LCOM
new file mode 100644
index 00000000..1fae0a49
Binary files /dev/null and b/CLTL2/CMLTYPES.LCOM differ
diff --git a/CLTL2/CMLUNDO b/CLTL2/CMLUNDO
new file mode 100644
index 00000000..d3c33a26
--- /dev/null
+++ b/CLTL2/CMLUNDO
@@ -0,0 +1,716 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
+(IL:FILECREATED "18-Oct-93 15:22:19" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLUNDO.;2" 33104  
+
+      IL:|previous| IL:|date:| "12-Feb-92 05:57:01" 
+"{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLUNDO.;1")
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CMLUNDOCOMS)
+
+(IL:RPAQQ IL:CMLUNDOCOMS
+          ((IL:VARIABLES *IN-DEFINER*)
+           (IL:FUNCTIONS NOHOOK UNDOABLY UNDOABLY-FMAKUNBOUND UNDOABLY-MAKUNBOUND UNDOABLY-SETF 
+                  UNDOHOOK UNDOABLY-PSETF UNDOABLY-POP UNDOABLY-PUSH UNDOABLY-PUSHNEW UNDOABLY-REMF 
+                  UNDOABLY-ROTATEF UNDOABLY-SHIFTF DEFINE-UNDOABLE-MODIFY-MACRO UNDOABLY-DECF 
+                  UNDOABLY-INCF UNDOABLY-PROCLAIM)
+           (IL:FUNCTIONS MAKE-UNDOABLE STOP-UNDOABLY)
+           (IL:FUNCTIONS UNDOABLY-SETF-SYMBOL-FUNCTION UNDOABLY-SETF-MACRO-FUNCTION 
+                  UNDOABLY-SET-SETF-METHOD-EXPANDER)
+           (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (IL:P (IL:MOVD 
+                                                                                     '
+                                                                        UNDOABLY-SETF-SYMBOL-FUNCTION
+                                                                                     
+                                                                                     '
+                                                                     IL:UNDOABLY-SETF-SYMBOL-FUNCTION
+                                                                                     )
+                                                                              (IL:MOVD 
+                                                                                     '
+                                                                         UNDOABLY-SETF-MACRO-FUNCTION
+                                                                                     
+                                                                                     '
+                                                                         UNDOABLY-SETF-MACRO-FUNCTION
+                                                                                     )))
+           (IL:ADDVARS (IL:LISPXFNS (PROCLAIM . UNDOABLY-PROCLAIM)
+                              (POP . UNDOABLY-POP)
+                              (PSETF . UNDOABLY-PSETF)
+                              (PUSH . UNDOABLY-PUSH)
+                              (PUSHNEW . UNDOABLY-PUSHNEW)
+                              ((REMF) . UNDOABLY-REMF)
+                              (ROTATEF . UNDOABLY-ROTATEF)
+                              (SHIFTF . UNDOABLY-SHIFTF)
+                              (DECF . UNDOABLY-DECF)
+                              (INCF . UNDOABLY-INCF)
+                              (SET . UNDOABLY-SET-SYMBOL)
+                              (MAKUNBOUND . UNDOABLY-MAKUNBOUND)
+                              (FMAKUNBOUND . UNDOABLY-FMAKUNBOUND)))
+           (IL:FUNCTIONS GET-UNDOABLE-SETF-METHOD UNDOABLY-SET-SYMBOL UNDOABLY-SET-FDEFINITION)
+           (IL:FNS UNDOABLY-SETQ)
+           (IL:SPECIAL-FORMS UNDOABLY UNDOABLY-SETQ)
+           (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (IL:P (IL:MOVD 
+                                                                                     '
+                                                                                  UNDOABLY-SET-SYMBOL
+                                                                                     
+                                                                                     '
+                                                                               IL:UNDOABLY-SET-SYMBOL
+                                                                                     )))
+           (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                  IL:CMLUNDO)
+           (IL:PROP :UNDOABLE-SETF-INVERSE SYMBOL-FUNCTION MACRO-FUNCTION FDEFINITION)
+           (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS
+                  (IL:ADDVARS (IL:NLAMA UNDOABLY-SETQ)
+                         (IL:NLAML)
+                         (IL:LAMA)))))
+
+(DEFVAR *IN-DEFINER* NIL)
+
+(DEFUN NOHOOK (FN ARGS &OPTIONAL ENV &AUX (*EVALHOOK* NIL))
+   (APPLY FN ARGS))
+
+(DEFMACRO UNDOABLY (&REST FORMS &ENVIRONMENT ENV)
+   (WALK-FORM
+    (IL:MKPROGN FORMS)
+    :ENVIRONMENT ENV :WALK-FUNCTION
+    #'(LAMBDA
+       (X CONTEXT)
+       (COND
+          ((NOT (CONSP X))
+           X)
+          ((NOT (SYMBOLP (CAR X)))
+           X)
+          (T
+           (CASE (CAR X)
+               ((SETQ SETQ SETF) 
+                  (VALUES
+                   (IL:MKPROGN
+                    (WITH-COLLECTION
+                     (DO ((TAIL (CDR X)
+                                (CDDR TAIL)))
+                         ((NULL TAIL))
+                       (COLLECT
+                        (IF (SYMBOLP (CAR TAIL))
+                            (IF (VARIABLE-LEXICAL-P (CAR TAIL))
+                                `(SETQ ,(CAR TAIL)
+                                       ,(WALK-FORM-INTERNAL (CADR TAIL)))
+                                (PROGN (WARN "Variable ~S presumed special in UNDOABLY.. SETQ"
+                                             (CAR TAIL))
+                                       `(UNDOABLY-SET-SYMBOL ',(CAR TAIL)
+                                               ,(WALK-FORM-INTERNAL (CADR TAIL)))))
+                            (MULTIPLE-VALUE-BIND
+                             (FORMALS ACTUALS NEW-VALUE SETTER GETTER)
+                             (GET-UNDOABLE-SETF-METHOD (CAR TAIL))
+                             (IF (NULL (CDR NEW-VALUE))
+                                 `(,'LET* (,@(MAPCAR #'(LAMBDA (X Y)
+                                                              (LIST X (WALK-FORM-INTERNAL Y)))
+                                                    FORMALS ACTUALS)
+                                           (,(WALK-FORM-INTERNAL (CAR NEW-VALUE))
+                                            ,(CADR TAIL)))
+                                         ,SETTER)
+
+                                 (IL:* IL:|;;| "It's one of those multiple-value jobbers...")
+
+                                 `(LET* (,@(MAPCAR #'(LAMBDA (X Y)
+                                                            (LIST X (WALK-FORM-INTERNAL Y)))
+                                                  FORMALS ACTUALS))
+                                        (MULTIPLE-VALUE-BIND ,(MAPCAR #'WALK-FORM-INTERNAL NEW-VALUE)
+                                               ,(CADR TAIL)
+                                               ,SETTER)))))))))
+                   T))
+               (STOP-UNDOABLY (VALUES (IL:MKPROGN (CDR X))
+                                     T))
+               (T (LET ((UNDONAME (CDR (MEMBER (CAR X)
+                                              IL:LISPXFNS :TEST #'EQ))))
+                       (IF UNDONAME
+                           (CONS UNDONAME (CDR X))
+                           (IF (AND (OR (GET (CAR X)
+                                             ':DEFINER-FOR)
+                                        (GET (CAR X)
+                                             'IL:DEFINER-FOR))
+                                    (NOT *IN-DEFINER*))
+                               (LET ((*IN-DEFINER* T))
+                                    (VALUES (WALK-FORM-INTERNAL (MACROEXPAND-1 X))
+                                           T))
+                               X))))))))))
+
+(DEFUN UNDOABLY-FMAKUNBOUND (SYMBOL)
+   (IL:/PUTD SYMBOL NIL)
+   (IL:/REMPROP SYMBOL 'IL:MACRO-FN)
+   (IL:/REMPROP SYMBOL 'IL:SPECIAL-FORM)
+   (IL:/REMPROP SYMBOL 'IL:CODE)
+   (IL:/REMPROP SYMBOL 'IL:EXPR)
+   SYMBOL)
+
+(DEFUN UNDOABLY-MAKUNBOUND (SYMBOL)
+
+   (IL:* IL:|;;| "Make a symbol unbound.")
+
+   (IL:SAVESET SYMBOL 'IL:NOBIND)                            (IL:* IL:\; 
+                                                           " unbound symbols are set to IL:NOBIND")
+   (IL:/PUTHASH SYMBOL NIL IL:COMPVARMACROHASH)              (IL:* IL:\; 
+                                                           "remove any constant entry")
+   (IL:/REMPROP SYMBOL 'IL:GLOBALLY-SPECIAL)                 (IL:* IL:\; 
+                                                           " left by PROCLAIM special")
+   (IL:/REMPROP SYMBOL 'IL:GLOBALVAR)                        (IL:* IL:\; "")
+   SYMBOL)
+
+(DEFMACRO UNDOABLY-SETF (PLACE NEW-VALUE &ENVIRONMENT ENV)
+   "UNDOable version of SETF"
+
+   (IL:* IL:|;;| "note that this is a \"one-shot\", in that (UNDOABLY (SETF (CDR (RPLACA X Y)) Z) will make the RPLACA undoable, but (UNDOABLY-SETF (CDR (RPLACA X Y)) Z) will not")
+
+   (COND
+      ((SYMBOLP PLACE)
+
+       (IL:* IL:|;;| "assumes variable is not lexical !")
+
+       `(UNDOABLY-SET-SYMBOL ',PLACE ,NEW-VALUE))
+      (T (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
+                (GET-UNDOABLE-SETF-METHOD PLACE ENV)
+                (IF (NULL (CDR NEWVAL))
+                    `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
+                              (,(CAR NEWVAL)
+                               ,NEW-VALUE))
+                            ,SETTER)
+
+                    (IL:* IL:|;;| "It's one of those multiple-value jobbers...")
+
+                    `(LET* (,@(MAPCAR #'LIST DUMMIES VALS))
+                           (MULTIPLE-VALUE-BIND ,NEWVAL ,NEW-VALUE ,SETTER)))))))
+
+(DEFUN UNDOHOOK (FORM ENV &AUX (*APPLYHOOK* NIL))        (IL:* IL:\; 
+                                                           "Edited 10-Feb-92 12:15 by jrb:")
+   (IF (ATOM FORM)
+       (EVAL FORM ENV)
+       (CASE (CAR FORM)
+           ((SETQ SETQ SETF) 
+
+              (IL:* IL:|;;| "The following mess is to insure that the evaluation of the last pair gets returned as the value of the form immediately, so any multiple-values generated by it get back to the top level.")
+
+              (LET
+               ((TAIL (CDR FORM)))
+               (FLET
+                ((SET-IT-UNDOABLY
+                  NIL
+                  (IF (SYMBOLP (CAR TAIL))
+                      (UNDOABLY-SET-SYMBOL (POP TAIL)
+                             (UNDOHOOK (POP TAIL)
+                                    ENV)
+                             ENV)
+                      (EVAL
+
+                       (IL:* IL:|;;| "real cop-out , just to EVAL of making it undoable ")
+
+                       (MULTIPLE-VALUE-BIND
+                        (FORMALS VALS NEW-VALUE SETTER GETTER)
+                        (GET-UNDOABLE-SETF-METHOD (POP TAIL)
+                               ENV)
+                        (IF (NULL (CDR NEW-VALUE))
+                            `(LET* (,@(MAPCAR #'(LAMBDA (X Y)
+                                                       (LIST X (LIST 'UNDOABLY Y)))
+                                             FORMALS VALS)
+                                    (,(CAR NEW-VALUE)
+                                     (UNDOABLY ,(POP TAIL))))
+                                   ,SETTER)
+
+                            (IL:* IL:|;;| "It's one of those multiple-value jobbers...")
+
+                            `(LET* (,@(MAPCAR #'(LAMBDA (X Y)
+                                                       (LIST X (LIST 'UNDOABLY Y)))
+                                             FORMALS VALS))
+                                   (MULTIPLE-VALUE-BIND ,NEW-VALUE (UNDOABLY ,(POP TAIL))
+                                          ,SETTER))))
+                       ENV))))
+                (DO NIL
+                    ((NULL (CDDR TAIL))
+                     (SET-IT-UNDOABLY))
+                  (SET-IT-UNDOABLY)))))
+           (STOP-UNDOABLY 
+
+              (IL:* IL:|;;| "special signal to not undo")
+
+              (IL:\\EVAL-PROGN (CDR FORM)
+                     ENV))
+           (T (LET ((UNDONAME (CDR (MEMBER (CAR FORM)
+                                          IL:LISPXFNS :TEST #'EQ))))
+                   (IF UNDONAME
+                       (EVALHOOK (CONS UNDONAME (CDR FORM))
+                              'UNDOHOOK
+                              'NOHOOK ENV)
+                       (EVALHOOK FORM 'UNDOHOOK 'NOHOOK ENV)))))))
+
+(DEFMACRO UNDOABLY-PSETF (&REST ARGS &ENVIRONMENT ENV)
+
+   (IL:* IL:|;;| "parallel version of UNDOABLY-SETF - simple minded version")
+
+   (COND
+      ((NULL ARGS)
+       NIL)
+      (T `(PROG1 NIL
+              (UNDOABLY-SETF ,(POP ARGS)
+                     (PROG1 ,(POP ARGS)
+                         (UNDOABLY-PSETF ,@ARGS)))))))
+
+(DEFMACRO UNDOABLY-POP (PLACE &ENVIRONMENT ENV)
+   (IF (SYMBOLP PLACE)
+       `(PROG1 (CAR ,PLACE)
+            (UNDOABLY-SETQ ,PLACE (CDR ,PLACE)))
+       (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
+              (GET-UNDOABLE-SETF-METHOD PLACE ENV)
+              `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
+                        ,(LIST (CAR NEWVAL)
+                               GETTER))
+                      (PROG1 (CAR ,(CAR NEWVAL))
+                          (SETQ ,(CAR NEWVAL)
+                                (CDR ,(CAR NEWVAL)))
+                          ,SETTER)))))
+
+(DEFMACRO UNDOABLY-PUSH (OBJ PLACE &ENVIRONMENT ENV)
+
+   (IL:* IL:|;;| "Takes an object and a location holding a list.  Conses the object onto PLACE returning then modified list.")
+
+   (IF (SYMBOLP PLACE)
+       `(UNDOABLY-SETQ ,PLACE (CONS ,OBJ ,PLACE))
+       (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
+              (GET-UNDOABLE-SETF-METHOD PLACE ENV)
+              `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
+                        (,(CAR NEWVAL)
+                         (CONS ,OBJ ,GETTER)))
+                      ,SETTER))))
+
+(DEFMACRO UNDOABLY-PUSHNEW (OBJ PLACE &REST KEYS &ENVIRONMENT ENV)
+   (IF (SYMBOLP PLACE)
+       `(UNDOABLY-SETQ ,PLACE (ADJOIN ,OBJ ,PLACE ,@KEYS))
+       (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
+              (GET-UNDOABLE-SETF-METHOD PLACE ENV)
+              `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
+                        (,(CAR NEWVAL)
+                         (ADJOIN ,OBJ ,GETTER ,@KEYS)))
+                      ,SETTER))))
+
+(DEFMACRO UNDOABLY-REMF (PLACE INDICATOR &ENVIRONMENT ENV)
+   (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
+          (GET-UNDOABLE-SETF-METHOD PLACE ENV)
+          (LET ((IND-TEMP (GENSYM))
+                (LOCAL1 (GENSYM))
+                (LOCAL2 (GENSYM)))
+               `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
+                         (,(CAR NEWVAL)
+                          ,GETTER)
+                         (,IND-TEMP ,INDICATOR))
+                       (DO ((,LOCAL1 ,(CAR NEWVAL)
+                                   (CDDR ,LOCAL1))
+                            (,LOCAL2 NIL ,LOCAL1))
+                           ((ATOM ,LOCAL1)
+                            NIL)
+                         (COND
+                            ((ATOM (CDR ,LOCAL1))
+                             (ERROR "Odd-length property list in REMF."))
+                            ((EQ (CAR ,LOCAL1)
+                                 ,IND-TEMP)
+                             (COND
+                                (,LOCAL2 (IL:/RPLACD (CDR ,LOCAL2)
+                                                (CDDR ,LOCAL1))
+                                       (RETURN T))
+                                (T (SETQ ,(CAR NEWVAL)
+                                         (CDDR ,(CAR NEWVAL)))
+                                   ,SETTER
+                                   (RETURN T))))))))))
+
+(DEFMACRO UNDOABLY-ROTATEF (&REST ARGS &ENVIRONMENT ENV)
+
+   (IL:* IL:|;;| 
+ "Assigns to each place the value of the form to its right; last gets first. Returns NIL.")
+
+   (IL:* IL:|;;| "forms evaluated in order")
+
+   (COND
+      ((NULL ARGS)
+       NIL)
+      ((NULL (CDR ARGS))
+       `(PROGN ,(CAR ARGS)
+               NIL))
+      (T (LISP::ROTATEF-INTERNAL ARGS ENV 'GET-UNDOABLE-SETF-METHOD))))
+
+(DEFMACRO UNDOABLY-SHIFTF (&REST ARGS &ENVIRONMENT ENV)
+   (COND
+      ((OR (NULL ARGS)
+           (NULL (CDR ARGS)))
+       (ERROR "SHIFTF needs at least two arguments"))
+      (T (LISP::SHIFTF-INTERNAL ARGS ARGS 'GET-UNDOABLE-SETF-METHOD))))
+
+(DEFDEFINER DEFINE-UNDOABLE-MODIFY-MACRO IL:FUNCTIONS (NAME LAMBDA-LIST FUNCTION &OPTIONAL 
+                                                                DOC-STRING)
+   (LET
+    ((OTHER-ARGS NIL)
+     (REST-ARG NIL))
+    (DO ((LL LAMBDA-LIST (CDR LL))
+         (ARG NIL))
+        ((NULL LL))
+      (SETQ ARG (CAR LL))
+      (COND
+         ((EQ ARG '&OPTIONAL))
+         ((EQ ARG '&REST)
+          (SETQ REST-ARG (CADR LL))
+          (RETURN NIL))
+         ((SYMBOLP ARG)
+          (PUSH ARG OTHER-ARGS))
+         (T (PUSH (CAR ARG)
+                  OTHER-ARGS))))
+    (SETQ OTHER-ARGS (REVERSE OTHER-ARGS))
+    `(DEFMACRO ,NAME (SI::%$$MODIFY-MACRO-FORM ,@LAMBDA-LIST &ENVIRONMENT 
+                            SI::%$$MODIFY-MACRO-ENVIRONMENT)
+        ,DOC-STRING (MULTIPLE-VALUE-BIND
+                     (DUMMIES VALS NEWVAL SETTER GETTER)
+                     (GET-UNDOABLE-SETF-METHOD SI::%$$MODIFY-MACRO-FORM 
+                            SI::%$$MODIFY-MACRO-ENVIRONMENT)
+                     (MULTIPLE-VALUE-BIND
+                      (DUMMIES VALS NEWVALS SETTER GETTER)
+                      (GET-SETF-METHOD SI::%$$MODIFY-MACRO-FORM SI::%$$MODIFY-MACRO-ENVIRONMENT)
+                      `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
+                                (,(CAR NEWVALS)
+                                 ,,(IF REST-ARG
+                                       `(LIST* ',FUNCTION GETTER ,@OTHER-ARGS ,REST-ARG)
+                                       `(LIST ',FUNCTION GETTER ,@OTHER-ARGS))))
+                              ,SETTER))))))
+
+(DEFINE-UNDOABLE-MODIFY-MACRO UNDOABLY-DECF (&OPTIONAL (DELTA 1))
+                                                -)
+
+(DEFINE-UNDOABLE-MODIFY-MACRO UNDOABLY-INCF (&OPTIONAL (DELTA 1))
+                                                +)
+
+(DEFUN UNDOABLY-PROCLAIM (PROCLAMATION)
+
+   (IL:* IL:|;;| "Undoable version of PROCLAIM.")
+
+   (WHEN (CONSP PROCLAMATION)
+       (CASE (CAR PROCLAMATION)
+           (SPECIAL (DOLIST (X (CDR PROCLAMATION))
+                        (UNDOABLY (SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X)
+                                            T)
+                               (SETF (IL:VARIABLE-GLOBAL-P X)
+                                     NIL)
+                               (SETF (CONSTANTP X)
+                                     NIL))))
+           (GLOBAL (DOLIST (X (CDR PROCLAMATION))
+                       (UNDOABLY (SETF (IL:VARIABLE-GLOBAL-P X)
+                                           T)
+                              (SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X)
+                                    NIL)
+                              (SETF (CONSTANTP X)
+                                    NIL))))
+           (SI::CONSTANT (DOLIST (X (CDR PROCLAMATION))
+                             (UNDOABLY (SETF (CONSTANTP X)
+                                                 T)
+                                    (SETF (IL:VARIABLE-GLOBAL-P X)
+                                          NIL)
+                                    (SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X)
+                                          NIL))))
+           (DECLARATION (DOLIST (X (CDR PROCLAMATION))
+                            (UNDOABLY (SETF (DECL-SPECIFIER-P X)
+                                                T))))
+           (NOTINLINE (DOLIST (X (CDR PROCLAMATION))
+                          (UNDOABLY (SETF (GLOBALLY-NOTINLINE-P X)
+                                              T))))
+           (INLINE (DOLIST (X (CDR PROCLAMATION))
+                       (UNDOABLY (SETF (GLOBALLY-NOTINLINE-P X)
+                                           NIL)))))))
+
+(DEFUN MAKE-UNDOABLE (FORM &OPTIONAL ENV)
+   (LIST 'UNDOABLY FORM))
+
+(DEFMACRO STOP-UNDOABLY (&REST FORMS)
+
+   (IL:* IL:|;;| "evaluate forms -- inside UNDOABLY, stops transformation")
+
+   (IL:MKPROGN FORMS))
+
+(DEFUN UNDOABLY-SETF-SYMBOL-FUNCTION (SYMBOL DEFINITION)
+
+   (IL:* IL:|;;| 
+ "NOTE:  If you change this version, be sure to change the not-undoable version on LLSYMBOL!")
+
+   (IL:* IL:|;;| " undoable inverse of SYMBOL-FUNCTION")
+
+   (IL:VIRGINFN SYMBOL T)
+   (COND
+      ((CONSP DEFINITION)
+
+       (IL:* IL:|;;| "Either it's a LAMBDA form or one of the special lists put together by SYMBOL-FUNCTION for macros and special forms.")
+
+       (CASE (CAR DEFINITION)
+           (:MACRO (UNDOABLY-SETF (MACRO-FUNCTION SYMBOL)
+                          (CDR DEFINITION)))
+           (:SPECIAL-FORM (UNDOABLY-SETF (GET SYMBOL 'IL:SPECIAL-FORM)
+                                 (CDR DEFINITION)))
+           (T (IL:/PUTD SYMBOL DEFINITION T))))
+
+      (IL:* IL:|;;| "If it's (SETF (SYMBOL-FUNCTION 'FOO) 'BAR) then we give FOO the same definition as BAR.  This isn't quite like Lucid and Symbolics, but it will do for now.")
+
+      ((AND (SYMBOLP DEFINITION)
+            (NOT (NULL DEFINITION)))
+       (IL:/PUTD SYMBOL (IL:GETD DEFINITION)
+              T))
+
+      (IL:* IL:|;;| "It's probably a compiled-code object or an interpreted closure.  In any case, go ahead and put it in there; if it's illegal, we'll find out when we try to apply it.")
+
+      (T (IL:/PUTD SYMBOL DEFINITION T)))
+
+   (IL:* IL:|;;| "(SETF (SYMBOL-FUNCTION ...) ...) is supposed to remove macro definitions.  We only remove the ones that could come from DEFMACRO.")
+
+   (UNLESS (OR (NULL DEFINITION)
+               (AND (CONSP DEFINITION)
+                    (EQ (CAR DEFINITION)
+                        :MACRO)))
+       (IL:/REMPROP SYMBOL 'IL:MACRO-FN))
+   DEFINITION)
+
+(DEFUN UNDOABLY-SETF-MACRO-FUNCTION (X BODY)
+
+   (IL:* IL:|;;| "undoable setf of macro-function")
+
+   (IL:* IL:|;;| 
+ "NOTE:  If you change this, be sure to change the not-undoable version on CMLMACROS!")
+
+   (PROG1 (UNDOABLY-SETF (GET X 'IL:MACRO-FN)
+                 BODY)
+       (AND (IL:GETD X)
+            (CASE (IL:ARGTYPE X)
+                ((1 3)                                       (IL:* IL:\; 
+                                                         "Leave Interlisp nlambda definition alone")
+)
+                (OTHERWISE (IL:/PUTD X NIL))))))
+
+(DEFUN UNDOABLY-SET-SETF-METHOD-EXPANDER (NAME EXPANDER)
+
+   (IL:* IL:|;;| "If you change this, change the normal version on SETF-RUNTIME too.")
+
+   (IL:/REMPROP NAME 'IL:SETF-INVERSE)
+   (IL:/REMPROP NAME ':SETF-INVERSE)
+   (IL:/REMPROP NAME ':SHARED-SETF-INVERSE)
+   (UNDOABLY-SETF (GET NAME ':SETF-METHOD-EXPANDER)
+          EXPANDER))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY 
+
+(IL:MOVD 'UNDOABLY-SETF-SYMBOL-FUNCTION 'IL:UNDOABLY-SETF-SYMBOL-FUNCTION)
+
+(IL:MOVD 'UNDOABLY-SETF-MACRO-FUNCTION 'UNDOABLY-SETF-MACRO-FUNCTION)
+)
+
+(IL:ADDTOVAR IL:LISPXFNS (PROCLAIM . UNDOABLY-PROCLAIM)
+                             (POP . UNDOABLY-POP)
+                             (PSETF . UNDOABLY-PSETF)
+                             (PUSH . UNDOABLY-PUSH)
+                             (PUSHNEW . UNDOABLY-PUSHNEW)
+                             ((REMF) . UNDOABLY-REMF)
+                             (ROTATEF . UNDOABLY-ROTATEF)
+                             (SHIFTF . UNDOABLY-SHIFTF)
+                             (DECF . UNDOABLY-DECF)
+                             (INCF . UNDOABLY-INCF)
+                             (SET . UNDOABLY-SET-SYMBOL)
+                             (MAKUNBOUND . UNDOABLY-MAKUNBOUND)
+                             (FMAKUNBOUND . UNDOABLY-FMAKUNBOUND))
+
+(DEFUN GET-UNDOABLE-SETF-METHOD (FORM &OPTIONAL ENVIRONMENT &AUX TEMP)
+                                                             (IL:* IL:\; 
+                                                           "Edited  6-Feb-92 16:07 by jrb:")
+   (COND
+      ((SYMBOLP FORM)
+       (VALUES NIL NIL (LIST (SETQ TEMP (GENSYM)))
+              `(IL:UNDOABLY-SET-SYMBOL ',FORM ,TEMP)
+              FORM))
+      ((NOT (CONSP FORM))
+       (LISP::SETF-ERROR FORM))
+      ((SETQ TEMP (IL:LOCAL-MACRO-FUNCTION (CAR FORM)
+                         ENVIRONMENT))
+
+       (IL:* IL:|;;| "always expand local macros")
+
+       (GET-UNDOABLE-SETF-METHOD (FUNCALL TEMP FORM ENVIRONMENT)
+              ENVIRONMENT))
+      ((SETQ TEMP (GET (CAR FORM)
+                       ':UNDOABLE-SETF-INVERSE))
+
+       (IL:* IL:|;;| "found a special undoable property -- use it")
+
+       (LISP::GET-SIMPLE-SETF-METHOD FORM TEMP))
+      (T (BLOCK DONE
+             (MULTIPLE-VALUE-BIND
+              (DUMMIES VALS NEWVAL SETTER GETTER)
+              (COND
+                 ((SETQ TEMP (OR (GET (CAR FORM)
+                                      ':SETF-INVERSE)
+                                 (GET (CAR FORM)
+                                      'IL:SETF-INVERSE)
+                                 (GET (CAR FORM)
+                                      'IL:SETFN)))
+                  (LISP::GET-SIMPLE-SETF-METHOD FORM TEMP))
+                 ((SETQ TEMP (GET (CAR FORM)
+                                  ':SHARED-SETF-INVERSE))
+                  (LISP::GET-SHARED-SETF-METHOD FORM TEMP))
+                 ((SETQ TEMP (OR (GET (CAR FORM)
+                                      ':SETF-METHOD-EXPANDER)
+                                 (GET (CAR FORM)
+                                      'IL:SETF-METHOD-EXPANDER)))
+                  (FUNCALL TEMP FORM ENVIRONMENT))
+                 (T (MULTIPLE-VALUE-BIND (MAC MORE)
+                           (MACROEXPAND-1 FORM ENVIRONMENT)
+                           (IF (AND MORE (NOT (EQ MAC FORM)))
+                               (RETURN-FROM DONE (GET-UNDOABLE-SETF-METHOD MAC ENVIRONMENT))
+                               (LISP::DEFUN-SETF-METHOD FORM ENVIRONMENT)))))
+
+              (IL:* IL:|;;| 
+            "this is lexically correct, but doesn't work in bytecompiler, interlisp")
+
+              (IL:* IL:|;;| "(cl:values dummies vals newval `(cl:labels ((undostore (,@newval) (undosave (list #'undostore ,getter)) ,setter)) (undostore ,@newval)) getter)")
+
+              (IL:* IL:|;;| "so, instead we do the following, which binds the dummies too so that there are no free references. LABELS is used because the thing saved on the undo list is also saved when the UNDO is undefined.")
+
+              (IL:* IL:|;;| " ")
+
+              (VALUES DUMMIES VALS NEWVAL
+                     (IF (NULL (CDR NEWVAL))
+                         `(IL:COMMON-LISP (LABELS ((UNDOSTORE (,@DUMMIES ,@NEWVAL)
+                                                          (IL:UNDOSAVE (LIST #'UNDOSTORE ,@DUMMIES
+                                                                             ,GETTER))
+                                                          ,SETTER))
+                                                 (UNDOSTORE ,@DUMMIES ,@NEWVAL)))
+
+                         (IL:* IL:|;;| "It's one of those multiple-value jobbers...")
+
+                         `(IL:COMMON-LISP (LABELS ((UNDOSTORE (,@DUMMIES ,@NEWVAL)
+                                                          (IL:UNDOSAVE (LIST* #'UNDOSTORE
+                                                                              ,@DUMMIES
+                                                                              (MULTIPLE-VALUE-LIST
+                                                                               ,GETTER)))
+                                                          ,SETTER))
+                                                 (UNDOSTORE ,@DUMMIES ,@NEWVAL))))
+                     GETTER))))))
+
+(DEFUN UNDOABLY-SET-SYMBOL (SYMBOL VALUE &OPTIONAL ENVIRONMENT)
+   (BLOCK UNDOABLY-SET-SYMBOL
+       (WHEN ENVIRONMENT
+
+           (IL:* IL:|;;| 
+         "This function only saves undo info when there is no lexical binding for the variable.")
+
+           (SETQ ENVIRONMENT (IL:ENVIRONMENT-VARS ENVIRONMENT))
+           (LOOP (IF (NULL ENVIRONMENT)
+                     (RETURN NIL))
+                 (IF (EQ SYMBOL (CAR ENVIRONMENT))
+
+                     (IL:* IL:|;;| "found a binding for this symbol")
+
+                     (PROGN (IF (EQ (CAR (SETQ ENVIRONMENT (CDR ENVIRONMENT)))
+                                    IL:*SPECIAL-BINDING-MARK*)
+
+                                (IL:* IL:|;;| 
+                           "it is a special binding, or a mark that we are using the special value")
+
+                                (RETURN NIL)                 (IL:* IL:\; "return from WHILE")
+                                )
+                            (RPLACA ENVIRONMENT VALUE)
+
+                            (IL:* IL:|;;| "smash new value in")
+
+                            (RETURN-FROM UNDOABLY-SET-SYMBOL VALUE))
+                     (SETQ ENVIRONMENT (CDDR ENVIRONMENT)))))
+
+       (IL:* IL:|;;| "no environment, or not found.  ")
+
+       (LET
+        ((VP (IL:\\STKSCAN SYMBOL)))
+        (COND
+           ((EQ (IL:\\HILOC VP)
+                IL:\\STACKHI)
+            (IL:\\PUTBASEPTR VP 0 VALUE))
+           (T (WHEN (CONSTANTP SYMBOL)
+                  (UNLESS (EQL VALUE (IL:GETTOPVAL SYMBOL))
+                         (CERROR "Go ahead and set it" "Attempt to set constant ~S to ~S" SYMBOL 
+                                VALUE)))
+              (LET ((OLDVAL (IL:\\GETBASEPTR VP 0))
+                    TEM)
+                   (UNLESS (OR (NULL IL:LISPXHIST)
+                               (AND (SETQ TEM (SOME #'(LAMBDA (X)
+                                                             (AND (CONSP X)
+                                                                  (EQ (CAR X)
+                                                                      'IL:/SETTOPVAL)
+                                                                  (EQ (CADR X)
+                                                                      SYMBOL)))
+                                                    (IL:LISTGET1 IL:LISPXHIST 'IL:SIDE)))
+                                    (NOT (TAILP TEM (IL:LISTP IL:UNDOSIDE0)))))
+
+                       (IL:* IL:|;;| "special optimization from Interlisp: don't save more than one assignment of the same variable in the same event(!)")
+
+                       (IL:UNDOSAVE (LIST 'IL:/SETTOPVAL SYMBOL OLDVAL))))
+              (IL:\\RPLPTR VP 0 VALUE))))))
+
+(DEFUN UNDOABLY-SET-FDEFINITION (FUNCTION-NAME NEWVALUE)
+
+   (IL:* IL:|;;| "If you change this, be sure to change the normal version on LLSYMBOL")
+
+   (IF (LISP::SETF-NAME-P FUNCTION-NAME)
+       (LET* ((REAL-NAME (SECOND FUNCTION-NAME))
+              (DEFUN-SETF-NAME (DEFUN-SETF-NAME REAL-NAME)))
+
+             (IL:* IL:|;;| "We smash the SYMBOL-FUNCTION of DEFUN-SETF-NAME rather than just changing the :SETF-DEFUN property to insure the SETF function's having a consistent name")
+
+             (UNDOABLY-SETF (GET REAL-NAME :SETF-DEFUN)
+                    DEFUN-SETF-NAME)
+             (UNDOABLY-SETF (SYMBOL-FUNCTION DEFUN-SETF-NAME)
+                    NEWVALUE))
+       (UNDOABLY-SETF-SYMBOL-FUNCTION FUNCTION-NAME NEWVALUE))
+   NEWVALUE)
+(IL:DEFINEQ
+
+(UNDOABLY-SETQ
+  (IL:NLAMBDA VARVALUE                                       (IL:* IL:\; 
+                                                           "Edited  8-Oct-87 18:54 by jop")
+                                                             (IL:* IL:\; "Interlisp version")
+    (UNDOABLY-SET-SYMBOL (CAR VARVALUE)
+           (IL:\\EVPROG1 (CDR VARVALUE)))))
+)
+
+(DEFINE-SPECIAL-FORM UNDOABLY (&REST FORMS &ENVIRONMENT ENV)
+   (LOOP (IF (NULL (CDR FORMS))
+             (RETURN (UNDOHOOK (CAR FORMS)
+                            ENV))
+             (UNDOHOOK (POP FORMS)
+                    ENV))))
+
+(DEFINE-SPECIAL-FORM UNDOABLY-SETQ (&REST TAIL &ENVIRONMENT ENV)
+   (LET (VALUE)
+        (LOOP (IF (NULL TAIL)
+                  (RETURN NIL)
+                  (SETQ VALUE (UNDOABLY-SET-SYMBOL (POP TAIL)
+                                     (EVAL (POP TAIL)
+                                           ENV)
+                                     ENV))))
+        VALUE))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY 
+
+(IL:MOVD 'UNDOABLY-SET-SYMBOL 'IL:UNDOABLY-SET-SYMBOL)
+)
+
+(IL:PUTPROPS IL:CMLUNDO IL:FILETYPE :COMPILE-FILE)
+
+(IL:PUTPROPS IL:CMLUNDO IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL"))
+
+(IL:PUTPROPS SYMBOL-FUNCTION :UNDOABLE-SETF-INVERSE UNDOABLY-SETF-SYMBOL-FUNCTION)
+
+(IL:PUTPROPS MACRO-FUNCTION :UNDOABLE-SETF-INVERSE UNDOABLY-SETF-MACRO-FUNCTION)
+
+(IL:PUTPROPS FDEFINITION :UNDOABLE-SETF-INVERSE UNDOABLY-SET-FDEFINITION)
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA UNDOABLY-SETQ)
+
+(IL:ADDTOVAR IL:NLAML )
+
+(IL:ADDTOVAR IL:LAMA )
+)
+(IL:PUTPROPS IL:CMLUNDO IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 1993))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL (31241 31634 (UNDOABLY-SETQ 31254 . 31632)))))
+IL:STOP
diff --git a/CLTL2/CMLUNDO.DFASL b/CLTL2/CMLUNDO.DFASL
new file mode 100644
index 00000000..da99b14d
Binary files /dev/null and b/CLTL2/CMLUNDO.DFASL differ
diff --git a/CLTL2/CMLWALK b/CLTL2/CMLWALK
new file mode 100644
index 00000000..b8a8d3bf
--- /dev/null
+++ b/CLTL2/CMLWALK
@@ -0,0 +1,560 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 15:25:46" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLWALK.;2" 27482  
+
+      previous date%: " 3-Sep-91 17:53:09" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLWALK.;1")
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLWALKCOMS)
+
+(RPAQQ CMLWALKCOMS
+       [(FUNCTIONS XCL:ONCE-ONLY)
+                                                             (* ; 
+                       "not a wonderful place for it, but CMLMACROS comes too eraly in the loadup.")
+        (VARIABLES *WALK-FUNCTION* *WALK-FORM* *DECLARATIONS* *LEXICAL-VARIABLES* *ENVIRONMENT* 
+               *WALK-COPY*)
+        (FUNCTIONS WITH-NEW-CONTOUR NOTE-LEXICAL-BINDING NOTE-DECLARATION)
+        (FUNCTIONS VARIABLE-SPECIAL-P VARIABLE-LEXICAL-P GET-WALKER-TEMPLATE)
+        (FUNCTIONS WALK-FORM)
+        (FNS WALK-FORM-INTERNAL WALK-TEMPLATE WALK-TEMPLATE-HANDLE-REPEAT 
+             WALK-TEMPLATE-HANDLE-REPEAT-1 WALK-LIST WALK-RECONS)
+        (FUNCTIONS WALK-RELIST*)
+        (FNS WALK-DECLARATIONS WALK-ARGLIST WALK-LAMBDA)
+        (COMS (PROP WALKER-TEMPLATE LISP:COMPILER-LET)
+              (FNS WALK-COMPILER-LET)
+              (PROP WALKER-TEMPLATE DECLARE)
+              (FNS WALK-UNEXPECTED-DECLARE)
+              (PROP WALKER-TEMPLATE LET PROG LET* PROG*)
+              (FNS WALK-LET WALK-LET* WALK-LET/LET*)
+              (PROP WALKER-TEMPLATE LISP:TAGBODY)
+              (FNS WALK-TAGBODY)
+              (PROP WALKER-TEMPLATE FUNCTION LISP:FUNCTION GO LISP:IF LISP:MULTIPLE-VALUE-CALL 
+                    LISP:MULTIPLE-VALUE-PROG1 PROGN LISP:PROGV QUOTE LISP:RETURN-FROM RETURN 
+                    LISP:SETQ LISP:BLOCK LISP:CATCH LISP:EVAL-WHEN THE LISP:THROW LISP:UNWIND-PROTECT
+                    LOAD-TIME-EVAL COND LISP:UNWIND-PROTECT SETQ AND OR))
+        (COMS 
+              (* ;; "for Interlisp")
+
+              (PROP WALKER-TEMPLATE RPAQ? RPAQ XNLSETQ ERSETQ NLSETQ RESETVARS))
+        (PROP FILETYPE CMLWALK)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML)
+                      (LAMA WALK-TAGBODY WALK-LET/LET* WALK-LET* WALK-LET WALK-UNEXPECTED-DECLARE 
+                            WALK-COMPILER-LET WALK-LAMBDA WALK-ARGLIST WALK-DECLARATIONS WALK-RECONS
+                            WALK-TEMPLATE-HANDLE-REPEAT-1 WALK-TEMPLATE-HANDLE-REPEAT WALK-TEMPLATE 
+                            WALK-FORM-INTERNAL])
+
+(DEFMACRO XCL:ONCE-ONLY (XCL::VARS &BODY XCL::BODY)
+
+(* ;;; "ONCE-ONLY assures that the forms given as vars are evaluated in the proper order, once only. Used in the body of macro definitions. Taken from Zeta Lisp.")
+
+   [LET* [(XCL::GENSYM-VAR (LISP:GENSYM))
+          (XCL::RUN-TIME-VARS (LISP:GENSYM))
+          (XCL::RUN-TIME-VALS (LISP:GENSYM))
+          (XCL::EXPAND-TIME-VAL-FORMS (FOR XCL::VAR IN XCL::VARS
+                                         COLLECT `(LISP:IF (OR (LISP:SYMBOLP ,XCL::VAR)
+                                                                   (LISP:CONSTANTP ,XCL::VAR))
+                                                          ,XCL::VAR
+                                                          (LET ((,XCL::GENSYM-VAR (LISP:GENSYM)))
+                                                               (LISP:PUSH ,XCL::GENSYM-VAR
+                                                                      ,XCL::RUN-TIME-VARS)
+                                                               (LISP:PUSH ,XCL::VAR 
+                                                                      ,XCL::RUN-TIME-VALS)
+                                                               ,XCL::GENSYM-VAR))]
+         `(LET* [,XCL::RUN-TIME-VARS ,XCL::RUN-TIME-VALS
+                       (XCL::WRAPPED-BODY (LET ,(FOR XCL::VAR IN XCL::VARS AS 
+                                                                            XCL::EXPAND-TIME-VAL-FORM
+                                                   IN XCL::EXPAND-TIME-VAL-FORMS
+                                                   COLLECT (LIST XCL::VAR 
+                                                                     XCL::EXPAND-TIME-VAL-FORM))
+                                               ,@XCL::BODY]
+                `(LET ,(FOR XCL::RUN-TIME-VAR IN (LISP:REVERSE XCL::RUN-TIME-VARS)
+                          AS XCL::RUN-TIME-VAL IN (LISP:REVERSE XCL::RUN-TIME-VALS)
+                          COLLECT (LIST XCL::RUN-TIME-VAR XCL::RUN-TIME-VAL))
+                      ,XCL::WRAPPED-BODY])
+
+
+
+(* ; "not a wonderful place for it, but CMLMACROS comes too eraly in the loadup.")
+
+
+(LISP:DEFVAR *WALK-FUNCTION* NIL
+   "the function being called on each sub-form in the code-walker")
+
+(LISP:DEFVAR *WALK-FORM*
+   "When the first argument to the IF template in the code-walker is a list, it will be evaluated with *walk-form* bound to the form currently being walked."
+)
+
+(LISP:DEFVAR *DECLARATIONS* "a list of the declarations currently in effect while codewalking")
+
+(LISP:DEFVAR *LEXICAL-VARIABLES* NIL                   (* ; 
+                                       "used in walker to hold list of lexical variables available")
+   )
+
+(LISP:DEFVAR *ENVIRONMENT*
+   "while codewalking, this is the lexical environment as far as macros are concerned")
+
+(LISP:DEFVAR *WALK-COPY*
+   "while walking, this is true if we are making a copy of the expresion being walked")
+
+(DEFMACRO WITH-NEW-CONTOUR (&BODY BODY)
+
+   (* ;; "WITH-NEW-CONTOUR is used to enter a new lexical binding contour which inherits from the exisiting one.  Using WITH-NEW-CONTOUR is often overkill: It would suffice for the the walker to rebind *LEXICAL-VARIABLES* and *DECLARATIONS* when walking LET and rebind *ENVIRONMENT* and *DECLARATIONS* when walking MACROLET etc.  WITH-NEW-CONTOUR is much more convenient and just as correct.  *")
+
+   `(LET ((*DECLARATIONS* NIL)
+          (*LEXICAL-VARIABLES* *LEXICAL-VARIABLES*)
+          (*ENVIRONMENT* *ENVIRONMENT*))
+         ,@BODY))
+
+(DEFMACRO NOTE-LEXICAL-BINDING (THING)
+   `(LISP:PUSH ,THING *LEXICAL-VARIABLES*))
+
+(DEFMACRO NOTE-DECLARATION (LISP:DECLARATION)
+   `(LISP:PUSH ,LISP:DECLARATION *DECLARATIONS*))
+
+(LISP:DEFUN VARIABLE-SPECIAL-P (VAR)
+                                                             (* lmm "27-May-86 15:42")
+   (OR (for DECL in *DECLARATIONS* do (AND (EQ (CAR DECL)
+                                                           'LISP:SPECIAL)
+                                                       (FMEMB VAR (CDR DECL))
+                                                       (RETURN T)))
+       (VARIABLE-GLOBALLY-SPECIAL-P VAR)))
+
+(LISP:DEFUN VARIABLE-LEXICAL-P (VAR)
+                                                             (* lmm "11-Apr-86 10:59")
+   (AND (NOT (VARIABLE-SPECIAL-P VAR))
+        (LISP:MEMBER VAR *LEXICAL-VARIABLES* :TEST (FUNCTION EQ))))
+
+(LISP:DEFUN GET-WALKER-TEMPLATE (X)
+                                                             (* lmm "24-May-86 14:48")
+   (LISP:IF (NOT (LISP:SYMBOLP X))
+       '(LISP:LAMBDA :REPEAT (:EVAL))
+       (GET X 'WALKER-TEMPLATE)))
+
+(LISP:DEFUN WALK-FORM (FORM &KEY ((:DECLARATIONS *DECLARATIONS*)
+                                      NIL)
+                                ((:LEXICAL-VARIABLES *LEXICAL-VARIABLES*)
+                                 NIL)
+                                ((:ENVIRONMENT *ENVIRONMENT*)
+                                 NIL)
+                                ((:WALK-FUNCTION *WALK-FUNCTION*)
+                                 (FUNCTION (LISP:LAMBDA (X IGNORE)
+                                                  IGNORE X)))
+                                ((:COPY *WALK-COPY*)
+                                 T))
+   "Walk FORM, expanding all macros, calling :WALK-FUNCTION on each subfof :COPY is true (default), will return the expansion"
+   (WALK-FORM-INTERNAL FORM ':EVAL))
+(DEFINEQ
+
+(WALK-FORM-INTERNAL
+  [LISP:LAMBDA (FORM CONTEXT &AUX FN TEMPLATE WALK-NO-MORE-P NEWFORM)
+                                                             (* lmm "24-May-86 20:28")
+
+         (* ;; "WALK-FORM-INTERNAL is the main driving function for the code walker.  It takes a form and the current context and walks the form calling itself or the appropriate template recursively.")
+
+         (LISP:MULTIPLE-VALUE-SETQ (NEWFORM WALK-NO-MORE-P)
+                (LISP:FUNCALL *WALK-FUNCTION* FORM CONTEXT))
+         (COND
+            (WALK-NO-MORE-P NEWFORM)
+            ((NOT (EQ FORM NEWFORM))
+             (WALK-FORM-INTERNAL NEWFORM CONTEXT))
+            ((NOT (LISP:CONSP FORM))
+             FORM)
+            ((NOT (LISP:SYMBOLP (CAR FORM)))
+             (WALK-TEMPLATE FORM '(:CALL :REPEAT (:EVAL))
+                    CONTEXT))
+            ((SETQ TEMPLATE (GET-WALKER-TEMPLATE (CAR FORM)))
+             (LISP:IF (LISP:SYMBOLP TEMPLATE)
+                 (LISP:FUNCALL TEMPLATE FORM CONTEXT)
+                 (WALK-TEMPLATE FORM TEMPLATE CONTEXT)))
+            ((NEQ FORM (SETQ FORM (LISP:MACROEXPAND-1 FORM *ENVIRONMENT*)))
+             (WALK-FORM-INTERNAL FORM CONTEXT))
+            (T 
+               (* ;; "Otherwise, walk the form as if its just a standard function call using a template for standard function call.")
+
+               (WALK-TEMPLATE FORM '(:CALL :REPEAT (:EVAL))
+                      CONTEXT])
+
+(WALK-TEMPLATE
+  [LISP:LAMBDA (FORM TEMPLATE CONTEXT)                       (* lmm "24-May-86 16:43")
+         (LISP:IF (LISP:ATOM TEMPLATE)
+             (LISP:ECASE TEMPLATE
+                 ((CALL :CALL) (if (LISP:CONSP FORM)
+                                   then (WALK-LAMBDA FORM NIL)
+                                 else FORM))
+                 ((QUOTE NIL PPE :ERROR) FORM)
+                 ((:EVAL EVAL :FUNCTION FUNCTION :TEST TEST :EFFECT EFFECT :RETURN RETURN) 
+                    (WALK-FORM-INTERNAL FORM ':EVAL))
+                 ((SET :SET) (WALK-FORM-INTERNAL FORM ':SET))
+                 (LISP:LAMBDA (WALK-LAMBDA FORM CONTEXT)))
+             (CASE (CAR TEMPLATE)
+                 (LISP:IF (LET ((*WALK-FORM* FORM))
+                               (WALK-TEMPLATE FORM (COND
+                                                          ((LISP:IF (LISTP (LISP:SECOND TEMPLATE))
+                                                               (LISP:EVAL (LISP:SECOND TEMPLATE))
+                                                               (LISP:FUNCALL (LISP:SECOND TEMPLATE)
+                                                                      FORM))
+                                                           (LISP:THIRD TEMPLATE))
+                                                          (T (LISP:FOURTH TEMPLATE)))
+                                      CONTEXT)))
+                 ((REPEAT :REPEAT) (WALK-TEMPLATE-HANDLE-REPEAT FORM (CDR TEMPLATE)
+                                          (LISP:NTHCDR (- (LISP:LENGTH FORM)
+                                                          (LISP:LENGTH (CDDR TEMPLATE)))
+                                                 FORM)
+                                          CONTEXT))
+                 (T [COND
+                       ((LISP:ATOM FORM)
+                        FORM)
+                       (T (WALK-RECONS FORM (WALK-TEMPLATE (CAR FORM)
+                                                       (CAR TEMPLATE)
+                                                       CONTEXT)
+                                 (WALK-TEMPLATE (CDR FORM)
+                                        (CDR TEMPLATE)
+                                        CONTEXT])))])
+
+(WALK-TEMPLATE-HANDLE-REPEAT
+  (LISP:LAMBDA (FORM TEMPLATE STOP-FORM CONTEXT)             (* lmm "11-Apr-86 12:05")
+         (LISP:IF (EQ FORM STOP-FORM)
+             (WALK-TEMPLATE FORM (CDR TEMPLATE)
+                    CONTEXT)
+             (WALK-TEMPLATE-HANDLE-REPEAT-1 FORM TEMPLATE (CAR TEMPLATE)
+                    STOP-FORM CONTEXT))))
+
+(WALK-TEMPLATE-HANDLE-REPEAT-1
+  [LISP:LAMBDA (FORM TEMPLATE REPEAT-TEMPLATE STOP-FORM CONTEXT)
+                                                             (* lmm "24-May-86 16:43")
+         (COND
+            ((NULL FORM)
+             NIL)
+            ((EQ FORM STOP-FORM)
+             (LISP:IF (NULL REPEAT-TEMPLATE)
+                 (WALK-TEMPLATE STOP-FORM (CDR TEMPLATE)
+                        CONTEXT)
+                 (LISP:ERROR 
+      "While handling repeat:
+                     ~%%~Ran into stop while still in repeat template.")))
+            ((NULL REPEAT-TEMPLATE)
+             (WALK-TEMPLATE-HANDLE-REPEAT-1 FORM TEMPLATE (CAR TEMPLATE)
+                    STOP-FORM CONTEXT))
+            (T (WALK-RECONS FORM (WALK-TEMPLATE (CAR FORM)
+                                            (CAR REPEAT-TEMPLATE)
+                                            CONTEXT)
+                      (WALK-TEMPLATE-HANDLE-REPEAT-1 (CDR FORM)
+                             TEMPLATE
+                             (CDR REPEAT-TEMPLATE)
+                             STOP-FORM CONTEXT])
+
+(WALK-LIST
+  [LAMBDA (LIST FN)                                          (* lmm "24-May-86 16:43")
+                                                             (* copy list walking each element)
+    (LISP:IF LIST
+        (WALK-RECONS LIST (LISP:FUNCALL FN (CAR LIST))
+               (WALK-LIST (CDR LIST)
+                      FN)))])
+
+(WALK-RECONS
+  (LISP:LAMBDA (X CAR CDR)                                   (* lmm "24-May-86 16:43")
+         (LISP:IF *WALK-COPY*
+             (LISP:IF (OR (NOT (EQ (CAR X)
+                                   CAR))
+                          (NOT (EQ (CDR X)
+                                   CDR)))
+                 (CONS CAR CDR)
+                 X)
+             NIL)))
+)
+
+(DEFMACRO WALK-RELIST* (X FIRST &REST LISP:REST)
+   (LISP:IF LISP:REST
+       `(WALK-RECONS ,X ,FIRST (WALK-RELIST* (CDR ,X)
+                                          ,@LISP:REST))
+       FIRST))
+(DEFINEQ
+
+(WALK-DECLARATIONS
+  [LISP:LAMBDA (BODY FN &OPTIONAL DOC-STRING-P DECLARATIONS &AUX (FORM (CAR BODY)))
+                                                             (* lmm "18-Jun-86 14:35")
+                                                             (* skips over declarations)
+         (COND
+            ((AND (STRINGP FORM)                             (* might be a doc string *)
+                  (CDR BODY)                                 (* isn't the returned value *)
+                  (NULL DOC-STRING-P)                        (* no doc string yet *)
+                  (NULL DECLARATIONS))                       (* no declarations yet *)
+             (WALK-RECONS BODY FORM (WALK-DECLARATIONS (CDR BODY)
+                                               FN T)))
+            ((AND (LISTP FORM)
+                  (EQ (CAR FORM)
+                      'DECLARE))                             (* Got a real declaration.
+                                                           Record it, look for more.
+                                                           *)
+             (LISP:DOLIST (LISP:DECLARATION (CDR FORM))
+                 (NOTE-DECLARATION LISP:DECLARATION)
+                 (LISP:PUSH LISP:DECLARATION DECLARATIONS))
+             (WALK-RECONS BODY FORM (WALK-DECLARATIONS (CDR BODY)
+                                               FN DOC-STRING-P DECLARATIONS)))
+            ([AND (LISP:CONSP FORM)
+                  (NULL (GET-WALKER-TEMPLATE (CAR FORM)))
+                  (NOT (EQ FORM (SETQ FORM (LISP:MACROEXPAND-1 FORM *ENVIRONMENT*]
+
+         (* * When we macroexpanded this form we got something else back.
+       Maybe this is a macro which expanded into a declare? Recurse to find out.)
+
+             (WALK-DECLARATIONS (CONS FORM (CDR BODY))
+                    FN DOC-STRING-P DECLARATIONS))
+            (T 
+
+         (* Now that we have walked and recorded the declarations, call the function our 
+       caller provided to expand the body. We call that function rather than passing 
+       the real-body back, because we are RECONSING up the new body.)
+
+               (LISP:FUNCALL FN BODY])
+
+(WALK-ARGLIST
+  [LISP:LAMBDA (ARGLIST CONTEXT &OPTIONAL DESTRUCTURINGP &AUX ARG)
+                                                             (* lmm "24-May-86 16:44")
+         (COND
+            ((NULL ARGLIST)
+             NIL)
+            [(LISP:SYMBOLP (LISP:SETQ ARG (CAR ARGLIST)))
+             (OR (LISP:MEMBER ARG LISP:LAMBDA-LIST-KEYWORDS :TEST (FUNCTION EQ))
+                 (NOTE-LEXICAL-BINDING ARG))
+             (WALK-RECONS ARGLIST ARG (WALK-ARGLIST
+                                           (CDR ARGLIST)
+                                           CONTEXT
+                                           (AND DESTRUCTURINGP (NOT (LISP:MEMBER
+                                                                     ARG LISP:LAMBDA-LIST-KEYWORDS 
+                                                                     :TEST (FUNCTION EQ]
+            [(LISP:CONSP ARG)
+             (PROG1 (LISP:IF DESTRUCTURINGP
+                        (WALK-ARGLIST ARG CONTEXT DESTRUCTURINGP)
+                        (WALK-RECONS ARGLIST (WALK-RELIST* ARG (CAR ARG)
+                                                        (WALK-FORM-INTERNAL (CADR ARG)
+                                                               ':EVAL)
+                                                        (CDDR ARG))
+                               (WALK-ARGLIST (CDR ARGLIST)
+                                      CONTEXT NIL)))
+                 (LISP:IF (LISP:SYMBOLP (CAR ARG))
+                     (NOTE-LEXICAL-BINDING (CAR ARG))
+                     (NOTE-LEXICAL-BINDING (CADAR ARG)))
+                 (OR (NULL (CDDR ARG))
+                     (NOT (LISP:SYMBOLP (CADDR ARG)))
+                     (NOTE-LEXICAL-BINDING ARG)))]
+            (T (LISP:ERROR "Can't understand something in the arglist ~S" ARGLIST])
+
+(WALK-LAMBDA
+  [LISP:LAMBDA (FORM CONTEXT)                                (* lmm "24-May-86 16:44")
+         (WITH-NEW-CONTOUR (LET* [(ARGLIST (CADR FORM))
+                                      (BODY (CDDR FORM))
+                                      (WALKED-ARGLIST NIL)
+                                      (WALKED-BODY (WALK-DECLARATIONS
+                                                    BODY
+                                                    (FUNCTION (LISP:LAMBDA
+                                                               (REAL-BODY)
+                                                               (LISP:SETQ WALKED-ARGLIST
+                                                                      (WALK-ARGLIST ARGLIST 
+                                                                             CONTEXT))
+                                                               (WALK-TEMPLATE
+                                                                REAL-BODY
+                                                                '(:REPEAT (:EVAL))
+                                                                CONTEXT]
+                                     (WALK-RELIST* FORM (CAR FORM)
+                                            WALKED-ARGLIST WALKED-BODY])
+)
+
+(PUTPROPS LISP:COMPILER-LET WALKER-TEMPLATE WALK-COMPILER-LET)
+(DEFINEQ
+
+(WALK-COMPILER-LET
+  [LISP:LAMBDA (FORM CONTEXT)                                (* gbn " 7-Aug-86 18:21")
+                                                             (* ; 
+                                             "bind the variables, but then return the COMPILER-LET")
+         (LET [(VARS (LISP:MAPCAR [FUNCTION (LAMBDA (X)
+                                              (LISP:IF (LISP:CONSP X)
+                                                  (CAR X)
+                                                  X)]
+                            (CADR FORM)))
+               (VALS (LISP:MAPCAR (FUNCTION (LISP:LAMBDA (X)
+                                                   (LISP:IF (LISP:CONSP X)
+                                                       (LISP:EVAL (CADR X))
+                                                       NIL)))
+                            (CADR FORM]
+              (LISP:PROGV VARS VALS
+                  (WALK-TEMPLATE FORM '(NIL NIL :REPEAT (:EVAL)
+                                                  :RETURN)
+                         CONTEXT))])
+)
+
+(PUTPROPS DECLARE WALKER-TEMPLATE WALK-UNEXPECTED-DECLARE)
+(DEFINEQ
+
+(WALK-UNEXPECTED-DECLARE
+  (LISP:LAMBDA (FORM CONTEXT)                                (* lmm "24-May-86 22:27")
+         (DECLARE (IGNORE CONTEXT))
+         (LISP:WARN "Encountered declare ~S in a place where a declare was not expected." FORM)
+         FORM))
+)
+
+(PUTPROPS LET WALKER-TEMPLATE WALK-LET)
+
+(PUTPROPS PROG WALKER-TEMPLATE WALK-LET)
+
+(PUTPROPS LET* WALKER-TEMPLATE WALK-LET*)
+
+(PUTPROPS PROG* WALKER-TEMPLATE WALK-LET*)
+(DEFINEQ
+
+(WALK-LET
+  (LISP:LAMBDA (FORM CONTEXT)
+         (WALK-LET/LET* FORM CONTEXT NIL)))
+
+(WALK-LET*
+  (LISP:LAMBDA (FORM CONTEXT)
+         (WALK-LET/LET* FORM CONTEXT T)))
+
+(WALK-LET/LET*
+  [LISP:LAMBDA
+   (FORM CONTEXT SEQUENTIALP)                                (* lmm "24-May-86 16:44")
+   (LET
+    ((OLD-DECLARATIONS *DECLARATIONS*)
+     (OLD-LEXICAL-VARIABLES *LEXICAL-VARIABLES*))
+    (WITH-NEW-CONTOUR
+     (LET* [(LET/LET* (CAR FORM))
+            (BINDINGS (CADR FORM))
+            (BODY (CDDR FORM))
+            WALKED-BINDINGS
+            (WALKED-BODY
+             (WALK-DECLARATIONS
+              BODY
+              (FUNCTION (LISP:LAMBDA
+                         (REAL-BODY)
+                         [LISP:SETQ WALKED-BINDINGS
+                                (WALK-LIST BINDINGS
+                                       (FUNCTION (LAMBDA (BINDING)
+                                                   (LISP:IF (LISP:SYMBOLP BINDING)
+                                                       (PROG1 BINDING (NOTE-LEXICAL-BINDING
+                                                                       BINDING))
+                                                       (PROG1 (LET ((*DECLARATIONS* OLD-DECLARATIONS)
+                                                                    (*LEXICAL-VARIABLES* (LISP:IF 
+                                                                                          SEQUENTIALP
+                                                                                             
+                                                                                  *LEXICAL-VARIABLES*
+                                                                                             
+                                                                                OLD-LEXICAL-VARIABLES)
+                                                                           ))
+                                                                   (WALK-RELIST*
+                                                                    BINDING
+                                                                    (CAR BINDING)
+                                                                    (WALK-FORM-INTERNAL
+                                                                     (CADR BINDING)
+                                                                     CONTEXT)
+                                                                    (CDDR BINDING)))
+                                                           (NOTE-LEXICAL-BINDING (CAR BINDING))))
+                                                   ]
+                         (WALK-TEMPLATE REAL-BODY '(:REPEAT (:EVAL))
+                                CONTEXT]
+           (WALK-RELIST* FORM LET/LET* WALKED-BINDINGS WALKED-BODY])
+)
+
+(PUTPROPS LISP:TAGBODY WALKER-TEMPLATE WALK-TAGBODY)
+(DEFINEQ
+
+(WALK-TAGBODY
+  [LISP:LAMBDA (FORM CONTEXT)                                (* lmm "24-May-86 16:44")
+         (WALK-RECONS FORM (CAR FORM)
+                (WALK-LIST (CDR FORM)
+                       (FUNCTION (LAMBDA (X)
+                                   (WALK-FORM-INTERNAL X (LISP:IF (LISP:SYMBOLP X)
+                                                                 'QUOTE
+                                                                 CONTEXT)])
+)
+
+(PUTPROPS FUNCTION WALKER-TEMPLATE (NIL :CALL))
+
+(PUTPROPS LISP:FUNCTION WALKER-TEMPLATE (NIL :CALL))
+
+(PUTPROPS GO WALKER-TEMPLATE (NIL NIL))
+
+(PUTPROPS LISP:IF WALKER-TEMPLATE (NIL :TEST :RETURN :RETURN))
+
+(PUTPROPS LISP:MULTIPLE-VALUE-CALL WALKER-TEMPLATE (NIL :EVAL :REPEAT (:EVAL)))
+
+(PUTPROPS LISP:MULTIPLE-VALUE-PROG1 WALKER-TEMPLATE (NIL :RETURN :REPEAT (:EVAL)))
+
+(PUTPROPS PROGN WALKER-TEMPLATE (NIL :REPEAT (:EVAL)))
+
+(PUTPROPS LISP:PROGV WALKER-TEMPLATE (NIL :EVAL :EVAL :REPEAT (:EVAL)))
+
+(PUTPROPS QUOTE WALKER-TEMPLATE (NIL QUOTE))
+
+(PUTPROPS LISP:RETURN-FROM WALKER-TEMPLATE (NIL NIL :EVAL))
+
+(PUTPROPS RETURN WALKER-TEMPLATE (NIL :EVAL))
+
+(PUTPROPS LISP:SETQ WALKER-TEMPLATE (NIL :REPEAT (:SET :EVAL)))
+
+(PUTPROPS LISP:BLOCK WALKER-TEMPLATE (NIL NIL :REPEAT (:EVAL)))
+
+(PUTPROPS LISP:CATCH WALKER-TEMPLATE (NIL :EVAL :REPEAT (:EVAL)))
+
+(PUTPROPS LISP:EVAL-WHEN WALKER-TEMPLATE (NIL NIL :REPEAT (:EVAL)))
+
+(PUTPROPS THE WALKER-TEMPLATE (NIL NIL :EVAL))
+
+(PUTPROPS LISP:THROW WALKER-TEMPLATE (NIL :EVAL :EVAL))
+
+(PUTPROPS LISP:UNWIND-PROTECT WALKER-TEMPLATE (NIL :EVAL :REPEAT (:EVAL)))
+
+(PUTPROPS LOAD-TIME-EVAL WALKER-TEMPLATE (NIL :EVAL))
+
+(PUTPROPS COND WALKER-TEMPLATE [NIL :REPEAT ((:REPEAT (:EVAL])
+
+(PUTPROPS LISP:UNWIND-PROTECT WALKER-TEMPLATE (NIL :EVAL :REPEAT (:EVAL)))
+
+(PUTPROPS SETQ WALKER-TEMPLATE (NIL :SET :EVAL))
+
+(PUTPROPS AND WALKER-TEMPLATE (NIL :REPEAT (:EVAL)))
+
+(PUTPROPS OR WALKER-TEMPLATE (NIL :REPEAT (:EVAL)))
+
+
+
+(* ;; "for Interlisp")
+
+
+(PUTPROPS RPAQ? WALKER-TEMPLATE (NIL :SET :EVAL))
+
+(PUTPROPS RPAQ WALKER-TEMPLATE (NIL :SET :EVAL))
+
+(PUTPROPS XNLSETQ WALKER-TEMPLATE (NIL :REPEAT (:EVAL)))
+
+(PUTPROPS ERSETQ WALKER-TEMPLATE (NIL :REPEAT (:EVAL)))
+
+(PUTPROPS NLSETQ WALKER-TEMPLATE (NIL :REPEAT (:EVAL)))
+
+(PUTPROPS RESETVARS WALKER-TEMPLATE WALK-LET)
+
+(PUTPROPS CMLWALK FILETYPE :COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA WALK-TAGBODY WALK-LET/LET* WALK-LET* WALK-LET WALK-UNEXPECTED-DECLARE 
+                         WALK-COMPILER-LET WALK-LAMBDA WALK-ARGLIST WALK-DECLARATIONS WALK-RECONS 
+                         WALK-TEMPLATE-HANDLE-REPEAT-1 WALK-TEMPLATE-HANDLE-REPEAT WALK-TEMPLATE 
+                         WALK-FORM-INTERNAL)
+)
+(PUTPROPS CMLWALK COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (8105 14049 (WALK-FORM-INTERNAL 8115 . 9572) (WALK-TEMPLATE 9574 . 11843) (
+WALK-TEMPLATE-HANDLE-REPEAT 11845 . 12206) (WALK-TEMPLATE-HANDLE-REPEAT-1 12208 . 13310) (WALK-LIST 
+13312 . 13665) (WALK-RECONS 13667 . 14047)) (14259 19629 (WALK-DECLARATIONS 14269 . 16481) (
+WALK-ARGLIST 16483 . 18330) (WALK-LAMBDA 18332 . 19627)) (19702 20803 (WALK-COMPILER-LET 19712 . 20801
+)) (20872 21155 (WALK-UNEXPECTED-DECLARE 20882 . 21153)) (21358 24219 (WALK-LET 21368 . 21461) (
+WALK-LET* 21463 . 21553) (WALK-LET/LET* 21555 . 24217)) (24282 24766 (WALK-TAGBODY 24292 . 24764)))))
+STOP
diff --git a/CLTL2/CMLWALK.LCOM b/CLTL2/CMLWALK.LCOM
new file mode 100644
index 00000000..a8e3e339
Binary files /dev/null and b/CLTL2/CMLWALK.LCOM differ
diff --git a/CLTL2/COMMON-LISP-PACKAGE b/CLTL2/COMMON-LISP-PACKAGE
new file mode 100644
index 00000000..95301443
--- /dev/null
+++ b/CLTL2/COMMON-LISP-PACKAGE
@@ -0,0 +1,38 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
+(FILECREATED " 8-Apr-92 23:35:08" |{DSK}<usr>local>lde>lispcore>sources>COMMON-LISP-PACKAGE.;4| 10139  
+
+      |changes| |to:|  (FUNCTIONS CREATE-CL-PACKAGE)
+
+      |previous| |date:| " 8-Apr-92 16:51:03" 
+|{DSK}<usr>local>lde>lispcore>sources>COMMON-LISP-PACKAGE.;3|)
+
+
+; Copyright (c) 1991, 1992 by Venue Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT COMMON-LISP-PACKAGECOMS)
+
+(RPAQQ COMMON-LISP-PACKAGECOMS ((VARIABLES *COMMON-LISP-PACKAGE* NEWCLSYMS OLDCLSYMS XCLCLSYMS SPLITCLSYMS STRANGECLSYMS) (FUNCTIONS CRUNCH-FILES CREATE-CL-PACKAGE FLIP-CL) (PROP FILETYPE COMMON-LISP-PACKAGE)))
+
+(DEFGLOBALVAR *COMMON-LISP-PACKAGE* NIL "Place holder for the COMMON-LISP package variable")
+
+(CL:DEFPARAMETER NEWCLSYMS (QUOTE ("*BREAK-ON-SIGNALS*" "*COMPILE-FILE-PATHNAME*" "*COMPILE-FILE-TRUENAME*" "*COMPILE-PRINT*" "*COMPILE-VERBOSE*" "*DEBUGGER-HOOK*" "*LOAD-PATHNAME*" "*LOAD-PRINT*" "*LOAD-TRUENAME*" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" "*PRINT-PPRINT-DISPATCH*" "*PRINT-READABLY*" "*PRINT-RIGHT-MARGIN*" "*READ-EVAL*" "ABORT" "AUGMENT-ENVIRONMENT" "BASE-CHARACTER" "BASE-STRING" "BROADCAST-STREAM" "BROADCAST-STREAM-STREAMS" "CELL-ERROR-NAME" "COMPILE-FILE-PATHNAME" "COMPILER-MACRO-FUNCTION" "COMPILER-MACROEXPAND" "COMPILER-MACROEXPAND-1" "COMPLEMENT" "COMPUTE-RESTARTS" "CONCATENATED-STREAM" "CONCATENATED-STREAM-STREAMS" "CONDITION" "CONTINUE" "COPY-PPRINT-DISPATCH" "DECLAIM" "DECLARATION-INFORMATION" "DEFINE-COMPILER-MACRO" "DEFINE-CONDITION" "DEFINE-DECLARATION" "DESTRUCTURING-BIND" "DIVISION-BY-ZERO" "DYNAMIC-EXTENT" "ECHO-STREAM" "ECHO-STREAM-INPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM" "ENCLOSE" "END-OF-FILE" "EXTENDED-CHARACTER" "FDEFINITION" "FILE-ERROR" "FILE-ERROR-PATHNAME" "FILE-STREAM" "FILE-STRING-LENGTH" "FIND-RESTART" "FLOATING-POINT-INEXACT" "FLOATING-POINT-INVALID-OPERATION" "FLOATING-POINT-OVERFLOW" "FLOATING-POINT-UNDERFLOW" "FORMATTER" "FUNCTION-INFORMATION" "FUNCTION-LAMBDA-EXPRESSION" "HANDLER-CASE" "HANDLER-BIND" "HASH-TABLE-REHASH-SIZE" "HASH-TABLE-REHASH-THRESHOLD" "HASH-TABLE-SIZE" "HASH-TABLE-TEST" "IGNORE-ERRORS" "INTERACTIVE-STREAM-P" "INVOKE-DEBUGGER" "INVOKE-RESTART" "INVOKE-RESTART-INTERACTIVELY" "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" "LOAD-LOGICAL-PATHNAME-TRANSLATIONS" "LOAD-TIME-EVAL" "LOAD-TIME-VALUE" "LOGICAL-PATHNAME" "LOGICAL-PATHNAME-TRANSLATIONS" "MAKE-CONDITION" "MAKE-LOAD-FORM" "MAKE-LOAD-FORM-SAVING-SLOTS" "MAP-INTO" "MUFFLE-WARNING" "NTH-VALUE" "OPEN-STREAM-P" "PACKAGE-ERROR" "PARSE-ERROR" "PARSE-MACRO" "PATHNAME-MATCH-P" "PPRINT-DISPATCH" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-FILL" "PPRINT-INDENT" "PPRINT-LINEAR" "PPRINT-LOGICAL-BLOCK" "PPRINT-NEWLINE" "PPRINT-POP" "PPRINT-TAB" "PPRINT-TABULAR" "PRINT-NOT-READABLE" "PRINT-UNREADABLE-OBJECT" "PROGRAM-ERROR" "READER-ERROR" "READTABLE-CASE" "READTABLE-CASE" "REAL" "REALP" "RESTART" "RESTART-BIND" "RESTART-CASE" "SET-PPRINT-DISPATCH" "SIMPLE-BASE-STRING" "SIMPLE-CONDITION-FORMAT-ARGUMENTS" "SIMPLE-CONDITION-FORMAT-STRING" "STORE-VALUE" "STREAM-ERROR-STREAM" "STREAM-EXTERNAL-FORMAT" "STRING-STREAM" "STYLE-WARNING" "SYNONYM-STREAM" "SYNONYM-STREAM-SYMBOL" "TRANSLATE-LOGICAL-PATHNAME" "TRANSLATE-PATHNAME" "TWO-WAY-STREAM" "TWO-WAY-STREAM-INPUT-STREAM" "TWO-WAY-STREAM-OUTPUT-STREAM" "TYPE-ERROR-DATUM" "UNBOUND-SLOT" "UNBOUND-VARIABLE" "UPGRADED-ARRAY-ELEMENT-TYPE" "UPGRADED-COMPLEX-PART-TYPE" "USE-VALUE" "VARIABLE-INFORMATION" "WILD-PATHNAME-P" "WITH-COMPILATION-UNIT" "WITH-CONDITION-RESTARTS" "WITH-HASH-TABLE-ITERATOR" "WITH-PACKAGE-ITERATOR" "WITH-SIMPLE-RESTART" "WITH-STANDARD-IO-SYNTAX")))
+
+(CL:DEFPARAMETER OLDCLSYMS (QUOTE ("COMMON" "COMMONP" "STRING-CHAR" "STRING-CHAR-P" "INT-CHAR" "COMPILER-LET" "CHAR-BIT" "SET-CHAR-BIT" "*MODULES*" "PROVIDE" "REQUIRE" "CHAR-FONT-LIMIT" "CHAR-BITS-LIMIT" "CHAR-BITS" "CHAR-FONT" "MAKE-CHAR" "CHAR-CONTROL-BIT" "CHAR-META-BIT" "CHAR-SUPER-BIT" "CHAR-HYPER-BIT" "*BREAK-ON-WARNINGS*")) "Symbols in LISP and not in COMMON-LISP")
+
+(CL:DEFPARAMETER XCLCLSYMS (QUOTE ("ABORT" "ARITHMETIC-ERROR" "ARITHMETIC-ERROR-OPERANDS" "ARITHMETIC-ERROR-OPERATION" "BROADCAST-STREAM-STREAMS" "CELL-ERROR" "CELL-ERROR-NAME" "CONCATENATED-STREAM-STREAMS" "CONDITION" "CONTROL-ERROR" "DEFINE-CONDITION" "DEFPACKAGE" "DESTRUCTURING-BIND" "DELETE-PACKAGE" "ECHO-STREAM-INPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM" "END-OF-FILE" "HANDLER-BIND" "IGNORE-ERRORS" "MAKE-CONDITION" "OPEN-STREAM-P" "PACKAGE-ERROR" "PACKAGE-ERROR-PACKAGE" "SERIOUS-CONDITION" "SIGNAL" "SIMPLE-CONDITION" "SIMPLE-CONDITION-FORMAT-ARGUMENTS" "SIMPLE-CONDITION-FORMAT-STRING" "SIMPLE-ERROR" "SIMPLE-TYPE-ERROR" "SIMPLE-WARNING" "STORAGE-CONDITION" "STORE-VALUE" "STREAM-ERROR" "STREAM-ERROR-STREAM" "SYNONYM-STREAM-SYMBOL" "TWO-WAY-STREAM-INPUT-STREAM" "TWO-WAY-STREAM-OUTPUT-STREAM" "TYPE-ERROR" "TYPE-ERROR-EXPECTED-TYPE" "UNBOUND-VARIABLE" "UNDEFINED-FUNCTION" "USE-VALUE" "WARNING")))
+
+(CL:DEFPARAMETER SPLITCLSYMS (QUOTE ("LOCALLY" "IN-PACKAGE")))
+
+(CL:DEFPARAMETER STRANGECLSYMS (QUOTE (("LISP" "SIMPLE-STRING" "*GENSYM-COUNTER*") ("XCL" "ROW-MAJOR-AREF"))) "Symbols in CL that are predefined in the loadup in another package")
+
+(CL:DEFUN CRUNCH-FILES (FL) (CL:WHEN (AND FL (CL:SYMBOLP FL)) (CL:SETQ FL (LIST FL))) (CL:DOLIST (F FL) (CL:FORMAT T "Crunching ~a~%" F) (FLIP-CL :LISP) (LOAD F (QUOTE ALLPROP)) (FLIP-CL :NOWHERE) (MAKEFILE F (QUOTE NEW)) (CL:IF (CL:PROBE-FILE (CONCAT F ".DFASL")) (CL:COMPILE-FILE F) (FAKE-COMPILE-FILE F)) (CL:FORMAT T "Done crunching ~a~%" F)))
+
+(CL:DEFUN CREATE-CL-PACKAGE NIL (* \; "Edited  8-Apr-92 20:15 by jrb:") (* |;;| "First, rename the LISP package to get its nicknames out of our way") (CL:RENAME-PACKAGE (CL:FIND-PACKAGE "LISP") "LISP" NIL NIL) (* |;;| "Then create the COMMON-LISP package and friends") (CL:UNLESS (CL:FIND-PACKAGE "COMMON-LISP") (* |;;| "For the moment, no nicknames for COMMON-LISP; FLIP-CL can be used to fix this later.") (SETQ *COMMON-LISP-PACKAGE* (CL:MAKE-PACKAGE "COMMON-LISP" :USE NIL)) (CL:MAKE-PACKAGE "COMMON-LISP-USER" :USE (QUOTE ("COMMON-LISP" "XCL")))) (LET ((WEIRDTAG (CONS NIL NIL)) (OLDPROP (CONS NIL NIL)) (UNSHAREDPROP (CONS NIL NIL)) I) (* |;;| "Flag the atoms in LISP that are not going to be shared into COMMON-LISP") (CL:DOLIST (I OLDCLSYMS) (PUT (CL:FIND-SYMBOL I *LISP-PACKAGE*) WEIRDTAG OLDPROP)) (CL:DOLIST (I SPLITCLSYMS) (PUT (CL:FIND-SYMBOL I *LISP-PACKAGE*) WEIRDTAG UNSHAREDPROP)) (* |;;| "OK, crunch the external symbols in LISP.  We may eventually rehome these symbols into COMMON-LISP") (CL:DO-EXTERNAL-SYMBOLS (I *LISP-PACKAGE*) (LET ((WEIRD? (GET I WEIRDTAG)) S) (COND ((EQ WEIRD? OLDPROP) (* \; "Just leave it alone") (REMPROP I WEIRDTAG)) ((EQ WEIRD? UNSHAREDPROP) (* \; "Export a new, unshared symbol") (EXPORT (CL:INTERN (CL:SYMBOL-NAME I) *COMMON-LISP-PACKAGE*) *COMMON-LISP-PACKAGE*) (REMPROP I WEIRDTAG)) ((NULL WEIRD?) (* \; "Share symbol; if it's already there, shadow it") (CL:IF (SETQ S (CL:FIND-SYMBOL (CL:SYMBOL-NAME I) *COMMON-LISP-PACKAGE*)) (CL:UNLESS (EQ S I) (CL:SHADOWING-IMPORT I *COMMON-LISP-PACKAGE*)) (IMPORT I *COMMON-LISP-PACKAGE*)) (EXPORT I *COMMON-LISP-PACKAGE*)) (T (* \; "VERY unlikely...") (ERROR "Garbage on property list during LISP->COMMON-LISP import" (CONS I WEIRD?)))))) (* |;;| "Handle the few strange CLsymbols (ones that for one reason or another already exist in another package).") (CL:DOLIST (SL STRANGECLSYMS) (LET ((P (CL:FIND-PACKAGE (CAR SL))) OLDS) (CL:DOLIST (S (CDR SL)) (IF (SETQ OLDS (CL:FIND-SYMBOL S P)) THEN (IMPORT OLDS *COMMON-LISP-PACKAGE*) (EXPORT OLDS *COMMON-LISP-PACKAGE*))))) (* |;;| "And snarf the XCL symbols that need to be shared with COMMON-LISP") (LET ((XCLP (CL:FIND-PACKAGE "XCL"))) (CL:DOLIST (I XCLCLSYMS) (IMPORT (CL:FIND-SYMBOL I XCLP) *COMMON-LISP-PACKAGE*) (EXPORT (CL:FIND-SYMBOL I *COMMON-LISP-PACKAGE*) *COMMON-LISP-PACKAGE*))) (* |;;| "If these other packages are around, grab their symbols") (LET (P S) (CL:WHEN (SETQ P (CL:FIND-PACKAGE "XP")) (CL:DOLIST (I (QUOTE ("*PRINT-PPRINT-DISPATCH*" "*PPRINT-RIGHT-MARGIN*" "*PPRINT-MISER-WIDTH*" "PPRINT-NEWLINE" "PPRINT-LOGICAL-BLOCK" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-INDENT" "PPRINT-TAB" "PPRINT-FILL" "PPRINT-LINEAR" "PPRINT-TABULAR" "FORMATTER" "COPY-PPRINT-DISPATCH" "PPRINT-DISPATCH" "SET-PPRINT-DISPATCH"))) (SETQ S (CL:FIND-SYMBOL I P)) (IMPORT S *COMMON-LISP-PACKAGE*) (EXPORT S *COMMON-LISP-PACKAGE*))) (* |;;| "This will have to be changed somewhat as we change the CONDITIONS system to comply with CLtL2") (CL:WHEN (SETQ P (CL:FIND-PACKAGE "CONDITIONS")) (CL:UNUSE-PACKAGE *LISP-PACKAGE* P) (CL:USE-PACKAGE *COMMON-LISP-PACKAGE* P) (CL:DO-EXTERNAL-SYMBOLS (I P) (LET ((S (CL:FIND-SYMBOL (CL:SYMBOL-NAME I) *COMMON-LISP-PACKAGE*))) (IF S THEN (CL:SHADOWING-IMPORT I *COMMON-LISP-PACKAGE*) ELSE (IMPORT I *COMMON-LISP-PACKAGE*)) (EXPORT I *COMMON-LISP-PACKAGE*)))) (* |;;| "Finally, hose out the new COMMON-LISP symbols") (CL:DOLIST (I NEWCLSYMS) (EXPORT (CL:INTERN I *COMMON-LISP-PACKAGE*) *COMMON-LISP-PACKAGE*)) (FLIP-CL :COMMON-LISP))))
+
+(CL:DEFUN FLIP-CL (WHERE) (LET ((WHERE-WAS-IT (CL:FIND-PACKAGE "CL"))) (SETQ WHERE-WAS-IT (COND ((EQ WHERE-WAS-IT *COMMON-LISP-PACKAGE*) :COMMON-LISP) ((EQ WHERE-WAS-IT *LISP-PACKAGE*) :LISP) ((NULL WHERE-WAS-IT) :NOWHERE) (T (ERROR "CL nickname in odd package" WHERE-WAS-IT)))) (CL:ECASE WHERE (:LISP (CL:RENAME-PACKAGE *COMMON-LISP-PACKAGE* "COMMON-LISP" NIL NIL) (CL:RENAME-PACKAGE *LISP-PACKAGE* "LISP" (QUOTE ("CL")) "CL")) (:COMMON-LISP (CL:RENAME-PACKAGE *LISP-PACKAGE* "LISP" NIL NIL) (CL:RENAME-PACKAGE *COMMON-LISP-PACKAGE* "COMMON-LISP" (QUOTE ("CL")) "CL")) (:NOWHERE (CL:RENAME-PACKAGE *LISP-PACKAGE* "LISP" NIL NIL) (CL:RENAME-PACKAGE *COMMON-LISP-PACKAGE* "COMMON-LISP" NIL NIL))) WHERE-WAS-IT))
+
+(PUTPROPS COMMON-LISP-PACKAGE FILETYPE :COMPILE-FILE)
+(PUTPROPS COMMON-LISP-PACKAGE COPYRIGHT ("Venue Corporation" 1991 1992))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/CLTL2/COMMON-LISP-PACKAGE.DFASL b/CLTL2/COMMON-LISP-PACKAGE.DFASL
new file mode 100644
index 00000000..14e8497b
Binary files /dev/null and b/CLTL2/COMMON-LISP-PACKAGE.DFASL differ
diff --git a/CLTL2/CONDITION-HIERARCHY b/CLTL2/CONDITION-HIERARCHY
new file mode 100644
index 00000000..138818d8
--- /dev/null
+++ b/CLTL2/CONDITION-HIERARCHY
@@ -0,0 +1,136 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "XCL" (USE)))
+(IL:FILECREATED "25-Oct-91 16:28:50" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>CONDITION-HIERARCHY.;3| 12064  
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:CONDITION-HIERARCHYCOMS)
+
+      IL:|previous| IL:|date:| "30-Jul-91 15:14:18" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>CONDITION-HIERARCHY.;2|)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CONDITION-HIERARCHYCOMS)
+
+(IL:RPAQQ IL:CONDITION-HIERARCHYCOMS ((IL:STRUCTURES CONDITION SIMPLE-CONDITION WARNING SIMPLE-WARNING SERIOUS-CONDITION ERROR SIMPLE-ERROR ASSERTION-FAILED HASH-TABLE-FULL) (IL:STRUCTURES CELL-ERROR UNBOUND-VARIABLE UNDEFINED-FUNCTION ATTEMPT-TO-CHANGE-CONSTANT ATTEMPT-TO-RPLAC-NIL) (IL:FILES IL:CONDITION-HIERARCHY-SI IL:CONDITION-HIERARCHY-POST-SI) (IL:COMS (IL:FUNCTIONS IL:PRETTY-TYPE-NAME) (IL:STRUCTURES TYPE-ERROR SIMPLE-TYPE-ERROR TYPE-MISMATCH SYMBOL-AS-PATHNAME)) (IL:STRUCTURES CONTROL-ERROR PROGRAM-ERROR ILLEGAL-GO ILLEGAL-RETURN ILLEGAL-THROW BAD-PROCEED-CASE) (IL:STRUCTURES STREAM-ERROR STREAM-NOT-OPEN READ-ERROR SYMBOL-NAME-TOO-LONG END-OF-FILE) (IL:STRUCTURES STORAGE-CONDITION STACK-OVERFLOW CRITICAL-STORAGE-CONDITION STORAGE-EXHAUSTED SYMBOL-HT-FULL ARRAY-SPACE-FULL DATA-TYPES-EXHAUSTED) (IL:STRUCTURES DEVICE-ERROR SIMPLE-DEVICE-ERROR) (IL:STRUCTURES FILE-ERROR FILE-WONT-OPEN FS-RESOURCES-EXCEEDED FS-PROTECTION-VIOLATION FS-RENAMEFILE-SOURCE-COULDNT-DELETE) (IL:STRUCTURES ARITHMETIC-ERROR DIVISION-BY-ZERO FLOATING-POINT-OVERFLOW FLOATING-POINT-UNDERFLOW) (IL:STRUCTURES PATHNAME-ERROR FILE-NOT-FOUND INVALID-PATHNAME) (IL:STRUCTURES CL::PRINT-NOT-READABLE) (IL:FUNCTIONS SIMPLE-CONDITION-FORMAT-ARGUMENTS SIMPLE-CONDITION-FORMAT-STRING) (IL:FILES IL:CONDITION-HIERARCHY-IL) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CONDITION-HIERARCHY)))
+
+(DEFINE-CONDITION CONDITION NIL NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Condition ~S occurred." CONDITION))))
+
+(DEFINE-CONDITION SIMPLE-CONDITION (CONDITION) (FORMAT-STRING FORMAT-ARGUMENTS) (:CONC-NAME "%SIMPLE-CONDITION-") (:REPORT (LAMBDA (CONDITION STREAM) (APPLY (QUOTE FORMAT) STREAM (%SIMPLE-CONDITION-FORMAT-STRING CONDITION) (%SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION)))))
+
+(DEFINE-CONDITION WARNING (CONDITION) (CONDITION) (:REPORT (LAMBDA (C S) (FORMAT S "Warning: ~A" (WARNING-CONDITION S)))))
+
+(DEFINE-CONDITION SIMPLE-WARNING (WARNING) (FORMAT-STRING FORMAT-ARGUMENTS) (:CONC-NAME "%SIMPLE-WARNING-") (:REPORT (LAMBDA (CONDITION STREAM) (APPLY (QUOTE FORMAT) STREAM (%SIMPLE-WARNING-FORMAT-STRING CONDITION) (%SIMPLE-WARNING-FORMAT-ARGUMENTS CONDITION)))))
+
+(DEFINE-CONDITION SERIOUS-CONDITION (CONDITION) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Serious condition ~S occurred." (TYPE-OF CONDITION)))))
+
+(DEFINE-CONDITION ERROR (SERIOUS-CONDITION) NIL)
+
+(DEFINE-CONDITION SIMPLE-ERROR (ERROR) (FORMAT-STRING FORMAT-ARGUMENTS) (:CONC-NAME "%SIMPLE-ERROR-") (:REPORT (LAMBDA (CONDITION STREAM) (APPLY (QUOTE FORMAT) STREAM (%SIMPLE-ERROR-FORMAT-STRING CONDITION) (%SIMPLE-ERROR-FORMAT-ARGUMENTS CONDITION)))))
+
+(DEFINE-CONDITION ASSERTION-FAILED (SIMPLE-ERROR) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (APPLY (QUOTE FORMAT) T (OR (ASSERTION-FAILED-FORMAT-STRING CONDITION) "Assertion failed.") (ASSERTION-FAILED-FORMAT-ARGUMENTS CONDITION)))))
+
+(DEFINE-CONDITION HASH-TABLE-FULL (ERROR) (TABLE) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Hash table full: ~S" (HASH-TABLE-FULL-TABLE CONDITION)))))
+
+(DEFINE-CONDITION CELL-ERROR (ERROR) (NAME))
+
+(DEFINE-CONDITION UNBOUND-VARIABLE (CELL-ERROR) NIL (:REPORT (LAMBDA (C S) (FORMAT S "~S is an unbound variable." (UNBOUND-VARIABLE-NAME C)))))
+
+(DEFINE-CONDITION UNDEFINED-FUNCTION (CELL-ERROR) NIL (:REPORT (LAMBDA (C S) (FORMAT S "~S is an undefined function." (UNDEFINED-FUNCTION-NAME C)))))
+
+(DEFINE-CONDITION ATTEMPT-TO-CHANGE-CONSTANT (CELL-ERROR) NIL)
+
+(DEFINE-CONDITION ATTEMPT-TO-RPLAC-NIL (ATTEMPT-TO-CHANGE-CONSTANT) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Attempt to rplac NIL with ~S" (ATTEMPT-TO-RPLAC-NIL-NAME CONDITION)))))
+
+(IL:FILESLOAD IL:CONDITION-HIERARCHY-SI IL:CONDITION-HIERARCHY-POST-SI)
+
+(DEFUN IL:PRETTY-TYPE-NAME (IL:TYPESPEC) (IL:IF (EQ (CAR (IL:LISTP IL:TYPESPEC)) (QUOTE OR)) IL:THEN (LET ((IL:TYPES (IL:SUBSET (CDR IL:TYPESPEC) (IL:FUNCTION (IL:LAMBDA (IL:NAME) (NOT (IL:SOME (CDR IL:TYPESPEC) (IL:FUNCTION (IL:LAMBDA (IL:OTHER) (AND (IL:NEQ IL:OTHER IL:NAME) (SUBTYPEP IL:NAME IL:OTHER))))))))))) (IL:IF (IL:EQUAL (IL:SORT IL:TYPES) (QUOTE (COMPLEX FLOAT INTEGER RATIO))) IL:THEN "a number" IL:ELSE (IL:CONCATLIST (CDR (IL:FOR IL:X IL:IN IL:TYPES IL:JOIN (LIST " or " (IL:PRETTY-TYPE-NAME IL:X))))))) IL:ELSE (LET (IL:DOC) (IF (AND (SYMBOLP IL:TYPESPEC) (IL:SETQ IL:DOC (DOCUMENTATION IL:TYPESPEC (QUOTE TYPE)))) IL:DOC (IL:CONCAT "a " IL:TYPESPEC)))))
+
+(DEFINE-CONDITION TYPE-ERROR (ERROR) (EXPECTED-TYPE DATUM) (:REPORT (LAMBDA (C S) (FORMAT S "Arg not ~A~&~S" (IL:PRETTY-TYPE-NAME (TYPE-ERROR-EXPECTED-TYPE C)) (TYPE-ERROR-DATUM C)))))
+
+(DEFINE-CONDITION SIMPLE-TYPE-ERROR (IL:* IL:|;;;| "This is a pretty worthless type to have around.") (TYPE-ERROR) (FORMAT-STRING FORMAT-ARGUMENTS) (:CONC-NAME "%SIMPLE-TYPE-ERROR-") (:REPORT (LAMBDA (C S) (APPLY (QUOTE FORMAT) S (%SIMPLE-TYPE-ERROR-FORMAT-STRING C) (%SIMPLE-TYPE-ERROR-FORMAT-ARGUMENTS C)))))
+
+(DEFINE-CONDITION TYPE-MISMATCH (TYPE-ERROR) (NAME VALUE MESSAGE) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (IF (EQL (TYPE-MISMATCH-NAME CONDITION) (TYPE-MISMATCH-VALUE CONDITION)) (FORMAT T "~S is not ~A." (TYPE-MISMATCH-VALUE CONDITION) (OR (TYPE-MISMATCH-MESSAGE CONDITION) (IL:PRETTY-TYPE-NAME (TYPE-MISMATCH-EXPECTED-TYPE CONDITION)))) (FORMAT T "The value of ~S, ~S, is not ~A." (TYPE-MISMATCH-NAME CONDITION) (TYPE-MISMATCH-VALUE CONDITION) (OR (TYPE-MISMATCH-MESSAGE CONDITION) (IL:PRETTY-TYPE-NAME (TYPE-MISMATCH-EXPECTED-TYPE CONDITION))))))))
+
+(DEFINE-CONDITION SYMBOL-AS-PATHNAME (TYPE-ERROR) (SYMBOL WHERE MESSAGE) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (IF (SYMBOL-AS-PATHNAME-MESSAGE CONDITION) (FORMAT T (SYMBOL-AS-PATHNAME-MESSAGE CONDITION) (SYMBOL-AS-PATHNAME-SYMBOL CONDITION)) (FORMAT T "~a: symbol ~s used as pathname" (SYMBOL-AS-PATHNAME-WHERE CONDITION) (SYMBOL-AS-PATHNAME-SYMBOL CONDITION))))))
+
+(DEFINE-CONDITION CONTROL-ERROR (ERROR) NIL)
+
+(DEFINE-CONDITION PROGRAM-ERROR (ERROR) NIL)
+
+(DEFINE-CONDITION ILLEGAL-GO (PROGRAM-ERROR) (TAG) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "GO to a nonexistent tag: ~S." (ILLEGAL-GO-TAG CONDITION)))))
+
+(DEFINE-CONDITION ILLEGAL-RETURN (PROGRAM-ERROR) (TAG) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "RETURN to nonexistent block: ~S." (ILLEGAL-RETURN-TAG CONDITION)))))
+
+(DEFINE-CONDITION ILLEGAL-THROW (CONTROL-ERROR) (TAG) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Tag for THROW not found: ~S." (ILLEGAL-THROW-TAG CONDITION)))))
+
+(DEFINE-CONDITION BAD-PROCEED-CASE (CONTROL-ERROR) (NAME) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Proceed case ~S is not currently active." (BAD-PROCEED-CASE-NAME CONDITION)))))
+
+(DEFINE-CONDITION STREAM-ERROR (ERROR) (STREAM) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Stream error on ~S." (STREAM-ERROR-STREAM CONDITION)))))
+
+(DEFINE-CONDITION STREAM-NOT-OPEN (STREAM-ERROR) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Stream not open: ~S" (STREAM-NOT-OPEN-STREAM CONDITION)))))
+
+(DEFINE-CONDITION READ-ERROR (ERROR) NIL)
+
+(DEFINE-CONDITION SYMBOL-NAME-TOO-LONG (READ-ERROR) NIL (:REPORT "Symbol name too long"))
+
+(DEFINE-CONDITION END-OF-FILE (STREAM-ERROR) NIL (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "End of file ~S" (END-OF-FILE-STREAM CONDITION)))))
+
+(DEFINE-CONDITION STORAGE-CONDITION (SERIOUS-CONDITION) NIL)
+
+(DEFINE-CONDITION STACK-OVERFLOW (STORAGE-CONDITION) NIL (:REPORT "Stack overflow"))
+
+(DEFINE-CONDITION CRITICAL-STORAGE-CONDITION (STORAGE-CONDITION) NIL)
+
+(DEFINE-CONDITION STORAGE-EXHAUSTED (CRITICAL-STORAGE-CONDITION) NIL)
+
+(DEFINE-CONDITION SYMBOL-HT-FULL (CRITICAL-STORAGE-CONDITION) NIL (:REPORT "Symbol hash table full"))
+
+(DEFINE-CONDITION ARRAY-SPACE-FULL (CRITICAL-STORAGE-CONDITION) NIL (:REPORT "Array space full"))
+
+(DEFINE-CONDITION DATA-TYPES-EXHAUSTED (CRITICAL-STORAGE-CONDITION) NIL (:REPORT "No more data types available"))
+
+(DEFINE-CONDITION DEVICE-ERROR (SERIOUS-CONDITION) (DEVICE))
+
+(DEFINE-CONDITION SIMPLE-DEVICE-ERROR (DEVICE-ERROR) (MESSAGE) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Device error: ~A" (SIMPLE-DEVICE-ERROR-MESSAGE CONDITION)))))
+
+(DEFINE-CONDITION FILE-ERROR (ERROR) (PATHNAME))
+
+(DEFINE-CONDITION FILE-WONT-OPEN (FILE-ERROR) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "File won't open: ~A" (FILE-WONT-OPEN-PATHNAME CONDITION)))))
+
+(DEFINE-CONDITION FS-RESOURCES-EXCEEDED (FILE-ERROR) NIL (:REPORT (LAMBDA (C S) (FORMAT S "File system resources exceeded: ~A" (FS-RESOURCES-EXCEEDED-PATHNAME C)))))
+
+(DEFINE-CONDITION FS-PROTECTION-VIOLATION (FILE-ERROR) NIL (:REPORT (LAMBDA (C S) (FORMAT S "Protection violation: ~A" (FILE-ERROR-PATHNAME C)))))
+
+(DEFINE-CONDITION FS-RENAMEFILE-SOURCE-COULDNT-DELETE (FILE-ERROR) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Couldn't delete the source file: ~A" (FS-RENAMEFILE-SOURCE-COULDNT-DELETE-PATHNAME CONDITION)))))
+
+(DEFINE-CONDITION ARITHMETIC-ERROR (ERROR) (OPERATION OPERANDS) (:REPORT (LAMBDA (C S) (FORMAT S "Arithmetic error during (~S~{ ~S~})" (ARITHMETIC-ERROR-OPERATION C) (ARITHMETIC-ERROR-OPERANDS C)))))
+
+(DEFINE-CONDITION DIVISION-BY-ZERO (ARITHMETIC-ERROR) NIL (:REPORT "Attempt to divide by zero."))
+
+(DEFINE-CONDITION FLOATING-POINT-OVERFLOW (ARITHMETIC-ERROR) NIL (:REPORT "Floating point overflow."))
+
+(DEFINE-CONDITION FLOATING-POINT-UNDERFLOW (ARITHMETIC-ERROR) NIL (:REPORT "Floating point underflow."))
+
+(DEFINE-CONDITION PATHNAME-ERROR (ERROR) (PATHNAME))
+
+(DEFINE-CONDITION FILE-NOT-FOUND (FILE-ERROR) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "File not found: ~A" (FILE-NOT-FOUND-PATHNAME CONDITION)))) (:HANDLE (LAMBDA (CONDITION) (COND ((BOUNDP (QUOTE IL:ERRORPOS)) (LET ((NEWNAME (IL:SPELLFILE (IL:ROOTFILENAME (FILE-NOT-FOUND-PATHNAME CONDITION)) NIL IL:NOFILESPELLFLG))) (COND (NEWNAME (IL:ENVAPPLY (IL:STKNAME IL:ERRORPOS) (IL:SUBST NEWNAME (FILE-NOT-FOUND-PATHNAME CONDITION) (MAPCAR (FUNCTION (LAMBDA (X) (IF (PATHNAMEP X) (NAMESTRING X) X))) (IL:STKARGS IL:ERRORPOS))) (IL:STKNTH -1 IL:ERRORPOS IL:ERRORPOS) IL:ERRORPOS T T)))))))))
+
+(DEFINE-CONDITION INVALID-PATHNAME (PATHNAME-ERROR) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Invalid pathname: ~A" (INVALID-PATHNAME-PATHNAME CONDITION)))))
+
+(DEFINE-CONDITION CL::PRINT-NOT-READABLE (ERROR) (THING WHERE) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (LET ((CL:*PRINT-READABLY* NIL)) (FORMAT T "~S cannot be printed readably~@[ by ~S~]" (CL::PRINT-NOT-READABLE-THING CONDITION) (CL::PRINT-NOT-READABLE-WHERE CONDITION))))))
+
+(DEFUN SIMPLE-CONDITION-FORMAT-ARGUMENTS (CONDITION) (ETYPECASE CONDITION (SIMPLE-ERROR (%SIMPLE-ERROR-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-TYPE-ERROR (%SIMPLE-TYPE-ERROR-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-CONDITION (%SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-WARNING (%SIMPLE-WARNING-FORMAT-ARGUMENTS CONDITION))))
+
+(DEFUN SIMPLE-CONDITION-FORMAT-STRING (CONDITION) (ETYPECASE CONDITION (SIMPLE-ERROR (%SIMPLE-ERROR-FORMAT-STRING CONDITION)) (SIMPLE-TYPE-ERROR (%SIMPLE-TYPE-ERROR-FORMAT-STRING CONDITION)) (SIMPLE-CONDITION (%SIMPLE-CONDITION-FORMAT-STRING CONDITION)) (SIMPLE-WARNING (%SIMPLE-WARNING-FORMAT-STRING CONDITION))))
+
+(IL:FILESLOAD IL:CONDITION-HIERARCHY-IL)
+
+(IL:PUTPROPS IL:CONDITION-HIERARCHY IL:FILETYPE COMPILE-FILE)
+
+(IL:PUTPROPS IL:CONDITION-HIERARCHY IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "XCL" (:USE))))
+(IL:PUTPROPS IL:CONDITION-HIERARCHY IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991
+))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/CONDITION-HIERARCHY-SI b/CLTL2/CONDITION-HIERARCHY-SI
new file mode 100644
index 00000000..158b6ae0
--- /dev/null
+++ b/CLTL2/CONDITION-HIERARCHY-SI
@@ -0,0 +1,56 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "SYSTEM")
+(IL:FILECREATED "16-May-90 15:05:52" 
+IL:{DSK}<usr>local>lde>lispcore>sources>CONDITION-HIERARCHY-SI.;2 2452   
+
+      IL:changes IL:to%:  (IL:VARS IL:CONDITION-HIERARCHY-SICOMS)
+
+      IL:previous IL:date%: "11-Jan-88 18:43:35" 
+IL:{DSK}<usr>local>lde>lispcore>sources>CONDITION-HIERARCHY-SI.;1)
+
+
+(IL:* ; "
+Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(IL:PRETTYCOMPRINT IL:CONDITION-HIERARCHY-SICOMS)
+
+(IL:RPAQQ IL:CONDITION-HIERARCHY-SICOMS ((IL:STRUCTURES DEBUGGER-EVAL-ABORTED)
+                                             (IL:STRUCTURES NO-PROCEED-TEST)
+                                             (IL:STRUCTURES BREAKPOINT INTERRUPT REVERT)
+                                             (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                                                    IL:CONDITION-HIERARCHY-SI)))
+
+(XCL:DEFINE-CONDITION DEBUGGER-EVAL-ABORTED (XCL:CONDITION)
+   (CONDITION)
+   (:REPORT "DEBUGGER-EVAL was aborted."))
+
+(XCL:DEFINE-CONDITION NO-PROCEED-TEST (XCL:UNDEFINED-FUNCTION)
+   NIL
+   (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*)
+                   (FORMAT T "No test specified for proceed case: ~S." NAME))))
+
+(XCL:DEFINE-CONDITION BREAKPOINT (XCL:SERIOUS-CONDITION)
+   (FUNCTION)
+   [:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*)
+                   (IF (CONSP (BREAKPOINT-FUNCTION CONDITION))
+                       (FORMAT T "Breakpoint at ~S, called from ~S." (FIRST (BREAKPOINT-FUNCTION
+                                                                             CONDITION))
+                              (THIRD (BREAKPOINT-FUNCTION CONDITION)))
+                       (FORMAT T "Breakpoint at ~S." (BREAKPOINT-FUNCTION CONDITION)))])
+
+(XCL:DEFINE-CONDITION INTERRUPT (BREAKPOINT)
+   NIL
+   [:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*)
+                   (FORMAT T "Interrupt below ~S." (INTERRUPT-FUNCTION CONDITION])
+
+(XCL:DEFINE-CONDITION REVERT (BREAKPOINT)
+   NIL)
+
+(IL:PUTPROPS IL:CONDITION-HIERARCHY-SI IL:FILETYPE IL:COMPILE-FILE)
+
+(IL:PUTPROPS IL:CONDITION-HIERARCHY-SI IL:MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" 
+                                                                              :PACKAGE "SYSTEM"))
+(IL:PUTPROPS IL:CONDITION-HIERARCHY-SI IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990))
+(IL:DECLARE%: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/CONDITION-HIERARCHY-SI.LCOM b/CLTL2/CONDITION-HIERARCHY-SI.LCOM
new file mode 100644
index 00000000..75a01361
Binary files /dev/null and b/CLTL2/CONDITION-HIERARCHY-SI.LCOM differ
diff --git a/CLTL2/CONDITION-HIERARCHY.LCOM b/CLTL2/CONDITION-HIERARCHY.LCOM
new file mode 100644
index 00000000..cd62ad3d
Binary files /dev/null and b/CLTL2/CONDITION-HIERARCHY.LCOM differ
diff --git a/CLTL2/CONDITION-PACKAGE b/CLTL2/CONDITION-PACKAGE
new file mode 100644
index 00000000..1f0b77b5
--- /dev/null
+++ b/CLTL2/CONDITION-PACKAGE
@@ -0,0 +1,118 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE (DEFPACKAGE "CONDITIONS" (USE "COMMON-LISP")))
+(IL:FILECREATED " 6-Apr-92 19:39:50" IL:{DSK}<usr>local>lde>lispcore>sources>CONDITION-PACKAGE.;9 6885   
+
+      IL:changes IL:to%:  (IL:VARS IL:CONDITION-PACKAGECOMS)
+                          (IL:VARIABLES *FUTURE-CITIZENS-OF-CONDITIONS*)
+
+      IL:previous IL:date%: "17-Mar-92 18:47:01" 
+IL:{DSK}<usr>local>lde>lispcore>sources>CONDITION-PACKAGE.;8)
+
+
+(IL:* ; "
+Copyright (c) 1987, 1988, 1900, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(IL:PRETTYCOMPRINT IL:CONDITION-PACKAGECOMS)
+
+(IL:RPAQQ IL:CONDITION-PACKAGECOMS 
+          ((IL:FUNCTIONS CL::NATURALIZE CL::REHOME-SYMBOL DEFECT-FROM-XCL-TO-CONDITIONS)
+           (IL:VARIABLES *FUTURE-CITIZENS-OF-CONDITIONS*)
+           (IL:DECLARE%: IL:DONTEVAL@LOAD IL:DOCOPY
+                  (IL:P (DEFPACKAGE "CONDITIONS" (:USE "COMMON-LISP")
+                               (:EXPORT "*BREAK-ON-SIGNALS*" "COMPUTE-RESTARTS" "CONTINUE" 
+                                      "DIVISION-BY-ZERO" "FILE-ERROR" "FILE-ERROR-PATHNAME" 
+                                      "FIND-RESTART" "FLOATING-POINT-INEXACT" 
+                                      "FLOATING-POINT-INVALID-OPERATION" "FLOATING-POINT-OVERFLOW" 
+                                      "FLOATING-POINT-UNDERFLOW" "HANDLER-CASE" "INVOKE-DEBUGGER" 
+                                      "INVOKE-RESTART" "INVOKE-RESTART-INTERACTIVELY" 
+                                      "MUFFLE-WARNING" "PARSE-ERROR" "PROGRAM-ERROR" "READER-ERROR" 
+                                      "RESTART" "RESTART-BIND" "RESTART-CASE" "RESTART-NAME" 
+                                      "STYLE-WARNING" "TYPE-ERROR-DATUM" "UNBOUND-SLOT" 
+                                      "WITH-SIMPLE-RESTART" "WITH-CONDITION-RESTARTS"))
+                        (MAPC #'DEFECT-FROM-XCL-TO-CONDITIONS *FUTURE-CITIZENS-OF-CONDITIONS*)))
+           (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                  IL:CONDITION-PACKAGE)))
+
+(DEFUN CL::NATURALIZE (CL::NAME CL::SOURCE CL::DESTINATION)
+                                                        (IL:* IL:; "Edited 17-Mar-92 18:45 by jrb:")
+
+   (IL:* IL:;; "Make a symbol, possibly in source, be in source and citizen and export of destination.  Don't move it if it's currently in COMMON-LISP")
+
+   (CHECK-TYPE CL::NAME STRING)
+   (CHECK-TYPE CL::SOURCE PACKAGE)
+   (CHECK-TYPE CL::DESTINATION PACKAGE)
+   [MULTIPLE-VALUE-BIND (CL::CLSYMBOL CL::CLWHERE)
+          (FIND-SYMBOL CL::NAME IL:*COMMON-LISP-PACKAGE*)
+          (IF CL::CLSYMBOL
+              (PROGN (IMPORT CL::CLSYMBOL CL::SOURCE)
+                     (IMPORT CL::CLSYMBOL CL::DESTINATION)
+                     (EXPORT CL::CLSYMBOL CL::DESTINATION))
+              [MULTIPLE-VALUE-BIND (CL::SSYMBOL CL::SWHERE)
+                     (FIND-SYMBOL CL::NAME CL::SOURCE)
+                     (MULTIPLE-VALUE-BIND (CL::DSYMBOL CL::DWHERE)
+                            (FIND-SYMBOL CL::NAME CL::DESTINATION)
+                            (COND
+                               ((AND CL::SWHERE CL::DWHERE (NOT (EQ CL::SSYMBOL CL::DSYMBOL)))
+                                (ERROR "Can't naturalize ~s because name exists in ~s and ~s" 
+                                       CL::NAME (PACKAGE-NAME CL::SOURCE)
+                                       (PACKAGE-NAME CL::DESTINATION)))
+                               (CL::SWHERE (IMPORT CL::SSYMBOL CL::DESTINATION)
+                                      (EXPORT CL::SSYMBOL CL::DESTINATION)
+                                      (CL::REHOME-SYMBOL CL::SSYMBOL CL::DESTINATION))
+                               (CL::DWHERE (IMPORT CL::DSYMBOL CL::SOURCE)
+                                      (CL::REHOME-SYMBOL CL::DSYMBOL CL::DESTINATION))
+                               (T (LET ((SYMBOL (INTERN CL::NAME CL::DESTINATION)))
+                                       (IMPORT SYMBOL CL::SOURCE)
+                                       (EXPORT SYMBOL CL::DESTINATION])]
+   T)
+
+(DEFUN CL::REHOME-SYMBOL (CL::S CL::NEW-HOME)   (IL:* IL:; "Edited 17-Mar-92 15:35 by jrb:")
+
+   (IL:* IL:;; "This must be done carefully if the symbol currently names a type; the type-variable must be shared between the old and new packages")
+
+   (WHEN (LISP::PARSED-STRUCTURE CL::S T)
+       (LET ((CL::TV (IL:TYPE-VARIABLE-FROM-TYPE-NAME CL::S)))
+            (IMPORT CL::TV CL::NEW-HOME)
+            (SETF (SYMBOL-PACKAGE CL::TV)
+                  CL::NEW-HOME)))
+   (IMPORT CL::S CL::NEW-HOME)
+   (EXPORT CL::S CL::NEW-HOME)
+   (SETF (SYMBOL-PACKAGE CL::S)
+         CL::NEW-HOME))
+
+(DEFUN DEFECT-FROM-XCL-TO-CONDITIONS (NAME)
+   (CL::NATURALIZE NAME (FIND-PACKAGE "XCL")
+          (FIND-PACKAGE "CONDITIONS")))
+
+(XCL:DEFGLOBALPARAMETER *FUTURE-CITIZENS-OF-CONDITIONS*
+   '("ABORT" "ARITHMETIC-ERROR" "ARITHMETIC-ERROR-OPERANDS" "ARITHMETIC-ERROR-OPERATION" "CELL-ERROR"
+           "CELL-ERROR-NAME" "CONDITION" "CONTROL-ERROR" "DEFINE-CONDITION" "END-OF-FILE" 
+           "HANDLER-BIND" "HANDLER-CASE" "IGNORE-ERRORS" "MAKE-CONDITION" "SERIOUS-CONDITION" 
+           "SIGNAL" "SIMPLE-CONDITION" "SIMPLE-CONDITION-FORMAT-ARGUMENTS" 
+           "SIMPLE-CONDITION-FORMAT-STRING" "SIMPLE-ERROR" "SIMPLE-TYPE-ERROR" "SIMPLE-WARNING" 
+           "STORAGE-CONDITION" "STORE-VALUE" "STREAM-ERROR" "STREAM-ERROR-STREAM" "TYPE-ERROR" 
+           "TYPE-ERROR-EXPECTED-TYPE" "UNBOUND-VARIABLE" "UNDEFINED-FUNCTION" "USE-VALUE" "WARNING")
+   "Current citizens of XCL that should be in CONDITIONS: do not change this list!!!")
+(IL:DECLARE%: IL:DONTEVAL@LOAD IL:DOCOPY 
+
+(DEFPACKAGE "CONDITIONS" (:USE "COMMON-LISP")
+       (:EXPORT "*BREAK-ON-SIGNALS*" "COMPUTE-RESTARTS" "CONTINUE" "DIVISION-BY-ZERO" "FILE-ERROR" 
+              "FILE-ERROR-PATHNAME" "FIND-RESTART" "FLOATING-POINT-INEXACT" 
+              "FLOATING-POINT-INVALID-OPERATION" "FLOATING-POINT-OVERFLOW" "FLOATING-POINT-UNDERFLOW"
+              "HANDLER-CASE" "INVOKE-DEBUGGER" "INVOKE-RESTART" "INVOKE-RESTART-INTERACTIVELY" 
+              "MUFFLE-WARNING" "PARSE-ERROR" "PROGRAM-ERROR" "READER-ERROR" "RESTART" "RESTART-BIND"
+              "RESTART-CASE" "RESTART-NAME" "STYLE-WARNING" "TYPE-ERROR-DATUM" "UNBOUND-SLOT" 
+              "WITH-SIMPLE-RESTART" "WITH-CONDITION-RESTARTS"))
+
+(MAPC #'DEFECT-FROM-XCL-TO-CONDITIONS *FUTURE-CITIZENS-OF-CONDITIONS*)
+)
+
+(IL:PUTPROPS IL:CONDITION-PACKAGE IL:FILETYPE IL:COMPILE-FILE)
+
+(IL:PUTPROPS IL:CONDITION-PACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE
+                                                                     (DEFPACKAGE "CONDITIONS"
+                                                                            (:USE "COMMON-LISP"))))
+(IL:PUTPROPS IL:CONDITION-PACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1900 1990 1992))
+(IL:DECLARE%: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/CONDITION-PACKAGE.LCOM b/CLTL2/CONDITION-PACKAGE.LCOM
new file mode 100644
index 00000000..263a2e3e
--- /dev/null
+++ b/CLTL2/CONDITION-PACKAGE.LCOM
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE (DEFPACKAGE "CONDITIONS" (USE "COMMON-LISP")))
(IL:FILECREATED "22-Nov-93 16:17:22" ("compiled on " 
IL:{DSK}<king>export>lispcore>sources>CLTL2>CONDITION-PACKAGE.;1) "11-Nov-93 16:58:33" IL:bcompl'd IL:in
 "Medley 11-Nov-93 ..." IL:dated "11-Nov-93 17:07:44")
(IL:FILECREATED " 6-Apr-92 19:39:50" IL:{DSK}<usr>local>lde>lispcore>sources>CONDITION-PACKAGE.;9 6885
 IL:changes IL:to%: (IL:VARS IL:CONDITION-PACKAGECOMS) (IL:VARIABLES *FUTURE-CITIZENS-OF-CONDITIONS*) 
IL:previous IL:date%: "17-Mar-92 18:47:01" IL:{DSK}<usr>local>lde>lispcore>sources>CONDITION-PACKAGE.;8
)
(IL:PRETTYCOMPRINT IL:CONDITION-PACKAGECOMS)
(IL:RPAQQ IL:CONDITION-PACKAGECOMS ((IL:FUNCTIONS CL::NATURALIZE CL::REHOME-SYMBOL 
DEFECT-FROM-XCL-TO-CONDITIONS) (IL:VARIABLES *FUTURE-CITIZENS-OF-CONDITIONS*) (IL:DECLARE%: 
IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (DEFPACKAGE "CONDITIONS" (:USE "COMMON-LISP") (:EXPORT 
"*BREAK-ON-SIGNALS*" "COMPUTE-RESTARTS" "CONTINUE" "DIVISION-BY-ZERO" "FILE-ERROR" 
"FILE-ERROR-PATHNAME" "FIND-RESTART" "FLOATING-POINT-INEXACT" "FLOATING-POINT-INVALID-OPERATION" 
"FLOATING-POINT-OVERFLOW" "FLOATING-POINT-UNDERFLOW" "HANDLER-CASE" "INVOKE-DEBUGGER" "INVOKE-RESTART"
 "INVOKE-RESTART-INTERACTIVELY" "MUFFLE-WARNING" "PARSE-ERROR" "PROGRAM-ERROR" "READER-ERROR" 
"RESTART" "RESTART-BIND" "RESTART-CASE" "RESTART-NAME" "STYLE-WARNING" "TYPE-ERROR-DATUM" 
"UNBOUND-SLOT" "WITH-SIMPLE-RESTART" "WITH-CONDITION-RESTARTS")) (MAPC (FUNCTION 
DEFECT-FROM-XCL-TO-CONDITIONS) *FUTURE-CITIZENS-OF-CONDITIONS*))) (IL:PROP (IL:FILETYPE 
IL:MAKEFILE-ENVIRONMENT) IL:CONDITION-PACKAGE)))
(DEFUN CL::NATURALIZE (CL::NAME CL::SOURCE CL::DESTINATION) (IL:* IL:; 
"Edited 17-Mar-92 18:45 by jrb:") (IL:* IL:;; 
"Make a symbol, possibly in source, be in source and citizen and export of destination.  Don't move it if it's currently in COMMON-LISP"
) (CHECK-TYPE CL::NAME STRING) (CHECK-TYPE CL::SOURCE PACKAGE) (CHECK-TYPE CL::DESTINATION PACKAGE) (
MULTIPLE-VALUE-BIND (CL::CLSYMBOL CL::CLWHERE) (FIND-SYMBOL CL::NAME IL:*COMMON-LISP-PACKAGE*) (IF 
CL::CLSYMBOL (PROGN (IMPORT CL::CLSYMBOL CL::SOURCE) (IMPORT CL::CLSYMBOL CL::DESTINATION) (EXPORT 
CL::CLSYMBOL CL::DESTINATION)) (MULTIPLE-VALUE-BIND (CL::SSYMBOL CL::SWHERE) (FIND-SYMBOL CL::NAME 
CL::SOURCE) (MULTIPLE-VALUE-BIND (CL::DSYMBOL CL::DWHERE) (FIND-SYMBOL CL::NAME CL::DESTINATION) (COND
 ((AND CL::SWHERE CL::DWHERE (NOT (EQ CL::SSYMBOL CL::DSYMBOL))) (ERROR 
"Can't naturalize ~s because name exists in ~s and ~s" CL::NAME (PACKAGE-NAME CL::SOURCE) (
PACKAGE-NAME CL::DESTINATION))) (CL::SWHERE (IMPORT CL::SSYMBOL CL::DESTINATION) (EXPORT CL::SSYMBOL 
CL::DESTINATION) (CL::REHOME-SYMBOL CL::SSYMBOL CL::DESTINATION)) (CL::DWHERE (IMPORT CL::DSYMBOL 
CL::SOURCE) (CL::REHOME-SYMBOL CL::DSYMBOL CL::DESTINATION)) (T (LET ((SYMBOL (INTERN CL::NAME 
CL::DESTINATION))) (IMPORT SYMBOL CL::SOURCE) (EXPORT SYMBOL CL::DESTINATION)))))))) T)
(DEFUN CL::REHOME-SYMBOL (CL::S CL::NEW-HOME) (IL:* IL:; "Edited 17-Mar-92 15:35 by jrb:") (IL:* IL:;;
 
"This must be done carefully if the symbol currently names a type; the type-variable must be shared between the old and new packages"
) (WHEN (CL::PARSED-STRUCTURE CL::S T) (LET ((CL::TV (IL:TYPE-VARIABLE-FROM-TYPE-NAME CL::S))) (IMPORT
 CL::TV CL::NEW-HOME) (SETF (SYMBOL-PACKAGE CL::TV) CL::NEW-HOME))) (IMPORT CL::S CL::NEW-HOME) (
EXPORT CL::S CL::NEW-HOME) (SETF (SYMBOL-PACKAGE CL::S) CL::NEW-HOME))
(DEFUN DEFECT-FROM-XCL-TO-CONDITIONS (NAME) (CL::NATURALIZE NAME (FIND-PACKAGE "XCL") (FIND-PACKAGE 
"CONDITIONS")))
(XCL:DEFGLOBALPARAMETER *FUTURE-CITIZENS-OF-CONDITIONS* (QUOTE ("ABORT" "ARITHMETIC-ERROR" 
"ARITHMETIC-ERROR-OPERANDS" "ARITHMETIC-ERROR-OPERATION" "CELL-ERROR" "CELL-ERROR-NAME" "CONDITION" 
"CONTROL-ERROR" "DEFINE-CONDITION" "END-OF-FILE" "HANDLER-BIND" "HANDLER-CASE" "IGNORE-ERRORS" 
"MAKE-CONDITION" "SERIOUS-CONDITION" "SIGNAL" "SIMPLE-CONDITION" "SIMPLE-CONDITION-FORMAT-ARGUMENTS" 
"SIMPLE-CONDITION-FORMAT-STRING" "SIMPLE-ERROR" "SIMPLE-TYPE-ERROR" "SIMPLE-WARNING" 
"STORAGE-CONDITION" "STORE-VALUE" "STREAM-ERROR" "STREAM-ERROR-STREAM" "TYPE-ERROR" 
"TYPE-ERROR-EXPECTED-TYPE" "UNBOUND-VARIABLE" "UNDEFINED-FUNCTION" "USE-VALUE" "WARNING")) 
"Current citizens of XCL that should be in CONDITIONS: do not change this list!!!")
(DEFPACKAGE "CONDITIONS" (:USE "COMMON-LISP") (:EXPORT "*BREAK-ON-SIGNALS*" "COMPUTE-RESTARTS" 
"CONTINUE" "DIVISION-BY-ZERO" "FILE-ERROR" "FILE-ERROR-PATHNAME" "FIND-RESTART" 
"FLOATING-POINT-INEXACT" "FLOATING-POINT-INVALID-OPERATION" "FLOATING-POINT-OVERFLOW" 
"FLOATING-POINT-UNDERFLOW" "HANDLER-CASE" "INVOKE-DEBUGGER" "INVOKE-RESTART" 
"INVOKE-RESTART-INTERACTIVELY" "MUFFLE-WARNING" "PARSE-ERROR" "PROGRAM-ERROR" "READER-ERROR" "RESTART"
 "RESTART-BIND" "RESTART-CASE" "RESTART-NAME" "STYLE-WARNING" "TYPE-ERROR-DATUM" "UNBOUND-SLOT" 
"WITH-SIMPLE-RESTART" "WITH-CONDITION-RESTARTS"))
(MAPC (FUNCTION DEFECT-FROM-XCL-TO-CONDITIONS) *FUTURE-CITIZENS-OF-CONDITIONS*)
(IL:PUTPROPS IL:CONDITION-PACKAGE IL:FILETYPE IL:COMPILE-FILE)
(IL:PUTPROPS IL:CONDITION-PACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE (DEFPACKAGE
 "CONDITIONS" (:USE "COMMON-LISP"))))
(IL:PUTPROPS IL:CONDITION-PACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1900 1990 1992))
IL:NIL
\ No newline at end of file
diff --git a/CLTL2/DEFSTRUCT b/CLTL2/DEFSTRUCT
new file mode 100644
index 00000000..f3d593d8
--- /dev/null
+++ b/CLTL2/DEFSTRUCT
@@ -0,0 +1,303 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
+(IL:FILECREATED " 8-Jan-92 09:59:20" IL:|{DSK}<usr>local>lde>lispcore>sources>DEFSTRUCT.;7| 57169  
+
+      IL:|changes| IL:|to:|  (IL:FUNCTIONS SET-XP-PRINTER)
+
+      IL:|previous| IL:|date:| "25-Oct-91 16:34:45" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>DEFSTRUCT.;3|)
+
+
+; Copyright (c) 1986, 1987, 1900, 1988, 1989, 1990, 1991, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:DEFSTRUCTCOMS)
+
+(IL:RPAQQ IL:DEFSTRUCTCOMS ((IL:* IL:|;;;| "Implementation of Structure facilities of Commmon Lisp.  (Chapter 19 of CLtL).") (IL:* IL:|;;;| "public interface ") (IL:DEFINE-TYPES IL:STRUCTURES) (IL:FUNCTIONS DEFSTRUCT) (IL:* IL:|;;;| "top-level ") (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:FILES IL:DEFSTRUCT-RUN-TIME)) (IL:* IL:|;;;| "parsing code") (IL:VARIABLES %DEFAULT-DEFSTRUCT-TYPE %DEFAULT-SLOT-TYPE %DEFAULT-STRUCTURE-INCLUDE %DEFSTRUCT-OPTIONS %NO-CONSTRUCTOR %NO-PREDICATE %NO-COPIER %DEFSTRUCT-CONSP-OPTIONS %DEFSTRUCT-EXPORT-OPTIONS) (IL:FUNCTIONS ASSIGN-SLOT-ACCESSOR REMOVE-DOCUMENTATION RECORD-DOCUMENTATION ENSURE-VALID-TYPE PARSE-SLOT DEFSTRUCT-PARSE-OPTIONS ENSURE-CONSISTENT-PS PS-NUMBER-OF-SLOTS PS-TYPE-SPECIFIER SET-XP-PRINTER) (IL:* IL:|;;;| "slot resolution code") (IL:FUNCTIONS ASSIGN-SLOT-OFFSET RESOLVE-SLOTS INSERT-INCLUDED-SLOT MERGE-SLOTS NAME-SLOT DUMMY-SLOT OFFSET-SLOT) (IL:* IL:|;;;| "data layout code") (IL:FUNCTIONS ASSIGN-STRUCTURE-REPRESENTATION COERCE-TYPE %STRUCTURE-TYPE-TO-FIELDSPEC ASSIGN-FIELD-DESCRIPTORS STRUCTURE-POINTER-SLOTS) (IL:* IL:|;;;| "type system hooks") (IL:FUNCTIONS PROCESS-TYPE PREDICATE-BODY TYPE-EXPAND-STRUCTURE TYPE-EXPAND-NAMED-STRUCTURE PS-NAME-SLOT-POSITION DEFAULT-PREDICATE-NAME DEFSTRUCT-SHARED-PREDICATE-OPTIMIZER CACHE-PREDICATE-INFO) (IL:VARIABLES %FUNCTION-DEFINING-FORM-KEYWORDS) (IL:* IL:|;;;| "accessors and setfs") (IL:FUNCTIONS SETF-NAME) (IL:FUNCTIONS ACCESSOR-BODY PROCESS-ACCESSORS ESTABLISH-ACCESSORS DEFINE-ACCESSORS DEFSTRUCT-SHARED-ACCESSOR-OPTIMIZER DEFSTRUCT-SHARED-SETF-EXPANDER CACHE-SLOT-INFO) (IL:FUNCTIONS %MAKE-ACCESSOR-CLOSURE %MAKE-LIST-ACCESSOR %MAKE-ARRAY-ACCESSOR %MAKE-POINTER-ACCESSOR %MAKE-BIT-ACCESSOR %MAKE-FLAG-ACCESSOR %MAKE-WORD-ACCESSOR %MAKE-FIXP-ACCESSOR %MAKE-SMALL-FIXP-ACCESSOR %MAKE-FLOAT-ACCESSOR) (IL:* IL:|;;;| "constructor definition code") (IL:FUNCTIONS DEFINE-CONSTRUCTORS DEFINE-BOA-CONSTRUCTOR ARGUMENT-NAMES BOA-ARG-LIST-WITH-INITIAL-VALUES BOA-SLOT-SETFS FIND-SLOT RAW-CONSTRUCTOR BUILD-CONSTRUCTOR-ARGLIST BUILD-CONSTRUCTOR-SLOT-SETFS BOA-CONSTRUCTOR-P DEFAULT-CONSTRUCTOR-NAME) (IL:* IL:|;;;| "copiers") (IL:FUNCTIONS DEFINE-COPIERS BUILD-COPIER-SLOT-SETFS BUILD-COPIER-TYPE-CHECK) (IL:* IL:|;;;| "print functions") (IL:VARIABLES %DEFAULT-PRINT-FUNCTION) (IL:* IL:|;;;| "internal stuff.") (IL:SETFS IL:FFETCHFIELD) (IL:* IL:|;;;| "utilities") (IL:FUNCTIONS DEFSTRUCT-ASSERT-SUBTYPEP) (IL:* IL:|;;;| "inspecting structures") (IL:FUNCTIONS STRUCTURE-OBJECT-P INSPECT-STRUCTURE-OBJECT STRUCTURE-OBJECT-INSPECT-FETCHFN STRUCTURE-OBJECT-INSPECT-PROPPRINTFN STRUCTURE-OBJECT-INSPECT-STOREFN STRUCTURE-OBJECT-PROPCOMMANDFN) (IL:* IL:|;;| "Defined last so functions required to load a defstruct are loaded first") (IL:STRUCTURES PS PARSED-SLOT) (IL:* IL:|;;| "Mapping between names of generated functions and their associated structures") (IL:FUNCTIONS STRUCTURE-FUNCTION-P STRUCTURE-FUNCTIONS) (IL:* IL:|;;;| "Editing structures") (IL:FUNCTIONS STRUCTURES.HASDEF STRUCTURES.EDITDEF) (IL:P (IL:FILEPKGTYPE (QUOTE IL:STRUCTURES) (QUOTE IL:HASDEF) (QUOTE STRUCTURES.HASDEF) (QUOTE IL:EDITDEF) (QUOTE STRUCTURES.EDITDEF))) (IL:ADDVARS (IL:SHADOW-TYPES (IL:STRUCTURES IL:FNS))) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:ADDVARS (IL:INSPECTMACROS ((IL:FUNCTION STRUCTURE-OBJECT-P) . INSPECT-STRUCTURE-OBJECT)))) (IL:* IL:|;;;| "file properties") (IL:PROP IL:FILETYPE IL:DEFSTRUCT) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:DEFSTRUCT)))
+
+
+
+(IL:* IL:|;;;| "Implementation of Structure facilities of Commmon Lisp.  (Chapter 19 of CLtL).")
+
+
+
+
+(IL:* IL:|;;;| "public interface ")
+
+
+(XCL:DEF-DEFINE-TYPE IL:STRUCTURES "Common Lisp structures")
+
+(XCL:DEFDEFINER (DEFSTRUCT (:NAME (LAMBDA (WHOLE) (LET ((NAME-AND-OPTIONS (SECOND WHOLE))) (IF (CONSP NAME-AND-OPTIONS) (CAR NAME-AND-OPTIONS) NAME-AND-OPTIONS)))) (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFSTRUCT ((IL:\\\, NAME) (":option" "value")) "documentation string" ("slot-name" "initial-value"))))))) IL:STRUCTURES (NAME &REST SLOT-DESCRIPTIONS) (LET* ((PS (DEFSTRUCT-PARSE-OPTIONS NAME)) (SLOT-DESCRIPTIONS (REMOVE-DOCUMENTATION PS SLOT-DESCRIPTIONS))) (RESOLVE-SLOTS SLOT-DESCRIPTIONS PS) (IL:BQUOTE (PROGN (EVAL-WHEN (EVAL COMPILE LOAD) (SETF (PARSED-STRUCTURE (QUOTE (IL:\\\, (PS-NAME PS))) T) (QUOTE (IL:\\\, PS)))) (IL:\\\,@ (ASSIGN-STRUCTURE-REPRESENTATION PS)) (IL:\\\,@ (PROCESS-TYPE PS)) (IL:\\\,@ (PROCESS-ACCESSORS PS)) (EVAL-WHEN (EVAL COMPILE LOAD) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE (IL:\\\, (PS-NAME PS))))) (IL:\\\,@ (DEFINE-CONSTRUCTORS PS)) (IL:\\\,@ (DEFINE-COPIERS PS)) (IL:\\\,@ (RECORD-DOCUMENTATION PS)) (IL:\\\,@ (SET-XP-PRINTER PS))))))
+
+
+
+(IL:* IL:|;;;| "top-level ")
+
+(IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD 
+
+(IL:FILESLOAD IL:DEFSTRUCT-RUN-TIME)
+)
+
+
+
+(IL:* IL:|;;;| "parsing code")
+
+
+(DEFVAR %DEFAULT-DEFSTRUCT-TYPE (QUOTE DATATYPE) "The type of structures when no :type option is specified")
+
+(DEFVAR %DEFAULT-SLOT-TYPE (QUOTE T) "the type of any slot which does not specifiy a :type option")
+
+(DEFCONSTANT %DEFAULT-STRUCTURE-INCLUDE (QUOTE STRUCTURE-OBJECT) "datatype included by every structure")
+
+(DEFPARAMETER %DEFSTRUCT-OPTIONS (QUOTE (:CONC-NAME :CONSTRUCTOR :COPIER :PREDICATE :INCLUDE :PRINT-FUNCTION :TYPE :INITIAL-OFFSET :NAMED :INLINE :FAST-ACCESSORS :TEMPLATE :EXPORT)))
+
+(DEFCONSTANT %NO-CONSTRUCTOR (QUOTE :NONE) "the value which says that no constructor was specified.")
+
+(DEFCONSTANT %NO-PREDICATE (QUOTE :NONE) "the value which says that no constructor was specified")
+
+(DEFCONSTANT %NO-COPIER (QUOTE :NONE))
+
+(DEFPARAMETER %DEFSTRUCT-CONSP-OPTIONS (REMOVE (QUOTE :NAMED) %DEFSTRUCT-OPTIONS))
+
+(DEFPARAMETER %DEFSTRUCT-EXPORT-OPTIONS (QUOTE (:ACCESSOR :CONSTRUCTOR :PREDICATE :COPIER)))
+
+(DEFUN ASSIGN-SLOT-ACCESSOR (SLOT CONC-NAME) (IL:* IL:|;;| "assigns the accessor name to a slot") (IF (PSLOT-ACCESSOR SLOT) (SETF (PSLOT-ACCESSOR SLOT) (VALUES (INTERN (CONCATENATE (QUOTE STRING) (STRING CONC-NAME) (STRING (PSLOT-NAME SLOT))))))))
+
+(DEFUN REMOVE-DOCUMENTATION (PS SLOT-DESCRIPTIONS) (IL:* IL:|;;| "Records it if there is any documentation string.") (LET ((DOC? (CAR SLOT-DESCRIPTIONS))) (COND ((STRINGP DOC?) (IL:* IL:|;;| " save it and return the rest of the slots.") (SETF (PS-DOCUMENTATION-STRING PS) DOC?) (REST SLOT-DESCRIPTIONS)) (T (IL:* IL:|;;| "no doc string, return the whole thing.") SLOT-DESCRIPTIONS))))
+
+(DEFUN RECORD-DOCUMENTATION (PS) (IL:* IL:|;;| "Returns a form which saves the documentation string for a structure.") (LET ((PARSED-DOCSTRING (PS-DOCUMENTATION-STRING PS))) (IF PARSED-DOCSTRING (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, (PS-NAME PS))) (QUOTE STRUCTURE)) (IL:\\\, PARSED-DOCSTRING)))))))
+
+(DEFUN ENSURE-VALID-TYPE (TYPE-FORM) (IL:* IL:|;;| "Bogus right now ") TYPE-FORM)
+
+(DEFUN PARSE-SLOT (DESCRIPTION &OPTIONAL (GENERATE-ACCESSOR T)) (IL:* IL:|;;| "Takes a slot description from the defstruct body or included slots and returns a parsed version") (LET* ((DESCRIPTION (IF (CONSP DESCRIPTION) DESCRIPTION (LIST DESCRIPTION))) (SLOT (MAKE-PARSED-SLOT))) (XCL:DESTRUCTURING-BIND (NAME &OPTIONAL INITIAL-VALUE &REST SLOT-OPTIONS) DESCRIPTION (IF (SYMBOLP NAME) (SETF (PSLOT-NAME SLOT) NAME) (ERROR "Slot name not symbol: ~S" NAME)) (SETF (PSLOT-INITIAL-VALUE SLOT) INITIAL-VALUE) (IL:* IL:|;;| "some variant of PCL's keyword-bind would be easier here, but it's incapable of producing reasonable error msgs for the user.  Maybe later.") (DO ((OPTION-PAIR SLOT-OPTIONS (CDDR OPTION-PAIR))) ((NULL OPTION-PAIR)) (CASE (CAR OPTION-PAIR) (:TYPE (SETF (PSLOT-TYPE SLOT) (ENSURE-VALID-TYPE (CADR OPTION-PAIR)))) (:READ-ONLY (SETF (PSLOT-READ-ONLY SLOT) (AND (CADR OPTION-PAIR) T))) (OTHERWISE (IF (KEYWORDP INITIAL-VALUE) (ERROR "Initial value must be specified to use slot options. ~S" DESCRIPTION) (ERROR "Illegal slot option ~S in slot ~S" (CAR OPTION-PAIR) NAME))))) (IF GENERATE-ACCESSOR (SETF (PSLOT-ACCESSOR SLOT) T))) SLOT))
+
+(DEFUN DEFSTRUCT-PARSE-OPTIONS (NAME&OPTIONS) (IL:* IL:|;;| "Returns a structure representing the options in a defstruct call.") (LET* ((OPTIONS (IF (LISTP NAME&OPTIONS) NAME&OPTIONS (LIST NAME&OPTIONS))) (NAME (POP OPTIONS)) (PS (MAKE-PS :NAME NAME :CONC-NAME (CONCATENATE (QUOTE STRING) (STRING NAME) "-")))) (DOLIST (OPTION OPTIONS) (COND ((LISTP OPTION) (XCL:DESTRUCTURING-BIND (OPTION-KEYWORD &OPTIONAL (OPTION-VALUE NIL ARGUMENT-PROVIDED) &REST FURTHER-ARGUMENTS) OPTION (CASE OPTION-KEYWORD (:CONC-NAME (IL:* IL:|;;| "if the option is specified, but the option value is nil, then use the empty string as conc-name") (SETF (PS-CONC-NAME PS) (OR OPTION-VALUE ""))) (:CONSTRUCTOR (IL:* IL:|;;| "multiple constructors are allowed.  If NIL is provided, then define no constructor.") (COND ((NOT OPTION-VALUE) (IF ARGUMENT-PROVIDED (IL:* IL:|;;| "NIL was specified.  Record that no constructor is to be built.") (SETF (PS-CONSTRUCTORS PS) NIL) (IL:* IL:|;;| "otherwise, it as though the option weren't specified (p. 312 cltl) so leave the default value there."))) ((EQ (PS-CONSTRUCTORS PS) %NO-CONSTRUCTOR) (IL:* IL:|;;| "this is the first constructor specified.  Make the field be a list now.") (SETF (PS-CONSTRUCTORS PS) (LIST (IF FURTHER-ARGUMENTS (CDR OPTION) OPTION-VALUE)))) (T (IL:* IL:|;;| "just push another one on the list of constructors.") (PUSH (IF FURTHER-ARGUMENTS (CDR OPTION) OPTION-VALUE) (PS-CONSTRUCTORS PS))))) (:COPIER (IL:* IL:|;;| "if the argument is specified (even if it is nil), use it.  Otherwise use the default COPY- form already in the ps.") (IF ARGUMENT-PROVIDED (SETF (PS-COPIER PS) OPTION-VALUE))) (:PREDICATE (IF ARGUMENT-PROVIDED (SETF (PS-PREDICATE PS) OPTION-VALUE))) (:INCLUDE (WHEN (SOME (FUNCTION (LAMBDA (X) (SUBTYPEP OPTION-VALUE X))) (QUOTE (CONS SYMBOL ARRAY NUMBER CHARACTER HASH-TABLE READTABLE PACKAGE PATHNAME STREAM RANDOM-STATE))) (CERROR "Include it anyway" "~a is a standard type and shouldn't be :INCLUDEd" OPTION-VALUE)) (SETF (PS-INCLUDE PS) OPTION-VALUE) (IL:* IL:|;;| "if there are any included slots record them") (SETF (PS-INCLUDED-SLOTS PS) (CDDR OPTION))) (:SYSTEM-INCLUDE (SETF (PS-INCLUDE PS) OPTION-VALUE) (IL:* IL:|;;| "if there are any included slots record them") (SETF (PS-INCLUDED-SLOTS PS) (CDDR OPTION))) (:PRINT-FUNCTION (COND ((AND ARGUMENT-PROVIDED (NULL OPTION-VALUE)) (IL:* IL:|;;| "extension to CLtL, if NIL is specified as the defprint, then the internal print function is specified.") (SETF (PS-PRINT-FUNCTION PS) (QUOTE IL:\\PRINT-USING-ADDRESS))) (ARGUMENT-PROVIDED (SETF (PS-PRINT-FUNCTION PS) OPTION-VALUE)) (T (IL:* IL:|;;| "CLtL2 - (:PRINT-FUNCTION) means use default print function regardless of inheritance") (SETF (PS-PRINT-FUNCTION PS) %DEFAULT-PRINT-FUNCTION)))) (:TYPE (SETF (PS-TYPE PS) (COND ((EQ OPTION-VALUE (QUOTE LIST)) (QUOTE LIST)) ((EQ OPTION-VALUE (QUOTE VECTOR)) (IL:* IL:\; "default the vector type to t") (SETF (PS-VECTOR-TYPE PS) T) (QUOTE VECTOR)) ((AND (CONSP OPTION-VALUE) (EQ (CAR OPTION-VALUE) (QUOTE VECTOR))) (SETF (PS-VECTOR-TYPE PS) (IL:%GET-CANONICAL-CML-TYPE (CADR OPTION-VALUE))) (QUOTE VECTOR)) (T (ERROR "the specified :type is not list or subtype of vector: ~S" OPTION-VALUE))))) (:INITIAL-OFFSET (IF (NOT (TYPEP OPTION-VALUE (QUOTE (INTEGER 0 *)))) (ERROR ":initial-offset isn't a non-negative integer: ~S" OPTION-VALUE)) (SETF (PS-INITIAL-OFFSET PS) OPTION-VALUE)) (:INLINE (IL:* IL:|;;| "Is one or both of  :accessor, and  :predicate or t, which is equivalent to both") (IL:* IL:|;;| "Default is '(:accessor :predicate) ") (IL:* IL:|;;| "option (:inline :only) implies no funcallable accessors or predicate is generated") (IF ARGUMENT-PROVIDED (SETF (PS-INLINE PS) OPTION-VALUE))) (:FAST-ACCESSORS (IL:* IL:|;;| "Is either t or nil,  t implying no type checks for all accessors") (IF ARGUMENT-PROVIDED (SETF (PS-FAST-ACCESSORS PS) OPTION-VALUE))) (:TEMPLATE (IL:* IL:|;;| "Is either t or nil -- t  implying type datatype, no copier, predicate, print-function or constructors, and fast accessors, and no new datatype declared.") (IF ARGUMENT-PROVIDED (SETF (PS-TEMPLATE PS) OPTION-VALUE))) (:EXPORT (IL:* IL:|;;| "Edited by TT(13-June-90) Export Option is added for DEFSTRUCT(Medley 1.2). The Specified functions(ex. :constructor, :copier...) will be exported.") (IF FURTHER-ARGUMENTS (ERROR "The specified export functions is not list or atom : ~S" (CONS :EXPORT (CONS OPTION-VALUE FURTHER-ARGUMENTS))) (IF ARGUMENT-PROVIDED (SETF (PS-EXPORT PS) OPTION-VALUE) (SETF (PS-EXPORT PS) T)))) (OTHERWISE (ERROR "Bad option to defstruct: ~S." OPTION))))) (T (CASE OPTION (:NAMED (SETF (PS-NAMED PS) T)) (OTHERWISE (IF (MEMBER OPTION %DEFSTRUCT-CONSP-OPTIONS :TEST (FUNCTION EQ)) (ERROR "defstruct option ~s must be in parentheses with its value" OPTION) (ERROR "Bad option to defstruct: ~S." OPTION))))))) (ENSURE-CONSISTENT-PS PS) PS))
+
+(DEFUN ENSURE-CONSISTENT-PS (PS) (IL:* IL:|;;| "Accomplishes the consistency checks that can't occur until all the options have been parsed.") (IF (PS-INCLUDE PS) (LET* ((INCLUDE (PS-INCLUDE PS)) (INCLUDED-PSTRUCTURE (PARSED-STRUCTURE INCLUDE))) (IL:* IL:|;;| "ensure that the user is not suicidal.  If a structure includes itself, a *very* tight ucode loop will  occur in the instancep opcode.") (IF (EQ INCLUDE (PS-NAME PS)) (ERROR "You probably don't want ~S to include ~S." INCLUDE INCLUDE)) (IL:* IL:|;;| "ensure that the included structure is defined.") (IF (OR (NULL INCLUDED-PSTRUCTURE) (PS-TEMPLATE INCLUDED-PSTRUCTURE)) (ERROR "Included structure ~s is unknown or not instantiated." INCLUDE)) (IL:* IL:|;;| "make sure the type of the included structure is the same") (IF (OR (NOT (EQ (PS-TYPE INCLUDED-PSTRUCTURE) (PS-TYPE PS))) (NOT (EQ (PS-VECTOR-TYPE INCLUDED-PSTRUCTURE) (PS-VECTOR-TYPE PS)))) (ERROR "~s must be same type as included structure ~s" (PS-NAME PS) INCLUDE)))) (LET ((INLINE (PS-INLINE PS)) (POSSIBLE-KEYWORDS (QUOTE (:ACCESSOR :PREDICATE)))) (CASE INLINE ((T) (IL:* IL:|;;| "this is the default case, so make the default be that only the accessors, predicates are inline.") (SETF (PS-INLINE PS) POSSIBLE-KEYWORDS)) ((NIL :ONLY)) (OTHERWISE (MAPCAR (FUNCTION (LAMBDA (KEYWORD) (IF (NOT (MEMBER KEYWORD POSSIBLE-KEYWORDS :TEST (FUNCTION EQ))) (ERROR "~s must be one of ~s." KEYWORD POSSIBLE-KEYWORDS)))) (IF (CONSP INLINE) INLINE (SETF (PS-INLINE PS) (LIST INLINE))))))) (COND ((PS-TEMPLATE PS) (IF (NOT (EQ (PS-TYPE PS) %DEFAULT-DEFSTRUCT-TYPE)) (ERROR "Templated defstructs may not be of type: ~s" (PS-TYPE PS))) (IF (OR (NOT (EQ (PS-CONSTRUCTORS PS) %NO-CONSTRUCTOR)) (NOT (EQ (PS-PREDICATE PS) %NO-PREDICATE)) (NOT (EQ (PS-COPIER PS) %NO-COPIER)) (PS-PRINT-FUNCTION PS)) (ERROR "Templated defstructs may not have constructors predicates copiers or print functions"))) (T (IF (PS-PRINT-FUNCTION PS) (IF (NOT (EQ (PS-TYPE PS) %DEFAULT-DEFSTRUCT-TYPE)) (ERROR "A print-function can't be specified for structures of type ~s" (PS-TYPE PS))) (LET ((INCLUDE (PS-INCLUDE PS))) (IF INCLUDE (IL:* IL:|;;| "CLtL is silent, but we inherit print-functions") (SETF (PS-PRINT-FUNCTION PS) (PS-PRINT-FUNCTION (PARSED-STRUCTURE INCLUDE))) (IL:* IL:|;;| "otherwise, use the default #s style printer") (SETF (PS-PRINT-FUNCTION PS) %DEFAULT-PRINT-FUNCTION)))) (IF (AND (EQ (PS-TYPE PS) (QUOTE VECTOR)) (EQ (PS-NAMED PS) T)) (IL:* IL:|;;| "check that the vector type can actually hold the symbol required for the name.") (DEFSTRUCT-ASSERT-SUBTYPEP (QUOTE SYMBOL) (PS-VECTOR-TYPE PS) ("vector of ~S cannot contain the symbol required for the :named options" (PS-VECTOR-TYPE PS)))) (IF (EQ (PS-PREDICATE PS) %NO-PREDICATE) (IL:* IL:|;;| "there is no predicate. (Note that this is not a null check.  If this field is NIL the user explicitly gave NIL as the predicate.)  ") (IF (OR (EQ (PS-TYPE PS) (QUOTE DATATYPE)) (PS-NAMED PS)) (IL:* IL:|;;| "If this structure is type datatype or named, use the default name") (SETF (PS-PREDICATE PS) (DEFAULT-PREDICATE-NAME (PS-NAME PS))) (IL:* IL:|;;| "now set it to NIL to signal no predicate to the predicate builder.") (SETF (PS-PREDICATE PS) NIL))) (IF (EQ (PS-COPIER PS) %NO-COPIER) (IL:* IL:|;;| "Note that this is not a null check.  If this field is NIL the user explicitly gave NIL as the copier  ") (SETF (PS-COPIER PS) (INTERN (CONCATENATE (QUOTE STRING) "COPY-" (STRING (PS-NAME PS)))))) (LET ((EXPORTNAMES (PS-EXPORT PS))) (IL:* IL:|;;| "If export-slot is nil, functions will not be exported. otherwise, export the specified functions.[Edited by TT (13-June-90)") (AND EXPORTNAMES (OR (EQ EXPORTNAMES T) (AND (NOT (LISTP EXPORTNAMES)) (NOT (SETF (PS-EXPORT PS) (SETQ EXPORTNAMES (LIST EXPORTNAMES))))) (DOLIST (EXPORTNAME EXPORTNAMES T) (OR (MEMBER EXPORTNAME %DEFSTRUCT-EXPORT-OPTIONS) (ERROR "~S is not valid option keyword for :EXPORT" EXPORTNAME)))))) (COND ((EQ (PS-CONSTRUCTORS PS) %NO-CONSTRUCTOR) (IL:* IL:|;;| "There were no constructors specified.  Default the value.") (SETF (PS-CONSTRUCTORS PS) (IL:BQUOTE ((IL:\\\, (DEFAULT-CONSTRUCTOR-NAME (PS-NAME PS)))))))))))
+
+(DEFUN PS-NUMBER-OF-SLOTS (PS) "the number of slots in an instance of this structure" (LENGTH (PS-ALL-SLOTS PS)))
+
+(DEFUN PS-TYPE-SPECIFIER (PS) "returns list, vector, or (vector foo)" (ECASE (PS-TYPE PS) (LIST (QUOTE LIST)) (VECTOR (LET ((ELEMENT-TYPE (PS-VECTOR-TYPE PS))) (IF (IL:NEQ ELEMENT-TYPE T) (IL:BQUOTE (VECTOR (IL:\\\, ELEMENT-TYPE))) (QUOTE VECTOR))))))
+
+(DEFUN SET-XP-PRINTER (PS) (IL:* IL:\; "Edited  8-Jan-92 09:53 by jrb:") (IL:* IL:|;;| "Hang the XP::STRUCTURE-PRINTER property the new pretty-printer expects to see") (IL:* IL:|;;| "Changed property to CL::STRUCTURE-PRINTER and changed #'CL::STRUCTURE-WITH-USER-PRINTER to just 'CL::STRUCTURE-WITH-USER-PRINTER, as none of this stuff is defined until XP gets loaded WAY later in the init") (LET ((NAME (PS-NAME PS))) (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE CL::STRUCTURE-PRINTER)) (IL:\\\, (COND ((NOT (EQ (PS-PRINT-FUNCTION PS) %DEFAULT-PRINT-FUNCTION)) (QUOTE (QUOTE CL::STRUCTURE-WITH-USER-PRINTER))) ((EQ (PS-TYPE PS) %DEFAULT-DEFSTRUCT-TYPE) (LET* ((CONC-NAME (STRING (PS-CONC-NAME PS))) (SLOTS (MAPCAR (FUNCTION (LAMBDA (X) (IF (CONSP X) (CAR X) X))) (PS-ALL-SLOTS PS)))) (IL:BQUOTE (FUNCTION (LAMBDA (XP OBJ) (CL::STRUCTURE-WITH-DEFAULT-PRINTER XP (QUOTE (IL:\\\, NAME)) (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (SLOT) (IL:BQUOTE ((IL:\\\, (STRING SLOT)) ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) CONC-NAME (STRING SLOT)))) OBJ))))) SLOTS)))))))) (T :NONE))))))))
+
+
+
+(IL:* IL:|;;;| "slot resolution code")
+
+
+(DEFUN ASSIGN-SLOT-OFFSET (PS) (IL:* IL:|;;| "Assigns the offsets for each slot for type vector and list.") (LET* ((NAME (PS-NAME PS)) (SLOTS (PS-ALL-SLOTS PS))) (ECASE (PS-TYPE PS) ((VECTOR LIST) (IL:* IL:|;;| "the field descriptor is just the offset.") (DO ((I 0 (1+ I)) (SLOT SLOTS (CDR SLOT))) ((NULL SLOT)) (SETF (PSLOT-FIELD-DESCRIPTOR (CAR SLOT)) I))))))
+
+(DEFUN RESOLVE-SLOTS (LOCAL-SLOT-DESCRIPTIONS PS) (IL:* IL:|;;| "Combines the slot descriptions from the defstruct call with the included slot-descriptions from supers and the :includes option, and installs the decription in the parsed-structure") (LET ((LOCAL-SLOTS (MAPCAR (FUNCTION PARSE-SLOT) LOCAL-SLOT-DESCRIPTIONS)) (INCLUDED-SLOTS (MAPCAR (FUNCTION PARSE-SLOT) (PS-INCLUDED-SLOTS PS))) (INCLUDES (PS-INCLUDE PS))) (WHEN (PS-NAMED PS) (IL:* IL:|;;| "Adds the slot representing the name pseudo-slot. ") (IF (NOT (PS-NAMED PS)) (ERROR ":named not supplied for this defstruct")) (PUSH (NAME-SLOT PS) LOCAL-SLOTS)) (WHEN (NOT (EQ 0 (PS-INITIAL-OFFSET PS))) (IL:* IL:|;;| "Adds parsed-slots to the local-slots to represent the initial offset.") (SETQ LOCAL-SLOTS (NCONC (XCL:WITH-COLLECTION (DOTIMES (I (PS-INITIAL-OFFSET PS)) (XCL:COLLECT (OFFSET-SLOT)))) LOCAL-SLOTS))) (IF INCLUDES (LET ((SUPER-SLOTS (IL:* IL:|;;| "must copy the slots, since the accessor-name will be destructively modified to use the new conc-name.") (MAPCAR (FUNCTION COPY-PARSED-SLOT) (PS-ALL-SLOTS (PARSED-STRUCTURE INCLUDES))))) (IL:* IL:|;;| "update the super-slots according to the included-slots, then make all-slots be (append merged-slots local-slots)") (SETF (PS-ALL-SLOTS PS) (NCONC (MERGE-SLOTS INCLUDED-SLOTS SUPER-SLOTS PS) LOCAL-SLOTS))) (PROGN (IF INCLUDED-SLOTS (ERROR "Can't include slots when ~s includes no structure." (PS-NAME PS))) (IL:* IL:|;;| "no included slots, so the local-slots are it.") (SETF (PS-ALL-SLOTS PS) LOCAL-SLOTS))) (WHEN (AND (NULL (PS-ALL-SLOTS PS)) (EQ (PS-TYPE PS) %DEFAULT-DEFSTRUCT-TYPE)) (PUSH (DUMMY-SLOT) LOCAL-SLOTS) (SETF (PS-ALL-SLOTS PS) LOCAL-SLOTS)) (IL:* IL:|;;| "No longer require local slots to be recorded") (SETF (PS-LOCAL-SLOTS PS) LOCAL-SLOTS) (IL:* IL:|;;| "now that all slots (included, super, local and filler) have been included, we can create accessor names.") (LET ((CONC-NAME (PS-CONC-NAME PS))) (DOLIST (SLOT (PS-ALL-SLOTS PS)) (ASSIGN-SLOT-ACCESSOR SLOT CONC-NAME))) (IL:* IL:|;;| "we can also record slot-names for the default-structure-printer and inspector.") (SETF (PS-ALL-SLOT-NAMES PS) (MAPCAR (FUNCTION PSLOT-NAME) (PS-ALL-SLOTS PS))) (IL:* IL:|;;| "make sure that no slot names have been repeated (either from being explicitly listed twice in the defstruct, or using a slot name that is present in the super without using :include for the slot)") (DO ((SLOT-NAMES (PS-ALL-SLOT-NAMES PS) (CDR SLOT-NAMES))) ((NULL SLOT-NAMES)) (IF (MEMBER (CAR SLOT-NAMES) (CDR SLOT-NAMES) :TEST (FUNCTION STRING=)) (ERROR "The slot ~s is repeated in ~s." (CAR SLOT-NAMES) (PS-ALL-SLOT-NAMES PS))))))
+
+(DEFUN INSERT-INCLUDED-SLOT (NEW-SLOT SUPER-SLOTS PS) (IL:* IL:|;;| "Replaces the slot in super-slots that corresponds to new-slot with new-slot") (FLET ((SAME-SLOT (SLOT1 SLOT2) (EQ (PSLOT-NAME SLOT1) (PSLOT-NAME SLOT2)))) (LET* ((TAIL (MEMBER NEW-SLOT SUPER-SLOTS :TEST (FUNCTION SAME-SLOT))) (OLD-SLOT (CAR TAIL))) (IF (NOT TAIL) (ERROR "included slot ~S not present in included structure ~S" (PSLOT-NAME NEW-SLOT) (PS-INCLUDE PS))) (IL:* IL:|;;| " verify the inclusion rules.") (IF (AND (PSLOT-READ-ONLY OLD-SLOT) (NOT (PSLOT-READ-ONLY NEW-SLOT))) (ERROR "included slot ~s must be read-only.  It is in included structure ~S" (PSLOT-NAME NEW-SLOT) (PS-INCLUDE PS))) (DEFSTRUCT-ASSERT-SUBTYPEP (PSLOT-TYPE NEW-SLOT) (PSLOT-TYPE OLD-SLOT) ("Included slot ~S's type ~s is not a subtype of original slot type ~s" (PSLOT-NAME NEW-SLOT) (PSLOT-TYPE NEW-SLOT) (PSLOT-TYPE OLD-SLOT))) (IL:* IL:|;;| "finally, we can replace the slot") (RPLACA TAIL NEW-SLOT))))
+
+(DEFUN MERGE-SLOTS (INCLUDED-SLOTS SUPER-SLOTS PS) (IL:* IL:|;;| "Takes the included-slots, and the local slots, then merges them with the slots from the super that aren't shadowed.") (IL:* IL:|;;| "go through the slots from the super and replace the super's def with the overriding included-slot") (DOLIST (NEW-SLOT INCLUDED-SLOTS) (INSERT-INCLUDED-SLOT NEW-SLOT SUPER-SLOTS PS)) SUPER-SLOTS)
+
+(DEFUN NAME-SLOT (PS) (IL:* IL:|;;| "Returns a parsed-slot representing the 'name' field of a structure") (PARSE-SLOT (IL:BQUOTE (SI::--STRUCTURE-NAME-SLOT-- (QUOTE (IL:\\\, (PS-NAME PS))) :READ-ONLY T)) NIL))
+
+(DEFUN DUMMY-SLOT NIL (PARSE-SLOT (IL:BQUOTE (SI::--STRUCTURE-DUMMY-SLOT-- NIL :READ-ONLY T :TYPE IL:XPOINTER)) NIL))
+
+(DEFUN OFFSET-SLOT NIL (PARSE-SLOT (IL:BQUOTE ((IL:\\\, (GENSYM)) (IL:* IL:|;;| "to make sure that names are unique, so that when the inspector works on :type list, there will be a unique name.") NIL :READ-ONLY T)) NIL))
+
+
+
+(IL:* IL:|;;;| "data layout code")
+
+
+(DEFUN ASSIGN-STRUCTURE-REPRESENTATION (PS) (IL:* IL:|;;| "Determines the descriptors and returns a form to create the datatype at loadtime.") (IL:* IL:|;;| "Side effects ps.") (LET ((LOCAL-SLOTS (PS-LOCAL-SLOTS PS))) (IL:* IL:|;;| "Local slots no longer need be recorded") (SETF (PS-LOCAL-SLOTS PS) NIL) (CASE (PS-TYPE PS) ((VECTOR LIST) (IL:* IL:|;;| "just assign the the field descriptors (offsets).  No run-time declaration is needed since the representation is known (list and vector)") (ASSIGN-SLOT-OFFSET PS) NIL) (DATATYPE (LET* ((LOCAL-FIELD-SPECS (MAPCAR (FUNCTION (LAMBDA (SLOT) (%STRUCTURE-TYPE-TO-FIELDSPEC (PSLOT-TYPE SLOT)))) LOCAL-SLOTS)) (SUPER-FIELD-SPECS (IF (PS-INCLUDE PS) (PS-FIELD-SPECIFIERS (PARSED-STRUCTURE (PS-INCLUDE PS))))) (ALL-FIELD-SPECS (APPEND SUPER-FIELD-SPECS LOCAL-FIELD-SPECS)) (STRUCTURE-NAME (PS-NAME PS))) (SETF (PS-FIELD-SPECIFIERS PS) ALL-FIELD-SPECS) (XCL:DESTRUCTURING-BIND (LENGTH &REST FIELD-DESCRIPTORS) (IL:TRANSLATE.DATATYPE (IF (NOT (PS-TEMPLATE PS)) STRUCTURE-NAME) ALL-FIELD-SPECS) (IL:* IL:|;;| "Note that this side-effects ps") (ASSIGN-FIELD-DESCRIPTORS PS FIELD-DESCRIPTORS) (IL:* IL:|;;| "save the descriptors? No, even though the ones in the dtd are for the current world, not the crosscompiling world.  They are recomputed each redeclaration by TRANSLATE.DATATYPE") (IF (NOT (PS-TEMPLATE PS)) (IL:BQUOTE ((SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE (IL:\\\, STRUCTURE-NAME)) (QUOTE (IL:\\\, ALL-FIELD-SPECS)) (QUOTE (IL:\\\, FIELD-DESCRIPTORS)) (IL:\\\, LENGTH) (QUOTE (IL:\\\, (OR (PS-INCLUDE PS) %DEFAULT-STRUCTURE-INCLUDE)))))))))))))
+
+(DEFUN COERCE-TYPE (ELEMENT-TYPE) (IL:* IL:|;;| "As in IL:%canonical-cml-type -- Returns the types (t, string-char, single-float, IL:xpointer, (unsigned-byte n) and (signed-byte n)") (IF (CONSP ELEMENT-TYPE) (CASE (CAR ELEMENT-TYPE) (UNSIGNED-BYTE (IL:* IL:|;;| "Let the bits hang out") (IF (> (CADR ELEMENT-TYPE) 16) T ELEMENT-TYPE)) (SIGNED-BYTE (IL:%GET-ENCLOSING-SIGNED-BYTE ELEMENT-TYPE)) (MOD (IL:* IL:|;;| "From cmlarray -- reduces (mod n) to (unsigned-byte m)") (IL:%REDUCE-MOD ELEMENT-TYPE)) (INTEGER (IL:* IL:|;;| "From cmlarray -- reduces (integer x y) to (signed-byte m)") (IL:%REDUCE-INTEGER ELEMENT-TYPE)) (MEMBER (IF (AND (EQ 2 (LENGTH (CDR ELEMENT-TYPE))) (EVERY (FUNCTION (LAMBDA (ELT) (OR (EQ ELT T) (EQ ELT NIL)))) (CDR ELEMENT-TYPE))) ELEMENT-TYPE T)) (T (IL:* IL:|;;| "Attempt type expansion") (LET ((EXPANDER (TYPE-EXPANDER (CAR ELEMENT-TYPE)))) (IF EXPANDER (COERCE-TYPE (TYPE-EXPAND ELEMENT-TYPE EXPANDER)) T)))) (CASE ELEMENT-TYPE ((T IL:FULLPOINTER IL:XPOINTER IL:FULLXPOINTER SINGLE-FLOAT STRING-CHAR) ELEMENT-TYPE) (IL:POINTER T) ((FLOAT SHORT-FLOAT LONG-FLOAT DOUBLE-FLOAT) (QUOTE SINGLE-FLOAT)) (FIXNUM (IL:* IL:|;;| "Could be (signed-byte 32) -- but pointer representation is more efficient") T) (CHARACTER (QUOTE STRING-CHAR)) (BIT (QUOTE (UNSIGNED-BYTE 1))) (T (LET ((EXPANDER (TYPE-EXPANDER ELEMENT-TYPE))) (IF EXPANDER (COERCE-TYPE (TYPE-EXPAND ELEMENT-TYPE EXPANDER)) T))))))
+
+(DEFUN %STRUCTURE-TYPE-TO-FIELDSPEC (ELEMENT-TYPE) (IL:* IL:|;;;| "Returns the most specific InterLisp type descriptor which will hold a given type.") (IL:* IL:|;;;| "Note: This function accepts only a limited subset of the Common Lisp type specifiers: T FLOAT SINGLE-FLOAT FIXNUM BIT (MOD n) (UNSIGNED-BYTE n) INTEGER (INTEGER low high) IL:XPOINTER DOUBLE-IL:POINTER") (LET ((COERCED-TYPE (COERCE-TYPE ELEMENT-TYPE))) (IF (NOT (CONSP COERCED-TYPE)) (CASE COERCED-TYPE ((T STRING-CHAR) (QUOTE IL:POINTER)) ((IL:FULLPOINTER IL:XPOINTER IL:FULLXPOINTER) COERCED-TYPE) ((SINGLE-FLOAT) (QUOTE IL:FLOATP)) (OTHERWISE (QUOTE IL:POINTER))) (CASE (CAR COERCED-TYPE) (UNSIGNED-BYTE (IL:BQUOTE (IL:BITS (IL:\\\, (CADR COERCED-TYPE))))) (SIGNED-BYTE (CASE (CADR COERCED-TYPE) (16 (QUOTE IL:SIGNEDWORD)) (32 (QUOTE IL:FIXP)) (OTHERWISE (QUOTE IL:POINTER)))) (MEMBER (QUOTE IL:FLAG)) (OTHERWISE (QUOTE IL:POINTER))))))
+
+(DEFUN ASSIGN-FIELD-DESCRIPTORS (PS FIELD-DESCRIPTORS) (IL:* IL:|;;| "Assigns the field descriptors for accessing each slot of the structure") (IF (NOT (EQ (PS-TYPE PS) (QUOTE DATATYPE))) (ERROR "Not a structure of type datatype")) (DO ((F FIELD-DESCRIPTORS (CDR F)) (SLOT (PS-ALL-SLOTS PS) (CDR SLOT))) ((NULL F)) (SETF (PSLOT-FIELD-DESCRIPTOR (CAR SLOT)) (CAR F))) (IL:* IL:|;;| "DON'T record where the pointer fields are for the circle printer.  it will do this when it needs them.") (IL:* IL:|;;| "(setf (ps-pointer-descriptors ps) (mapcan #'(lambda (descriptor) (case (caddr descriptor) ((il:pointer il:fullpointer il:xpointer il:fullxpointer) (list descriptor)))) field-descriptors))"))
+
+(DEFUN STRUCTURE-POINTER-SLOTS (STRUCTURE-NAME) (IL:* IL:|;;| "record where the pointer fields are for the circle printer.") (LET ((PS (PARSED-STRUCTURE STRUCTURE-NAME))) (OR (PS-POINTER-DESCRIPTORS PS) (SETF (PS-POINTER-DESCRIPTORS PS) (MAPCAN (FUNCTION (LAMBDA (DESCRIPTOR) (CASE (CADDR DESCRIPTOR) ((IL:POINTER IL:FULLPOINTER IL:XPOINTER IL:FULLXPOINTER) (LIST DESCRIPTOR))))) (MAPCAR (FUNCTION PSLOT-FIELD-DESCRIPTOR) (PS-ALL-SLOTS PS)))))))
+
+
+
+(IL:* IL:|;;;| "type system hooks")
+
+
+(DEFUN PROCESS-TYPE (PS) (IL:* IL:|;;;| "adds the structure to the common lisp type system and defines the predicate, if any.") (IF (NOT (PS-TEMPLATE PS)) (LET* ((NAME (PS-NAME PS)) (TYPE (PS-TYPE PS)) (PREDICATE (PS-PREDICATE PS)) (PREDICATE-BODY (AND PREDICATE (PREDICATE-BODY PS (QUOTE OBJECT)))) (EXPORTNAME (PS-EXPORT PS))) (IF (AND PREDICATE (OR (EQ EXPORTNAME T) (MEMBER :PREDICATE EXPORTNAME))) (EXPORT PREDICATE)) (IL:* IL:\; "Edited by TT(13-June-90) Export Option Follow up") (IL:BQUOTE ((IL:\\\,@ (COND ((EQ TYPE (QUOTE DATATYPE)) (IL:BQUOTE ((EVAL-WHEN (EVAL LOAD COMPILE) (SETF (TYPE-EXPANDER (QUOTE (IL:\\\, NAME))) (QUOTE TYPE-EXPAND-STRUCTURE)))))) ((PS-NAMED PS) (IL:BQUOTE ((EVAL-WHEN (EVAL LOAD COMPILE) (SETF (TYPE-EXPANDER (QUOTE (IL:\\\, NAME))) (QUOTE TYPE-EXPAND-NAMED-STRUCTURE)))))))) (IL:\\\,@ (WHEN PREDICATE (LET* ((INLINE (PS-INLINE PS)) (INLINE-P (AND (EQ TYPE (QUOTE DATATYPE)) (OR (EQ INLINE :ONLY) (AND (CONSP INLINE) (MEMBER :PREDICATE INLINE :TEST (FUNCTION EQ)))))) (INLINE-ONLY-P (EQ INLINE :ONLY))) (IF (NULL INLINE-P) (IL:* IL:|;;| "Flush optimizer (a bit extreme, but also gets rid of old definline optimizers from the old defstruct") (SETF (COMPILER:OPTIMIZER-LIST PREDICATE) NIL)) (IL:BQUOTE ((IL:\\\,@ (IF (NOT INLINE-ONLY-P) (IL:BQUOTE ((DEFUN (IL:\\\, PREDICATE) (OBJECT) (IL:\\\, PREDICATE-BODY)))))) (IL:\\\,@ (IF INLINE-P (IL:BQUOTE ((EVAL-WHEN (EVAL LOAD COMPILE) (ESTABLISH-PREDICATE (QUOTE (IL:\\\, (PS-NAME PS)))))))))))))))))))
+
+(DEFUN PREDICATE-BODY (PS ARG) (LET ((PREDICATE (PS-PREDICATE PS)) (TYPE (PS-TYPE PS))) (CASE TYPE (DATATYPE (IL:* IL:|;;| "for datatypes, always create a predicate.  Use typep") (IL:BQUOTE (TYPEP (IL:\\\, ARG) (QUOTE (IL:\\\, (PS-NAME PS)))))) (OTHERWISE (IL:* IL:|;;| "vectors and lists can only have a predicate if they are named") (IF (NOT (PS-NAMED PS)) (ERROR "The predicate ~s may not be specified for ~s because it is not :name'd" PREDICATE (PS-NAME PS))) (IL:BQUOTE (AND (TYPEP (IL:\\\, ARG) (QUOTE (IL:\\\, (IF (EQ TYPE (QUOTE LIST)) (QUOTE CONS) (QUOTE VECTOR))))) (EQ (IL:\\\, (IF (EQ TYPE (QUOTE LIST)) (IL:BQUOTE (NTH (IL:\\\, (PS-NAME-SLOT-POSITION PS)) (IL:\\\, ARG))) (IL:BQUOTE (AREF (IL:\\\, ARG) (IL:\\\, (PS-NAME-SLOT-POSITION PS)))))) (QUOTE (IL:\\\, (PS-NAME PS))))))))))
+
+(DEFUN TYPE-EXPAND-STRUCTURE (TYPE-FORM) (IL:BQUOTE (:DATATYPE (IL:\\\, (CAR TYPE-FORM)))))
+
+(DEFUN TYPE-EXPAND-NAMED-STRUCTURE (TYPE-FORM) (IL:BQUOTE (SATISFIES (IL:\\\, (PS-PREDICATE (PARSED-STRUCTURE (CAR TYPE-FORM)))))))
+
+(DEFUN PS-NAME-SLOT-POSITION (PS) "returns the offset of the name slot for ps." (LET* ((INCLUDE (PS-INCLUDE PS)) (SUPER-SLOTS (AND INCLUDE (PS-ALL-SLOTS (PARSED-STRUCTURE INCLUDE))))) (+ (PS-INITIAL-OFFSET PS) (LENGTH SUPER-SLOTS))))
+
+(DEFUN DEFAULT-PREDICATE-NAME (STRUCTURE-NAME) (VALUES (INTERN (CONCATENATE (QUOTE STRING) (STRING STRUCTURE-NAME) "-P"))))
+
+(DEFUN DEFSTRUCT-SHARED-PREDICATE-OPTIMIZER (FORM &OPTIONAL ENVIRONMENT CONTEXT) (XCL:DESTRUCTURING-BIND (PREDICATE OBJECT) FORM (LET ((NAME (GETHASH PREDICATE *DEFSTRUCT-INFO-CACHE*))) (IF (NULL NAME) (SETQ NAME (CACHE-PREDICATE-INFO PREDICATE))) (IF NAME (IL:BQUOTE (TYPEP (IL:\\\, OBJECT) (QUOTE (IL:\\\, NAME)))) COMPILER:PASS))))
+
+(DEFUN CACHE-PREDICATE-INFO (PREDICATE) (IL:* IL:|;;| "Establishes a shared a shared optimizer for a defstruct predicate") (LET ((PS (GET-PS-FROM-PREDICATE PREDICATE T))) (WHEN PS (SETF (GETHASH PREDICATE *DEFSTRUCT-INFO-CACHE*) (PS-NAME PS)))))
+
+(DEFCONSTANT %FUNCTION-DEFINING-FORM-KEYWORDS (QUOTE (:ACCESSOR :COPIER :PREDICATE :BOA-CONSTRUCTOR :CONSTRUCTOR)) "all the legal contexts for function-defining-form in defstruct")
+
+
+
+(IL:* IL:|;;;| "accessors and setfs")
+
+
+(DEFUN SETF-NAME (ACCESSOR-NAME) "produces the name of the setf function for this accessor" (XCL:PACK (LIST (QUOTE %%SETF-) ACCESSOR-NAME)))
+
+(DEFUN ACCESSOR-BODY (SLOT ARGUMENT STRUCTURE-TYPE &OPTIONAL (NO-TYPE-CHECK NIL)) (IL:* IL:|;;| "Returns a form which fetches slot from argument") (ECASE STRUCTURE-TYPE (DATATYPE (IL:BQUOTE ((IL:\\\, (IF NO-TYPE-CHECK (QUOTE IL:FFETCHFIELD) (QUOTE IL:FETCHFIELD))) (QUOTE (IL:\\\, (PSLOT-FIELD-DESCRIPTOR SLOT))) (IL:\\\, ARGUMENT)))) (LIST (IL:BQUOTE (NTH (IL:\\\, (PSLOT-FIELD-DESCRIPTOR SLOT)) (IL:\\\, ARGUMENT)))) (VECTOR (IL:BQUOTE (AREF (IL:\\\, ARGUMENT) (IL:\\\, (PSLOT-FIELD-DESCRIPTOR SLOT)))))))
+
+(DEFUN PROCESS-ACCESSORS (PS) (IF (NOT (EQ (PS-INLINE PS) :ONLY)) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (IL:BQUOTE ((ESTABLISH-ACCESSORS (QUOTE (IL:\\\, (PS-NAME PS)))))) (IL:BQUOTE ((EVAL-WHEN (EVAL) (ESTABLISH-ACCESSORS (QUOTE (IL:\\\, (PS-NAME PS))))) (EVAL-WHEN (LOAD) (IL:\\\,@ (DEFINE-ACCESSORS PS))))))))
+
+(DEFUN ESTABLISH-ACCESSORS (PS-NAME) (IL:* IL:|;;| "Makes a closure for every accessor ") (LET* ((PS (PARSED-STRUCTURE PS-NAME)) (STRUCTURE-TYPE (PS-TYPE PS))) (MAPCAN (FUNCTION (LAMBDA (SLOT) (LET ((ACCESSOR (PSLOT-ACCESSOR SLOT)) (EXPORTNAME (PS-EXPORT PS))) (WHEN ACCESSOR (IF (OR (EQ EXPORTNAME T) (MEMBER :ACCESSOR EXPORTNAME)) (EXPORT ACCESSOR)) (IL:* IL:\; "Edited by TT(13-June-90) Export Option Follow up ") (SETF (SYMBOL-FUNCTION ACCESSOR) (%MAKE-ACCESSOR-CLOSURE SLOT STRUCTURE-TYPE)))))) (PS-ALL-SLOTS PS))))
+
+(DEFUN DEFINE-ACCESSORS (PS) (IL:* IL:|;;| "Returns the forms that when evaluated, define the accessors") (IL:* IL:|;;| "Only used by the byte compiler") (LET ((NAME (PS-NAME PS)) (STRUCTURE-TYPE (PS-TYPE PS))) (IL:* IL:|;;| "the arg-name must be the structure name, since it is already in the raw-accessors.") (MAPCAN (FUNCTION (LAMBDA (SLOT) (LET ((ACCESSOR (PSLOT-ACCESSOR SLOT)) (EXPORTNAME (PS-EXPORT PS))) (WHEN ACCESSOR (IF (OR (EQ EXPORTNAME T) (MEMBER :ACCESSOR EXPORTNAME)) (EXPORT ACCESSOR)) (IL:* IL:\; "Edited by TT(13-June-90) Export Option follow-up. ") (IL:BQUOTE ((DEFUN (IL:\\\, ACCESSOR) ((IL:\\\, NAME)) (IL:\\\, (ACCESSOR-BODY SLOT NAME STRUCTURE-TYPE))))))))) (PS-ALL-SLOTS PS))))
+
+(DEFUN DEFSTRUCT-SHARED-ACCESSOR-OPTIMIZER (FORM &OPTIONAL ENVIRONMENT CONTEXT) (XCL:DESTRUCTURING-BIND (ACCESSOR OBJECT) FORM (LET ((SLOT-INFO (GETHASH ACCESSOR *DEFSTRUCT-INFO-CACHE*))) (IF (NULL SLOT-INFO) (SETQ SLOT-INFO (CACHE-SLOT-INFO ACCESSOR))) (IF SLOT-INFO (XCL:DESTRUCTURING-BIND (TYPE SLOT FAST-ACCESSORS-P) SLOT-INFO (ACCESSOR-BODY SLOT OBJECT TYPE FAST-ACCESSORS-P)) (QUOTE COMPILER:PASS)))))
+
+(DEFINE-SHARED-SETF-MACRO DEFSTRUCT-SHARED-SETF-EXPANDER ACCESSOR (DATUM) (NEW-VALUE) (IL:* IL:|;;| "Shared setf expander for all defstruct slot accessors ") (LET ((SLOT-INFO (GETHASH ACCESSOR *DEFSTRUCT-INFO-CACHE*))) (WHEN (NULL SLOT-INFO) (SETQ SLOT-INFO (CACHE-SLOT-INFO ACCESSOR))) (XCL:DESTRUCTURING-BIND (TYPE SLOT FAST-ACCESSSOR-P) SLOT-INFO (LET ((DESCRIPTOR (PSLOT-FIELD-DESCRIPTOR SLOT))) (ECASE TYPE (DATATYPE (IL:BQUOTE ((IL:\\\, (IF FAST-ACCESSSOR-P (QUOTE IL:FREPLACEFIELD) (QUOTE IL:REPLACEFIELD))) (QUOTE (IL:\\\, DESCRIPTOR)) (IL:\\\, DATUM) (IL:\\\, NEW-VALUE)))) (LIST (IL:BQUOTE (SETF (NTH (IL:\\\, DESCRIPTOR) (IL:\\\, DATUM)) (IL:\\\, NEW-VALUE)))) (VECTOR (MACROLET ((SIMPLE-P (X) (IL:BQUOTE (OR (SYMBOLP (IL:\\\, X)) (CONSTANTP (IL:\\\, X)))))) (IF (AND (SIMPLE-P DATUM) (SIMPLE-P NEW-VALUE)) (IL:BQUOTE (XCL:ASET (IL:\\\, NEW-VALUE) (IL:\\\, DATUM) (IL:\\\, DESCRIPTOR))) (LET ((D (GENSYM)) (V (GENSYM))) (IL:BQUOTE (LET (((IL:\\\, D) (IL:\\\, DATUM)) ((IL:\\\, V) (IL:\\\, NEW-VALUE))) (XCL:ASET (IL:\\\, V) (IL:\\\, D) (IL:\\\, DESCRIPTOR)))))))))))))
+
+(DEFUN CACHE-SLOT-INFO (ACCESSOR) (IL:* IL:|;;;| "saves the internal accessors in a hash table so that setf methods can be generated at interpret/compile time.") (LET* ((PS (GET-PS-FROM-ACCESSOR ACCESSOR)) (FAST-ACCESSORS (PS-FAST-ACCESSORS PS))) (SETF (GETHASH ACCESSOR *DEFSTRUCT-INFO-CACHE*) (IL:* IL:\; "Make a copy of the slot to keep refcounts down") (LIST (PS-TYPE PS) (COPY-TREE (GET-SLOT-DESCRIPTOR-FROM-PS ACCESSOR PS)) (AND FAST-ACCESSORS T)))))
+
+(DEFUN %MAKE-ACCESSOR-CLOSURE (SLOT STRUCTURE-TYPE) (LET ((DESCRIPTOR (PSLOT-FIELD-DESCRIPTOR SLOT))) (ECASE STRUCTURE-TYPE (DATATYPE (XCL:DESTRUCTURING-BIND (TYPENAME OFFSET FIELD-DESCRIPTOR) DESCRIPTOR (CASE FIELD-DESCRIPTOR ((IL:POINTER IL:FULLPOINTER IL:XPOINTER IL:FULLXPOINTER) (%MAKE-POINTER-ACCESSOR TYPENAME OFFSET)) (IL:FLOATP (%MAKE-FLOAT-ACCESSOR TYPENAME OFFSET)) (IL:FIXP (%MAKE-FIXP-ACCESSOR TYPENAME OFFSET)) (OTHERWISE (IL:* IL:|;;| "Must be a bit field") (LET* ((FIELD-TYPE (CAR FIELD-DESCRIPTOR)) (FIELD-ARG (CDR FIELD-DESCRIPTOR)) (SIZE (1+ (LOGAND FIELD-ARG 15))) (POSITION (- 16 (+ SIZE (ASH FIELD-ARG -4))))) (ECASE FIELD-TYPE (IL:BITS (IF (EQ SIZE 16) (%MAKE-WORD-ACCESSOR TYPENAME OFFSET) (%MAKE-BIT-ACCESSOR TYPENAME OFFSET POSITION SIZE))) (IL:FLAGBITS (IF (EQ SIZE 1) (%MAKE-FLAG-ACCESSOR TYPENAME OFFSET POSITION) (ERROR "Illegal field descriptor: ~s" DESCRIPTOR))) (IL:SIGNEDBITS (IF (EQ SIZE 16) (%MAKE-SMALL-FIXP-ACCESSOR TYPENAME OFFSET) (IL:* IL:|;;| "Would be better to say here \"Inconvenient field descriptor\"") (ERROR "Illegal field descriptor: ~s" DESCRIPTOR))))))))) (LIST (%MAKE-LIST-ACCESSOR DESCRIPTOR)) (VECTOR (%MAKE-ARRAY-ACCESSOR DESCRIPTOR)))))
+
+(DEFUN %MAKE-LIST-ACCESSOR (OFFSET) (FUNCTION (LAMBDA (LIST) (NTH OFFSET LIST))))
+
+(DEFUN %MAKE-ARRAY-ACCESSOR (OFFSET) (FUNCTION (LAMBDA (VECTOR) (AREF VECTOR OFFSET))))
+
+(DEFUN %MAKE-POINTER-ACCESSOR (TYPE OFFSET) (IF TYPE (FUNCTION (LAMBDA (OBJECT) (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE)) (ERROR "Arg not ~s: ~s" TYPE OBJECT) (IL:\\GETBASEPTR OBJECT OFFSET)))) (FUNCTION (LAMBDA (OBJECT) (IL:\\GETBASEPTR OBJECT OFFSET)))))
+
+(DEFUN %MAKE-BIT-ACCESSOR (TYPE WORD-OFFSET OFFSET SIZE) (IF TYPE (FUNCTION (LAMBDA (OBJECT) (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE)) (ERROR "Arg not ~s: ~s" TYPE OBJECT) (LDB (BYTE SIZE OFFSET) (IL:\\GETBASE OBJECT WORD-OFFSET))))) (FUNCTION (LAMBDA (OBJECT) (LDB (BYTE SIZE OFFSET) (IL:\\GETBASE OBJECT WORD-OFFSET))))))
+
+(DEFUN %MAKE-FLAG-ACCESSOR (TYPE WORD-OFFSET OFFSET) (IF TYPE (FUNCTION (LAMBDA (OBJECT) (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE)) (ERROR "Arg not ~s: ~s" TYPE OBJECT) (NOT (EQ 0 (LDB (BYTE 1 OFFSET) (IL:\\GETBASE OBJECT WORD-OFFSET))))))) (FUNCTION (LAMBDA (OBJECT) (NOT (EQ 0 (LDB (BYTE 1 OFFSET) (IL:\\GETBASE OBJECT WORD-OFFSET))))))))
+
+(DEFUN %MAKE-WORD-ACCESSOR (TYPE OFFSET) (IF TYPE (FUNCTION (LAMBDA (OBJECT) (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE)) (ERROR "Arg not ~s: ~s" TYPE OBJECT) (IL:\\GETBASE OBJECT OFFSET)))) (FUNCTION (LAMBDA (OBJECT) (IL:\\GETBASE OBJECT OFFSET)))))
+
+(DEFUN %MAKE-FIXP-ACCESSOR (TYPE OFFSET) (IF TYPE (FUNCTION (LAMBDA (OBJECT) (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE)) (ERROR "Arg not ~s: ~s" TYPE OBJECT) (IL:\\GETBASEFIXP OBJECT OFFSET)))) (FUNCTION (LAMBDA (OBJECT) (IL:\\GETBASEFIXP OBJECT OFFSET)))))
+
+(DEFUN %MAKE-SMALL-FIXP-ACCESSOR (TYPE OFFSET) (IF TYPE (FUNCTION (LAMBDA (OBJECT) (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE)) (ERROR "Arg not ~s: ~s" TYPE OBJECT) (IL:\\GETBASESMALL-FIXP OBJECT OFFSET)))) (FUNCTION (LAMBDA (OBJECT) (IL:\\GETBASESMALL-FIXP OBJECT OFFSET)))))
+
+(DEFUN %MAKE-FLOAT-ACCESSOR (TYPE OFFSET) (IF TYPE (FUNCTION (LAMBDA (OBJECT) (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE)) (ERROR "Arg not ~s: ~s" TYPE OBJECT) (IL:\\GETBASEFLOATP OBJECT OFFSET)))) (FUNCTION (LAMBDA (OBJECT) (IL:\\GETBASEFLOATP OBJECT OFFSET)))))
+
+
+
+(IL:* IL:|;;;| "constructor definition code")
+
+
+(DEFUN DEFINE-CONSTRUCTORS (PS) (IL:* IL:|;;| "Returns the forms that when evaluated, define the constructors") (IF (NOT (PS-TEMPLATE PS)) (LET* ((CONSTRUCTORS (PS-CONSTRUCTORS PS)) (SLOTS (PS-ALL-SLOTS PS)) (RESULT-ARG (PS-NAME PS)) (ALL-BOAS? (EVERY (FUNCTION BOA-CONSTRUCTOR-P) CONSTRUCTORS)) (EXPORTNAME (PS-EXPORT PS))) (IF (OR (EQ EXPORTNAME T) (MEMBER :CONSTRUCTOR EXPORTNAME)) (EXPORT CONSTRUCTORS)) (IL:* IL:\; "Edited by TT(13-June-90) Export Option Follow up") (COND (ALL-BOAS? (IL:* IL:|;;| "don't bother building the arglist etc.") (MAPCAR (FUNCTION (LAMBDA (CONSTRUCTOR) (DEFINE-BOA-CONSTRUCTOR CONSTRUCTOR PS))) CONSTRUCTORS)) (T (LET* ((ARGUMENT-LIST (BUILD-CONSTRUCTOR-ARGLIST SLOTS)) (SLOT-SETFS (BUILD-CONSTRUCTOR-SLOT-SETFS SLOTS ARGUMENT-LIST PS))) (XCL:WITH-COLLECTION (DOLIST (CONSTRUCTOR CONSTRUCTORS) (XCL:COLLECT (COND ((BOA-CONSTRUCTOR-P CONSTRUCTOR) (DEFINE-BOA-CONSTRUCTOR CONSTRUCTOR PS)) (T (IL:* IL:|;;| "keep the name of a standard constructor, if any, so that the #s form can work.") (SETF (PS-STANDARD-CONSTRUCTOR PS) CONSTRUCTOR) (IL:* IL:|;;| "since we just built the object we're setting fields of, we don't need to type check it.") (IL:BQUOTE (DEFUN (IL:\\\, CONSTRUCTOR) (&KEY (IL:\\\,@ ARGUMENT-LIST)) (LET (((IL:\\\, RESULT-ARG) (IL:\\\, (RAW-CONSTRUCTOR PS)))) (IL:\\\,@ SLOT-SETFS) (IL:\\\, RESULT-ARG)))))))))))))))
+
+(DEFUN DEFINE-BOA-CONSTRUCTOR (NAME&ARGLIST PS) (LET* ((CONSTRUCTOR-NAME (CAR NAME&ARGLIST)) (ARGLIST (CADR NAME&ARGLIST)) (NEW-ARGUMENT-LIST (BOA-ARG-LIST-WITH-INITIAL-VALUES ARGLIST PS)) (RESULT-ARG (PS-NAME PS)) (SLOT-SETFS (BOA-SLOT-SETFS RESULT-ARG (ARGUMENT-NAMES NEW-ARGUMENT-LIST) PS))) (IL:BQUOTE (DEFUN (IL:\\\, CONSTRUCTOR-NAME) (IL:\\\, NEW-ARGUMENT-LIST) (LET (((IL:\\\, RESULT-ARG) (IL:\\\, (RAW-CONSTRUCTOR PS)))) (IL:\\\,@ SLOT-SETFS) (IL:\\\, RESULT-ARG))))))
+
+(DEFUN ARGUMENT-NAMES (ARG-LIST) (MAPCAN (FUNCTION (LAMBDA (ARG) (COND ((CONSP ARG) (IF (CONSP (CAR ARG)) (LIST (CONS (CADR (CAR ARG)) (CDR ARG))) (LIST ARG))) ((MEMBER ARG LAMBDA-LIST-KEYWORDS) NIL) (T (LIST (LIST ARG :REQUIRED-ARG)))))) ARG-LIST))
+
+(DEFUN BOA-ARG-LIST-WITH-INITIAL-VALUES (ARG-LIST PS) (LET ((NEW-ARG-LIST (COPY-TREE ARG-LIST)) (SLOTS (PS-ALL-SLOTS PS)) (LEGAL-KEYWORDS (QUOTE (&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS &AUX))) ARG-TAIL ARG-HEAD) (IL:* IL:|;;| "Munch through the argument list, generating the slightly munged BOA argument list.  First pop off the mandatory arguments") (SETQ ARG-TAIL NEW-ARG-LIST) (FLET ((MORE-TO-DO NIL (AND ARG-TAIL (NOT (MEMBER (CAR ARG-TAIL) LEGAL-KEYWORDS :TEST (FUNCTION EQ))))) (BUILD-ARG (OLD-ARG KEY?) (SETF (CAR ARG-TAIL) (COND ((SYMBOLP OLD-ARG) (LET ((IVF (PSLOT-INITIAL-VALUE (FIND-SLOT OLD-ARG SLOTS)))) (IF IVF (IL:BQUOTE ((IL:\\\, OLD-ARG) (IL:\\\, IVF))) (IL:BQUOTE ((IL:\\\, OLD-ARG) NIL (IL:\\\, (IL:GENSYM))))))) ((CONSP OLD-ARG) (IF (CDR OLD-ARG) OLD-ARG (IL:* IL:\; "already a default") (LET ((IVF (PSLOT-INITIAL-VALUE (FIND-SLOT (IF (AND KEY? (CONSP (CAR OLD-ARG))) (SECOND (CAR OLD-ARG)) (CAR OLD-ARG)) SLOTS)))) (IF IVF (IL:BQUOTE ((IL:\\\, (CAR OLD-ARG)) (IL:\\\, IVF))) (IL:BQUOTE ((IL:\\\, (CAR OLD-ARG)) NIL (IL:\\\, (IL:GENSYM)))))))))))) (IL:WHILE (MORE-TO-DO) IL:DO (POP ARG-TAIL)) (IL:* IL:|;;| "Then chew on the seperate argument classes") (IL:WHILE ARG-TAIL IL:DO (CASE (SETQ ARG-HEAD (POP ARG-TAIL)) (&OPTIONAL (IL:WHILE (MORE-TO-DO) IL:DO (BUILD-ARG (CAR ARG-TAIL) NIL) (POP ARG-TAIL))) (&KEY (IL:WHILE (MORE-TO-DO) IL:DO (BUILD-ARG (CAR ARG-TAIL) T) (POP ARG-TAIL))) (&ALLOW-OTHER-KEYS) (&REST (POP ARG-TAIL)) (&AUX (IL:WHILE (MORE-TO-DO) IL:DO (POP ARG-TAIL))) (OTHERWISE (ERROR "~S cannot appear in a BOA constructor as it does in ~S." ARG-HEAD ARG-LIST))))) NEW-ARG-LIST))
+
+(DEFUN BOA-SLOT-SETFS (RESULT-ARG SLOT-NAMES PS) (LET ((STRUCTURE-TYPE (PS-TYPE PS))) (XCL:WITH-COLLECTION (LET (SLOT-PLACE SLOT-NAME SLOT-ARGUMENT) (DOLIST (SLOT (PS-ALL-SLOTS PS)) (SETQ SLOT-NAME (PSLOT-NAME SLOT)) (SETQ SLOT-PLACE (ACCESSOR-BODY SLOT RESULT-ARG STRUCTURE-TYPE T)) (SETQ SLOT-ARGUMENT (ASSOC SLOT-NAME SLOT-NAMES :TEST (FUNCTION EQ))) (XCL:COLLECT (IF SLOT-ARGUMENT (LET ((SUPPLIED-P (CADDR SLOT-ARGUMENT))) (IF SUPPLIED-P (IL:BQUOTE (IF (IL:\\\, SUPPLIED-P) (SETF (IL:\\\, SLOT-PLACE) (IL:\\\, SLOT-NAME)))) (IL:BQUOTE (SETF (IL:\\\, SLOT-PLACE) (IL:\\\, SLOT-NAME))))) (IL:BQUOTE (SETF (IL:\\\, SLOT-PLACE) (IL:\\\, (PSLOT-INITIAL-VALUE SLOT)))))))))))
+
+(DEFUN FIND-SLOT (NAME SLOTS &OPTIONAL (DONT-ERROR NIL)) (DOLIST (SLOT SLOTS (OR DONT-ERROR (ERROR "slot ~s not found." NAME))) (IF (EQ NAME (PSLOT-NAME SLOT)) (RETURN SLOT))))
+
+(DEFUN RAW-CONSTRUCTOR (PS) (IL:* IL:|;;| "Returns a form which will make an instance of this structure w/o initialisation") (ECASE (PS-TYPE PS) (DATATYPE (IL:BQUOTE (IL:NCREATE (QUOTE (IL:\\\, (PS-NAME PS)))))) (LIST (IL:BQUOTE (MAKE-LIST (IL:\\\, (PS-NUMBER-OF-SLOTS PS))))) (VECTOR (IL:BQUOTE (MAKE-ARRAY (QUOTE ((IL:\\\, (PS-NUMBER-OF-SLOTS PS)))) :ELEMENT-TYPE (QUOTE (IL:\\\, (PS-VECTOR-TYPE PS))))))))
+
+(DEFUN BUILD-CONSTRUCTOR-ARGLIST (SLOTS) (IL:* IL:|;;| "Gathers the keywords and initial-values for (non BOA) constructors") (MAPCAN (FUNCTION (LAMBDA (SLOT) (LET* ((INIT-FORM (PSLOT-INITIAL-VALUE SLOT)) (ARG-NAME (PSLOT-NAME SLOT)) (KEYWORD-PAIR (IL:BQUOTE ((IL:\\\, (VALUES (INTERN (SYMBOL-NAME ARG-NAME) (QUOTE KEYWORD)))) (IL:\\\, (GENSYM)))))) (COND ((NOT (PSLOT-ACCESSOR SLOT)) (IL:* IL:|;;| "this is an invisible slot (name, initial-offset, etc.) don't generate a keyword arg") NIL) (INIT-FORM (IL:* IL:|;;| "specify an initial value for the keyword arg") (IL:BQUOTE (((IL:\\\, KEYWORD-PAIR) (IL:\\\, INIT-FORM))))) (T (IL:BQUOTE (((IL:\\\, KEYWORD-PAIR) NIL (IL:\\\, (GENSYM)))))))))) SLOTS))
+
+(DEFUN BUILD-CONSTRUCTOR-SLOT-SETFS (SLOTS ARGUMENT-LIST PS) (IL:* IL:|;;| "Builds the setfs that initialize the slots in a constructor") (LET ((STRUCTURE-TYPE (PS-TYPE PS)) (OBJECT-NAME (PS-NAME PS)) (ARGUMENT-LIST ARGUMENT-LIST)) (IL:* IL:|;;| "The argument list does not have arguments for \"invisible\" slots.") (MAPCAR (FUNCTION (LAMBDA (SLOT) (COND ((NOT (PSLOT-ACCESSOR SLOT)) (IL:* IL:|;;| "invisible slot, so generate a setf to it's initial-value") (IL:BQUOTE (SETF (IL:\\\, (ACCESSOR-BODY SLOT OBJECT-NAME STRUCTURE-TYPE T)) (IL:\\\, (PSLOT-INITIAL-VALUE SLOT))))) (T (LET* ((ARGUMENT (POP ARGUMENT-LIST)) (KEYWORD-VAR-NAME (CADAR ARGUMENT)) (INITIAL-VALUE-FORM (CADR ARGUMENT))) (IL:* IL:|;;| "since slots can be read-only, we setf the raw accessor, not the slot accessor.") (IL:* IL:|;;| "Also, since we built the object in which we are setting fields, we use the internal-accessor without typecheck") (IF INITIAL-VALUE-FORM (IL:BQUOTE (SETF (IL:\\\, (ACCESSOR-BODY SLOT OBJECT-NAME STRUCTURE-TYPE T)) (IL:\\\, KEYWORD-VAR-NAME))) (IL:BQUOTE (IF (IL:\\\, (CADDR ARGUMENT)) (SETF (IL:\\\, (ACCESSOR-BODY SLOT OBJECT-NAME STRUCTURE-TYPE T)) (IL:\\\, KEYWORD-VAR-NAME)))))))))) SLOTS)))
+
+(DEFUN BOA-CONSTRUCTOR-P (CONSTRUCTOR) (IL:* IL:|;;| "Returns t if the constructor is a By Order of Arguments constructor") (CONSP CONSTRUCTOR))
+
+(DEFUN DEFAULT-CONSTRUCTOR-NAME (STRUCTURE-NAME) (VALUES (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" (STRING STRUCTURE-NAME)))))
+
+
+
+(IL:* IL:|;;;| "copiers")
+
+
+(DEFUN DEFINE-COPIERS (PS) (IL:* IL:|;;| "Returns the form that when evaluated, defines the copier") (IF (NOT (PS-TEMPLATE PS)) (LET ((COPIER (PS-COPIER PS)) (RESULT-ARG (QUOTE NEW)) (FROM-ARG (PS-NAME PS))) (IF COPIER (MULTIPLE-VALUE-BIND (FROM-ARG-TYPE-CHECK TYPE-CHECK-SLOTS?) (BUILD-COPIER-TYPE-CHECK PS FROM-ARG) (LET ((SLOT-SETFS (BUILD-COPIER-SLOT-SETFS (PS-ALL-SLOTS PS) (PS-TYPE PS) FROM-ARG RESULT-ARG TYPE-CHECK-SLOTS?)) (EXPORTNAME (PS-EXPORT PS))) (IF (OR (EQ EXPORTNAME T) (MEMBER :COPIER EXPORTNAME)) (EXPORT (PS-COPIER PS))) (IL:* IL:\; "Edited by TT(13-June-90) Export Option follow up") (IL:* IL:|;;| "Since we just built the object we're setting fields of, we don't need to type check it.") (IL:BQUOTE ((DEFUN (IL:\\\, (PS-COPIER PS)) ((IL:\\\, FROM-ARG)) (IL:\\\,@ FROM-ARG-TYPE-CHECK) (LET (((IL:\\\, RESULT-ARG) (IL:\\\, (RAW-CONSTRUCTOR PS)))) (IL:\\\,@ SLOT-SETFS) (IL:\\\, RESULT-ARG)))))))))))
+
+(DEFUN BUILD-COPIER-SLOT-SETFS (SLOTS STRUCTURE-TYPE FROM-ARGUMENT TO-ARGUMENT TYPE-CHECK-SLOTS?) "constructs the forms that copy each individual slot." (IL:* IL:|;;| "build a series of forms that look like") (IL:* IL:|;;| "(setf (structure-slot to-arg) (structure-slot from-arg))") (MAPCAR (FUNCTION (LAMBDA (SLOT) (IL:BQUOTE (SETF (IL:\\\, (ACCESSOR-BODY SLOT TO-ARGUMENT STRUCTURE-TYPE T)) (IL:\\\, (ACCESSOR-BODY SLOT FROM-ARGUMENT STRUCTURE-TYPE T)))))) SLOTS))
+
+(DEFUN BUILD-COPIER-TYPE-CHECK (PS FROM-ARG) (IL:* IL:|;;| "Constructs the type checking form at the beginning of the copier and decides whether individual slots need to be type-checked.") (COND ((EQ (PS-TYPE PS) (QUOTE DATATYPE)) (IL:* IL:|;;| "If something is a datatype type check the from-arg once at the beginning.  Don't check the individual accesses.") (VALUES (IL:BQUOTE ((CHECK-TYPE (IL:\\\, FROM-ARG) (IL:\\\, (PS-NAME PS))))) NIL)) ((PS-PREDICATE PS) (IL:* IL:|;;| "if the structure has a predicate ,then call the predicate.") (VALUES (IL:BQUOTE ((OR ((IL:\\\, (PS-PREDICATE PS)) (IL:\\\, FROM-ARG)) (ERROR (IL:\\\, (FORMAT NIL "Arg not ~s: ~~S" (PS-NAME PS))) (IL:\\\, FROM-ARG))))) NIL)) (T (IL:* IL:|;;| "Otherwise, just use the type-checked slot access, so that at least the argument is assured to be a vector/list.") (VALUES NIL T))))
+
+
+
+(IL:* IL:|;;;| "print functions")
+
+
+(DEFVAR %DEFAULT-PRINT-FUNCTION (QUOTE DEFAULT-STRUCTURE-PRINTER) "print function used when none is specified in a defstruct")
+
+
+
+(IL:* IL:|;;;| "internal stuff.")
+
+
+(DEFSETF IL:FFETCHFIELD IL:FREPLACEFIELD)
+
+
+
+(IL:* IL:|;;;| "utilities")
+
+
+(DEFMACRO DEFSTRUCT-ASSERT-SUBTYPEP (TYPE1 TYPE2 (ERROR-STRING . ERROR-ARGS) &REST CERROR-ACTIONS) (IL:* IL:|;;| "Provides an interface for places where the implementor isn't sure that subtypep can be trusted") (LET ((ERROR-STRING (OR ERROR-STRING "~S is not a subtype of ~S")) (ERROR-ARGS (OR ERROR-ARGS (LIST TYPE1 TYPE2)))) (IL:BQUOTE (MULTIPLE-VALUE-BIND (SUBTYPE? CERTAIN?) (SUBTYPEP (IL:\\\, TYPE1) (IL:\\\, TYPE2)) (COND (SUBTYPE? (IL:* IL:\; "it's ok, continue") T) (CERTAIN? (IL:* IL:\; "subtypep says it sure, so blow up") (ERROR (IL:\\\, ERROR-STRING) (IL:\\\,@ ERROR-ARGS))) (T (IL:* IL:\; "subtypep isn't sure, so raise a continuable error") (CERROR "Assume subtypep should return t" (IL:\\\, (FORMAT NIL "Perhaps, ~a" ERROR-STRING)) (IL:\\\,@ ERROR-ARGS)) (IL:\\\,@ CERROR-ACTIONS) T))))))
+
+
+
+(IL:* IL:|;;;| "inspecting structures")
+
+
+(DEFUN STRUCTURE-OBJECT-P (OBJECT) (TYPEP OBJECT (QUOTE STRUCTURE-OBJECT)))
+
+(DEFUN INSPECT-STRUCTURE-OBJECT (STRUCTURE OBJECTTYPE WHERE) "calls the system facilities with the appropriate slots and functions." (IL:INSPECTW.CREATE STRUCTURE (PS-ALL-SLOTS (PARSED-STRUCTURE (TYPE-OF STRUCTURE))) (QUOTE STRUCTURE-OBJECT-INSPECT-FETCHFN) (QUOTE STRUCTURE-OBJECT-INSPECT-STOREFN) (QUOTE STRUCTURE-OBJECT-PROPCOMMANDFN) NIL NIL (LET ((XCL:*PRINT-STRUCTURE* NIL)) (CONCATENATE (QUOTE STRING) (PRINC-TO-STRING STRUCTURE) " Inspector")) NIL WHERE (QUOTE STRUCTURE-OBJECT-INSPECT-PROPPRINTFN)))
+
+(DEFUN STRUCTURE-OBJECT-INSPECT-FETCHFN (OBJECT PROPERTY) (IF (PSLOT-ACCESSOR PROPERTY) (FUNCALL (PSLOT-ACCESSOR PROPERTY) OBJECT) (IL:FETCHFIELD (PSLOT-FIELD-DESCRIPTOR PROPERTY) OBJECT)))
+
+(DEFUN STRUCTURE-OBJECT-INSPECT-PROPPRINTFN (PROPERTY DATUM) (PSLOT-NAME PROPERTY))
+
+(DEFUN STRUCTURE-OBJECT-INSPECT-STOREFN (OBJECT PROPERTY NEWVALUE) (IL:* IL:|;;| "this effectively does (eval `(setf (,(pslot-accessor property) object) newvalue)) ") (IF (PSLOT-ACCESSOR PROPERTY) (EVAL (IL:BQUOTE (SETF ((IL:\\\, (PSLOT-ACCESSOR PROPERTY)) (QUOTE (IL:\\\, OBJECT))) (QUOTE (IL:\\\, NEWVALUE))))) (IL:REPLACEFIELD (PSLOT-FIELD-DESCRIPTOR PROPERTY) OBJECT NEWVALUE)))
+
+(DEFUN STRUCTURE-OBJECT-PROPCOMMANDFN (PROPERTY DATUM INSPECTOR-WINDOW) (IF (AND (TYPEP DATUM (QUOTE STRUCTURE-OBJECT)) (PSLOT-READ-ONLY PROPERTY)) (IL:PROMPTPRINT "Can't set a read-only slot.") (IL:DEFAULT.INSPECTW.PROPCOMMANDFN PROPERTY DATUM INSPECTOR-WINDOW)))
+
+
+
+(IL:* IL:|;;| "Defined last so functions required to load a defstruct are loaded first")
+
+
+(DEFSTRUCT (PS (:TYPE LIST) :NAMED) (IL:* IL:|;;;| "Contains the parsed information for a SINGLE structure type") (IL:* IL:|;;| "most values are not defaulted here, because the defaults depend on other slot values (e.g. predicate depends on type and named.)  These defaults are installed in ensure-consistent-ps.") (NAME) (IL:* IL:\; "The name of the structure") (STANDARD-CONSTRUCTOR) (IL:* IL:\; "Contains the constructor to be used by the #s reader.") (ALL-SLOT-NAMES) (IL:* IL:\; "The slot-name list used by the inspector.") (TYPE %DEFAULT-DEFSTRUCT-TYPE) (IL:* IL:\; "Is this structure a datatype, list or vector.") (VECTOR-TYPE) (IL:* IL:\; "If its a vector, this is the element-type of the vector") (INCLUDE NIL) (IL:* IL:\; "The included structure, if any.") (CONC-NAME) (CONSTRUCTORS %NO-CONSTRUCTOR) (IL:* IL:\; "A list of the constructors for this structure.  Boas have the argument list, not just the name.") (PREDICATE %NO-PREDICATE) (PRINT-FUNCTION) (COPIER %NO-COPIER) (NAMED NIL) (INITIAL-OFFSET 0) (LOCAL-SLOTS NIL) (IL:* IL:\; "The slot descriptors for slots present locally (not included).") (ALL-SLOTS) (IL:* IL:\; "The list of slot descriptors for every slot present in an instance of this slot.") (INCLUDED-SLOTS) (IL:* IL:\; "Slots specified in the :include option.") (IL:* IL:|;;| "Redundant") (DOCUMENTATION-STRING) (IL:* IL:|;;| "Unused") (FIELD-SPECIFIERS) (IL:* IL:\; "The position of each slot in the structure.  For vectors and  list structures, it is just an offset.  For datatypes, it is a field-specifier for fetchield.") (IL:* IL:|;;| "Unused") (POINTER-DESCRIPTORS) (IL:* IL:\; "the descriptors for all fields which the circle-printer must scan.  It is filled in the first time it is needed.") (INLINE T) (IL:* IL:\; "Flag telling whether or not functions built by defstruct are inline or not.") (FAST-ACCESSORS NIL) (IL:* IL:\; "Flag telling whether or not accessor functions should check the type of the object before slot accesses.") (TEMPLATE NIL) (IL:* IL:\; "As in IL:BLOCKRECORD. Implies type datatype, no copier, predicate or constructors, and fast accessors. No datatype is declared for this option.") (EXPORT NIL) (IL:* IL:\; "EXPORT indicates  export of Structure's functions"))
+
+(DEFSTRUCT (PARSED-SLOT (:CONC-NAME PSLOT-) (:TYPE LIST)) "describes a single slot in a structure" (NAME NIL :TYPE SYMBOL) (INITIAL-VALUE NIL) (TYPE %DEFAULT-SLOT-TYPE) (READ-ONLY NIL) FIELD-DESCRIPTOR ACCESSOR)
+
+
+
+(IL:* IL:|;;| "Mapping between names of generated functions and their associated structures")
+
+
+(DEFUN STRUCTURE-FUNCTION-P (SYMBOL) (CATCH (QUOTE FOUND) (MAPHASH (FUNCTION (LAMBDA (KEY PS) (IF (OR (AND (CONSP (PS-CONSTRUCTORS PS)) (MEMBER SYMBOL (PS-CONSTRUCTORS PS) :TEST (FUNCTION EQ))) (EQ SYMBOL (PS-PREDICATE PS)) (EQ SYMBOL (PS-COPIER PS)) (DOLIST (SLOT (PS-ALL-SLOTS PS)) (IF (EQ SYMBOL (PSLOT-ACCESSOR SLOT)) (RETURN (PS-NAME PS))))) (THROW (QUOTE FOUND) KEY)))) *PARSED-DEFSTRUCTS*)))
+
+(DEFUN STRUCTURE-FUNCTIONS (STRUCTURE-NAME) (LET ((PS (PARSED-STRUCTURE STRUCTURE-NAME))) (IL:BQUOTE ((IL:\\\,@ (PS-CONSTRUCTORS PS)) (IL:\\\,. (LET ((PREDICATE (PS-PREDICATE PS))) (IF PREDICATE (LIST PREDICATE)))) (IL:\\\,. (LET ((COPIER (PS-COPIER PS))) (IF COPIER (LIST COPIER)))) (IL:\\\,. (MAPCAN (FUNCTION (LAMBDA (SLOT) (LET ((ACCESSOR (PSLOT-ACCESSOR SLOT))) (AND ACCESSOR (LIST ACCESSOR))))) (PS-ALL-SLOTS PS)))))))
+
+
+
+(IL:* IL:|;;;| "Editing structures")
+
+
+(DEFUN STRUCTURES.HASDEF (NAME &OPTIONAL TYPE SOURCE SPELLFLG) (OR (STRUCTURE-FUNCTION-P NAME) (IL:GETDEF NAME (QUOTE IL:STRUCTURES) (QUOTE IL:CURRENT) (QUOTE (IL:NODWIM IL:NOCOPY IL:NOERROR IL:HASDEF)))))
+
+(DEFUN STRUCTURES.EDITDEF (NAME TYPE SOURCE EDITCOMS OPTIONS) "From accessor function or structure name, edit the structure." (IL:* IL:\; "Edited by TT (8-June-90 : solution for AR#11127)") (IF (PARSED-STRUCTURE NAME T) (IL:DEFAULT.EDITDEF NAME (QUOTE IL:STRUCTURES) SOURCE EDITCOMS OPTIONS) (LET ((STRUCTURE-NAME (STRUCTURE-FUNCTION-P NAME))) (IL:* IL:\; "Accessor functions are identified as structures, edit the structure instead.") (IF STRUCTURE-NAME (IL:DEFAULT.EDITDEF STRUCTURE-NAME (QUOTE IL:STRUCTURES) SOURCE EDITCOMS OPTIONS) (IL:DEFAULT.EDITDEF NAME TYPE SOURCE EDITCOMS OPTIONS)))) NAME)
+
+(IL:FILEPKGTYPE (QUOTE IL:STRUCTURES) (QUOTE IL:HASDEF) (QUOTE STRUCTURES.HASDEF) (QUOTE IL:EDITDEF) (QUOTE STRUCTURES.EDITDEF))
+
+(IL:ADDTOVAR IL:SHADOW-TYPES (IL:STRUCTURES IL:FNS))
+(IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD 
+
+(IL:ADDTOVAR IL:INSPECTMACROS ((IL:FUNCTION STRUCTURE-OBJECT-P) . INSPECT-STRUCTURE-OBJECT))
+)
+
+
+
+(IL:* IL:|;;;| "file properties")
+
+
+(IL:PUTPROPS IL:DEFSTRUCT IL:FILETYPE :COMPILE-FILE)
+
+(IL:PUTPROPS IL:DEFSTRUCT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
+(IL:PUTPROPS IL:DEFSTRUCT IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1900 1988 1989 1990 1991
+ 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/DEFSTRUCT-RUN-TIME b/CLTL2/DEFSTRUCT-RUN-TIME
new file mode 100644
index 00000000..1cf81c0a
--- /dev/null
+++ b/CLTL2/DEFSTRUCT-RUN-TIME
@@ -0,0 +1,355 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
+(IL:FILECREATED "18-Oct-93 15:27:40" 
+"{Pele:mv:envos}<LispCore>Sources>CLTL2>DEFSTRUCT-RUN-TIME.;2" 15658  
+
+      IL:|previous| IL:|date:| "29-Aug-91 17:01:45" 
+"{Pele:mv:envos}<LispCore>Sources>CLTL2>DEFSTRUCT-RUN-TIME.;1")
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:DEFSTRUCT-RUN-TIMECOMS)
+
+(IL:RPAQQ IL:DEFSTRUCT-RUN-TIMECOMS
+          ((IL:COMS 
+
+                  (IL:* IL:|;;| "Remembering parsed structures")
+
+                  (IL:VARIABLES *PARSED-DEFSTRUCTS*)
+                  (IL:FUNCTIONS PARSED-STRUCTURE SET-PARSED-STRUCTURE)
+                  (IL:SETFS PARSED-STRUCTURE))
+           (IL:COMS 
+
+                  (IL:* IL:|;;| "Declaring storage for structures")
+
+                  (IL:FUNCTIONS SI::%STRUCTURE-DECLARE-DATATYPE)
+                  (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY 
+
+                         (IL:* IL:|;;| "This defines the root of the defstruct type hierarchy.")
+
+                         (IL:P (IL:\\ASSIGNDATATYPE1 'STRUCTURE-OBJECT NIL 0))))
+           (IL:COMS 
+
+                  (IL:* IL:|;;| "Support for setf expansions etc")
+
+                  (IL:VARIABLES *DEFSTRUCT-INFO-CACHE*)
+                  (IL:FUNCTIONS ESTABLISH-SETFS-AND-OPTIMIZERS ESTABLISH-PREDICATE)
+                  (IL:FUNCTIONS GET-PS-FROM-ACCESSOR GET-PS-FROM-PREDICATE 
+                         GET-SLOT-DESCRIPTOR-FROM-PS)
+                  (IL:FUNCTIONS CACHE-SETF-INFO))
+           (IL:COMS 
+
+                  (IL:* IL:|;;| "defstruct IO")
+
+                  (IL:VARIABLES XCL:*PRINT-STRUCTURE*)
+                  (IL:FUNCTIONS PRINT-STRUCTURE-INSTANCE DEFAULT-STRUCTURE-PRINTER 
+                         STRUCTURE-SLOT-NAMES)
+                  
+                  (IL:* IL:|;;| "For reading")
+
+                  (IL:FUNCTIONS IL:CREATE-STRUCTURE STRUCTURE-CONSTRUCTOR))
+           (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                  IL:DEFSTRUCT-RUN-TIME)
+           (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS
+                                                                                         (IL:NLAMA)
+                                                                                         (IL:NLAML)
+                                                                                         (IL:LAMA)))))
+
+
+
+(IL:* IL:|;;| "Remembering parsed structures")
+
+
+(DEFVAR *PARSED-DEFSTRUCTS* (IL:HASHARRAY 100)
+
+                                (IL:* IL:|;;| "All declared structures")
+
+                                )
+
+(DEFMACRO PARSED-STRUCTURE (NAME &OPTIONAL (NO-ERROR NIL))
+
+   (IL:* IL:|;;| "Returns the parsed-structure corresponding to name")
+
+   (COND
+      (NO-ERROR `(IL:GETHASH ,NAME *PARSED-DEFSTRUCTS*))
+      (T `(OR (IL:GETHASH ,NAME *PARSED-DEFSTRUCTS*)
+              (ERROR "~s is not a defined structure" ,NAME)))))
+
+(DEFUN SET-PARSED-STRUCTURE (NAME PS &OPTIONAL (EXTRA NIL EXTRA-P))
+
+   (IL:* IL:|;;| "SETF method for CL::PARSED-STRUCTURE.  Extra arg is because CL::PARSED-STRUCTURE takes an optional, which we ignore here, but that pushes the new value over one.")
+
+   (WHEN EXTRA-P (SETQ PS EXTRA))
+   (IL:PUTHASH NAME PS *PARSED-DEFSTRUCTS*))
+
+(DEFSETF PARSED-STRUCTURE SET-PARSED-STRUCTURE)
+
+
+
+(IL:* IL:|;;| "Declaring storage for structures")
+
+
+(DEFUN SI::%STRUCTURE-DECLARE-DATATYPE (NAME FIELD-SPECIFICATIONS FIELD-DESCRIPTORS WORD-LENGTH 
+                                                 SUPERTYPE)
+
+(IL:* IL:|;;;| "analagous to declare-datatype, but does not prepend the supers descriptors. You must include all descs.")
+
+(IL:* IL:|;;;| "N.B.  descriptions and specs are for ALL slots, not just local-slots.")
+
+   (IL:* IL:|;;| "field-specifications is a list of the form '(pointer pointer (bits 3) (bits 5) word fixp).  See p. 8.21 IRM")
+
+   (IL:* IL:|;;| "field-descriptors is the list returned from translate.datatype when given the above FIELD-SPECIFICATIONS.  They are legal to pass to fetchfield.")
+
+   (IL:* IL:|;;| "word-length is the car of the result of translate.datatype.")
+
+   (IL:* IL:|;;| "supertype is the typename of the supertype.")
+
+   (IF (NOT (AND (SYMBOLP NAME)
+                 (IL:SMALLPOSP WORD-LENGTH)))
+       (ERROR "Illegal arguments: ~s ~s" NAME WORD-LENGTH))
+   (LET ((REFERENCE-COUNTED-POINTERS (MAPCAN #'(LAMBDA (DESCRIPTOR)
+                                                      (CASE (CADDR DESCRIPTOR)
+                                                          ((IL:POINTER IL:FULLPOINTER) 
+                                                             (LIST (CADR DESCRIPTOR)))))
+                                            FIELD-DESCRIPTORS)))
+        (MULTIPLE-VALUE-BIND (TYPE-NUMBER REDECLARED?)
+               (IL:\\ASSIGNDATATYPE1 NAME FIELD-DESCRIPTORS WORD-LENGTH FIELD-SPECIFICATIONS 
+                      REFERENCE-COUNTED-POINTERS SUPERTYPE)
+
+               (IL:* IL:|;;| "set the magic global to the allocated type number")
+
+               (IL:SETTOPVAL (IL:\\TYPEGLOBALVARIABLE NAME T)
+                      TYPE-NUMBER)
+               (VALUES FIELD-DESCRIPTORS REDECLARED?))))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY 
+
+(IL:\\ASSIGNDATATYPE1 'STRUCTURE-OBJECT NIL 0)
+)
+
+
+
+(IL:* IL:|;;| "Support for setf expansions etc")
+
+
+(DEFVAR *DEFSTRUCT-INFO-CACHE* (IL:HASHARRAY 100)
+
+                                   (IL:* IL:|;;| "Used to cache slots and predicates")
+
+                                   )
+
+(DEFUN ESTABLISH-SETFS-AND-OPTIMIZERS (PS-NAME)
+
+   (IL:* IL:|;;| "Caches shared setf expanders and accessor optimizers where appropriate")
+
+   (LET* ((PS (PARSED-STRUCTURE PS-NAME))
+          (INLINE (PS-INLINE PS)))
+         (MAPC #'(LAMBDA (SLOT)
+
+                        (IL:* IL:|;;| 
+     "function-defining-form decides whether or not the accessors should be defun, definline, etc.")
+
+                        (LET ((ACCESSOR (PSLOT-ACCESSOR SLOT)))
+                             (WHEN ACCESSOR
+                                 (REMHASH ACCESSOR *DEFSTRUCT-INFO-CACHE*)
+                                 (IF (NOT (PSLOT-READ-ONLY SLOT))
+
+                                     (IL:* IL:|;;| 
+                                "install the setf method expander that is shared for all accessors")
+
+                                     (SET-SHARED-SETF-INVERSE ACCESSOR 
+                                            'DEFSTRUCT-SHARED-SETF-EXPANDER))
+                                 (COND
+                                    ((EQ INLINE :ONLY)
+                                     (SETF (MACRO-FUNCTION ACCESSOR)
+                                           'DEFSTRUCT-SHARED-ACCESSOR-OPTIMIZER))
+                                    ((MEMBER :ACCESSOR INLINE :TEST #'EQ)
+                                     (SETF (GET ACCESSOR 'COMPILER:OPTIMIZER-LIST)
+                                           (LIST 'DEFSTRUCT-SHARED-ACCESSOR-OPTIMIZER)))
+                                    (T (REMPROP ACCESSOR 'COMPILER:OPTIMIZER-LIST))))))
+               (PS-ALL-SLOTS PS))))
+
+(DEFUN ESTABLISH-PREDICATE (PS-NAME)
+
+   (IL:* IL:|;;| "Establishes a shared a shared optimizer for a defstruct predicate")
+
+   (LET* ((PS (PARSED-STRUCTURE PS-NAME))
+          (PREDICATE (PS-PREDICATE PS)))
+         (REMHASH PREDICATE *DEFSTRUCT-INFO-CACHE*)
+         (IF (EQ (PS-INLINE PS)
+                 :ONLY)
+             (SETF (MACRO-FUNCTION PREDICATE)
+                   'DEFSTRUCT-SHARED-PREDICATE-OPTIMIZER)
+             (SETF (GET PREDICATE 'COMPILER:OPTIMIZER-LIST)
+                   (LIST 'DEFSTRUCT-SHARED-PREDICATE-OPTIMIZER)))))
+
+(DEFUN GET-PS-FROM-ACCESSOR (ACCESSOR &OPTIONAL (NO-ERROR-P NIL))
+   (OR (CATCH 'FIND-PS
+           (MAPHASH #'(LAMBDA (KEY VALUE)
+                             (DOLIST (SLOT (PS-ALL-SLOTS VALUE)
+                                           NIL)
+                                 (IF (EQ ACCESSOR (PSLOT-ACCESSOR SLOT))
+                                     (THROW 'FIND-PS VALUE))))
+                  *PARSED-DEFSTRUCTS*))
+       (IF (NULL NO-ERROR-P)
+           (ERROR "No such slot: ~s" ACCESSOR))))
+
+(DEFUN GET-PS-FROM-PREDICATE (PREDICATE &OPTIONAL (NO-ERROR-P NIL))
+   (OR (CATCH 'FIND-PS
+           (MAPHASH #'(LAMBDA (KEY VALUE)
+                             (IF (EQ PREDICATE (PS-PREDICATE VALUE))
+                                 (THROW 'FIND-PS VALUE)))
+                  *PARSED-DEFSTRUCTS*))
+       (IF (NULL NO-ERROR-P)
+           (ERROR "No such predicate: ~s" PREDICATE))))
+
+(DEFUN GET-SLOT-DESCRIPTOR-FROM-PS (ACCESSOR PS &OPTIONAL (NO-ERROR-P NIL))
+   (OR (DOLIST (SLOT (PS-ALL-SLOTS PS)
+                     NIL)
+           (IF (EQ ACCESSOR (PSLOT-ACCESSOR SLOT))
+               (RETURN SLOT)))
+       (IF (NULL NO-ERROR-P)
+           (ERROR "No such slot: ~s" ACCESSOR))))
+
+(DEFUN CACHE-SETF-INFO (PS-NAME)
+
+   (IL:* IL:|;;| "For compatability with the old defstruct")
+
+   (LET ((PS (PARSED-STRUCTURE PS-NAME)))
+        (MAPC #'(LAMBDA (SLOT)
+
+                       (IL:* IL:|;;| 
+     "function-defining-form decides whether or not the accessors should be defun, definline, etc.")
+
+                       (LET ((ACCESSOR (PSLOT-ACCESSOR SLOT)))
+                            (WHEN ACCESSOR
+                                (REMHASH ACCESSOR *DEFSTRUCT-INFO-CACHE*)
+                                (IF (NOT (PSLOT-READ-ONLY SLOT))
+
+                                    (IL:* IL:|;;| 
+                                "install the setf method expander that is shared for all accessors")
+
+                                    (SET-SHARED-SETF-INVERSE ACCESSOR 
+                                           'DEFSTRUCT-SHARED-SETF-EXPANDER)))))
+              (PS-ALL-SLOTS PS))))
+
+
+
+(IL:* IL:|;;| "defstruct IO")
+
+
+(DEFVAR XCL:*PRINT-STRUCTURE* T
+   "Flag indicating whether the contents of structures are to be printed.")
+
+(DEFUN PRINT-STRUCTURE-INSTANCE (OBJECT STREAM DEPTH)
+
+   (IL:* IL:|;;| "Looks up the print function for the structure instance and calls it; observes *print-circle* and XCL:*PRINT-STRUCTURE* from here, too.")
+
+   (LET (LABEL (FIRST-TIME? T))
+        (WHEN IL:*PRINT-CIRCLE-HASHTABLE*
+            (MULTIPLE-VALUE-SETQ (LABEL FIRST-TIME?)
+                   (IL:PRINT-CIRCLE-LOOKUP OBJECT)))
+        (WHEN LABEL
+
+            (IL:* IL:|;;| "this guy needs to be flagged for circle-printing")
+
+            (IL:PRIN3 LABEL STREAM))
+        (WHEN (OR (NOT LABEL)
+                  FIRST-TIME?)
+            (FUNCALL (OR (PS-PRINT-FUNCTION (PARSED-STRUCTURE (TYPE-OF OBJECT)))
+                         %DEFAULT-PRINT-FUNCTION)
+                   OBJECT STREAM (OR DEPTH 0)))
+        T))
+
+(DEFUN DEFAULT-STRUCTURE-PRINTER (STRUC STREAM &OPTIONAL (PRINT-LEVEL 0))
+   (IF (NOT XCL:*PRINT-STRUCTURE*)
+       (IL:\\PRINT-USING-ADDRESS STRUC STREAM 0)
+       (LET ((*PRINT-LEVEL* (AND *PRINT-LEVEL* (1- *PRINT-LEVEL*))))
+            (IF (OR (AND *PRINT-LEVEL* (<= *PRINT-LEVEL* PRINT-LEVEL))
+                    (AND *PRINT-LENGTH* (<= *PRINT-LENGTH* 0)))
+                (IL:\\ELIDE.PRINT.ELEMENT STREAM)
+                (LET ((LENGTHSOFAR (IF *PRINT-LENGTH* 0))
+                      (TYPE (IL:TYPENAME STRUC)))
+                     (IL:\\OUTCHAR STREAM (IL:|fetch| (READTABLEP IL:HASHMACROCHAR) IL:|of|
+                                                                                        *READTABLE*))
+                     (WRITE-STRING "S(" STREAM)
+                     (IF (AND LENGTHSOFAR (> (INCF LENGTHSOFAR)
+                                             *PRINT-LENGTH*))
+                         (IL:\\ELIDE.PRINT.TAIL STREAM T)
+                         (PROGN (IF *PRINT-ESCAPE*
+                                    (PRIN1 TYPE STREAM)
+                                    (PRINC TYPE STREAM))
+                                (DO ((FIELD (STRUCTURE-SLOT-NAMES TYPE)
+                                            (CDR FIELD))
+                                     (DESCRIPTOR (IL:GETDESCRIPTORS TYPE)
+                                            (CDR DESCRIPTOR)))
+                                    ((NULL FIELD))
+                                  (WHEN (EQ (CAR FIELD)
+                                            'SI::--STRUCTURE-DUMMY-SLOT--)
+                                        (GO SKIP))
+                                  (IL:\\OUTCHAR STREAM (IL:CONSTANT (CHAR-CODE #\Space)))
+                                  (IF (AND LENGTHSOFAR (> (INCF LENGTHSOFAR)
+                                                          *PRINT-LENGTH*))
+                                      (PROGN (IL:\\ELIDE.PRINT.TAIL STREAM T)
+                                             (RETURN NIL))
+                                      (PROGN (PRINC (CAR FIELD)
+                                                    STREAM)
+                                             (IF (AND LENGTHSOFAR (> (INCF LENGTHSOFAR)
+                                                                     *PRINT-LENGTH*))
+                                                 (PROGN (IL:\\ELIDE.PRINT.TAIL STREAM T)
+                                                        (RETURN NIL))
+                                                 (PROGN (IL:\\OUTCHAR STREAM (IL:CONSTANT
+                                                                              (CHAR-CODE #\Space)))
+                                                        (IL:\\PRINDATUM (IL:FETCHFIELD (CAR 
+                                                                                           DESCRIPTOR
+                                                                                            )
+                                                                               STRUC)
+                                                               STREAM
+                                                               (1+ PRINT-LEVEL))))))
+                                  SKIP)))
+                     (WRITE-STRING ")" STREAM)))
+            T)))
+
+(DEFUN STRUCTURE-SLOT-NAMES (STRUCTURE-NAME &OPTIONAL (DONT-COPY NIL))
+   (LET* ((PS (PARSED-STRUCTURE STRUCTURE-NAME))
+          NAMES)
+         (SETQ NAMES (PS-ALL-SLOT-NAMES PS))
+         (IF DONT-COPY
+             NAMES
+             (COPY-LIST NAMES))))
+
+
+
+(IL:* IL:|;;| "For reading")
+
+
+(DEFUN IL:CREATE-STRUCTURE (STRUCTURE-FORM)
+   (APPLY (STRUCTURE-CONSTRUCTOR (CAR STRUCTURE-FORM))
+          (XCL:WITH-COLLECTION (DO ((TAIL (CDR STRUCTURE-FORM)
+                                          (CDDR TAIL)))
+                                   ((NULL TAIL))
+                                 (XCL:COLLECT (IL:MAKE-KEYWORD (CAR TAIL)))
+                                 (XCL:COLLECT (CADR TAIL))))))
+
+(DEFUN STRUCTURE-CONSTRUCTOR (STRUCTURE-NAME)
+   (OR (GET STRUCTURE-NAME 'IL:STRUCTURE-CONSTRUCTOR)
+       (LET* ((PS (PARSED-STRUCTURE STRUCTURE-NAME))
+              (CONSTRUCTOR (PS-STANDARD-CONSTRUCTOR PS)))
+             (OR CONSTRUCTOR (ERROR "~S is a structure with no standard constructor." (PS-NAME PS))))
+       ))
+
+(IL:PUTPROPS IL:DEFSTRUCT-RUN-TIME IL:FILETYPE COMPILE-FILE)
+
+(IL:PUTPROPS IL:DEFSTRUCT-RUN-TIME IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA )
+
+(IL:ADDTOVAR IL:NLAML )
+
+(IL:ADDTOVAR IL:LAMA )
+)
+(IL:PUTPROPS IL:DEFSTRUCT-RUN-TIME IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 
+1993))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/DEFSTRUCT-RUN-TIME.LCOM b/CLTL2/DEFSTRUCT-RUN-TIME.LCOM
new file mode 100644
index 00000000..98932c18
Binary files /dev/null and b/CLTL2/DEFSTRUCT-RUN-TIME.LCOM differ
diff --git a/CLTL2/DEFSTRUCT.DFASL b/CLTL2/DEFSTRUCT.DFASL
new file mode 100644
index 00000000..6e693d33
Binary files /dev/null and b/CLTL2/DEFSTRUCT.DFASL differ
diff --git a/CLTL2/DESCRIBE b/CLTL2/DESCRIBE
new file mode 100644
index 00000000..9bf74cbc
--- /dev/null
+++ b/CLTL2/DESCRIBE
@@ -0,0 +1,324 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "SYSTEM")
+(IL:FILECREATED "18-Oct-93 15:29:00" "{Pele:mv:envos}<LispCore>Sources>CLTL2>DESCRIBE.;2" 14735  
+
+      IL:|previous| IL:|date:| " 4-Feb-92 12:21:53" 
+"{Pele:mv:envos}<LispCore>Sources>CLTL2>DESCRIBE.;1")
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:DESCRIBECOMS)
+
+(IL:RPAQQ IL:DESCRIBECOMS
+          (
+           (IL:* IL:|;;| "Common LISP describe facility")
+
+           (IL:FUNCTIONS DESCRIBE DESCRIBE-INTERNAL DESCRIBE-NEW-LINE DESCRIBE-USING-DESCRIBERS 
+                  GET-SUPER-DESCRIBERS GET-INSPECT-MACRO INSPECT-MACRO-USABLE-BY-DESCRIBE? 
+                  DESCRIBE-USING-INSPECT-MACRO DESCRIBE-USING-RECORD-DECL)
+           (IL:FUNCTIONS A-OR-AN VOWEL-P)
+           (IL:DEFINE-TYPES LISP::DESCRIBERS)
+           (IL:FUNCTIONS LISP::DEFDESCRIBER GET-DESCRIBERS)
+           (IL:PROP IL:PROPTYPE DESCRIBERS)
+           (LISP::DESCRIBERS SYMBOL LISP::STRUCTURE-OBJECT CHARACTER FIXNUM SINGLE-FLOAT HASH-TABLE)
+           (IL:VARIABLES LISP::*DESCRIBE-DEPTH* LISP::*DESCRIBE-INDENT* LISP::*DESCRIBE-PRINT-LENGTH*
+                  LISP::*DESCRIBE-PRINT-LEVEL*)
+           (IL:PROPS (IL:DESCRIBE IL:MAKEFILE-ENVIRONMENT IL:FILETYPE))))
+
+
+
+(IL:* IL:|;;| "Common LISP describe facility")
+
+
+(DEFUN DESCRIBE (LISP::OBJECT &OPTIONAL STREAM)          (IL:* IL:\; 
+                                                           "Edited  3-Feb-92 11:16 by jrb:")
+   "Describe OBJECT, printing to STREAM."
+   (LET ((*PRINT-LENGTH* LISP::*DESCRIBE-PRINT-LENGTH*)
+         (*PRINT-LEVEL* LISP::*DESCRIBE-PRINT-LEVEL*)
+         (*STANDARD-OUTPUT* (IL:\\GETSTREAM STREAM)))
+        (DESCRIBE-INTERNAL LISP::OBJECT 0)
+        (VALUES)))
+
+(DEFUN DESCRIBE-INTERNAL (OBJECT DEPTH)
+
+(IL:* IL:|;;;| "Recursive entry point for descriptions.")
+
+   (IF (< DEPTH LISP::*DESCRIBE-DEPTH*)
+       (LET* ((TYPE (TYPE-OF OBJECT))
+              (TYPE-NAME (IF (CONSP TYPE)
+                             (CAR TYPE)
+                             TYPE))
+              DESCRIBERS INSPECT-MACRO SUPER-DESCRIBERS IL:DECL)
+             (DESCRIBE-NEW-LINE DEPTH)
+             (FORMAT T "~A ~A, " (A-OR-AN TYPE-NAME)
+                    TYPE-NAME)
+             (COND
+                ((SETQ DESCRIBERS (GET-DESCRIBERS TYPE-NAME))
+                 (DESCRIBE-USING-DESCRIBERS OBJECT (1+ DEPTH)
+                        DESCRIBERS))
+                ((AND (SETQ INSPECT-MACRO (GET-INSPECT-MACRO OBJECT))
+                      (INSPECT-MACRO-USABLE-BY-DESCRIBE? INSPECT-MACRO))
+                 (DESCRIBE-USING-INSPECT-MACRO OBJECT (1+ DEPTH)
+                        INSPECT-MACRO))
+                ((SETQ SUPER-DESCRIBERS (GET-SUPER-DESCRIBERS TYPE-NAME))
+                 (DESCRIBE-USING-DESCRIBERS OBJECT (1+ DEPTH)
+                        SUPER-DESCRIBERS))
+                ((SETQ IL:DECL (OR (IL:FINDRECDECL OBJECT)
+                                   (IL:FINDSYSRECDECL OBJECT)))
+                 (DESCRIBE-USING-RECORD-DECL OBJECT IL:DECL (1+ DEPTH)))
+                (T 
+                   (IL:* IL:|;;| "Punt to printing")
+
+                   (PRIN1 OBJECT))))
+       (PRIN1 OBJECT)))
+
+(DEFUN DESCRIBE-NEW-LINE (DEPTH)
+   (FRESH-LINE)
+   (DOTIMES (N (* DEPTH LISP::*DESCRIBE-INDENT*))
+       (WRITE-CHAR #\Space)))
+
+(DEFUN DESCRIBE-USING-DESCRIBERS (OBJECT DEPTH DESCRIBERS)
+   (MAPC #'(LAMBDA (DESCRIBER)
+                  (IF (AND (CONSP DESCRIBER)
+                           (STRINGP (FIRST DESCRIBER)))
+                      (MULTIPLE-VALUE-BIND (FIELD EMPTY?)
+                             (FUNCALL (SECOND DESCRIBER)
+                                    OBJECT)
+                             (UNLESS EMPTY?
+                                 (DESCRIBE-NEW-LINE DEPTH)
+                                 (FORMAT T "~A: " (FIRST DESCRIBER))
+                                 (DESCRIBE-INTERNAL FIELD (1+ DEPTH))))
+                      (FUNCALL DESCRIBER OBJECT DEPTH)))
+         DESCRIBERS))
+
+(DEFUN GET-SUPER-DESCRIBERS (TYPE)
+
+   (IL:* IL:|;;| "Search up super-types of TYPE for describers")
+
+   (DO* ((TYPE TYPE (IL:GETSUPERTYPE TYPE))
+         (DESCRIBER NIL (GET-DESCRIBERS TYPE)))
+        ((OR DESCRIBER (NULL TYPE))
+         DESCRIBER)))
+
+(DEFUN GET-INSPECT-MACRO (OBJECT)
+
+   (IL:* IL:|;;| "Search IL:INSPECTMACROS for an inspect macro for OBJECT")
+
+   (DECLARE (XCL:GLOBAL IL:INSPECTMACROS))
+   (DO* ((TAIL IL:INSPECTMACROS (REST TAIL))
+         (HEAD NIL (FIRST TAIL))
+         (TYPE NIL (FIRST HEAD))
+         (MACRO NIL (TYPECASE TYPE
+                        (CONS (AND (EQ (FIRST TYPE)
+                                       'IL:FUNCTION)
+                                   (FUNCALL (SECOND TYPE)
+                                          OBJECT)))
+                        (OTHERWISE (TYPEP OBJECT TYPE)))))
+        ((OR MACRO (NULL TAIL))
+         HEAD)))
+
+(DEFUN INSPECT-MACRO-USABLE-BY-DESCRIBE? (MACRO)
+   (CONSP (REST MACRO)))
+
+(DEFUN DESCRIBE-USING-INSPECT-MACRO (OBJECT DEPTH MACRO)
+   (LET ((FETCHFN (THIRD MACRO))
+         (FIELDS (SECOND MACRO)))
+        (MAPCAR #'(LAMBDA (FIELD-NAME)
+                         (DESCRIBE-NEW-LINE DEPTH)
+                         (PRINC FIELD-NAME)
+                         (PRINC ": ")
+                         (DESCRIBE-INTERNAL (FUNCALL FETCHFN OBJECT FIELD-NAME)
+                                (1+ DEPTH)))
+               (IF (CONSP FIELDS)
+                   FIELDS
+                   (FUNCALL FIELDS OBJECT)))))
+
+(DEFUN DESCRIBE-USING-RECORD-DECL (OBJECT IL:DECL DEPTH)
+   (MAPC #'(LAMBDA (FIELD-NAME)
+                  (DESCRIBE-NEW-LINE DEPTH)
+                  (FORMAT T "~A: " FIELD-NAME)
+                  (DESCRIBE-INTERNAL (IL:RECORDACCESS FIELD-NAME OBJECT IL:DECL)
+                         (1+ DEPTH)))
+         (IL:INSPECTABLEFIELDNAMES IL:DECL)))
+
+(DEFUN A-OR-AN (WORD)
+   "Return 'a' or 'an' depending upon whether the first letter in WORD is a vowel"
+   (IF (VOWEL-P (ELT (ETYPECASE WORD
+                             (SYMBOL (SYMBOL-NAME WORD))
+                             (STRING WORD))
+                         0))
+       "an"
+       "a"))
+
+(DEFUN VOWEL-P (CHAR)
+   "T if char is an A, E, I, O or U.  Not dependable with funky charsets."
+   (CASE (CHARACTER CHAR)
+       ((#\A #\a #\E #\e #\I #\i #\O #\o #\U #\u) T)
+       (OTHERWISE NIL)))
+
+(XCL:DEF-DEFINE-TYPE LISP::DESCRIBERS "Describers of objects")
+
+(XCL:DEFDEFINER LISP::DEFDESCRIBER LISP::DESCRIBERS (TYPE &REST LISP::DESCRIBERS)
+   `(SETF
+     (GET ',TYPE 'DESCRIBERS)
+     (LIST ,@(MAPCAR #'(LAMBDA (LISP::ITEM)
+
+                              (IL:* IL:|;;| 
+           "Throughout here symbols are quoted and lambda-expressions are hash-quoted for compiler")
+
+                              (IF (AND (CONSP LISP::ITEM)
+                                       (STRINGP (FIRST LISP::ITEM)))
+
+                                  (IL:* IL:|;;| "It's a field name and function")
+
+                                  `(LIST ',(FIRST LISP::ITEM)
+                                         (IF (CONSP ',(SECOND LISP::ITEM))
+                                             #',(SECOND LISP::ITEM)
+                                             ',(SECOND LISP::ITEM)))
+
+                                  (IL:* IL:|;;| "Else, it must be just a function")
+
+                                  (IF (CONSP LISP::ITEM)
+                                      `#',LISP::ITEM
+                                      `',LISP::ITEM)))
+                    LISP::DESCRIBERS))))
+
+(DEFUN GET-DESCRIBERS (TYPE)
+   (GET TYPE 'DESCRIBERS))
+
+(IL:PUTPROPS DESCRIBERS IL:PROPTYPE IGNORE)
+
+(LISP::DEFDESCRIBER SYMBOL
+
+   (IL:* IL:|;;| "This describer uses all features")
+
+   ("name" SYMBOL-NAME)                                      (IL:* IL:\; 
+                                                           "A field name and accessor")
+   (LAMBDA (SYMBOL LISP::DEPTH)                              (IL:* IL:\; "An arbitrary function")
+          (LET ((LISP::FIRST-TIME? 'T)
+                (LISP::HASH-TABLES))
+               (MAPHASH #'(LAMBDA (TYPE HASH-TABLE)
+                                 (WHEN (NOT (MEMBER HASH-TABLE LISP::HASH-TABLES :TEST #'EQ))
+                                     (PUSH HASH-TABLE LISP::HASH-TABLES)
+                                     (LET ((LISP::DOC (GETHASH SYMBOL HASH-TABLE)))
+                                          (WHEN LISP::DOC
+                                              (WHEN LISP::FIRST-TIME?
+                                                  (SETQ LISP::FIRST-TIME? 'NIL)
+                                                  (DESCRIBE-NEW-LINE LISP::DEPTH)
+                                                  (PRINC "documentation:"))
+                                              (DESCRIBE-NEW-LINE (1+ LISP::DEPTH))
+                                              (FORMAT T "~A: ~A" TYPE LISP::DOC)
+                                              NIL))))
+                      IL:*DOCUMENTATION-HASH-TABLE*)))
+   ("package cell" SYMBOL-PACKAGE)                           (IL:* IL:\; 
+                                                           "another field name & accessor")
+   ("value cell"                                             (IL:* IL:\; 
+                                                           "use of multiple values in accessor ")
+          (LAMBDA (SYMBOL)
+                 (LET ((LISP::UNBOUND? (NOT (BOUNDP SYMBOL))))
+                      (VALUES (UNLESS LISP::UNBOUND? (SYMBOL-VALUE SYMBOL))
+                             LISP::UNBOUND?))))
+   ("function cell"                                          (IL:* IL:\; "ditto")
+          (LAMBDA (SYMBOL)
+                 (LET ((LISP::UNDEFINED? (NOT (FBOUNDP SYMBOL))))
+                      (VALUES (UNLESS LISP::UNDEFINED? (SYMBOL-FUNCTION SYMBOL))
+                             LISP::UNDEFINED?))))
+   (LAMBDA (SYMBOL LISP::DEPTH)                              (IL:* IL:\; 
+                                                           "arbitratry function again")
+          (LET ((LISP::PLIST (SYMBOL-PLIST SYMBOL)))
+               (WHEN LISP::PLIST
+                   (DESCRIBE-NEW-LINE LISP::DEPTH)
+                   (PRINC "property list:")
+                   (DO ((LISP::PLIST LISP::PLIST (CDDR LISP::PLIST)))
+                       ((NULL LISP::PLIST))
+                     (DESCRIBE-NEW-LINE (1+ LISP::DEPTH))
+                     (PRIN1 (FIRST LISP::PLIST))
+                     (PRINC " : ")
+
+                     (IL:* IL:|;;| "Recurse on each property")
+
+                     (DESCRIBE-INTERNAL (SECOND LISP::PLIST)
+                            (+ LISP::DEPTH 2)))))))
+
+(LISP::DEFDESCRIBER LISP::STRUCTURE-OBJECT
+
+   (IL:* IL:|;;| "Describer for objects created by DEFSTRUCT")
+
+   (LAMBDA (LISP::OBJECT LISP::DEPTH)
+          (MAPC #'(LAMBDA (LISP::SLOT)
+                         (DESCRIBE-NEW-LINE LISP::DEPTH)
+                         (FORMAT T "~A: " (LISP::PSLOT-NAME LISP::SLOT))
+
+                         (IL:* IL:|;;| "Recurse on fields")
+
+                         (DESCRIBE-INTERNAL (FUNCALL (LISP::PSLOT-ACCESSOR LISP::SLOT)
+                                                       LISP::OBJECT)
+                                (1+ LISP::DEPTH)))
+                (LISP::PS-ALL-SLOTS (LISP::PARSED-STRUCTURE (TYPE-OF LISP::OBJECT))))))
+
+(LISP::DEFDESCRIBER CHARACTER
+   (LAMBDA (CHAR LISP::DEPTH)
+          (MULTIPLE-VALUE-CALL 'FORMAT T 
+                 "'~:@C', code #\\~O-~3,'0O (~D decimal, ~:*~X hex, ~:*~B binary)" CHAR
+                 (FLOOR (CHAR-CODE CHAR)
+                        256)
+                 (CHAR-CODE CHAR))))
+
+(LISP::DEFDESCRIBER FIXNUM (LAMBDA (NUMBER LISP::DEPTH)
+                                      (FORMAT T 
+                              "~D decimal, ~:*~O octal, ~:*~X hex, ~:*~B binary~@[, '~C' character~]"
+                                             NUMBER (INT-CHAR NUMBER))))
+
+(LISP::DEFDESCRIBER SINGLE-FLOAT
+   ("sign" (LAMBDA (FLOAT)
+                  (ECASE (FLOAT-SIGN FLOAT)
+                      (1.0 'LISP::POSITIVE)
+                      (-1.0 'LISP::NEGATIVE))))
+   ("radix" FLOAT-RADIX)
+   ("digits" FLOAT-DIGITS)
+   ("significand" (LAMBDA (FLOAT)
+
+                         (IL:* IL:|;;| "onlyt return first value, as second confuses describe.")
+
+                         (VALUES (DECODE-FLOAT FLOAT))))
+   ("exponent" (LAMBDA (FLOAT)
+                      (SECOND (MULTIPLE-VALUE-LIST (DECODE-FLOAT FLOAT))))))
+
+(LISP::DEFDESCRIBER HASH-TABLE ("count" HASH-TABLE-COUNT)
+                                   ("size" IL:HARRAYSIZE)
+                                   ("test" (LAMBDA (LISP::TABLE)
+                                                  (IL:HARRAYPROP LISP::TABLE 'IL:EQUIVFN)))
+                                   (LAMBDA (LISP::TABLE LISP::DEPTH)
+                                          (DESCRIBE-NEW-LINE LISP::DEPTH)
+                                          (PRINC "contents:")
+                                          (LET* ((LISP::NEW-DEPTH (1+ LISP::DEPTH))
+                                                 (LISP::NEW-NEW-DEPTH (1+ LISP::NEW-DEPTH)))
+                                                (MAPHASH #'(LAMBDA (LISP::KEY LISP::VALUE)
+                                                                  (DESCRIBE-NEW-LINE 
+                                                                         LISP::NEW-DEPTH)
+                                                                  (PRIN1 LISP::KEY)
+                                                                  (PRINC " : ")
+                                                                  (DESCRIBE-INTERNAL LISP::VALUE
+                                                                         LISP::NEW-NEW-DEPTH))
+                                                       LISP::TABLE))))
+
+(DEFPARAMETER LISP::*DESCRIBE-DEPTH* 1
+   "The recursive depth to which DESCRIBE describes")
+
+(DEFPARAMETER LISP::*DESCRIBE-INDENT* 3
+   "Number of spaces to indent recursive descriptions")
+
+(DEFPARAMETER LISP::*DESCRIBE-PRINT-LENGTH* 3
+   "The value of *PRINT-LENGTH* in DESCRIBE")
+
+(DEFPARAMETER LISP::*DESCRIBE-PRINT-LEVEL* 3
+   "The value of *PRINT-LEVEL* in DESCRIBE")
+
+(IL:PUTPROPS IL:DESCRIBE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "SYSTEM"))
+
+(IL:PUTPROPS IL:DESCRIBE IL:FILETYPE :COMPILE-FILE)
+(IL:PUTPROPS IL:DESCRIBE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 1993)
+)
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/DESCRIBE.DFASL b/CLTL2/DESCRIBE.DFASL
new file mode 100644
index 00000000..eb2bfb96
Binary files /dev/null and b/CLTL2/DESCRIBE.DFASL differ
diff --git a/CLTL2/DTDECLARE b/CLTL2/DTDECLARE
new file mode 100644
index 00000000..363bb286
--- /dev/null
+++ b/CLTL2/DTDECLARE
@@ -0,0 +1,662 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+(FILECREATED "11-Oct-93 14:34:11" "{Pele:mv:envos}<LispCore>Sources>CLTL2>DTDECLARE.;1" 35305  
+
+      |changes| |to:|  (FUNCTIONS TYPE-VARIABLE-FROM-TYPE-NAME)
+
+      |previous| |date:| "15-Dec-92 14:08:39" "{Pele:mv:envos}<LispCore>Sources>DTDECLARE.;6")
+
+
+; Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT DTDECLARECOMS)
+
+(RPAQQ DTDECLARECOMS
+       (
+        (* |;;| "declaring DATATYPES --- part of ABC too")
+
+        (FNS /DECLAREDATATYPE DECLAREDATATYPE TRANSLATE.DATATYPE \\REUSETO \\TYPEGLOBALVARIABLE)
+        (FUNCTIONS TYPE-VARIABLE-FROM-TYPE-NAME)
+        (FNS |BitFieldMask| |BitFieldShift| |BitFieldShiftedMask| |MakeBitField| |BitFieldWidth| 
+             |BitFieldFirst|)
+        (OPTIMIZERS FETCHFIELD FFETCHFIELD REPLACEFIELD FREPLACEFIELD REPLACEFIELDVAL 
+               FREPLACEFIELDVAL NCREATE \\DTEST)
+        (PROP DMACRO \\TESTBITS)
+        (FNS COMPILEDFETCHFIELD COMPILEDREPLACEFIELD COMPILEDNCREATE)
+        (DECLARE\: DONTCOPY (EXPORT (RECORDS |FldDsc|)))
+        (VARS DATATYPEFIELDTYPES)
+        (COMS                                                (* \; 
+                        "Macros which convert a record access form into an address-generating form")
+              (MACROS LOCF INDEXF)
+              (FNS TRANSLATE.LOCF))
+        (LOCALVARS . T)
+        (PROP FILETYPE DTDECLARE)))
+
+
+
+(* |;;| "declaring DATATYPES --- part of ABC too")
+
+(DEFINEQ
+
+(/DECLAREDATATYPE
+  (LAMBDA (TYPENAME FIELDSPECS DLIST LEN SUPERTYPE)          (* \; "Edited 18-May-87 17:09 by Snow")
+    (AND LISPXHIST TYPENAME (UNDOSAVE (LIST '/DECLAREDATATYPE TYPENAME (GETFIELDSPECS TYPENAME)
+                                            NIL NIL (GETSUPERTYPE TYPENAME))))
+    (CL:MULTIPLE-VALUE-BIND (DLIST REDECLARED)
+           (DECLAREDATATYPE TYPENAME FIELDSPECS DLIST LEN SUPERTYPE)
+           (COND
+              (REDECLARED (LISPXPRINT (LIST '|datatype| TYPENAME '|redeclared|)
+                                 T T)))
+           DLIST)))
+
+(DECLAREDATATYPE
+  (LAMBDA (TYPENAME FIELDSPECS DLIST LENGTH SUPERTYPE)       (* |Pavel| "16-Oct-86 14:52")
+
+    (* |;;| "this is called twice when declaring records;  once where the DLIST and LENGTH hasn't been computed, and another time when it has.")
+
+    (LET ((SUPERSPECS (COND
+                         (SUPERTYPE (GETFIELDSPECS SUPERTYPE)))))
+                                                             (* \; 
+                                                       "maybe an error if supertype doesn't exist?")
+         (SETQ FIELDSPECS (APPEND SUPERSPECS FIELDSPECS))
+         (COND
+            ((AND FIELDSPECS (OR (NOT DLIST)
+                                 (NOT LENGTH)))              (* \; 
+                                "the AND is an optimization -- do we really need to compute DLIST?")
+             (SETQ DLIST (TRANSLATE.DATATYPE TYPENAME FIELDSPECS))
+             (SETQ LENGTH (|pop| DLIST)))))
+    (OR (AND TYPENAME (LITATOM TYPENAME))
+        (LISPERROR "ILLEGAL ARG" TYPENAME))
+    (LET ((PTRS (|for| P |in| DLIST |when| (SELECTQ (|fetch| |fdType| |of| P)
+                                                           ((POINTER FULLPOINTER) 
+                                                                T)
+                                                           NIL) |collect| (|fetch| |fdOffset|
+                                                                                 |of| P))))
+         (CL:MULTIPLE-VALUE-BIND (TYPENUM REDECLARED)
+                (\\ASSIGNDATATYPE1 TYPENAME DLIST LENGTH FIELDSPECS PTRS SUPERTYPE)
+                (SETTOPVAL (\\TYPEGLOBALVARIABLE TYPENAME T)
+                       TYPENUM)
+                (CL:VALUES DLIST REDECLARED)))))
+
+(TRANSLATE.DATATYPE
+  (LAMBDA (TYPENAME FIELDSPECS)                              (* DECLARATIONS\: (RECORD SPEC
+                                                           (N LEN . FD)))
+    (DECLARE (SPECVARS TYPENAME UNUSED BIT OFFSET FD))   (* \; "Edited 15-Dec-92 13:57 by jds")
+    (COND
+       ((NULL TYPENAME))
+       ((OR (NOT (LITATOM TYPENAME))
+            (EQ TYPENAME '**DEALLOC**))
+        (ERROR "Invalid type name" TYPENAME)))
+    (PROG ((N 0)
+           UNUSED
+           (OFFSET 0)
+           (BIT 0)
+           DLIST REUSE LEN FD)
+          (SETQ DLIST (|for| S |in| FIELDSPECS
+                         |collect| (|create| SPEC
+                                              N _ (|add| N 1)
+                                              LEN _ (SELECTQ S
+                                                        ((POINTER XPOINTER) 
+                                                             28)
+                                                        ((FIXP FLOATP SWAPPEDFIXP FULLPOINTER 
+                                                               SWAPPEDXPOINTER FULLXPOINTER) 
+                                                             BITSPERCELL)
+                                                        (FLAG (SETQQ S FLAGBITS)
+                                                              1)
+                                                        (BYTE (SETQQ S BITS)
+                                                              BITSPERBYTE)
+                                                        (WORD (SETQQ S BITS)
+                                                              BITSPERWORD)
+                                                        (SIGNEDWORD (SETQQ S SIGNEDBITS)
+                                                                    BITSPERWORD)
+                                                        (SELECTQ (CAR (LISTP S))
+                                                            ((BITS FLAGBITS SIGNEDBITS) 
+                                                                 (PROG1 (CADR S)
+                                                                     (SETQ S (CAR S))))
+                                                            (ERROR "invalid field spec: " S)))
+                                              FD _
+                                              (|create| |FldDsc|
+                                                     |fdTypeName| _ TYPENAME
+                                                     |fdType| _ S
+                                                     |fdOffset| _ NIL))))
+          (|for| S |in| DLIST
+             |do|
+             (|replace| |fdOffset| |of| (SETQ FD (|fetch| FD |of| S))
+                |with|
+                (SELECTQ (|fetch| |fdType| |of| FD)
+                    ((POINTER XPOINTER) 
+                         (COND
+                            ((AND TYPENAME
+                                  (|find| X |in| UNUSED
+                                     |suchthat|
+                                     (AND (EQ 0 (LOGAND (CAR X)
+                                                       1))
+                                          (IGEQ (CADDR X)
+                                                (- 28 BITSPERWORD))
+                                          (EQ (IPLUS (CADR X)
+                                                     (CADDR X))
+                                              BITSPERWORD)
+                                          (|find| Y |in| UNUSED
+                                             |suchthat| (AND (EQ (CAR Y)
+                                                                     (ADD1 (CAR X)))
+                                                                 (EQ (CADDR Y)
+                                                                     BITSPERWORD))))))
+                                                             (* \; "unused 24 bit quantity")
+                                                             (* \; "this case not implemented yet")
+                             ))
+                         (COND
+                            ((IGREATERP BIT 4)               (* \; 
+                                                           "Less than 8 bits left in this word")
+                             (\\REUSETO BITSPERWORD)))
+                         (COND
+                            ((ODDP OFFSET WORDSPERCELL)      (* \; "not on double word boundary")
+                             (\\REUSETO BITSPERWORD)))
+                         (COND
+                            ((NEQ BIT 4)
+                             (\\REUSETO 4 (EQ BIT 0))))
+                         (SETQ BIT 0)                        (* \; "")
+                         (PROG1 OFFSET (|add| OFFSET WORDSPERCELL)))
+                    ((FIXP SWAPPEDFIXP FLOATP SWAPPEDXPOINTER) 
+                                                             (* \; "32 bit quantities")
+                         (COND
+                            ((NEQ BIT 0)
+                             (\\REUSETO BITSPERWORD)))
+                         (PROG1 OFFSET (|add| OFFSET WORDSPERCELL)))
+                    ((FULLPOINTER FULLXPOINTER)              (* \; 
+                                                           "32 bit doubleword-aligned quantities")
+                         (COND
+                            ((NEQ BIT 0)
+                             (\\REUSETO BITSPERWORD)))
+                         (COND
+                            ((ODDP OFFSET WORDSPERCELL)
+                             (\\REUSETO BITSPERWORD)))
+                         (PROG1 OFFSET (|add| OFFSET WORDSPERCELL)))
+                    ((BITS FLAGBITS SIGNEDBITS) 
+                         (SETQ LEN (|fetch| LEN |of| S))
+                         (COND
+                            ((AND TYPENAME (SETQ REUSE (|find| X |in| UNUSED
+                                                          |suchthat| (ILEQ LEN (CADDR X)))))
+                             (RPLACA (CDDR REUSE)
+                                    (IDIFFERENCE (CAR (CDDR REUSE))
+                                           LEN))
+                             (|replace| |fdType| |of| FD |with|
+                                                                 (CONS (|fetch| |fdType|
+                                                                          |of| FD)
+                                                                       (|MakeBitField|
+                                                                        (CADR REUSE)
+                                                                        LEN)))
+                             (|add| (CADR REUSE)
+                                    LEN)
+                             (CAR REUSE))
+                            ((IGREATERP LEN BITSPERWORD)     (* \; 
+                                               "more than 1 word --- Must right justify first word")
+                             (SETQ LEN (IDIFFERENCE LEN BITSPERWORD))
+                             (COND
+                                ((IGREATERP LEN (IDIFFERENCE BITSPERWORD BIT))
+                                 (\\REUSETO BITSPERWORD)))
+                             (COND
+                                ((NEQ (IDIFFERENCE BITSPERWORD BIT)
+                                      LEN)
+                                 (\\REUSETO (IDIFFERENCE BITSPERWORD LEN))))
+                             (|replace| |fdType| |of| FD |with| (CONS 'LONGBITS
+                                                                                  (|MakeBitField|
+                                                                                   BIT LEN)))
+                             (SETQ BIT 0)
+                             (PROG1 OFFSET (|add| OFFSET 2)))
+                            (T (COND
+                                  ((IGREATERP LEN (IDIFFERENCE BITSPERWORD BIT))
+                                   (\\REUSETO BITSPERWORD)))
+                               (|replace| |fdType| |of| FD
+                                  |with| (CONS (|fetch| |fdType| |of| FD)
+                                                   (|MakeBitField| BIT LEN)))
+                               (|add| BIT LEN)
+                               (PROG1 OFFSET
+                                   (COND
+                                      ((EQ BIT BITSPERWORD)
+                                       (SETQ BIT 0)
+                                       (|add| OFFSET 1)))))))
+                    (SHOULDNT))))
+          (COND
+             (TYPENAME (COND
+                          ((NEQ BIT 0)
+                           (\\REUSETO BITSPERWORD)))
+                    (|while| (ODDP OFFSET WORDSPERCELL) |do| (|add| OFFSET 1))
+                    (COND
+                       ((IGREATERP OFFSET |\\MDSIncrement|)
+                        (ERROR TYPENAME "DATATYPE TOO BIG")))))
+          (RETURN (CONS OFFSET (MAPCAR DLIST (FUNCTION (LAMBDA (X)
+                                                         (|fetch| FD |of| X)))))))))
+
+(\\REUSETO
+  (LAMBDA (N FLG)                                            (* \; "Edited 15-Dec-92 13:46 by jds")
+
+    (* |;;| "Skip over unused bits in a datatype or blockrecord declaration.  Advance the bin-int-word and word-offset pointers accordingly.  Complain if this isn't supposed to be allowed.")
+
+    (SETQ N (IDIFFERENCE N BIT))
+    (COND
+       ((NEQ N 0)
+        (COND
+           ((AND (NULL TYPENAME)
+                 (NOT FLG))
+            (ERROR "Block/datatype field not aligned properly" FD)))
+        (|push| UNUSED (LIST OFFSET BIT N))))
+    (|add| BIT N)
+    (COND
+       ((EQ BIT 16)
+        (SETQ BIT 0)
+        (|add| OFFSET 1)))))
+
+(\\TYPEGLOBALVARIABLE
+  (LAMBDA (TYPENAME VARFLG)                                  (* \; "Edited 18-May-87 17:14 by Snow")
+
+(* |;;;| "Returns a constant or a variable that contains the datatype number of TYPENAME.  It is used when compiling type tests and assigning datatypes.  If TYPENAME is a system type, it returns the number.  Otherwise it creates a variable name and puts it on GLOBALVARS.")
+
+(* |;;;| "This is a kludge that will go away when we have type resolution at load time.")
+
+(* |;;;| "If VARFLG is true, always returns a var, rather than a system constant.  This is another kludge for backward compatibility.")
+
+    (OR (AND (NOT VARFLG)
+             (|for| ENTRY |in| \\BUILT-IN-SYSTEM-TYPES |as| I |from| 1
+                |when| (EQ TYPENAME (CAR ENTRY)) |do| (RETURN I)))
+        (LET ((VAR (TYPE-VARIABLE-FROM-TYPE-NAME TYPENAME)))
+             (COND
+                ((NOT (OR (FMEMB VAR GLOBALVARS)
+                          (GETPROP VAR 'GLOBALVAR)))
+                 (PUTPROP VAR 'GLOBALVAR T)))
+             VAR))))
+)
+
+(CL:DEFUN TYPE-VARIABLE-FROM-TYPE-NAME (TYPE-NAME)
+
+(* |;;;| "Convert a symbol naming a type into the unique global variable that holds the number for that type.  This can be tricky during that portion of the init before packages have been turned on.")
+
+   (IF (NULL *PACKAGE*)
+       THEN 
+
+             (* |;;| "Packages are, indeed, not on yet.  We must check the type-name symbol to see if it begins with a known init-time package prefix.  If so, we strip that off and put it back on the front.  The function NAMESTRING-CONVERSION-CLAUSE is from LLPACKAGE.")
+
+             (LET* ((BASE (|ffetch| (CL:SYMBOL PNAMEBASE) |of| TYPE-NAME))
+                    (LEN (|ffetch| (CL:SYMBOL PNAMELENGTH) |of| TYPE-NAME))
+                    (FATP (|ffetch| (CL:SYMBOL FATPNAMEP) |of| TYPE-NAME))
+                    (CLAUSE (NAMESTRING-CONVERSION-CLAUSE BASE 1 LEN FATP)))
+                   (COND
+                      ((NULL CLAUSE)
+
+                       (* |;;| "TYPE-NAME is homed in the Interlisp Package; we need to check for the types that are shared in IL and CL")
+
+                       (CL:DO ((S CMLSYMBOLS.SHARED (CDR S))
+                               (HEADER ""))
+                              ((COND
+                                  ((NULL S))
+                                  ((\\STRING-EQUALBASE (CAR S)
+                                          BASE 1 LEN FATP)
+                                   (SETQ HEADER "CL::")))
+                               (PACK* HEADER TYPE-NAME "TYPE#"))))
+                      (T                                     (* \; "The symbol matched a clause.  We take the prefix off the front of the name and put it at the beginning.")
+                         (LET* ((PREFIX (CL:FIRST CLAUSE))
+                                (PREFIX-LENGTH (FFETCH (STRINGP LENGTH) OF PREFIX))
+                                (INTERNAL? (IF (EQ (CL:FOURTH CLAUSE)
+                                                       :EXTERNAL)
+                                               THEN ":"
+                                             ELSE "")))
+
+                               (* |;;| "The INTERNAL? jazz handles the bizaroid case of READTABLEP, and should handle future similar problems; I can't conceive of one of these kludgy type-variables EVER being an external symbol in any rational package")
+
+                               (PACK* PREFIX INTERNAL? "" (SUBSTRING TYPE-NAME (CL:1+ PREFIX-LENGTH
+                                                                                        ))
+                                      "TYPE#")))))
+     ELSE 
+
+           (* |;;| "Packages are on; this is the normal case.")
+
+           (LET ((PACKAGE (CL:SYMBOL-PACKAGE TYPE-NAME)))
+                (IF (OR (EQ PACKAGE *LISP-PACKAGE*)
+                            (EQ PACKAGE *COMMON-LISP-PACKAGE*))
+                    THEN 
+
+                          (* |;;| 
+                       "We have to be careful here; these two packages are intertwingled strangely")
+
+                          (LET* ((STRING (CONCAT "" (MKSTRING TYPE-NAME)
+                                                "TYPE#"))
+                                 (LISPSYM (CL:FIND-SYMBOL STRING *LISP-PACKAGE*))
+                                 (CLSYM (CL:FIND-SYMBOL STRING *COMMON-LISP-PACKAGE*)))
+
+                                (* |;;| 
+                    "After this COND, CLSYM contains the type symbol; LISPSYM may also contain it.")
+
+                                (COND
+                                   ((AND LISPSYM CLSYM)
+                                    (IF (NOT (EQ LISPSYM CLSYM))
+                                        THEN (ERROR "Somehow BOTH these type symbols exist"
+                                                        (LIST LISPSYM CLSYM))))
+                                   (LISPSYM (IMPORT (SETQ CLSYM LISPSYM)
+                                                   *COMMON-LISP-PACKAGE*))
+                                   (CLSYM (IMPORT CLSYM *LISP-PACKAGE*))
+                                   (T (IMPORT (SETQ CLSYM (CL:INTERN STRING *COMMON-LISP-PACKAGE*))
+                                             *LISP-PACKAGE*)))
+
+                                (* |;;| "There's one last way to lose big-time here: we can have version skews such that the type# symbol already exists, and its home package is not the same as the home package of the type symbol.  Check that here and force the right thing (grrr)...")
+
+                                (CL:UNLESS (EQ PACKAGE (CL:SYMBOL-PACKAGE CLSYM))
+                                    (CL:SETF (CL:SYMBOL-PACKAGE CLSYM)
+                                           PACKAGE))
+                                CLSYM)
+                  ELSE (CL:INTERN (CONCAT "" (MKSTRING TYPE-NAME)
+                                             "TYPE#")
+                                  PACKAGE)))))
+(DEFINEQ
+
+(|BitFieldMask|
+  (LAMBDA (FD)                                               (* \; "Edited 18-May-87 17:14 by Snow")
+    (SUB1 (LLSH 1 (|BitFieldWidth| FD)))))
+
+(|BitFieldShift|
+  (LAMBDA (FD)                                               (* \; "Edited 18-May-87 17:14 by Snow")
+    (IDIFFERENCE 16 (IPLUS (|BitFieldFirst| FD)
+                           (|BitFieldWidth| FD)))))
+
+(|BitFieldShiftedMask|
+  (LAMBDA (FD)                                               (* \; "Edited 18-May-87 17:15 by Snow")
+    (IDIFFERENCE (LLSH 1 (IDIFFERENCE 16 (|BitFieldFirst| FD)))
+           (LLSH 1 (IDIFFERENCE 16 (IPLUS (|BitFieldFirst| FD)
+                                          (|BitFieldWidth| FD)))))))
+
+(|MakeBitField|
+  (LAMBDA (FIRST WIDTH)                                  (* \; "Edited 18-May-87 17:15 by Snow")
+    (LOGOR (LLSH FIRST 4)
+           (SUB1 WIDTH))))
+
+(|BitFieldWidth|
+  (LAMBDA (FD)                                               (* \; "Edited 18-May-87 17:16 by Snow")
+    (ADD1 (LOGAND FD 15))))
+
+(|BitFieldFirst|
+  (LAMBDA (FD)                                               (* \; "Edited 18-May-87 17:16 by Snow")
+    (LRSH FD 4)))
+)
+
+(DEFOPTIMIZER FETCHFIELD (&REST X)
+                             (COMPILEDFETCHFIELD X))
+
+(DEFOPTIMIZER FFETCHFIELD (&REST X)
+                              (COMPILEDFETCHFIELD X T))
+
+(DEFOPTIMIZER REPLACEFIELD (&REST X)
+                               (COMPILEDREPLACEFIELD X))
+
+(DEFOPTIMIZER FREPLACEFIELD (&REST X)
+                                (COMPILEDREPLACEFIELD X T))
+
+(DEFOPTIMIZER REPLACEFIELDVAL (&REST ARGS)
+                                  (CONS '(OPENLAMBDA (DESCRIPTOR DATUM NEWVALUE)
+                                                (PROG1 DATUM (REPLACEFIELD DESCRIPTOR DATUM NEWVALUE)
+                                                       ))
+                                        ARGS))
+
+(DEFOPTIMIZER FREPLACEFIELDVAL (&REST ARGS)
+                                   (CONS '(OPENLAMBDA (DESCRIPTOR DATUM NEWVALUE)
+                                                 (PROG1 DATUM (FREPLACEFIELD DESCRIPTOR DATUM 
+                                                                     NEWVALUE)))
+                                         ARGS))
+
+(DEFOPTIMIZER NCREATE (&REST X)
+                          (COMPILEDNCREATE X))
+
+(DEFOPTIMIZER \\DTEST (VALUE TYPE &ENVIRONMENT ENV)
+                          (COND
+                             ((AND (EQ (CAR TYPE)
+                                       'QUOTE)
+                                   (LITATOM (CADR TYPE)))
+                              (COND
+                                 ((FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
+                                  `((OPCODES DTEST 0 0 0 (ATOM \\\, (CADR TYPE)))
+                                    ,VALUE))
+                                 ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
+                                  `((OPCODES DTEST 0 0 (ATOM \\\, (CADR TYPE)))
+                                    ,VALUE))
+                                 (T `((OPCODES DTEST 0 (ATOM \\\, (CADR TYPE)))
+                                      ,VALUE))))
+                             (T 'IGNOREMACRO)))
+
+(PUTPROPS \\TESTBITS DMACRO ((X N FD)
+                                     (NEQ 0 (\\GETBITS X N FD))))
+(DEFINEQ
+
+(COMPILEDFETCHFIELD
+  (LAMBDA (X FASTFLG)                                        (* \; "Edited 18-May-87 17:32 by Snow")
+    (COND
+       ((EQ (CAR (LISTP (CAR X)))
+            'QUOTE)
+        ((LAMBDA (DESCRIPTOR DATUM)
+           (PROG (TYPENAME)
+                 (COND
+                    ((AND (NOT FASTFLG)
+                          (SETQ TYPENAME (|fetch| |fdTypeName| |of| DESCRIPTOR)))
+                     (SETQ DATUM (LIST (FUNCTION \\DTEST)
+                                       DATUM
+                                       (KWOTE TYPENAME)))))
+                 (RETURN
+                  (SELECTQ (|fetch| |fdType| |of| DESCRIPTOR)
+                      ((POINTER XPOINTER FULLPOINTER FULLXPOINTER) 
+                           (LIST '\\GETBASEPTR DATUM (|fetch| |fdOffset| |of| DESCRIPTOR)))
+                      (SWAPPEDXPOINTER 
+                           `((OPENLAMBDA (D)
+                                    (\\VAG2 (\\GETBASE D ,(ADD1 (|fetch| |fdOffset| |of|
+                                                                                        DESCRIPTOR)))
+                                           (\\GETBASE D ,(|fetch| |fdOffset| |of| DESCRIPTOR)
+                                                  )))
+                             ,DATUM))
+                      (FLOATP `(\\GETBASEFLOATP ,DATUM ,(|fetch| |fdOffset| |of| DESCRIPTOR)))
+                      (FIXP `(\\GETBASEFIXP ,DATUM ,(|fetch| |fdOffset| |of| DESCRIPTOR)))
+                      (SWAPPEDFIXP `((OPENLAMBDA (D)
+                                            (\\MAKENUMBER (\\GETBASE D
+                                                                 ,(ADD1 (|fetch| |fdOffset|
+                                                                           |of| DESCRIPTOR)))
+                                                   (\\GETBASE D ,(|fetch| |fdOffset| |of|
+                                                                                         DESCRIPTOR))
+                                                   ))
+                                     ,DATUM))
+                      (PROG ((FT (|fetch| |fdType| |of| DESCRIPTOR))
+                             (OFF (|fetch| |fdOffset| |of| DESCRIPTOR)))
+                            (RETURN (SELECTQ (CAR FT)
+                                        (BITS (LIST '\\GETBITS DATUM OFF (CDR FT)))
+                                        (SIGNEDBITS `(SIGNED (\\GETBITS ,DATUM ,OFF
+                                                                    ,(CDR FT))
+                                                            ,(|BitFieldWidth| (CDR FT))))
+                                        (FLAGBITS (LIST '\\TESTBITS DATUM OFF (CDR FT)))
+                                        (LONGBITS `((OPENLAMBDA (D)
+                                                           (\\MAKENUMBER (\\GETBITS
+                                                                          D
+                                                                          ,OFF
+                                                                          ,(CDR FT))
+                                                                  (\\GETBASE D ,(ADD1 OFF))))
+                                                    ,DATUM))
+                                        (SHOULDNT))))))))
+         (CADAR X)
+         (CADR X)))
+       (T 'IGNOREMACRO))))
+
+(COMPILEDREPLACEFIELD
+  (LAMBDA (X FASTFLG RPLVALFLG)                              (* \; "Edited 18-May-87 17:29 by Snow")
+
+    (* |;;| "compile code for replacing field values.  Goes to great length to ensure that the coerced value is returned")
+
+    (COND
+       ((EQ (CAR (LISTP (CAR X)))
+            'QUOTE)
+        ((LAMBDA (DESCRIPTOR DATUM NEWVALUE)
+           (PROG ((TYPENAME (|fetch| |fdTypeName| |of| DESCRIPTOR))
+                  (FT (|fetch| |fdType| |of| DESCRIPTOR))
+                  (OFFSET (|fetch| |fdOffset| |of| DESCRIPTOR)))
+                 (COND
+                    ((AND (NOT FASTFLG)
+                          TYPENAME)
+                     (SETQ DATUM (LIST (FUNCTION \\DTEST)
+                                       DATUM
+                                       (KWOTE TYPENAME)))))
+                 (RETURN (SELECTQ FT
+                             ((POINTER FULLPOINTER) 
+                                  (LIST (FUNCTION \\RPLPTR)
+                                        DATUM OFFSET NEWVALUE))
+                             (XPOINTER (LIST (FUNCTION PUTBASEPTRX)
+                                             DATUM OFFSET NEWVALUE))
+                             (FULLXPOINTER (LIST '\\PUTBASEPTR DATUM OFFSET NEWVALUE))
+                             (SWAPPEDXPOINTER 
+                                  `((OPENLAMBDA (D R)
+                                           (\\PUTBASE D ,OFFSET (\\LOLOC R))
+                                           (\\PUTBASE D ,(ADD1 OFFSET)
+                                                  (\\HILOC R))
+                                           R)
+                                    ,DATUM
+                                    ,NEWVALUE))
+                             (FIXP `(\\PUTBASEFIXP ,DATUM ,OFFSET ,NEWVALUE))
+                             (SWAPPEDFIXP `(\\PUTSWAPPEDFIXP (\\ADDBASE ,DATUM ,OFFSET)
+                                                  ,NEWVALUE))
+                             (FLOATP `(\\PUTBASEFLOATP ,DATUM ,OFFSET ,NEWVALUE))
+                             (SELECTQ (CAR FT)
+                                 (BITS (LIST '\\PUTBITS DATUM OFFSET (CDR FT)
+                                             NEWVALUE))
+                                 (LONGBITS (LIST (SUBPAIR '(OFFSET FT)
+                                                        (LIST OFFSET (CDR FT))
+                                                        '(OPENLAMBDA (D V)
+                                                                (\\PUTBITS D OFFSET FT (\\HINUM
+                                                                                        V))
+                                                                (\\PUTBASE D (ADD1 OFFSET)
+                                                                       (\\LONUM V))
+                                                                V))
+                                                 DATUM NEWVALUE))
+                                 (SIGNEDBITS `(SIGNED (\\PUTBITS ,DATUM ,OFFSET ,(CDR FT)
+                                                             (UNSIGNED ,NEWVALUE
+                                                                    ,(|BitFieldWidth|
+                                                                      (CDR FT))))
+                                                     ,(|BitFieldWidth| (CDR FT))))
+                                 (FLAGBITS `(NEQ (\\PUTBITS ,DATUM ,OFFSET ,(CDR FT)
+                                                        (COND
+                                                           (,NEWVALUE ,(|BitFieldMask|
+                                                                        (CDR FT)))
+                                                           (T 0)))
+                                                 0))
+                                 (RETURN 'IGNOREMACRO))))))
+         (CADAR X)
+         (CADR X)
+         (CADDR X)))
+       (T 'IGNOREMACRO))))
+
+(COMPILEDNCREATE
+  (LAMBDA (X)                                                (* \; "Edited 18-May-87 17:34 by Snow")
+
+(* |;;;| "compiles code for NCREATEs.  Exists to eliminate the call to \\TYPENUMBERFROMNAME.")
+
+    (COND
+       ((EQ (CAR (LISTP (CAR X)))
+            'QUOTE)
+        (COND
+           ((NULL (CADR X))
+            (LIST 'CREATECELL (\\TYPEGLOBALVARIABLE (CADAR X))))
+           (T (LIST 'NCREATE2 (\\TYPEGLOBALVARIABLE (CADAR X))
+                    (CADR X)))))
+       (T 'IGNOREMACRO))))
+)
+(DECLARE\: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE\: EVAL@COMPILE
+
+(RECORD |FldDsc| (|fdTypeName| |fdOffset| |fdType|))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+
+(RPAQQ DATATYPEFIELDTYPES
+       ((FLOATP 0.0)
+        (FIXP 0)
+        (SWAPPEDFIXP 0)
+        (POINTER NIL)
+        (XPOINTER NIL)
+        (FULLPOINTER NIL)
+        (FULLXPOINTER NIL)
+        (SWAPPEDXPOINTER NIL)
+        (FLAG NIL)
+        (BYTE 0)
+        (WORD 0)
+        (SIGNEDWORD 0)))
+
+
+
+(* \; "Macros which convert a record access form into an address-generating form")
+
+(DECLARE\: EVAL@COMPILE 
+
+(PUTPROPS LOCF DMACRO (X (TRANSLATE.LOCF X)))
+
+(PUTPROPS INDEXF DMACRO (X (TRANSLATE.LOCF X T)))
+)
+(DEFINEQ
+
+(TRANSLATE.LOCF
+  (LAMBDA (ARGS INDEXONLY)                                   (* \; "Edited 18-May-87 17:35 by Snow")
+    (DECLARE (GLOBALVARS CLISPARRAY))
+    (PROG ((FORM (MKPROGN ARGS))
+           NEWFORM OFFSET SPEC)
+      RETRY
+          (SELECTQ (CAR (LISTP FORM))
+              (PROGN (COND
+                        ((NOT (CDDR FORM))                   (* \; 
+                                              "get rid of extra PROGN's inserted by record package")
+                         (SETQ FORM (CADR FORM))
+                         (GO RETRY))))
+              ((FETCHFIELD FFETCHFIELD) 
+                   (COND
+                      ((AND (SETQ OFFSET (LISTP (CADR FORM)))
+                            (EQ (CAR OFFSET)
+                                'QUOTE)
+                            (SETQ OFFSET (CADR (SETQ SPEC (CADR OFFSET))))
+                            (FIXP OFFSET))
+                       (RETURN (COND
+                                  (INDEXONLY OFFSET)
+                                  ((EQ OFFSET 0)
+                                   (CADDR FORM))
+                                  (T (SETQ FORM (CADDR FORM))
+
+                                     (* |;;| "loop in order to merge \\ADDBASEs.  Should actually be done by compiler optimization, but apparently that is currently broken")
+
+                                     (|repeatwhile| (SELECTQ (CAR (LISTP FORM))
+                                                            (PROGN (COND
+                                                                      ((NULL (CDDR FORM))
+                                                                       (SETQ FORM (CADR FORM))
+                                                                       T)))
+                                                            ((ADDBASE \\ADDBASE) 
+                                                                 (COND
+                                                                    ((FIXP (CADDR FORM))
+                                                                     (|add| OFFSET (CADDR FORM))
+                                                                     (SETQ FORM (CADR FORM))
+                                                                     T)))
+                                                            (COND
+                                                               ((NEQ (SETQ NEWFORM (CL:MACROEXPAND-1
+                                                                                    FORM))
+                                                                     FORM)
+                                                                (SETQ FORM NEWFORM)
+                                                                T))))
+                                     (LIST '\\ADDBASE FORM OFFSET)))))))
+              (COND
+                 ((NEQ FORM (SETQ FORM (CL:MACROEXPAND-1 FORM)))
+                  (GO RETRY))))
+          (ERROR "LOCF Can't figure out this argument" ARGS)
+          (RETURN 'IGNOREMACRO))))
+)
+(DECLARE\: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+
+(PUTPROPS DTDECLARE FILETYPE CL:COMPILE-FILE)
+(PUTPROPS DTDECLARE COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1990 
+1992 1993))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (1560 14941 (/DECLAREDATATYPE 1570 . 2148) (DECLAREDATATYPE 2150 . 3917) (
+TRANSLATE.DATATYPE 3919 . 13172) (\\REUSETO 13174 . 13850) (\\TYPEGLOBALVARIABLE 13852 . 14939)) (
+19919 21157 (|BitFieldMask| 19929 . 20100) (|BitFieldShift| 20102 . 20335) (|BitFieldShiftedMask| 
+20337 . 20676) (|MakeBitField| 20678 . 20855) (|BitFieldWidth| 20857 . 21010) (|BitFieldFirst| 21012
+ . 21155)) (23347 31298 (COMPILEDFETCHFIELD 23357 . 26803) (COMPILEDREPLACEFIELD 26805 . 30766) (
+COMPILEDNCREATE 30768 . 31296)) (32014 35061 (TRANSLATE.LOCF 32024 . 35059)))))
+STOP
diff --git a/CLTL2/DTDECLARE.LCOM b/CLTL2/DTDECLARE.LCOM
new file mode 100644
index 00000000..aeabe224
Binary files /dev/null and b/CLTL2/DTDECLARE.LCOM differ
diff --git a/CLTL2/EDITINTERFACE b/CLTL2/EDITINTERFACE
new file mode 100644
index 00000000..4eff14e1
--- /dev/null
+++ b/CLTL2/EDITINTERFACE
@@ -0,0 +1,810 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 15:30:38" "{Pele:mv:envos}<LispCore>Sources>CLTL2>EDITINTERFACE.;2" 40076  
+
+      previous date%: "12-Jan-92 12:30:13" "{Pele:mv:envos}<LispCore>Sources>CLTL2>EDITINTERFACE.;1"
+)
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT EDITINTERFACECOMS)
+
+(RPAQQ EDITINTERFACECOMS
+       [
+        (* ;; "This is John Wozencraft's simplified edit interface, created December 1990.")
+
+        (PROP (Definition-for-EDITL Definition-for-EDITE Definition-for-EDITDATE)
+              TELETYPE DISPLAY)
+        (GLOBALVARS *LAST-DF* *LAST-DV* *LAST-DC* *LAST-DP*)
+        (INITVARS (*LAST-DF*)
+               (*LAST-DV*)
+               (*LAST-DC*)
+               (*LAST-DP*))
+        (INITVARS (*EDITMODE* 'TELETYPE)
+               (*DISPLAY-EDITOR*))
+        
+        (* ;; "init *EDITMODE* to TELETYPE, since that's the only editor we know is loaded.  other editors should set *DISPLAY-EDITOR* and call EDITMODE as appropriate.")
+
+        (VARS DUMMY-EDIT-FUNCTION-BODY)
+        (VARIABLES *ED-OFFERS-PROPERTY-LIST* XCL::ED-LAST-INFO)
+        (FUNCTIONS ED INSTALL-PROTOTYPE-DEFN)
+        (FNS EDITDEF.FNS EDITF EDITFB EDITFNS EDITLOADFNS? EDITMODE EDITP EDITV DC DF DP DV EDITPROP
+             EF EP EV EDITE EDITL)
+        [COMS 
+              (* ;; "Time stamp on functions when edited")
+
+              
+              (* ;; "User enables this by an (ADDTOVAR INITIALSLIST (USERNAME )) in his INIT.LISP.  E.g.  (ADDTOVAR INITIALSLIST (MASINTER )) The date fixup is enabled by the variable INITIALS.  The function SETINITIALS sets INITIALS from INITIALSLIST and USERNAME at load time, and after a sysin.")
+
+              (FNS NEW/EDITDATE FIXEDITDATE EDITDATE? EDITDATE SETINITIALS)
+              (INITVARS (INITIALS)
+                     (INITIALSLST)
+                     (DEFAULTINITIALS T))
+              (VARIABLES *REPLACE-OLD-EDIT-DATES*)
+              (P (MOVD? 'EDITDATE 'TTY/EDITDATE]
+        [INITVARS (COMMON-SOURCE-MANAGER-TYPES '(FUNCTIONS VARIABLES STRUCTURES TYPES SETFS 
+                                                       OPTIMIZERS]
+        (PROP FILETYPE EDITINTERFACE)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA EV EP EF DV DP DF DC EDITV EDITP EDITFNS EDITF)
+                      (NLAML)
+                      (LAMA])
+
+
+
+(* ;; "This is John Wozencraft's simplified edit interface, created December 1990.")
+
+
+(PUTPROPS TELETYPE Definition-for-EDITL TTY/EDITL)
+
+(PUTPROPS DISPLAY Definition-for-EDITL TTY/EDITL)
+
+(PUTPROPS TELETYPE Definition-for-EDITE TTY/EDITE)
+
+(PUTPROPS DISPLAY Definition-for-EDITE TTY/EDITE)
+
+(PUTPROPS TELETYPE Definition-for-EDITDATE TTY/EDITDATE)
+
+(PUTPROPS DISPLAY Definition-for-EDITDATE TTY/EDITDATE)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS *LAST-DF* *LAST-DV* *LAST-DC* *LAST-DP*)
+)
+
+(RPAQ? *LAST-DF* )
+
+(RPAQ? *LAST-DV* )
+
+(RPAQ? *LAST-DC* )
+
+(RPAQ? *LAST-DP* )
+
+(RPAQ? *EDITMODE* 'TELETYPE)
+
+(RPAQ? *DISPLAY-EDITOR* )
+
+
+
+(* ;; 
+"init *EDITMODE* to TELETYPE, since that's the only editor we know is loaded.  other editors should set *DISPLAY-EDITOR* and call EDITMODE as appropriate."
+)
+
+
+(RPAQQ DUMMY-EDIT-FUNCTION-BODY [LAMBDA (ARGS |...|)
+                                           BODY])
+
+(LISP:DEFVAR *ED-OFFERS-PROPERTY-LIST* T
+   "Controls whether ED offers property list as an editable aspect")
+
+(DEFGLOBALVAR XCL::ED-LAST-INFO NIL
+   "used in ED to stash last call info so (ED NIL) will restart last edit")
+
+(LISP:DEFUN ED (LISP::NAME LISP::OPTIONS)                (* ; "Edited  5-Jul-88 16:03 by woz")
+
+(* ;;; "Standard Common Lisp editor entry.  CLtL say's ED does something reasonable when passed a pathname.  We coerce name into something that might be the name of something with an IL:FILES definition, & try to edit  that.  Then save call info in ED-LAST-INFO, so (ED) will start last edit over again.")
+
+   (LISP:UNLESS (LISP:LISTP LISP::OPTIONS)
+       (LISP:SETQ LISP::OPTIONS (LIST LISP::OPTIONS)))
+   (LISP:WHEN (LISP:PATHNAMEP LISP::NAME)
+       (LISP:WHEN (LISP::LOGICAL-PATHNAME-P LISP::NAME)
+           (LISP:SETQ LISP::NAME (LISP:TRANSLATE-LOGICAL-PATHNAME LISP::NAME)))
+       (LISP:SETQ LISP::NAME (NAMEFIELD (LISP:STRING-UPCASE (LISP:NAMESTRING LISP::NAME))
+                                    T))
+       (LISP:PUSHNEW 'FILES LISP::OPTIONS))
+   [COND
+      (LISP::NAME (LISP:SETQ XCL::ED-LAST-INFO (CONS LISP::NAME LISP::OPTIONS)))
+      (T (LISP:WHEN (NULL XCL::ED-LAST-INFO)
+             (LISP:FORMAT T "Sorry, there is no previous edit to restart.")
+             (LISP:RETURN-FROM ED NIL))
+         (LISP:SETQ LISP::NAME (CAR XCL::ED-LAST-INFO))
+         (LISP:SETQ LISP::OPTIONS (LISP:APPEND (CDR XCL::ED-LAST-INFO)
+                                         LISP::OPTIONS]
+   (LET* ((LISP::FROM-DISPLAY (OR (EQ LISP::OPTIONS T)
+                                  (LISP:MEMBER :DISPLAY LISP::OPTIONS)
+                                  (LISP:MEMBER 'DISPLAY LISP::OPTIONS)))
+          (LISP::GIVEN-TYPES (for X inside LISP::OPTIONS when (NEQ X T) bind TYPE
+                                when (LISP:SETQ TYPE (GETFILEPKGTYPE X 'TYPES T LISP::NAME))
+                                collect TYPE))
+          [LISP::TYPES-WITH-DEFNS (TYPESOF LISP::NAME LISP::GIVEN-TYPES NIL
+                                         (LISP:IF (OR (LISP:MEMBER :CURRENT LISP::OPTIONS)
+                                                      (LISP:MEMBER 'CURRENT LISP::OPTIONS))
+                                             'CURRENT
+                                             '?)
+                                         #'(LAMBDA (X)
+                                             (NEQ (GET X 'EDITDEF)
+                                                  'NILL]
+          (LISP::POSSIBLE-TYPES (COND
+                                   ([AND (NULL LISP::GIVEN-TYPES)
+                                         (LISP:SYMBOLP LISP::NAME)
+                                         (NOT (NULL *ED-OFFERS-PROPERTY-LIST*))
+                                         (find X on (GETPROPLIST LISP::NAME)
+                                            by (CDDR X) suchthat (NULL (GET (CAR X)
+                                                                                    'PROPTYPE]
+
+                                 (* ;; "if we're supposed to offer PROPERTY-LIST as an edit type, and this name has a property list with other than system properties on it, then add IL:PROPERTY-LIST to the possible types.")
+
+                                    (CONS 'PROPERTY-LIST LISP::TYPES-WITH-DEFNS))
+                                   (T LISP::TYPES-WITH-DEFNS)))
+          (TYPE))
+         (LISP:WHEN (LISP:MEMBER 'PROPERTY-LIST LISP::OPTIONS)
+
+             (* ;; 
+        "this will allow PROPERTY-LIST to be specified as a fake filepkg type by the user (caller)")
+
+             (LISP:SETQ LISP::POSSIBLE-TYPES '(PROPERTY-LIST)))
+         [LISP:SETQ TYPE (if (LISP:MEMBER :NEW LISP::OPTIONS)
+                             then 
+
+                                   (* ;; "if :NEW then install a blank definition first")
+
+                                   (OR (INSTALL-PROTOTYPE-DEFN LISP::NAME (OR 
+                                                                               LISP::TYPES-WITH-DEFNS
+                                                                                  LISP::GIVEN-TYPES)
+                                              :NEW)
+                                       (LISP:RETURN-FROM ED NIL))
+                           elseif (CDR LISP::POSSIBLE-TYPES)
+                             then 
+
+                                   (* ;; "Many types were found/given.  Ask the user which to use.")
+
+                                   (if LISP::FROM-DISPLAY
+                                       then (OR (MENU (create MENU
+                                                                 ITEMS _ LISP::POSSIBLE-TYPES
+                                                                 TITLE _ (LISP:FORMAT NIL 
+                                                                      "Edit which definition of ~S ?"
+                                                                                LISP::NAME)))
+                                                    (LISP:RETURN-FROM ED NIL))
+                                     else (ASKUSER NIL (CAR LISP::POSSIBLE-TYPES)
+                                                     (LISP:FORMAT NIL 
+                                                            "Edit which ~A definition of ~S ? " 
+                                                            LISP::POSSIBLE-TYPES LISP::NAME)
+                                                     LISP::POSSIBLE-TYPES))
+                           elseif (NOT (NULL LISP::POSSIBLE-TYPES))
+                             then 
+
+                                   (* ;; "Exactly one type was found.")
+
+                                   (if LISP::FROM-DISPLAY
+                                       then              (* ; "prepare the prompt window")
+                                             (TERPRI PROMPTWINDOW))
+                                   (LISP:FORMAT (if LISP::FROM-DISPLAY
+                                                    then PROMPTWINDOW
+                                                  else T)
+                                          "Editing ~A ~A ~S.~%%"
+                                          (CAR LISP::POSSIBLE-TYPES)
+                                          (LISP:IF (EQ (CAR LISP::POSSIBLE-TYPES)
+                                                       'PROPERTY-LIST)
+                                              "of"
+                                              "definition of")
+                                          LISP::NAME)
+                                   (CAR LISP::POSSIBLE-TYPES)
+                           else 
+
+                                 (* ;; 
+                               "No types were found.  Use the DefDefiner prototyping machinery.")
+
+                                 (OR (INSTALL-PROTOTYPE-DEFN LISP::NAME LISP::GIVEN-TYPES)
+                                     (LISP:RETURN-FROM ED NIL]
+         (LISP:IF (EQ TYPE 'PROPERTY-LIST)
+             (EDITE (GETPROPLIST LISP::NAME)
+                    NIL LISP::NAME 'PROPLST NIL LISP::OPTIONS)
+             (EDITDEF LISP::NAME TYPE NIL NIL LISP::OPTIONS))
+         (LISP:RETURN-FROM ED LISP::NAME)))
+
+(LISP:DEFUN INSTALL-PROTOTYPE-DEFN (NAME &REST ARGS)
+
+(* ;;; "Explain to the user that the given name has no definitions (of the given type, if any) and give them the chance to pick a new, dummy definition to install under that name.  Return the file-manager type of the definition installed.  If TYPES were supplied, the one returned should be one of them.  If no dummy was selected, return NIL.  If the third arg in :NEW then don't bother with the %"no defn found%" message, cause the user intends to intall anew.")
+
+   [LISP:FLET
+    [(MAKE-AND-INSTALL (TYPE DEFINER)
+            (LET ((DFNFLG 'PROP))
+                 (DECLARE (LISP:SPECIAL DFNFLG))
+                 (EVAL (XCL::MAKE-PROTOTYPE NAME TYPE DEFINER]
+    (LET*
+     ((DEFINER-HELP-STRING (LISP:FORMAT NIL "Installs a definition for ~S using this definer." NAME
+                                  ))
+      [REQUESTED-TYPES (AND (LISTP ARGS)
+                            (MKLIST (CAR ARGS]
+      (NEW-DEFN-FLG (AND (LISTP ARGS)
+                         (EQ (CADR ARGS)
+                             :NEW)))
+      [TYPES-WITH-PROTOTYPES (IF (NULL REQUESTED-TYPES)
+                                 THEN (XCL::PROTOTYPE-DEFN-TYPES)
+                               ELSE (INTERSECTION REQUESTED-TYPES (XCL::PROTOTYPE-DEFN-TYPES]
+      PROTOTYPE-TYPE)
+     (IF (AND NEW-DEFN-FLG TYPES-WITH-PROTOTYPES)
+         THEN (IF (CDR TYPES-WITH-PROTOTYPES)
+                      THEN (LISP:FORMAT T "Installing new definition for ~S~%%" NAME)
+                    ELSE (LISP:FORMAT T "Installing new ~S definition for ~S~%%" (CAR 
+                                                                                TYPES-WITH-PROTOTYPES
+                                                                                          )
+                                    NAME))
+       ELSEIF (NULL REQUESTED-TYPES)
+         THEN (LISP:FORMAT T "~S has no definitions.~%%" NAME)
+       ELSEIF (NULL (CDR REQUESTED-TYPES))
+         THEN (LISP:FORMAT T "~S has no ~A definition.~%%" NAME (CAR REQUESTED-TYPES))
+       ELSE (LISP:FORMAT T "~S has no definition of any of these types:~%%  ~A~%%" NAME 
+                       REQUESTED-TYPES))
+     [IF (NULL TYPES-WITH-PROTOTYPES)
+         THEN (LISP:RETURN-FROM INSTALL-PROTOTYPE-DEFN NIL)
+       ELSEIF (NULL (CDR TYPES-WITH-PROTOTYPES))
+         THEN (SETQ PROTOTYPE-TYPE (CAR TYPES-WITH-PROTOTYPES))
+       ELSE
+       (LISP:FORMAT T "Select a type of dummy definition to install.~%%")
+       (LET*
+        ([MENU
+          (CREATE
+           MENU
+           TITLE _ "Select a type for a dummy defn:"
+           ITEMS _
+           (APPEND
+            [FOR TYPE IN TYPES-WITH-PROTOTYPES
+               COLLECT `(,TYPE '(:TYPE ,TYPE)
+                                   "Displays a menu of definers for this type."
+                                   (SUBITEMS ,@(FOR DEFINER IN (
+                                                                     XCL::PROTOTYPE-DEFINERS-FOR-TYPE
+                                                                        TYPE)
+                                                  COLLECT `(,DEFINER '(:DEFINER ,TYPE
+                                                                                 ,DEFINER)
+                                                                      ,DEFINER-HELP-STRING]
+            (LIST '("Don't make a dummy defn" NIL]
+         (RESULT (MENU MENU)))
+        (LISP:ECASE (LISP:FIRST RESULT)
+            (:TYPE (SETQ PROTOTYPE-TYPE (LISP:SECOND RESULT)))
+            (:DEFINER 
+               (MAKE-AND-INSTALL (LISP:SECOND RESULT)
+                      (LISP:THIRD RESULT))
+               (LISP:RETURN-FROM INSTALL-PROTOTYPE-DEFN (LISP:SECOND RESULT)))
+            ((NIL) (LISP:RETURN-FROM INSTALL-PROTOTYPE-DEFN NIL)))]
+     (LISP:FORMAT T "Select a definer to use for a dummy definition.~%%")
+     (LET [(DEFINER (MENU (CREATE MENU
+                                 TITLE _ "Select a definer for a dummy defn:"
+                                 ITEMS _ (APPEND (XCL::PROTOTYPE-DEFINERS-FOR-TYPE PROTOTYPE-TYPE)
+                                                (LIST '("Don't make a dummy defn" NIL]
+          (IF DEFINER
+              THEN (MAKE-AND-INSTALL PROTOTYPE-TYPE DEFINER)
+                    PROTOTYPE-TYPE
+            ELSE NIL])
+(DEFINEQ
+
+(EDITDEF.FNS
+  [LAMBDA (NAME EDITCOMS OPTIONS)                            (* ; "Edited 20-Nov-87 14:25 by woz")
+    (PROG (DEF)
+      LP  (COND
+             ((EXPRP (SETQ DEF (OR (GET NAME 'ADVISED)
+                                   (GET NAME 'BROKEN)
+                                   NAME)))
+              (EDITE (if (LITATOM DEF)
+                             then (GETD DEF)
+                           else DEF)
+                     EDITCOMS NAME 'FNS NIL OPTIONS)
+              (RETURN NAME))
+             ([EXPRP (SETQ DEF (GETPROP NAME 'EXPR]
+
+              (* ;; 
+"woz: don't use edit type PROP anymore.  Let putdef for fns worry about where the definition goes.")
+
+              (EDITE DEF EDITCOMS NAME 'FNS NIL OPTIONS)
+              (RETURN NAME))
+             ((EDITFB NAME)
+              (GO LP))
+             (T 
+                (* ;; "Used to call EDITFERROR to check for MACROS definition or install dummy FNS defintion.  FNS can no longer be coerced to MACROS, and the new prototype stuff handles the other case.  So if we're here, it's because EDITFB failed to find the definition, and thus NAME is not editable.")
+
+                (LISP:FORMAT *ERROR-OUTPUT* "Could not find fns definition for ~a." NAME)
+                (ERROR "Could not find fns definition for " NAME T])
+
+(EDITF
+  [NLAMBDA EDITFX                                            (* ; "Edited 11-Jun-90 15:44 by jds")
+    (SETQ EDITFX (NLAMBDA.ARGS EDITFX))
+    (LET ((FNTYPE 'FNS))
+         (EDITDEF (if EDITFX
+                      then (COND
+                                  ((HASDEF (CAR EDITFX)
+                                          'FUNCTIONS
+                                          '? EDITFX)
+                                   (SETQ FNTYPE 'FUNCTIONS)
+                                   (CAR EDITFX))
+                                  ((HASDEF (CAR EDITFX)
+                                          'FNS
+                                          '? EDITFX)
+                                   (CAR EDITFX)))
+                    else (PROGN (PRIN1 "Editing " T)
+                                    (PRINT LASTWORD T)))
+                FNTYPE NIL (CDR EDITFX])
+
+(EDITFB
+  [LAMBDA (FN)                                               (* ; "Edited 27-Jan-87 14:50 by Pavel")
+    (PROG (FL TEM)
+          (COND
+             ((SETQ FL (EDITLOADFNS? FN (AND (NULL EDITLOADFNSFLG)
+                                                 '"not editable, do you want to load it PROP from")
+                              (NULL EDITLOADFNSFLG)))
+              (LOADFNS FN FL 'PROP))
+             ((AND (EQ (NARGS 'WHEREIS)
+                       4)
+                   (SETQ FL (EDITLOADFNS? FN 
+                                   '"not editable; do you want to LOADFROM PROP the file" T T)))
+              (LOADFROM FL (LIST FN)
+                     'PROP))
+             (T (RETURN)))
+          (COND
+             ((GETPROP FN 'EXPR)
+              (RETURN T))
+             (T (PRINTOUT T "** Not found on " FL T])
+
+(EDITFNS
+  [NLAMBDA X                                                 (* DD%: " 7-Oct-81 20:56")
+
+    (* ;; "FNS is a list (or name of a list) of functions to be edited;  (CDR X) are the operations to be performed.")
+
+    (SETQ X (MKLIST X))
+    (MAPC [COND
+             ((LISTP (CAR X))
+              (STKEVAL 'EDITFNS (CAR X)
+                     NIL
+                     'INTERNAL))
+             (T                                              (* ; 
+                                       "If (CAR X) is name of a file, do editfns on its functions.")
+                (OR (LISTP (EVALV (CAR X)
+                                  'EDITFNS))
+                    (AND (GETPROP (OR (AND DWIMFLG (MISSPELLED? (CAR X)
+                                                          70 FILELST NIL X))
+                                      (CAR X))
+                                'FILE)
+                         (FILEFNSLST (CAR X)))
+                    (STKEVAL 'EDITFNS (CAR X)
+                           'INTERNAL]
+          (FUNCTION (LAMBDA (Y)
+                      (ERSETQ (APPLY 'EDITF (CONS (PROG1 (PRIN2 Y T T)
+                                                         (SPACES 1 T))
+                                                  (CDR X])
+
+(EDITLOADFNS?
+  [LAMBDA (FN STR ASKFLG FILES)                              (* lmm "20-Nov-86 21:23")
+
+    (* ;; "Value is name of file from which function or functions can be loaded.  If STR is non-NIL, user is asked to approve, and STR used in the message.  EDITLOADFNS?  is also used by prettyprint")
+
+    (AND FN FILEPKGFLG (PROG ((LST (WHEREIS FN 'FNS FILES))
+                              FILE DATES FD)
+                             (OR (COND
+                                    ((EQ FILES T)
+
+                                 (* ;; "if FILES = T, means consult data base.  if user has removed a function from one of those files, as evidenced by the fact that editloafns?  was called with files=T, then dont offer that file.")
+
+                                     (SETQ LST (LDIFFERENCE LST FILELST)))
+                                    (T LST))
+                                 (RETURN))
+                             [SETQ FILE (COND
+                                           ((CDR LST)
+                                            (PRIN2 FN T)
+                                            (MAPRINT LST T " is contained on " "
+" " and ")
+                                            (OR (ASKUSER NIL NIL "indicate which file to use: "
+                                                       (MAKEKEYLST LST)
+                                                       T)
+                                                (RETURN)))
+                                           (T (CAR LST]
+                             [SETQ DATES (LISTP (GETPROP FILE 'FILEDATES]
+
+                        (* ;; 
+                      "only look at file in FILEDATES if the file has been LOADed or LOADFROMd")
+
+                             (SETQ FILE (OR (AND DATES (FMEMB (CDAR (GETPROP FILE 'FILE))
+                                                              '(LOADFNS T))
+                                                 (INFILEP (CDAR DATES)))
+                                            (FINDFILE FILE T)
+                                            (RETURN)))
+                             [COND
+                                ((AND DATES (NEQ FILE (CDAR DATES)))
+                                                             (* ; 
+                                                         "found a different file than in FILEDATES")
+                                 (COND
+                                    ((EQUAL (CAAR DATES)
+                                            (SETQ FD (FILEDATE FILE)))
+                                                             (* ; 
+                                   "found a goood version of file on a different name.  smash name")
+                                     (/RPLACD (CAR DATES)
+                                            FILE))
+                                    (T (LISP:FORMAT *TERMINAL-IO* "*** Note: loading definition from ~A dated ~A~&while file ~A dated ~A is the version currently loaded."
+                                              FILE FD (CDAR DATES)
+                                              (CAAR DATES]
+                             (COND
+                                ((STREQUAL STR ""))
+                                ((NULL ASKFLG)
+                                 (if STR
+                                     then (EXEC-FORMAT "~&~A~A" STR FILE)
+                                   else (EXEC-FORMAT "~&Loading definition of ~S from ~A." FN 
+                                                   FILE)))
+                                ((NEQ (ASKUSER DWIMWAIT 'Y (LIST FN STR FILE)
+                                             NIL T)
+                                      'Y)
+                                 (RETURN)))
+                             (RETURN FILE])
+
+(EDITMODE
+  [LAMBDA (NEWMODE)
+
+(* ;;; "WOZ- 1/9/91.  Took (setq newmode (il:u-case newmode)) out because it puts newmode in the IL: package.  This doesn't work with my new definition of what an editor is, ie a symbol whos function cell can be applied to (structure props options).  The rest of the old code , eg Definition-for-EDITL remains until DEDIT goes away and the TTY/EDITOR becomes a programmatic structure editor only.")
+
+    (PROG1 (if (NOT (DISPLAYSTREAMP (TTYDISPLAYSTREAM)))
+               then 
+
+                     (* ;; "not a display, always say teletype. This is mainly for chatserver")
+
+                     'TELETYPE
+             else (SELECTQ *EDITMODE*
+                          (DISPLAY *DISPLAY-EDITOR*)
+                          *EDITMODE*))
+
+        (* ;; "return old value, and, if new value given, set it.")
+
+        (LISP:WHEN NEWMODE
+            (LET (new.display.editor)
+                 (if (EQ NEWMODE 'STANDARD)
+                     then                                (* ; "Obselete terminology")
+                           (SETQ NEWMODE 'TELETYPE)
+                   elseif (AND (EQ NEWMODE 'DISPLAY)
+                                   *DISPLAY-EDITOR*)
+                     then (SETQ NEWMODE *DISPLAY-EDITOR*)
+                   elseif (NEQ NEWMODE 'TELETYPE)
+                     then                                (* ; 
+       "if we've been called with the name of a display editor, make it the default display editor")
+                           (SETQ new.display.editor NEWMODE))
+                 (if (NOT (GETPROP NEWMODE 'Definition-for-EDITL))
+                     then (LISP:CERROR "Ignore call to EDITMODE" 
+                                     "~S is unrecognized argument to EDITMODE" NEWMODE)
+                   else (if new.display.editor
+                                then (SETQ *DISPLAY-EDITOR* new.display.editor))
+                         (SETQ *EDITMODE* NEWMODE)))))])
+
+(EDITP
+  [NLAMBDA EDITPX                                            (* lmm "10-Jun-85 17:12")
+    (SETQ EDITPX (NLAMBDA.ARGS EDITPX))
+    (PROG ((ATM (CAR EDITPX)))
+          [COND
+             ((AND DWIMFLG (NLISTP (GETPROPLIST ATM)))
+              (SETQ ATM (OR (MISSPELLED? ATM 75 USERWORDS NIL NIL (FUNCTION GETPROPLIST))
+                            ATM]
+          (EDITE (GETPROPLIST ATM)
+                 (CDR EDITPX)
+                 ATM
+                 'PROPLST)
+          (RETURN ATM])
+
+(EDITV
+  [NLAMBDA EDITVX                                            (* lmm " 2-Sep-85 13:17")
+    (SETQ EDITVX (NLAMBDA.ARGS EDITVX))
+    (LET* [[VAR (OR (CAR EDITVX)
+                    (PROGN (PRIN1 "= " T)
+                           (PRINT LASTWORD T]
+           (FRAME (AND VAR (STKSCAN VAR]
+          (if FRAME
+              then (EDITE (ENVEVAL VAR FRAME NIL T)
+                              (CDR EDITVX)
+                              VAR)
+            elseif (SETQ VAR (HASDEF VAR 'VARS 'CURRENT T))
+              then (EDITDEF VAR 'VARS 'CURRENT (CDR EDITVX))
+            else (ERROR VAR "not editable"])
+
+(DC
+  [NLAMBDA FILE                                              (* ; "Edited 18-Mar-87 16:03 by woz")
+                                                             (* ; "Edits COMS of file FILE")
+    (LET ((*EDITMODE* 'DISPLAY)
+          (ARGS (NLAMBDA.ARGS FILE)))
+
+         (* ;; "(APPLY (QUOTE EDITV) (FILECOMS (OR (HASDEF (CAR (NLAMBDA.ARGS FILE)) (QUOTE FILE) NIL T) (ERROR FILE 'is not a loaded file' T))))")
+
+         (if (LISTP ARGS)
+             then (SETQ *LAST-DC* (CAR ARGS)))
+         (if *LAST-DC*
+             then (ED *LAST-DC* '(FILES :DONTWAIT))
+           else (ERROR "No saved file name." "Edit aborted."])
+
+(DF
+  [NLAMBDA FN                                                (* ; "Edited 18-Mar-87 17:00 by woz")
+    (LET ((*EDITMODE* 'DISPLAY)
+          (ARGS (NLAMBDA.ARGS FN)))
+
+         (* ;; "(APPLY (COND ((EQ (CADR (LISTP FN)) (QUOTE NEW)) (QUOTE EDITFERROR)) (T (QUOTE EDITF))) (NLAMBDA.ARGS FN))")
+
+         (* ;; "DF used to look for MACROS under EDITFERROR.  Decided this is bad, because could get the macro without noticing the fns if the file was sysloaded.  Now just look for FUNCTIONS and FNS.")
+
+         (if (LISTP ARGS)
+             then (SETQ *LAST-DF* (CAR ARGS)))
+         (if *LAST-DF*
+             then [ED *LAST-DF* (if (AND (CDR ARGS)
+                                                     (EQ (CADR ARGS)
+                                                         'NEW))
+                                            then '(FUNCTIONS FNS :DONTWAIT :NEW)
+                                          else '(FUNCTIONS FNS :DONTWAIT]
+           else (ERROR "No saved function name." "Edit aborted."])
+
+(DP
+  [NLAMBDA ATOM                                              (* ; "Edited 18-Mar-87 16:16 by woz")
+    (LET ((*EDITMODE* 'DISPLAY)
+          (ARGS (NLAMBDA.ARGS ATOM)))                        (* ; 
+                                                     "(APPLY (QUOTE EDITPROP) (NLAMBDA.ARGS ATOM))")
+         [if (LISTP ARGS)
+             then (if (CDR ARGS)
+                          then                           (* ; 
+                                                      "specific PROP to edit. remember (ATOM PROP)")
+                                (SETQ *LAST-DP* ARGS)
+                        else                             (* ; 
+                                                           "edit whole plist.  remember ATOM")
+                              (SETQ *LAST-DP* (CAR ARGS]
+         (if *LAST-DP*
+             then [ED *LAST-DP* (if (LISTP *LAST-DP*)
+                                            then '(PROPS :DONTWAIT)
+                                          else '(PROPERTY-LIST :DONTWAIT]
+           else (ERROR "No saved symbol name." "Edit aborted."])
+
+(DV
+  [NLAMBDA VAR                                               (* ; "Edited 18-Mar-87 12:43 by woz")
+    (LET ((*EDITMODE* 'DISPLAY)
+          (ARGS (NLAMBDA.ARGS VAR)))                         (* ; 
+                                                         "(APPLY (QUOTE EDITV) (NLAMBDA.ARGS VAR))")
+         (if (LISTP ARGS)
+             then (SETQ *LAST-DV* (CAR ARGS)))
+         (if *LAST-DV*
+             then (ED *LAST-DV* '(VARIABLES VARS :DONTWAIT))
+           else (ERROR "No saved variable name." "Edit aborted."])
+
+(EDITPROP
+  [LAMBDA (NAME PROP)                                        (* bas%: "21-MAR-83 20:29")
+    (COND
+       (PROP (EDITDEF (LIST NAME PROP)
+                    'PROPS))
+       (T (APPLY 'EDITP NAME])
+
+(EF
+  [NLAMBDA FN                                                (* jow "16-Oct-86 11:41")
+    (LET ((*EDITMODE* 'TELETYPE))
+         (APPLY (COND
+                   ((EQ (CADR (LISTP FN))
+                        'NEW)
+                    'EDITFERROR)
+                   (T 'EDITF))
+                (NLAMBDA.ARGS FN])
+
+(EP
+  [NLAMBDA ATOM                                              (* jow "16-Oct-86 11:42")
+    (LET ((*EDITMODE* 'TELETYPE))
+         (APPLY 'EDITPROP (NLAMBDA.ARGS ATOM])
+
+(EV
+  [NLAMBDA VAR                                               (* jow "16-Oct-86 11:42")
+    (LET ((*EDITMODE* 'TELETYPE))
+         (APPLY 'EDITV (NLAMBDA.ARGS VAR])
+
+(EDITE
+  [LAMBDA (EXPR COMS ATM TYPE IFCHANGEDFN OPTIONS)           (* ; "Edited 17-Mar-87 11:59 by woz")
+    (if (AND EXPR (NLISTP EXPR)
+                 (SELECTQ (EDITMODE)
+                     (TELETYPE                               (* ; "don't inspect")
+                               NIL)
+                     (SEDIT (NOT (STRINGP EXPR))             (* ; 
+                                            "Sedit can't handle strings, it returns the old string")
+                            T)
+                     T))
+        then 
+
+              (* ;; "this used to be done by redefining EDITE on the file INSPECT. Its not clear that it is still a good idea")
+
+              (INSPECT EXPR)
+      else (LISP:FUNCALL (GET (EDITMODE)
+                                  'Definition-for-EDITE)
+                      EXPR COMS ATM TYPE IFCHANGEDFN OPTIONS])
+
+(EDITL
+  [LAMBDA (L COMS ATM MESS EDITCHANGES)                      (* lmm "12-Nov-86 15:18")
+    (LISP:FUNCALL (GET (EDITMODE)
+                       'Definition-for-EDITL)
+           L COMS ATM MESS EDITCHANGES])
+)
+
+
+
+(* ;; "Time stamp on functions when edited")
+
+
+
+
+(* ;; 
+"User enables this by an (ADDTOVAR INITIALSLIST (USERNAME )) in his INIT.LISP.  E.g.  (ADDTOVAR INITIALSLIST (MASINTER )) The date fixup is enabled by the variable INITIALS.  The function SETINITIALS sets INITIALS from INITIALSLIST and USERNAME at load time, and after a sysin."
+)
+
+(DEFINEQ
+
+(NEW/EDITDATE
+  [LAMBDA (OLDATE INITLS)                                    (* lmm "12-Nov-86 15:18")
+    (LISP:FUNCALL (GET (EDITMODE)
+                       'Definition-for-EDITDATE)
+           OLDATE INITLS])
+
+(FIXEDITDATE
+  [LAMBDA (EXPR)                                             (* NOBIND "18-JUL-78 21:11")
+                                                             (* ; 
+                                                           "Inserts or replaces previous edit date")
+    (AND INITIALS (LISTP EXPR)
+         (FMEMB (CAR EXPR)
+                LAMBDASPLST)
+         (LISTP (CDR EXPR))
+         (PROG ((E (CDDR EXPR)))
+           RETRY
+               [COND
+                  ((NLISTP E)
+                   (RETURN))
+                  ((LISTP (CAR E))
+                   (SELECTQ (CAAR E)
+                       ((CLISP%: DECLARE) 
+                            (SETQ E (CDR E))
+                            (GO RETRY))
+                       (BREAK1 (COND
+                                  ((EQ (CAR (CADAR E))
+                                       'PROGN)
+                                   (SETQ E (CDR (CADAR E)))
+                                   (GO RETRY))))
+                       (ADV-PROG                             (* ; 
+                                      "No easy way to mark cleanly the date of an advised function")
+                                 (RETURN))
+                       (COND
+                          ((AND (EQ (CAAR E)
+                                    COMMENTFLG)
+                                (EQ (CADAR E)
+                                    'DECLARATIONS%:))
+                           (SETQ E (CDR E))
+                           (GO RETRY]
+               (COND
+                  ((AND (LISTP (CDR E))
+                        (EDITDATE? (CAR E)))
+                   (/RPLACA E (EDITDATE (CAR E)
+                                     INITIALS)))
+                  (T (/ATTACH (EDITDATE NIL INITIALS)
+                            E)))
+               (RETURN EXPR])
+
+(EDITDATE?
+  [LAMBDA (COMMENT)                                          (* ; "Edited 29-Oct-87 16:41 by drc:")
+
+(* ;;; "Tests to see if a given common is in fact an edit date -- this has to be general enough to recognize the most comment comment forms while specific enough to not recognize things that are not edit dates.  We settle for the conservative form of (* initials date-string), since only truly ancient edit dates look any different from that")
+
+    (DECLARE (LOCALVARS . T))
+    (AND *REPLACE-OLD-EDIT-DATES* (LISTP COMMENT)
+         (EQMEMB (CAR COMMENT)
+                COMMENTFLG)
+         (LISTP (CDR COMMENT))
+         (LISTP (CDDR COMMENT))
+         (NULL (CDDDR COMMENT))
+         (STRINGP (CADDR COMMENT))
+         (LET ((INITIALS? (CADR COMMENT)))
+              (AND (NOT (EQMEMB INITIALS? COMMENTFLG))
+                   (OR (EQ INITIALS? INITIALS)
+                       (if (LITATOM INITIALS?)
+                           then (if (for I from 1 to (NCHARS INITIALS?)
+                                               always (EQ (NTHCHARCODE INITIALS? I)
+                                                              (CHARCODE ";")))
+                                        then             (* ; " an sedit comment")
+                                              (AND (EQ INITIALS? ';)
+                                                   (STRPOS "Edited " (CADDR COMMENT)
+                                                          1 NIL T)
+                                                   (>= (LISP:LENGTH (CADDR COMMENT))
+                                                       (LISP:LENGTH "Edited 01-jan-86 00:00 by ")))
+                                      else               (* ; "an old-style comment")
+                                            T)
+                         elseif (STRINGP INITIALS?)
+                           then                          (* ; 
+                                                        "make sure it's not a string-body comment.")
+                                 (ILESSP (NCHARS INITIALS?)
+                                        12])
+
+(EDITDATE
+  [LAMBDA (OLDATE INITLS)                                    (* ; 
+                                                           "Edited 20-Nov-86 23:23 by Masinter")
+
+    (* ;; "Generates a new date from an old one")
+
+    (LET [(NEWDATE (LIST '; (CONCAT "Edited " (DATE (DATEFORMAT NO.SECONDS))
+                                   " by " INITLS]
+         (COND
+            ((EQMEMB (CAR (LISTP OLDATE))
+                    COMMENTFLG)
+
+             (* ;; "Destructively alter old date.  This is for benefit of DEDIT being able to find the old form to reprint")
+
+             (/RPLACD OLDATE NEWDATE))
+            (T (CONS (OR (CAR (LISTP COMMENTFLG))
+                         COMMENTFLG)
+                     NEWDATE])
+
+(SETINITIALS
+  [LAMBDA NIL                                              (* ; 
+                                                           "Edited 20-Nov-86 23:22 by MASINTER")
+
+(* ;;; "Sets the default initials to appear in edited code, and sets the user's first name.  Called following GREET via POSTGREETFORMS.")
+
+    (LET ((DFNFLG T)
+          (FILEPKGFLG NIL)
+          (USER (USERNAME NIL NIL T))
+          POS TRIPLE)
+         (SETQ POS (STRPOS "." USER))                        (* ; 
+"Find out if there's a period in the name, which would indicate that there's a registry on the end.")
+         [COND
+            ((AND POS DEFAULTREGISTRY (STRING-EQUAL (SUBSTRING USER (ADD1 POS)
+                                                           -1)
+                                             DEFAULTREGISTRY))
+
+             (* ;; "If there's a registry on the end, and it's the default registry, remove the registry.  We assume that DEFAULTREGISTRY has been set by the time that GREET has finished.")
+
+             (SETQ USER (SUBSTRING USER 1 (SUB1 POS]
+         (COND
+            [(find old TRIPLE in INITIALSLST suchthat (STRING-EQUAL USER (CAR TRIPLE)
+                                                                             ))
+                                                             (* ; 
+         "OK we found his last name on the INITIALSLST.  Now break out his initials and first name")
+             (COND
+                ((NLISTP (CDR TRIPLE))                       (* ; "old style")
+                 (SAVESET 'INITIALS (CDR TRIPLE)))
+                (T (SAVESET 'FIRSTNAME (CADR TRIPLE))
+                   (SAVESET 'INITIALS (CADDR TRIPLE]
+            (T (SAVESET 'INITIALS (COND
+                                     ((NOT DEFAULTINITIALS)
+                                      NIL)
+                                     ((NEQ DEFAULTINITIALS T)
+                                      DEFAULTINITIALS)
+                                     (T USER])
+)
+
+(RPAQ? INITIALS )
+
+(RPAQ? INITIALSLST )
+
+(RPAQ? DEFAULTINITIALS T)
+
+(LISP:DEFVAR *REPLACE-OLD-EDIT-DATES* T
+   "NIL or T; if NIL, old edit dates will not be replaced")
+
+(MOVD? 'EDITDATE 'TTY/EDITDATE)
+
+(RPAQ? COMMON-SOURCE-MANAGER-TYPES '(FUNCTIONS VARIABLES STRUCTURES TYPES SETFS OPTIMIZERS))
+
+(PUTPROPS EDITINTERFACE FILETYPE LISP:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA EV EP EF DV DP DF DC EDITV EDITP EDITFNS EDITF)
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA )
+)
+(PUTPROPS EDITINTERFACE COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (15224 32017 (EDITDEF.FNS 15234 . 16576) (EDITF 16578 . 17460) (EDITFB 17462 . 18310) 
+(EDITFNS 18312 . 19575) (EDITLOADFNS? 19577 . 23356) (EDITMODE 23358 . 25372) (EDITP 25374 . 25885) (
+EDITV 25887 . 26532) (DC 26534 . 27200) (DF 27202 . 28258) (DP 28260 . 29418) (DV 29420 . 29986) (
+EDITPROP 29988 . 30203) (EF 30205 . 30530) (EP 30532 . 30711) (EV 30713 . 30888) (EDITE 30890 . 31787)
+ (EDITL 31789 . 32015)) (32367 39397 (NEW/EDITDATE 32377 . 32599) (FIXEDITDATE 32601 . 34437) (
+EDITDATE? 34439 . 36612) (EDITDATE 36614 . 37359) (SETINITIALS 37361 . 39395)))))
+STOP
diff --git a/CLTL2/EDITINTERFACE.LCOM b/CLTL2/EDITINTERFACE.LCOM
new file mode 100644
index 00000000..ee21186f
Binary files /dev/null and b/CLTL2/EDITINTERFACE.LCOM differ
diff --git a/CLTL2/ERROR-RUNTIME b/CLTL2/ERROR-RUNTIME
new file mode 100644
index 00000000..300db76e
--- /dev/null
+++ b/CLTL2/ERROR-RUNTIME
@@ -0,0 +1,420 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+(FILECREATED "18-Oct-93 15:37:49" "{Pele:mv:envos}<LispCore>Sources>CLTL2>ERROR-RUNTIME.;2" 23732  
+
+      |previous| |date:| "11-Mar-92 14:19:49" 
+"{Pele:mv:envos}<LispCore>Sources>CLTL2>ERROR-RUNTIME.;1")
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT ERROR-RUNTIMECOMS)
+
+(RPAQQ ERROR-RUNTIMECOMS
+       ((COMS 
+
+(* |;;;| "Internal functions.")
+
+              (FUNCTIONS SI::CONDITION-CASE-ERROR CONDITION-HANDLER CONDITION-REPORTER 
+                     %PRINT-CONDITION CONDITIONS::%RESTART-PRINTER 
+                     CONDITIONS::%RESTART-DEFAULT-REPORTER REPORT-CONDITION CONDITION-PARENT)
+              (VARIABLES *CONDITION-HANDLER-BINDINGS* LISP:*DEBUGGER-HOOK* *PROCEED-CASES*)
+              (FUNCTIONS CHECK-TYPE-FAIL ECASE-FAIL ASSERT-FAIL)
+              (FUNCTIONS XCL::SYMBOL-AS-PATHNAME)
+              (FUNCTIONS MAKE-INTO-CONDITION RAISE-SIGNAL DEFAULT-HANDLE-CONDITION 
+                     DEFAULT-PROCEED-REPORTER CONDITIONS::DEFAULT-RESTART-REPORTER 
+                     DEFAULT-PROCEED-TEST TEST-PROCEED-CASE WALK-PROCEED-CASES 
+                     SI::INVOKE-ACTUAL-RESTART))
+        (COMS 
+
+(* |;;;| "Exported symbols. Anything here that's not in CL should be in XCL.")
+
+              (VARIABLES CONDITIONS:*BREAK-ON-SIGNALS* *BREAK-ON-WARNINGS* XCL:*CURRENT-CONDITION*)
+              (FUNCTIONS MAKE-CONDITION SIGNAL LISP:ERROR LISP:CERROR LISP:WARN LISP:BREAK 
+                     CONDITIONS:INVOKE-DEBUGGER)
+              (FUNCTIONS LISP:FIND-RESTART LISP:COMPUTE-RESTARTS LISP:INVOKE-RESTART 
+                     CONDITIONS:INVOKE-RESTART-INTERACTIVELY))
+        (PROP FILETYPE ERROR-RUNTIME)))
+
+
+
+(* |;;;| "Internal functions.")
+
+
+(LISP:DEFUN SI::CONDITION-CASE-ERROR (SI::REAL-SELECTOR SI::POSSIBILITIES)
+   (LISP:ERROR "Unexpected selector in ~S." 'CONDITION-CASE SI::REAL-SELECTOR SI::POSSIBILITIES))
+
+(DEFMACRO CONDITION-HANDLER (XCL::CONDITION-TYPE)
+   `(GETPROP ,XCL::CONDITION-TYPE '%CONDITION-HANDLER))
+
+(DEFMACRO CONDITION-REPORTER (XCL::CONDITION-TYPE)
+   `(GETPROP ,XCL::CONDITION-TYPE '%CONDITION-REPORTER))
+
+(LISP:DEFUN %PRINT-CONDITION (CONDITION STREAM LEVEL)
+   (DECLARE (IGNORE LEVEL))
+   (LISP:IF *PRINT-ESCAPE*
+       (LISP:FORMAT STREAM "#<Condition ~S @ ~O,~O>" (LISP:TYPE-OF CONDITION)
+              (\\HILOC CONDITION)
+              (\\LOLOC CONDITION))
+       (REPORT-CONDITION CONDITION STREAM)))
+
+(LISP:DEFUN CONDITIONS::%RESTART-PRINTER (CONDITIONS:RESTART STREAM CONDITIONS::LEVEL)
+                                                             (* \; "Edited  2-Mar-92 16:00 by jrb:")
+   (LISP:IF *PRINT-ESCAPE*
+       (LISP:FUNCALL LISP::%DEFAULT-PRINT-FUNCTION CONDITIONS:RESTART STREAM CONDITIONS::LEVEL)
+       (LET ((CONDITIONS::REPORTER (OR (CONDITIONS::RESTART-REPORT CONDITIONS:RESTART)
+                                       (CONDITIONS::DEFAULT-RESTART-REPORT (CONDITIONS:RESTART-NAME
+                                                                            CONDITIONS:RESTART))
+                                       (LISP:RETURN-FROM CONDITIONS::%RESTART-PRINTER
+                                              (CONDITIONS::DEFAULT-RESTART-REPORTER 
+                                                     CONDITIONS:RESTART STREAM)))))
+            (LISP:IF (LISP:STRINGP CONDITIONS::REPORTER)
+                (LISP:PRINC CONDITIONS::REPORTER STREAM)
+                (LISP:FUNCALL CONDITIONS::REPORTER STREAM)))))
+
+(LISP:DEFUN CONDITIONS::%RESTART-DEFAULT-REPORTER (CONDITIONS:RESTART STREAM)
+   (LISP:FUNCALL (CONDITIONS::DEFAULT-RESTART-REPORT (CONDITIONS:RESTART-NAME CONDITIONS:RESTART))
+          CONDITIONS:RESTART STREAM))
+
+(LISP:DEFUN REPORT-CONDITION (CONDITION STREAM)
+   (LISP:DO* ((TYPE (LISP:TYPE-OF CONDITION)
+                    (CONDITION-PARENT TYPE))
+              (REPORTER (CONDITION-REPORTER TYPE)
+                     (CONDITION-REPORTER TYPE)))
+             ((NULL TYPE)
+              (LISP:BREAK "No report function found for ~S." CONDITION))
+       (LISP:WHEN REPORTER
+           (RETURN (LISP:IF (LISP:STRINGP REPORTER)
+                       (LISP:PRINC REPORTER STREAM)
+                       (LISP:FUNCALL REPORTER CONDITION STREAM))))))
+
+(LISP:DEFUN CONDITION-PARENT (TYPE)
+   (LET ((PARENT (GETSUPERTYPE TYPE)))
+        (LISP:IF (EQ PARENT 'LISP::STRUCTURE-OBJECT)
+            NIL
+            PARENT)))
+
+(LISP:DEFVAR *CONDITION-HANDLER-BINDINGS* NIL
+   "Condition handler binding stack")
+
+(LISP:DEFVAR LISP:*DEBUGGER-HOOK* NIL)
+
+(LISP:DEFVAR *PROCEED-CASES* NIL
+   "Active proceed case stack")
+
+(LISP:DEFUN CHECK-TYPE-FAIL (PROCEEDABLE PLACE VALUE DESIRED-TYPE MESSAGE)
+   (LISP:RESTART-CASE (LISP:ERROR 'XCL:TYPE-MISMATCH :NAME PLACE :VALUE VALUE :EXPECTED-TYPE 
+                             DESIRED-TYPE :MESSAGE MESSAGE)
+          (STORE-VALUE (NEW)
+                 :REPORT
+                 (LAMBDA (STREAM)
+                   (LISP:FORMAT STREAM "Change the value of ~A" PLACE))
+                 :INTERACTIVE
+                 (LAMBDA NIL
+                   (LISP:FORMAT *QUERY-IO* "Enter a new value to store into ~A: " PLACE)
+                   (LIST (LISP:EVAL (LISP:READ *QUERY-IO*))))
+                 :FILTER
+                 (LAMBDA NIL
+                   (AND PROCEEDABLE (TYPEP XCL:*CURRENT-CONDITION* 'XCL:TYPE-MISMATCH)))
+                 NEW)))
+
+(LISP:DEFUN ECASE-FAIL (PROCEEDABLE PLACE VALUE SELECTORS)
+   (LISP:RESTART-CASE (LISP:IF (EQL PLACE VALUE)
+                          (LISP:ERROR "~S is ~?." VALUE 
+                                 "~#[wrong~;not ~S~;neither ~S nor ~S~:;not~@{~#[~; or~] ~S~^,~}~]" 
+                                 SELECTORS)
+                          (LISP:ERROR "The value of ~S, ~S,~&is ~?." PLACE VALUE 
+                                 "~#[wrong~;not ~S~;neither ~S nor ~S~:;not~@{~#[~; or~] ~S~^,~}~]" 
+                                 SELECTORS))
+          (STORE-VALUE (V)
+                 :FILTER
+                 (LAMBDA NIL PROCEEDABLE)
+                 :REPORT
+                 (LAMBDA (STREAM)
+                   (LISP:FORMAT STREAM "Change the value of ~A" PLACE))
+                 :INTERACTIVE
+                 (LAMBDA NIL
+                   (LISP:FORMAT *QUERY-IO* "Enter a new value to store into ~A: " PLACE)
+                   (LIST (LISP:EVAL (LISP:READ *QUERY-IO*))))
+                 V)))
+
+(LISP:DEFUN ASSERT-FAIL (STRING &REST ARGS)
+   (PROCEED-CASE (LISP:ERROR 'XCL:ASSERTION-FAILED :FORMAT-STRING STRING :FORMAT-ARGUMENTS ARGS)
+          (CONDITIONS:CONTINUE NIL :REPORT "Re-test assertion")))
+
+(LISP:DEFUN XCL::SYMBOL-AS-PATHNAME (LISP:SYMBOL XCL::WHERE &OPTIONAL XCL::MESSAGE)
+   (LISP:RESTART-CASE (LISP:ERROR 'XCL::SYMBOL-AS-PATHNAME :SYMBOL LISP:SYMBOL :WHERE XCL::WHERE
+                             :MESSAGE XCL::MESSAGE)
+          (XCL::USE-PNAME NIL :REPORT (LISP:LAMBDA (STREAM)
+                                               (LISP:PRINC "Use the symbol's pname" STREAM))
+                 :FILTER
+                 (LISP:LAMBDA NIL (TYPEP XCL:*CURRENT-CONDITION* 'XCL::SYMBOL-AS-PATHNAME)))))
+
+(LISP:DEFUN MAKE-INTO-CONDITION (DATUM DESIRED-TYPE ARGS)
+   (LISP:ETYPECASE DATUM
+       (CONDITION DATUM)
+       (LISP:SYMBOL (LISP:IF (LISP:SUBTYPEP DATUM 'CONDITION)
+                        (LISP:APPLY 'MAKE-CONDITION DATUM ARGS)
+                        (LISP:ERROR "~S is not a condition type." DATUM)))
+       (STRING (MAKE-CONDITION DESIRED-TYPE :FORMAT-STRING DATUM :FORMAT-ARGUMENTS ARGS))))
+
+(LISP:DEFUN RAISE-SIGNAL (CONDITION)
+   (LISP:WHEN (TYPEP CONDITION CONDITIONS:*BREAK-ON-SIGNALS*)
+          (LISP:BREAK "Condition ~S is about to be signalled." CONDITION))
+   (LET ((*CONDITION-HANDLER-BINDINGS* *CONDITION-HANDLER-BINDINGS*))
+        (LISP:FLET ((TRY-TO-HANDLE (CONDITION TYPE-SPEC HANDLER)
+                           (LISP:MACROLET ((WITHOUT-HANDLERS (&BODY BODY)
+                                                  `(LET (*CONDITION-HANDLER-BINDINGS*)
+                                                        ,@BODY)))
+                                  (LISP:WHEN (PROCEED-CASE (WITHOUT-HANDLERS (TYPEP CONDITION 
+                                                                                    TYPE-SPEC))
+                                                    (PROCEED NIL :REPORT 
+                                                           "Skip the bad handler binding" NIL))
+                                         (LISP:FUNCALL HANDLER CONDITION)))))
+               (WHILE *CONDITION-HANDLER-BINDINGS*
+                  DO (LET ((BINDING (LISP:POP *CONDITION-HANDLER-BINDINGS*)))
+                              (IF (EQ (LISP:FIRST BINDING)
+                                          :MULTIPLE-HANDLER-BINDINGS)
+                                  THEN (LISP:POP BINDING)
+                                        (WHILE BINDING DO (TRY-TO-HANDLE CONDITION
+                                                                         (LISP:POP BINDING)
+                                                                         (LISP:POP BINDING)))
+                                ELSE (TRY-TO-HANDLE CONDITION (CAR BINDING)
+                                                (CDR BINDING)))) FINALLY (
+                                                                           DEFAULT-HANDLE-CONDITION
+                                                                              CONDITION)))
+        CONDITION))
+
+(LISP:DEFUN DEFAULT-HANDLE-CONDITION (CONDITION)
+   (LISP:DO ((TYPE (LISP:TYPE-OF CONDITION)
+                   (CONDITION-PARENT TYPE)))
+            ((NULL TYPE))
+       (LET ((HANDLER (CONDITION-HANDLER TYPE)))
+            (LISP:WHEN HANDLER (LISP:FUNCALL HANDLER CONDITION)))))
+
+(LISP:DEFUN DEFAULT-PROCEED-REPORTER (PC STREAM)
+   (LISP:FORMAT STREAM "Proceed-type: ~A" (PROCEED-CASE-NAME PC)))
+
+(LISP:DEFUN CONDITIONS::DEFAULT-RESTART-REPORTER (CONDITIONS:RESTART STREAM)
+   (LISP:FORMAT STREAM "Restart type: ~A" (CONDITIONS:RESTART-NAME CONDITIONS:RESTART)))
+
+(DEFMACRO DEFAULT-PROCEED-TEST (XCL::PROCEED-TYPE)
+   `(GETPROP ,XCL::PROCEED-TYPE '%DEFAULT-PROCEED-TEST))
+
+(LISP:DEFUN TEST-PROCEED-CASE (PC &AUX FILTER)
+   (COND
+      ((LISP:SETF FILTER (CONDITIONS::RESTART-TEST PC))
+       (LISP:FUNCALL FILTER))
+      ((CONDITIONS:RESTART-NAME PC)
+       (LISP:IF (LISP:SETF FILTER (DEFAULT-PROCEED-TEST (CONDITIONS:RESTART-NAME PC)))
+           (LISP:FUNCALL FILTER)
+           T))
+      (T                                                     (* \; 
+                                                       "unnamed proceed case with no explicit test")
+         T)))
+
+(LISP:DEFUN WALK-PROCEED-CASES (PROCEED-CASES PRED)
+   (LISP:FLET ((CONVERT-PROCEED-CASE (PC BLIP)
+                      (LISP:IF (NULL (CONDITIONS::RESTART-TAG PC))
+                          (LET ((NEW (CONDITIONS::COPY-RESTART PC)))
+                               (LISP:SETF (CONDITIONS::RESTART-TAG NEW)
+                                      BLIP)
+                               NEW)
+                          PC)))
+          (LISP:DO ((TAIL PROCEED-CASES (CDR TAIL)))
+                   ((NULL TAIL)
+                    NIL)
+              (LISP:MACROLET ((PROCESS-THING (THING BLIP)
+                                     `(LET ((PC (CONVERT-PROCEED-CASE ,THING ,BLIP)))
+                                           (LISP:WHEN (LISP:FUNCALL PRED PC)
+                                                  (LISP:RETURN-FROM WALK-PROCEED-CASES PC)))))
+                     (LET ((OBJECT (CAR TAIL)))
+                          (LISP:IF (LISP:CONSP OBJECT)
+                              (LISP:DO ((THINGS OBJECT (CDR THINGS)))
+                                       ((NULL THINGS))
+                                  (PROCESS-THING (CAR THINGS)
+                                         TAIL))
+                              (PROCESS-THING OBJECT TAIL)))))))
+
+(LISP:DEFUN SI::INVOKE-ACTUAL-RESTART (SI::RESTART SI::ARGUMENTS)
+   (COND
+      ((NULL (CONDITIONS::RESTART-FUNCTION SI::RESTART))
+       (LISP:THROW (CONDITIONS::RESTART-TAG SI::RESTART)
+              (CONS (CONDITIONS::RESTART-SELECTOR SI::RESTART)
+                    SI::ARGUMENTS)))
+      ((EQ (CONDITIONS::RESTART-SELECTOR SI::RESTART)
+           'SI::COMPLEX-RESTART-MARKER)
+       (LISP:APPLY (CONDITIONS::RESTART-FUNCTION SI::RESTART)
+              SI::ARGUMENTS))
+      (T (LISP:ERROR "Malformed restart object ~S." SI::RESTART))))
+
+
+
+(* |;;;| "Exported symbols. Anything here that's not in CL should be in XCL.")
+
+
+(LISP:DEFVAR CONDITIONS:*BREAK-ON-SIGNALS* NIL)
+
+(LISP:DEFVAR *BREAK-ON-WARNINGS* NIL
+   "If true, calls to WARN will cause a break as well as logging the warning.")
+
+(LISP:DEFVAR XCL:*CURRENT-CONDITION* NIL
+   "The condition currently being signalled")
+
+(LISP:DEFUN MAKE-CONDITION (TYPE &REST XCL::SLOT-INITIALIZATIONS)
+   "Create a condition object of the specified type."
+   (LISP:APPLY (LISP::STRUCTURE-CONSTRUCTOR TYPE)
+          XCL::SLOT-INITIALIZATIONS))
+
+(LISP:DEFUN SIGNAL (XCL::DATUM &REST XCL::ARGS)
+   (LET ((XCL:*CURRENT-CONDITION* (MAKE-INTO-CONDITION XCL::DATUM 'SIMPLE-CONDITION XCL::ARGS)))
+        (RAISE-SIGNAL (LISP:SETQ *LAST-CONDITION* XCL:*CURRENT-CONDITION*))
+        (LISP:RETURN-FROM SIGNAL XCL:*CURRENT-CONDITION*)))
+
+(LISP:DEFUN LISP:ERROR (LISP::DATUM &REST LISP::ARGS)
+
+   (* |;;| "In Xerox Common Lisp, as with Interlisp, errors may not enter the debugger if they are simple, defined by ENTER-DEBUGGER-P")
+
+   (LET ((XCL:*CURRENT-CONDITION* (MAKE-INTO-CONDITION LISP::DATUM 'SIMPLE-ERROR LISP::ARGS)))
+        (RAISE-SIGNAL (LISP:SETQ *LAST-CONDITION* XCL:*CURRENT-CONDITION*))
+                                                             (* \; "may just unwind.")
+        (RESETLST
+            (LET ((PRINTMSG T)
+                  (ERRORPOS (FIND-DEBUGGER-ENTRY-FRAME 'LISP:ERROR)))
+                 (DECLARE (LISP:SPECIAL PRINTMSG ERRORPOS))
+                 (RESETSAVE NIL (LIST 'RELSTK ERRORPOS))
+                 (COND
+                    ((NULL (ENTER-DEBUGGER-P HELPDEPTH ERRORPOS XCL:*CURRENT-CONDITION*))
+
+                     (* |;;| " says not to enter debugger")
+
+                     (COND
+                        (PRINTMSG                            (* \; 
+                                                           "print message if no break is to occur.")
+                               (LISP:PRINC XCL:*CURRENT-CONDITION* *ERROR-OUTPUT*)))
+                     (ERROR!)))
+                 (DEBUGGER :CONDITION XCL:*CURRENT-CONDITION* :AT (STKNAME ERRORPOS))))))
+
+(LISP:DEFUN LISP:CERROR (LISP::PROCEED-FORMAT-STRING LISP::DATUM &REST LISP::ARGUMENTS)
+   (LET ((XCL:*CURRENT-CONDITION* (MAKE-INTO-CONDITION LISP::DATUM 'SIMPLE-ERROR LISP::ARGUMENTS)
+                ))
+        (PROCEED-CASE (LISP:ERROR XCL:*CURRENT-CONDITION*)
+               (CONDITIONS:CONTINUE NIL :REPORT (LISP:APPLY (FUNCTION LISP:FORMAT)
+                                                         T LISP::PROCEED-FORMAT-STRING 
+                                                         LISP::ARGUMENTS)
+                      (LISP:RETURN-FROM LISP:CERROR XCL:*CURRENT-CONDITION*)))))
+
+(LISP:DEFUN LISP:WARN (LISP::DATUM &REST LISP::ARGUMENTS)
+   (LET ((XCL:*CURRENT-CONDITION* (MAKE-INTO-CONDITION LISP::DATUM 'SIMPLE-WARNING 
+                                         LISP::ARGUMENTS)))
+        (LISP:UNLESS (TYPEP XCL:*CURRENT-CONDITION* 'WARNING)
+            (LISP:CERROR "Signal and report the condition anyway" 'XCL:TYPE-MISMATCH :NAME
+                   'LISP::CONDITION :VALUE XCL:*CURRENT-CONDITION* :EXPECTED-TYPE 'WARNING))
+        (LISP:WHEN *BREAK-ON-WARNINGS* (LISP:BREAK "Warning: ~A" XCL:*CURRENT-CONDITION*))
+        (PROCEED-CASE (PROGN (RAISE-SIGNAL XCL:*CURRENT-CONDITION*)
+                             (LISP:FORMAT *ERROR-OUTPUT* "~&Warning: ~A~%" XCL:*CURRENT-CONDITION*)
+                             NIL)
+               (CONDITIONS:MUFFLE-WARNING NIL :REPORT "Don't print the warning" NIL))))
+
+(LISP:DEFUN LISP:BREAK (&OPTIONAL (LISP::FORMAT-STRING "Break.")
+                                  &REST LISP::FORMAT-ARGUMENTS)
+
+   (* |;;| "Want to try and get some indication of which break you're returning from.")
+
+   (PROCEED-CASE (CONDITIONS:INVOKE-DEBUGGER (MAKE-CONDITION 'SIMPLE-CONDITION :FORMAT-STRING
+                                                        LISP::FORMAT-STRING :FORMAT-ARGUMENTS 
+                                                        LISP::FORMAT-ARGUMENTS))
+          (CONDITIONS:CONTINUE NIL :REPORT "Return from BREAK" (LISP:RETURN-FROM LISP:BREAK NIL))
+          ))
+
+(LISP:DEFUN CONDITIONS:INVOKE-DEBUGGER (CONDITION)       (* \; "Edited 19-Feb-92 20:27 by jrb:")
+
+   (* |;;| 
+ "Look at the *DEBUGGER-HOOK* and call it; if you get back, enter debugger, never to return ")
+
+   (LISP:WHEN LISP:*DEBUGGER-HOOK* (LISP:FUNCALL LISP:*DEBUGGER-HOOK* CONDITION LISP:*DEBUGGER-HOOK*)
+          )
+   (DEBUGGER :CONDITION CONDITION))
+
+(LISP:DEFUN LISP:FIND-RESTART (CONDITIONS::IDENTIFIER &OPTIONAL (XCL:*CURRENT-CONDITION* 
+                                                                           XCL:*CURRENT-CONDITION*))
+                                                             (* \; "Edited 24-Feb-92 12:02 by jrb:")
+   (LISP:FLET ((CONDITIONS::SAME-RESTART (CONDITIONS::IDENTIFIER CONDITIONS::PROTOTYPE)))
+          (LISP:ETYPECASE CONDITIONS::IDENTIFIER
+              (NULL (LISP:ERROR "~S is an invalid argument to ~S;~%    use ~S instead" NIL
+                           'LISP:FIND-RESTART
+                           'LISP:COMPUTE-RESTARTS))
+              (CONDITIONS:RESTART (WALK-PROCEED-CASES
+                                   *PROCEED-CASES*
+                                   #'(LISP:LAMBDA (CONDITIONS:RESTART)
+                                            (AND (OR (EQ CONDITIONS::IDENTIFIER CONDITIONS:RESTART)
+                                                     (AND (CONDITIONS::RESTART-TAG 
+                                                                 CONDITIONS::IDENTIFIER)
+                                                          (EQ (CONDITIONS:RESTART-NAME 
+                                                                     CONDITIONS::IDENTIFIER)
+                                                              (CONDITIONS:RESTART-NAME 
+                                                                     CONDITIONS:RESTART))
+                                                          (EQ (CONDITIONS::RESTART-TAG 
+                                                                     CONDITIONS::IDENTIFIER)
+                                                              (CONDITIONS::RESTART-TAG 
+                                                                     CONDITIONS:RESTART))
+                                                          (EQ (CONDITIONS::RESTART-SELECTOR 
+                                                                     CONDITIONS::IDENTIFIER)
+                                                              (CONDITIONS::RESTART-SELECTOR 
+                                                                     CONDITIONS:RESTART))
+                                                          (EQ (CONDITIONS::RESTART-TEST 
+                                                                     CONDITIONS::IDENTIFIER)
+                                                              (CONDITIONS::RESTART-TEST 
+                                                                     CONDITIONS:RESTART))
+                                                          (EQ (CONDITIONS::RESTART-REPORT 
+                                                                     CONDITIONS::IDENTIFIER)
+                                                              (CONDITIONS::RESTART-REPORT 
+                                                                     CONDITIONS:RESTART))
+                                                          (EQ (CONDITIONS::RESTART-INTERACTIVE-FN
+                                                               CONDITIONS::IDENTIFIER)
+                                                              (CONDITIONS::RESTART-INTERACTIVE-FN
+                                                               CONDITIONS:RESTART))
+                                                          (EQ (CONDITIONS::RESTART-FUNCTION 
+                                                                     CONDITIONS::IDENTIFIER)
+                                                              (CONDITIONS::RESTART-FUNCTION 
+                                                                     CONDITIONS:RESTART))))
+                                                 (TEST-PROCEED-CASE CONDITIONS:RESTART)))))
+              (LISP:SYMBOL (WALK-PROCEED-CASES *PROCEED-CASES*
+                                  #'(LISP:LAMBDA (CONDITIONS:RESTART)
+                                           (AND (EQ (CONDITIONS:RESTART-NAME CONDITIONS:RESTART)
+                                                    CONDITIONS::IDENTIFIER)
+                                                (TEST-PROCEED-CASE CONDITIONS:RESTART))))))))
+
+(LISP:DEFUN LISP:COMPUTE-RESTARTS (&OPTIONAL (XCL:*CURRENT-CONDITION* XCL:*CURRENT-CONDITION*))
+                                                             (* \; "Edited 24-Feb-92 12:01 by jrb:")
+   (LET ((CONDITIONS::FOUND NIL))
+        (WALK-PROCEED-CASES *PROCEED-CASES* #'(LISP:LAMBDA (CONDITIONS:RESTART)
+                                                         (LISP:WHEN (LISP:CATCH 
+                                                                           'SI::SKIP-PROCEED-CASE
+                                                                           (TEST-PROCEED-CASE
+                                                                            CONDITIONS:RESTART))
+                                                                (LISP:PUSH CONDITIONS:RESTART 
+                                                                       CONDITIONS::FOUND))
+                                                         NIL))
+        (LISP:NREVERSE CONDITIONS::FOUND)))
+
+(LISP:DEFUN LISP:INVOKE-RESTART (CONDITIONS:RESTART &REST CONDITIONS::ARGUMENTS)
+   (LET ((CONDITIONS::R (LISP:FIND-RESTART CONDITIONS:RESTART)))
+        (LISP:IF (NULL CONDITIONS::R)
+            (LISP:ERROR 'XCL:BAD-PROCEED-CASE :NAME CONDITIONS:RESTART)
+            (SI::INVOKE-ACTUAL-RESTART CONDITIONS::R CONDITIONS::ARGUMENTS))))
+
+(LISP:DEFUN CONDITIONS:INVOKE-RESTART-INTERACTIVELY (CONDITIONS:RESTART)
+   (LET ((CONDITIONS::R (LISP:FIND-RESTART CONDITIONS:RESTART)))
+        (LISP:IF (NULL CONDITIONS::R)
+            (LISP:ERROR 'XCL:BAD-PROCEED-CASE :NAME CONDITIONS:RESTART)
+            (LET ((CONDITIONS::I-FN (CONDITIONS::RESTART-INTERACTIVE-FN CONDITIONS:RESTART)))
+                 (SI::INVOKE-ACTUAL-RESTART CONDITIONS::R (LISP:IF CONDITIONS::I-FN (LISP:FUNCALL
+                                                                                         
+                                                                                     CONDITIONS::I-FN
+                                                                                         )))))))
+
+(PUTPROPS ERROR-RUNTIME FILETYPE LISP:COMPILE-FILE)
+(PUTPROPS ERROR-RUNTIME COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 1993))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/CLTL2/ERROR-RUNTIME-AFTER-FASL b/CLTL2/ERROR-RUNTIME-AFTER-FASL
new file mode 100644
index 00000000..f110bbce
--- /dev/null
+++ b/CLTL2/ERROR-RUNTIME-AFTER-FASL
@@ -0,0 +1,43 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+(FILECREATED "28-Feb-92 11:55:34" 
+|{DSK}<usr>local>lde>lispcore>sources>ERROR-RUNTIME-AFTER-FASL.;2| 2101   
+
+      |changes| |to:|  (FUNCTIONS CONDITIONS:CONTINUE CONDITIONS:MUFFLE-WARNING USE-VALUE STORE-VALUE)
+
+      |previous| |date:| "16-May-90 16:26:16" 
+|{DSK}<usr>local>lde>lispcore>sources>ERROR-RUNTIME-AFTER-FASL.;1|)
+
+
+; Copyright (c) 1987, 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT ERROR-RUNTIME-AFTER-FASLCOMS)
+
+(RPAQQ ERROR-RUNTIME-AFTER-FASLCOMS ((PROP FILETYPE ERROR-RUNTIME-AFTER-FASL) (* |;;;| "These functions must be PavCompiled.") (FUNCTIONS SI::CREATE-CONDITION-CASE-LITERALS) (* |;;;| "These don't need to be, but depend on the previous stuff.") (FUNCTIONS ABORT CONDITIONS:CONTINUE CONDITIONS:MUFFLE-WARNING USE-VALUE STORE-VALUE)))
+
+(PUTPROPS ERROR-RUNTIME-AFTER-FASL FILETYPE :COMPILE-FILE)
+
+
+
+(* |;;;| "These functions must be PavCompiled.")
+
+
+(CL:DEFUN SI::CREATE-CONDITION-CASE-LITERALS (SI::TYPE-LIST) (LET ((SI::CATCH-TAG (LIST NIL))) (* \; "use a separate CONS for the catch tag so that you don't get a circular structure (you could save one by making the tag be the handler binding itself, then smashing its CDR with the closure).") (LIST* SI::CATCH-TAG SI::TYPE-LIST (CL:FUNCTION (CL:LAMBDA (SI::CONDITION) (CL:THROW SI::CATCH-TAG SI::CONDITION))))))
+
+
+
+(* |;;;| "These don't need to be, but depend on the previous stuff.")
+
+
+(DEFINE-PROCEED-FUNCTION ABORT :REPORT "Abort" (CONDITION XCL:*CURRENT-CONDITION*))
+
+(DEFINE-PROCEED-FUNCTION CONDITIONS:CONTINUE (CONDITION XCL:*CURRENT-CONDITION*))
+
+(DEFINE-PROCEED-FUNCTION CONDITIONS:MUFFLE-WARNING (CONDITION XCL:*CURRENT-CONDITION*))
+
+(DEFINE-PROCEED-FUNCTION USE-VALUE :REPORT "Use a different value" XCL::VALUE (CONDITION XCL:*CURRENT-CONDITION*))
+
+(DEFINE-PROCEED-FUNCTION STORE-VALUE :REPORT "Store a new value and use it" XCL::VALUE (CONDITION XCL:*CURRENT-CONDITION*))
+(PUTPROPS ERROR-RUNTIME-AFTER-FASL COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 1992))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/CLTL2/ERROR-RUNTIME-AFTER-FASL.DFASL b/CLTL2/ERROR-RUNTIME-AFTER-FASL.DFASL
new file mode 100644
index 00000000..11768d6e
Binary files /dev/null and b/CLTL2/ERROR-RUNTIME-AFTER-FASL.DFASL differ
diff --git a/CLTL2/ERROR-RUNTIME.LCOM b/CLTL2/ERROR-RUNTIME.LCOM
new file mode 100644
index 00000000..cbfc594e
Binary files /dev/null and b/CLTL2/ERROR-RUNTIME.LCOM differ
diff --git a/CLTL2/FASDUMP b/CLTL2/FASDUMP
new file mode 100644
index 00000000..0cfc9a82
--- /dev/null
+++ b/CLTL2/FASDUMP
@@ -0,0 +1,561 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "FASL")
+(IL:FILECREATED "18-Oct-93 15:40:08" "{Pele:mv:envos}<LispCore>Sources>CLTL2>FASDUMP.;2" 25524  
+
+      IL:|previous| IL:|date:| " 3-Sep-91 17:55:43" 
+"{Pele:mv:envos}<LispCore>Sources>CLTL2>FASDUMP.;1")
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:FASDUMPCOMS)
+
+(IL:RPAQQ IL:FASDUMPCOMS
+          (
+
+(IL:* IL:|;;;| "FASL Dumper.")
+
+           (IL:DECLARE\: IL:EVAL@COMPILE IL:EVAL@LOAD IL:DONTCOPY (IL:FILES (IL:LOADCOMP)
+                                                                         IL:FASLOAD))
+           (IL:STRUCTURES HANDLE)
+           (IL:VARIABLES DUMMY-HANDLE)
+           (IL:VARIABLES +SMALLEST-FOUR-BYTE-INTEGER+ +LARGEST-FOUR-BYTE-INTEGER+)
+           (IL:VARIABLES *GATHER-DUMPER-STATS* *TABLE-ATTEMPTS* *TABLE-HITS*)
+           (IL:FUNCTIONS RESET-DUMPER-STATS)
+           (IL:FUNCTIONS DOTTED-LIST-LENGTH STATE-CASE FAT-STRING-P REMEMBER ELEMENTS-IDENTICAL-P 
+                  END-BLOCK END-TEXT WRITE-OP LOOKUP-VALUE SAVE-VALUE)
+           (IL:FUNCTIONS DUMP-VALUE-FETCH DUMP-CHARACTER DUMP-SYMBOL DUMP-LIST DUMP-SIMPLE-VECTOR 
+                  DUMP-ARRAY-DESCRIPTOR DUMP-BIT-ARRAY DUMP-GENERAL-ARRAY DUMP-ARRAY 
+                  WRITE-INTEGER-BYTES INTEGER-BYTE-LIST DUMP-RATIONAL DUMP-COMPLEX DUMP-INTEGER 
+                  DUMP-PACKAGE DUMP-DCODE DUMP-STRING DUMP-FLOAT32 DUMP-STRUCTURE DUMP-BITMAP)
+           (IL:FUNCTIONS OPEN-FASL-HANDLE WITH-OPEN-HANDLE BEGIN-TEXT BEGIN-BLOCK VALUE-DUMPABLE-P 
+                  DUMP-VALUE DUMP-FUNCTION-DEF DUMP-FUNCALL DUMP-EVAL CLOSE-FASL-HANDLE)
+           
+           (IL:* IL:|;;| "Arrange for the correct compiler and makefile environment")
+
+           (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                  IL:FASDUMP)))
+
+
+
+(IL:* IL:|;;;| "FASL Dumper.")
+
+(IL:DECLARE\: IL:EVAL@COMPILE IL:EVAL@LOAD IL:DONTCOPY 
+
+(IL:FILESLOAD (IL:LOADCOMP)
+       IL:FASLOAD)
+)
+
+(DEFSTRUCT (HANDLE (:CONSTRUCTOR MAKE-HANDLE))
+   STREAM
+   (STATE :BLOCK-END)
+   (LAST-INDEX 0)
+   (HASH (MAKE-HASH-TABLE :TEST #'EQ)))
+
+(DEFCONSTANT DUMMY-HANDLE (MAKE-HANDLE :STREAM (OPEN "{null}" :DIRECTION :OUTPUT)
+                                     :STATE :BLOCK :HASH NIL))
+
+(DEFCONSTANT +SMALLEST-FOUR-BYTE-INTEGER+ (- (EXPT 2 31)))
+
+(DEFCONSTANT +LARGEST-FOUR-BYTE-INTEGER+ (1- (EXPT 2 31)))
+
+(DEFVAR *GATHER-DUMPER-STATS* NIL)
+
+(DEFVAR *TABLE-ATTEMPTS* 0
+   "Number of table lookups by the FASL dumper.")
+
+(DEFVAR *TABLE-HITS* 0
+   "Number of successful table lookups by the FASL dumper.")
+
+(DEFUN RESET-DUMPER-STATS NIL
+   (SETQ *TABLE-ATTEMPTS* 0 *TABLE-HITS* 0))
+
+(DEFUN DOTTED-LIST-LENGTH (X)
+   (DO ((N 0 (+ N 2))
+        (FAST X (CDDR FAST))
+        (SLOW X (CDR SLOW)))
+       (NIL)
+     (COND
+        ((NULL FAST)
+         (RETURN N))
+        ((ATOM FAST)
+         (RETURN (VALUES N T)))
+        ((NULL (CDR FAST))
+         (RETURN (1+ N)))
+        ((ATOM (CDR FAST))
+         (RETURN (VALUES (1+ N)
+                        T)))
+        ((AND (EQ FAST SLOW)
+              (> N 0))
+         (RETURN NIL)))))
+
+(DEFMACRO STATE-CASE (&REST CLAUSES)
+   `(ECASE (HANDLE-STATE HANDLE)
+        (IL:\\\,@ CLAUSES)))
+
+(DEFUN FAT-STRING-P (STRING)
+   (COND
+      ((IL:STRINGP STRING)
+       (EQ (IL:FETCH (IL:STRINGP IL:TYP) IL:OF STRING)
+           IL:\\ST.POS16))
+      (T (IL:%FAT-STRING-ARRAY-P STRING))))
+
+(DEFMACRO REMEMBER (VALUE &BODY BODY)
+   `(LET (($REMEMBER-VAL$ ,VALUE))
+         (WHEN REMEMBER
+             (WRITE-OP HANDLE 'FASL-TABLE-STORE))
+         ,@BODY
+         (WHEN REMEMBER (SAVE-VALUE HANDLE $REMEMBER-VAL$))))
+
+(DEFUN ELEMENTS-IDENTICAL-P (ARRAY)
+   (LET* ((SEQ (IL:%FLATTEN-ARRAY ARRAY))
+          (TESTELT (AREF SEQ 0)))
+         (EVERY #'(LAMBDA (X)
+                         (EQL X TESTELT))
+                SEQ)))
+
+(DEFUN END-BLOCK (HANDLE)
+   (STATE-CASE (:BLOCK (WHEN CHECK-TABLE-SIZE
+                               (WRITE-OP HANDLE 'FASL-VERIFY-TABLE-SIZE)
+                               (DUMP-VALUE HANDLE (HANDLE-LAST-INDEX HANDLE)
+                                      NIL))
+                          (IL:BOUT (HANDLE-STREAM HANDLE)
+                                 END-MARK)
+                          (SETF (HANDLE-LAST-INDEX HANDLE)
+                                0)
+                          (SETF (HANDLE-HASH HANDLE)
+                                (MAKE-HASH-TABLE :TEST #'EQ))
+                          (SETF (HANDLE-STATE HANDLE)
+                                :BLOCK-END))))
+
+(DEFUN END-TEXT (HANDLE)
+   (STATE-CASE (:TEXT (IL:BOUT (HANDLE-STREAM HANDLE)
+                                 END-MARK)
+                          (SETF (HANDLE-STATE HANDLE)
+                                :BLOCK))))
+
+(DEFUN WRITE-OP (HANDLE OPNAME)
+   (STATE-CASE (:BLOCK (LET ((STREAM (HANDLE-STREAM HANDLE))
+                                 (OPSEQ (OPCODE-SEQUENCE OPNAME)))
+                                (IF (NULL OPSEQ)
+                                    (ERROR 'UNIMPLEMENTED-OPCODE :OPNAME OPNAME)
+                                    (DOLIST (OP OPSEQ)
+                                        (IL:BOUT STREAM OP)))))))
+
+(DEFUN LOOKUP-VALUE (HANDLE VALUE)
+   (LET ((HASH-TABLE (HANDLE-HASH HANDLE)))
+        (AND HASH-TABLE (IL:GETHASH VALUE HASH-TABLE))))
+
+(DEFUN SAVE-VALUE (HANDLE VALUE)
+   (LET ((HASH-TABLE (HANDLE-HASH HANDLE)))
+        (UNLESS (NULL HASH-TABLE)
+            (SETF (IL:GETHASH VALUE HASH-TABLE)
+                  (HANDLE-LAST-INDEX HANDLE))
+            (INCF (HANDLE-LAST-INDEX HANDLE)))))
+
+(DEFUN DUMP-VALUE-FETCH (HANDLE INDEX)
+   (WRITE-OP HANDLE 'FASL-TABLE-FETCH)
+   (DUMP-VALUE HANDLE INDEX NIL))
+
+(DEFUN DUMP-CHARACTER (HANDLE CHAR REMEMBER)
+   (DECLARE (IGNORE REMEMBER))
+
+   (IL:* IL:|;;| "Characters don't get remembered.")
+
+   (LET ((CODE (CHAR-CODE CHAR))
+         (STREAM (HANDLE-STREAM HANDLE)))
+        (WRITE-OP HANDLE 'FASL-CHARACTER)
+        (IF (< CODE 256)
+            (IL:BOUT STREAM CODE)
+            (PROGN (IL:BOUT STREAM 255)
+                   (IL:BOUT16 STREAM CODE)))))
+
+(DEFUN DUMP-SYMBOL (HANDLE SYMBOL REMEMBER)
+
+   (IL:* IL:|;;| 
+ "No point in remembering the pname because SYMBOL-NAME always gives you a new one.")
+
+   (LET* ((PNAME (SYMBOL-NAME SYMBOL))
+          (PACKAGE (SYMBOL-PACKAGE SYMBOL))
+          (PKG-NAME (AND PACKAGE (PACKAGE-NAME PACKAGE))))
+         (REMEMBER SYMBOL (COND
+                                 ((KEYWORDP SYMBOL)
+                                  (WRITE-OP HANDLE 'FASL-KEYWORD-SYMBOL)
+                                  (DUMP-VALUE HANDLE PNAME NIL))
+                                 ((EQUAL PKG-NAME "LISP")
+                                  (WRITE-OP HANDLE 'FASL-LISP-SYMBOL)
+                                  (DUMP-VALUE HANDLE PNAME NIL))
+                                 ((EQUAL PKG-NAME "INTERLISP")
+                                  (WRITE-OP HANDLE 'FASL-INTERLISP-SYMBOL)
+                                  (DUMP-VALUE HANDLE PNAME NIL))
+                                 (T (WRITE-OP HANDLE 'FASL-SYMBOL-IN-PACKAGE)
+                                    (DUMP-VALUE HANDLE PNAME NIL)
+                                    (DUMP-VALUE HANDLE PACKAGE REMEMBER))))))
+
+(DEFUN DUMP-LIST (HANDLE LIST REMEMBER)
+   (MULTIPLE-VALUE-BIND (LENGTH DOTTED)
+          (DOTTED-LIST-LENGTH LIST)
+          (UNLESS LENGTH
+              (ERROR 'OBJECT-NOT-DUMPABLE :OBJECT LIST))
+          (REMEMBER LIST (WRITE-OP HANDLE (IF DOTTED
+                                                      'FASL-LIST*
+                                                      'FASL-LIST))
+                 (DUMP-VALUE HANDLE (IF DOTTED
+                                            (1+ LENGTH)
+                                            LENGTH)
+                        NIL)
+                 (DOTIMES (I LENGTH)
+                     (DUMP-VALUE HANDLE (CAR LIST))
+                     (POP LIST))
+                 (WHEN DOTTED (DUMP-VALUE HANDLE LIST NIL)))))
+
+(DEFUN DUMP-SIMPLE-VECTOR (HANDLE VECTOR REMEMBER)
+   (LET ((LENGTH (LENGTH VECTOR)))
+        (REMEMBER VECTOR (WRITE-OP HANDLE 'FASL-VECTOR)
+               (DUMP-VALUE HANDLE LENGTH REMEMBER)
+               (DOTIMES (I LENGTH)
+                   (DUMP-VALUE HANDLE (SVREF VECTOR I)
+                          REMEMBER)))))
+
+(DEFUN DUMP-ARRAY-DESCRIPTOR (HANDLE ARRAY REMEMBER &KEY (INITIAL-ELEMENT NIL USE-SINGLE-ELT))
+   (REMEMBER ARRAY (WRITE-OP HANDLE 'FASL-CREATE-ARRAY)
+          (DUMP-VALUE HANDLE (IF (EQL (ARRAY-RANK ARRAY)
+                                          1)
+                                     (CAR (ARRAY-DIMENSIONS ARRAY))
+                                     (ARRAY-DIMENSIONS ARRAY))
+                 REMEMBER)
+          (DUMP-VALUE HANDLE `(:ELEMENT-TYPE ,(ARRAY-ELEMENT-TYPE ARRAY)
+                                         :ADJUSTABLE
+                                         ,(ADJUSTABLE-ARRAY-P ARRAY)
+                                         ,@(WHEN (ARRAY-HAS-FILL-POINTER-P ARRAY)
+                                               `(:FILL-POINTER ,(FILL-POINTER ARRAY)))
+                                         ,@(WHEN USE-SINGLE-ELT
+                                               `(:INITIAL-ELEMENT ,INITIAL-ELEMENT)))
+                 REMEMBER)))
+
+(DEFUN DUMP-BIT-ARRAY (HANDLE ARRAY REMEMBER)
+   (LET ((NBITS (ARRAY-TOTAL-SIZE ARRAY)))
+        (UNLESS (ZEROP (IL:%ARRAY-OFFSET ARRAY))
+            (ERROR 'OBJECT-NOT-DUMPABLE :OBJECT ARRAY))
+        (REMEMBER ARRAY (WRITE-OP HANDLE 'FASL-INITIALIZE-BIT-ARRAY)
+               (DUMP-ARRAY-DESCRIPTOR HANDLE ARRAY REMEMBER)
+               (DUMP-VALUE HANDLE NBITS REMEMBER)
+               (IL:\\BOUTS (HANDLE-STREAM HANDLE)
+                      (IL:%ARRAY-BASE ARRAY)
+                      0
+                      (CEILING NBITS 8)))))
+
+(DEFUN DUMP-GENERAL-ARRAY (HANDLE ARRAY REMEMBER)
+
+   (IL:* IL:|;;| "Arrays don't get remembered. Displacement information is lost.")
+
+   (LET* ((NELTS (ARRAY-TOTAL-SIZE ARRAY))
+          (ELT-TYPE (ARRAY-ELEMENT-TYPE ARRAY)))
+         (WRITE-OP HANDLE 'FASL-INITIALIZE-ARRAY)
+         (DUMP-ARRAY-DESCRIPTOR HANDLE ARRAY NIL)
+         (DUMP-VALUE HANDLE NELTS NIL)
+         (LET ((INDIRECT (MAKE-ARRAY NELTS :DISPLACED-TO ARRAY :ELEMENT-TYPE ELT-TYPE)))
+              (DOTIMES (I NELTS)
+                  (DUMP-VALUE HANDLE (AREF INDIRECT I)
+                         NIL)))))
+
+(DEFUN DUMP-ARRAY (HANDLE ARRAY REMEMBER)
+   (COND
+      ((XCL:DISPLACED-ARRAY-P ARRAY)
+       (ERROR 'OBJECT-NOT-DUMPABLE :OBJECT ARRAY))
+      ((ADJUSTABLE-ARRAY-P ARRAY)
+       (DUMP-GENERAL-ARRAY HANDLE ARRAY REMEMBER))
+      ((TYPEP ARRAY '(ARRAY BIT))
+       (DUMP-BIT-ARRAY HANDLE ARRAY REMEMBER))
+      ((TYPEP ARRAY 'VECTOR)
+       (DUMP-SIMPLE-VECTOR HANDLE ARRAY REMEMBER))
+      (T (DUMP-GENERAL-ARRAY HANDLE ARRAY REMEMBER))))
+
+(DEFUN WRITE-INTEGER-BYTES (HANDLE NBYTES VALUE)
+   (LET ((STREAM (HANDLE-STREAM HANDLE)))
+        (DOLIST (BYTE (INTEGER-BYTE-LIST VALUE NBYTES))
+            (IL:BOUT STREAM BYTE))))
+
+(DEFUN INTEGER-BYTE-LIST (VALUE NBYTES)
+   (DO ((COUNT 0 (1+ COUNT))
+        (RESULT NIL)
+        (N VALUE)
+        BYTE)
+       ((>= COUNT NBYTES)
+        RESULT)
+     (MULTIPLE-VALUE-SETQ (N BYTE)
+            (FLOOR N 256))
+     (PUSH BYTE RESULT)))
+
+(DEFUN DUMP-RATIONAL (HANDLE VALUE REMEMBER)
+   (DECLARE (IGNORE REMEMBER))
+   (WRITE-OP HANDLE 'FASL-RATIO)
+   (DUMP-VALUE HANDLE (NUMERATOR VALUE)
+          NIL)
+   (DUMP-VALUE HANDLE (DENOMINATOR VALUE)
+          NIL))
+
+(DEFUN DUMP-COMPLEX (HANDLE VALUE REMEMBER)
+   (DECLARE (IGNORE REMEMBER))
+   (WRITE-OP HANDLE 'FASL-COMPLEX)
+   (DUMP-VALUE HANDLE (REALPART VALUE)
+          NIL)
+   (DUMP-VALUE HANDLE (IMAGPART VALUE)
+          NIL))
+
+(DEFUN DUMP-INTEGER (HANDLE VALUE REMEMBER)
+   (DECLARE (IGNORE REMEMBER))
+   (COND
+      ((AND (<= 0 VALUE)
+            (< VALUE 128))
+       (IL:BOUT (HANDLE-STREAM HANDLE)
+              VALUE))
+      ((AND (<= +SMALLEST-FOUR-BYTE-INTEGER+ VALUE +LARGEST-FOUR-BYTE-INTEGER+))
+       (WRITE-OP HANDLE 'FASL-INTEGER)
+       (WRITE-INTEGER-BYTES HANDLE 4 VALUE))
+      (T (WRITE-OP HANDLE 'FASL-LARGE-INTEGER)
+         (LET* ((MINBITS (1+ (INTEGER-LENGTH VALUE)))
+                (NBYTES (CEILING MINBITS 8)))
+
+               (IL:* IL:|;;| "According to the book, MINBITS gives the minimum field width for this number in 2's complement representation.")
+
+               (DUMP-VALUE HANDLE NBYTES NIL)
+               (WRITE-INTEGER-BYTES HANDLE NBYTES VALUE)))))
+
+(DEFUN DUMP-PACKAGE (HANDLE PACKAGE REMEMBER)
+   (REMEMBER PACKAGE (WRITE-OP HANDLE 'FASL-FIND-PACKAGE)
+          (DUMP-VALUE HANDLE (PACKAGE-NAME PACKAGE)
+                 REMEMBER)))
+
+(DEFUN DUMP-DCODE (HANDLE DCODE REMEMBER)
+   (LET ((STREAM (HANDLE-STREAM HANDLE)))
+        (MACROLET ((DUMP-SEQ (SEQ DUMP-LENGTH &REST STUFF)
+                          `(LET ((SEQ ,SEQ))
+                                ,@(AND DUMP-LENGTH '((DUMP-VALUE HANDLE (LENGTH SEQ)
+                                                            REMEMBER)))
+                                (IF (LISTP SEQ)
+                                    (DOLIST (ELT SEQ)
+                                        ,@STUFF)
+                                    (DOTIMES (INDEX (LENGTH SEQ))
+                                        (LET ((ELT (AREF SEQ INDEX)))
+                                             ,@STUFF))))))
+
+               (IL:* IL:|;;| 
+             "If group fixups are necessary, wrap the whole thing in a FASL-LOCAL-FN-FIXUPS.")
+
+               (UNLESS (NULL (D-ASSEM::DCODE-LOCAL-FN-FIXUPS DCODE))
+                   (WRITE-OP HANDLE 'FASL-LOCAL-FN-FIXUPS))
+               (REMEMBER DCODE                           (IL:* IL:\; 
+                         "So that it turns up as a value fetch in the local function fixups below.")
+                      (WRITE-OP HANDLE 'FASL-DCODE)
+                      (DUMP-VALUE HANDLE (LENGTH (D-ASSEM::DCODE-NAME-TABLE DCODE))
+                             REMEMBER)
+                      (LET* ((CODE-ARRAY (D-ASSEM::DCODE-CODE-ARRAY DCODE))
+                             (NBYTES (LENGTH CODE-ARRAY)))
+                            (DUMP-VALUE HANDLE NBYTES REMEMBER)
+                            (DOTIMES (I NBYTES)
+                                (IL:BOUT STREAM (AREF CODE-ARRAY I))))
+                      (DUMP-SEQ (D-ASSEM::DCODE-NAME-TABLE DCODE)
+                             NIL
+                             (IL:BOUT STREAM (FIRST ELT))
+                             (DUMP-VALUE HANDLE (SECOND ELT)
+                                    REMEMBER)
+                             (DUMP-VALUE HANDLE (THIRD ELT)
+                                    REMEMBER))
+                      (DUMP-VALUE HANDLE (D-ASSEM::DCODE-FRAME-NAME DCODE)
+                             REMEMBER)
+                      (IL:BOUT STREAM (D-ASSEM::DCODE-NLOCALS DCODE))
+                      (IL:BOUT STREAM (D-ASSEM::DCODE-NFREEVARS DCODE))
+                      (IL:BOUT STREAM (D-ASSEM::DCODE-ARG-TYPE DCODE))
+                      (DUMP-VALUE HANDLE (D-ASSEM::DCODE-NUM-ARGS DCODE)
+                             REMEMBER)
+                      (DUMP-VALUE HANDLE (D-ASSEM::DCODE-CLOSURE-P DCODE)
+                             REMEMBER)
+                      (DUMP-VALUE HANDLE (D-ASSEM::DCODE-DEBUGGING-INFO DCODE)
+                             REMEMBER)
+                      (MACROLET ((DUMP-FIXUPS (LIST)
+                                        `(DUMP-SEQ ,LIST T (DUMP-VALUE HANDLE (FIRST ELT))
+                                                (DUMP-VALUE HANDLE (SECOND ELT)))))
+                             (DUMP-FIXUPS (D-ASSEM::DCODE-FN-FIXUPS DCODE))
+                             (DUMP-FIXUPS (D-ASSEM::DCODE-SYM-FIXUPS DCODE))
+                             (DUMP-FIXUPS (D-ASSEM::DCODE-LIT-FIXUPS DCODE))
+                             (DUMP-FIXUPS (D-ASSEM::DCODE-TYPE-FIXUPS DCODE))))
+
+               (IL:* IL:|;;| "Now do the actual group fixups if needed.")
+
+               (UNLESS (NULL (D-ASSEM::DCODE-LOCAL-FN-FIXUPS DCODE))
+                   (DUMP-SEQ (D-ASSEM::DCODE-LOCAL-FN-FIXUPS DCODE D-ASSEM:DCODE)
+                          T
+                          (DUMP-VALUE HANDLE (FIRST ELT))
+                          (DUMP-VALUE HANDLE (SECOND ELT))
+                          (DUMP-VALUE HANDLE (THIRD ELT)))))
+        NIL))
+
+(DEFUN DUMP-STRING (HANDLE STRING REMEMBER)
+   (REMEMBER STRING (LET ((STREAM (HANDLE-STREAM HANDLE))
+                              (NCHARS (LENGTH STRING)))
+                             (COND
+                                ((FAT-STRING-P STRING)
+                                 (WRITE-OP HANDLE 'FASL-FAT-STRING)
+                                 (DUMP-VALUE HANDLE NCHARS REMEMBER)
+                                 (DO ((I 0 (1+ I))
+                                      (CSET 0))
+                                     ((>= I NCHARS))         (IL:* IL:\; "Always run-encode")
+                                   (LET* ((CHAR (CHAR-CODE (CHAR STRING I)))
+                                          (NEW-CSET (IL:LRSH CHAR 8)))
+                                         (UNLESS (EQL NEW-CSET CSET)
+                                             (SETQ CSET NEW-CSET)
+                                             (IL:BOUT STREAM 255)
+                                             (IL:BOUT STREAM CSET))
+                                         (IL:BOUT STREAM (LOGAND CHAR 255)))))
+                                (T (WRITE-OP HANDLE 'FASL-THIN-STRING)
+                                   (DUMP-VALUE HANDLE NCHARS REMEMBER)
+
+                                   (IL:* IL:|;;| "should use \\bouts")
+
+                                   (DOTIMES (I NCHARS)
+                                       (IL:BOUT STREAM (CHAR-CODE (CHAR STRING I)))))))))
+
+(DEFUN DUMP-FLOAT32 (HANDLE NUMBER REMEMBER)             (IL:* IL:\; 
+                                                           "Floats don't get remembered")
+   (WRITE-OP HANDLE 'FASL-FLOAT32)
+   (IL:\\BOUTS (HANDLE-STREAM HANDLE)
+          NUMBER 0 4))
+
+(DEFUN DUMP-STRUCTURE (HANDLE VALUE REMEMBER)
+   (LET ((TYPE (IL:TYPENAME VALUE)))
+        (REMEMBER VALUE (WRITE-OP HANDLE 'FASL-STRUCTURE)
+               (DUMP-VALUE HANDLE TYPE T)
+               (DUMP-VALUE HANDLE (IL:FOR FIELD IL:IN (LISP::STRUCTURE-SLOT-NAMES TYPE T)
+                                         IL:AS DESCRIPTOR IL:IN (IL:GETDESCRIPTORS TYPE)
+                                         IL:JOIN (LIST FIELD (IL:FETCHFIELD DESCRIPTOR VALUE)))
+                      T))))
+
+(DEFUN DUMP-BITMAP (HANDLE VALUE REMEMBER)
+   (LET ((WIDTH (IL:BITMAPWIDTH VALUE))
+         (HEIGHT (IL:BITMAPHEIGHT VALUE))
+         (BITS-PER-PIXEL (IL:BITSPERPIXEL VALUE))
+         (BASE (IL:FETCH (IL:BITMAP IL:BITMAPBASE) IL:OF VALUE))
+         (STREAM (HANDLE-STREAM HANDLE)))
+        (REMEMBER VALUE                                  (IL:* IL:\; 
+                                                           "Remember the bitmap itself.")
+               (WRITE-OP HANDLE 'FASL-BITMAP16)
+               (DUMP-VALUE HANDLE WIDTH)
+               (DUMP-VALUE HANDLE HEIGHT)
+               (DUMP-VALUE HANDLE BITS-PER-PIXEL)
+               (IL:\\BOUTS STREAM BASE 0 (* 2 HEIGHT (CEILING (* WIDTH BITS-PER-PIXEL)
+                                                            16))))))
+
+(DEFUN OPEN-FASL-HANDLE (NAME &REST OPEN-OPTIONS)
+   (LET ((STREAM (APPLY #'OPEN NAME :DIRECTION :OUTPUT :ELEMENT-TYPE '(UNSIGNED-BYTE 8)
+                        :IF-EXISTS :NEW-VERSION OPEN-OPTIONS)))
+
+        (IL:* IL:|;;| "A newly opened stream has fileptr = 0..")
+
+        (IL:BOUT STREAM SIGNATURE)
+        (IL:BOUT16 STREAM CURRENT-VERSION)
+        (MAKE-HANDLE :STREAM STREAM)))
+
+(DEFMACRO WITH-OPEN-HANDLE ((HANDLE FILENAME &REST OPEN-OPTIONS)
+                                &BODY
+                                (BODY DECLS))
+   (LET ((ABORT (IL:GENSYM "FASL:WITH-OPEN-FASL-HANDLE")))
+        `(LET ((,HANDLE (OPEN-FASL-HANDLE ,FILENAME ,@OPEN-OPTIONS))
+               (,ABORT T))
+              ,@DECLS
+              (UNWIND-PROTECT
+                  (MULTIPLE-VALUE-PROG1 (PROGN ,@BODY)
+                         (SETQ ,ABORT NIL))
+                  (WHEN ,HANDLE
+                      (CLOSE-FASL-HANDLE ,HANDLE :ABORT ,ABORT))))))
+
+(DEFUN BEGIN-TEXT (HANDLE)
+   (STATE-CASE ((:TEXT :BLOCK-END))
+          (:BLOCK (END-BLOCK HANDLE)))
+   (SETF (HANDLE-STATE HANDLE)
+         :TEXT)
+   (HANDLE-STREAM HANDLE))
+
+(DEFUN BEGIN-BLOCK (HANDLE)
+   (STATE-CASE (:BLOCK-END (BEGIN-TEXT HANDLE)
+                          (END-TEXT HANDLE))
+          (:TEXT (END-TEXT HANDLE))
+          (:BLOCK)))
+
+(DEFUN VALUE-DUMPABLE-P (OBJ)
+   (XCL:CONDITION-CASE (PROGN (DUMP-VALUE DUMMY-HANDLE OBJ NIL)
+                              T)
+          (OBJECT-NOT-DUMPABLE NIL NIL)))
+
+(DEFUN DUMP-VALUE (HANDLE VALUE &OPTIONAL (REMEMBER T)
+                             &AUX INDEX)
+   (STATE-CASE (:BLOCK (COND
+                              ((EQ VALUE NIL)
+                               (WRITE-OP HANDLE 'FASL-NIL))
+                              ((EQ VALUE T)
+                               (WRITE-OP HANDLE 'FASL-T))
+                              ((PROG1 (SETQ INDEX (LOOKUP-VALUE HANDLE VALUE))
+                                   (WHEN *GATHER-DUMPER-STATS* (INCF *TABLE-ATTEMPTS*)))
+                               (WHEN *GATHER-DUMPER-STATS* (INCF *TABLE-HITS*))
+                               (DUMP-VALUE-FETCH HANDLE INDEX))
+                              (T (TYPECASE VALUE
+                                     (INTEGER (DUMP-INTEGER HANDLE VALUE REMEMBER))
+                                     (RATIONAL (DUMP-RATIONAL HANDLE VALUE REMEMBER))
+                                     (SINGLE-FLOAT (DUMP-FLOAT32 HANDLE VALUE REMEMBER))
+                                     (COMPLEX (DUMP-COMPLEX HANDLE VALUE REMEMBER))
+                                     (CHARACTER (DUMP-CHARACTER HANDLE VALUE REMEMBER))
+                                     (SYMBOL (DUMP-SYMBOL HANDLE VALUE REMEMBER))
+                                     (PACKAGE (DUMP-PACKAGE HANDLE VALUE REMEMBER))
+                                     (CONS (DUMP-LIST HANDLE VALUE REMEMBER))
+                                     (D-ASSEM:DCODE (DUMP-DCODE HANDLE VALUE REMEMBER))
+                                     (STRING (DUMP-STRING HANDLE VALUE REMEMBER))
+                                     (ARRAY (DUMP-ARRAY HANDLE VALUE REMEMBER))
+                                     (COMPILER::EVAL-WHEN-LOAD (LET ((REMEMBER T))
+                                                             (IL:* IL:\; "always remember these.")
+                                                                    (REMEMBER VALUE
+                                                                           (DUMP-EVAL
+                                                                            HANDLE
+                                                                            (
+                                                                        COMPILER::EVAL-WHEN-LOAD-FORM
+                                                                             VALUE)))))
+                                     (LISP::STRUCTURE-OBJECT (DUMP-STRUCTURE HANDLE VALUE 
+                                                                    REMEMBER))
+                                     (IL:BITMAP (DUMP-BITMAP HANDLE VALUE REMEMBER))
+                                     (OTHERWISE (ERROR 'OBJECT-NOT-DUMPABLE :OBJECT VALUE))))))))
+
+(DEFUN DUMP-FUNCTION-DEF (HANDLE DCODE NAME)
+   (STATE-CASE (:BLOCK (WRITE-OP HANDLE 'FASL-SETF-SYMBOL-FUNCTION)
+                          (DUMP-VALUE HANDLE NAME)
+                          (DUMP-VALUE HANDLE DCODE))))
+
+(DEFUN DUMP-FUNCALL (HANDLE FUNCTION)
+   (STATE-CASE (:BLOCK (WRITE-OP HANDLE 'FASL-FUNCALL)
+                          (DUMP-VALUE HANDLE FUNCTION))))
+
+(DEFUN DUMP-EVAL (HANDLE FORM)
+   (STATE-CASE (:BLOCK (WRITE-OP HANDLE 'FASL-EVAL)
+                          (DUMP-VALUE HANDLE FORM))))
+
+(DEFUN CLOSE-FASL-HANDLE (HANDLE &REST CLOSE-OPTIONS &KEY ABORT &ALLOW-OTHER-KEYS)
+   (STATE-CASE (:TEXT (END-TEXT HANDLE)
+                          (END-BLOCK HANDLE))
+          (:BLOCK (END-BLOCK HANDLE))
+          (:BLOCK-END))
+   (IL:BOUT (HANDLE-STREAM HANDLE)
+          END-OF-DATA-MARK)
+   (SETF (HANDLE-STATE HANDLE)
+         :CLOSED)
+   (APPLY #'CLOSE (HANDLE-STREAM HANDLE)
+          CLOSE-OPTIONS))
+
+
+
+(IL:* IL:|;;| "Arrange for the correct compiler and makefile environment")
+
+
+(IL:PUTPROPS IL:FASDUMP IL:FILETYPE :COMPILE-FILE)
+
+(IL:PUTPROPS IL:FASDUMP IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "FASL"))
+(IL:PUTPROPS IL:FASDUMP IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1993))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/FASDUMP.DFASL b/CLTL2/FASDUMP.DFASL
new file mode 100644
index 00000000..f4016b32
Binary files /dev/null and b/CLTL2/FASDUMP.DFASL differ
diff --git a/CLTL2/FILEIO b/CLTL2/FILEIO
new file mode 100644
index 00000000..53ff1f63
--- /dev/null
+++ b/CLTL2/FILEIO
@@ -0,0 +1,2024 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "12-Oct-93 17:36:33" "{Pele:mv:envos}<LispCore>Sources>CLTL2>FILEIO.;1" 133165 
+
+      changes to%:  (FNS \DO.PARAMS.AT.OPEN COPYFILE)
+                    (VARS FILEIOCOMS)
+                    (RECORDS STREAM FDEV EXTERNALFORMAT)
+
+      previous date%: " 3-Sep-91 15:30:45" {DSK}<mo>usr>users>sybalsky>cltl2>sources>FILEIO.;1)
+
+
+(* ; "
+Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT FILEIOCOMS)
+
+(RPAQQ FILEIOCOMS
+       [(PROP (FILETYPE MAKEFILE-ENVIRONMENT)
+              FILEIO)
+        
+        (* ;; "Device independent IO.  This file is used by VAX")
+
+        (COMS 
+              (* ;; "STREAM, FDEV declarations")
+
+              (DECLARE%: FIRST DOCOPY 
+
+                     (* ;; "The microcode relies on STREAM being of a particular type, viz.  the first type declared in the initial loadup (after VMEMPAGEP)")
+
+                     (INITRECORDS STREAM))
+              (SYSRECORDS STREAM)
+              (DECLARE%: DONTCOPY (EXPORT (RECORDS STREAM)
+                                         (MACROS STREAMOP)
+                                         (CONSTANTS AppendBit NoBits ReadBit WriteBit
+                                                (OutputBits (LOGOR AppendBit WriteBit))
+                                                (BothBits (LOGOR ReadBit OutputBits))
+                                                \NORUNCODE)
+                                         (MACROS TestMasked APPENDABLE APPENDONLY DIRTYABLE OPENED 
+                                                OVERWRITEABLE READABLE READONLY WRITEABLE)
+                                         (MACROS \RUNCODED)
+                                         (CONSTANTS * EOLCONVENTIONS)))
+              (FNS STREAMPROP GETSTREAMPROP PUTSTREAMPROP STREAMP)
+              [COMS                                          (* ; "make streams print pretty")
+                    (FNS \DEFPRINT.BY.NAME \STREAM.DEFPRINT \FDEV.DEFPRINT)
+                    (DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'STREAM (FUNCTION \STREAM.DEFPRINT))
+                                                       (DEFPRINT 'FDEV (FUNCTION \FDEV.DEFPRINT]
+              (COMS                                          (* ; 
+                                                          "Needed because of STREAM initialization")
+                    (INITVARS (FILELINELENGTH 102)
+                           (\STREAM.DEFAULT.MAXBUFFERS 3)))
+              (FNS \GETACCESS \SETACCESS)
+              (DECLARE%: DONTCOPY (EXPORT (MACROS FDEVOP \RECOGNIZE-HACK)
+                                         (RECORDS FDEV FILEGENOBJ)))
+              (INITRECORDS FDEV)
+              (SYSRECORDS FDEV))
+        [COMS                                                (* ; 
+                                                 "EXTERNALFORMAT declaration and related functions")
+              (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (RECORDS EXTERNALFORMAT)))
+              (INITRECORDS EXTERNALFORMAT)
+              (SYSRECORDS EXTERNALFORMAT)
+              (FNS \INSTALL.EXTERNALFORMAT \REMOVE.EXTERNALFORMAT \GET.EXTERNALFORMAT.FROM.NAME 
+                   \EXTERNALFORMAT)
+              (INITVARS (*SUPPORTED-EXTERNALFORMATS* '(:XCCS :DEFAULT))
+                     (*EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*))
+              (GLOBALVARS *SUPPORTED-EXTERNALFORMATS* *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*)
+              (FNS \CREATE.JIS.EXTERNALFORMAT \CREATE.SHIFTJIS.EXTERNALFORMAT 
+                   \CREATE.EUC.EXTERNALFORMAT \CREATE.THROUGH.EXTERNALFORMAT)
+              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.JIS.EXTERNALFORMAT)
+                                                 (\CREATE.SHIFTJIS.EXTERNALFORMAT)
+                                                 (\CREATE.EUC.EXTERNALFORMAT)
+                                                 (\CREATE.THROUGH.EXTERNALFORMAT]
+        (COMS                                                (* ; "Device operations")
+              (FNS \DEFINEDEVICE \GETDEVICEFROMNAME \GETDEVICEFROMHOSTNAME \REMOVEDEVICE 
+                   \REMOVEDEVICE.NAMES)
+              (FNS \CLOSEFILE \DELETEFILE \DEVICEEVENT \GENERATEFILES \GENERATENEXTFILE 
+                   \GENERATEFILEINFO \GETFILENAME \GENERIC.READCCODE \GENERIC.OUTFILEP \OPENFILE 
+                   \DO.PARAMS.AT.OPEN \RENAMEFILE \REVALIDATEFILE \PAGED.REVALIDATEFILELST 
+                   \PAGED.REVALIDATEFILES \PAGED.REVALIDATEFILE \BUFFERED.REVALIDATEFILE 
+                   \BUFFERED.REVALIDATEFILELST \PRINT-REVALIDATION-RESULT \TRUNCATEFILE 
+                   \FILE-CONFLICT)
+              (COMS                                          (* ; "Generic enumerator")
+                    (FNS \GENERATENOFILES \NULLFILEGENERATOR \NOFILESNEXTFILEFN \NOFILESINFOFN)
+                    (DECLARE%: DONTCOPY (RECORDS NOFILEGENSTATE)))
+              (FNS \FILE.NOT.OPEN \FILE.WONT.OPEN \ILLEGAL.DEVICEOP \IS.NOT.RANDACCESSP 
+                   \STREAM.NOT.OPEN)
+              (ADDVARS (\FILEDEVICES)
+                     (\FILEDEVICENAMES)
+                     (\DEVICENAMETODEVICE))
+              (COMS                                          (* ; "Device instances")
+                    (FNS \FDEVINSTANCE)
+                    (MACROS \INHERITFDEVOP.D \INHERITFDEVOP.S))
+              (INITVARS (LOGINHOST/DIR '{DSK})
+                     (\CONNECTED.DIRECTORY '{DSK}))
+              (GLOBALVARS LOGINHOST/DIR \CONNECTED.DIRECTORY \FILEDEVICES \FILEDEVICENAMES 
+                     \DEVICENAMETODEVICE))
+        (COMS                                                (* ; "Directory defaulting")
+              (FNS CNDIR DIRECTORYNAME DIRECTORYNAMEP HOSTNAMEP \ADD.CONNECTED.DIR))
+        [COMS                                                (* ; "Binary I/O Public functions")
+              (FNS \BACKFILEPTR \BACKPEEKBIN \BACKBIN BIN \BIN \BINS BOUT \BOUT \BOUTS COPYBYTES 
+                   COPYCHARS COPYFILE \COPYOPENFILE \INFER.FILE.TYPE EOFP FORCEOUTPUT 
+                   \FLUSH.OPEN.STREAMS CHARSET ACCESS-CHARSET GETEOFPTR GETFILEINFO 
+                   \TYPE.FROM.FILETYPE \FILETYPE.FROM.TYPE GETFILEPTR SETFILEINFO SETFILEPTR BOUT16 
+                   BIN16)
+              (PROP (DOPCODE)
+                    BOUT)
+                                                             (* ; "Generic functions")
+              (FNS \GENERIC.BINS \GENERIC.BOUTS \GENERIC.RENAMEFILE \GENERIC.OPENP \GENERIC.READP 
+                   \GENERIC.CHARSET)
+              (FNS \MAP-OPEN-STREAMS)
+              (VARS FILING.TYPES)
+              (GLOBALVARS FILING.TYPES)
+              (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS \OUTCHAR \DEVICE-OPEN-STREAMS 
+                                                              \CONVERT-PATHNAME)
+                                                      (OPTIMIZERS ACCESS-CHARSET)))
+              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAPC '((FORCEOUTPUT FLUSHOUTPUT)
+                                                         (FORCEOUTPUT FLUSHMAP)
+                                                         (\GENERIC.BINS \NONPAGEDBINS)
+                                                         (\GENERIC.BOUTS \NONPAGEDBOUTS))
+                                                       (FUNCTION (LAMBDA (PAIR)
+                                                                        (PUTD (CADR PAIR)
+                                                                              (GETD (CAR PAIR))
+                                                                              T]
+        (COMS                                                (* ; "Internal functions")
+              (FNS \EOF.ACTION \EOSERROR \GETEOFPTR \INCFILEPTR \PEEKBIN \SETCLOSEDFILELENGTH 
+                   \SETEOFPTR \SETFILEPTR)
+              (FNS \FIXPOUT \FIXPIN)
+              (DECLARE%: DONTCOPY (EXPORT (MACROS \DECFILEPTR \GETFILEPTR \SIGNEDWIN \SIGNEDWOUT \WIN
+                                                 \WOUT \BINS \BOUTS \EOFP SIZE.FROM.LENGTH)
+                                         (CONSTANTS BitsPerByte (ByteOffsetSize (SELECTQ (SYSTEMTYPE)
+                                                                                       (VAX 10)
+                                                                                       9))
+                                                WordsPerPage)
+                                         [CONSTANTS (\MAXFILEPTR (SUB1 (LLSH 1 30]
+                                         (RECORDS BYTEPTR))
+                     (CONSTANTS MaxChar)))
+        (COMS                                                (* ; "Buffered IO")
+              (FNS \BUFFERED.BIN \BUFFERED.PEEKBIN \BUFFERED.BOUT \BUFFERED.BINS \BUFFERED.BOUTS 
+                   \BUFFERED.COPYBYTES))
+        [COMS                                                (* ; "NULL device")
+              (FNS \NULLDEVICE \NULL.OPENFILE)
+              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\NULLDEVICE]
+        (LOCALVARS . T)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML)
+                                                                             (LAMA 
+                                                                                  \IS.NOT.RANDACCESSP
+                                                                                   \ILLEGAL.DEVICEOP
+                                                                                   STREAMPROP])
+
+(PUTPROPS FILEIO FILETYPE :BCOMPL)
+
+(PUTPROPS FILEIO MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10))
+
+
+
+(* ;; "Device independent IO.  This file is used by VAX")
+
+
+
+
+(* ;; "STREAM, FDEV declarations")
+
+(DECLARE%: FIRST DOCOPY 
+
+(/DECLAREDATATYPE 'STREAM
+       '(WORD WORD FLAG (BITS 3)
+              POINTER BYTE BYTE WORD WORD WORD FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG 
+              POINTER FLAG (BITS 2)
+              FLAG POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER WORD 
+              WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
+              WORD WORD POINTER)
+       '((STREAM 0 (BITS . 15))
+         (STREAM 1 (BITS . 15))
+         (STREAM 2 (FLAGBITS . 0))
+         (STREAM 2 (BITS . 18))
+         (STREAM 2 POINTER)
+         (STREAM 4 (BITS . 7))
+         (STREAM 4 (BITS . 135))
+         (STREAM 5 (BITS . 15))
+         (STREAM 6 (BITS . 15))
+         (STREAM 7 (BITS . 15))
+         (STREAM 8 (FLAGBITS . 0))
+         (STREAM 8 (FLAGBITS . 16))
+         (STREAM 8 (FLAGBITS . 32))
+         (STREAM 8 (FLAGBITS . 48))
+         (STREAM 8 POINTER)
+         (STREAM 10 (FLAGBITS . 0))
+         (STREAM 10 (FLAGBITS . 16))
+         (STREAM 10 (FLAGBITS . 32))
+         (STREAM 10 (FLAGBITS . 48))
+         (STREAM 10 POINTER)
+         (STREAM 12 (FLAGBITS . 0))
+         (STREAM 12 (BITS . 17))
+         (STREAM 12 (FLAGBITS . 48))
+         (STREAM 12 POINTER)
+         (STREAM 14 POINTER)
+         (STREAM 16 POINTER)
+         (STREAM 18 (BITS . 15))
+         (STREAM 19 (BITS . 15))
+         (STREAM 20 POINTER)
+         (STREAM 22 POINTER)
+         (STREAM 24 POINTER)
+         (STREAM 26 POINTER)
+         (STREAM 28 POINTER)
+         (STREAM 30 (BITS . 15))
+         (STREAM 31 (BITS . 15))
+         (STREAM 32 (BITS . 15))
+         (STREAM 33 (BITS . 15))
+         (STREAM 34 POINTER)
+         (STREAM 36 POINTER)
+         (STREAM 38 POINTER)
+         (STREAM 40 POINTER)
+         (STREAM 42 POINTER)
+         (STREAM 44 POINTER)
+         (STREAM 46 POINTER)
+         (STREAM 48 POINTER)
+         (STREAM 50 POINTER)
+         (STREAM 52 (BITS . 15))
+         (STREAM 53 (BITS . 15))
+         (STREAM 54 POINTER))
+       '56)
+)
+(ADDTOVAR SYSTEMRECLST
+
+(DATATYPE STREAM ((COFFSET WORD)
+                      (CBUFSIZE WORD)
+                      (PEEKEDCHARP FLAG)
+                      (ACCESSBITS BITS 3)
+                      (CBUFPTR POINTER)
+                      (BYTESIZE BYTE)
+                      (CHARSET BYTE)
+                      (PEEKEDCHAR WORD)
+                      (CHARPOSITION WORD)
+                      (CBUFMAXSIZE WORD)
+                      (NONDEFAULTDATEFLG FLAG)
+                      (REVALIDATEFLG FLAG)
+                      (MULTIBUFFERHINT FLAG)
+                      (USERCLOSEABLE FLAG)
+                      (FULLFILENAME POINTER)
+                      (BINABLE FLAG)
+                      (BOUTABLE FLAG)
+                      (EXTENDABLE FLAG)
+                      (CBUFDIRTY FLAG)
+                      (DEVICE POINTER)
+                      (USERVISIBLE FLAG)
+                      (EOLCONVENTION BITS 2)
+                      (NOTXCCS FLAG)
+                      (VALIDATION POINTER)
+                      (CPAGE POINTER)
+                      (EPAGE POINTER)
+                      (EOFFSET WORD)
+                      (LINELENGTH WORD)
+                      (F1 POINTER)
+                      (F2 POINTER)
+                      (F3 POINTER)
+                      (F4 POINTER)
+                      (F5 POINTER)
+                      (FW6 WORD)
+                      (FW7 WORD)
+                      (FW8 WORD)
+                      (FW9 WORD)
+                      (F10 POINTER)
+                      (STRMBINFN POINTER)
+                      (STRMBOUTFN POINTER)
+                      (OUTCHARFN POINTER)
+                      (ENDOFSTREAMOP POINTER)
+                      (OTHERPROPS POINTER)
+                      (IMAGEOPS POINTER)
+                      (IMAGEDATA POINTER)
+                      (BUFFS POINTER)
+                      (MAXBUFFERS WORD)
+                      (LASTCCODE WORD)
+                      (EXTRASTREAMOP POINTER)))
+)
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
+
+(DATATYPE STREAM 
+          (
+           (* ;; "First 8 words are fixed for BIN, BOUT opcodes.  Used to require length of whole datatype be multiple of 4, but Dolphin dead now.")
+
+           (COFFSET WORD)                                    (* ; 
+                                                           "Offset in CPPTR of next bin or bout")
+           (CBUFSIZE WORD)                                   (* ; 
+                                                           "Offset past last byte in that buffer")
+           (PEEKEDCHARP FLAG)                                (* ; 
+                                 "if true, PEEKEDCHAR contains value of recent call to unread-char")
+           (ACCESSBITS BITS 3)                               (* ; 
+                                       "What kind of access file is open for (read, write, append)")
+           (CBUFPTR POINTER)                                 (* ; "Pointer to current buffer")
+           (BYTESIZE BYTE)                                   (* ; 
+                                                           "Byte size of stream, always 8 for now")
+           (CHARSET BYTE)                                    (* ; "the current character set for this stream.  If 255, stream is not runcoded, so read-char consumes two bytes every time")
+           (PEEKEDCHAR WORD)                                 (* ; "value of unread-char call")
+           (CHARPOSITION WORD)                               (* ; "Used by POSITION etc.")
+           (CBUFMAXSIZE WORD)                                (* ; 
+                             "on output, the size of the physical buffer--can't extend beyond this")
+
+           (* ;; "-------- Above fields (8 words) potentially known to microcode.  --------")
+
+           (NONDEFAULTDATEFLG FLAG)
+           (REVALIDATEFLG FLAG)
+           (MULTIBUFFERHINT FLAG)                            (* ; 
+                            "True if stream likes to read and write more than one buffer at a time")
+           (USERCLOSEABLE FLAG)                              (* ; 
+                                           "Can be closed by CLOSEF;  NIL for terminal, dribble...")
+           (FULLFILENAME POINTER)                            (* ; 
+                                                           "Name by which file is known to user")
+           (BINABLE FLAG)                                    (* ; "BIN punts unless this bit on")
+           (BOUTABLE FLAG)                                   (* ; "BOUT punts unless this bit on")
+           (EXTENDABLE FLAG)                                 (* ; 
+                      "BOUT punts when COFFSET ge CBUFFSIZE unless this bit set and COFFSET lt 512")
+           (CBUFDIRTY FLAG)                                  (* ; 
+                                                      "true if BOUT has sullied the current buffer")
+           (DEVICE POINTER)                                  (* ; "FDEV of this guy")
+           (USERVISIBLE FLAG)                                (* ; 
+                                                  "Listed by OPENP;  NIL for terminal, dribble ...")
+           (EOLCONVENTION BITS 2)                            (* ; "End-of-line convention")
+           (NOTXCCS FLAG)                                    (* ; 
+                                               "True if the character encoding format is not XCCS.")
+           (VALIDATION POINTER)                              (* ; 
+          "A number somehow identifying file, used to determine if file has changed in our absence")
+           (CPAGE POINTER)                                   (* ; 
+                      "CPAGE,,COFFSET constitutes current file pointer for most randaccess streams")
+           (EPAGE POINTER)
+           (EOFFSET WORD)                                    (* ; "Page, byte offset of eof")
+           (LINELENGTH WORD)                                 (* ; 
+                                                   "LINELENGTH of stream, or -1 for no line length")
+
+           (* ;; "----Following are device-specific fields----")
+
+           (* ;; "Available for device-specific uses, NOT for application use.")
+
+           (F1 POINTER)
+           (F2 POINTER)
+           (F3 POINTER)
+           (F4 POINTER)
+           (F5 POINTER)
+           (FW6 WORD)
+           (FW7 WORD)
+           (FW8 WORD)
+           (FW9 WORD)
+           (F10 POINTER)
+
+           (* ;; "----Following only filled in for open streams----")
+
+           (STRMBINFN POINTER)                               (* ; 
+                                                       "Either the BIN fn from the FDEV, or a trap")
+           (STRMBOUTFN POINTER)                              (* ; 
+                                                       "Either the BIN fn from the FDEV, or a trap")
+           (OUTCHARFN POINTER)                               (* ; 
+                                                "Called by \OUTCHAR, the normal character printer.")
+           (ENDOFSTREAMOP POINTER)                           (* ; 
+                                                           "Called if EOF and we try to read.")
+           (OTHERPROPS POINTER)                              (* ; 
+                                                           "PROP LIST for holding other info.")
+           (IMAGEOPS POINTER)                                (* ; "Image operations vector")
+           (IMAGEDATA POINTER)                               (* ; 
+                                       "Image instance variables--format depends on IMAGEOPS value")
+           (BUFFS POINTER)                                   (* ; 
+                                                           "Buffer chain for pmapped streams")
+           (MAXBUFFERS WORD)                                 (* ; 
+                                                       "Max # of buffers the system will allocate.")
+           (LASTCCODE WORD)                                  (* ; "After READ, RATOM, etc, the charcode that will be returned (as a character) by LASTC.  If there is none, this field is 65535.")
+           (EXTRASTREAMOP POINTER)                           (* ; 
+                                                    "For use of applications programs, not devices")
+           )
+          (BLOCKRECORD STREAM ((NIL 2 WORD)
+                               (UCODEFLAGS1 BITS 1)
+
+                               (* ;; "respecification of access bits:")
+
+                               (RANDOMWRITEABLE FLAG)        (* ; 
+                                                   "File open for output (access = OUTPUT or BOTH)")
+                               (APPENDABLE FLAG)             (* ; 
+                                                  "File open for append (OUTPUT or APPEND or BOTH)")
+                               (READABLE FLAG)               (* ; 
+                                                           "File open for read (READ or BOTH)")
+                               (NIL POINTER)))
+          (BLOCKRECORD STREAM ((NIL 4 WORD)
+                               (NIL BITS 14)
+
+                               (* ;; 
+                             "JIS character encoding format specific, overrides CHARSET field.")
+
+                               (IN.KANJIIN FLAG)             (* ; 
+                                                        "True if input stream is in Kanji-in mode.")
+                               (OUT.KANJIIN FLAG)            (* ; 
+                                                       "True if output stream is in Kanji-in mode.")
+                               ))
+          [ACCESSFNS STREAM ((ACCESS \GETACCESS \SETACCESS)
+                             (FULLNAME (OR (fetch (STREAM FULLFILENAME) of DATUM)
+                                           DATUM))
+                             (NAMEDP (AND (fetch (STREAM FULLFILENAME) of DATUM)
+                                          T]
+          [ACCESSFNS STREAM (EXTERNALFORMAT (LISTGET (ffetch (STREAM OTHERPROPS) of DATUM)
+                                                   'EXTERNALFORMAT)
+                                   (LET ((PROPS (ffetch (STREAM OTHERPROPS) of DATUM)))
+                                        (freplace (STREAM NOTXCCS) of DATUM with T)
+                                        [COND
+                                           (PROPS (LISTPUT PROPS 'EXTERNALFORMAT NEWVALUE))
+                                           (T (freplace (STREAM OTHERPROPS) of DATUM
+                                                 with (LIST 'EXTERNALFORMAT NEWVALUE]
+                                        (freplace (STREAM OUTCHARFN) of DATUM
+                                           with (ffetch (EXTERNALFORMAT FILEOUTCHARFN)
+                                                       of NEWVALUE))
+                                        (AND (ffetch (EXTERNALFORMAT EOLVALID) of NEWVALUE)
+                                             (freplace (STREAM EOLCONVENTION) of DATUM
+                                                with (ffetch (EXTERNALFORMAT EOL)
+                                                            of NEWVALUE]
+          [ACCESSFNS STREAM (EXTERNALFORMAT.NAME (LISTGET (ffetch (STREAM OTHERPROPS)
+                                                             of DATUM)
+                                                        'EXTERNALFORMAT.NAME)
+                                   (LET [(PROPS (ffetch (STREAM OTHERPROPS) of DATUM))
+                                         (NAME (COND
+                                                  ((LITATOM NEWVALUE)
+                                                   NEWVALUE)
+                                                  (T (MKATOM NEWVALUE]
+                                        (freplace (STREAM NOTXCCS) of DATUM with T)
+                                        (COND
+                                           (PROPS (LISTPUT PROPS 'EXTERNALFORMAT.NAME NAME))
+                                           (T (freplace (STREAM OTHERPROPS) of DATUM
+                                                 with (LIST 'EXTERNALFORMAT.NAME NAME]
+          [ACCESSFNS STREAM (INCCODEFN (LET [(XFMT (LISTGET (ffetch (STREAM OTHERPROPS)
+                                                               of DATUM)
+                                                          'EXTERNALFORMAT]
+                                            (AND (type? EXTERNALFORMAT XFMT)
+                                                 (fetch (EXTERNALFORMAT INCCODEFN) of XFMT]
+          [ACCESSFNS STREAM (PEEKCCODEFN (LET [(XFMT (LISTGET (ffetch (STREAM OTHERPROPS)
+                                                                 of DATUM)
+                                                            'EXTERNALFORMAT]
+                                              (AND (type? EXTERNALFORMAT XFMT)
+                                                   (fetch (EXTERNALFORMAT PEEKCCODEFN)
+                                                      of XFMT]
+          [ACCESSFNS STREAM (BACKCHARFN (LET [(XFMT (LISTGET (ffetch (STREAM OTHERPROPS)
+                                                                of DATUM)
+                                                           'EXTERNALFORMAT]
+                                             (AND (type? EXTERNALFORMAT XFMT)
+                                                  (fetch (EXTERNALFORMAT BACKCHARFN) of
+                                                                                         XFMT]
+          (ACCESSFNS STREAM (FILEOUTCHARFN (ffetch (STREAM OUTCHARFN) of DATUM)))
+          (SYNONYM CBUFPTR (CPPTR))
+          USERCLOSEABLE _ T USERVISIBLE _ T ACCESSBITS _ NoBits CPAGE _ 0 EPAGE _ 0 BUFFS _ NIL 
+          BYTESIZE _ 8 CBUFPTR _ NIL MAXBUFFERS _ (LET NIL (DECLARE (GLOBALVARS 
+                                                                           \STREAM.DEFAULT.MAXBUFFERS
+                                                                                   ))
+                                                         \STREAM.DEFAULT.MAXBUFFERS)
+          CHARPOSITION _ 0 LINELENGTH _ (LET NIL (DECLARE (GLOBALVARS FILELINELENGTH))
+                                             FILELINELENGTH)
+          OUTCHARFN _ (FUNCTION \FILEOUTCHARFN)
+          ENDOFSTREAMOP _ (FUNCTION \EOSERROR)
+          IMAGEOPS _ \NOIMAGEOPS EOLCONVENTION _ (SELECTQ (SYSTEMTYPE)
+                                                     (D CR.EOLC)
+                                                     (VAX LF.EOLC)
+                                                     (JERICHO CRLF.EOLC)
+                                                     CR.EOLC)
+          STRMBINFN _ (FUNCTION \STREAM.NOT.OPEN)
+          STRMBOUTFN _ (FUNCTION \STREAM.NOT.OPEN)
+          LASTCCODE _ 65535 NOTXCCS _ NIL)
+)
+
+(/DECLAREDATATYPE 'STREAM
+       '(WORD WORD FLAG (BITS 3)
+              POINTER BYTE BYTE WORD WORD WORD FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG 
+              POINTER FLAG (BITS 2)
+              FLAG POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER WORD 
+              WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
+              WORD WORD POINTER)
+       '((STREAM 0 (BITS . 15))
+         (STREAM 1 (BITS . 15))
+         (STREAM 2 (FLAGBITS . 0))
+         (STREAM 2 (BITS . 18))
+         (STREAM 2 POINTER)
+         (STREAM 4 (BITS . 7))
+         (STREAM 4 (BITS . 135))
+         (STREAM 5 (BITS . 15))
+         (STREAM 6 (BITS . 15))
+         (STREAM 7 (BITS . 15))
+         (STREAM 8 (FLAGBITS . 0))
+         (STREAM 8 (FLAGBITS . 16))
+         (STREAM 8 (FLAGBITS . 32))
+         (STREAM 8 (FLAGBITS . 48))
+         (STREAM 8 POINTER)
+         (STREAM 10 (FLAGBITS . 0))
+         (STREAM 10 (FLAGBITS . 16))
+         (STREAM 10 (FLAGBITS . 32))
+         (STREAM 10 (FLAGBITS . 48))
+         (STREAM 10 POINTER)
+         (STREAM 12 (FLAGBITS . 0))
+         (STREAM 12 (BITS . 17))
+         (STREAM 12 (FLAGBITS . 48))
+         (STREAM 12 POINTER)
+         (STREAM 14 POINTER)
+         (STREAM 16 POINTER)
+         (STREAM 18 (BITS . 15))
+         (STREAM 19 (BITS . 15))
+         (STREAM 20 POINTER)
+         (STREAM 22 POINTER)
+         (STREAM 24 POINTER)
+         (STREAM 26 POINTER)
+         (STREAM 28 POINTER)
+         (STREAM 30 (BITS . 15))
+         (STREAM 31 (BITS . 15))
+         (STREAM 32 (BITS . 15))
+         (STREAM 33 (BITS . 15))
+         (STREAM 34 POINTER)
+         (STREAM 36 POINTER)
+         (STREAM 38 POINTER)
+         (STREAM 40 POINTER)
+         (STREAM 42 POINTER)
+         (STREAM 44 POINTER)
+         (STREAM 46 POINTER)
+         (STREAM 48 POINTER)
+         (STREAM 50 POINTER)
+         (STREAM 52 (BITS . 15))
+         (STREAM 53 (BITS . 15))
+         (STREAM 54 POINTER))
+       '56)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS STREAMOP MACRO [ARGS (CONS 'SPREADAPPLY*
+                                             (CONS (COND
+                                                      ((EQ (CAR (LISTP (CAR ARGS)))
+                                                           'QUOTE)
+                                                       (LIST 'fetch (CADAR ARGS)
+                                                             'of
+                                                             (CADR ARGS)))
+                                                      (T (HELP "STREAMOP - OPNAME not quoted:" ARGS))
+                                                      )
+                                                   (CDDR ARGS])
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ AppendBit 2)
+
+(RPAQQ NoBits 0)
+
+(RPAQQ ReadBit 1)
+
+(RPAQQ WriteBit 4)
+
+(RPAQ OutputBits (LOGOR AppendBit WriteBit))
+
+(RPAQ BothBits (LOGOR ReadBit OutputBits))
+
+(RPAQQ \NORUNCODE 255)
+
+
+(CONSTANTS AppendBit NoBits ReadBit WriteBit (OutputBits (LOGOR AppendBit WriteBit))
+       (BothBits (LOGOR ReadBit OutputBits))
+       \NORUNCODE)
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS TestMasked MACRO ((BITS MASK)
+                                    (NEQ (LOGAND BITS MASK)
+                                         0)))
+
+(PUTPROPS APPENDABLE MACRO ((STREAM)
+                                    (TestMasked (fetch ACCESSBITS of STREAM)
+                                           AppendBit)))
+
+(PUTPROPS APPENDONLY MACRO ((STREAM)
+                                    (EQ (fetch ACCESSBITS of STREAM)
+                                        AppendBit)))
+
+(PUTPROPS DIRTYABLE MACRO [(STREAM)
+                                   (TestMasked (fetch ACCESSBITS of STREAM)
+                                          (CONSTANT (LOGOR AppendBit WriteBit])
+
+(PUTPROPS OPENED MACRO ((STREAM)
+                                (NEQ (fetch ACCESSBITS of STREAM)
+                                     NoBits)))
+
+(PUTPROPS OVERWRITEABLE MACRO ((STREAM)
+                                       (TestMasked (fetch ACCESSBITS of STREAM)
+                                              WriteBit)))
+
+(PUTPROPS READABLE MACRO ((STREAM)
+                                  (TestMasked (fetch ACCESSBITS of STREAM)
+                                         ReadBit)))
+
+(PUTPROPS READONLY MACRO ((STREAM)
+                                  (EQ (fetch ACCESSBITS of STREAM)
+                                      ReadBit)))
+
+(PUTPROPS WRITEABLE MACRO [(STREAM)
+                                   (OR (OVERWRITEABLE STREAM)
+                                       (AND (APPENDABLE STREAM)
+                                            (\EOFP STREAM])
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \RUNCODED MACRO (OPENLAMBDA (STREAM)
+
+                                         (* ;; "returns NIL is the stream is not runcoded, that is, if the stream has 16 bit bytes explicitly represented")
+                                                             (* ; 
+                                      "note that neq is ok since charsets are known to be SMALLP's")
+                                         (NEQ (fetch CHARSET of STREAM)
+                                              \NORUNCODE)))
+)
+
+(RPAQQ EOLCONVENTIONS ((CR.EOLC 0)
+                           (LF.EOLC 1)
+                           (CRLF.EOLC 2)))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ CR.EOLC 0)
+
+(RPAQQ LF.EOLC 1)
+
+(RPAQQ CRLF.EOLC 2)
+
+
+(CONSTANTS (CR.EOLC 0)
+       (LF.EOLC 1)
+       (CRLF.EOLC 2))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+(DEFINEQ
+
+(STREAMPROP
+(LAMBDA X (* rda%: "22-Aug-84 14:24") (* ;; "general top level entry for both fetching and setting stream properties.") (COND ((IGREATERP X 2) (PUTSTREAMPROP (ARG X 1) (ARG X 2) (ARG X 3))) ((EQ X 2) (GETSTREAMPROP (ARG X 1) (ARG X 2))) (T (\ILLEGAL.ARG NIL))))
+)
+
+(GETSTREAMPROP
+(LAMBDA (STREAM PROP) (* rda%: "22-Aug-84 16:17") (OR (type? STREAM STREAM) (\ILLEGAL.ARG)) (LISTGET (fetch (STREAM OTHERPROPS) of STREAM) PROP))
+)
+
+(PUTSTREAMPROP
+(LAMBDA (STREAM PROP VALUE) (* rda%: "22-Aug-84 16:11") (OR (type? STREAM STREAM) (\ILLEGAL.ARG STREAM)) (PROG ((OLDDATA (fetch OTHERPROPS of STREAM)) OLDVALUE) (RETURN (PROG1 (COND (OLDDATA (SETQ OLDVALUE (LISTGET OLDDATA PROP)) (COND (VALUE (LISTPUT OLDDATA PROP VALUE)) (OLDVALUE (* ; "Remove the property") (COND ((EQ (CAR OLDDATA) PROP) (replace OTHERPROPS of STREAM with (CDDR OLDDATA))) (T (for TAIL on (CDR OLDDATA) by (CDDR TAIL) when (EQ (CADR TAIL) PROP) do (FRPLACD TAIL (CDDDR TAIL)) (RETURN)))))) OLDVALUE) (VALUE (replace OTHERPROPS of STREAM with (LIST PROP VALUE)) (* ; "know old value is NIL") NIL))))))
+)
+
+(STREAMP
+(LAMBDA (X) (* rmk%: "14-OCT-83 14:35") (AND (type? STREAM X) X)))
+)
+
+
+
+(* ; "make streams print pretty")
+
+(DEFINEQ
+
+(\DEFPRINT.BY.NAME
+(LAMBDA (OBJECT STREAM NAME TYPENAME) (* ; "Edited  8-May-87 15:53 by bvm:") (* ;; "Print an object using its name, for example, #<FDev ERIS/76,5432>.  NAME is the object's name (or NIL if this one happens to be nameless), TYPENAME is a string giving the generic name you want to appear in front, e.g., %"FDev%"") (.SPACECHECK. STREAM (+ (NCHARS TYPENAME) (PROGN (* ; "Longest address is `< /177,177777>'") 14) (COND (NAME (NCHARS NAME)) (T 0)))) (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*)) (\OUTCHAR STREAM (CHARCODE <)) (\SOUT (MKSTRING TYPENAME) STREAM) (COND (NAME (\OUTCHAR STREAM (CHARCODE SPACE)) (\SOUT (MKSTRING NAME) STREAM))) (\OUTCHAR STREAM (CHARCODE /)) (\PRINTADDR OBJECT STREAM) (\OUTCHAR STREAM (CHARCODE >)) T)
+)
+
+(\STREAM.DEFPRINT
+(LAMBDA (STRM OUTSTREAM) (* ; "Edited 19-Aug-88 14:01 by bvm") (LET ((TYPE (SELECTC (fetch ACCESSBITS of STRM) (ReadBit "Input") (OutputBits "Output") (BothBits "IO") (AppendBit "Append") "Closed"))) (\DEFPRINT.BY.NAME STRM OUTSTREAM NIL (COND ((fetch (STREAM NAMEDP) of STRM) (* ; "Use file name") (CONCAT TYPE " Stream on " (fetch (STREAM FULLFILENAME) of STRM))) (T (* ; "Name the device") (CONCAT TYPE " " (CL:STRING-CAPITALIZE (STRING (fetch (FDEV DEVICENAME) of (fetch DEVICE of STRM)))) " Stream"))))))
+)
+
+(\FDEV.DEFPRINT
+(LAMBDA (DEV STREAM) (* ; "Edited  8-May-87 15:55 by bvm") (* ;; "Print device using its name, for example, #<FDev ERIS/76,5432>") (\DEFPRINT.BY.NAME DEV STREAM (fetch (FDEV DEVICENAME) of DEV) "FDev"))
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(DEFPRINT 'STREAM (FUNCTION \STREAM.DEFPRINT))
+
+(DEFPRINT 'FDEV (FUNCTION \FDEV.DEFPRINT))
+)
+
+
+
+(* ; "Needed because of STREAM initialization")
+
+
+(RPAQ? FILELINELENGTH 102)
+
+(RPAQ? \STREAM.DEFAULT.MAXBUFFERS 3)
+(DEFINEQ
+
+(\GETACCESS
+(LAMBDA (STREAM) (* bvm%: "26-DEC-81 15:43") (* ;; "Decodes the access bits.  The inverse of the encoding in \SETACCESS.  Ugly but no less so than the machinery to do it elegantly.") (SELECTC (fetch ACCESSBITS of STREAM) (NoBits NIL) (ReadBit (QUOTE INPUT)) (AppendBit (QUOTE APPEND)) (OutputBits (QUOTE OUTPUT)) (BothBits (QUOTE BOTH)) (SHOULDNT)))
+)
+
+(\SETACCESS
+(LAMBDA (STREAM ACCESS) (* rmk%: " 7-NOV-83 15:02") (* ;; "The setfn for the ACCESS field.  Does not assume that streams are initialized with all bits off and \STREAM.NOT.OPEN installed") (UNINTERRUPTABLY (PROG ((DEVICE (fetch DEVICE of STREAM))) (SELECTQ ACCESS (NIL (replace ACCESSBITS of STREAM with NoBits) (* ; "Was open, now closing") (replace BINABLE of STREAM with (replace BOUTABLE of STREAM with (replace EXTENDABLE of STREAM with NIL))) (replace STRMBINFN of STREAM with (replace STRMBOUTFN of STREAM with (FUNCTION \STREAM.NOT.OPEN)))) (INPUT (replace ACCESSBITS of STREAM with ReadBit) (* ; "Was closed, now opening") (replace BINABLE of STREAM with (fetch FDBINABLE of DEVICE)) (replace STRMBINFN of STREAM with (fetch BIN of DEVICE)) (replace STRMBOUTFN of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (replace BOUTABLE of STREAM with (replace EXTENDABLE of STREAM with NIL))) (APPEND (replace ACCESSBITS of STREAM with AppendBit) (replace BOUTABLE of STREAM with (fetch FDBOUTABLE of DEVICE)) (replace EXTENDABLE of STREAM with (fetch FDEXTENDABLE of DEVICE)) (replace STRMBOUTFN of STREAM with (fetch BOUT of DEVICE)) (replace STRMBINFN of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (replace BINABLE of STREAM with NIL)) (OUTPUT (replace ACCESSBITS of STREAM with OutputBits) (replace BOUTABLE of STREAM with (fetch FDBOUTABLE of DEVICE)) (replace EXTENDABLE of STREAM with (fetch FDEXTENDABLE of DEVICE)) (replace STRMBOUTFN of STREAM with (fetch BOUT of DEVICE)) (replace STRMBINFN of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (replace BINABLE of STREAM with NIL)) (BOTH (replace ACCESSBITS of STREAM with BothBits) (replace BINABLE of STREAM with (fetch FDBINABLE of DEVICE)) (replace BOUTABLE of STREAM with (fetch FDBOUTABLE of DEVICE)) (replace EXTENDABLE of STREAM with (fetch FDEXTENDABLE of DEVICE)) (replace STRMBINFN of STREAM with (fetch BIN of DEVICE)) (replace STRMBOUTFN of STREAM with (fetch BOUT of DEVICE))) (RAID "Illegal stream access mode")))) ACCESS)
+)
+)
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS FDEVOP DMACRO [ARGS (LET ((OPNAME (CAR ARGS))
+                                            (METHOD-DEVICE (CADR ARGS))
+                                            (TAIL (CDDR ARGS)))
+                                           (COND
+                                              [(AND (LISTP OPNAME)
+                                                    (EQ (CAR OPNAME)
+                                                        'QUOTE))
+                                               `(SPREADAPPLY* (fetch (FDEV ,(CADR OPNAME))
+                                                                 of ,METHOD-DEVICE)
+                                                       ,@TAIL]
+                                              (T (ERROR "OPNAME not quoted: " OPNAME])
+
+(PUTPROPS \RECOGNIZE-HACK DMACRO [ARGS (LET ((NAME (CAR ARGS))
+                                                     (RECOG (CADR ARGS))
+                                                     (DEVICE (CADDR ARGS)))
+                                                    `(if (type? STREAM ,NAME)
+                                                         then ,NAME
+                                                       else (FDEVOP 'GETFILENAME ,DEVICE
+                                                                       ,NAME
+                                                                       ,RECOG
+                                                                       ,DEVICE])
+)
+(DECLARE%: EVAL@COMPILE
+
+(DATATYPE FDEV ((RESETABLE FLAG)                         (* ; "Obsolete")
+                    (RANDOMACCESSP FLAG)
+                    (NODIRECTORIES FLAG)
+                    (PAGEMAPPED FLAG)                        (* ; 
+                                                           "True if i/o handled by pmap routines")
+                    (FDBINABLE FLAG)                         (* ; 
+                               "Copied as a microcode flag for INPUT streams formed on this device")
+                    (FDBOUTABLE FLAG)
+                    (FDEXTENDABLE FLAG)
+                    (BUFFERED FLAG)                          (* ; "True implies that the device supports the BIN & BOUT uCode conventions, and implements the GETNEXTBUFFER method")
+                    (DEVICENAME POINTER)                     (* ; "Identifying name somehow")
+                    (REMOTEP FLAG)                           (* ; 
+                                                           "true if device not local to machine")
+                    (SUBDIRECTORIES FLAG)                    (* ; 
+                                                           "true if device has real subdirectories")
+                    (INPUT-INDIRECTED FLAG)                  (* ; 
+                "True for devices that indirect their input stream.  Method INPUTSTREAM fetches it")
+                    (OUTPUT-INDIRECTED FLAG)                 (* ; 
+              "True for devices that indirect their output stream.  Method OUTPUTSTREAM fetches it")
+                    (DEVICEINFO POINTER)                     (* ; 
+                                                       "arbitrary device-specific info stored here")
+                    (OPENFILELST POINTER)                    (* ; 
+                                        "Default place to keep list of streams open on this device")
+
+                    (* ;; "-----Rest of record consists of device %"methods%"-----")
+
+                    (* ;; "-----Following fields required of all devices-----")
+
+                    (HOSTNAMEP POINTER)                      (* ; "(hostname {device}) => T if hostname is valid.  If device is given, return a FDEV for this {new} host, or T to use existing device")
+                    (EVENTFN POINTER)                        (* ; 
+                                      "(device event), called before/after logout, sysout, makesys")
+
+                    (* ;; 
+             "-----Following fields required of all named devices, e.g., ones that open files-----")
+
+                    (DIRECTORYNAMEP POINTER)                 (* ; 
+                                                   "(host/dir) => true if directory exists on host")
+                    (OPENFILE POINTER)                       (* ; 
+ "(name access recog otherinfo device) => new stream open on this device, or NIL if name not found")
+                    (CLOSEFILE POINTER)                      (* ; 
+                                                           "(stream) => closes stream, returns it")
+                    (REOPENFILE POINTER)                     (* ; "(name access recog otherinfo device stream) like openfile, but called after logout to revalidate file, so optionally uses info in old stream to keep this opening like the previous")
+                    (GETFILENAME POINTER)                    (* ; 
+                                                           "(name recog device) => full file name")
+                    (DELETEFILE POINTER)                     (* ; 
+                "(name) => deletes file so named, returning name, or NIL on failure.  RECOG=OLDEST")
+                    (GENERATEFILES POINTER)                  (* ; "(device pattern) => generator object for files matching pattern.  Car of object is generator function, cdr is arbitrary state.  Generator fn returns next file, or NIL when finished")
+                    (RENAMEFILE POINTER)                     (* ; "(olddevice oldfile newdevice newfile) to rename file on this (olddevice) to a potentially different device.")
+                    (OPENP POINTER)                          (* ; 
+        "(name access dev) => stream if name is open for access, or all open streams if name = NIL")
+                    (REGISTERFILE POINTER)                   (* ; 
+                                                   "(stream dev) => registers stream on its device")
+                    (UNREGISTERFILE POINTER)                 (* ; 
+                                             "(stream dev) => unregisters a stream from its device")
+                    (FREEPAGECOUNT POINTER)                  (* ; 
+                                                    "(host/dir dev) => # of free pages on host/dir")
+                    (MAKEDIRECTORY POINTER)                  (* ; "(host/dir dev)")
+                    (CHECKFILENAME POINTER)                  (* ; 
+                                        "(name dev) => name if it is well-formed file name for dev")
+                    (HOSTALIVEP POINTER)                     (* ; 
+          "(host dev) => true if host is alive, i.e., responsive;  only defined if REMOTEP is true")
+                    (BREAKCONNECTION POINTER)                (* ; 
+                                                   "(host fastp dev) => closes connections to host")
+
+                    (* ;; 
+                  "-----The following are required methods for operating on open streams-----")
+
+                    (BIN POINTER)                            (* ; "(stream) => next byte of input")
+                    (BOUT POINTER)                           (* ; 
+                                                           "(stream byte) output byte to stream")
+                    (PEEKBIN POINTER)                        (* ; 
+                                       "(stream) => next byte without advancing position in stream")
+                    (READCHAR POINTER)                       (* ; "(stream) => next input char")
+                    (WRITECHAR POINTER)                      (* ; 
+                                                           "(stream char) => writes char to stream")
+                    (PEEKCHAR POINTER)
+                    (UNREADCHAR POINTER)
+                    (READP POINTER)                          (* ; 
+                             "(stream flag) => T if there is input available from stream right now")
+                    (EOFP POINTER)                           (* ; 
+                                                           "(stream) => T if BIN would signal eof.")
+                    (BLOCKIN POINTER)                        (* ; 
+                                                           "(stream buffer byteoffset nbytes)")
+                    (BLOCKOUT POINTER)                       (* ; 
+                                                           "(stream buffer byteoffset nbytes)")
+                    (FORCEOUTPUT POINTER)                    (* ; 
+     "(stream waitForFinish) flushes out to device anything that is buffered awaiting transmission")
+                    (GETFILEINFO POINTER)                    (* ; 
+      "(stream/name attribute device) => value of attribute for open stream or name of closed file")
+                    (SETFILEINFO POINTER)                    (* ; 
+"(stream/name attribute newvalue device) sets attribute of open stream or closed file of given name")
+                    (CHARSETFN POINTER)                      (* ; "(stream charset) => access function for the charset slot, for benefit of indirect streams.  See IMCHARSET for changing it on a file.")
+                    (INPUTSTREAM POINTER)                    (* ; 
+                                                           "(stream) => indirected input stream")
+                    (OUTPUTSTREAM POINTER)                   (* ; 
+                                                           "(stream) => indirected output stream")
+
+                    (* ;; "-----Following are required of random-access streams-----")
+
+                    (GETFILEPTR POINTER)
+                    (GETEOFPTR POINTER)
+                    (SETFILEPTR POINTER)
+                    (BACKFILEPTR POINTER)                    (* ; "(stream) backs up `fileptr' by one.  Stream is only required to be able to do this once, i.e.  one-character buffer suffices")
+                    (SETEOFPTR POINTER)                      (* ; 
+                             "(stream length) => truncates or lengthens stream to indicated length")
+                    (LASTC POINTER)                          (* ; 
+                                                         "Should be possible only if RANDOMACCESSP")
+
+                    (* ;; "-----Following used for buffered streams-----")
+
+                    (GETNEXTBUFFER POINTER)                  (* ; "(stream whatfor noerrorflg) => Disposes of current buffer and optionally reads next.  whatfor is READ or WRITE.  Can cause EOF error unless noerrorflg")
+                    (RELEASEBUFFER POINTER)                  (* ; 
+                                   "(stream) => Does whatever appropriate when CBUFPTR is released")
+
+                    (* ;; "-----Following used for pagemapped streams-----")
+
+                    (READPAGES POINTER)                      (* ; "(stream firstpage# buflist) => # of bytes read, starting at firstpage#, reading into buflist, a list of buffers or a single buffer (the usual case)")
+                    (WRITEPAGES POINTER)                     (* ; 
+       "(stream firstpage# buflist) writes from buflist to stream starting at firstpage# of stream")
+                    (TRUNCATEFILE POINTER)                   (* ; 
+           "(stream page offset) make stream's eof be at page,offset, discarding anything after it")
+
+                    (* ;; "-----For window system, argh-----")
+
+                    (WINDOWOPS POINTER)                      (* ; "window system operations")
+                    (WINDOWDATA POINTER)                     (* ; "data for window systems")
+
+                    (* ;; "-----For any stream (here to not recompile everything)-----")
+
+                    (READCHARCODE POINTER)                   (* ; 
+                                        "Read a character code from the stream (cf BIN for bytes).")
+                    )
+                   DIRECTORYNAMEP _ (FUNCTION NILL)
+                   HOSTNAMEP _ (FUNCTION NILL)
+                   READP _ (FUNCTION \GENERIC.READP)
+                   SETFILEPTR _ (FUNCTION \IS.NOT.RANDACCESSP)
+                   GETFILEPTR _ (FUNCTION \ILLEGAL.DEVICEOP)
+                   GETEOFPTR _ (FUNCTION \IS.NOT.RANDACCESSP)
+                   EOFP _ (FUNCTION \ILLEGAL.DEVICEOP)
+                   BLOCKIN _ (FUNCTION \GENERIC.BINS)
+                   BLOCKOUT _ (FUNCTION \GENERIC.BOUTS)
+                   RENAMEFILE _ (FUNCTION \GENERIC.RENAMEFILE)
+                   FORCEOUTPUT _ (FUNCTION NILL)
+                   REGISTERFILE _ (FUNCTION NILL)
+                   OPENP _ (FUNCTION NILL)
+                   UNREGISTERFILE _ (FUNCTION NILL)
+                   READCHAR _ (FUNCTION \GENERIC.READCHAR)
+                   WRITECHAR _ (FUNCTION \GENERIC.WRITECHAR)
+                   PEEKCHAR _ (FUNCTION \GENERIC.PEEKCHAR)
+                   UNREADCHAR _ (FUNCTION \GENERIC.UNREADCHAR)
+                   CHARSETFN _ (FUNCTION \GENERIC.CHARSET)
+                   BREAKCONNECTION _ (FUNCTION NILL)
+                   READCHARCODE _ (FUNCTION \GENERIC.READCCODE))
+
+(RECORD FILEGENOBJ (NEXTFILEFN FILEINFOFN . GENFILESTATE))
+)
+
+(/DECLAREDATATYPE 'FDEV
+       '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG POINTER POINTER POINTER
+              POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
+              POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
+              POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
+              POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
+              POINTER POINTER POINTER POINTER)
+       '((FDEV 0 (FLAGBITS . 0))
+         (FDEV 0 (FLAGBITS . 16))
+         (FDEV 0 (FLAGBITS . 32))
+         (FDEV 0 (FLAGBITS . 48))
+         (FDEV 0 (FLAGBITS . 64))
+         (FDEV 0 (FLAGBITS . 80))
+         (FDEV 0 (FLAGBITS . 96))
+         (FDEV 0 (FLAGBITS . 112))
+         (FDEV 2 POINTER)
+         (FDEV 2 (FLAGBITS . 0))
+         (FDEV 2 (FLAGBITS . 16))
+         (FDEV 2 (FLAGBITS . 32))
+         (FDEV 2 (FLAGBITS . 48))
+         (FDEV 4 POINTER)
+         (FDEV 6 POINTER)
+         (FDEV 8 POINTER)
+         (FDEV 10 POINTER)
+         (FDEV 12 POINTER)
+         (FDEV 14 POINTER)
+         (FDEV 16 POINTER)
+         (FDEV 18 POINTER)
+         (FDEV 20 POINTER)
+         (FDEV 22 POINTER)
+         (FDEV 24 POINTER)
+         (FDEV 26 POINTER)
+         (FDEV 28 POINTER)
+         (FDEV 30 POINTER)
+         (FDEV 32 POINTER)
+         (FDEV 34 POINTER)
+         (FDEV 36 POINTER)
+         (FDEV 38 POINTER)
+         (FDEV 40 POINTER)
+         (FDEV 42 POINTER)
+         (FDEV 44 POINTER)
+         (FDEV 46 POINTER)
+         (FDEV 48 POINTER)
+         (FDEV 50 POINTER)
+         (FDEV 52 POINTER)
+         (FDEV 54 POINTER)
+         (FDEV 56 POINTER)
+         (FDEV 58 POINTER)
+         (FDEV 60 POINTER)
+         (FDEV 62 POINTER)
+         (FDEV 64 POINTER)
+         (FDEV 66 POINTER)
+         (FDEV 68 POINTER)
+         (FDEV 70 POINTER)
+         (FDEV 72 POINTER)
+         (FDEV 74 POINTER)
+         (FDEV 76 POINTER)
+         (FDEV 78 POINTER)
+         (FDEV 80 POINTER)
+         (FDEV 82 POINTER)
+         (FDEV 84 POINTER)
+         (FDEV 86 POINTER)
+         (FDEV 88 POINTER)
+         (FDEV 90 POINTER)
+         (FDEV 92 POINTER)
+         (FDEV 94 POINTER)
+         (FDEV 96 POINTER)
+         (FDEV 98 POINTER)
+         (FDEV 100 POINTER)
+         (FDEV 102 POINTER)
+         (FDEV 104 POINTER))
+       '106)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+
+(/DECLAREDATATYPE 'FDEV
+       '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG POINTER POINTER POINTER
+              POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
+              POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
+              POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
+              POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
+              POINTER POINTER POINTER POINTER)
+       '((FDEV 0 (FLAGBITS . 0))
+         (FDEV 0 (FLAGBITS . 16))
+         (FDEV 0 (FLAGBITS . 32))
+         (FDEV 0 (FLAGBITS . 48))
+         (FDEV 0 (FLAGBITS . 64))
+         (FDEV 0 (FLAGBITS . 80))
+         (FDEV 0 (FLAGBITS . 96))
+         (FDEV 0 (FLAGBITS . 112))
+         (FDEV 2 POINTER)
+         (FDEV 2 (FLAGBITS . 0))
+         (FDEV 2 (FLAGBITS . 16))
+         (FDEV 2 (FLAGBITS . 32))
+         (FDEV 2 (FLAGBITS . 48))
+         (FDEV 4 POINTER)
+         (FDEV 6 POINTER)
+         (FDEV 8 POINTER)
+         (FDEV 10 POINTER)
+         (FDEV 12 POINTER)
+         (FDEV 14 POINTER)
+         (FDEV 16 POINTER)
+         (FDEV 18 POINTER)
+         (FDEV 20 POINTER)
+         (FDEV 22 POINTER)
+         (FDEV 24 POINTER)
+         (FDEV 26 POINTER)
+         (FDEV 28 POINTER)
+         (FDEV 30 POINTER)
+         (FDEV 32 POINTER)
+         (FDEV 34 POINTER)
+         (FDEV 36 POINTER)
+         (FDEV 38 POINTER)
+         (FDEV 40 POINTER)
+         (FDEV 42 POINTER)
+         (FDEV 44 POINTER)
+         (FDEV 46 POINTER)
+         (FDEV 48 POINTER)
+         (FDEV 50 POINTER)
+         (FDEV 52 POINTER)
+         (FDEV 54 POINTER)
+         (FDEV 56 POINTER)
+         (FDEV 58 POINTER)
+         (FDEV 60 POINTER)
+         (FDEV 62 POINTER)
+         (FDEV 64 POINTER)
+         (FDEV 66 POINTER)
+         (FDEV 68 POINTER)
+         (FDEV 70 POINTER)
+         (FDEV 72 POINTER)
+         (FDEV 74 POINTER)
+         (FDEV 76 POINTER)
+         (FDEV 78 POINTER)
+         (FDEV 80 POINTER)
+         (FDEV 82 POINTER)
+         (FDEV 84 POINTER)
+         (FDEV 86 POINTER)
+         (FDEV 88 POINTER)
+         (FDEV 90 POINTER)
+         (FDEV 92 POINTER)
+         (FDEV 94 POINTER)
+         (FDEV 96 POINTER)
+         (FDEV 98 POINTER)
+         (FDEV 100 POINTER)
+         (FDEV 102 POINTER)
+         (FDEV 104 POINTER))
+       '106)
+(ADDTOVAR SYSTEMRECLST
+
+(DATATYPE FDEV ((RESETABLE FLAG)
+                    (RANDOMACCESSP FLAG)
+                    (NODIRECTORIES FLAG)
+                    (PAGEMAPPED FLAG)
+                    (FDBINABLE FLAG)
+                    (FDBOUTABLE FLAG)
+                    (FDEXTENDABLE FLAG)
+                    (BUFFERED FLAG)
+                    (DEVICENAME POINTER)
+                    (REMOTEP FLAG)
+                    (SUBDIRECTORIES FLAG)
+                    (INPUT-INDIRECTED FLAG)
+                    (OUTPUT-INDIRECTED FLAG)
+                    (DEVICEINFO POINTER)
+                    (OPENFILELST POINTER)
+                    (HOSTNAMEP POINTER)
+                    (EVENTFN POINTER)
+                    (DIRECTORYNAMEP POINTER)
+                    (OPENFILE POINTER)
+                    (CLOSEFILE POINTER)
+                    (REOPENFILE POINTER)
+                    (GETFILENAME POINTER)
+                    (DELETEFILE POINTER)
+                    (GENERATEFILES POINTER)
+                    (RENAMEFILE POINTER)
+                    (OPENP POINTER)
+                    (REGISTERFILE POINTER)
+                    (UNREGISTERFILE POINTER)
+                    (FREEPAGECOUNT POINTER)
+                    (MAKEDIRECTORY POINTER)
+                    (CHECKFILENAME POINTER)
+                    (HOSTALIVEP POINTER)
+                    (BREAKCONNECTION POINTER)
+                    (BIN POINTER)
+                    (BOUT POINTER)
+                    (PEEKBIN POINTER)
+                    (READCHAR POINTER)
+                    (WRITECHAR POINTER)
+                    (PEEKCHAR POINTER)
+                    (UNREADCHAR POINTER)
+                    (READP POINTER)
+                    (EOFP POINTER)
+                    (BLOCKIN POINTER)
+                    (BLOCKOUT POINTER)
+                    (FORCEOUTPUT POINTER)
+                    (GETFILEINFO POINTER)
+                    (SETFILEINFO POINTER)
+                    (CHARSETFN POINTER)
+                    (INPUTSTREAM POINTER)
+                    (OUTPUTSTREAM POINTER)
+                    (GETFILEPTR POINTER)
+                    (GETEOFPTR POINTER)
+                    (SETFILEPTR POINTER)
+                    (BACKFILEPTR POINTER)
+                    (SETEOFPTR POINTER)
+                    (LASTC POINTER)
+                    (GETNEXTBUFFER POINTER)
+                    (RELEASEBUFFER POINTER)
+                    (READPAGES POINTER)
+                    (WRITEPAGES POINTER)
+                    (TRUNCATEFILE POINTER)
+                    (WINDOWOPS POINTER)
+                    (WINDOWDATA POINTER)
+                    (READCHARCODE POINTER)))
+)
+
+
+
+(* ; "EXTERNALFORMAT declaration and related functions")
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
+
+(DATATYPE EXTERNALFORMAT ((EOLVALID FLAG)                (* ; 
+     "If true, the value of EOL field will replace the EOLCONVENTION field of the resulted stream.")
+                              (EOL BITS 2)
+                              (NIL BITS 1)
+                              (INCCODEFN POINTER)            (* ; 
+                                                   "Called with two arguments -- STREAM and COUNTP")
+                              (PEEKCCODEFN POINTER)          (* ; 
+                                        "Called with three arguments -- STREAM, NOERROR and COUNTP")
+                              (BACKCHARFN POINTER)           (* ; 
+                                                   "Called with two arguments -- STREAM and COUNTP")
+                              (FILEOUTCHARFN POINTER)        (* ; 
+                                                 "Called with two arguments -- STREAM and CHARCODE")
+                              )
+                             EOLVALID _ NIL)
+)
+
+(/DECLAREDATATYPE 'EXTERNALFORMAT '(FLAG (BITS 2)
+                                         (BITS 1)
+                                         POINTER POINTER POINTER POINTER)
+       '((EXTERNALFORMAT 0 (FLAGBITS . 0))
+         (EXTERNALFORMAT 0 (BITS . 17))
+         (EXTERNALFORMAT 0 (BITS . 48))
+         (EXTERNALFORMAT 0 POINTER)
+         (EXTERNALFORMAT 2 POINTER)
+         (EXTERNALFORMAT 4 POINTER)
+         (EXTERNALFORMAT 6 POINTER))
+       '8)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+
+(/DECLAREDATATYPE 'EXTERNALFORMAT '(FLAG (BITS 2)
+                                         (BITS 1)
+                                         POINTER POINTER POINTER POINTER)
+       '((EXTERNALFORMAT 0 (FLAGBITS . 0))
+         (EXTERNALFORMAT 0 (BITS . 17))
+         (EXTERNALFORMAT 0 (BITS . 48))
+         (EXTERNALFORMAT 0 POINTER)
+         (EXTERNALFORMAT 2 POINTER)
+         (EXTERNALFORMAT 4 POINTER)
+         (EXTERNALFORMAT 6 POINTER))
+       '8)
+(ADDTOVAR SYSTEMRECLST
+
+(DATATYPE EXTERNALFORMAT ((EOLVALID FLAG)
+                              (EOL BITS 2)
+                              (NIL BITS 1)
+                              (INCCODEFN POINTER)
+                              (PEEKCCODEFN POINTER)
+                              (BACKCHARFN POINTER)
+                              (FILEOUTCHARFN POINTER)))
+)
+(DEFINEQ
+
+(\INSTALL.EXTERNALFORMAT
+(LAMBDA (NAME EXTERNALFORMAT) (* ; "Edited 26-Feb-91 17:33 by nm") (* ;;; "Install an external format vector, giving it the name NAME.  EXTERNALFORMAT is an instance of the datatype EXTERNALFORMAT.   *SUPPORTED-EXTERNALFORMATS* contains all installed external formats.   *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT* maps a name int its external format.") (DECLARE (GLOBALVARS *SUPPORTED-EXTERNALFORMATS* *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*)) (COND ((type? EXTERNALFORMAT EXTERNALFORMAT) (LET (ENTRY) (SETQ NAME (COND ((LITATOM NAME) NAME) (T (MKATOM NAME)))) (UNINTERRUPTABLY (COND ((SETQ ENTRY (FASSOC NAME *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*)) (RPLACD ENTRY EXTERNALFORMAT)) (T (pushnew *SUPPORTED-EXTERNALFORMATS* NAME) (push *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT* (CONS NAME EXTERNALFORMAT)))) NAME))) (T (ERROR "INVALID EXTERNALFORMAT " EXTERNALFORMAT))))
+)
+
+(\REMOVE.EXTERNALFORMAT
+(LAMBDA (EXTERNALFORMAT) (* ; "Edited 26-Feb-91 17:34 by nm") (* ;;; "Removes externalformat EXTERNALFORMAT and association between any of its name and EXTERNALFORMAT.") (DECLARE (GLOBALVARS *SUPPORTED-EXTERNALFORMATS* *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*)) (LET (ENTRY) (COND ((SETQ ENTRY (CL:RASSOC EXTERNALFORMAT *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*)) (UNINTERRUPTABLY (SETQ *SUPPORTED-EXTERNALFORMATS* (DREMOVE (CAR ENTRY) *SUPPORTED-EXTERNALFORMATS*)) (SETQ *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT* (DREMOVE ENTRY *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*))))) EXTERNALFORMAT))
+)
+
+(\GET.EXTERNALFORMAT.FROM.NAME
+(LAMBDA (NAME) (DECLARE (GLOBALVARS *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*)) (* ; "Edited 26-Feb-91 17:33 by nm") (SETQ NAME (COND ((LITATOM NAME) NAME) (T (MKATOM NAME)))) (CDR (FASSOC NAME *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*)))
+)
+
+(\EXTERNALFORMAT
+(LAMBDA (STREAM NEWVALUE) (* ; "Edited 26-Feb-91 13:20 by nm") (* ;;; "If NEWVALUE is nil, just returns the current external format name of STREAM.  If NEWVALUE is supplied, the external format of STREAM is set to the external format named NEWVALUE.") (\DTEST STREAM (QUOTE STREAM)) (COND (NEWVALUE (COND ((FMEMB NEWVALUE (QUOTE (:XCCS :DEFAULT)) (freplace (STREAM NOTXCCS) of STREAM with NIL))) ((FMEMB NEWVALUE *SUPPORTED-EXTERNALFORMATS*) (freplace EXTERNALFORMAT.NAME of STREAM with NEWVALUE) (freplace EXTERNALFORMAT of STREAM with (\DTEST (\GET.EXTERNALFORMAT.FROM.NAME NEWVALUE) (QUOTE EXTERNALFORMAT)))) (T (ERROR NEWVALUE "INVALID EXTERNALFORMAT " NEWVALUE)))) (T (COND ((ffetch (STREAM NOTXCCS) of STREAM) (ffetch EXTERNALFORMAT.NAME of STREAM)) (T :DEFAULT)))))
+)
+)
+
+(RPAQ? *SUPPORTED-EXTERNALFORMATS* '(:XCCS :DEFAULT))
+
+(RPAQ? *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT* )
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS *SUPPORTED-EXTERNALFORMATS* *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*)
+)
+(DEFINEQ
+
+(\CREATE.JIS.EXTERNALFORMAT
+(LAMBDA NIL (* ; "Edited 25-Feb-91 17:21 by nm") (* ;;; "Create an instance of EXTERNALFORMAT datatype and install it with :JIS as its name.") (LET ((XFMT (create EXTERNALFORMAT INCCODEFN _ (FUNCTION \JISIN) PEEKCCODEFN _ (FUNCTION \JISPEEK) BACKCHARFN _ (FUNCTION \BACKJISCHAR) FILEOUTCHARFN _ (FUNCTION \JISFILEOUTCHARFN)))) (\INSTALL.EXTERNALFORMAT :JIS XFMT)))
+)
+
+(\CREATE.SHIFTJIS.EXTERNALFORMAT
+(LAMBDA NIL (* ; "Edited 25-Feb-91 18:15 by nm") (* ;;; "Create two instances of EXTERNALFORMAT datatype and install them with :W-MS and :MS as their names respectively.  :MS have to change the end of line convention to CRLF.") (LET ((XFMT1 (create EXTERNALFORMAT INCCODEFN _ (FUNCTION \SHIFTJISIN) PEEKCCODEFN _ (FUNCTION \SHIFTJISPEEK) BACKCHARFN _ (FUNCTION \BACKSHIFTJISCHAR) FILEOUTCHARFN _ (FUNCTION \SHIFTJISFILEOUTCHARFN))) (XFMT2 (create EXTERNALFORMAT INCCODEFN _ (FUNCTION \SHIFTJISIN) PEEKCCODEFN _ (FUNCTION \SHIFTJISPEEK) BACKCHARFN _ (FUNCTION \BACKSHIFTJISCHAR) FILEOUTCHARFN _ (FUNCTION \SHIFTJISFILEOUTCHARFN) EOLVALID _ T EOL _ CRLF.EOLC))) (\INSTALL.EXTERNALFORMAT :W-MS XFMT1) (\INSTALL.EXTERNALFORMAT :MS XFMT2)))
+)
+
+(\CREATE.EUC.EXTERNALFORMAT
+(LAMBDA NIL (* ; "Edited 25-Feb-91 17:27 by nm") (* ;;; "Create an instance of EXTERNALFORMAT datatype and install it with :EUC as its name.") (LET ((XFMT (create EXTERNALFORMAT INCCODEFN _ (FUNCTION \EUCIN) PEEKCCODEFN _ (FUNCTION \EUCPEEK) BACKCHARFN _ (FUNCTION \BACKEUCCHAR) FILEOUTCHARFN _ (FUNCTION \EUCFILEOUTCHARFN)))) (\INSTALL.EXTERNALFORMAT :EUC XFMT)))
+)
+
+(\CREATE.THROUGH.EXTERNALFORMAT
+(LAMBDA NIL (* ; "Edited 26-Feb-91 13:33 by nm") (* ;;; "Create an instance of EXTERNALFORMAT datatype and install it with :THROUGH as its name.  EOL is adjusted to CR so as not to do any eol conversion on this stream.") (LET ((XFMT (create EXTERNALFORMAT INCCODEFN _ (FUNCTION \THROUGHIN) PEEKCCODEFN _ (FUNCTION \THROUGHPEEK) BACKCHARFN _ (FUNCTION \BACKTHROUGHCHAR) FILEOUTCHARFN _ (FUNCTION \THROUGHFILEOUTCHARFN) EOLVALID _ T EOL _ CR.EOLC))) (\INSTALL.EXTERNALFORMAT :THROUGH XFMT)))
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(\CREATE.JIS.EXTERNALFORMAT)
+
+(\CREATE.SHIFTJIS.EXTERNALFORMAT)
+
+(\CREATE.EUC.EXTERNALFORMAT)
+
+(\CREATE.THROUGH.EXTERNALFORMAT)
+)
+
+
+
+(* ; "Device operations")
+
+(DEFINEQ
+
+(\DEFINEDEVICE
+(LAMBDA (NAME DEV) (* bvm%: " 5-APR-83 15:33") (* ;; "NIL DEV removes any device associated with NAME.  NIL NAME simply adds the device without associating a name with it.  This is useful for getting its EVENTFN invoked.  A litatom DEV makes NAME be a synonym for the device currently named DEV --- \FILEDEVICES contains each device only once, \FILEDEVICENAMES contains each name device/host name only once (for spelling correction), and \DEVICENAMETODEVICE maps a name into its device.") (DECLARE (GLOBALVARS \FILEDEVICES \FILEDEVICENAMES \DEVICENAMETODEVICE)) (PROG (TEMP) (SETQ NAME (U-CASE NAME)) (* ; "Use upper-case canonical device names") RETRY (COND ((NULL DEV) (COND ((SETQ TEMP (FASSOC NAME \DEVICENAMETODEVICE)) (UNINTERRUPTABLY (SETQ \DEVICENAMETODEVICE (DREMOVE TEMP \DEVICENAMETODEVICE)) (SETQ \FILEDEVICENAMES (DREMOVE NAME \FILEDEVICENAMES)))))) ((type? FDEV DEV) (SETQ TEMP (FASSOC NAME \DEVICENAMETODEVICE)) (UNINTERRUPTABLY (COND ((NOT (FMEMB DEV \FILEDEVICES)) (COND (TEMP (SETQ \FILEDEVICES (DREMOVE (CDR TEMP) \FILEDEVICES)))) (* ; "Devices are stored in inverse order of their definition, for proper EVENTFN ordering.") (push \FILEDEVICES DEV))) (COND (NAME (pushnew \FILEDEVICENAMES NAME) (RPLACD (OR TEMP (CAR (push \DEVICENAMETODEVICE (CONS NAME)))) DEV))))) ((AND (LITATOM DEV) (SETQ TEMP (CDR (FASSOC (U-CASE DEV) \DEVICENAMETODEVICE)))) (SETQ DEV TEMP) (GO RETRY)) (T (SETQ DEV (ERROR "INVALID FILE DEVICE" DEV)) (GO RETRY))) (RETURN NAME)))
+)
+
+(\GETDEVICEFROMNAME
+(LAMBDA (NAME NOERROR DONTCREATE) (* lmm " 5-Oct-84 18:06") (* ;; "maps a filename (with host added) into a device") (OR (AND (OR (LITATOM NAME) (STRINGP NAME)) (LET ((HOST (FILENAMEFIELD NAME (QUOTE HOST)))) (\GETDEVICEFROMHOSTNAME (OR HOST NAME) DONTCREATE))) (AND (NOT NOERROR) (LISPERROR "FILE NOT FOUND" NAME))))
+)
+
+(\GETDEVICEFROMHOSTNAME
+(LAMBDA (HOSTN DONTCREATE) (DECLARE (GLOBALVARS \DEVICENAMETODEVICE \FILEDEVICES)) (* lmm " 5-Oct-84 14:36") (OR (CDR (FASSOC HOSTN \DEVICENAMETODEVICE)) (CDR (FASSOC (SETQ HOSTN (U-CASE HOSTN)) \DEVICENAMETODEVICE)) (AND (NOT DONTCREATE) (for D TEMP in \FILEDEVICES when (SETQ TEMP (FDEVOP (QUOTE HOSTNAMEP) D HOSTN D)) do (* ;; "HOSTNAMEP is a pure predicate if the second arg is NIL.  Here we give a device, which indicates that we are not just a predicate, but in fact would like a new device back, possibly constructed from the old one.  A device value is installed with the new hostname;  a T value means install with D.") (COND ((type? FDEV TEMP) (SETQ D TEMP))) (\DEFINEDEVICE HOSTN D) (RETURN D)))))
+)
+
+(\REMOVEDEVICE
+(LAMBDA (DEV) (* bvm%: " 3-NOV-83 23:17") (* ;; "Removes device DEV and also any association between any of its name and DEV") (DECLARE (GLOBALVARS \FILEDEVICES \FILEDEVICENAMES \DEVICENAMETODEVICE)) (PROG (TEMP) (UNINTERRUPTABLY (while (SETQ TEMP (find PAIR in \DEVICENAMETODEVICE suchthat (EQ (CDR PAIR) DEV))) do (SETQ \FILEDEVICENAMES (DREMOVE (CAR TEMP) \FILEDEVICENAMES)) (SETQ \DEVICENAMETODEVICE (DREMOVE TEMP \DEVICENAMETODEVICE))) (SETQ \FILEDEVICES (DREMOVE DEV \FILEDEVICES))) (RETURN DEV)))
+)
+
+(\REMOVEDEVICE.NAMES
+(LAMBDA (DEV NAMES) (* bvm%: "30-Jan-85 21:53") (DECLARE (GLOBALVARS \DEVICENAMETODEVICE \FILEDEVICENAMES)) (* ;;; "removes any names associated with device DEV without actually removing the device itself.  If NAMES is non-NIL, removes only the names inside it") (for TAIL on \DEVICENAMETODEVICE bind CHANGED when (AND (EQ (CDAR TAIL) DEV) (OR (NULL NAMES) (EQMEMB (CAAR TAIL) NAMES))) do (SETQ \FILEDEVICENAMES (DREMOVE (CAAR TAIL) \FILEDEVICENAMES)) (RPLACA TAIL NIL) (SETQ CHANGED T) finally (COND (CHANGED (SETQ \DEVICENAMETODEVICE (DREMOVE NIL \DEVICENAMETODEVICE))))))
+)
+)
+(DEFINEQ
+
+(\CLOSEFILE
+(LAMBDA (STREAM ABORTFLG) (* ; "Edited  8-May-87 16:35 by bvm") (* ;; "Close the file specified by the given open file descriptor and return the file handle.") (COND ((NOT (READONLY STREAM)) (IMAGEOP (QUOTE IMCLOSEFN) STREAM STREAM) (* ; "Do image-specific operations before physically closing the stream"))) (LET ((DEVICE (fetch (STREAM DEVICE) of STREAM))) (PROG1 (FDEVOP (QUOTE CLOSEFILE) DEVICE STREAM ABORTFLG) (FDEVOP (QUOTE UNREGISTERFILE) DEVICE DEVICE STREAM) (replace (STREAM ACCESS) of STREAM with NIL) (* ; "This marks the STREAM as closed"))))
+)
+
+(\DELETEFILE
+(LAMBDA (FILENAME DEV) (* hdj "13-Jun-86 14:36") (SETQ FILENAME (\ADD.CONNECTED.DIR (\CONVERT-PATHNAME FILENAME))) (AND (OR DEV (SETQ DEV (\GETDEVICEFROMNAME FILENAME T))) (FDEVOP (QUOTE DELETEFILE) DEV FILENAME DEV)))
+)
+
+(\DEVICEEVENT
+(LAMBDA (EVENT) (* ; "Edited 20-Aug-88 18:08 by bvm") (* ;; "Executes device-dependent event code so all devices can respond to various system transition events (LOGOUT, MAKESYS, etc.) Before an event, devices are considered in the inverse order of their definition, so that older devices get processed later.  The order is reversed for after-events.") (DECLARE (GLOBALVARS \FILEDEVICES)) (LET ((BEFOREP (SELECTQ EVENT ((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT BEFORESAVEVM) T) NIL))) (for D in (if BEFOREP then \FILEDEVICES else (REVERSE \FILEDEVICES)) do (FDEVOP (QUOTE EVENTFN) D D EVENT) (if BEFOREP then (* ;; "Mark output files as needing revalidation if we write to them again.  This is so that if you do a SAVEVM, then write to the file some more, then boot back to the SAVEVM, that the AFTERSAVEVM event will notice that the stream has changed.") (* ;; "Don't do this until AFTER we've run the eventfn because, e.g., the eventfn might have done a forceoutput on the stream, thereby prematurely observing this flag.") (for STREAM in (FDEVOP (QUOTE OPENP) D NIL (QUOTE OUTPUT) D) unless (fetch (STREAM NONDEFAULTDATEFLG) of STREAM) do (replace (STREAM REVALIDATEFLG) of STREAM with T))))))
+)
+
+(\GENERATEFILES
+(LAMBDA (PATTERN DESIREDPROPS OPTIONS) (* bvm%: "27-Apr-84 23:21") (* ;; "Returns a file-generator object that will generate all files whose names match PATTERN.  A gen-object consists of a device dependent NEXTFILEFN and GENFILESTATE") (SETQ PATTERN (\ADD.CONNECTED.DIR PATTERN)) (PROG ((FDEV (\GETDEVICEFROMNAME PATTERN))) (RETURN (FDEVOP (QUOTE GENERATEFILES) FDEV FDEV PATTERN DESIREDPROPS OPTIONS))))
+)
+
+(\GENERATENEXTFILE
+(LAMBDA (GENOBJ NAMEONLY) (* bvm%: " 8-Jul-85 19:30") (* ;; "GENOBJ is a file-generator object as created by \GENERATEFILES.  The NEXTFILEFN must return the name of the next file generated by the generator, as a string or symbol.  Returns NIL if no files left.  It updates GENOBJ so that it will get the following satisfactory file on the next call to this function.  --- If NAMEONLY, then filenames returned need not contain host, directory or version") (CL:FUNCALL (fetch NEXTFILEFN of GENOBJ) (fetch GENFILESTATE of GENOBJ) NAMEONLY))
+)
+
+(\GENERATEFILEINFO
+(LAMBDA (GENOBJ ATTRIBUTE) (* bvm%: "26-Apr-84 15:40") (* ;; "GENOBJ is a file-generator object as created by \GENERATEFILES.  The FILEINFOFN performs a GETFILEINFO on the file which is the currently enumerated file, i.e., the last thing that NEXTFILEFN returned") (CL:FUNCALL (fetch FILEINFOFN of GENOBJ) (fetch GENFILESTATE of GENOBJ) ATTRIBUTE))
+)
+
+(\GETFILENAME
+(LAMBDA (NAME RECOG FDEV) (* hdj " 4-Sep-86 15:22") (* ;; "Expands NAME according to recog, returning either the full NAME or NIL.") (SETQ NAME (\ADD.CONNECTED.DIR (\CONVERT-PATHNAME NAME))) (COND ((OR FDEV (SETQ FDEV (\GETDEVICEFROMNAME NAME T))) (FDEVOP (QUOTE GETFILENAME) FDEV NAME RECOG FDEV))))
+)
+
+(\GENERIC.READCCODE
+(LAMBDA (FILE RDTBL) (* ; "Edited 13-Jan-88 10:04 by jds") (* ;;; "returns a 16 bit character code.  \INCHAR does the EOL conversion and this function converts to a 16 bit value.  Saves the character for LASTC as well.") (* ;; "This is the GENERIC method for READCCODE.") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (\RefillBufferFn (FUNCTION \READCREFILL)) (STREAM (\INSTREAMARG FILE))) (DECLARE (SPECVARS *READTABLE* \RefillBufferFn)) (replace (STREAM LASTCCODE) of STREAM with (\INCCODE STREAM))))
+)
+
+(\GENERIC.OUTFILEP
+(LAMBDA (NAME DEV) (* lmm " 6-Jan-85 17:41") (PROG ((V (FDEVOP (QUOTE GETFILENAME) DEV NAME (QUOTE OLD) DEV))) (RETURN (if V then (PACKFILENAME (QUOTE VERSION) (ADD1 (OR (FILENAMEFIELD V (QUOTE VERSION)) 1)) (QUOTE BODY) V) else (PACKFILENAME (QUOTE VERSION) 1 (QUOTE BODY) NAME)))))
+)
+
+(\OPENFILE
+(LAMBDA (NAME ACCESS RECOG PARAMETERS) (* hdj "14-Oct-86 14:04") (* ;;; "Opens the file identified by NAME possibly expanded according to RECOG.  Returns an open stream for the file.  ACCESS is assumed to be one of INPUT, OUTPUT, BOTH, or APPEND.") (PROG (FDEV CDNAME STREAM) RETRY (COND ((type? STREAM NAME) (COND ((\IOMODEP NAME ACCESS T) (\DO.PARAMS.AT.OPEN NAME ACCESS PARAMETERS) (RETURN NAME)) (T (SETQ CDNAME NAME) (SETQ FDEV (fetch (STREAM DEVICE) of NAME))))) (T (SETQ CDNAME (\ADD.CONNECTED.DIR NAME)) (SETQ FDEV (\GETDEVICEFROMNAME CDNAME)))) (* ; "Keep NAME for possible error") (* ;; "The OPENFILE operation returns NIL if the file wasn't found, so the name is right for the not-found error.  That error must not be generated from inside the device, or spellfile would be too constrained.  The won't-open error may happen inside the device, if the device itself does some interlocking (e.g.  a file-server).  The generic code in OPENFILE may also generate that error, to enforce interlocks among files already opened in this Lisp.") (COND ((SETQ STREAM (FDEVOP (QUOTE OPENFILE) FDEV CDNAME ACCESS RECOG PARAMETERS FDEV)) (replace ACCESS of STREAM with ACCESS) (replace CPAGE of STREAM with (COND ((EQ ACCESS (QUOTE APPEND)) (fetch EPAGE of STREAM)) (T 0))) (replace COFFSET of STREAM with (COND ((EQ ACCESS (QUOTE APPEND)) (fetch EOFFSET of STREAM)) (T 0))) (\DO.PARAMS.AT.OPEN STREAM ACCESS PARAMETERS) (* ;; "register the file using its internal device's registerfile method instead of FDEV's; this is primarily for the benefit of the file cacher") (LET ((STREAM-FDEV (fetch (STREAM DEVICE) of STREAM))) (FDEVOP (QUOTE REGISTERFILE) STREAM-FDEV STREAM-FDEV STREAM)) (RETURN STREAM)) (T (SETQ NAME (LISPERROR "FILE NOT FOUND" NAME)) (GO RETRY)))))
+)
+
+(\DO.PARAMS.AT.OPEN
+  [LAMBDA (STREAM ACCESS PARAMETERS)                         (* ; "Edited  5-Oct-92 13:45 by jds")
+
+    (* ;; "Does generic parameters when a file/stream is open.  Called by \OPENFILE and OPENSTREAM")
+
+    (for X ATTR VAL in PARAMETERS do (COND
+                                                    [(LISTP X)
+                                                     (SETQ ATTR (CAR X))
+                                                     (SETQ VAL (CAR (LISTP (CDR X]
+                                                    (T (SETQ ATTR X)
+                                                       (SETQ VAL T)))
+                                                (SELECTQ ATTR
+                                                    (BUFFERS (SETFILEINFO STREAM 'BUFFERS VAL))
+                                                    (ENDOFSTREAMOP (SETFILEINFO STREAM
+                                                                          'ENDOFSTREAMOP VAL))
+                                                    (CHARSET (CHARSET STREAM VAL))
+                                                    (EXTERNALFORMAT 
+                                                         (\EXTERNALFORMAT STREAM VAL))
+                                                    (CONVHANKAKU (CONVHANKAKU STREAM VAL))
+                                                    ((EOL EOLCONVENTION EOLC) 
+                                                         (replace EOLCONVENTION of STREAM
+                                                            with (SELECTQ VAL
+                                                                         (CR CR.EOLC)
+                                                                         (LF LF.EOLC)
+                                                                         (CRLF CRLF.EOLC)
+                                                                         (\ILLEGAL.ARG VAL))))
+                                                    NIL])
+
+(\RENAMEFILE
+(LAMBDA (OLDFILE NEWFILE) (* hdj " 7-May-86 12:22") (SETQ OLDFILE (\ADD.CONNECTED.DIR OLDFILE)) (SETQ NEWFILE (\ADD.CONNECTED.DIR NEWFILE)) (LET ((OLD-DEVICE (\GETDEVICEFROMNAME OLDFILE T)) (NEW-DEVICE (\GETDEVICEFROMNAME NEWFILE T))) (AND OLD-DEVICE (FDEVOP (QUOTE RENAMEFILE) OLD-DEVICE OLD-DEVICE OLDFILE NEW-DEVICE NEWFILE))))
+)
+
+(\REVALIDATEFILE
+(LAMBDA (STREAM) (* bvm%: "30-DEC-81 17:45") (* ;; "Check the file to determine if it corresponds to the status information for it found in the STREAM and file handle.  Return DELETED if the file no longer exists, CHANGED if the file does not correspond to the status information, or NIL if everything is OK.") (PROG ((NEWSTREAM (FDEVOP (QUOTE REOPENFILE) (fetch DEVICE of STREAM) (fetch FULLFILENAME of STREAM) (fetch ACCESS of STREAM) (QUOTE OLD) NIL (fetch DEVICE of STREAM) STREAM))) (RETURN (COND ((NOT NEWSTREAM) (QUOTE DELETED)) ((EQ NEWSTREAM STREAM) (* ; "Nothing changed") NIL) (T (replace F1 of STREAM with (fetch F1 of NEWSTREAM)) (* ; "Copy 'device' information from the new opening to the old") (replace F2 of STREAM with (fetch F2 of NEWSTREAM)) (replace F3 of STREAM with (fetch F3 of NEWSTREAM)) (replace F4 of STREAM with (fetch F4 of NEWSTREAM)) (replace F5 of STREAM with (fetch F5 of NEWSTREAM)) (replace FW6 of STREAM with (fetch FW6 of NEWSTREAM)) (replace FW7 of STREAM with (fetch FW7 of NEWSTREAM)) (COND ((EQUAL (fetch VALIDATION of NEWSTREAM) (fetch VALIDATION of STREAM)) NIL) (T (replace VALIDATION of STREAM with (fetch VALIDATION of NEWSTREAM)) (replace EPAGE of STREAM with (fetch EPAGE of NEWSTREAM)) (replace EOFFSET of STREAM with (fetch EOFFSET of NEWSTREAM)) (QUOTE CHANGED))))))))
+)
+
+(\PAGED.REVALIDATEFILELST
+(LAMBDA (DEVICE) (* hdj "30-Sep-86 15:23") (* ;;; "Revalidate all of the open files on DEVICE (a PMAP device)") (bind REASON PAGES for STREAM in (FDEVOP (QUOTE OPENP) DEVICE NIL NIL DEVICE) do (if (SETQ REASON (\PAGED.REVALIDATEFILE STREAM)) then (SELECTQ REASON (CHANGED (* ; "it changed 
+
+update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disappeared, so zap the stream") (SETQ PAGES (FORGETPAGES STREAM)) (MAPC (STREAMPROP STREAM (QUOTE AFTERCLOSE)) (FUNCTION (LAMBDA (FN) (APPLY* FN STREAM)))) (replace ACCESS of STREAM with NIL) (FDEVOP (QUOTE UNREGISTERFILE) DEVICE DEVICE STREAM)) (SHOULDNT)) (\PRINT-REVALIDATION-RESULT REASON STREAM))) (* ; "might as well return something useful") (FDEVOP (QUOTE OPENP) DEVICE NIL NIL DEVICE))
+)
+
+(\PAGED.REVALIDATEFILES
+(LAMBDA (LIST) (* hdj "30-Sep-86 15:18") (* ;;; "Revalidate all of the open files on LIST;  they are all PMAPped streams") (LET ((NEWLIST (COPY LIST))) (bind REASON PAGES for STREAM in LIST do (if (SETQ REASON (\PAGED.REVALIDATEFILE STREAM)) then (SELECTQ REASON (CHANGED (* ; "it changed - update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disappeared, so zap the stream") (SETQ PAGES (FORGETPAGES STREAM)) (MAPC (STREAMPROP STREAM (QUOTE AFTERCLOSE)) (FUNCTION (LAMBDA (FN) (APPLY* FN STREAM)))) (replace ACCESS of STREAM with NIL) (LET ((DEVICE (fetch (STREAM DEVICE) of STREAM))) (FDEVOP (QUOTE UNREGISTERFILE) DEVICE DEVICE STREAM)) (SETQ NEWLIST (DREMOVE STREAM NEWLIST))) (SHOULDNT)) (\PRINT-REVALIDATION-RESULT REASON STREAM))) (* ;;; "return the remaining files") NEWLIST))
+)
+
+(\PAGED.REVALIDATEFILE
+(LAMBDA (STREAM) (* hdj "23-May-86 14:14") (* ;; "Check the file to determine if it corresponds to the status information for it found in the STREAM and file handle.  Return DELETED if the file no longer exists, CHANGED if the file does not correspond to the status information, or NIL if everything is OK") (LET ((NEWSTREAM (FDEVOP (QUOTE REOPENFILE) (fetch DEVICE of STREAM) (fetch FULLFILENAME of STREAM) (fetch ACCESS of STREAM) (QUOTE OLD) NIL (fetch DEVICE of STREAM) STREAM))) (COND ((NOT NEWSTREAM) (QUOTE DELETED)) ((EQ NEWSTREAM STREAM) (* ; "Nothing changed") NIL) (T (replace F1 of STREAM with (fetch F1 of NEWSTREAM)) (* ; "Copy 'device' information from the new opening to the old") (replace F2 of STREAM with (fetch F2 of NEWSTREAM)) (replace F3 of STREAM with (fetch F3 of NEWSTREAM)) (replace F4 of STREAM with (fetch F4 of NEWSTREAM)) (replace F5 of STREAM with (fetch F5 of NEWSTREAM)) (replace FW6 of STREAM with (fetch FW6 of NEWSTREAM)) (replace FW7 of STREAM with (fetch FW7 of NEWSTREAM)) (COND ((EQUAL (fetch VALIDATION of NEWSTREAM) (fetch VALIDATION of STREAM)) NIL) (T (replace VALIDATION of STREAM with (fetch VALIDATION of NEWSTREAM)) (replace EPAGE of STREAM with (fetch EPAGE of NEWSTREAM)) (replace EOFFSET of STREAM with (fetch EOFFSET of NEWSTREAM)) (QUOTE CHANGED)))))))
+)
+
+(\BUFFERED.REVALIDATEFILE
+(LAMBDA (STREAM) (* hdj "23-May-86 14:14") (* ;; "Check the file to determine if it corresponds to the status information for it found in the STREAM and file handle.  Return DELETED if the file no longer exists, CHANGED if the file does not correspond to the status information, or NIL if everything is OK") (LET ((NEWSTREAM (FDEVOP (QUOTE REOPENFILE) (fetch DEVICE of STREAM) (fetch FULLFILENAME of STREAM) (fetch ACCESS of STREAM) (QUOTE OLD) NIL (fetch DEVICE of STREAM) STREAM))) (COND ((NOT NEWSTREAM) (QUOTE DELETED)) ((EQ NEWSTREAM STREAM) (* ; "Nothing changed") NIL) (T (replace F1 of STREAM with (fetch F1 of NEWSTREAM)) (* ; "Copy 'device' information from the new opening to the old") (replace F2 of STREAM with (fetch F2 of NEWSTREAM)) (replace F3 of STREAM with (fetch F3 of NEWSTREAM)) (replace F4 of STREAM with (fetch F4 of NEWSTREAM)) (replace F5 of STREAM with (fetch F5 of NEWSTREAM)) (replace FW6 of STREAM with (fetch FW6 of NEWSTREAM)) (replace FW7 of STREAM with (fetch FW7 of NEWSTREAM)) (COND ((EQUAL (fetch VALIDATION of NEWSTREAM) (fetch VALIDATION of STREAM)) NIL) (T (replace VALIDATION of STREAM with (fetch VALIDATION of NEWSTREAM)) (replace EPAGE of STREAM with (fetch EPAGE of NEWSTREAM)) (replace EOFFSET of STREAM with (fetch EOFFSET of NEWSTREAM)) (QUOTE CHANGED)))))))
+)
+
+(\BUFFERED.REVALIDATEFILELST
+(LAMBDA (DEVICE) (* hdj "30-Sep-86 15:16") (* ;;; "Revalidate all of the open files on DEVICE (a buffered device)") (bind REASON for STREAM in (FDEVOP (QUOTE OPENP) DEVICE NIL NIL DEVICE) do (if (SETQ REASON (\BUFFERED.REVALIDATEFILE STREAM)) then (SELECTQ REASON ((DELETED CHANGED) (* ; "the file changed or disappeared, so zap the stream") (MAPC (STREAMPROP STREAM (QUOTE AFTERCLOSE)) (FUNCTION (LAMBDA (FN) (APPLY* FN STREAM)))) (replace ACCESS of STREAM with NIL) (FDEVOP (QUOTE UNREGISTERFILE) DEVICE DEVICE STREAM) (\PRINT-REVALIDATION-RESULT REASON STREAM)) (SHOULDNT)))) (* ;; "might as well return something useful") (FDEVOP (QUOTE OPENP) DEVICE NIL NIL DEVICE))
+)
+
+(\PRINT-REVALIDATION-RESULT
+(LAMBDA (RESULT STREAM) (* hdj "26-May-86 15:46") (printout T T T "**** WARNING:  The file " (fetch (STREAM FULLNAME) of STREAM)) (SELECTQ RESULT (CHANGED (printout T " has been modified since you last accessed it!" T)) (DELETED (printout T " was previously opened but has disappeared!" T)) (SHOULDNT)))
+)
+
+(\TRUNCATEFILE
+(LAMBDA (STREAM LASTPAGE LASTOFFSET) (* bvm%: " 8-MAY-82 16:11") (* ;; "Shorten an open file to have the given last page and offset.  Last page = NIL means to truncate to the current length, which some devices may interpret as a noop") (FDEVOP (QUOTE TRUNCATEFILE) (fetch DEVICE of STREAM) STREAM LASTPAGE LASTOFFSET))
+)
+
+(\FILE-CONFLICT
+(LAMBDA (NAME ACCESS DEVICE) (* ; "Edited 14-Apr-87 18:07 by jop") (* ;; "returns NIL if there's no conflict between the access mode of the file we're about to open and the ones already open there's no conflict if there are none already open, or if the ones already open are open for input, and so's the candidate") (LET* ((FILENAME (if (type? STREAM NAME) then (fetch (STREAM FULLFILENAME) of NAME) else NAME)) (STREAMS-FOR-THIS-FILE (FDEVOP (QUOTE OPENP) DEVICE FILENAME NIL DEVICE))) (if STREAMS-FOR-THIS-FILE then (LET ((EXISTING-ACCESS-MODE (fetch (STREAM ACCESS) of (CAR STREAMS-FOR-THIS-FILE)))) (if (NEQ ACCESS EXISTING-ACCESS-MODE) then T elseif (EQ ACCESS (QUOTE INPUT)) then NIL else (NEQ NAME (CAR STREAMS-FOR-THIS-FILE)))) else NIL)))
+)
+)
+
+
+
+(* ; "Generic enumerator")
+
+(DEFINEQ
+
+(\GENERATENOFILES
+(LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* bvm%: " 5-Jun-84 16:31") (* ;; "A dummy function to be used by devices that don't support directory generation.  This produces a generate that generates no files.") (PROG ((STAR (STRPOS (QUOTE *) PATTERN)) (ESC (STRPOS (QUOTE (CONSTANT (CHARACTER (CHARCODE ESC)))) PATTERN))) (RETURN (COND ((AND (OR (NULL STAR) (AND (EQ (NTHCHARCODE PATTERN (SUB1 STAR)) (CHARCODE ;)) (NULL (STRPOS (QUOTE *) PATTERN (ADD1 STAR))))) (OR (NULL ESC) (AND (EQ (NTHCHARCODE PATTERN (SUB1 ESC)) (CHARCODE ;)) (NULL (STRPOS (CONSTANT (CHARACTER (CHARCODE ESC))) PATTERN (ADD1 ESC)))))) (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \NOFILESNEXTFILEFN) FILEINFOFN _ (FUNCTION \NOFILESINFOFN) GENFILESTATE _ (create NOFILEGENSTATE NOFILETYPE _ (COND ((AND (NULL STAR) (NULL ESC)) (QUOTE NOSTAR)) (T (SETQ PATTERN (PACKFILENAME (QUOTE VERSION) NIL (QUOTE BODY) PATTERN)) (QUOTE STAR))) NOFILEPATTERN _ PATTERN))) (T (\NULLFILEGENERATOR))))))
+)
+
+(\NULLFILEGENERATOR
+(LAMBDA NIL (* bvm%: " 5-Jun-84 15:46") (* ;; "A file generator that generates no files") (create FILEGENOBJ NEXTFILEFN _ (FUNCTION NILL)))
+)
+
+(\NOFILESNEXTFILEFN
+(LAMBDA (GENFILESTATE NAMEONLY) (* bvm%: " 8-Jul-85 19:28") (PROG (FILE TYPE) (SELECTQ (SETQ TYPE (fetch NOFILETYPE of GENFILESTATE)) (NOSTAR (replace NOFILETYPE of GENFILESTATE with (QUOTE DONE)) (SETQ FILE (INFILEP (fetch NOFILEPATTERN of GENFILESTATE)))) (DONE (RETURN NIL)) (STAR (* ;; "Star in version field.  Start out by producing the oldest file, and note its version and the version of the newest file for subsequent enumeration") (SETQ FILE (FULLNAME (fetch NOFILEPATTERN of GENFILESTATE) (QUOTE OLDEST))) (replace NOFILETYPE of GENFILESTATE with (CONS (FILENAMEFIELD FILE (QUOTE VERSION)) (FILENAMEFIELD (INFILEP (fetch NOFILEPATTERN of GENFILESTATE)) (QUOTE VERSION))))) (PROG ((VER (ADD1 (CAR TYPE)))) (* ;; "TYPE is a dotted pair of versions (old . newest) -- test INFILEP for each version number after old until we get to newest") LP (COND ((IGREATERP VER (CDR TYPE)) (RETURN NIL)) ((SETQ FILE (INFILEP (PACKFILENAME.STRING (QUOTE VERSION) VER (QUOTE BODY) (fetch NOFILEPATTERN of GENFILESTATE)))) (RPLACA TYPE (FILENAMEFIELD FILE (QUOTE VERSION)))) (T (add VER 1) (GO LP))))) (RETURN (COND (FILE (replace NOFILENAME of GENFILESTATE with FILE) FILE)))))
+)
+
+(\NOFILESINFOFN
+(LAMBDA (GENSTATE ATTRIBUTE) (* bvm%: "27-Apr-84 22:17") (* ;;; "Fileinfo fn for getting attributes of the file currently enumerated -- go thru the generic GETFILEINFO") (GETFILEINFO (fetch NOFILENAME of GENSTATE) ATTRIBUTE))
+)
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE
+
+(RECORD NOFILEGENSTATE (NOFILETYPE NOFILEPATTERN . NOFILENAME))
+)
+)
+(DEFINEQ
+
+(\FILE.NOT.OPEN
+(LAMBDA (X NOERROR) (* hdj "17-Jun-86 18:28") (* ;; "Returns NIL of NOERROR, otherwise causes the FILE NOT OPEN error.  Used by \GETSTREAM.  \STREAM.NOT.OPEN doesn't take NOERROR arg.") (AND (NULL NOERROR) (LISPERROR "FILE NOT OPEN" (COND ((type? STREAM X) (fetch (STREAM FULLNAME) of X)) (T X)))))
+)
+
+(\FILE.WONT.OPEN
+(LAMBDA (X) (* hdj "17-Jun-86 18:32") (LISPERROR "FILE WON'T OPEN" (COND ((type? STREAM X) (fetch (STREAM FULLNAME) of X)) (T X))))
+)
+
+(\ILLEGAL.DEVICEOP
+(LAMBDA N (* bvm%: "28-DEC-81 15:44") (ERROR "Attempt to use undefined device operation" (for I from 1 to N collect (ARG N I))))
+)
+
+(\IS.NOT.RANDACCESSP
+(LAMBDA N (* hdj "17-Jun-86 18:32") (PROG ((THING (ARG N 1))) (RETURN (ERROR "File is not RANDACCESSP" (COND ((type? STREAM THING) (fetch (STREAM FULLNAME) of THING)) (T THING))))))
+)
+
+(\STREAM.NOT.OPEN
+(LAMBDA (STREAM) (* hdj "17-Jun-86 18:32") (* ;; "Can be used as BIN/BOUT function.  \FILE.NOT.OPEN accepts more than just a stream, and also has NOERROR control") (LISPERROR "FILE NOT OPEN" (fetch (STREAM FULLNAME) of STREAM)))
+)
+)
+
+(ADDTOVAR \FILEDEVICES )
+
+(ADDTOVAR \FILEDEVICENAMES )
+
+(ADDTOVAR \DEVICENAMETODEVICE )
+
+
+
+(* ; "Device instances")
+
+(DEFINEQ
+
+(\FDEVINSTANCE
+(LAMBDA (FDEV) (* gbn "16-Sep-85 18:09") (* ;; "Creates an 'instance' of FDEV, a distinct device that executes all the operations of FDEV, but which can be smashed to change those operations in order to specialize streams.  --- \INHERITFDEVOP.S and .D are macros that expect the device to be found from a STREAM or FDEV argument, respectively.  Only operations that relate to streams are included, since non-stream device operations will be obtained from the original device, whose name is registered.") (create FDEV using FDEV DEVICEINFO _ FDEV CLOSEFILE _ (\INHERITFDEVOP.S CLOSEFILE STREAM) GETFILEINFO _ (\INHERITFDEVOP.D GETFILEINFO STREAM ATTRIB FDEV) OPENFILE _ (\INHERITFDEVOP.D OPENFILE CDNAME ACCESS RECOG OTHERINFO FDEV) READPAGES _ (\INHERITFDEVOP.S READPAGES STREAM FIRSTPAGE BUFFERLIST) SETFILEINFO _ (\INHERITFDEVOP.D SETFILEINFO STREAM ATTRIBUTE VALUE FDEV) TRUNCATEFILE _ (\INHERITFDEVOP.S TRUNCATEFILE STREAM LASTPAGE LASTOFFSET) WRITEPAGES _ (\INHERITFDEVOP.S WRITEPAGES STREAM FIRSTPAGE BUFFERLIST) REOPENFILE _ (\INHERITFDEVOP.D REOPENFILE NAME ACCESS RECOG OTHERINFO FDEV OLDSTREAM) BIN _ (\INHERITFDEVOP.S BIN STREAM) BOUT _ (\INHERITFDEVOP.S BOUT STREAM BYTE) PEEKBIN _ (\INHERITFDEVOP.S PEEKBIN STREAM NOERRORFLG) BACKFILEPTR _ (\INHERITFDEVOP.S BACKFILEPTR STREAM) SETFILEPTR _ (\INHERITFDEVOP.S SETFILEPTR STREAM INDX) GETFILEPTR _ (\INHERITFDEVOP.S GETFILEPTR STREAM) GETEOFPTR _ (\INHERITFDEVOP.S GETEOFPTR STREAM) EOFP _ (\INHERITFDEVOP.S EOFP STREAM) BLOCKIN _ (\INHERITFDEVOP.S BLOCKIN STREAM BASE OFFSET NBYTES) BLOCKOUT _ (\INHERITFDEVOP.S BLOCKOUT STREAM BASE OFFSET NBYTES) FORCEOUTPUT _ (\INHERITFDEVOP.S FORCEOUTPUT STREAM)))
+)
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \INHERITFDEVOP.D MACRO [X (SUBPAIR '(NEWARGS OPNAME . ARGS)
+                                                   (CONS (SUBST '(fetch DEVICEINFO of FDEV)
+                                                                'FDEV
+                                                                (CDR X))
+                                                         X)
+                                                   '(FUNCTION (LAMBDA ARGS
+                                                                (FDEVOP 'OPNAME (fetch DEVICEINFO
+                                                                                   of FDEV)
+                                                                                           . NEWARGS])
+
+(PUTPROPS \INHERITFDEVOP.S MACRO [(OPNAME . ARGS)
+                                          (FUNCTION (LAMBDA ARGS
+                                                      (FDEVOP 'OPNAME (fetch DEVICEINFO
+                                                                         of (fetch DEVICE
+                                                                                   of STREAM))
+                                                                                              . ARGS])
+)
+
+(RPAQ? LOGINHOST/DIR '{DSK})
+
+(RPAQ? \CONNECTED.DIRECTORY '{DSK})
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS LOGINHOST/DIR \CONNECTED.DIRECTORY \FILEDEVICES \FILEDEVICENAMES \DEVICENAMETODEVICE)
+)
+
+
+
+(* ; "Directory defaulting")
+
+(DEFINEQ
+
+(CNDIR
+(LAMBDA (HOST/DIR) (* ; "Edited 11-Mar-87 14:28 by Pavel") (* ;;; "Connects to HOST/DIR, verifying that HOST/DIR exists.") (DECLARE (GLOBALVARS \CONNECTED.DIRECTORY)) (LET ((TEMP-DEFAULTS (PATHNAME (SETQ \CONNECTED.DIRECTORY (OR (DIRECTORYNAME (AND HOST/DIR (\CONVERT-PATHNAME HOST/DIR)) T (QUOTE ASK)) (ERROR "Non-existent directory" HOST/DIR))))) (NEW-DEFAULTS (COPY-PATHNAME *DEFAULT-PATHNAME-DEFAULTS*))) (CL:SETF (%%PATHNAME-HOST NEW-DEFAULTS) (CL:PATHNAME-HOST TEMP-DEFAULTS)) (CL:SETF (%%PATHNAME-DEVICE NEW-DEFAULTS) (CL:PATHNAME-DEVICE TEMP-DEFAULTS)) (CL:SETF (%%PATHNAME-DIRECTORY NEW-DEFAULTS) (CL:PATHNAME-DIRECTORY TEMP-DEFAULTS)) (SETQ *DEFAULT-PATHNAME-DEFAULTS* NEW-DEFAULTS)) \CONNECTED.DIRECTORY)
+)
+
+(DIRECTORYNAME
+(LAMBDA (DIRNAME STRPTR CREATE?) (* ; "Edited  3-Sep-91 15:18 by jrb:") (* ;; "Returns connected directory name") (AND (CL:PATHNAMEP DIRNAME) (SETQ DIRNAME (CL:NAMESTRING DIRNAME))) (SELECTQ (SYSTEMTYPE) (VAX (GETDIRNAME)) (D (DECLARE (GLOBALVARS LOGINHOST/DIR)) (PROG (DN FDEV) (SELECTQ DIRNAME (T (* ; "Connected host/dir") (SETQ DN \CONNECTED.DIRECTORY)) (NIL (SETQ DN (OR LOGINHOST/DIR (QUOTE {DSK})))) (COND ((AND (SETQ FDEV (LET ((HOST (FILENAMEFIELD DIRNAME (QUOTE HOST)))) (\GETDEVICEFROMHOSTNAME (OR HOST (FILENAMEFIELD (SELCHARQ (NTHCHARCODE DIRNAME 1) ((< /) (SETQ DIRNAME (PACKFILENAME.STRING (QUOTE DIRECTORY) DIRNAME (QUOTE BODY) \CONNECTED.DIRECTORY))) (SETQ DIRNAME (PACKFILENAME.STRING (QUOTE SUBDIRECTORY) DIRNAME (QUOTE DIRECTORY) \CONNECTED.DIRECTORY))) (QUOTE HOST)))))) (SETQ DN (FDEVOP (QUOTE DIRECTORYNAMEP) FDEV DIRNAME FDEV CREATE?))) (COND ((EQ DN T) (SETQ DN (PACKFILENAME.STRING (QUOTE HOST) (fetch (FDEV DEVICENAME) of FDEV) (QUOTE DIRECTORY) DIRNAME))))) (T (RETURN)))) (RETURN (if (NOT STRPTR) then (MKSTRING DN) elseif (EQ STRPTR T) then (MKATOM DN) else (MKSTRING DN))))) (HELP)))
+)
+
+(DIRECTORYNAMEP
+(LAMBDA (DIRNAME HOSTNAME) (* bvm%: "18-Oct-85 14:38") (* ;; "T if DIRNAME is recognized as a currently existing directory, on HOSTNAME, or if not included, on the hostname in DIRNAME, or the connected host.") (LET ((DN (COND (HOSTNAME (PACKFILENAME.STRING (QUOTE DIRECTORY) DIRNAME (QUOTE HOST) HOSTNAME)) (T (PACKFILENAME.STRING (QUOTE DIRECTORY) DIRNAME (QUOTE DIRECTORY) \CONNECTED.DIRECTORY)))) FDEV) (AND (SETQ FDEV (\GETDEVICEFROMNAME DN T)) (FDEVOP (QUOTE DIRECTORYNAMEP) FDEV DN FDEV) T)))
+)
+
+(HOSTNAMEP
+(LAMBDA (NAME) (* rmk%: "11-NOV-81 14:33") (* ;; "T if NAME is the name of a recognizable host") (DECLARE (GLOBALVARS \FILEDEVICENAMES \FILEDEVICES)) (PROG (N) (COND ((LITATOM NAME) (SETQ N (U-CASE NAME))) ((STRINGP NAME) (SETQ N (MKATOM (U-CASE NAME)))) (T (RETURN NIL))) (COND ((EQ (CHCON1 N) (CHARCODE {)) (SETQ N (SUBATOM N 2 (SUB1 (OR (STRPOS (QUOTE }) N 2) (RETURN NIL))))))) (RETURN (AND (OR (MEMB N \FILEDEVICENAMES) (find D in \FILEDEVICES suchthat (FDEVOP (QUOTE HOSTNAMEP) D N))) T))))
+)
+
+(\ADD.CONNECTED.DIR
+  [LAMBDA (FILENAME)                                     (* ; "Edited 29-Dec-89 15:41 by jds")
+
+    (* ;; "Modifies the filename to include connected host and/or dir")
+
+    (COND
+       ([AND (OR (LITATOM FILENAME)
+                 (STRINGP FILENAME))
+             (NOT (UNPACKFILENAME.STRING FILENAME 'HOST]
+        (PACKFILENAME.STRING 'BODY FILENAME 'DIRECTORY \CONNECTED.DIRECTORY))
+       (T FILENAME])
+)
+
+
+
+(* ; "Binary I/O Public functions")
+
+(DEFINEQ
+
+(\BACKFILEPTR
+(LAMBDA (STREAM) (* bvm%: "30-JAN-82 16:59") (FDEVOP (QUOTE BACKFILEPTR) (fetch DEVICE of STREAM) STREAM))
+)
+
+(\BACKPEEKBIN
+(LAMBDA (STREAM) (* bvm%: " 7-Jun-84 16:45") (* ;; "Returns previous byte on file without changing fileptr.  Returns NIL if we are positioned at the beginning of the file.  Called by LASTC") (UNINTERRUPTABLY (AND (\BACKFILEPTR STREAM) (\BIN STREAM))))
+)
+
+(\BACKBIN
+(LAMBDA (STREAM) (* bvm%: " 7-Jun-84 16:46") (* ;; "Returns previous character on file and backs up fileptr so that next \BIN will also return it.  Returns NIL if we are positioned at the beginning of the file.") (AND (\BACKFILEPTR STREAM) (\PEEKBIN STREAM)))
+)
+
+(BIN
+(LAMBDA (STREAM) (* lmm "20-APR-82 22:00") (* ; "MERELY EXECUTE OPCODE") (\BIN STREAM)))
+
+(\BIN
+(LAMBDA (STREAM) (* rmk%: " 2-NOV-83 14:32") (* ; "UFN for BIN opcode") (STREAMOP (QUOTE STRMBINFN) (SETQ STREAM (\DTEST STREAM (QUOTE STREAM))) STREAM))
+)
+
+(\BINS
+(LAMBDA (STREAM BASE OFF NBYTES) (* bvm%: "25-MAY-83 12:48") (* ;; "BINs NBYTES bytes from STREAM into BASE+OFF") (FDEVOP (QUOTE BLOCKIN) (ffetch DEVICE of (SETQ STREAM (\DTEST STREAM (QUOTE STREAM)))) STREAM BASE OFF NBYTES))
+)
+
+(BOUT
+(LAMBDA (STREAM BYTE) (* ; "Edited  3-Mar-87 16:04 by lal") (* ; "Merely execute opcode") (if (NUMBERP BYTE) then (if (GREATERP BYTE 65535) then (\ILLEGAL.ARG BYTE))) (\BOUT STREAM BYTE))
+)
+
+(\BOUT
+(LAMBDA (STREAM BYTE) (* ; "Edited  8-Jan-88 17:00 by jds") (COND ((NUMBERP BYTE) (COND ((GREATERP BYTE 65535) (\ILLEGAL.ARG BYTE))))) (SETQ STREAM (\DTEST STREAM (QUOTE STREAM))) (STREAMOP (QUOTE STRMBOUTFN) STREAM STREAM BYTE))
+)
+
+(\BOUTS
+(LAMBDA (STREAM BASE OFF NBYTES) (* bvm%: "25-MAY-83 12:47") (* ;; "BOUTs NBYTES bytes from BASE+OFF into OFD.  Follows logic of BINS.") (FDEVOP (QUOTE BLOCKOUT) (ffetch DEVICE of (SETQ STREAM (\DTEST STREAM (QUOTE STREAM)))) STREAM BASE OFF NBYTES))
+)
+
+(COPYBYTES
+(LAMBDA (SRCFIL DSTFIL START END) (* ; "Edited 24-Jun-88 15:08 by drc:") (* ;; "Copies bytes from START up to but not including END from SRCFIL into DSTFIL.") (PROG ((SRC (\GETSTREAM SRCFIL (QUOTE INPUT))) (DST (\GETSTREAM DSTFIL (QUOTE OUTPUT))) NBYTES) (SETQ NBYTES (COND (END (* ; "Specified a start and ending") (COND ((EQUAL START END) (* ; "special case: no bytes to copy") (RETURN))) (\SETFILEPTR SRC (COND ((type? BYTEPTR START) START) (T (\ILLEGAL.ARG START)))) (IDIFFERENCE (COND ((EQ END -1) (COND ((RANDACCESSP SRC) (* ; "It's random access, so GETEOFPTR will work") (\GETEOFPTR SRC)) (T (* ; "Otherwise, we have to hack around this (probably a bug in FTP streams)") (GETFILEINFO SRC (QUOTE LENGTH))))) ((type? BYTEPTR END) END) (T (\ILLEGAL.ARG END))) START)) (T START))) (* ; "How much to copy, or NIL if to EOF") (COND ((AND NBYTES (ILESSP NBYTES 0)) (ERROR "Negative number of bytes to copy" NBYTES))) (COND ((fetch BUFFERED of (fetch DEVICE of SRC)) (* ; "Can copy by the bufferfull") (\BUFFERED.COPYBYTES SRC DST NBYTES)) ((OR NBYTES (SETQ NBYTES (COND ((fetch RANDOMACCESSP of (fetch DEVICE of SRC)) (IDIFFERENCE (\GETEOFPTR SRC) (\GETFILEPTR SRC)))))) (* ; "Know how many bytes to copy") (FRPTQ NBYTES (\BOUT DST (\BIN SRC)))) (T (* ; "Copying to EOF but can't tell when that will happen") (until (\EOFP SRC) do (\BOUT DST (\BIN SRC))))) (RETURN T) (* ; "As specified in VM")))
+)
+
+(COPYCHARS
+(LAMBDA (SRCFIL DSTFIL START END) (* rmk%: "11-Mar-85 12:12") (* ;; "This is similar to COPYBYTES except that conversion is done between the EOL convention of the input and the EOL convention of the output") (PROG ((SRCSTRM (\GETSTREAM SRCFIL)) (DSTSTRM (\GETSTREAM DSTFIL)) (ACTUALSTART 0) RAP ACTUALEND EOF SRCEOLC DSTEOLC CH) (COND ((EQ (SETQ SRCEOLC (fetch EOLCONVENTION of SRCSTRM)) (SETQ DSTEOLC (fetch EOLCONVENTION of DSTSTRM))) (RETURN (COPYBYTES SRCSTRM DSTSTRM START END)))) (COND ((SETQ RAP (fetch RANDOMACCESSP of (fetch DEVICE of SRCSTRM))) (SETQ EOF (\GETEOFPTR SRCSTRM)))) (COND (END (OR RAP (ERROR "COPYCHARS: Source file is not random access" (fetch FULLFILENAME of SRCSTRM))) (OR (type? BYTEPTR (SETQ ACTUALSTART (FIX START))) (LISPERROR "ILLEGAL ARG" START)) (\SETFILEPTR SRCSTRM ACTUALSTART) (SETQ ACTUALEND (COND ((EQ END -1) EOF) ((type? BYTEPTR END) END) (T (\ILLEGAL.ARG END))))) (START (SETQ ACTUALEND (COND (RAP (SETQ ACTUALSTART (\GETFILEPTR SRCSTRM)) (IMIN EOF (IPLUS START ACTUALSTART))) (T START)))) (RAP (SETQ ACTUALSTART (\GETFILEPTR SRCSTRM)) (SETQ ACTUALEND EOF)) (T (until (\EOFP SRCSTRM) do (\OUTCHAR DSTSTRM (\INCHAR SRCSTRM))) (* ; "Not RAP and START and END are both NIL.  Slow copy to the end of the file.") (RETURN))) (OR (IGEQ ACTUALEND ACTUALSTART) (ERROR "Negative number of bytes to copy" (IDIFFERENCE ACTUALEND ACTUALSTART))) (* ; "We only have to worry about mismatched EOLCs") (SELECTC SRCEOLC (CR.EOLC (* ; "DST is either CRLF or LF") (FRPTQ (IDIFFERENCE ACTUALEND ACTUALSTART) (SELCHARQ (SETQ CH (\BIN SRCSTRM)) (CR (AND (EQ DSTEOLC CRLF.EOLC) (\BOUT DSTSTRM (CHARCODE CR))) (\BOUT DSTSTRM (CHARCODE LF))) (\BOUT DSTSTRM CH)))) (LF.EOLC (* ; "DST is either CRLF or CR") (FRPTQ (IDIFFERENCE ACTUALEND ACTUALSTART) (SELCHARQ (SETQ CH (\BIN SRCSTRM)) (LF (\BOUT DSTSTRM (CHARCODE CR)) (AND (EQ DSTEOLC CRLF.EOLC) (\BOUT DSTSTRM (CHARCODE LF)))) (\BOUT DSTSTRM CH)))) (CRLF.EOLC (* ; "DST is either CR or LF") (for I from (IDIFFERENCE ACTUALEND ACTUALSTART) to 1 by -1 do (\BOUT DSTSTRM (COND ((OR (NEQ (SETQ CH (\BIN SRCSTRM)) (CHARCODE CR)) (EQ I 1)) CH) ((PROGN (add I -1) (* ; "Adjust for second character") (EQ (SETQ CH (\BIN SRCSTRM)) (CHARCODE LF))) (COND ((EQ DSTEOLC CR.EOLC) (CHARCODE CR)) (T (CHARCODE LF)))) (T (\BOUT DSTSTRM (CHARCODE CR)) CH))))) (SHOULDNT))) T)
+)
+
+(COPYFILE
+  [LAMBDA (FROMFILE TOFILE DESTPARAMETERS)                   (* ; "Edited  2-Jan-93 13:35 by jds")
+
+(* ;;; "DESTPARAMETERS is like PARAMETERS arg to OPENSTREAM -- overrides default parameters")
+
+    [AND (DIRECTORYNAMEP (PACKFILENAME 'HOST NIL 'BODY TOFILE)
+                (UNPACKFILENAME TOFILE 'HOST))
+         (SETQ TOFILE (PACKFILENAME 'DIRECTORY TOFILE 'BODY (PACKFILENAME 'HOST NIL 'DIRECTORY 
+                                                                   NIL 'BODY FROMFILE]
+    (RESETLST
+        [RESETSAVE [SETQ FROMFILE (OPENSTREAM FROMFILE 'INPUT 'OLD '((SEQUENTIAL T)
+                                                                     (DON'TCACHE T]
+               '(PROGN (CLOSEF OLDVALUE]
+        (\COPYOPENFILE FROMFILE TOFILE DESTPARAMETERS))])
+
+(\COPYOPENFILE
+  [LAMBDA (INSTREAM NEWNAME DESTPARAMETERS)              (* ; "Edited 17-Sep-90 11:41 by jds")
+                                                             (* bvm%: "18-Oct-85 15:54")
+    (PROG ((PROPS DESTPARAMETERS)
+           TYPE X OUTSTREAM)
+          [COND
+             ([AND (NOT (ASSOC 'CREATIONDATE DESTPARAMETERS))
+                   (SETQ X (GETFILEINFO INSTREAM 'CREATIONDATE]
+              (push PROPS (LIST 'CREATIONDATE X]
+          [COND
+             ((SETQ X (GETFILEINFO INSTREAM 'LENGTH))
+              (push PROPS (LIST 'LENGTH X]
+          [COND
+             [(SETQ TYPE (CADR (ASSOC 'TYPE DESTPARAMETERS]
+             ((OR (AND (SETQ TYPE (GETFILEINFO INSTREAM 'TYPE))
+                       (NEQ TYPE '?))
+                  (SETQ TYPE (\INFER.FILE.TYPE INSTREAM)))
+              (push PROPS (LIST 'TYPE TYPE]
+
+     (* ;; "TAL removed : (COND ((AND (EQ TYPE 'TEXT) (SETQ X (GETFILEINFO INSTREAM 'EOL)) (NOT (ASSOC 'EOL DESTPARAMETERS))) (push PROPS (LIST 'EOL X)))) --- if the caller didn't specify, we ought to convert to the destination system's EOL convention for text files.")
+
+          [RESETSAVE [SETQ OUTSTREAM (OPENSTREAM NEWNAME 'OUTPUT 'NEW `((SEQUENTIAL T)
+                                                                        (DON'TCACHE T)
+                                                                        ,@PROPS]
+                 '(AND RESETSTATE (SETQ OLDVALUE (CLOSEF OLDVALUE))
+                       (DELFILE OLDVALUE]
+
+     (* ;; "Obsoleted by Lyric's multiple streams:  (OR (EQ (\GETFILEPTR INSTREAM) 0) (SETFILEPTR INSTREAM 0)) ;; In case it was open by someone else! Really need multiple streams, but until then at least don't lose big this way")
+
+          (COND
+             [(AND (EQ TYPE 'TEXT)
+                   (NEQ (GETFILEINFO OUTSTREAM 'EOL)
+                        X))                                  (* ; 
+                                                        "Incompatible EOL conventions, do slow way")
+              (replace ENDOFSTREAMOP of INSTREAM with (FUNCTION NILL))
+              (bind CH (SRCEOL _ (fetch EOLCONVENTION of INSTREAM))
+                 until (NULL (SETQ CH (\BIN INSTREAM)))
+                 do (\OUTCHAR OUTSTREAM (\CHECKEOLC CH SRCEOL INSTREAM]
+             (T (COPYBYTES INSTREAM OUTSTREAM)))
+
+     (* ;; "On UNIX version, give FX the option of printing a warning when the file type is defaulted -- they want to discourage that behavior.")
+
+          (AND (EQ \MACHINETYPE \MAIKO)
+               FileTypeConfirmFlg
+               (STKPOS 'COPYFILE)
+               (NULL (ASSOC 'TYPE DESTPARAMETERS))
+               (\UFStoOtherCopyMess INSTREAM OUTSTREAM))
+
+     (* ;; "We return the closed stream.")
+
+          (RETURN (CLOSEF OUTSTREAM])
+
+(\INFER.FILE.TYPE
+(LAMBDA (STREAM) (* bvm%: " 8-Jun-84 11:48") (* ;; "STREAM is open on a file whose TYPE is unknown.  If we can, decide between TEXT and BINARY by examining bytes") (COND ((RANDACCESSP STREAM) (SETFILEPTR STREAM 0) (PROG ((OLDEOF (fetch ENDOFSTREAMOP of STREAM)) TYPE) (replace ENDOFSTREAMOP of STREAM with (FUNCTION NILL)) (SETQ TYPE (do (COND ((IGREATERP (OR (\BIN STREAM) (RETURN (QUOTE TEXT))) 127) (RETURN (QUOTE BINARY)))))) (replace ENDOFSTREAMOP of STREAM with OLDEOF) (SETFILEPTR STREAM 0) (* ; "Put file ptr back") (RETURN TYPE)))))
+)
+
+(EOFP
+(LAMBDA (FILE) (* bvm%: "10-Jun-84 22:46") (* ;; "User entry.  T if FILE is at EOF.  I-10 only considers input files, we merely give priority to them") (\EOFP (OR (\GETSTREAM FILE (QUOTE INPUT) T) (\GETSTREAM FILE))))
+)
+
+(FORCEOUTPUT
+(LAMBDA (STREAM WAITFORFINISH) (* bvm%: "27-Apr-84 22:45") (SETQ STREAM (\GETSTREAM STREAM (QUOTE OUTPUT))) (FDEVOP (QUOTE FORCEOUTPUT) (fetch DEVICE of STREAM) STREAM WAITFORFINISH))
+)
+
+(\FLUSH.OPEN.STREAMS
+(LAMBDA (FDEV) (* hdj " 5-Jun-86 12:58") (* ;;; "flush all of device's open streams") (for STREAM in (\DEVICE-OPEN-STREAMS FDEV) when (DIRTYABLE STREAM) do (FDEVOP (QUOTE FORCEOUTPUT) (fetch (STREAM DEVICE) of STREAM) STREAM)))
+)
+
+(CHARSET
+(LAMBDA (STREAM NEWVALUE) (* ; "Edited 11-Sep-87 16:22 by bvm:") (* ;; "Public access to a stream's CHARSET.  If NEWVALUE is given, changes the charset (which for output streams can write a charset shift).  We invoke the stream's device's get/set charset method on the stream, and also invoke the IMCHARSET image operation (which is where file streams get to write a charset shift).") (* ;; "If CHARACTERSET is either 255 or T, set the stream so that it's non run-coded, i.e., you read 2 bytes for each character read.") (SETQ STREAM (\GETSTREAM STREAM)) (COND ((EQ NEWVALUE NSCHARSETSHIFT) (* ; "Coerce 255 to T for uniformity") (SETQ NEWVALUE T)) ((NOT (OR (EQ NEWVALUE NIL) (EQ NEWVALUE T) (AND (>= NEWVALUE 0) (< NEWVALUE \MAXCHARSET)))) (\ILLEGAL.ARG NEWVALUE))) (LET ((OLDVAL (ACCESS-CHARSET STREAM (if (EQ NEWVALUE T) then NSCHARSETSHIFT else NEWVALUE)))) (* ; "First modify the stream's slot") (if (EQ OLDVAL NSCHARSETSHIFT) then (SETQ OLDVAL T)) (if (AND NEWVALUE (NEQ OLDVAL NEWVALUE)) then (* ; "Now invoke the imageop if anything interesting happened") (IMAGEOP (QUOTE IMCHARSET) STREAM STREAM NEWVALUE)) OLDVAL))
+)
+
+(ACCESS-CHARSET
+(LAMBDA (STREAM NEWVALUE) (* ; "Edited 11-Sep-87 15:46 by bvm:") (FDEVOP (QUOTE CHARSETFN) (fetch (STREAM DEVICE) of STREAM) STREAM NEWVALUE))
+)
+
+(GETEOFPTR
+(LAMBDA (FILE) (* rmk%: "21-OCT-83 11:19") (PROG ((STREAM (\GETSTREAM FILE))) (RETURN (FDEVOP (QUOTE GETEOFPTR) (fetch DEVICE of STREAM) STREAM))))
+)
+
+(GETFILEINFO
+(LAMBDA (FILE ATTRIB) (* ; "Edited  8-May-87 16:53 by bvm") (LET (FULLNAME DEV) (COND ((type? STREAM FILE) (* ; "FILE is open or nameless.  Ask device for info;  if it can't handle it, at least handle some generic cases") (COND ((EQ ATTRIB (QUOTE ACCESS)) (fetch ACCESS of FILE)) ((FDEVOP (QUOTE GETFILEINFO) (SETQ DEV (fetch DEVICE of FILE)) FILE ATTRIB DEV)) ((OPENED FILE) (* ; "Could be false for a closed nameless stream") (SELECTQ ATTRIB ((BYTESIZE OPENBYTESIZE) (fetch BYTESIZE of FILE)) (EOL (SELECTC (fetch EOLCONVENTION of FILE) (CR.EOLC (QUOTE CR)) (LF.EOLC (QUOTE LF)) (CRLF.EOLC (QUOTE CRLF)) (SHOULDNT))) (BUFFERS (fetch MAXBUFFERS of FILE)) (CHARSET (CHARSET FILE)) (ENDOFSTREAMOP (fetch ENDOFSTREAMOP of FILE)) (LENGTH (AND (RANDACCESSP FILE) (\GETEOFPTR FILE))) (SIZE (SIZE.FROM.LENGTH (OR (FDEVOP (QUOTE GETFILEINFO) DEV FILE (QUOTE LENGTH) DEV) (AND (RANDACCESSP FILE) (\GETEOFPTR FILE))))) NIL)) ((EQ ATTRIB (QUOTE SIZE)) (SIZE.FROM.LENGTH (FDEVOP (QUOTE GETFILEINFO) DEV FILE (QUOTE LENGTH) DEV))))) ((AND (SETQ DEV (\GETDEVICEFROMNAME (SETQ FULLNAME (\ADD.CONNECTED.DIR (\CONVERT-PATHNAME FILE))))) (SETQ FULLNAME (FDEVOP (QUOTE GETFILENAME) DEV FULLNAME (QUOTE OLD) DEV))) (* ; "Name of existing file.  It's possible we should have the device do recognition instead, but then we have the confusion of file not found recovery in the wrong place.") (SELECTQ ATTRIB ((ACCESS OPENBYTESIZE) (* ; "Strip off attributes that apply only to open files") NIL) (OR (FDEVOP (QUOTE GETFILEINFO) DEV FULLNAME ATTRIB DEV) (SELECTQ ATTRIB (SIZE (SIZE.FROM.LENGTH (FDEVOP (QUOTE GETFILEINFO) DEV FULLNAME (QUOTE LENGTH) DEV))) NIL)))) (T (LISPERROR "FILE NOT FOUND" FILE)))))
+)
+
+(\TYPE.FROM.FILETYPE
+(LAMBDA (FILETYPE) (* bvm%: "15-Jan-85 16:22") (* ;;; "Coerces a numeric FILETYPE to a symbolic TYPE or returns FILETYPE itself if it is not registered on the list FILING.TYPES") (AND FILETYPE (OR (CAR (find PAIR in FILING.TYPES suchthat (EQ (CADR PAIR) FILETYPE))) FILETYPE)))
+)
+
+(\FILETYPE.FROM.TYPE
+(LAMBDA (TYPE) (* bvm%: "15-Jan-85 17:08") (OR (CADR (ASSOC TYPE FILING.TYPES)) (FIXP TYPE))))
+
+(GETFILEPTR
+(LAMBDA (FILE) (* rmk%: "21-OCT-83 11:19") (PROG ((STREAM (\GETSTREAM FILE))) (RETURN (FDEVOP (QUOTE GETFILEPTR) (fetch DEVICE of STREAM) STREAM))))
+)
+
+(SETFILEINFO
+  [LAMBDA (FILE ATTRIB VALUE)                            (* ; "Edited 27-Mar-89 15:33 by bvm")
+    (LET (FULLNAME DEV)
+         (COND
+            [(type? STREAM FILE)                         (* ; 
+                           "FILE is open, so strip off attributes that can be set from the stream.")
+             (SELECTQ ATTRIB
+                 ((ACCESS BYTESIZE OPENBYTESIZE)             (* ; 
+                                                          "These can't be changed for an open file")
+                      NIL)
+                 (EOL (replace EOLCONVENTION of FILE with (SELECTQ VALUE
+                                                                          (CR CR.EOLC)
+                                                                          (CRLF CRLF.EOLC)
+                                                                          (LF LF.EOLC)
+                                                                          (\ILLEGAL.ARG VALUE)))
+                      VALUE)
+                 (ENDOFSTREAMOP (replace ENDOFSTREAMOP of FILE with VALUE))
+                 (BUFFERS (replace MAXBUFFERS of FILE with (IMAX 1 (FIX VALUE))))
+                 (CHARSET (CHARSET FILE VALUE))
+                 (OR (FDEVOP 'SETFILEINFO (SETQ DEV (fetch DEVICE of FILE))
+                            FILE ATTRIB VALUE DEV)
+                     (SELECTQ ATTRIB
+                         (LENGTH 
+                                 (* ;; "Let device at this attribute first.  Probably should not have this generic op, since we don't know how to do this for all devices")
+
+                                 [\SETEOFPTR FILE (COND
+                                                         ((type? BYTEPTR VALUE)
+                                                          VALUE)
+                                                         (T (\ILLEGAL.ARG VALUE])
+                         (SIZE (\SETEOFPTR FILE (UNFOLD VALUE BYTESPERPAGE)))
+                         NIL]
+            [(AND [SETQ DEV (\GETDEVICEFROMNAME (SETQ FULLNAME (\ADD.CONNECTED.DIR
+                                                                    (\CONVERT-PATHNAME FILE]
+                  (SETQ FULLNAME (FDEVOP 'GETFILENAME DEV FULLNAME 'OLD DEV)))
+                                                             (* ; "Name of existing file.  It's possible we should have the device do recognition instead, but then we have the confusion of file not found recovery in the wrong place.")
+             (SELECTQ ATTRIB
+                 ((ACCESS OPENBYTESIZE EOLCONVENTION) 
+                      NIL)
+                 (OR (FDEVOP 'SETFILEINFO DEV FULLNAME ATTRIB VALUE DEV)
+                     (COND
+                        ((EQ ATTRIB 'LENGTH)
+                         (\SETCLOSEDFILELENGTH FULLNAME (COND
+                                                               ((type? BYTEPTR VALUE)
+                                                                VALUE)
+                                                               (T (\ILLEGAL.ARG VALUE]
+            (T (LISPERROR "FILE NOT FOUND" FILE])
+
+(SETFILEPTR
+(LAMBDA (FILE ADR) (* ; "Edited 11-Sep-87 16:34 by bvm:") (LET ((STREAM (\GETSTREAM FILE))) (FDEVOP (QUOTE SETFILEPTR) (ffetch DEVICE of STREAM) STREAM (COND ((EQ ADR -1) (\GETEOFPTR STREAM)) ((type? BYTEPTR ADR) ADR) (T (LISPERROR "ILLEGAL ARG" ADR)))) (if (\RUNCODED STREAM) then (* ;; "always shift the character set to 0. This might be wrong sometimes, but it is more often right than wrong.  We don't do it when reading a non-runcoded file, since maybe the whole file is that way (unfortunately, we can't tell)") (ACCESS-CHARSET STREAM 0)) (freplace (STREAM CHARPOSITION) of STREAM with 0) (* ; "Value is not coerced!") ADR))
+)
+
+(BOUT16
+(LAMBDA (STREAM N) (* edited%: " 2-Apr-85 17:11") (BOUT STREAM (LRSH N 8)) (BOUT STREAM (LOGAND N 255)) N)
+)
+
+(BIN16
+(LAMBDA (STREAM) (* edited%: " 2-Apr-85 17:11") (LOGOR (LLSH (BIN STREAM) 8) (BIN STREAM))))
+)
+
+(PUTPROPS BOUT DOPCODE (33 BOUT 0 T -1 \BOUT (4K DORADO)))
+
+
+
+(* ; "Generic functions")
+
+(DEFINEQ
+
+(\GENERIC.BINS
+(LAMBDA (STREAM BASE OFF NBYTES) (* bvm%: "25-MAY-83 11:41") (* ;; "BINs NBYTES bytes from STREAM to memory starting at BASE+OFF.") (FRPTQ NBYTES (\PUTBASEBYTE BASE OFF (\BIN STREAM)) (add OFF 1)))
+)
+
+(\GENERIC.BOUTS
+(LAMBDA (STREAM BASE OFF NBYTES) (* bvm%: "25-MAY-83 11:40") (* ;; "BOUTs NBYTES bytes from BASE+OFF into STREAM") (FRPTQ NBYTES (\BOUT STREAM (\GETBASEBYTE BASE OFF)) (add OFF 1)))
+)
+
+(\GENERIC.RENAMEFILE
+(LAMBDA (OLDDEVICE OLDFILE NEWDEVICE NEWFILE) (* ; "Edited  2-Jul-90 16:03 by nm") (if (NOT (FDEVOP (QUOTE OPENP) OLDDEVICE (FULLNAME OLDFILE) NIL OLDDEVICE)) then (RESETLST (RESETSAVE (SETQ OLDFILE (OPENSTREAM OLDFILE (QUOTE INPUT) (QUOTE OLD) (QUOTE ((SEQUENTIAL T) DON'TCACHE)))) (QUOTE (AND RESETSTATE (CLOSEF? OLDVALUE)))) (COND ((SETQ NEWFILE (\COPYOPENFILE OLDFILE NEWFILE)) (if (\DELETEFILE (CLOSEF OLDFILE)) then NEWFILE else (CONDITIONS:RESTART-CASE (CL:ERROR (QUOTE XCL::FS-RENAMEFILE-SOURCE-COULDNT-DELETE) :PATHNAME OLDFILE) (DELETE-DESTINATION NIL :CONDITION XCL::FS-RENAMEFILE-SOURCE-COULDNT-DELETE :REPORT "Delete the destination file too." (DELFILE NEWFILE) NIL) (DONT-DELETE-DESTINATION NIL :CONDITION XCL::FS-RENAMEFILE-SOURCE-COULDNT-DELETE :REPORT "Don't delete the destination file.  Just returns the destination filename." NEWFILE))))))))
+)
+
+(\GENERIC.OPENP
+(LAMBDA (FILENAME ACCESS DEVICE) (* hdj " 6-Oct-86 17:07") (* ;;; "return all open stream on DEVICE with name FILENAME and access ACCESS.  FILENAME is assumed to be fully 'recognized.'  FILENAME and/or ACCESS may be NIL.") (if FILENAME then (LET ((OPENFILES (fetch (FDEV OPENFILELST) of DEVICE))) (if OPENFILES then (for STREAM in OPENFILES collect STREAM when (AND (STRING-EQUAL FILENAME (fetch (STREAM FULLNAME) of STREAM)) (OR (NULL ACCESS) (\IOMODEP STREAM ACCESS T)))))) else (for S in (fetch (FDEV OPENFILELST) of DEVICE) collect S when (AND (OR (NULL ACCESS) (\IOMODEP S ACCESS T)) (fetch USERVISIBLE of S)))))
+)
+
+(\GENERIC.READP
+(LAMBDA (STREAM FLG) (* ; "Edited 11-Sep-87 16:26 by bvm:") (* ; "The 10 does not do the EOL check on the peeked character.") (* ; "If FLG is NIL, a single EOL doesn't count.") (PROG ((SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256))) (RETURN (AND (NOT (\EOFP STREAM)) (OR (NOT (NULL FLG)) (NEQ EOL.TC (\SYNCODE \PRIMTERMSA (OR (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET T) (RETURN)))) (UNINTERRUPTABLY (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (* ;; "To find out if the EOL is the last character, we BIN the stream, check for EOF, then back it up again.") (PROG1 (NOT (\EOFP STREAM)) (\BACKNSCHAR STREAM SHIFTEDCHARSET))))))))
+)
+
+(\GENERIC.CHARSET
+(LAMBDA (STREAM NEWVALUE) (* ; "Edited 11-Sep-87 16:20 by bvm:") (* ;;; "sets or returns the current numeric character set for this stream.  This never writes anything on a stream, it just tells the stream what to think.") (PROG1 (ffetch (STREAM CHARSET) of (\DTEST STREAM (QUOTE STREAM))) (AND NEWVALUE (freplace (STREAM CHARSET) of STREAM with NEWVALUE))))
+)
+)
+(DEFINEQ
+
+(\MAP-OPEN-STREAMS
+(LAMBDA (FN DEVICES ACCESS) (* hdj "11-Sep-86 10:48") (for DEVICE in DEVICES when (fetch (FDEV OPENP) of DEVICE) join (for STREAM in (FDEVOP (QUOTE OPENP) DEVICE NIL ACCESS DEVICE) collect (APPLY* FN STREAM))))
+)
+)
+
+(RPAQQ FILING.TYPES ((BINARY 0)
+                         (DIRECTORY 1)
+                         (TEXT 2)
+                         (SERIALIZED 3)
+                         (INTERPRESS 4361)
+                         (TEDIT 6056)
+                         (FASL 6057)
+                         (LAFITE 6058)))
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS FILING.TYPES)
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \OUTCHAR DMACRO (OPENLAMBDA (STREAM CHARCODE)
+                                         (STREAMOP 'OUTCHARFN STREAM STREAM CHARCODE)))
+
+(PUTPROPS \DEVICE-OPEN-STREAMS MACRO [ARGS (LET ((DEVICE (CAR ARGS)))
+                                                        `(FDEVOP 'OPENP ,DEVICE NIL NIL
+                                                                ,DEVICE])
+
+(PUTPROPS \CONVERT-PATHNAME DMACRO (OPENLAMBDA (PATHNAME?)
+
+                                                  (* ;; 
+      "Coerce pathnames to Interlisp strings, for the benefit of antediluvian Interlisp-D file fns")
+
+                                                  (CL:TYPECASE PATHNAME?
+                                                      (CL:LOGICAL-PATHNAME (INTERLISP-NAMESTRING
+                                                                            (
+                                                                        CL:TRANSLATE-LOGICAL-PATHNAME
+                                                                             PATHNAME?)))
+                                                      (PATHNAME (INTERLISP-NAMESTRING PATHNAME?))
+                                                      (T PATHNAME?))))
+)
+
+(DEFOPTIMIZER ACCESS-CHARSET (STREAM &OPTIONAL NEWVALUE)
+                                 `((OPENLAMBDA (STRM)
+                                          (FDEVOP 'CHARSETFN (fetch (STREAM DEVICE) of STRM)
+                                                 STRM
+                                                 ,NEWVALUE))
+                                   ,STREAM))
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+[MAPC '((FORCEOUTPUT FLUSHOUTPUT)
+        (FORCEOUTPUT FLUSHMAP)
+        (\GENERIC.BINS \NONPAGEDBINS)
+        (\GENERIC.BOUTS \NONPAGEDBOUTS))
+      (FUNCTION (LAMBDA (PAIR)
+                  (PUTD (CADR PAIR)
+                        (GETD (CAR PAIR))
+                        T]
+)
+
+
+
+(* ; "Internal functions")
+
+(DEFINEQ
+
+(\EOF.ACTION
+(LAMBDA (STREAM) (* bvm%: "24-Aug-84 18:06") (* ;; "Standard thing to do at end of stream") (CL:FUNCALL (fetch (STREAM ENDOFSTREAMOP) of STREAM) STREAM))
+)
+
+(\EOSERROR
+(LAMBDA (STREAM) (* hdj "17-Jun-86 18:35") (LISPERROR "END OF FILE" (fetch (STREAM FULLNAME) of STREAM) T))
+)
+
+(\GETEOFPTR
+(LAMBDA (STREAM) (* lmm "25-MAY-83 23:17") (FDEVOP (QUOTE GETEOFPTR) (fetch DEVICE of STREAM) STREAM))
+)
+
+(\INCFILEPTR
+(LAMBDA (STREAM AMOUNT) (* bvm%: " 7-Jun-84 16:47") (COND ((NOT (fetch PAGEMAPPED of (fetch DEVICE of STREAM))) (\SETFILEPTR STREAM (IPLUS (\GETFILEPTR STREAM) AMOUNT))) (T (\PAGED.INCFILEPTR STREAM AMOUNT))))
+)
+
+(\PEEKBIN
+(LAMBDA (STREAM NOERRORFLG) (* bvm%: "26-DEC-81 15:59") (FDEVOP (QUOTE PEEKBIN) (fetch DEVICE of STREAM) STREAM NOERRORFLG))
+)
+
+(\SETCLOSEDFILELENGTH
+(LAMBDA (FILENAME NBYTES) (* bvm%: "13-JUL-83 15:15") (* ;; "Reset the length of a closed file to nBytes.") (PROG ((STREAM (\OPENFILE FILENAME (QUOTE BOTH) (QUOTE OLD)))) (\SETEOFPTR STREAM NBYTES) (\CLOSEFILE STREAM) (RETURN T)))
+)
+
+(\SETEOFPTR
+(LAMBDA (STREAM LEN) (* bvm%: " 9-Jul-84 17:37") (FDEVOP (QUOTE SETEOFPTR) (fetch DEVICE of STREAM) STREAM LEN))
+)
+
+(\SETFILEPTR
+(LAMBDA (STREAM INDX) (* rmk%: "22-AUG-83 13:37") (* ;; "Fast case of SETFILEPTR, assumes STREAM is a stream and INDX is an already coerced fileptr (not -1) Does not reset CHARPOSITION and value is uninteresting") (FDEVOP (QUOTE SETFILEPTR) (fetch DEVICE of STREAM) STREAM INDX))
+)
+)
+(DEFINEQ
+
+(\FIXPOUT
+(LAMBDA (STRM N) (* rmk%: "25-Jun-84 14:47") (\BOUT STRM (LOADBYTE N 24 BITSPERBYTE)) (\BOUT STRM (LOADBYTE N 16 BITSPERBYTE)) (\BOUT STRM (LOADBYTE N 8 BITSPERBYTE)) (\BOUT STRM (LOADBYTE N 0 BITSPERBYTE)))
+)
+
+(\FIXPIN
+(LAMBDA (STRM) (* rmk%: "14-Jun-84 19:36") (* ;; "Read in a full 32 bit integer") (LOGOR (LLSH (\WIN STRM) 16) (\WIN STRM)))
+)
+)
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \DECFILEPTR MACRO ((STREAM X)
+                                     (\INCFILEPTR STREAM (IMINUS X))))
+
+(PUTPROPS \GETFILEPTR MACRO (OPENLAMBDA (STRM)
+                                           (FDEVOP 'GETFILEPTR (fetch DEVICE of STRM)
+                                                  STRM)))
+
+(PUTPROPS \SIGNEDWIN MACRO ((STREAM)
+                                    (SIGNED (\WIN STREAM)
+                                           BITSPERWORD)))
+
+(PUTPROPS \SIGNEDWOUT MACRO ((STREAM N)
+                                     (\WOUT STREAM (UNSIGNED N BITSPERWORD))))
+
+(PUTPROPS \WIN MACRO (OPENLAMBDA (STREAM)
+                                    (create WORD
+                                           HIBYTE _ (\BIN STREAM)
+                                           LOBYTE _ (\BIN STREAM))))
+
+(PUTPROPS \WOUT MACRO (OPENLAMBDA (STREAM W)
+                                     (\BOUT STREAM (fetch HIBYTE of W))
+                                     (\BOUT STREAM (fetch LOBYTE of W))))
+
+(PUTPROPS \BINS BYTEMACRO (OPENLAMBDA (STRM BASE OFF NBYTES)
+                                         (FDEVOP 'BLOCKIN (fetch (STREAM DEVICE) of STRM)
+                                                STRM BASE OFF NBYTES)))
+
+(PUTPROPS \BOUTS BYTEMACRO (OPENLAMBDA (STRM BASE OFF NBYTES)
+                                          (FDEVOP 'BLOCKOUT (fetch (STREAM DEVICE) of STRM)
+                                                 STRM BASE OFF NBYTES)))
+
+(PUTPROPS \EOFP BYTEMACRO (OPENLAMBDA (STRM)
+                                         (FDEVOP 'EOFP (fetch (STREAM DEVICE) of STRM)
+                                                STRM)))
+
+(PUTPROPS SIZE.FROM.LENGTH MACRO [LAMBDA (LEN)
+                                           (DECLARE (LOCALVARS LEN))
+                                           (AND LEN (FOLDHI LEN BYTESPERPAGE])
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ BitsPerByte 8)
+
+(RPAQ ByteOffsetSize (SELECTQ (SYSTEMTYPE)
+                                (VAX 10)
+                                9))
+
+(RPAQQ WordsPerPage 256)
+
+
+(CONSTANTS BitsPerByte (ByteOffsetSize (SELECTQ (SYSTEMTYPE)
+                                           (VAX 10)
+                                           9))
+       WordsPerPage)
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQ \MAXFILEPTR (SUB1 (LLSH 1 30)))
+
+
+[CONSTANTS (\MAXFILEPTR (SUB1 (LLSH 1 30]
+)
+(DECLARE%: EVAL@COMPILE
+
+(ACCESSFNS BYTEPTR ((PAGE (FOLDLO DATUM BYTESPERPAGE))
+                        (OFFSET (MOD DATUM BYTESPERPAGE)))
+                       (TYPE? (AND (FIXP DATUM)
+                                       (IGEQ DATUM 0)
+                                       (ILEQ DATUM \MAXFILEPTR)))
+                       (CREATE (IPLUS (UNFOLD PAGE BYTESPERPAGE)
+                                          OFFSET)))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ MaxChar 255)
+
+
+(CONSTANTS MaxChar)
+)
+)
+
+
+
+(* ; "Buffered IO")
+
+(DEFINEQ
+
+(\BUFFERED.BIN
+(LAMBDA (STREAM) (* bvm%: "10-Jul-84 13:25") (PROG (OFF X) RETRY (RETURN (\GETBASEBYTE (OR (fetch CBUFPTR of STREAM) (GO REFILL)) (PROG1 (SETQ OFF (fetch COFFSET of STREAM)) (COND ((IGEQ OFF (fetch CBUFSIZE of STREAM)) (GO REFILL))) (replace COFFSET of STREAM with (ADD1 OFF))))) REFILL (COND ((EQ (SETQ X (FDEVOP (QUOTE GETNEXTBUFFER) (fetch DEVICE of STREAM) STREAM (QUOTE READ))) T) (GO RETRY)) (T (RETURN X)))))
+)
+
+(\BUFFERED.PEEKBIN
+(LAMBDA (STREAM NOERRORFLG) (* bvm%: "24-Aug-84 17:43") (PROG (OFF X) RETRY (RETURN (\GETBASEBYTE (OR (fetch CBUFPTR of STREAM) (GO REFILL)) (PROG1 (SETQ OFF (fetch COFFSET of STREAM)) (COND ((IGEQ OFF (fetch CBUFSIZE of STREAM)) (GO REFILL)))))) REFILL (COND ((EQ (SETQ X (FDEVOP (QUOTE GETNEXTBUFFER) (fetch DEVICE of STREAM) STREAM (QUOTE READ) NOERRORFLG)) T) (GO RETRY)) (T (RETURN X)))))
+)
+
+(\BUFFERED.BOUT
+(LAMBDA (STREAM BYTE) (* bvm%: "10-Jul-84 13:30") (CHECK (type? STREAM STREAM) (WRITEABLE STREAM)) (PROG (OFF) RETRY (\PUTBASEBYTE (OR (fetch CBUFPTR of STREAM) (GO REFILL)) (PROG1 (SETQ OFF (fetch COFFSET of STREAM)) (COND ((ILESSP OFF (fetch CBUFMAXSIZE of STREAM)) (replace COFFSET of STREAM with (ADD1 OFF))) (T (GO REFILL)))) BYTE) (replace CBUFDIRTY of STREAM with T) (RETURN 1) REFILL (FDEVOP (QUOTE GETNEXTBUFFER) (fetch DEVICE of STREAM) STREAM (QUOTE WRITE)) (GO RETRY)))
+)
+
+(\BUFFERED.BINS
+(LAMBDA (STREAM DBASE OFFSET NBYTES NOERRORFLG) (* bvm%: "11-Jul-84 19:15") (* ;;; "For buffered streams, BINs NBYTES bytes from STREAM to memory starting at DBASE+OFFSET --- If NOERRORFLG then stops without error at eof.  Returns number of bytes actually read") (bind (BYTESLEFT _ NBYTES) CNT END IBASE START X do (COND ((SETQ IBASE (fetch CBUFPTR of STREAM)) (* ; "Current buffer") (SETQ START (fetch COFFSET of STREAM)) (* ; "Offset of first byte to transfer") (COND ((IGREATERP (SETQ CNT (IDIFFERENCE (SETQ END (fetch CBUFSIZE of STREAM)) START)) BYTESLEFT) (* ; "Not a whole buffer full") (SETQ END (IPLUS START (SETQ CNT BYTESLEFT))))) (* ; "First byte BEYOND whats to be read from this page") (\MOVEBYTES IBASE START DBASE OFFSET CNT) (replace COFFSET of STREAM with END) (COND ((EQ CNT BYTESLEFT) (* ; "Finished") (RETURN NBYTES)) (T (add OFFSET CNT) (SETQ BYTESLEFT (IDIFFERENCE BYTESLEFT CNT)))))) (COND ((NULL (SETQ X (FDEVOP (QUOTE GETNEXTBUFFER) (fetch DEVICE of STREAM) STREAM (QUOTE READ) NOERRORFLG))) (* ; "No error at eof") (RETURN (IDIFFERENCE NBYTES BYTESLEFT))) ((NEQ X T) (* ; "At eof, but EOF op returned a value to fake more data at eof") (RETURN (do (\PUTBASEBYTE DBASE OFFSET X) (add OFFSET 1) (COND ((EQ (add BYTESLEFT -1) 0) (RETURN NBYTES))) (SETQ X (\BIN STREAM))))))))
+)
+
+(\BUFFERED.BOUTS
+(LAMBDA (STREAM SBASE OFFSET NBYTES) (* bvm%: "10-Jul-84 13:39") (* ;;; "For buffered streams, bouts NBYTES bytes to STREAM from SBASE+OFFSET") (bind (DEV _ (fetch DEVICE of STREAM)) CNT END DBASE START do (COND ((SETQ DBASE (fetch CBUFPTR of STREAM)) (SETQ START (fetch COFFSET of STREAM)) (COND ((IGREATERP (SETQ CNT (IDIFFERENCE (SETQ END (fetch CBUFMAXSIZE of STREAM)) START)) NBYTES) (SETQ END (IPLUS START (SETQ CNT NBYTES))))) (\MOVEBYTES SBASE OFFSET DBASE START CNT) (replace COFFSET of STREAM with END) (replace CBUFDIRTY of STREAM with T) (COND ((ILEQ (SETQ NBYTES (IDIFFERENCE NBYTES CNT)) 0) (RETURN)) (T (add OFFSET CNT))))) (FDEVOP (QUOTE GETNEXTBUFFER) DEV STREAM (QUOTE WRITE))))
+)
+
+(\BUFFERED.COPYBYTES
+(LAMBDA (SRC DST NBYTES) (* bvm%: "10-Jul-84 21:48") (* ;;; "Copies NBYTES bytes from buffered stream SRC to arbitrary stream DST, or copies to eof if NBYTES is NIL") (bind (NOERRORFLG _ (NULL NBYTES)) (DEV _ (fetch DEVICE of SRC)) BUF NB STARTOFFSET END do (COND ((SETQ BUF (fetch CBUFPTR of SRC)) (* ; "Copy a buffer full") (SETQ NB (IDIFFERENCE (SETQ END (fetch CBUFSIZE of SRC)) (SETQ STARTOFFSET (fetch COFFSET of SRC)))) (COND ((AND NBYTES (IGREATERP NB NBYTES)) (* ; "Don't copy too much") (SETQ END (IPLUS STARTOFFSET (SETQ NB NBYTES))))) (\BOUTS DST BUF STARTOFFSET NB) (replace COFFSET of SRC with END) (COND (NBYTES (COND ((EQ NB NBYTES) (RETURN)) (T (SETQ NBYTES (IDIFFERENCE NBYTES NB)))))))) repeatwhile (FDEVOP (QUOTE GETNEXTBUFFER) DEV SRC (QUOTE READ) NOERRORFLG)))
+)
+)
+
+
+
+(* ; "NULL device")
+
+(DEFINEQ
+
+(\NULLDEVICE
+(LAMBDA NIL (* bvm%: "30-Jan-85 22:06") (* ;; "Defines the NULL device, an infinite source or sink") (\DEFINEDEVICE (QUOTE NULL) (create FDEV DEVICENAME _ (QUOTE NULL) RANDOMACCESSP _ T NODIRECTORIES _ T CLOSEFILE _ (FUNCTION NILL) DELETEFILE _ (FUNCTION NILL) OPENFILE _ (FUNCTION \NULL.OPENFILE) REOPENFILE _ (FUNCTION \NULL.OPENFILE) BIN _ (FUNCTION \EOF.ACTION) BOUT _ (FUNCTION NILL) PEEKBIN _ (FUNCTION (LAMBDA (STREAM NOERRORFLG) (AND (NULL NOERRORFLG) (BIN STREAM)))) READP _ (FUNCTION NILL) BACKFILEPTR _ (FUNCTION NILL) EOFP _ (FUNCTION TRUE) RENAMEFILE _ (FUNCTION NILL) GETFILENAME _ (FUNCTION NILL) EVENTFN _ (FUNCTION NILL) BLOCKIN _ (FUNCTION \EOF.ACTION) BLOCKOUT _ (FUNCTION NILL) GENERATEFILES _ (FUNCTION \NULLFILEGENERATOR) GETFILEPTR _ (FUNCTION ZERO) GETEOFPTR _ (FUNCTION ZERO) SETFILEPTR _ (FUNCTION NILL) GETFILEINFO _ (FUNCTION NILL) SETFILEINFO _ (FUNCTION NILL) SETEOFPTR _ (FUNCTION NILL))))
+)
+
+(\NULL.OPENFILE
+(LAMBDA (NAME ACCESS RECOG PARAMETERS DEVICE OLDSTREAM) (* bvm%: "30-Jan-85 22:05") (OR OLDSTREAM (create STREAM USERCLOSEABLE _ T ACCESS _ ACCESS FULLFILENAME _ NIL DEVICE _ DEVICE)))
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(\NULLDEVICE)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA \IS.NOT.RANDACCESSP \ILLEGAL.DEVICEOP STREAMPROP)
+)
+(PUTPROPS FILEIO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 
+1990 1991 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (33011 34195 (STREAMPROP 33021 . 33300) (GETSTREAMPROP 33302 . 33468) (PUTSTREAMPROP 
+33470 . 34112) (STREAMP 34114 . 34193)) (34238 35788 (\DEFPRINT.BY.NAME 34248 . 35025) (
+\STREAM.DEFPRINT 35027 . 35560) (\FDEV.DEFPRINT 35562 . 35786)) (36046 38427 (\GETACCESS 36056 . 36423
+) (\SETACCESS 36425 . 38425)) (61949 64543 (\INSTALL.EXTERNALFORMAT 61959 . 62854) (
+\REMOVE.EXTERNALFORMAT 62856 . 63471) (\GET.EXTERNALFORMAT.FROM.NAME 63473 . 63744) (\EXTERNALFORMAT 
+63746 . 64541)) (64776 66891 (\CREATE.JIS.EXTERNALFORMAT 64786 . 65184) (
+\CREATE.SHIFTJIS.EXTERNALFORMAT 65186 . 65960) (\CREATE.EUC.EXTERNALFORMAT 65962 . 66360) (
+\CREATE.THROUGH.EXTERNALFORMAT 66362 . 66889)) (67106 70824 (\DEFINEDEVICE 67116 . 68608) (
+\GETDEVICEFROMNAME 68610 . 68953) (\GETDEVICEFROMHOSTNAME 68955 . 69693) (\REMOVEDEVICE 69695 . 70219)
+ (\REMOVEDEVICE.NAMES 70221 . 70822)) (70825 87348 (\CLOSEFILE 70835 . 71409) (\DELETEFILE 71411 . 
+71648) (\DEVICEEVENT 71650 . 72866) (\GENERATEFILES 72868 . 73295) (\GENERATENEXTFILE 73297 . 73859) (
+\GENERATEFILEINFO 73861 . 74234) (\GETFILENAME 74236 . 74556) (\GENERIC.READCCODE 74558 . 75081) (
+\GENERIC.OUTFILEP 75083 . 75391) (\OPENFILE 75393 . 77171) (\DO.PARAMS.AT.OPEN 77173 . 79181) (
+\RENAMEFILE 79183 . 79532) (\REVALIDATEFILE 79534 . 80876) (\PAGED.REVALIDATEFILELST 80878 . 81671) (
+\PAGED.REVALIDATEFILES 81673 . 82510) (\PAGED.REVALIDATEFILE 82512 . 83847) (\BUFFERED.REVALIDATEFILE 
+83849 . 85187) (\BUFFERED.REVALIDATEFILELST 85189 . 85895) (\PRINT-REVALIDATION-RESULT 85897 . 86234) 
+(\TRUNCATEFILE 86236 . 86575) (\FILE-CONFLICT 86577 . 87346)) (87384 89991 (\GENERATENOFILES 87394 . 
+88377) (\NULLFILEGENERATOR 88379 . 88544) (\NOFILESNEXTFILEFN 88546 . 89740) (\NOFILESINFOFN 89742 . 
+89989)) (90110 91217 (\FILE.NOT.OPEN 90120 . 90440) (\FILE.WONT.OPEN 90442 . 90596) (\ILLEGAL.DEVICEOP
+ 90598 . 90751) (\IS.NOT.RANDACCESSP 90753 . 90961) (\STREAM.NOT.OPEN 90963 . 91215)) (91352 93048 (
+\FDEVINSTANCE 91362 . 93046)) (94598 97957 (CNDIR 94608 . 95336) (DIRECTORYNAME 95338 . 96473) (
+DIRECTORYNAMEP 96475 . 96995) (HOSTNAMEP 96997 . 97510) (\ADD.CONNECTED.DIR 97512 . 97955)) (98002 
+116433 (\BACKFILEPTR 98012 . 98138) (\BACKPEEKBIN 98140 . 98411) (\BACKBIN 98413 . 98688) (BIN 98690
+ . 98787) (\BIN 98789 . 98954) (\BINS 98956 . 99195) (BOUT 99197 . 99396) (\BOUT 99398 . 99640) (
+\BOUTS 99642 . 99906) (COPYBYTES 99908 . 101322) (COPYCHARS 101324 . 103664) (COPYFILE 103666 . 104470
+) (\COPYOPENFILE 104472 . 107339) (\INFER.FILE.TYPE 107341 . 107906) (EOFP 107908 . 108137) (
+FORCEOUTPUT 108139 . 108341) (\FLUSH.OPEN.STREAMS 108343 . 108597) (CHARSET 108599 . 109739) (
+ACCESS-CHARSET 109741 . 109905) (GETEOFPTR 109907 . 110071) (GETFILEINFO 110073 . 111773) (
+\TYPE.FROM.FILETYPE 111775 . 112079) (\FILETYPE.FROM.TYPE 112081 . 112200) (GETFILEPTR 112202 . 112368
+) (SETFILEINFO 112370 . 115554) (SETFILEPTR 115556 . 116204) (BOUT16 116206 . 116326) (BIN16 116328 . 
+116431)) (116536 119547 (\GENERIC.BINS 116546 . 116764) (\GENERIC.BOUTS 116766 . 116969) (
+\GENERIC.RENAMEFILE 116971 . 117859) (\GENERIC.OPENP 117861 . 118500) (\GENERIC.READP 118502 . 119161)
+ (\GENERIC.CHARSET 119163 . 119545)) (119548 119795 (\MAP-OPEN-STREAMS 119558 . 119793)) (122288 
+123784 (\EOF.ACTION 122298 . 122470) (\EOSERROR 122472 . 122596) (\GETEOFPTR 122598 . 122718) (
+\INCFILEPTR 122720 . 122948) (\PEEKBIN 122950 . 123090) (\SETCLOSEDFILELENGTH 123092 . 123350) (
+\SETEOFPTR 123352 . 123482) (\SETFILEPTR 123484 . 123782)) (123785 124161 (\FIXPOUT 123795 . 124018) (
+\FIXPIN 124020 . 124159)) (127318 131546 (\BUFFERED.BIN 127328 . 127764) (\BUFFERED.PEEKBIN 127766 . 
+128184) (\BUFFERED.BOUT 128186 . 128689) (\BUFFERED.BINS 128691 . 130012) (\BUFFERED.BOUTS 130014 . 
+130733) (\BUFFERED.COPYBYTES 130735 . 131544)) (131575 132734 (\NULLDEVICE 131585 . 132524) (
+\NULL.OPENFILE 132526 . 132732)))))
+STOP
diff --git a/CLTL2/FILEIO.LCOM b/CLTL2/FILEIO.LCOM
new file mode 100644
index 00000000..25d34d8e
Binary files /dev/null and b/CLTL2/FILEIO.LCOM differ
diff --git a/CLTL2/FILEPKG b/CLTL2/FILEPKG
new file mode 100644
index 00000000..2c9a9f8e
--- /dev/null
+++ b/CLTL2/FILEPKG
@@ -0,0 +1,2318 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+(FILECREATED "12-Oct-93 18:01:09" "{Pele:mv:envos}<LispCore>Sources>CLTL2>FILEPKG.;1" 190280 
+
+      changes to%:  (FNS DEFAULT.EDITDEF)
+                    (VARS FILEPKGCOMS)
+
+      previous date%: "22-Sep-92 19:19:15" {DSK}<mo>usr>users>sybalsky>cltl2>sources>FILEPKG.;1)
+
+
+(* ; "
+Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+The following program was created in 1982 but has not been published
+within the meaning of the copyright law, is furnished under license,
+and may not be used, copied and/or disclosed except in accordance
+with the terms of said license.
+")
+
+(PRETTYCOMPRINT FILEPKGCOMS)
+
+(RPAQQ FILEPKGCOMS
+       [(COMS                                                (* ; 
+            "standard records for accessing file  package type/command parts.  Exported for PRETTY")
+              (VARS FILEPKGTYPEPROPS)
+              (EXPORT (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS * FILEPKGRECORDS)))
+              (FNS SEARCHPRETTYTYPELST PRETTYDEFMACROS FILEPKGCOMPROPS)
+              (INITRECORDS * FILEPKGRECORDS))
+        [DECLARE%: EVAL@COMPILE DOCOPY 
+
+               (* ;; "Proclaim SPECIAL those variables that are used freely in a lot of code.")
+
+               (P (CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES 
+                                       PRETTYPRINTMACROS *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS
+                                       PRETTYFLG))
+                  (CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES 
+                                       NOTCOMPILEDFILES MAKEFILEFORMS CLEANUPOPTIONS]
+        (INITVARS (MSDATABASELST))
+        [COMS 
+              (* ;; "making, adding, listing, compiling files")
+
+              (FNS CLEANUP COMPILEFILES COMPILEFILES0 CONTINUEDIT MAKEFILE FILECHANGES 
+                   FILEPKG.MERGECHANGES FILEPKG.CHANGEDFNS MAKEFILE1 COMPILE-FILE? MAKEFILES ADDFILE
+                   ADDFILE0 LISTFILES)
+              (INITVARS (*DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)
+                     (FILELST)
+                     (LOADEDFILELST)
+                     (NOTLISTEDFILES)
+                     (NOTCOMPILEDFILES)
+                     (MAKEFILEFORMS)
+                     (NILCOMS))
+              (ADDVARS (MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP 
+                              CLISP%  F ST STF (REC . RC)
+                              (BREC . RC)
+                              (TC . C)
+                              (BC . C)
+                              (TCOMPL . C)
+                              (BCOMPL . C)))
+              (INITVARS (MAKEFILEREMAKEFLG T)
+                     (CLEANUPOPTIONS '(RC]
+        (COMS 
+              (* ;; "scanning file coms")
+
+              (FNS FILEPKGCHANGES GETFILEPKGTYPE MARKASCHANGED FILECOMS WHEREIS SMASHFILECOMS 
+                   FILEFNSLST FILECOMSLST UPDATEFILES INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM
+                   INFILECOMSVALS INFILECOMSVAL INFILECOMSPROP IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
+                   IFCDECLARE INFILEPAIRS INFILECOMSMACRO))
+        (COMS 
+              (* ;; "adding to a file")
+
+              (FNS FILES? FILES?1 FILES?PRINTLST ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM 
+                   ADDTOCOM1 ADDNEWCOM MAKENEWCOM DEFAULTMAKENEWCOM)
+              (INITVARS (DEFAULTCOMHASFILEFLG))
+              (ADDVARS (MARKASCHANGEDFNS))
+              (FNS MERGEINSERT MERGEINSERT1)
+              (INITVARS [ADDTOFILEKEYLST `((%[ "" EXPLAINSTRING 
+                                           "[ -- prettyprint the item to terminal and then ask again"
+                                               NOECHOFLG T)
+                                           ((MKSTRING (CHARACTER (CHARCODE "^J")))
+                                            "" EXPLAINSTRING 
+                                            "{line-feed} - same as previous response" NOECHOFLG T)
+                                           (%  " 
+" EXPLAINSTRING "{space} - no action" NOECHOFLG T)
+                                           (%] "Nowhere
+" EXPLAINSTRING "] - nowhere, item is marked as a dummy
+" NOECHOFLG T)
+                                           [%( "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T 
+                                               KEYLST (( "" CONFIRMFLG (%) %] %  %
+)
+                                                          RETURN
+                                                          (CDR ANSWER]
+                                           (@ "Near: " EXPLAINSTRING 
+                                                 "@ other-item   -- put the item near the other item"
+                                                    NOECHOFLG T KEYLST (( "" CONFIRMFLG (%
+)
+                                                                           RETURN ANSWER)))
+                                           (%
+ "" RETURN '% )
+                                           ("" "File name: " EXPLAINSTRING "a file name" KEYLST
+                                               (]
+                     (LASTFILE)))
+        (COMS 
+              (* ;; "deleting an item from a file")
+
+              (FNS DELFROMFILES DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM MOVETOFILE)
+              (P (MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)
+                 (MOVD? 'MOVETOFILE 'MOVEITEM NIL T))
+              (ADDVARS (SYSPROPS PROPTYPE VARTYPE)))
+        [COMS                                                (* ; 
+                      "functions for doing things and marking them changed and auxiliary functions")
+              (FNS SAVEPUT)
+              [DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
+                                                     (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT]
+              (FNS UNMARKASCHANGED PREEDITFN POSTEDITPROPS POSTEDITALISTS)
+              (ADDVARS (LISPXFNS (PUT . SAVEPUT)
+                              (PUTPROP . SAVEPUT]
+        (COMS                                                (* ; 
+                                                  "sub-functions for file package commands & types")
+              (FNS ALISTS.GETDEF ALISTS.WHENCHANGED CLEARCLISPARRAY EXPRESSIONS.WHENCHANGED 
+                   MAKEALISTCOMS MAKEFILESCOMS MAKELISPXMACROSCOMS MAKEPROPSCOMS MAKEUSERMACROSCOMS 
+                   PROPS.WHENCHANGED FILEGETDEF.LISPXMACROS FILEGETDEF.ALISTS FILEGETDEF.RECORDS 
+                   FILEGETDEF.PROPS FILEGETDEF.MACROS FILEGETDEF.VARS FILEGETDEF.FNS 
+                   FILEPKGCOMS.PUTDEF FILES.PUTDEF VARS.PUTDEF FILES.WHENCHANGED)
+              (ADDVARS (MACROPROPS MACRO BYTEMACRO DMACRO)
+                     (SYSPROPS PROPTYPE))
+              (PROP PROPTYPE I.S.OPR SUBR LIST CODE FILEDATES FILE FILEMAP EXPR VALUE COPYRIGHT 
+                    FILETYPE)
+              (PROP VARTYPE BAKTRACELST BREAKMACROS COMPILETYPELST EDITMACROS ERRORTYPELST FONTDEFS 
+                    LISPXHISTORYMACROS LISPXMACROS PRETTYDEFMACROS PRETTYEQUIVLST PRETTYPRINTMACROS 
+                    PRETTYPRINTYPEMACROS USERMACROS))
+        (COMS                                                (* ; 
+                    "Define the commands below AFTER the various properties have been established.")
+              (USERMACROS M))
+        (COMS                                                (* ; "GETDEF methods")
+              (FNS RENAME CHANGECALLERS)
+              (FNS SHOWDEF COPYDEF GETDEF GETDEFCOM GETDEFCOM0 GETDEFCURRENT GETDEFERR GETDEFFROMFILE
+                   GETDEFSAVED PUTDEF EDITDEF DEFAULT.EDITDEF EDITDEF.FILES LOADDEF DWIMDEF DELDEF 
+                   DELFROMLIST HASDEF GETFILEDEF SAVEDEF UNSAVEDEF COMPAREDEFS COMPARE TYPESOF)
+              (INITVARS (WHEREIS.HASH)))
+                                                             (* ; "Must come after PUTDEF")
+        (COMS (FNS FIXEDITDATE EDITDATE?)
+                                                             (* ; 
+                                  "Edit date support for all kinds of definers (from PARC 6/10/92)")
+              [VARS (EDITDATE-ARGLIST-DEFINERS '(FUNCTIONS TYPES))
+                    (EDITDATE-NAME-DEFINERS '(STRUCTURES VARIABLES]
+              (GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS))
+        (COMS 
+              (* ;; "how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started.")
+
+              (FNS FILEPKGCOM FILEPKGTYPE)
+              (PROP ARGNAMES FILEPKGCOM)
+              (ADDVARS (FILEPKGCOMSPLST FILEPKGCOMS)
+                     (FILEPKGTYPES FILEPKGCOMS))
+              (FILEPKGCOMS FILEPKGCOMS)
+              (FILEPKGCOMS ALISTS DEFS EDITMACROS EXPRESSIONS FIELDS FILEPKGTYPES FILES FILEVARS FNS
+                     INITRECORDS INITVARS LISPXCOMS LISPXMACROS MACROS PRETTYDEFMACROS PROPS RECORDS
+                     OLDRECORDS SYSRECORDS USERMACROS VARS * CONSTANTS))
+        (ADDVARS (SHADOW-TYPES (FUNCTIONS FNS)
+                        (VARIABLES VARS CONSTANTS)))
+        (INITVARS (SAVEDDEFS))
+        (COMS                                                (* ; "EDITCALLERS")
+              (FNS FINDCALLERS EDITCALLERS EDITFROMFILE FINDATS LOOKIN)
+              (FNS SEPRCASE)
+              [INITVARS (DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL]
+              (INITVARS (SEPRCASEARRAYS)
+                     (CLISPCASEARRAYS))
+              (P (MOVD? 'INFILEP 'FINDFILE)
+                                                             (* ; "or else from SPELLFILE"))
+              (BLOCKS (EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
+                             (NOLINKFNS LOADFROM)))
+              (GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS))
+        (COMS                                                (* ; "EXPORT")
+              (FNS IMPORTFILE IMPORTEVAL IMPORTFILESCAN CHECKIMPORTS GATHEREXPORTS \DUMPEXPORTS)
+              (FILEPKGCOMS EXPORT)
+              [INITVARS (BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")
+                     (ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"]
+              (GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM))
+        (COMS                                                (* ; "for GAINSPACE")
+              (FNS CLEARFILEPKG)
+              [ADDVARS (GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
+                                              ((Y "es")
+                                               (N "o")
+                                               (E . "verything")
+                                               (F "ilemaps only
+"]
+              (GLOBALVARS SMASHPROPSLST1))
+        (GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT 
+               DECLARETAGSLST DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 
+               I.S.OPRLST LISPXCOMS LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS 
+               MAKEFILEOPTIONS MAKEFILEREMAKEFLG MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS 
+               SYSPROPS USERMACROS USERRECLST USERWORDS FILEPKGTYPEPROPS)
+        (BLOCKS (DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
+                       (SPECVARS COMSNAME))
+               (ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
+                      (NOLINKFNS . T)
+                      (SPECVARS COMSNAME)
+                      (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))
+               (INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL 
+                      INFILECOMSVALS INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
+                      IFCDECLARE (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
+                      INFILECOMSPROP)
+               (NIL MAKEFILE (LOCALVARS . T)
+                      (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))
+               (ADDFILE ADDFILE ADDFILE0)
+               (FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))
+               (NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
+                      COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES 
+                      EDITDEF EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM 
+                      FILEPKGCOMPROPS FILEPKGTYPE FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL
+                      LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES MAKEFILESCOMS MAKELISPXMACROSCOMS 
+                      MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED MOVETOFILE 
+                      POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF
+                      SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED 
+                      UNSAVEDEF UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS 
+                                                   COMPILE.EXT EDITMACROS EDITLOADFNSFLG LOADOPTIONS)
+                      (LOCALVARS . T))
+               (DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))
+               (GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
+                      GETDEFSAVED (RETFNS GETDEFCOM)
+                      (NOLINKFNS . T)
+                      (GLOBALVARS NOT-FOUNDTAG)))
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS 
+                               MAKEFILESCOMS MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP 
+                               FILEPKGCOMPROPS PRETTYDEFMACROS)
+                      (NLAML)
+                      (LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES])
+
+
+
+(* ; "standard records for accessing file  package type/command parts.  Exported for PRETTY")
+
+
+(RPAQQ FILEPKGTYPEPROPS (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
+                                   HASDEF EDITDEF CANFILEDEF FILEGETDEF))
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE DONTCOPY 
+
+(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
+(DECLARE%: EVAL@COMPILE
+
+(ACCESSFNS FILEPKGCOM [[ADD (GETPROP DATUM 'ADDTOPRETTYCOM)
+                                  (UNDOABLE (COND
+                                               (NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE))
+                                               (T (/REMPROP DATUM 'ADDTOPRETTYCOM]
+                           [DELETE (GETPROP DATUM 'DELFROMPRETTYCOM)
+                                  (UNDOABLE (COND
+                                               (NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE))
+                                               (T (/REMPROP DATUM 'DELFROMPRETTYCOM]
+                           [PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE)
+                                  (UNDOABLE (COND
+                                               (NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE))
+                                               (T (/REMPROP DATUM 'PRETTYTYPE]
+                           [CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS)
+                                  (UNDOABLE (COND
+                                               (NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE))
+                                               (T (/REMPROP DATUM 'FILEPKGCONTENTS]
+                           (MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS]
+                                  (STANDARD [COND
+                                               [NEWVALUE (PUTASSOC DATUM NEWVALUE
+                                                                (OR (LISTP (GETTOPVAL 
+                                                                                  'PRETTYDEFMACROS))
+                                                                    (SETTOPVAL 'PRETTYDEFMACROS
+                                                                           (LIST (LIST DATUM]
+                                               (T (SETTOPVAL 'PRETTYDEFMACROS
+                                                         (REMOVE (FASSOC DATUM (GETTOPVAL
+                                                                                'PRETTYDEFMACROS))
+                                                                (GETTOPVAL 'PRETTYDEFMACROS]
+                                         UNDOABLE
+                                         (COND
+                                            [NEWVALUE (/PUTASSOC DATUM NEWVALUE
+                                                             (OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS))
+                                                                 (/SETTOPVAL 'PRETTYDEFMACROS
+                                                                        (LIST (LIST DATUM]
+                                            (T (/SETTOPVAL 'PRETTYDEFMACROS
+                                                      (REMOVE (FASSOC DATUM (GETTOPVAL 
+                                                                                   'PRETTYDEFMACROS))
+                                                             (GETTOPVAL 'PRETTYDEFMACROS]
+                                                             (* Not an atom record cause want 
+                                                           REMPROP on NILs.)
+                                                             (* NOTE%: PRETTCOM on PRETTY has 
+                                                           open-coded access to the MACRO 
+                                                           property.)
+                          (INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE 
+                                       FILEPKGCONTENTS)))
+
+(ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
+                                   HASDEF EDITDEF FILEGETDEF CANFILEDEF)
+                            (ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM))
+                                                           (CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
+                                                           )
+                                                    (CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST
+                                                                              DATUM)))
+                                                           (STANDARD (SETTOPVAL (CAR (
+                                                                                  SEARCHPRETTYTYPELST
+                                                                                      DATUM NEWVALUE)
+                                                                                     )
+                                                                            NEWVALUE)
+                                                                  UNDOABLE
+                                                                  (/SETTOPVAL (CAR (
+                                                                                  SEARCHPRETTYTYPELST
+                                                                                    DATUM NEWVALUE))
+                                                                         NEWVALUE)))
+                                                    (DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST
+                                                                             DATUM)))
+                                                           (CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST
+                                                                               DATUM NEWVALUE))
+                                                                       NEWVALUE)))
+                                                    (ALLFIELDS NIL
+                                                           (/SETTOPVAL 'PRETTYTYPELST
+                                                                  (REMOVE (SEARCHPRETTYTYPELST DATUM)
+                                                                         (GETTOPVAL 'PRETTYTYPELST]
+                                                             (* NOTE%: PRETTYCOM on PRETTY has 
+                                                           open-coded access to GETDEF property)
+                                   (INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
+                                                (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
+                                                                                   (PUT X
+                                                                                        'PROPTYPE
+                                                                                        'FILEPKGCOMS]
+                                         (ADDTOVAR PRETTYTYPELST ))))
+
+(ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP)
+                     [ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE)
+                                             (STANDARD (PUTPROP DATUM 'FILE NEWVALUE)
+                                                    UNDOABLE
+                                                    (/PUTPROP DATUM 'FILE NEWVALUE])
+
+(RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME))
+
+(RECORD FILEPROP ((COMSNAME . LOADTYPE) . TOBEDUMPED))
+)
+
+(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)
+
+[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
+       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
+                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]
+
+(ADDTOVAR PRETTYTYPELST )
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+(DEFINEQ
+
+(SEARCHPRETTYTYPELST
+(LAMBDA (TYPE FLG) (* rmk%: " 3-JAN-82 22:55") (* ; "access functions used by the records") (AND (LITATOM TYPE) (OR (find X in PRETTYTYPELST suchthat (EQ (CADR X) TYPE)) (COND (FLG (/SETTOPVAL (QUOTE PRETTYTYPELST) (CONS (SETQ FLG (LIST (PACK* (QUOTE CHANGED) TYPE (QUOTE LST)) TYPE NIL)) (GETTOPVAL (QUOTE PRETTYTYPELST)))) (OR (LISTP (GETTOPVAL (CAR FLG))) (/SETTOPVAL (CAR FLG) NIL)) FLG)))))
+)
+
+(PRETTYDEFMACROS
+(NLAMBDA ARGS (* lmm " 5-SEP-78 16:16") (* ; "included so that old files will continue to load") (for X in ARGS collect (FILEPKGCOM (CAR X) (QUOTE MACRO) (CDR X))))
+)
+
+(FILEPKGCOMPROPS
+(NLAMBDA PROPS (MAPC PROPS (FUNCTION (LAMBDA (Y) (OR (MEMB Y SYSPROPS) (SETQ SYSPROPS (CONS Y SYSPROPS))) (PUT Y (QUOTE PROPTYPE) (QUOTE FILEPKGCOMS))))))
+)
+)
+
+(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
+
+(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)
+
+[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
+       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
+                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]
+
+(ADDTOVAR PRETTYTYPELST )
+(DECLARE%: EVAL@COMPILE DOCOPY 
+
+(CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES PRETTYPRINTMACROS 
+                     *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS PRETTYFLG))
+
+(CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES NOTCOMPILEDFILES MAKEFILEFORMS 
+                     CLEANUPOPTIONS))
+)
+
+(RPAQ? MSDATABASELST )
+
+
+
+(* ;; "making, adding, listing, compiling files")
+
+(DEFINEQ
+
+(CLEANUP
+(NLAMBDA FILES (* lmm "14-Aug-84 19:17") (PROG (TEM1 TEM2 OPTIONS) (COND ((LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES)))) (SETQ OPTIONS (CAR FILES)) (SETQ FILES (CDR FILES))) (T (SETQ OPTIONS CLEANUPOPTIONS))) (RETURN (APPEND (MAKEFILES OPTIONS FILES) (COND ((NOT (MEMB (QUOTE LIST) OPTIONS)) NIL) ((NULL FILES) (LISTFILES)) ((SETQ TEM1 (INTERSECTION FILES NOTLISTEDFILES)) (* ; "Intersection check because LISTFILES applied to NIL means list all of NOTLISTEDFILES.") (APPLY (QUOTE LISTFILES) TEM1))) (COND ((NULL (SETQ TEM1 (MEMB (QUOTE RC) OPTIONS)))) ((NULL FILES) (COMPILEFILES0 (SETQ TEM2 NOTCOMPILEDFILES) (CDR TEM1)) TEM2) ((SETQ TEM2 (INTERSECTION FILES NOTCOMPILEDFILES)) (COMPILEFILES0 TEM2 (CDR TEM1)) TEM2))))))
+)
+
+(COMPILEFILES
+(NLAMBDA FILES (* lmm "14-Aug-84 19:17") (COND ((LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES)))) (COMPILEFILES0 (CDR FILES) (CAR FILES))) (T (COMPILEFILES0 FILES))))
+)
+
+(COMPILEFILES0
+(LAMBDA (FILES OPTIONS) (* rmk%: "19-FEB-83 21:59") (for X OPTS (RCFLG _ T) on (OR FILES NOTCOMPILEDFILES) first (SETQ OPTS (SELECTQ (CAR (LISTP OPTIONS)) (C (SETQ RCFLG NIL) (CDR OPTIONS)) (RC (CDR OPTIONS)) OPTIONS)) do (MAKEFILE1 (OR (MISSPELLED? (CAR X) 70 FILELST NIL X) (CAR X)) RCFLG OPTS X)))
+)
+
+(CONTINUEDIT
+(LAMBDA (FILE) (* bvm%: "30-Aug-86 15:09") (PROG (STREAM FL TEM FC ENV) (RESETLST (RESETSAVE NIL (LIST (QUOTE CLOSEF) (SETQ STREAM (OPENSTREAM FILE (QUOTE INPUT))))) (SETQ FILE (FULLNAME STREAM)) (SETFILEPTR STREAM 0) (CL:MULTIPLE-VALUE-SETQ (ENV FC) (\PARSE-FILE-HEADER STREAM (QUOTE RETURN)))) (COND ((NOT (fetch FILEPROP of (SETQ FL (ROOTFILENAME FILE)))) (LOADFROM FILE) (* ; "also calls addfile to notice the file."))) (/replace FILECHANGES of FL with (FILECHANGES FC)) (/replace FILEDATES of FL with (LIST (create FILEDATEPAIR FILEDATE _ (CADR FC) DATEFILENAME _ FILE) (create FILEDATEPAIR FILEDATE _ (CAR (SETQ TEM (CDR (MEMB (QUOTE date%:) FC)))) DATEFILENAME _ (CADR TEM)))) (RETURN FILE)))
+)
+
+(MAKEFILE
+  [LAMBDA (FILE OPTIONS REPRINTFNS SOURCEFILE)           (* ; "Edited 29-Aug-89 11:46 by bvm")
+
+    (* ;; "OPTIONS: FAST means dump with PRETTYFLG set to NIL;  LIST means list the FILE;  RC means RECOMPILE, C means COMPILEL;  --- for C AND RC assume ST unless next option is F.")
+
+    (PROG ((PRETTYFLG (AND [NOT (MEMB 'FAST (SETQ OPTIONS (MKLIST OPTIONS]
+                           PRETTYFLG))
+           (*PRINT-BASE* (if (EQ *PRINT-BASE* 8)
+                             then 8
+                           else                          (* ; "make sure radix is either 8 or 10, because all others don't read in like they print.  Maybe obsolete now with makefile environments")
+                                 10))
+           FILETYPE ROOTNAME FILEPROP CHANGES FILEDATES (Z (ADDFILE FILE)))
+          (DECLARE (CL:SPECIAL PRETTYFLG))
+          (SETQ FILE (CAR Z))                                (* ; 
+                                               "Necessary because FILE might have been misspelled.")
+          (SETQ ROOTNAME (CADR Z))                           (* ; "result of (ROOTFILENAME FILE), or if FILE is corrected, result of applying ROOTFILENAME to correct value.")
+          (SETQ FILEPROP (CDDR Z))
+          (UPDATEFILES)                                  (* ; "Want updating done after file is added to filelst, so any functions that are being dumped are marked as having been dumped.")
+          (SETQ CHANGES (fetch TOBEDUMPED of FILEPROP))
+          (SETQ FILEDATES (LISTP (fetch FILEDATES of ROOTNAME)))
+          (SETQ FILETYPE (GETPROP ROOTNAME 'FILETYPE))
+      LP0 (if (AND (NULL (fetch LOADTYPE of FILEPROP))
+                       (NULL FILEDATES))
+              then                                       (* ; 
+                   "File has never been loaded and never dumped i.e. user just set up COMS in core")
+            elseif [OR (EQMEMB 'NEW OPTIONS)
+                           (AND (NULL MAKEFILEREMAKEFLG)
+                                (NOT (MEMB 'REMAKE OPTIONS]
+              then (COND
+                          ((AND (fetch LOADTYPE of FILEPROP)
+                                (NEQ T (fetch LOADTYPE of FILEPROP)))
+                           (LISPXPRIN2 FILE T T)
+                           (LISPXPRIN1 (SELECTQ (fetch LOADTYPE of FILEPROP)
+                                           (LOADCOMP 
+                                                  "the file was loaded for compilation purposes only")
+                                           ((compiled Compiled COMPILED) 
+                                                " -- only the compiled file has been loaded
+")
+                                           ((loadfns LOADFNS) 
+                                                " -- only some of its symbolics have been loaded
+")
+                                           (SHOULDNT))
+                                  T)
+                           (COND
+                              ((NEQ (ASKUSER DWIMWAIT 'Y "Go ahead and MAKEFILE anyway? ")
+                                    'Y)                      (* ; 
+            "E.g. user loads a .com file and then resets the COMS or defines the functons by hand.")
+                               (GO OUT)))
+                           (/replace LOADTYPE of FILEPROP with NIL)))
+                    (SETQ SOURCEFILE NIL)
+                    (SETQ REPRINTFNS NIL)
+            elseif SOURCEFILE
+              then                                       (* ; "source file given")
+            elseif [AND FILEDATES (OR [AND (SETQ SOURCEFILE (FINDFILE ROOTNAME T))
+                                               (EQUAL (FILEDATE SOURCEFILE)
+                                                      (fetch FILEDATE of (CAR FILEDATES]
+                                          (AND [NOT (STRING-EQUAL SOURCEFILE (SETQ SOURCEFILE
+                                                                              (fetch DATEFILENAME
+                                                                                 of (CAR 
+                                                                                            FILEDATES
+                                                                                             ]
+                                               (INFILEP SOURCEFILE)
+                                               (EQUAL (FILEDATE SOURCEFILE)
+                                                      (fetch FILEDATE of (CAR FILEDATES]
+              then (/replace DATEFILENAME of (CAR FILEDATES) with SOURCEFILE)
+                    (OR REPRINTFNS (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES)))
+            elseif [AND (CDR FILEDATES)
+                            [SETQ SOURCEFILE (INFILEP (fetch DATEFILENAME of (CADR FILEDATES]
+                            (EQUAL (FILEDATE SOURCEFILE)
+                                   (fetch FILEDATE of (CADR FILEDATES]
+              then 
+
+                    (* ;; "prevous version file is gone, drop back to original daddy file and dump everything that has been changed.")
+
+                    (SETQ CHANGES (FILEPKG.MERGECHANGES (fetch TOBEDUMPED of FILEPROP)
+                                         (fetch FILECHANGES of ROOTNAME)))
+                    (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES))
+            else (LISPXPRIN1 
+                            '"can't find either the previous version or the original version of 
+" T)
+                  (LISPXPRIN2 FILE T T)
+                  (LISPXPRIN1 '", so it will have to be written anew
+" T)
+                  (SETQ SOURCEFILE NIL)
+                  (SETQ REPRINTFNS NIL)
+                  (push OPTIONS 'NEW)
+                  (SETQ CHANGES (fetch FILECHANGES of ROOTNAME))
+                  (GO LP0))
+          (COND
+             ((AND SOURCEFILE (SETQ Z (SELECTQ (fetch LOADTYPE of FILEPROP)
+                                          (LOADCOMP          (* ; 
+                                                   "only loaded via LOADCOMP.  Need to do LOADFROM")
+                                                    (LIST 'N SOURCEFILE "was loaded with LOADCOMP"
+                                                          '- "LOADFROM it to obtain VARS/COMS"))
+                                          (Compiled (AND (INFILECOMS? 'DONTCOPY 'DECLARE%:
+                                                                (fetch COMSNAME of FILEPROP))
+                                                         (LIST 'Y "only compiled version of" ROOTNAME
+                                                               
+                                        "was loaded; LOADVARS the (DECLARE .. DONTCOPY ) expressions"
+                                                               )))
+                                          ((compiled loadfns) 
+                                               (LIST 'N "Only some functions from" SOURCEFILE 
+                                             "loaded via LOADFNS. Load all other expressions from it"
+                                                     ))
+                                          NIL)))
+              (SELECTQ [ASKUSER DWIMWAIT (CAR Z)
+                              (CDR Z)
+                              '((Y "es
+")
+                                (N "o
+")
+                                (A "bort MAKEFILE
+"]
+                  (Y (SELECTQ (fetch LOADTYPE of FILEPROP)
+                         (LOADCOMP                           (* ; 
+                               "file was never actually loaded, just loadcomped.  thus no filecoms")
+                                   (LOADFROM SOURCEFILE))
+                         (Compiled 
+
+                                 (* ;; "This is going to be a remake.  If it was originally loaded as a compiled file, must first do a LOADFROM in order to get the properties set up by declare: etc.")
+
+                                   (LOADVARS 'DONTCOPY SOURCEFILE)
+                                   (/replace LOADTYPE of FILEPROP with 'COMPILED)
+                                                             (* ; "So wont have to be done again.")
+
+                                 (* ;; "These are the only DECLARE:'s that are not also on the compiled file.  Note that a DECLARE: DONTEVAL@LOAD will be found and evaluated, but the corresponding expressions won't be evaluated from within the DECLARE:  Not worthwhile to bother setting up a complicated edit pattern to screen these out, especially if you consider expressions like (DECLARE: -- DONTEVAL@LOAD -- DOEVAL@LOAD --)")
+
+                                   )
+                         ((loadfns compiled) 
+
+                                 (* ;; "This is going to be a remake, but the original call to LOADFNS didnt specify all the VARS, so some expressions may not have been loaded.")
+
+                              (LOADVARS T SOURCEFILE))
+                         NIL))
+                  (A (GO OUT))
+                  NIL)))
+          (RESETLST
+              [COND
+                 ((MEMB 'NOCLISP OPTIONS)
+                  (RESETSAVE PRETTYTRANFLG T))
+                 ((MEMB 'CLISP%  OPTIONS)
+                  (RESETSAVE PRETTYTRANFLG 'BOTH]
+              (RESETSAVE %#UNDOSAVES)
+              [COND
+                 ((OR (MEMB 'CLISPIFY OPTIONS)
+                      (MEMB 'CLISP OPTIONS))
+                  (RESETSAVE CLISPIFYPRETTYFLG T))
+                 ((OR (EQ FILETYPE 'CLISP)
+                      (MEMB 'CLISP (LISTP FILETYPE)))
+                  (RESETSAVE CLISPIFYPRETTYFLG 'CHANGES]
+              (for X in MAKEFILEFORMS do (ERSETQ (EVAL X)))
+              (SETQ FILE (PRETTYDEF NIL FILE (fetch COMSNAME of FILEPROP)
+                                REPRINTFNS SOURCEFILE CHANGES)))
+          (SETQ LASTFILE ROOTNAME)
+          (/replace TOBEDUMPED of FILEPROP with NIL)
+          (COND
+             ((NOT (EQMEMB 'DON'TLIST FILETYPE))
+              (pushnew NOTLISTEDFILES ROOTNAME)))
+          (COND
+             ((NOT (EQMEMB 'DON'TCOMPILE FILETYPE))
+              (pushnew NOTCOMPILEDFILES ROOTNAME)))
+          [for TAIL OPT on OPTIONS do (SETQ OPT (CAR TAIL))
+                                                 (SELECTQ OPT
+                                                     (RC (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
+                                                              (MAKEFILE1 FILE T (CDR TAIL))))
+                                                     (C (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
+                                                             (MAKEFILE1 FILE NIL (CDR TAIL))))
+                                                     (LIST (AND (MEMB ROOTNAME NOTLISTEDFILES)
+                                                                (APPLY 'LISTFILES (LIST FILE))))
+                                                     (COND
+                                                        ((MEMB OPT MAKEFILEOPTIONS))
+                                                        ((FIXSPELL OPT NIL MAKEFILEOPTIONS NIL 
+                                                                OPTIONS)
+                                                         (GO $$LP))
+                                                        (T (ERROR "Unrecognized MAKEFILE option" OPT]
+          (RETURN FILE)
+      OUT (RETURN (LIST FILE "-- MAKEFILE not performed."])
+
+(FILECHANGES
+(LAMBDA (FILE TYPE) (* bvm%: "30-Aug-86 15:08") (* ;; "If FILE is a list, it is assumed to be a file-created expressions;  otherwise, the filecreated expression is read from FILE.  If TYPE, returns the list of changed items of that type from the changes expression.  If TYPE=NIL, returns the whole list of typed change-lists") (PROG ((FCEXPR (OR (LISTP FILE) (AND FILE (RESETLST (LET (OLDPTR STREAM) (if (SETQ STREAM (OPENP FILE (QUOTE INPUT))) then (SETQ OLDPTR (GETFILEPTR STREAM)) (SETFILEPTR STREAM 0) else (RESETSAVE NIL (LIST (QUOTE CLOSEF) (SETQ STREAM (OPENSTREAM FILE (QUOTE INPUT)))))) (CL:MULTIPLE-VALUE-BIND (ENV FC) (\PARSE-FILE-HEADER STREAM (QUOTE RETURN)) (if OLDPTR then (SETFILEPTR STREAM OLDPTR)) FC)))))) FNS CHANGES) (SETQ CHANGES (LDIFF (SETQ CHANGES (CDR (MEMB (QUOTE to%:) FCEXPR))) (MEMB (QUOTE previous) CHANGES))) (if (AND TYPE (NEQ TYPE (QUOTE FNS))) then (RETURN (CDR (ASSOC TYPE CHANGES)))) (SETQ FNS (SUBSET CHANGES (FUNCTION LITATOM))) (* ; "Old style changes expression listed FNS by name and other things by type") (RETURN (if TYPE then (* ; "TYPE=FNS cause of test above.") (NCONC FNS (CDR (ASSOC (QUOTE FNS) CHANGES))) elseif FNS then (CONS (CONS (QUOTE FNS) FNS) (SUBSET CHANGES (FUNCTION LISTP))) else CHANGES))))
+)
+
+(FILEPKG.MERGECHANGES
+(LAMBDA (C1 C2) (* rmk%: "24-MAY-82 23:09") (* ;; "Merges 2 changes lists into a single one.  Treat LITATOM's as FNS, to accomodate old-style format on files.") (for E2 TEMP (VAL _ (for E1 in C1 when (CDR (LISTP E1)) collect (APPEND E1))) in C2 do (COND ((SETQ TEMP (ASSOC (CAR E2) VAL)) (NCONC TEMP (for X in (CDR E2) unless (MEMBER X (CDR TEMP)) collect X))) (T (SETQ VAL (NCONC1 VAL (APPEND E2))))) finally (RETURN VAL)))
+)
+
+(FILEPKG.CHANGEDFNS
+(LAMBDA (CHANGES) (* rmk%: "20-MAY-82 22:00") (* ;; "Returns list of function names from a file-changes list.  Interprets old format (functions are atoms) and new format (with explicit type headers)") (CDR (ASSOC (QUOTE FNS) CHANGES)))
+)
+
+(MAKEFILE1
+  [LAMBDA (FILE RECOMPFLG OPTIONS OTHERFILES)            (* ; "Edited 29-Aug-89 11:46 by bvm")
+    (PROG* ((ROOTNAME (ROOTFILENAME FILE))
+            (COMPILER (COMPILE-FILE? ROOTNAME))
+            GROUP)
+           (COND
+              ((AND (OR (EQ COMPILER 'BCOMPL)
+                        (EQ COMPILER 'TCOMPL))
+                    (NOT (FILEFNSLST ROOTNAME)))         (* ; 
+                 "No FNS on this file, and we're told to use Interlisp compiler, so nothing to do.")
+               (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE ROOTNAME NOTCOMPILEDFILES))
+               (RETURN NIL)))
+           (COND
+              ([find X in (SETQ GROUP (GETPROP ROOTNAME 'FILEGROUP))
+                  suchthat (AND (NEQ X ROOTNAME)
+                                    (OR (fetch TOBEDUMPED of (fetch FILEPROP of
+                                                                                         X))
+                                        (MEMB X OTHERFILES]
+
+               (* ;; "The file in question must be recompiled with other files, and one of the remaining files still needs to be dumped, or else one of the other file is further down the list of files being compiled.  Wait.")
+
+               (RETURN)))
+           (LISPXPRIN1 '"
+compiling " T)
+           (LISPXPRINT (OR GROUP FILE)
+                  T T)
+           (LISPXPRINT (LET [[REDEFINE? (OR (EQ (CAR OPTIONS)
+                                                'ST)
+                                            (EQ (CAR OPTIONS)
+                                                'STF]
+                             (FORGET-EXPRS? (EQ (CAR OPTIONS)
+                                                'STF]
+                            (SELECTQ COMPILER
+                                ((FAKE-COMPILE-FILE)         (* ; 
+                                               "The old CommonLispy interface to the ByteCompiler.")
+                                     (FAKE-COMPILE-FILE FILE :REDEFINE REDEFINE? :SAVE-EXPRS
+                                            (AND REDEFINE? (NOT FORGET-EXPRS?))))
+                                ((CL:COMPILE-FILE)           (* ; "The new, improved (?) compiler")
+                                     (CL:COMPILE-FILE FILE :LOAD (COND
+                                                                    ((AND REDEFINE? (NOT 
+                                                                                        FORGET-EXPRS?
+                                                                                         ))
+                                                                     :SAVE)
+                                                                    (REDEFINE? T)
+                                                                    (T NIL))))
+                                ((TCOMPL BCOMPL)             (* ; "The old ByteCompiler")
+                                     [IF (MEMB (CAR OPTIONS)
+                                                   '(ST F S STF))
+                                         THEN (LISPXUNREAD (LIST (CAR OPTIONS]
+                                     [IF GROUP
+                                         THEN 
+
+                                               (* ;; 
+                                   "File contained in FILEGROUP.  Therefore must be blockcompiled.")
+
+                                               (IF RECOMPFLG
+                                                   THEN (BRECOMPILE GROUP)
+                                                 ELSE (BCOMPL GROUP))
+                                       ELSEIF (EQ COMPILER 'TCOMPL)
+                                         THEN (IF RECOMPFLG
+                                                      THEN (RECOMPILE FILE)
+                                                    ELSE (TCOMPL (LIST FILE)))
+                                       ELSE (IF RECOMPFLG
+                                                    THEN (BRECOMPILE FILE)
+                                                  ELSE (BCOMPL (LIST FILE])
+                                (SHOULDNT "Non-existent compiler returned from COMPILE-FILE?...")))
+                  T T])
+
+(COMPILE-FILE?
+(LAMBDA (ROOTNAME) (* ; "Edited 19-Jan-87 21:12 by Pavel") (* ;;; "Which compiler should CLEANUP use?") (LET ((TYPE (GET ROOTNAME (QUOTE FILETYPE))) (UNKNOWN NIL)) (FOR X INSIDE TYPE DO (SELECTQ X ((TCOMPL :TCOMPL) (RETURN (QUOTE TCOMPL))) ((BCOMPL :BCOMPL) (RETURN (QUOTE BCOMPL))) ((:FAKE-COMPILE-FILE CL:COMPILE-FILE COMPILE-FILE) (RETURN (QUOTE FAKE-COMPILE-FILE))) ((:COMPILE-FILE :XCL-COMPILE-FILE) (RETURN (QUOTE CL:COMPILE-FILE))) ((CLISP) NIL) (SETQ UNKNOWN T)) FINALLY (IF UNKNOWN THEN (CL:FORMAT T "~2%%**Warning: unknown FILETYPE value ~S~2%%" TYPE)) (RETURN *DEFAULT-CLEANUP-COMPILER*))))
+)
+
+(MAKEFILES
+(LAMBDA (OPTIONS FILES) (* rmk%: "23-FEB-83 21:20") (RESETVARS (%#UNDOSAVES) (* ; "Willing to save arbitrary amounts of undo info") (UPDATEFILES) (COND ((NULL FILES) (for TYPE FLG in FILEPKGTYPES when (FILES?1 TYPE (COND ((NULL FLG) (* ; "Gets printed the first time") (QUOTE "****NOTE: the following are not contained on any file:
+    ")) (T (QUOTE "    ")))) do (SETQ FLG T) finally (AND FLG (ADDTOFILES?))))) (SETQ OPTIONS (MKLIST OPTIONS)) (RETURN (for FILE inside (OR FILES FILELST) when (fetch TOBEDUMPED of (LISTP (fetch FILEPROP of (ROOTFILENAME FILE)))) collect (LISPXPRIN2 FILE T T) (LISPXPRIN1 (QUOTE |...|) T) (PROG1 (MAKEFILE FILE OPTIONS) (LISPXTERPRI T))))))
+)
+
+(ADDFILE
+(LAMBDA (FILE LOADTYPE PRLST FCLST) (* bvm%: "29-Aug-86 12:22") (* ;; "PRLST is the FILEPKGCHANGES prior to this file operation, FCLST is a list of file-created arguments, a singleton for a symbolic file, and a list whose car represents the compiled file and whose cdr represent symbolic files compiled into it, for compiled files.") (PROG ((ROOTNAME (ROOTFILENAME FILE)) FLST VAL) (COND ((NOT FCLST) (SETQ VAL (ADDFILE0 ROOTNAME LOADTYPE FILE))) ((NULL (CDR FCLST)) (* ; "A simple symbolic file") (SETQ FCLST (CAR FCLST)) (SETQ VAL (ADDFILE0 (COND ((LITATOM (CADR FCLST)) (ROOTFILENAME (CADR FCLST))) (T ROOTNAME)) LOADTYPE FILE (CAR FCLST)))) (T (* ;; "A compiled file, skip the first expression representing the compiled file itself, look at the cdr representing the symbolic files.") (SELECTQ LOADTYPE ((T LOADFNS) (SETQ LOADTYPE (QUOTE Compiled))) (loadfns (SETQ LOADTYPE (QUOTE compiled))) (LOADCOMP (* ; "loadcomp on compiled file.  Don't notice since we don't know what its state is") NIL) (SHOULDNT)) (for X in (CDR FCLST) when (LITATOM (CADR X)) do (push FLST (CADR X)) (OR (EQ LOADTYPE (QUOTE LOADCOMP)) (ADDFILE0 (ROOTFILENAME (CADR X)) LOADTYPE (CADR X) (CAR X)))))) (UPDATEFILES PRLST (OR FLST (LIST FILE))) (AND LOADTYPE (for TYPE CHANGED in FILEPKGTYPES when (AND (LITATOM TYPE) (SETQ CHANGED (fetch CHANGED of TYPE))) do (/replace CHANGED of TYPE with (INTERSECTION (CDR (ASSOC TYPE PRLST)) CHANGED)))) (AND ADDSPELLFLG (ADDSPELL ROOTNAME USERWORDS)) (RETURN VAL)))
+)
+
+(ADDFILE0
+(LAMBDA (ROOTNAME LOADTYPE FULLNAME DAT) (* lmm "28-Nov-84 16:47") (PROG (COMS X FILEPROP FLG TEM) TOP (SETQ COMS (FILECOMS ROOTNAME)) (COND ((SETQ FILEPROP (fetch FILEPROP of ROOTNAME)) (COND ((AND LOADTYPE (FMEMB LOADTYPE (CDR (FMEMB (fetch LOADTYPE of FILEPROP) (QUOTE (LOADCOMP loadfns compiled Compiled LOADFNS COMPILED NIL T)))))) (/replace LOADTYPE of FILEPROP with LOADTYPE) (* ;; "This call to ADDFILE reflects a 'higher' degree of loading, so upgrade property.  'loadfns' means just some information from file, if go to do makefile, must do loadfrom, 'compiled' is like 'loadfns' but for compiled files e.g. user does LOADFNS on compiled file.  'Compiled' means all but DECLARE: expressions are in.  e.g. user does LOAD of a compiled file.  COMPILED means everything is in, e.g. user does LOADDFROM a compiled file.  LOADFNS means everything in, e.g. user des LOADFROM symbolic file.  COMPILED and LOADFNS are equivalent in that means dont have to do any more loading when go to do a makefile but makefile NEW isnt permitted.  NIL is a makefile when coms were set up in core.  T is full load of symbolic file.  The check on TYPE=NIL is bcause dont want to upgrade as result of call from makefile, i.e. no new information there.") (* ;; "LOADCOMP means file was loadcomp'ed.  note that the actual structure is a tree, not a list, and the above is only an approximation.  if you do a loadcomp, and then load the compiled file, the state will be left with latter, but then loadcomp? will loadcomp again because compiled files might not contain all the declare: EVAL@COMPILE expressions, e.g. macros, records etc.  however, in most cases, loadcomp is used independently of other loading, e.g. for compilation purposes only, so this will at least permit loadcomp? to work.") (GO OUT)) (T (GO OUT1))))) (COND ((OR LOADTYPE (LISTP (GETTOPVAL COMS))) (SETQ FILEPROP (/replace FILEPROP of ROOTNAME with (create FILEPROP COMSNAME _ COMS LOADTYPE _ LOADTYPE)))) (FLG (GO ERROR)) ((AND DWIMFLG (EQ ROOTNAME FULLNAME) (SETQ ROOTNAME (MISSPELLED? ROOTNAME 70 FILELST T))) (* ;; "The EQ check is so as not to try correcting if the user has specified a version number or directory, as it is too messy trying to take them out, and then put them back in on the corrected root name.") (SETQ FULLNAME ROOTNAME) (SETQ FLG T) (* ; "so wont try to spelling correct again if file isnt there") (GO TOP)) (T (GO ERROR))) OUT (AND LOADTYPE DAT (/replace FILEDATES of ROOTNAME with (LIST (create FILEDATEPAIR FILEDATE _ DAT DATEFILENAME _ FULLNAME)))) (AND (EQ LOADTYPE T) (/replace TOBEDUMPED of FILEPROP with NIL)) OUT1 (COND ((AND (LISTP (GETTOPVAL COMS)) (NOT (FMEMB ROOTNAME (GETTOPVAL (QUOTE FILELST))))) (* ; "coms wuld not be set up on a loadccomp.") (/SETTOPVAL (QUOTE FILELST) (CONS ROOTNAME (GETTOPVAL (QUOTE FILELST)))))) (RETURN (COND ((NULL LOADTYPE) (* ; "call from makefile.") (CONS FULLNAME (CONS ROOTNAME FILEPROP))) (T FILEPROP))) ERROR (ERROR FULLNAME "not file name." T)))
+)
+
+(LISTFILES
+(NLAMBDA FILES (* rmk%: " 3-Dec-84 08:58") (DECLARE (GLOBALVARS NOTLISTEDFILES)) (* ; "LISTFILES1 is machinedependent") (for FILE FULLNAME OPTIONS in (COND (FILES (SETQ FILES (NLAMBDA.ARGS FILES))) (T NOTLISTEDFILES)) when (COND ((LISTP FILE) (SETQ OPTIONS (APPEND FILE OPTIONS)) NIL) ((SETQ FULLNAME (FINDFILE FILE)) FULLNAME) (T (printout T FILE " not found." T) NIL)) collect (COND ((LISTFILES1 FULLNAME OPTIONS) (SETQ NOTLISTEDFILES (REMOVE (NAMEFIELD FULLNAME T) NOTLISTEDFILES)))) FULLNAME))
+)
+)
+
+(RPAQ? *DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)
+
+(RPAQ? FILELST )
+
+(RPAQ? LOADEDFILELST )
+
+(RPAQ? NOTLISTEDFILES )
+
+(RPAQ? NOTCOMPILEDFILES )
+
+(RPAQ? MAKEFILEFORMS )
+
+(RPAQ? NILCOMS )
+
+(ADDTOVAR MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP%  F ST STF
+                                 (REC . RC)
+                                 (BREC . RC)
+                                 (TC . C)
+                                 (BC . C)
+                                 (TCOMPL . C)
+                                 (BCOMPL . C))
+
+(RPAQ? MAKEFILEREMAKEFLG T)
+
+(RPAQ? CLEANUPOPTIONS '(RC))
+
+
+
+(* ;; "scanning file coms")
+
+(DEFINEQ
+
+(FILEPKGCHANGES
+(LAMBDA N (* Pavel " 7-Oct-86 19:22") (COND ((EQ N 0) (PROG (TEM) (RETURN (for X in FILEPKGTYPES when (AND (LITATOM X) (SETQ TEM (FILEPKGCHANGES X))) collect (CONS X TEM))))) ((EQ (ARG N 1) T) (for X in FILEPKGTYPES when (LITATOM X) collect (CONS X (FILEPKGCHANGES X)))) ((EQ N 1) (COND ((LISTP (ARG N 1)) (for X in (ARG N 1) when (FMEMB (CAR X) FILEPKGTYPES) do (/replace CHANGED of (CAR X) with (CDR X)))) (T (for Y on (fetch CHANGED of (ARG N 1)) when (AND (CAR Y) (NOT (for Z in (CDR Y) thereis (CL:EQUAL (CAR Y) Z)))) collect (CAR Y))))) (T (/replace CHANGED of (ARG N 1) with (ARG N 2)))))
+)
+
+(GETFILEPKGTYPE
+(LAMBDA (TYPE ONLY NOERROR NAME) (* lmm "20-Nov-86 23:10") (* ;; "Coerce TYPE to a well defined definition type (FILEPKG type) or a command. ONLY is an indicator of which is acceptable; if NIL, either one is acceptable, if COMS, only commands are acceptable, and if TYPES, only types should be returned. If none is found, will signal an error if NOERROR is NIL, otherwise return NIL. ") (COND ((LISTP TYPE) (* ;; " given a list of types, coerce them all or return NIL") (for X in TYPE collect (OR (GETFILEPKGTYPE X ONLY NOERROR NAME) (RETURN)))) ((EQ TYPE (QUOTE ?)) (* ;; "odd case, may be obsolete: if given IL:?, return all known types of NAME. Maybe used by EDITDEF(NAME ?)?? ") (AND NAME (TYPESOF NAME))) ((AND (NEQ ONLY (QUOTE COMS)) (OR (SELECTQ TYPE (NIL (QUOTE FNS)) (T (QUOTE VARS)) NIL) (for X in FILEPKGTYPES do (if (EQ TYPE X) then (* ;; "type matched exactly") (RETURN TYPE) elseif (AND (LISTP X) (EQ TYPE (CAR X))) then (RETURN (CDR X))))))) ((AND (NEQ ONLY (QUOTE TYPE)) (LITATOM TYPE) (PROG1 (CAR (FMEMB TYPE FILEPKGCOMSPLST)) (* ; "Prefer an exact match quickly")))) ((AND (NEQ ONLY (QUOTE COMS)) (LITATOM TYPE) (for X in FILEPKGTYPES bind NAME do (SETQ NAME (if (NLISTP X) then X else (CAR X))) (* ;; "see if spelled the same or 1 char shorter; assume all FILEPKGTYPE names end with S. This handles package conversions and also pluralization") (AND (<= 0 (- (NCHARS NAME) (NCHARS TYPE)) 1) (STRPOS TYPE NAME) (RETURN (if (EQ X NAME) then X else (CDR X))))))) ((FIXSPELL TYPE NIL (SELECTQ ONLY (TYPE FILEPKGTYPES) (COMS FILEPKGCOMSPLST) (UNION FILEPKGTYPES FILEPKGCOMSPLST)))) ((NOT NOERROR) (ERROR (SELECTQ ONLY (TYPE "unrecognized manager definition type") (COMS "unrecognized manager command") "unrecognized manager definition-type/command") TYPE))))
+)
+
+(MARKASCHANGED
+(LAMBDA (NAME TYPE REASON) (* ; "Edited 25-May-88 15:37 by drc:") (COND (FILEPKGFLG (SETQ REASON (SELECTQ REASON ((CLISP LOAD CHANGED DEFINED DELETED) REASON) (NIL (QUOTE CHANGED)) (T (QUOTE DEFINED)) (ERROR "bad REASON in MARKASCHANGED" REASON))) (SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE))) (for FN inside (fetch WHENCHANGED of TYPE) do (APPLY* FN NAME TYPE REASON)) (for FN in MARKASCHANGEDFNS do (APPLY* FN NAME TYPE REASON)) (COND ((EQ REASON (QUOTE DELETED)) (for L on (fetch CHANGED of TYPE) when (EQUAL (CAR L) NAME) do (/RPLACA L NIL)) (* ; "unmark as changed and remove from files") (DELFROMFILES NAME TYPE)) (T (LET ((LST (push (fetch CHANGED of TYPE) NAME))) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /RPLACA) LST) LISPXHIST)) (* ; "UNDO by smashing with NIL;  makes calls to MARKASCHANGED independent")))) NAME)))
+)
+
+(FILECOMS
+(LAMBDA (FILE X) (* rmk%: "19-FEB-83 13:55") (COND ((AND (NULL FILE) (NULL X)) (QUOTE NILCOMS)) ((AND (OR (NULL X) (EQ X (QUOTE COMS))) (fetch COMSNAME of (LISTP (fetch FILEPROP of FILE))))) (T (PACK* (COMSNAME FILE) (OR X (QUOTE COMS))))))
+)
+
+(WHEREIS
+  [LAMBDA (NAME TYPE FILES FN)                        (* ; "Edited 12-Jul-88 17:14 by MASINTER")
+
+    (* ;; "T as a NAME has a special meaning to INFILECOMS?  so don't pass through.")
+
+    (CL:UNLESS (EQ NAME T)
+        (LET [(IN-FILES (UNION [SUBSET (OR (LISTP FILES)
+                                           FILELST)
+                                      (FUNCTION (LAMBDA (FILE)
+                                                  (INFILECOMS? NAME TYPE (FILECOMS FILE]
+                               (AND (EQ FILES T)
+                                    (CL:FBOUNDP 'XCL::HASH-FILE-WHERE-IS)
+                                    (LET ((FILES NIL))
+                                         (for TY inside TYPE
+                                            do (for FILE-NAME
+                                                      in (XCL::HASH-FILE-WHERE-IS NAME
+                                                                    (GETFILEPKGTYPE TYPE))
+                                                      do (CL:PUSHNEW (MKATOM (U-CASE FILE-NAME))
+                                                                    FILES)))
+                                         (REVERSE FILES]
+             (CL:IF FN
+                 [MAPC IN-FILES (FUNCTION (LAMBDA (FILE)
+                                            (APPLY* FN NAME FILE]
+                 IN-FILES)))])
+
+(SMASHFILECOMS
+(LAMBDA (FILE) (* rmk%: "19-FEB-83 22:15") (for X in (FILECOMSLST FILE (QUOTE FILEVARS)) when (LITATOM X) do (SETTOPVAL X (QUOTE NOBIND))) FILE)
+)
+
+(FILEFNSLST
+  [LAMBDA (FILE)                                         (* ; "Edited 14-Jun-90 19:30 by jds")
+    (FILECOMSLST FILE '(FUNCTIONS FNS])
+
+(FILECOMSLST
+(LAMBDA (FILE TYPE FLG) (* JonL "24-Jul-84 19:48") (* ; "TYPE is coerced in the innards of INFILECOMS?") (COND ((EQ FLG (QUOTE UPDATE)) (CDR (INFILECOMS? NIL TYPE (FILECOMS FILE) FLG))) (T (INFILECOMS? NIL TYPE (FILECOMS FILE) FLG))))
+)
+
+(UPDATEFILES
+(LAMBDA (PRLST FLST) (* rmk%: "19-FEB-83 14:27") (* ;; "PRLST may be the value of FILEPKGCHANGES before some operation (e.g.  LOAD, LOADFNS) involving the files in FLST began.") (for TYPE CHANGED in FILEPKGTYPES when (SETQ CHANGED (fetch CHANGED of TYPE)) do (COND ((NULL (SETQ CHANGED (FILEPKGCHANGES TYPE))) (* ; "FILEPKGCHANGES eliminates duplicates") (/replace CHANGED of TYPE with NIL)) (T (for FILE FOUND FILEPROP COMS LST TYPEDPROP PCHANGES (PREVITEMS _ (CDR (ASSOC TYPE PRLST))) in FILELST first (SETQ LST (INFILECOMS? CHANGED TYPE (QUOTE NILCOMS) (QUOTE UPDATE))) (* ;; "First check NIL=Nowhere.  LST:1 contains variables whose values are on the file literally.  These are `found' but not marked.  LST::1 contains all other items.") (SETQ FOUND (NCONC (CAR LST) (CDR LST) FOUND)) do (SETQ PCHANGES (COND ((FMEMB (fetch DATEFILENAME of (CAR (fetch FILEDATES of FILE))) FLST) (* ;; "PREVITEMS are changed items that were previously on the changed list, before PRLST was computed as this LOAD/LOADFNS began.  Thus, by this intersection we only worry about items that were previously changed;  any items that were only changed during this operation are ignored.") (INTERSECTION CHANGED PREVITEMS)) (T CHANGED))) (COND ((AND PCHANGES (SETQ COMS (fetch COMSNAME of (SETQ FILEPROP (LISTP (fetch FILEPROP of FILE))))) (SETQ LST (INFILECOMS? PCHANGES TYPE COMS (QUOTE UPDATE)))) (* ;; "LST:1 is a list of the times that literally appear on this file, LST::1 is a list of those whose literal values are not in the coms") (COND ((CDR LST) (* ; "CDR items must be distributed") (COND ((NULL (fetch TOBEDUMPED of FILEPROP)) (* ;; "Only finagle global lists the first time an item is added to PROP, when PROP::1 goes from NIL to non-NIL") (/SETTOPVAL (QUOTE NOTLISTEDFILES) (REMOVE FILE (GETTOPVAL (QUOTE NOTLISTEDFILES)))) (/SETTOPVAL (QUOTE NOTCOMPILEDFILES) (REMOVE FILE (GETTOPVAL (QUOTE NOTCOMPILEDFILES)))))) (* ; "Get the (possibly new) TYPE item list to smash") (COND ((SETQ TYPEDPROP (ASSOC TYPE (fetch TOBEDUMPED of FILEPROP)))) (T (/NCONC1 FILEPROP (SETQ TYPEDPROP (CONS TYPE))))) (* ; "Now distribute items to the file property") (for Y in (CDR LST) unless (MEMBER Y (CDR TYPEDPROP)) do (/NCONC1 TYPEDPROP Y)))) (SETQ FOUND (NCONC (CAR LST) (CDR LST) FOUND)))) finally (/replace CHANGED of TYPE with (LDIFFERENCE CHANGED FOUND)))))))
+)
+
+(INFILECOMS?
+  [LAMBDA (NAME TYPE COMS ONFILETYPE)                 (* ; "Edited 12-Jul-88 17:42 by MASINTER")
+
+    (* ;; "Returns T if NAME is 'CONTAINED' in COMS.  If NAME is NIL, then value is a list of all of the functions contained in COMS.  If NAME=T, value is T if there are any elements of type TYPE, otherwise NIL (this feature is used for deciding whether or not (and how) to compile files.)  Called by FILEFNSLST (which is used by BRECOMPILE) and by NEWFILE1.  while elements are the subset of NAME which are on the file in other case")
+
+    (* ;; "if ONFILETYPE is UPDATE, then NAME is a list of elements, and INFILECOMS?  returns the dotted pair of (literals  . elements) where literals are those which are `literally' on the file (e.g.  (VARS (X 3))) --- if ONEFILETYPE is EDIT, then NAME is interpreted as for ONFILETYPE=NIL, but only those elements which are not on the file literally and which are not subparts of other types are returned")
+
+    (* ;; "if ONFILETYPE is TYPESOF, type can be a list of types, and returns a list of types suitable for EDITDEF ")
+
+    (PROG (VAL LITERALS ORIGFLG)
+          (SETQ TYPE (GETFILEPKGTYPE TYPE))
+          (SELECTQ ONFILETYPE
+              (EDIT (SELECTQ TYPE
+                        (FILEVARS (RETURN))
+                        NIL))
+              NIL)
+          [COND
+             ((LITATOM COMS)
+              (SELECTQ TYPE
+                  ((VARS FILEVARS)                           (* ; 
+                                                           "the COMS of a file are also on it")
+                       (INFILECOMSVAL COMS))
+                  NIL)
+              (SETQ COMS (EVALV COMS]
+          (INFILECOMS COMS)
+          (SETQ VAL (DREVERSE VAL))
+          (RETURN (COND
+                     ((EQ ONFILETYPE 'UPDATE)
+                      (CONS LITERALS VAL))
+                     (T VAL])
+
+(INFILECOMTAIL
+  [LAMBDA (COM FLG)                                   (* ; "Edited  2-Aug-88 02:15 by masinter")
+    [SETQ COM (COND
+                 ((EQ (CADR COM)
+                      '*)
+                  (COND
+                     [(LITATOM (CADDR COM))
+                      (LISTP (EVALV (CADDR COM]
+                     (T [RESETVARS (DWIMLOADFNSFLG)
+                                   (NLSETQ (SETQ COM (EVAL (CADDR COM]
+                        COM)))
+                 (T (CDR COM]
+    (if (NOT FLG)
+        then (for X in COM
+                    do [if (AND (LISTP X)
+                                        (EQ (CAR X)
+                                            COMMENTFLG))
+                               then (RETURN (SUBSET COM (FUNCTION (LAMBDA (X)
+                                                                        (OR (NLISTP X)
+                                                                            (NEQ (CAR X)
+                                                                                 COMMENTFLG]
+                    finally (RETURN COM))
+      else COM])
+
+(INFILECOMS
+(LAMBDA (COMS) (* rmk%: "19-FEB-83 22:17") (for X in COMS do (INFILECOM X))))
+
+(INFILECOM
+  [LAMBDA (COM)                                       (* ; "Edited  2-Aug-88 02:27 by masinter")
+    (COND
+       [(NLISTP COM)
+        (COND
+           ((EQ TYPE 'VARS)
+            (INFILECOMSVAL COM]
+       ((EQ (CAR COM)
+            COMMENTFLG)
+
+        (* ;; 
+"must be special case'd first so that (* * values) doesn't make it look like `values' is a variable")
+                                                             (* ; 
+  "don't know why I should bother, but someone might want to know all of the comments on a file???")
+        (COND
+           ((EQ TYPE COMMENTFLG)
+            (INFILECOMSVAL COM T)))
+        NIL)
+       (T
+        (PROG ((COMNAME (CAR COM))
+               (TAIL (CDR COM))
+               CFN TEM)
+              (COND
+                 [[COND
+                     ((SETQ CFN (fetch (FILEPKGCOM CONTENTS) of COMNAME))
+                      (SETQ TEM (APPLY* CFN COM (COND
+                                                   ((AND (NULL ONFILETYPE)
+                                                         (NOT (CL:SYMBOLP NAME)))
+                                                             (* ; 
+                                                "call from WHEREIS of a name which is not a symbol")
+                                                    (LIST NAME))
+                                                   (T NAME))
+                                       TYPE ONFILETYPE)))
+                     ((SETQ CFN (fetch (FILEPKGCOM PRETTYTYPE) of COMNAME))
+                                                             (* ; "for compatability")
+                      (SETQ TEM (APPLY* CFN COM TYPE NAME]
+                  (COND
+                     [(NLISTP TEM)
+                      (COND
+                         ((EQ TEM T)
+                          (COND
+                             ((OR (EQ NAME T)
+                                  (NULL ONFILETYPE))
+                              (RETFROM 'INFILECOMS? T]
+                     (T (INFILECOMSVALS TEM]
+                 ((LISTP TAIL)
+
+                  (* ;; "this SELECTQ handles the `exceptional cases' for the built in types.  There is an explicit RETURN in the SELECTQ clause if the default is handled")
+
+                  (SELECTQ COMNAME
+                      ((PROP IFPROP) 
+                           (SETQ TAIL (CDR TAIL)))
+                      NIL)
+                  [COND
+                     ((EQ (CAR TAIL)
+                          '*)
+                      (COND
+                         ((LITATOM (CADR TAIL))
+                          (SELECTQ TYPE
+                              ((VARS FILEVARS) 
+                                   (INFILECOMSVAL (CADR TAIL)))
+                              NIL))
+                         ((AND (LISTP (CADR TAIL))
+                               (EQ ONFILETYPE 'UPDATE)
+                               (EQ TYPE 'VARS)
+                               (EQ (CAADR TAIL)
+                                   'PROGN)
+                               (FMEMB (CAR (LAST (CADR TAIL)))
+                                      NAME))
+                          (SETQ VAL (CONS (CADR TAIL)
+                                          VAL]
+                  (SELECTQ COMNAME
+                      ((COMS EXPORT) 
+                           (INFILECOMS (INFILECOMTAIL COM T)))
+                      (CL:EVAL-WHEN (INFILECOMS (INFILECOMTAIL (CDR COM)
+                                                           T)))
+                      (DECLARE%:                             (* ; "skip over DECLARE: tags")
+                                 [RETURN (AND (NOT (FMEMB 'COMPILERVARS COM))
+                                              (IFCDECLARE (INFILECOMTAIL COM)
+                                                     (EQ TYPE 'DECLARE%:])
+                      (ORIGINAL                              (* ; "dont expand macros")
+                                (PROG ((ORIGFLG T))
+                                      (INFILECOMS (INFILECOMTAIL COM T))))
+                      ((PROP IFPROP)                         (* ; 
+                                       "this currently does not handle `pseudo-types' of PROPNAMES")
+                           (SELECTQ TYPE
+                               (PROPS (IFCPROPSCAN (INFILECOMTAIL (CDR COM)
+                                                              T)
+                                             (CADR COM)))
+                               (MACROS (INFILECOMSMACRO (INFILECOMTAIL (CDR COM))
+                                              (CADR COM)))
+                               NIL))
+                      (PROPS (RETURN (IFCPROPS COM)))
+                      (MACROS (RETURN (SELECTQ TYPE
+                                          (PROPS (IFCPROPSCAN (INFILECOMTAIL COM T)
+                                                        MACROPROPS))
+                                          (MACROS (INFILECOMSVALS (INFILECOMTAIL COM T)))
+                                          NIL)))
+                      (ALISTS                                (* ; 
+                      "sigh.  This should probably also `coerce' when asking for LISPXMACROS, etc.")
+                              (RETURN (SELECTQ TYPE
+                                          (ALISTS (INFILEPAIRS (INFILECOMTAIL COM)))
+                                          NIL)))
+                      (P [RETURN (SELECTQ TYPE
+                                     ((EXPRESSIONS P) 
+                                          (INFILECOMSVALS (INFILECOMTAIL COM T)
+                                                 T))
+                                     (COND
+                                        ((NULL ONFILETYPE)   (* ; "for WHEREIS and FILECOMSLST")
+                                         (SELECTQ TYPE
+                                             (I.S.OPRS (IFCEXPRTYPE COM 'I.S.OPR))
+                                             (TEMPLATES (IFCEXPRTYPE COM 'SETTEMPLATE))
+                                             NIL])
+                      ((ADDVARS APPENDVARS) 
+                           (SELECTQ TYPE
+                               (VARS [RETURN (AND (NULL ONFILETYPE)
+                                                  (for X in (INFILECOMTAIL COM T)
+                                                     do (INFILECOMSVAL (CAR X)
+                                                                   T])
+                               (ALISTS [RETURN (for X in (INFILECOMTAIL COM T)
+                                                  when (EQMEMB 'ALIST (GETPROP (CAR X)
+                                                                                 'VARTYPE))
+                                                  do (for Z in (CDR X)
+                                                            do (INFILECOMSVAL
+                                                                    (LIST (CAR X)
+                                                                          (CAR Z))
+                                                                    T])
+                               (OR (EQ TYPE COMNAME)
+                                   (RETURN))))
+                      ((VARS INITVARS FILEVARS UGLYVARS HORRIBLEVARS CONSTANTS ARRAY) 
+                           [RETURN (COND
+                                      ((EQ TYPE 'EXPRESSIONS)
+                                       (for X in (INFILECOMTAIL COM T)
+                                          when (AND (LISTP X)
+                                                        (NEQ (CAR X)
+                                                             COMMENTFLG))
+                                          do (INFILECOMSVAL (CONS 'SETQ X)
+                                                        T)))
+                                      ((OR (EQ TYPE 'VARS)
+                                           (EQ TYPE COMNAME))(* ; 
+                   "either want all VARS, or else want all FILEVARS and this is a FILEVARS command")
+                                       (for X in (INFILECOMTAIL COM T)
+                                          do (COND
+                                                    ((LISTP X)
+                                                     (AND (CAR X)
+                                                          (NEQ (CAR X)
+                                                               COMMENTFLG)
+                                                          (INFILECOMSVAL (CAR X)
+                                                                 T)))
+                                                    (X (INFILECOMSVAL X (EQ COMNAME 'INITVARS])
+                      (DEFS [RETURN (for X in (INFILECOMTAIL COM T)
+                                       when (EQ TYPE (CAR X)) do (INFILECOMSVALS
+                                                                          (CDR X])
+                      (FILES (RETURN))
+                      NIL)
+
+                  (* ;; "Exceptional cases now handled.  If TYPE matches (CAR COM) then scan the tail as usual.  Else expand the com's MACRO, if it has one, unless there was a CONTENTS function")
+
+                  (COND
+                     ((EQ COMNAME TYPE)
+                      (INFILECOMSVALS (INFILECOMTAIL COM T)))
+                     [(AND (LISTP TYPE)
+                           (FMEMB COMNAME TYPE))
+                      (LET ((TYPE COMNAME))
+                           (INFILECOMSVALS (INFILECOMTAIL COM T]
+                     ((AND (OR (NULL CFN)
+                               (AND (EQ CFN T)
+                                    (NULL ONFILETYPE)))
+                           (NULL ORIGFLG)
+                           (SETQ TEM (fetch (FILEPKGCOM MACRO) of COMNAME)))
+                      (INFILECOMS (SUBPAIR (CAR TEM)
+                                             (INFILECOMTAIL COM T)
+                                             (CDR TEM])
+
+(INFILECOMSVALS
+  [LAMBDA (X FLG)                                     (* ; "Edited  2-Aug-88 02:21 by masinter")
+    (for Y in X when (NOT (AND (LISTP Y)
+                                           (EQ (CAR Y)
+                                               COMMENTFLG))) do (INFILECOMSVAL Y FLG])
+
+(INFILECOMSVAL
+  [LAMBDA (X FLG)                                     (* ; "Edited 12-Jul-88 17:56 by MASINTER")
+    (COND
+       [(EQ ONFILETYPE 'UPDATE)
+        (AND (OR (NULL NAME)
+                 (MEMBER X NAME))
+             (COND
+                (FLG (SETQ LITERALS (CONS X LITERALS)))
+                (T (SETQ VAL (CONS X VAL]
+       ((AND (EQ ONFILETYPE 'EDIT)
+             FLG)                                            (* ; 
+                                        "literals should not be edited as they are on the fileCOMS")
+        NIL)
+       ((EQ ONFILETYPE 'TYPESOF)
+        (AND (COND
+                ((LITATOM NAME)
+                 (EQ NAME X))
+                (T (EQUAL NAME X)))
+             (CL:PUSHNEW TYPE VAL)))
+       ([OR (EQ NAME T)
+            (COND
+               ((LITATOM NAME)
+                (EQ NAME X))
+               (T (EQUAL NAME X]
+        (RETFROM (FUNCTION INFILECOMS?)
+               T))
+       ((NULL NAME)
+        (SETQ VAL (CONS X VAL])
+
+(INFILECOMSPROP
+(LAMBDA (AT PROP) (* lmm "25-SEP-81 17:15") (COND ((EQ ONFILETYPE (QUOTE UPDATE)) (AND (OR (NULL NAME) (find X in NAME suchthat (AND (EQ (CAR X) AT) (EQ (CADR X) PROP)))) (SETQ VAL (CONS (LIST AT PROP) VAL)))) ((OR (EQ NAME T) (AND (EQ (CAR NAME) AT) (EQ (CADR NAME) PROP))) (RETFROM (FUNCTION INFILECOMS?) T)) ((NULL NAME) (SETQ VAL (CONS (LIST AT PROP) VAL)))))
+)
+
+(IFCPROPS
+(LAMBDA (COM) (* bvm%: " 2-Dec-83 14:24") (* ;;; "Examine a PROPS com for objects of specified TYPE") (SELECTQ TYPE (PROPS (* ; "the PROPS command can actually take (PROPNAME at1 at2 ...)") (INFILEPAIRS (INFILECOMTAIL COM))) (PROP (* ; "return the atoms which have any properties at all") (for PAIR in (INFILECOMTAIL COM) do (for ATNAME inside (CAR PAIR) do (INFILECOMSVAL ATNAME)))) (MACROS (* ; "only MACRO properties") (for PAIR in (INFILECOMTAIL COM) do (INFILECOMSMACRO (CAR PAIR) (CDR PAIR)))) NIL))
+)
+
+(IFCEXPRTYPE
+(LAMBDA (COM FN) (* ; "Edited  6-Apr-87 20:20 by Pavel") (* ;;; "Recognizes expressions in COM (a P com) that are calls to function FN") (for SUBCOM in (INFILECOMTAIL COM) when (AND (EQ (CAR SUBCOM) FN) (EQ (CAR (LISTP (CADR SUBCOM))) (QUOTE QUOTE))) do (INFILECOMSVAL (CADR (CADR SUBCOM)) T)))
+)
+
+(IFCPROPSCAN
+  [LAMBDA (ATOMS PROPNAMES)                           (* ; "Edited  2-Aug-88 02:20 by masinter")
+
+(* ;;; 
+"Recognizes members of ATOMS as being names (atom prop) of type PROPS for any prop in PROPNAMES")
+
+    (for AT in ATOMS WHEN (LITATOM AT) unless [COND
+                                                                 [(EQ ONFILETYPE 'UPDATE)
+                                                                  (COND
+                                                                     (NAME (NOT (ASSOC AT NAME]
+                                                                 ((LISTP NAME)
+                                                                  (NEQ AT (CAR NAME]
+       do (COND
+                 ((EQ PROPNAMES 'ALL)
+                  (for PROP in (GETPROPLIST AT) by (CDDR PROP)
+                     when (NOT (FMEMB PROP SYSPROPS)) collect (INFILECOMSPROP AT PROP)))
+                 (T (for PROP inside PROPNAMES do (INFILECOMSPROP AT PROP])
+
+(IFCDECLARE
+  [LAMBDA (TAIL WANTDECLARE)                          (* ; "Edited  8-Jun-90 18:11 by teruuchi")
+    (PROG ((TAIL TAIL))
+      LP  (COND
+             ((LISTP TAIL)
+              [SELECTQ (CAR TAIL)
+                  ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
+                       [AND WANTDECLARE (INFILECOMSVAL (LIST (CAR TAIL)
+                                                                 (CADR TAIL]
+                       (SETQ TAIL (CDR TAIL)))
+                  (DONTEVAL@LOAD [COND
+                                    ((OR (\STKSCAN 'DOFILESLOAD)
+                                         (\STKSCAN 'LOAD))
+                                                  (* ; "Edited by TT (8-June-90 : for AR#9376) In loading, discard the following contents in DECLARE tag %"DONTEVAL@LOAD%"")
+                                     (RETURN))
+                                    (WANTDECLARE (INFILECOMSVAL (CAR TAIL])
+                  (COMPILERVARS (RETURN))
+                  (COND
+                     [(FMEMB (CAR TAIL)
+                             DECLARETAGSLST)
+                      (COND
+                         (WANTDECLARE (INFILECOMSVAL (CAR TAIL]
+                     (T (INFILECOM (CAR TAIL]
+              (SETQ TAIL (CDR TAIL))
+              (GO LP])
+
+(INFILEPAIRS
+(LAMBDA (LST) (* lmm " 4-DEC-78 09:51") (for LL in LST do (for X inside (CAR LL) do (for Y inside (CDR LL) do (INFILECOMSVAL (LIST X Y))))))
+)
+
+(INFILECOMSMACRO
+(LAMBDA (ATS PROPS) (* lmm "28-SEP-78 18:35") (* ;; "this function is used, given a PROP or PROPS command, to tell which MACROS are contained in it.  --- Normally (e.g.  for WHEREIS and FILECOMSLST) it wants to return if the command contains any of the MACROPROPS for the given atom.  However, for UPDATE, it only wants a `hit' if the command contains ALL of the macro properties") (for AT inside ATS do (AND (OR (NEQ ONFILETYPE (QUOTE UPDATE)) (EVERY (PROPNAMES AT) (FUNCTION (LAMBDA (X) (OR (NOT (FMEMB X MACROPROPS)) (EQMEMB X PROPS)))))) (SOME MACROPROPS (FUNCTION (LAMBDA (PROP) (EQMEMB PROP PROPS)))) (INFILECOMSVAL AT))))
+)
+)
+
+
+
+(* ;; "adding to a file")
+
+(DEFINEQ
+
+(FILES?
+(LAMBDA NIL (* bvm%: "27-Oct-86 18:14") (* ;;; "Display each file needing dumping, etc.  For files needing dumping, display details of why.") (UPDATEFILES) (LET (FILES CHANGES PRINTED) (for FILE in FILELST when (SETQ CHANGES (fetch TOBEDUMPED of (LISTP (fetch FILEPROP of FILE)))) do (if (NOT PRINTED) then (LISPXPRIN1 "To be dumped:
+" T) (SETQ PRINTED T)) (LISPXPRIN2 FILE T) (LISPXPRIN1 " ...changes to " T) (for CH in CHANGES bind TB do (COND ((LISTP CH) (COND (TB (LISPXTAB TB NIL T)) (T (SETQ TB (POSITION T)))) (LISPXPRIN2 (CAR CH) T) (FILES?PRINTLST (CDR CH))) (T (* ; "old style") (LISPXPRIN2 CH T) (LISPXSPACES 1 T)))) (LISPXTERPRI T)) (for TYPE FLG in FILEPKGTYPES when (FILES?1 TYPE (AND PRINTED "    plus ")) do (SETQ FLG T) finally (if FLG then (OR PRINTED (LISPXPRIN1 "...to be dumped.  " T)) (ADDTOFILES?))) (if (SETQ FILES NOTCOMPILEDFILES) then (FILES?PRINTLST FILES "To be compiled: ") (LISPXTERPRI T)) (if (SETQ FILES NOTLISTEDFILES) then (FILES?PRINTLST FILES "To be listed: ") (LISPXTERPRI T)) (CL:VALUES)))
+)
+
+(FILES?1
+(LAMBDA (TYPE FIRST) (* bvm%: "27-Oct-86 18:17") (* ;; "If there are changed objects of TYPE, then print them out, preceded by FIRST (if given) plus a descriptive string, and return T.") (LET (STR LST) (COND ((AND (LITATOM TYPE) (SETQ STR (fetch DESCRIPTION of TYPE)) (LISTP (SETQ LST (fetch CHANGED of TYPE)))) (AND FIRST (LISPXPRIN1 FIRST T)) (LISPXPRIN1 (QUOTE "the ") T) (LISPXPRIN1 STR T) (FILES?PRINTLST LST) (LISPXTERPRI T) T))))
+)
+
+(FILES?PRINTLST
+(LAMBDA (LST STR) (* bvm%: "27-Oct-86 18:15") (* ;; "Print elements of LST separated by commas and indenting new lines a bunch.  If MAPRINT had a left margin arg, this would be simpler.") (MAPRINT LST T (OR STR ": ") NIL ", " (FUNCTION (LAMBDA (STR) (COND ((> (+ (POSITION T) (NCHARS STR T T) 3) (LINELENGTH NIL T)) (LISPXTERPRI T) (LISPXPRIN1 "         " T))) (LISPXPRIN2 STR T T))) T))
+)
+
+(ADDTOFILES?
+  [LAMBDA (NOASKSTR)                                     (* ; "Edited 21-Aug-91 10:13 by jds")
+
+    (* ;; "ask user about all of the things that need to be dumped, and distribute them to the files that he says")
+
+    (ERSETQ
+     (PROG [BUFS (VARSCHANGES (fetch (FILEPKGTYPE CHANGED) of 'VARS]
+
+      (* ;; "Save VARS list at the beginning, so that changes that might occur from adding things to files (e.g.  changing NILCOMS) will not be processed differently depending on the order of elements in FILEPKGTYPES")
+
+           [COND
+              (NOASKSTR (PRIN1 NOASKSTR T))
+              (T (DOBE)
+                 (SETQ BUFS (READP T))
+                 (SELECTQ (ASKUSER DWIMWAIT 'N '("want to say where the above go")
+                                 '((Y "es
+")
+                                   (N "o
+")
+                                   (%] "Nowhere
+" EXPLAINSTRING "] - nowhere, all items will be marked as dummy
+" NOECHOFLG T))
+                                 T)
+                     (N (RETURN))
+                     (%] (for TYPE in FILEPKGTYPES
+                            do (for NAME in (fetch (FILEPKGTYPE CHANGED)
+                                                           of TYPE)
+                                      do (ADDTOFILE NAME TYPE NIL)))
+                         (RETURN))
+                     NIL)                                    (* ; 
+                              "if there was type-ahead BEFORE the askuser, then don't allow it now")
+                 (COND
+                    (BUFS (SETQ BUFS (COND
+                                        ((READP T)
+                                         (LINBUF)
+                                         (SYSBUF)
+                                         (SETQ BUFS (CLBUFS NIL T READBUF]
+           [for TYPE STR LST in FILEPKGTYPES
+              when [AND (SETQ STR (fetch DESCRIPTION of TYPE))
+                            (LISTP (SETQ LST (COND
+                                                ((EQ TYPE 'VARS)
+                                                 VARSCHANGES)
+                                                (T (fetch (FILEPKGTYPE CHANGED) of TYPE]
+              do
+              (printout T "(" STR ")" T)
+              (for NAME TEM FILE in LST when NAME
+                 do
+                 (PROG NIL
+                   LP  (PRIN2 NAME T)
+                       (SPACES 2 T)
+
+                  (* ;; "if user typed ahead before entering addtofiles??  then dont allow typeahead here, because it will justgobble his earlier typeahead.")
+
+                       (SELECTQ (SETQ TEM (ASKUSER NIL NIL NIL ADDTOFILEKEYLST T))
+                           (%[ (ERSETQ (PROGN (SHOWDEF NAME TYPE T)
+
+                                 (* ;; "the DOBE is so that if the user control-E's after the printout is done but before it appears on the screen that the control-E will merely clear output buffer")
+
+                                              (DOBE)))
+                               (GO LP))
+                           (%] (SETQ FILE))
+                           (%                                (* ; "space.  means no action")
+                               (RETURN))
+                           (%
+ (PRINT (OR (SETQ FILE LASTFILE)
+                                          'Nowhere)
+                                      T))
+                           (SETQ FILE TEM))
+                       (OR (ERSETQ (PROG (TEM COMSNAME PLACE LISTNAME NEAR)
+                                         (SETQ PLACE (WHATIS FILE NIL TYPE))
+                                         [COND
+                                            ((LITATOM PLACE) (* ; "file name")
+                                             (SETQ FILE PLACE)
+                                             (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
+                                                        NAME TYPE NEAR LISTNAME)
+                                                 (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
+                                             (for F in (fetch WHENFILED of TYPE)
+                                                do (APPLY* F NAME TYPE FILE))
+
+                                          (* ;; "This isn't factored to the end, cause ADDTOLISTNAME might have to deal with a set of old elements on the listname.")
+
+                                             )
+                                            ((EQ (CAR PLACE)
+                                                 'Near%:)
+                                             (SETQ NEAR (CADR PLACE))
+                                             (COND
+                                                ([SOME FILELST (FUNCTION (LAMBDA (FL)
+                                                                           (ADDTOCOMS
+                                                                            (FILECOMS (SETQ FILE
+                                                                                           FL))
+                                                                            NAME TYPE NEAR LISTNAME]
+                                                 (PRINT (LIST 'on FILE)
+                                                        T T))
+                                                (T (PRINT (LIST (CADR PLACE)
+                                                                'not
+                                                                'found)
+                                                          T T)
+                                                   (ERROR!)))
+                                             (for F in (fetch WHENFILED of TYPE)
+                                                do (APPLY* F NAME TYPE FILE)))
+                                            ([OR [UNDONLSETQ (PROGN (SAVESET
+                                                                     (SETQ LISTNAME (CAR PLACE))
+                                                                     (MERGEINSERT
+                                                                      NAME
+                                                                      (LISTP (GETTOPVAL LISTNAME))
+                                                                      T)
+                                                                     T
+                                                                     'NOPRINT)
+                                                                    (OR (SETQ FILE
+                                                                         (CAR (WHEREIS NAME TYPE
+                                                                                     FILELST)))
+                                                                        (ERROR!]
+                                                 (SOME FILELST (FUNCTION (LAMBDA (X)
+                                                                           (ADDTOCOMS
+                                                                            (FILECOMS (SETQ FILE
+                                                                                           X))
+                                                                            NAME TYPE NEAR LISTNAME]
+                                             (PRIN1 "  value is filed on " T)
+                                             (PRINT FILE T T)
+                                             (for F in (fetch WHENFILED of TYPE)
+                                                do (APPLY* F NAME TYPE FILE))
+
+                                 (* ;; "Only have to notice the single new item here, unlike the case in ADDNEWCOM below, cause other items on the list already belong and were previously noticed")
+
+                                             )
+                                            (T (PRIN1 "    put list " T)
+                                               (PRIN2 (CAR PLACE)
+                                                      T T)
+                                               (SETQ FILE
+                                                (WHATIS (ASKUSER NIL NIL " on file: "
+                                                                   '(("" "" EXPLAINSTRING 
+                                                                         "a file name" KEYLST ()))
+                                                                   T)
+                                                       'FILE))
+                                               (SAVESET (CAR PLACE)
+                                                      (MERGEINSERT NAME
+                                                             (LISTP (GETTOPVAL (CAR PLACE)))
+                                                             T)
+                                                      T
+                                                      'NOPRINT)
+
+                                     (* ;; "Add new item before new command, so that user's new command function can inspect (CAR PLACE) and see all the items involved.")
+
+                                               (ADDNEWCOM (FILECOMS FILE)
+                                                      NAME TYPE (CAR PLACE)
+                                                      FILE)
+                                               (for F in (fetch WHENFILED of TYPE)
+                                                  do (for I in (GETTOPVAL (CAR PLACE))
+                                                            do (APPLY* F I TYPE FILE]
+                                         (AND FILE (ADDFILE FILE))
+                                         (SETQ LASTFILE PLACE)))
+                           (GO LP]
+           (AND BUFS (BKBUFS BUFS))
+           (UPDATEFILES])
+
+(ADDTOFILE
+(LAMBDA (NAME TYPE FILE NEAR LISTNAME) (* lmm "21-Nov-84 11:43") (* ; "adds NAME to the file FILE") (PROG (TEM COMSNAME) (SETQ TYPE (OR (GETFILEPKGTYPE TYPE NIL T) (COND ((FMEMB TYPE FILELST) (GETFILEPKGTYPE (swap TYPE FILE))) (T (GETFILEPKGTYPE TYPE))))) (SETQ FILE (WHATIS FILE (QUOTE FILE))) (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE)) NAME TYPE NEAR LISTNAME) (ADDNEWCOM COMSNAME NAME TYPE NIL FILE)) (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE)) (AND FILE (NOT (FMEMB FILE FILELST)) (ADDFILE FILE)) (RETURN FILE)))
+)
+
+(WHATIS
+(LAMBDA (USERINPUT ONLY) (* lmm "28-Nov-84 16:49") (* ;; "decides whether USERINPUT is a file or a list name --- if ONLY is nil, means either a listname or a filename is accepatble;  if ONLY is LIST then only a listname is acceptable and if ONLY is FILE then only a file name is acceptable") (PROG (TEM UCASE) (RETURN (COND ((NULL USERINPUT) (* ; "nowhere") NIL) ((LISTP USERINPUT) (COND (ONLY (ERROR!)) (T (SELECTQ (CAR USERINPUT) ((@ Near%:) (CONS (QUOTE Near%:) (CDR USERINPUT))) (WHATIS (CAR USERINPUT) (QUOTE LIST)))))) ((AND (NEQ ONLY (QUOTE LIST)) (OR (FMEMB (SETQ TEM (SETQ UCASE (U-CASE USERINPUT))) FILELST) (LISTP (GETTOPVAL (FILECOMS UCASE))) (SETQ TEM (FIXSPELL UCASE NIL FILELST T)))) TEM) ((AND (NEQ ONLY (QUOTE FILE)) (LISTP (GETTOPVAL USERINPUT))) (LIST USERINPUT)) ((AND (NEQ ONLY (QUOTE LIST)) (EQ (ASKUSER NIL NIL (LIST "create new file" UCASE) NIL T) (QUOTE Y))) UCASE) ((AND (NEQ ONLY (QUOTE FILE)) (EQ (ASKUSER NIL NIL (LIST "create new list" USERINPUT) NIL T) (QUOTE Y))) (LIST USERINPUT)) (T (* ; "none of above") (ERROR!))))))
+)
+
+(ADDTOCOMS
+(LAMBDA (COMS NAME TYPE NEAR LISTNAME) (* rmk%: "10-JUN-82 22:53") (* ;; "try to insert NAME of type TYPE command list COMS (either a coms name, or a just a list of coms);  return NIL if unsuccessful.  If LISTNAME is given, then only insert by adding to LISTNAME.  If NEAR is given, only insert near it") (COND ((NULL COMS) NIL) ((LITATOM COMS) (* ; "given a name of a command;  rebind COMSNAME to current variable and try to add to its value") (OR (PROG ((COMSNAME COMS)) (RETURN (ADDTOCOMS (LISTP (GETTOPVAL COMSNAME)) NAME TYPE NEAR (AND (NEQ COMS LISTNAME) LISTNAME)))) (AND (EQ COMS LISTNAME) (ADDNEWCOM COMS NAME TYPE)))) (T (SETQ TYPE (GETFILEPKGTYPE TYPE)) (for TAIL on COMS do (COND ((LISTP (CAR TAIL)) (COND ((ADDTOCOM (CAR TAIL) NAME TYPE NEAR LISTNAME) (RETURN T)))) (T (SELECTQ (CAR TAIL) ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) (SETQ TAIL (CDR TAIL))) NIL)))))))
+)
+
+(ADDTOCOM
+(LAMBDA (COM NAME TYPE NEAR LISTNAME) (* ; "Edited  2-May-87 19:04 by Pavel") (* ; "tries to insert NAME into the prettycom COM;  returns NIL if unsuccessful") (PROG (TEM) (COND ((AND NEAR (NOT (INFILECOMS? NEAR TYPE (LIST COM)))) (RETURN))) (COND ((SETQ TEM (fetch ADD of (CAR COM))) (RETURN (COND ((OR (NULL LISTNAME) (INFILECOMS? LISTNAME (QUOTE FILEVARS) (LIST COM))) (AND (SETQ TEM (APPLY* TEM COM NAME TYPE NEAR)) (MARKASCHANGED COMSNAME (QUOTE VARS))) TEM))))) (RETURN (SELECTQ (CAR COM) (FNS (AND (EQ TYPE (QUOTE FNS)) (ADDTOCOM1 COM NAME NEAR LISTNAME))) ((VARS INITVARS) (COND ((OR (EQ (CAR COM) (QUOTE VARS)) NEAR LISTNAME) (* ; "Don't stick on INITVARS unless NEAR or LISTNAME says we should.") (SELECTQ TYPE (EXPRESSIONS (COND ((EQ (CAR NAME) (QUOTE SETQ)) (ADDTOCOM1 COM (CDR NAME) NEAR LISTNAME)))) (VARS (ADDTOCOM1 COM NAME NEAR LISTNAME)) NIL)))) (COMS (ADDTOCOMS (COND ((EQ (CADR COM) (QUOTE *)) (COND ((LITATOM (CADDR COM)) (CADDR COM)) (T (RETURN)))) (T (CDR COM))) NAME TYPE NEAR LISTNAME)) (DECLARE%: (AND (OR LISTNAME NEAR) (ADDTOCOMS (COND ((EQ (CADR COM) (QUOTE *)) (COND ((LITATOM (CADDR COM)) (CADDR COM)) (T (RETURN)))) (T (CDR COM))) NAME TYPE NEAR LISTNAME))) (CL:EVAL-WHEN (AND (OR LISTNAME NEAR) (ADDTOCOMS (COND ((EQ (CL:THIRD COM) (QUOTE *)) (COND ((LITATOM (CL:FOURTH COM)) (CL:FOURTH COM)) (T (RETURN)))) (T (CDDR COM))) NAME TYPE NEAR LISTNAME))) ((PROP IFPROP) (SELECTQ TYPE (PROPS (COND ((EQ (CADR COM) (CADR NAME)) (ADDTOCOM1 (CDR COM) (CAR NAME) NEAR LISTNAME)) ((AND (EQ (CAR NAME) (CADDR COM)) (NULL (CDDDR COM))) (/RPLACA (CDR COM) (UNION (MKLIST (CDR NAME)) (MKLIST (CADR COM)))) (MARKASCHANGED COMSNAME (QUOTE VARS)) T))) (MACROS (COND ((AND (for PROP inside (CADR COM) always (EQMEMB PROP MACROPROPS)) (for PROP in MACROPROPS always (OR (EQMEMB PROP (CADR COM)) (NOT (GETPROP NAME PROP))))) (* ;; "every property in the command is a macro prop and, either this is an IFPROP or else the MACROS are changed") (ADDTOCOM1 (CDR COM) NAME NEAR LISTNAME)))) NIL)) ((PROPS ALISTS) (AND (EQ TYPE (CAR COM)) (ADDTOCOM1 COM (/NCONC1 (OR (ASSOC (CAR NAME) (COND ((EQ (CADR COM) (QUOTE *)) (COND ((LITATOM (CADDR COM)) (AND (OR (NULL LISTNAME) (EQ (CADDR COM) LISTNAME)) (GETTOPVAL (CADDR COM)))) (T (RETURN)))) (T (CDR COM)))) (LIST (CAR NAME))) (CADR NAME)) NEAR LISTNAME))) (P (COND ((AND (EQ TYPE (QUOTE EXPRESSIONS)) (NEQ (CAR NAME) (QUOTE SETQ))) (ADDTOCOM1 COM NAME NEAR LISTNAME)))) (AND (EQ (CAR COM) TYPE) (ADDTOCOM1 COM NAME NEAR LISTNAME))))))
+)
+
+(ADDTOCOM1
+(LAMBDA (COM NAME NEAR LISTNAME) (* rmk%: " 3-JAN-82 22:53") (COND ((EQ (CADR COM) (QUOTE *)) (* ; "add to list name") (AND (COND (LISTNAME (EQ (CADDR COM) LISTNAME)) (T (LITATOM (CADDR COM)))) (SAVESET (CADDR COM) (PROGN (SETQ COM (LISTP (GETTOPVAL (CADDR COM)))) (COND ((AND NEAR (SETQ NEAR (MEMBER NEAR COM))) (/RPLACD NEAR (CONS NAME (CDR NEAR))) COM) (T (MERGEINSERT NAME COM T)))) T (QUOTE NOPRINT)))) ((NULL LISTNAME) (* ; "add to standard com") (AND (NOT (MEMBER NAME (CDR COM))) (COND ((SETQ NEAR (MEMBER NEAR COM)) (/RPLACD NEAR (CONS NAME (CDR NEAR)))) (T (/RPLACD COM (MERGEINSERT NAME (CDR COM)))))) (MARKASCHANGED COMSNAME (QUOTE VARS)) T)))
+)
+
+(ADDNEWCOM
+(LAMBDA (COMSNAME NAME TYPE LISTNAME FILE) (* rmk%: " 3-JAN-82 22:53") (* ;; "Adds to COMSNAME a new command that will dump NAME as a TYPE on FILE.  --- if LISTNAME is given, then use it as the listname") (PROG (NEWCOM OLDCOM TAIL) (SETQ NEWCOM (MAKENEWCOM NAME TYPE LISTNAME FILE)) (COND ((NLISTP (SETQ TAIL (GETTOPVAL COMSNAME))) (RETURN (SAVESET COMSNAME (LIST NEWCOM) T (QUOTE NOPRINT))))) LP (COND ((OR (NLISTP (SETQ OLDCOM (CAR TAIL))) (SELECTQ (CAR OLDCOM) ((LOCALVARS SPECVARS BLOCKS) T) (DECLARE%: (FMEMB (QUOTE COMPILERVARS) (CDR OLDCOM))) NIL)) (/ATTACH NEWCOM TAIL)) ((LISTP (CDR TAIL)) (SETQ TAIL (CDR TAIL)) (GO LP)) (T (/RPLACD TAIL (LIST NEWCOM)))) (MARKASCHANGED COMSNAME (QUOTE VARS))))
+)
+
+(MAKENEWCOM
+(LAMBDA (NAME TYPE LISTNAME FILE) (* ; "Edited  8-Apr-87 14:55 by Pavel") (SETQ TYPE (GETFILEPKGTYPE TYPE)) (PROG (TEM) (* ;; "the user function MUST (a) check if FILE = T and not do anything destructive (since this is only for showdef) and (b) if LISTNAME is given, then use it rather than generating a different listname") (AND (LISTP NAME) (SETQ NAME (COPY NAME))) (RETURN (OR (AND (SETQ TEM (fetch NEWCOM of TYPE)) (APPLY* TEM NAME TYPE LISTNAME FILE)) (SELECTQ TYPE (PROPS (AND (NULL LISTNAME) (CONS (QUOTE PROP) (CONS (COND ((AND (LISTP (CDR NAME)) (NULL (CDDR NAME))) (CADR NAME)) (T (CDR NAME))) (OR (LISTP (CAR NAME)) (LIST (CAR NAME))))))) (EXPRESSIONS (COND ((EQ (CAR NAME) (QUOTE SETQ)) (MAKENEWCOM (CDR NAME) (QUOTE VARS) LISTNAME FILE)) (T (CONS (QUOTE P) (COND (LISTNAME (LIST (QUOTE *) LISTNAME)) (T (LIST NAME))))))) NIL) (DEFAULTMAKENEWCOM NAME TYPE LISTNAME FILE)))))
+)
+
+(DEFAULTMAKENEWCOM
+(LAMBDA (NAME TYPE LISTNAME FILE) (* lmm "20-OCT-82 22:48") (COND ((NOT (OR (FMEMB TYPE FILEPKGCOMSPLST) (fetch MACRO of TYPE) (fetch GETDEF of TYPE))) (ERROR "no defined way to dump or obtain the definition of " (OR (fetch DESCRIPTION of TYPE) TYPE) T)) ((NULL DEFAULTCOMHASFILEFLG) (* ; "disable FOOFNS FOOVARS junk") (LIST TYPE NAME)) ((EQ FILE T) (* ; "FILE=T only when called from SHOWDEF") (LIST TYPE NAME)) ((OR LISTNAME (AND FILE (SAVESET (SETQ LISTNAME (FILECOMS FILE TYPE)) (MERGEINSERT NAME (LISTP (GETTOPVAL LISTNAME)) T) T (QUOTE NOPRINT)))) (* ; "The check (AND FILE --) is so that it will not bother with making listnames just for deleting items") (LIST TYPE (QUOTE *) LISTNAME)) (T (LIST TYPE NAME))))
+)
+)
+
+(RPAQ? DEFAULTCOMHASFILEFLG )
+
+(ADDTOVAR MARKASCHANGEDFNS )
+(DEFINEQ
+
+(MERGEINSERT
+(LAMBDA (NEW LST ONEFLG) (* lmm "30-Jun-86 18:11") (* ;; "searches LST to find the most reasonable place to insert NEW.  Does nothing if ONEFLG is T and NEW is already a member of LST") (COND ((AND ONEFLG (MEMBER NEW LST)) LST) ((LISTP NEW) (/NCONC1 LST NEW)) (T (PROG ((N 0) LST1 PLACE TEM) (SETQ LST1 LST) LP (* ;; "finds the function with the longest leading common substring.  The idea is that if the list is only paatially sorted, want to insert the new thing in among those function that look like they are related.") (COND ((NULL LST1) (GO OUT)) ((OR (LISTP (CAR LST1)) (SETQ TEM (STRPOS (CAR LST1) NEW 1 NIL T T))) (* ;; "this takes precedence over even a longer string so that for example in the list (ADDTOFILES? ADDTOFILE), ADDTOFILE1 will be inserted aater ADDTOFILE") (SETQ PLACE LST1) (GO OUT)) ((IGREATERP (SETQ TEM (MERGEINSERT1 (CAR LST1) NEW)) N) (SETQ N TEM) (SETQ PLACE LST1))) (SETQ LST1 (CDR LST1)) (GO LP) OUT (SETQ TEM (CAR PLACE)) (OR (SOME (OR PLACE LST) (FUNCTION (LAMBDA (X LST) (COND ((OR (ALPHORDER NEW X) (AND PLACE (NOT (ALPHORDER TEM X)))) (* ;; "for example, if the FNS list is something like (...  FOO FOO1 ...) where the ...  may or may not be in order, e.g.  (ZAP FOO FOO1 BLAH), then want to insert FOO2 after FOO1, i.e. before BLAH, even though FOO2 wold not come before BLAH in a sorted list.") (/ATTACH NEW LST)) (T (SETQ TEM X) NIL))))) (SETQ LST (/NCONC1 LST NEW))) (RETURN LST)))))
+)
+
+(MERGEINSERT1
+(LAMBDA (X Y) (* rmk%: "24-MAY-82 00:05") (* ;; "value is the number of leading characters of X and Y that agree.") (PROG ((N 1) C1 C2) LP (COND ((OR (NULL (SETQ C1 (NTHCHARCODE X N))) (NULL (SETQ C2 (NTHCHARCODE Y N))) (NEQ C1 C2)) (RETURN (SUB1 N)))) (SETQ N (ADD1 N)) (GO LP)))
+)
+)
+
+(RPAQ? ADDTOFILEKEYLST
+       `((%[ "" EXPLAINSTRING "[ -- prettyprint the item to terminal and then ask again" NOECHOFLG T)
+         ((MKSTRING (CHARACTER (CHARCODE "^J")))
+          "" EXPLAINSTRING "{line-feed} - same as previous response" NOECHOFLG T)
+         (%  " 
+" EXPLAINSTRING "{space} - no action" NOECHOFLG T)
+         (%] "Nowhere
+" EXPLAINSTRING "] - nowhere, item is marked as a dummy
+" NOECHOFLG T)
+         [%( "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST (( "" CONFIRMFLG
+                                                                           (%) %] %  %
+)
+                                                                           RETURN
+                                                                           (CDR ANSWER]
+         (@ "Near: " EXPLAINSTRING "@ other-item   -- put the item near the other item" NOECHOFLG T 
+                  KEYLST (( "" CONFIRMFLG (%
+)
+                             RETURN ANSWER)))
+         (%
+ "" RETURN '% )
+         ("" "File name: " EXPLAINSTRING "a file name" KEYLST ())))
+
+(RPAQ? LASTFILE )
+
+
+
+(* ;; "deleting an item from a file")
+
+(DEFINEQ
+
+(DELFROMFILES
+(LAMBDA (NAME TYPE FILES) (* rmk%: " 6-MAR-82 13:16") (* ;; "Eliminates NAME as an item of type TYPE in COMS.") (PROG (COMS) (SETQ TYPE (GETFILEPKGTYPE TYPE)) (RETURN (for FILE inside (OR FILES FILELST) when (PROG1 (DELFROMCOMS (SETQ COMS (FILECOMS FILE)) NAME TYPE) (COND ((INFILECOMS? NAME TYPE COMS) (printout T "(could not delete " NAME " from " FILE ")" T)))) collect (for FN in (fetch WHENUNFILED of TYPE) do (APPLY* FN NAME TYPE FILE)) FILE))))
+)
+
+(DELFROMCOMS
+(LAMBDA (COMS NAME TYPE) (* bvm%: " 1-Oct-86 22:02") (* ;; "delete NAME of type TYPE from the coms COMS (either the name of some coms or a list).  Returns T if it does anything") (* ;; "If COMS is not a symbol, caller is required to bind COMSNAME to the symbol whose value we are deleting from, for benefit of marking it changed.") (COND ((LITATOM COMS) (LET ((COMSNAME COMS)) (DECLARE (SPECVARS COMS)) (AND (LISTP (SETQ COMS (GETTOPVAL COMSNAME))) (DELFROMCOMS COMS NAME TYPE)))) (T (PROG (DONE) (SETQ TYPE (GETFILEPKGTYPE TYPE)) LP (COND ((NLISTP COMS) (RETURN DONE))) (COND ((LISTP (CAR COMS)) (SELECTQ (DELFROMCOM (CAR COMS) NAME TYPE) (ALL (/RPLNODE2 COMS (CDR COMS)) (SETQQ DONE ALL) (GO LP)) (NIL) (SETQ DONE T))) (T (SELECTQ (CAR COMS) ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) (SETQ COMS (CDR COMS))) (COND ((AND (EQ TYPE (QUOTE VARS)) (EQ NAME (CAR COMS))) (/RPLNODE2 COMS (CDR COMS)) (SETQ DONE T) (GO LP)))))) (SETQ COMS (CDR COMS)) (GO LP)))))
+)
+
+(DELFROMCOM
+(LAMBDA (COM NAME TYPE) (* ; "Edited  2-May-87 19:02 by Pavel") (* ; "Tries to delete NAME from COM") (PROG (TEM VAR NEW) (COND ((SETQ TEM (fetch DELETE of (CAR COM))) (AND (SETQ TEM (APPLY* TEM COM NAME TYPE)) (MARKASCHANGED COMSNAME (QUOTE VARS))) (RETURN TEM))) (RETURN (SELECTQ (CAR COM) ((DECLARE%: COMS) (DELFROMCOMS (COND ((EQ (CADR COM) (QUOTE *)) (COND ((LITATOM (CADDR COM)) (CADDR COM)) (T (RETURN)))) (T (CDR COM))) NAME TYPE)) ((CL:EVAL-WHEN) (DELFROMCOMS (COND ((EQ (CL:THIRD COM) (QUOTE *)) (COND ((LITATOM (CL:FOURTH COM)) (CL:FOURTH COM)) (T (RETURN)))) (T (CDDR COM))) NAME TYPE)) ((ALISTS PROPS) (AND (EQ TYPE (CAR COM)) (COND ((EQ (CADR COM) (QUOTE *)) (COND ((AND (LITATOM (SETQ VAR (CADDR COM))) (SETQ TEM (ASSOC (CAR NAME) (GETTOPVAL VAR))) (NEQ (CDR TEM) (SETQ TEM (REMOVEITEM (CADR NAME) (CDR TEM))))) (SAVESET VAR TEM T (QUOTE NOPRINT)) T))) ((AND (CDR (SETQ TEM (ASSOC (CAR NAME) (CDR COM)))) (NEQ (CDR TEM) (SETQ NEW (REMOVEITEM (CADR NAME) (CDR TEM))))) (/RPLACD TEM NEW) (MARKASCHANGED COMSNAME (QUOTE VARS)) T)))) (BLOCKS (* ;; "Remove function name from blocks declarations.  This isn't entirely correctly, since in removing the name from the block variables, it will hit homonyms in globalvars, specvars, etc.") (AND (EQ TYPE (QUOTE FNS)) (for BLOCK in (INFILECOMTAIL COM T) do (AND (MEMB NAME BLOCK) (/DREMOVE NAME BLOCK)) (for X in BLOCK when (AND (LISTP X) (MEMB NAME (CDR X))) do (/RPLACD X (REMOVE NAME (CDR X))))))) ((PROP IFPROP) (SELECTQ TYPE (PROPS (RETURN (COND ((EQ (CADR COM) (CADR NAME)) (DELFROMCOM1 (CDR COM) (CAR NAME))) ((AND (EQMEMB (CADR NAME) (CADR COM)) (NULL (CDR (SETQ TEM (PRETTYCOM1 (CDR COM))))) (EQ (CAR TEM) (CAR NAME))) (/RPLACA (CDR COM) (REMOVE (CADR NAME) (MKLIST (CADR COM)))) (MARKASCHANGED COMSNAME (QUOTE VARS)) T)))) (COND ((for PROP inside (CADR COM) always (EQ TYPE (GETPROP PROP (QUOTE PROPTYPE)))) (DELFROMCOM1 (CDR COM) NAME))))) ((RECORDS INITRECORDS SYSRECORDS) (AND (EQ TYPE (QUOTE RECORDS)) (DELFROMCOM1 COM NAME))) (P (AND (EQ TYPE (QUOTE EXPRESSIONS)) (DELFROMCOM1 COM NAME))) ((VARS INITVARS) (AND (EQ TYPE (QUOTE VARS)) (DELFROMCOM1 COM NAME T))) (AND (EQ TYPE (CAR COM)) (DELFROMCOM1 COM NAME))))))
+)
+
+(DELFROMCOM1
+(LAMBDA (COM NAME FLG) (* rmk%: "10-JUN-82 22:44") (* ;; "FLG is passed on to REMOVEITEM, determines whether lists whose CAR is NAME will be removed") (LET (TEM VAL) (COND ((EQ (CADR COM) (QUOTE *)) (COND ((AND (LITATOM (SETQ TEM (CADDR COM))) (NEQ (SETQ VAL (GETTOPVAL TEM)) (SETQ VAL (REMOVEITEM NAME VAL FLG)))) (SAVESET TEM VAL T (QUOTE NOPRINT)) T))) ((NEQ (CDR COM) (SETQ TEM (REMOVEITEM NAME (CDR COM) FLG))) (/RPLACD COM TEM) (MARKASCHANGED COMSNAME (QUOTE VARS)) T))))
+)
+
+(REMOVEITEM
+(LAMBDA (X LST FLG) (* ; "Edited 25-May-88 17:52 by drc:") (* lmm "10-FEB-78 17:29") (* ;; "returns a subset of LST with X deleted;  if FLG is set, also remove elements whose CAR is X") (COND ((OR (MEMBER X LST) (AND FLG (SOME LST (FUNCTION (LAMBDA (Y) (EQUAL (CAR (LISTP Y)) X)))))) (SUBSET LST (FUNCTION (LAMBDA (Y) (AND (NOT (EQUAL Y X)) (OR (NOT FLG) (NLISTP Y) (NOT (EQUAL (CAR Y) X)))))))) (T LST)))
+)
+
+(MOVETOFILE
+(LAMBDA (TOFILE NAME TYPE FROMFILE) (* rmk%: "18-OCT-79 19:51") (* ; "To move items between files") (SETQ TYPE (GETFILEPKGTYPE TYPE)) (COND ((OR (EQ TYPE (QUOTE FNS)) FROMFILE) (* ; "FNS definition can reside on file if LOADFNS was done.  This guarantees that it is loaded.") (PUTDEF NAME TYPE (GETDEF NAME TYPE FROMFILE (QUOTE (NOCOPY NODWIM)))))) (AND (EQ TYPE (QUOTE FNS)) (MARKASCHANGED NAME TYPE)) (* ; "FNS won't get dumped unless they are `changed'") (DELFROMFILES NAME TYPE FROMFILE) (ADDTOFILE NAME TYPE TOFILE))
+)
+)
+
+(MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)
+
+(MOVD? 'MOVETOFILE 'MOVEITEM NIL T)
+
+(ADDTOVAR SYSPROPS PROPTYPE VARTYPE)
+
+
+
+(* ; "functions for doing things and marking them changed and auxiliary functions")
+
+(DEFINEQ
+
+(SAVEPUT
+(LAMBDA (ATM PROP VAL) (* lmm " 7-May-84 16:56") (* ;; "analogous to SAVESET but also marks changed property lists;  LISPXFNS are marked to change PUT and PUTPROP to SAVEPUT") (COND ((NOT (LITATOM ATM)) (ERRORX (LIST 14 ATM)))) (PROG ((X (GETPROPLIST ATM)) X0 TEM OLDFLG) LOOP (COND ((NLISTP X) (COND ((AND (NULL X) X0) (* ; "typical case.  property list ran out on an even parity position.  e.g.  (A B C D)") (SETQ TEM (LIST PROP VAL)) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /PUT-1) ATM TEM) LISPXHIST)) (FRPLACD (CDR X0) TEM) (GO RET))) (* ;; "property list was initially NIL or a non-list, or else it ended in a non-list following an even parity position, e.g. (A B . C) fall through and add new property at beginning")) ((NLISTP (CDR X)) (* ;; "property list runs out on an odd parity, or ends in an odd list following an odd parity, e.g.  (A B C) or (A B C . D) fall through and add at beginning.")) ((EQ (CAR X) PROP) (SETQ OLDFLG (NEQ (EQUALN (CADR X) VAL 400) T)) (* ; "i.e. it probably changed") (/RPLACA (CDR X) VAL) (COND ((NOT OLDFLG) (GO RET1)) (T (OR (EQ DFNFLG T) (LISPXPRINT (LIST (QUOTE new) PROP (QUOTE property) (QUOTE for) ATM) T T)) (GO RET)))) (T (SETQ X (CDDR (SETQ X0 X))) (GO LOOP))) (SETQ TEM (CONS PROP (CONS VAL (GETPROPLIST ATM)))) (SETPROPLIST ATM TEM) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /PUT-1) ATM TEM) LISPXHIST)) RET (MARKASCHANGED (LIST ATM PROP) (QUOTE PROPS) (NOT OLDFLG)) RET1 (AND ADDSPELLFLG (ADDSPELL ATM 0)) (RETURN VAL)))
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
+    (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT))
+)
+(DEFINEQ
+
+(UNMARKASCHANGED
+(LAMBDA (NAME TYPE) (* JonL "24-Jul-84 19:59") (* ;; "says to remove NAME from TYPE's changedlst, and also to remove it from any FILE properties.  Value is name if anything is done") (PROG (ANYFLG) (bind TAIL (CHANGED _ (fetch CHANGED of (SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE))))) while (SETQ TAIL (MEMBER NAME CHANGED)) do (/RPLACA TAIL) (SETQ ANYFLG T)) (for F TAIL PROP TYPEDPROP in FILELST when (SETQ TAIL (MEMBER NAME (CDR (SETQ TYPEDPROP (ASSOC TYPE (fetch TOBEDUMPED of (SETQ PROP (fetch FILEPROP of F)))))))) do (SETQ ANYFLG T) (COND ((SETQ TAIL (REMOVE (CAR TAIL) (CDR TYPEDPROP))) (/RPLACD TYPEDPROP TAIL)) (T (/replace TOBEDUMPED of PROP with (REMOVE TYPEDPROP (fetch TOBEDUMPED of PROP)))))) (RETURN (AND ANYFLG NAME))))
+)
+
+(PREEDITFN
+(LAMBDA (ATM TYPE EDITCHANGES) (* rmk%: "18-FEB-82 21:49") (* ; "EDITL is advised to call this before editing something") (AND FILEPKGFLG (SELECTQ TYPE (PROPLST (AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS) (CONS)) CLISPARRAY)) (for X in (GETPROPLIST ATM) do (OR (NLISTP X) (GETHASH X CLISPARRAY) (PUTHASH X (CONS (CAR X) (CDR X)) CLISPARRAY)))) (* ;; "note that if CLISPARRAY is disabled that ALL properties of an edited prop list will get marked as changed if any destructive edit is made") (RESETSAVE NIL (LIST (FUNCTION POSTEDITPROPS) EDITCHANGES (APPEND (GETPROPLIST ATM))))) (VARS (COND ((EQMEMB (QUOTE ALIST) (GETPROP ATM (QUOTE VARTYPE))) (AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS) (CONS)) CLISPARRAY)) (for X in (EVALV ATM) do (OR (NLISTP X) (GETHASH X CLISPARRAY) (PUTHASH X (CONS (CAR X) (CDR X)) CLISPARRAY)))) (RESETSAVE NIL (LIST (FUNCTION POSTEDITALISTS) EDITCHANGES (for X in (EVALV ATM) collect (CAR X))))))) NIL)))
+)
+
+(POSTEDITPROPS
+(LAMBDA (EDITCHANGES OLDPROPS) (* rmk%: "18-FEB-82 21:50") (* ; "was RESETSAVE'd from PREEDITFN") (PROG (OV FOUNDCHANGE) (OR FILEPKGFLG (RETURN)) (COND ((CADR EDITCHANGES) (for NEWPROP on (GETPROPLIST (CAR EDITCHANGES)) by (CDDR NEWPROP) when (for OLDPROP on OLDPROPS by (CDDR OLDPROP) do (COND ((EQ (CAR OLDPROP) (CAR NEWPROP)) (* ; "Found the property") (AND (EQ (CADR OLDPROP) (CADR NEWPROP)) (COND ((NLISTP (CADR OLDPROP)) (* ; "value is same") (RETURN)) ((AND CLISPARRAY (SETQ OV (GETHASH (CADR NEWPROP) CLISPARRAY)) (EQ (CAADR NEWPROP) (CAR OV)) (EQ (CDADR NEWPROP) (CDR OV))) (PUTHASH (CADR NEWPROP) NIL CLISPARRAY) (* ; "value has been edited (CLISPARRAY translation went away)") (RETURN)))) (RETURN T))) finally (* ; "didn't find the property") (RETURN T)) do (MARKASCHANGED (LIST (CAR EDITCHANGES) (CAR NEWPROP)) (QUOTE PROPS) NIL) (SETQ FOUNDCHANGE T)) (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES) NIL))))))
+)
+
+(POSTEDITALISTS
+(LAMBDA (EDITCHANGES OLDTOKENS) (* rmk%: " 4-JAN-82 10:14") (PROG (OV FOUNDCHANGE (NEWENTRIES (GETTOPVAL (CAR EDITCHANGES)))) (* ; "called after an ALIST has been edited") (OR FILEPKGFLG (RETURN)) (COND ((CADR EDITCHANGES) (for X in OLDTOKENS when (NOT (FASSOC X NEWENTRIES)) do (MARKASCHANGED (LIST (CAR EDITCHANGES) X) (QUOTE ALISTS) NIL) (SETQ FOUNDCHANGE T)) (for NEWENTRY in NEWENTRIES do (COND ((AND (LISTP NEWENTRY) (NOT (AND CLISPARRAY (SETQ OV (GETHASH NEWENTRY CLISPARRAY)) (EQ (CAR NEWENTRY) (CAR OV)) (EQ (CDR NEWENTRY) (CDR OV))))) (PUTHASH NEWENTRY NIL CLISPARRAY) (MARKASCHANGED (LIST (CAR EDITCHANGES) (CAR NEWENTRY)) (QUOTE ALISTS) NIL) (SETQ FOUNDCHANGE T)))) (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES) NIL))))))
+)
+)
+
+(ADDTOVAR LISPXFNS (PUT . SAVEPUT)
+                       (PUTPROP . SAVEPUT))
+
+
+
+(* ; "sub-functions for file package commands & types")
+
+(DEFINEQ
+
+(ALISTS.GETDEF
+(LAMBDA (NAME TYPE OPTIONS) (* Pavel " 7-Oct-86 17:24") (AND (LISTP NAME) (CL:SYMBOLP (CAR NAME)) (LET ((ASSOCIATION (ASSOC (CADR NAME) (GETTOPVAL (CAR NAME))))) (AND ASSOCIATION (LIST (QUOTE ADDTOVAR) (CAR NAME) ASSOCIATION)))))
+)
+
+(ALISTS.WHENCHANGED
+(LAMBDA (NAME TYPE NEWFLG) (* lmm "16-OCT-78 20:02") (* ; "called by MARKASCHANGED when an ALIST entry has changed") (PROG ((VARTYPE (GETPROP (CAR NAME) (QUOTE VARTYPE)))) (AND (LISTP VARTYPE) (EQ (CAR VARTYPE) (QUOTE ALIST)) (RETFROM (QUOTE MARKASCHANGED) (MARKASCHANGED (CADR NAME) (CADR VARTYPE) NEWFLG)))))
+)
+
+(CLEARCLISPARRAY
+(LAMBDA (NAME TYPE REASON) (DECLARE (SPECVARS NAME TYPE REASON)) (* lmm "14-Aug-84 15:03") (AND CLISPARRAY (MAPHASH CLISPARRAY (COND ((EQ TYPE (QUOTE I.S.OPRS)) (FUNCTION (LAMBDA (TRAN FORM) (AND (MEMB NAME FORM) (PUTHASH FORM NIL CLISPARRAY))))) (T (* ; "MACRO changed") (FUNCTION (LAMBDA (TRAN FORM) (COND ((OR (EQ NAME (CAR FORM)) (EQ (CAR (GETPROP (CAR FORM) (QUOTE CLISPWORD))) (QUOTE CHANGETRAN))) (PUTHASH FORM NIL CLISPARRAY))))))))))
+)
+
+(EXPRESSIONS.WHENCHANGED
+(LAMBDA (EXPR) (* ; "Edited  6-Apr-87 20:21 by Pavel") (SELECTQ (CAR EXPR) ((SETQ SETQQ) (UNMARKASCHANGED (CADR EXPR) (QUOTE VARS))) ((PROGN PROG) (for X in (CDR EXPR) do (EXPRESSIONS.WHENCHANGED X))) NIL))
+)
+
+(MAKEALISTCOMS
+(NLAMBDA X (* rmk%: "14-OCT-83 13:34") (* ;; "make command to dump prettydefmacros") (LIST (CONS (QUOTE ADDVARS) (for PR in X join (for ALISTNAME inside (CAR PR) collect (CONS ALISTNAME (for ATNAME inside (CDR PR) bind ENTRY when (SETQ ENTRY (OR (SASSOC ATNAME (GETTOPVAL ALISTNAME)) (PROGN (LISPXPRINT (LIST (QUOTE no) ATNAME (QUOTE entry) (QUOTE on) ALISTNAME) T T) NIL))) collect ENTRY)))))))
+)
+
+(MAKEFILESCOMS
+(NLAMBDA FILES (* JonL "12-FEB-83 19:02") (* ;; "This scans the command just to warn the user about any errors.  Must match up with the big SELECTQ in FILESLOAD NIL") (for FILE in FILES do (OR (LITATOM FILE) (while (LISTP FILE) do (SELECTQ (CAR (OR (LISTP FILE) (RETURN))) ((LOADCOMP LOADFROM)) (FROM (pop FILE) (if (OR (EQ (CAR FILE) (QUOTE VALUEOF)) (if (AND (EQ (CAR FILE) (QUOTE VALUE)) (EQ (CADR FILE) (QUOTE OF))) then (pop FILE))) then (pop FILE))) ((COMPILED LOAD EXTENSION EXT SOURCE SYMBOLIC IMPORT NOERROR)) (OR (FMEMB (CAR FILE) LOADOPTIONS) (PRINT (CONS (CAR FILE) (QUOTE (-- unrecognized FILES option))) T))) (pop FILE)))) (CONS (QUOTE FILESLOAD) FILES))
+)
+
+(MAKELISPXMACROSCOMS
+(NLAMBDA X (* lmm " 5-SEP-78 23:15") (PROG (TEM TEM2) (RETURN (CONS (CONS (QUOTE ALISTS) (SETQ TEM (NCONC (AND (SETQ TEM (SUBSET X (FUNCTION (LAMBDA (Z) (FASSOC Z LISPXHISTORYMACROS))))) (LIST (CONS (QUOTE LISPXHISTORYMACROS) TEM))) (AND (SETQ TEM (SUBSET X (FUNCTION (LAMBDA (Z) (FASSOC Z LISPXMACROS))))) (LIST (CONS (QUOTE LISPXMACROS) TEM)))))) (SETQ TEM2 (NCONC (AND (SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z) (FMEMB Z LISPXCOMS))))) (LIST (LIST (QUOTE ADDVARS) (CONS (QUOTE LISPXCOMS) TEM2)))) (AND (SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z) (FMEMB Z HISTORYCOMS))))) (LIST (LIST (QUOTE ADDVARS) (CONS (QUOTE HISTORYCOMS) TEM2))))))))))
+)
+
+(MAKEPROPSCOMS
+(NLAMBDA X (* lmm "26-FEB-78 17:10") (* ;; "make command to dump PROPS") (for PAIR in X collect (CONS (QUOTE PROP) (CONS (COND ((AND (LISTP (CDR PAIR)) (NULL (CDDR PAIR))) (CADR PAIR)) (T (CDR PAIR))) (OR (LISTP (CAR PAIR)) (LIST (CAR PAIR)))))))
+)
+
+(MAKEUSERMACROSCOMS
+(NLAMBDA X (* rmk%: " 3-JAN-82 23:20") (PROG (TEM) (COND (X (for Y in X do (OR (FASSOC Y USERMACROS) (FASSOC Y EDITMACROS) (LISPXPRINT (CONS Y (QUOTE (-- no entry on USERMACROS))) T T)))) (T (SETQ X (INTERSECTION (SETQ X (MAPCAR USERMACROS (QUOTE CAR))) X)))) (RETURN (LIST (CONS (QUOTE ADDVARS) (NCONC (for VAR in (QUOTE (USERMACROS EDITMACROS)) when (SETQ TEM (for Y in (GETTOPVAL VAR) when (FMEMB (CAR Y) X) collect Y)) collect (CONS VAR TEM)) (for LST in (QUOTE (EDITCOMSA EDITCOMSL COMPACTHISTORYCOMS DONTSAVEHISTORYCOMS)) when (SETQ TEM (SUBSET (GETTOPVAL LST) (FUNCTION (LAMBDA (Y) (OR (FMEMB Y X) (AND (LISTP Y) (FMEMB (CAR Y) X))))))) collect (CONS LST TEM))))))))
+)
+
+(PROPS.WHENCHANGED
+(LAMBDA (NAME TYPE NEWFLG) (* lmm " 7-SEP-78 22:08") (PROG ((PROPTYPE (GETPROP (CADR NAME) (QUOTE PROPTYPE)))) (COND (PROPTYPE (RETFROM (QUOTE MARKASCHANGED) (COND ((NEQ PROPTYPE (QUOTE IGNORE)) (MARKASCHANGED (CAR NAME) PROPTYPE NEWFLG))))) (T (SELECTQ (CADR NAME) (CLISPWORD (CLEARCLISPARRAY (CAR NAME))) NIL)))))
+)
+
+(FILEGETDEF.LISPXMACROS
+(LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm " 4-Jul-85 15:12") (MKPROGN (for X in (LOADFNS NIL SOURCE (QUOTE GETDEF) (QUOTE (LAMBDA (FIRST SECOND) (AND (EQ FIRST (QUOTE ADDTOVAR)) (MEMB SECOND (QUOTE (LISPXMACROS LISPXCOMS))) T)))) when (SELECTQ (CADR X) (LISPXMACROS (* ; "Rebuild the expressions cause there might be other elements in the ADDTOVAR") (AND (SETQ X (ASSOC NAME (CDDR X))) (SETQ X (LIST (QUOTE ADDTOVAR) (QUOTE LISPXMACROS) X)))) (LISPXCOMS (COND ((MEMB NAME (CDDR X)) (SETQ X (LIST (QUOTE ADDTOVAR) (QUOTE LISPXCOMS) NAME))) ((SETQ X (ASSOC NAME (CDDR X))) (* ; "For synonym pairs") (SETQ X (LIST (QUOTE ADDTOVAR) (QUOTE LISPXCOMS) X))))) NIL) collect X)))
+)
+
+(FILEGETDEF.ALISTS
+(LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm " 4-Jul-85 15:13") (for X in (LOADFNS NIL SOURCE (QUOTE GETDEF) (QUOTE (LAMBDA (FIRST SECOND) (AND (EQ FIRST (QUOTE ADDTOVAR)) (EQ SECOND (CAR NAME)))))) when (SETQ X (ASSOC (CADR NAME) (CDDR X))) collect X finally (RETURN (COND ($$VAL (CONS (QUOTE ADDTOVAR) (CONS (CAR NAME) $$VAL)))))))
+)
+
+(FILEGETDEF.RECORDS
+(LAMBDA (NAME TYPE SOURCE OPTIONS NOTFOUND) (* lmm "26-Jun-86 15:56") (LET ((VAL (LOADFNS NIL SOURCE (QUOTE GETDEF) (QUOTE (LAMBDA (FIRST SECOND) (AND (MEMB FIRST CLISPRECORDTYPES) (OR (EQ SECOND NAME) (AND (MEMB SECOND (QUOTE (%( %[))) (PROGN (RATOM) (RATOM) (RATOM) (EQ NAME (RATOM))))))))))) (if (EQ (CAAR VAL) (QUOTE NOT-FOUND%:)) then NOTFOUND elseif (CDR VAL) then (CONS (QUOTE PROGN) VAL) else (CAR VAL))))
+)
+
+(FILEGETDEF.PROPS
+(LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm " 4-Jul-85 15:13") (for X in (LOADFNS NIL SOURCE (QUOTE GETDEF) (QUOTE (LAMBDA (FIRST SECOND) (AND (EQ FIRST (QUOTE PUTPROPS)) (EQ SECOND (CAR NAME)))))) join (for TAIL on (CDDR X) by (CDDR TAIL) when (EQ (CAR TAIL) (CADR NAME)) join (LIST (CAR TAIL) (CADR TAIL))) finally (RETURN (COND ($$VAL (CONS (QUOTE PUTPROPS) (CONS (CAR NAME) $$VAL)))))))
+)
+
+(FILEGETDEF.MACROS
+(LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm "28-May-86 09:51") (MKPROGN (for X in (LOADFNS NIL SOURCE (QUOTE GETDEF) (QUOTE (LAMBDA (FIRST SECOND) (AND (FMEMB FIRST (QUOTE (PUTPROPS DEFMACRO))) (EQ SECOND NAME))))) join (if (EQ (CAR X) (QUOTE DEFMACRO)) then (LIST X) else (for TAIL on (CDDR X) by (CDDR TAIL) when (FMEMB (CAR TAIL) MACROPROPS) collect (LIST (QUOTE PUTPROPS) (CADR X) (CAR TAIL) (CADR TAIL)))))))
+)
+
+(FILEGETDEF.VARS
+(LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm " 4-Jul-85 15:14") (for X in (LOADFNS NIL SOURCE (QUOTE GETDEF) NAME) do (SELECTQ (CAR X) ((RPAQQ SETQQ) (RETURN (CADDR X))) ((RPAQ SETQ RPAQ?) (RETURN (EVAL (CADDR X)))) NIL) finally (RETURN (QUOTE NOBIND))))
+)
+
+(FILEGETDEF.FNS
+(LAMBDA (NAME TYPE SOURCE OPTIONS) (* bvm%: "29-Aug-86 22:30") (LET (MAP ENV) (COND ((AND (EQMEMB (QUOTE FAST) OPTIONS) (PROGN (CL:MULTIPLE-VALUE-SETQ (ENV MAP) (GET-ENVIRONMENT-AND-FILEMAP SOURCE)) MAP)) (for PAIR MAPLOC in (CDR MAP) when (SETQ MAPLOC (CADR (ASSOC NAME (CDDR PAIR)))) do (OR (OPENP SOURCE) (RESETSAVE NIL (LIST (QUOTE CLOSEF?) (SETQ SOURCE (OPENSTREAM SOURCE (QUOTE INPUT) (QUOTE OLD)))))) (SETFILEPTR SOURCE MAPLOC) (RETURN (WITH-READER-ENVIRONMENT ENV (COND ((EQMEMB (QUOTE ARGLIST) OPTIONS) (RATOM SOURCE) (READ SOURCE) (RATOM SOURCE) (LIST (READ SOURCE) (READ SOURCE))) (T (CADR (READ SOURCE)))))))) (T (CADR (FASSOC NAME (LOADEFS NAME SOURCE)))))))
+)
+
+(FILEPKGCOMS.PUTDEF
+(LAMBDA (NAME TYPE DEFINITION REASON) (* lmm "15-Jul-85 11:29") (PROG (COM TYP) (SELECTQ (CAR (LISTP DEFINITION)) (COM (SETQ COM (CDR DEFINITION))) (TYPE (SETQ TYP (CDR DEFINITION))) (PROGN (SETQ COM (CDR (ASSOC (QUOTE COM) DEFINITION))) (SETQ TYP (CDR (ASSOC (QUOTE TYPE) DEFINITION))))) (* ;; "Check properties first, so that we don't smash some and then get an error in a later call to FILEPKGCOM/TYPE") (for I in COM by (CDDR I) do (SELECTQ I ((ADD DELETE MACRO CONTENTS CONTAIN COM)) (ERROR I "not file package command property"))) (* ; "COM merely adds to spelling list, for builtins") (FILEPKGCOM NAME (QUOTE CONTENTS) (OR (LISTGET COM (QUOTE CONTENTS)) (LISTGET COM (QUOTE CONTAIN)))) (* ; "Until CONTAIN is de-documented.") (for PROP in (QUOTE (ADD DELETE MACRO COM)) do (FILEPKGCOM NAME PROP (LISTGET COM PROP))) (for I in TYP by (CDDR I) do (OR (FMEMB I FILEPKGTYPEPROPS) (SELECTQ I ((DESCRIPTION TYPE)) (ERROR I "not file package type/command property")))) (* ; "TYPE merely adds to spelling list, for builtins") (for PROP in (UNION (QUOTE (DESCRIPTION TYPE)) FILEPKGTYPEPROPS) do (FILEPKGTYPE NAME PROP (LISTGET TYP PROP)))))
+)
+
+(FILES.PUTDEF
+(LAMBDA (NAME TYPE DEFINITION REASON) (* lmm "15-Jul-85 17:13") (PROGN (PUTDEF (FILECOMS NAME) (QUOTE VARS) (CAR DEFINITION) REASON) (* ; "DEFINE THE COMS") (ADDFILE NAME) (* ; "MAKE SURE IT IS A FILE PACKAGE ENTITY") (/replace TOBEDUMPED of (fetch FILEPROP of NAME) (FILEPKG.MERGECHANGES (CADR DEFINITION) (fetch TOBEDUMPED of (fetch FILEPROP of NAME)))) (OR (fetch FILEDATES of NAME) (/replace FILEDATES of NAME with (CADDR DEFINITION)))))
+)
+
+(VARS.PUTDEF
+(LAMBDA (NAME TYPE DEFINITION REASON) (* lmm "29-Jul-85 20:59") (/SETTOPVAL NAME DEFINITION T)))
+
+(FILES.WHENCHANGED
+(LAMBDA (NAME TYPE REASON) (MARKASCHANGED (FILECOMS NAME) (QUOTE VARS) REASON)))
+)
+
+(ADDTOVAR MACROPROPS MACRO BYTEMACRO DMACRO)
+
+(ADDTOVAR SYSPROPS PROPTYPE)
+
+(PUTPROPS I.S.OPR PROPTYPE I.S.OPRS)
+
+(PUTPROPS SUBR PROPTYPE IGNORE)
+
+(PUTPROPS LIST PROPTYPE IGNORE)
+
+(PUTPROPS CODE PROPTYPE IGNORE)
+
+(PUTPROPS FILEDATES PROPTYPE IGNORE)
+
+(PUTPROPS FILE PROPTYPE IGNORE)
+
+(PUTPROPS FILEMAP PROPTYPE IGNORE)
+
+(PUTPROPS EXPR PROPTYPE FNS)
+
+(PUTPROPS VALUE PROPTYPE VARS)
+
+(PUTPROPS COPYRIGHT PROPTYPE FILES)
+
+(PUTPROPS FILETYPE PROPTYPE FILES)
+
+(PUTPROPS BAKTRACELST VARTYPE ALIST)
+
+(PUTPROPS BREAKMACROS VARTYPE ALIST)
+
+(PUTPROPS COMPILETYPELST VARTYPE ALIST)
+
+(PUTPROPS EDITMACROS VARTYPE (ALIST USERMACROS))
+
+(PUTPROPS ERRORTYPELST VARTYPE ALIST)
+
+(PUTPROPS FONTDEFS VARTYPE ALIST)
+
+(PUTPROPS LISPXHISTORYMACROS VARTYPE (ALIST LISPXMACROS))
+
+(PUTPROPS LISPXMACROS VARTYPE (ALIST LISPXMACROS))
+
+(PUTPROPS PRETTYDEFMACROS VARTYPE (ALIST FILEPKGCOMS))
+
+(PUTPROPS PRETTYEQUIVLST VARTYPE ALIST)
+
+(PUTPROPS PRETTYPRINTMACROS VARTYPE ALIST)
+
+(PUTPROPS PRETTYPRINTYPEMACROS VARTYPE ALIST)
+
+(PUTPROPS USERMACROS VARTYPE (ALIST USERMACROS))
+
+
+
+(* ; "Define the commands below AFTER the various properties have been established.")
+
+
+(ADDTOVAR USERMACROS
+          (M (X . Y)
+             (E (MARKASCHANGED (COND ((LISTP 'X)
+                                      (CAR 'X))
+                                     (T 'X))
+                       'USERMACROS)
+                T)
+             (ORIGINAL (M X . Y)))
+          (M NIL (MAKE FILE FILE)))
+
+(ADDTOVAR EDITMACROS
+          (M (X . Y)
+             (E (MARKASCHANGED (COND ((LISTP 'X)
+                                      (CAR 'X))
+                                     (T 'X))
+                       'USERMACROS)
+                T)
+             (ORIGINAL (M X . Y))))
+
+(ADDTOVAR EDITCOMSA M)
+
+(ADDTOVAR EDITCOMSL M)
+
+
+
+(* ; "GETDEF methods")
+
+(DEFINEQ
+
+(RENAME
+(LAMBDA (OLD NEW TYPES FILES METHOD) (* JonL "24-Jul-84 20:01") (PROG ((TYPES (GETFILEPKGTYPE TYPES (QUOTE TYPE) NIL OLD))) (* ;; "special kludge: change the callers BEFORE if we are changing a field;  this is so the CHANGECALLERS won't get an UNABLE TO DWIMIFY message") (for TYPE inside TYPES when (NEQ TYPE (QUOTE FIELDS)) do (COPYDEF OLD NEW TYPE NIL (COND ((EQ TYPE (QUOTE VARS)) (QUOTE NOERROR))))) (CHANGECALLERS OLD NEW TYPES FILES METHOD) (for TYPE inside TYPES do (COND ((AND (EQ TYPE (QUOTE FIELDS)) (HASDEF OLD (QUOTE FIELDS))) (* ;; "The HASDEF test is because the rename might already have been done in EDITFROMFILE in the CHANGECALLERS, if it found a record with the field on a file.  Otherwise, COPYDEF essentially will just do the necessary substitution in the existing record declarations, given that definitions for FIELDS are mutually exclusive.") (COPYDEF OLD NEW (QUOTE FIELDS))) (T (DELDEF OLD TYPE)))) (RETURN NEW)))
+)
+
+(CHANGECALLERS
+(LAMBDA (OLD NEW AS-TYPES FILES METHOD) (* ; "Edited  6-Dec-86 01:25 by lmm") (PROG ((AS-TYPES (GETFILEPKGTYPE AS-TYPES)) REL TEM EDITCOMS FNS) (OR METHOD (SETQ METHOD DEFAULTRENAMEMETHOD)) (SETQ EDITCOMS (LIST (COND ((OR (EQMEMB (QUOTE CAREFUL) METHOD) (PROGN (SETQ TEM (TYPESOF OLD NIL AS-TYPES)) (printout T "Warning --" OLD " is also defined as " TEM T))) (* ;; "This creates a `command' that searches like EXAM, but interrogates the user about whether to do the Rename.  Y means do it, No means skip, anything else goes into TTY.") (SUBPAIR (QUOTE (OLD NEW)) (LIST OLD NEW) (QUOTE (BIND (LPQ (F OLD N) (MARK %#1) (ORR (1 !0 P) NIL) (MARK %#2) (COMS (SELECTQ (ASKUSER NIL NIL "   Replace ? " (QUOTE ((Y "Yes
+") (N "No
+") (%
+ "") (%  "") (%
+ "") (& ""))) NIL NIL (QUOTE (NOECHOFLG T))) (Y (QUOTE (R1 OLD NEW))) (N NIL) (QUOTE TTY%:))) (MARK %#3) (IF (EQ (%## (\ %#3)) (%## (\ %#2))) ((\ %#1)) NIL)))))) (T (LIST (QUOTE R) OLD NEW))))) (SELECTQ (COND ((AND (EQMEMB (QUOTE MASTERSCOPE) METHOD) MSDATABASELST (for TYPE inside AS-TYPES do (COND ((SETQ TEM (SELECTQ TYPE ((FNS FUNCTIONS SPECIAL-FORMS OPTIMIZERS) (QUOTE CALL)) (MACROS (QUOTE (CALL DIRECTLY))) ((VARS VARIABLES) (QUOTE (USE OR BIND))) ((RECORDS FIELDS I.S.OPRS) (LIST (QUOTE USE) (QUOTE AS) TYPE)) (RETURN NIL))) (COND (REL (SETQ REL (LIST TEM (QUOTE OR) REL))) (T (SETQ REL TEM))))) FINALLY (RETURN REL))) (* ;; "can only use masterscope if (a) we say to, (b) something's been analyzed, and (c) the types the function is are known") (QUOTE MASTERSCOPE)) ((EQMEMB (QUOTE EDITCALLERS) METHOD) (QUOTE EDITCALLERS)) (T (QUOTE SEARCH))) (MASTERSCOPE (MAPC (SETQ FNS (NCONC (COND ((NULL FILES) (UPDATEFILES) (FILEPKGCHANGES (QUOTE FNS)))) (for FILE inside (OR FILES FILELST) join (FILEFNSLST FILE)))) (FUNCTION UPDATEFN)) (SETQ FNS (INTERSECTION (GETRELATION OLD (SETQ REL (PARSERELATION REL)) T) FNS))) (EDITCALLERS (SETQ FILES (for X inside (OR FILES FILELST) when (SETQ TEM (EDITCALLERS OLD X T)) collect (PROGN (SETQ FNS (NCONC FNS (CDR TEM))) X)))) (SEARCH (SETQ FNS (for X inside (OR FILES FILELST) join (FILEFNSLST X)))) (ERROR "UNRECOGNIZED RENAME METHOD" METHOD)) (AND (EQMEMB (QUOTE FNS) AS-TYPES) (FMEMB OLD FNS) (SETQ FNS (REMOVE OLD FNS))) (EDITFROMFILE FNS FILES OLD EDITCOMS) (for TYPE inside AS-TYPES do (for FILE in (WHEREIS OLD TYPE FILES) do (AND (ADDTOFILE NEW TYPE FILE) (DELFROMFILES OLD TYPE FILE) (printout T OLD " changed to " NEW " on " FILE))) (COND ((SETQ TEM (WHEREIS OLD TYPE FILES)) (printout T "Couldn't change " OLD " to " NEW " as " TYPE " on " TEM)))) (COND (REL (UPDATECHANGED) (COND ((AND (SETQ TEM (GETRELATION OLD REL T)) (WHEREIS TEM (QUOTE FNS) FILES)) (printout T "Couldn't find where " OLD " is referenced in " TEM T)))))))
+)
+)
+(DEFINEQ
+
+(SHOWDEF
+(LAMBDA (NAME TYPE FILE) (* lmm " 3-Jan-85 17:32") (* ; "prettyprint NAME as it would be dumped as a TYPE") (RESETLST (PROG (ORIGFLG FNSLST FL PRETTYCOMSLST) (DECLARE (SPECVARS . T)) (AND FILE (NEQ FILE (OUTPUT)) (if (SETQ FL (OPENP FILE (QUOTE OUTPUT))) then (RESETSAVE (OUTPUT FL)) else (OUTFILE FILE) (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (OUTPUT))))) (PRETTYCOM (MAKENEWCOM NAME TYPE)))))
+)
+
+(COPYDEF
+(LAMBDA (OLD NEW TYPE SOURCE OPTIONS) (* lmm "14-Aug-84 18:38") (* ; "like MOVD, but takes a type.") (PROG (TEM DEF) (SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE))) (SETQ DEF (GETDEF OLD TYPE SOURCE (COND ((EQ OPTIONS (QUOTE NOCOPY)) NIL) (T (REMOVE (QUOTE NOCOPY) (MKLIST OPTIONS)))))) (* ; "The default is for GETDEF to return a COPY.  Make sure that NOCOPY isn't in options though.") (SELECTQ TYPE (VARS) (FILES (for X in (CAR DEF) do (* ; "change all the listnames which are of form filenameTYPE") (SELECTQ (CAR X) ((PROP IFPROP) (SETQ X (CDR X))) NIL) (COND ((EQ (CADR X) (QUOTE *)) (SETQ X (CDDR X)) (COND ((AND (LITATOM (CAR X)) (SETQ TEM (STRPOS OLD (CAR X) 1 NIL T T))) (SAVESET (SETQ TEM (PACK* NEW (SUBATOM (CAR X) TEM -1))) (COPY (GETTOPVAL (CAR X))) T) (FRPLACA X TEM))))))) ((PROPS ALISTS) (OR (EQ (CAR NEW) (CAR OLD)) (DSUBST (CAR NEW) (CAR OLD) DEF)) (OR (EQ (CADR NEW) (CADR OLD)) (DSUBST (CADR NEW) (CADR OLD) DEF))) (DSUBST NEW OLD DEF)) (PUTDEF NEW TYPE DEF) (RETURN NEW)))
+)
+
+(GETDEF
+(LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm "13-Jul-85 04:10") (* ;; "returns the definition of NAME as a TYPE from SOURCE;  cause ERROR if not found unless OPTIONS is NOERROR --- usually returns a copy unless OPTIONS is NOCOPY in which case it tries not to return a copy --- FLG=NOCOPY is currently only used from SAVEDEF where SOURCE is always 0 --- If options is or contains a string, returns that string instead of causing error if no def found.  The caller can figure out what happened, even for types for which NIL/NOBIND might have defs.") (PROG (DEF TEM (NOCOPY (EQMEMB (QUOTE NOCOPY) OPTIONS))) (DECLARE (SPECVARS NOCOPY)) (SELECTQ OPTIONS (0 (SETQQ OPTIONS (NOERROR NODWIM)) (SETQ NOCOPY T)) (1 (SETQQ OPTIONS (NOERROR NODWIM FAST ARGLIST)) (SETQ NOCOPY T)) (T (SETQQ OPTIONS SPELL)) NIL) (SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE))) (SELECTQ SOURCE (0 (SETQQ SOURCE CURRENT)) (T (SETQQ SOURCE SAVED)) (NIL (SETQQ SOURCE ?)) NIL) (SELECTQ SOURCE (CURRENT (SETQ DEF (GETDEFCURRENT NAME TYPE OPTIONS))) (? (LET ((NOERROR (CONS (QUOTE NOERROR) (MKLIST OPTIONS)))) (OR (NEQ (SETQ DEF (GETDEFCURRENT NAME TYPE NOERROR)) (fetch NULLDEF of TYPE)) (NEQ (SETQ DEF (GETDEFSAVED NAME TYPE NOERROR)) (fetch NULLDEF of TYPE)) (SETQ DEF (GETDEFFROMFILE NAME TYPE (QUOTE FILE) OPTIONS))))) (SAVED (SETQ DEF (GETDEFSAVED NAME TYPE OPTIONS))) (COND ((AND (LISTP SOURCE) (EQ (CAR SOURCE) (QUOTE =))) (SETQ DEF (CDR SOURCE))) (T (SETQ DEF (GETDEFFROMFILE NAME TYPE SOURCE OPTIONS)) (SETQ NOCOPY T)))) (OR NOCOPY (SETQ DEF (COPY DEF))) (COND ((AND (EQ TYPE (QUOTE FNS)) (NOT (EQMEMB (QUOTE NODWIM) OPTIONS))) (DWIMDEF DEF NAME SOURCE))) (RETURN DEF)))
+)
+
+(GETDEFCOM
+(LAMBDA (X) (* lmm " 4-Jul-85 13:31") (* ;; "In the case where GETDEF doesn't know how to get the definition of something, it resorts to asking the file package to print it out to a file and then reading the file back in.  Actually, though, that is a two stage process where the `command' to print out the datum is first macro expanded and then executed.  --- In some cases, you can tell what would be printed without printing it by looking at the prettydef-macro expansion.  That is what GETDEFCOM does: it takes a list of prettydef commands and returns what Would be printed by those commands (or NIL if it is `too hard' to figure out.) --- A few of the commands are special-cased inside GETDEFCOM0 because they occur frequently or are simple.") (* ; "a RETFROM point") (for Y in X join (GETDEFCOM0 Y)))
+)
+
+(GETDEFCOM0
+(LAMBDA (COM) (* wt%: " 7-FEB-79 23:28") (PROG (TEM) (RETURN (COND ((SETQ TEM (fetch MACRO of (CAR COM))) (* COND ((fetch CONTENTS of (CAR COM)) (* ; "if it has a CONTENTS function, generally means it is not safe to evaluate") (RETFROM (QUOTE GETDEFCOM)))) (for Y in (SUBPAIR (CAR TEM) (PRETTYCOM1 COM) (CDR TEM)) join (GETDEFCOM0 Y))) (T (SELECTQ (CAR COM) (COMS (for X in (PRETTYCOM1 COM) join (GETDEFCOM0 X))) (ADDVARS (for Y in (PRETTYCOM1 COM) collect (CONS (QUOTE ADDTOVAR) Y))) (APPENDVARS (for Y in (PRETTYCOM1 COM) collect (CONS (QUOTE APPENDTOVAR) Y))) (P (APPEND (PRETTYCOM1 COM))) (RETFROM (QUOTE GETDEFCOM))))))))
+)
+
+(GETDEFCURRENT
+(LAMBDA (NAME TYPE OPTIONS) (* ; "Edited  2-May-87 19:00 by Pavel") (* ; "Gets the current definition--source=0") (LET (DEF) (COND ((AND (SETQ DEF (fetch GETDEF of TYPE)) (NEQ DEF T)) (* ;; "We assign T to types whose GETDEF is normally handled in the SELECTQ below but whose MACRO is to be defaulted to the PUTDEF/GETDEF in PRETTYCOM.") (OR (NEQ (SETQ DEF (APPLY* DEF NAME TYPE OPTIONS)) (fetch NULLDEF of TYPE)) (GETDEFERR NAME TYPE OPTIONS)) DEF) (T (OR (NEQ (SETQ DEF (SELECTQ TYPE (FNS (AND (LITATOM NAME) (EXPRP (SETQ DEF (VIRGINFN NAME))) DEF)) (VARS (if (LITATOM NAME) then (GETTOPVAL NAME) else (QUOTE NOBIND))) ((FIELDS RECORDS) (if (LITATOM NAME) then (SETQ DEF (SELECTQ TYPE (RECORDS (RECLOOK NAME)) (MKPROGN (FIELDLOOK NAME)))) (if (EQMEMB (QUOTE EDIT) OPTIONS) then (COPY DEF) else DEF))) (FILES (* ; "what is the `definition' of a file?  -- I guess the COMS which say what it contains") (if (LITATOM NAME) then (if (SETQ DEF (GETFILEDEF NAME)) then (UPDATEFILES) (LIST (LISTP (GETTOPVAL (FILECOMS DEF))) (fetch TOBEDUMPED of (fetch FILEPROP of DEF)) (LISTP (fetch FILEDATES of DEF)))))) (TEMPLATES (if (AND (LITATOM NAME) (SETQ DEF (GETTEMPLATE NAME))) then (LIST (QUOTE SETTEMPLATE) (KWOTE NAME) (KWOTE DEF)))) (MACROS (if (AND (LITATOM NAME) (SETQ DEF (for X on (GETPROPLIST NAME) by (CDDR X) when (FMEMB (CAR X) MACROPROPS) join (LIST (CAR X) (CADR X))))) then (BQUOTE (PUTPROPS (\, NAME) (\,@ DEF))))) (EXPRESSIONS (LISTP NAME)) (PROPS (AND (LISTP NAME) (AND (SETQ DEF (SOME (GETPROPLIST (CAR NAME)) (FUNCTION (LAMBDA (X) (EQ X (CADR NAME)))) (FUNCTION CDDR))) (LIST (QUOTE PUTPROPS) (CAR NAME) (CADR NAME) (CADR DEF))))) (FILEPKGCOMS (AND (LITATOM NAME) (PROG ((COM (FILEPKGCOM NAME)) (TYP (FILEPKGTYPE NAME))) (RETURN (COND ((AND COM TYP) (LIST (CONS (QUOTE COM) COM) (CONS (QUOTE TYPE) TYP))) (COM (LIST (CONS (QUOTE COM) COM))) (TYP (LIST (CONS (QUOTE TYPE) TYP)))))))) (FILEVARS (COND ((AND (LITATOM NAME) (LISTP (SETQ DEF (GETTOPVAL NAME))) (WHEREIS NAME (QUOTE FILEVARS))) DEF) (T (QUOTE NOBIND)))) (LET ((COMS (LIST (MAKENEWCOM NAME TYPE))) FILE) (COND ((NOT (SETQ DEF (GETDEFCOM COMS))) (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT* (RESETLST (RESETSAVE PRETTYFLG) (RESETSAVE FONTCHANGEFLG) (RESETSAVE (OUTPUT (SETQ FILE (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))))) (PRETTYDEFCOMS COMS) (SETFILEPTR FILE 0) (SETQ DEF (for X in (READFILE FILE) join (SELECTQ (CAR X) ((*) NIL) (DECLARE%: (for Y on (CDR X) unless (SELECTQ (CAR Y) ((COPYWHEN EVAL@LOADWHEN EVAL@COMPILEWHEN) (RETURN (LIST Y))) (FMEMB (CAR Y) DECLARETAGSLST)) collect (CAR Y))) (CL:EVAL-WHEN (CDDR X)) (PROGN (CDR X)) (LIST X)))) (SETQ NOCOPY T))))) (MKPROGN DEF)))) (fetch NULLDEF of TYPE)) (GETDEFERR NAME TYPE OPTIONS)) DEF))))
+)
+
+(GETDEFERR
+(LAMBDA (NAME TYPE OPTIONS MSG) (* lmm "13-Jul-85 04:11") (DECLARE (USEDFREE NODEF)) (* ; "Message non-null if looking for saved or filed definition.") (PROG (TEM) (RETURN (COND ((EQMEMB (QUOTE NOERROR) OPTIONS) (* ; "We want to do the string search in the HASDEF case") (RETURN (fetch NULLDEF of TYPE))) ((AND (NULL MSG) (EQMEMB (QUOTE SPELL) OPTIONS) (SETQ TEM (HASDEF NAME TYPE NIL (OR (LISTGET1 (LISTP OPTIONS) (QUOTE SPELL)) T))) (NEQ TEM NAME)) (RETFROM (QUOTE GETDEF) (GETDEF TEM TYPE (QUOTE ?) (CONS (QUOTE NOERROR) (MKLIST OPTIONS))))) (T (for O inside OPTIONS when (STRINGP O) do (RETFROM (QUOTE GETDEF) O) finally (ERROR NAME (CONS TYPE (QUOTE (definition not found))) T)))))))
+)
+
+(GETDEFFROMFILE
+(LAMBDA (NAME TYPE SOURCE OPTIONS) (* bvm%: " 1-Oct-86 22:10") (* ;; "Tries to get definition from source file.  If successful, returns the definition.  Otherwise returns the NULLDEF of the type if OPTIONS contains NOERROR.") (DECLARE (SPECVARS NAME)) (bind (NOTFOUND _ "not found") DEF SOURCE TEM2 for FILE inside (COND ((EQ SOURCE (QUOTE FILE)) (WHEREIS NAME TYPE T)) (T SOURCE)) when (AND (SETQ SOURCE (FINDFILE FILE T)) (NEQ (SETQ DEF (COND ((SETQ TEM2 (fetch FILEGETDEF of TYPE)) (APPLY* TEM2 NAME TYPE SOURCE OPTIONS NOTFOUND)) (T (SELECTQ TYPE (FNS (FILEGETDEF.FNS NAME TYPE SOURCE OPTIONS NOTFOUND)) ((VARS FILEVARS) (FILEGETDEF.VARS NAME TYPE SOURCE OPTIONS NOTFOUND)) (MACROS (FILEGETDEF.MACROS NAME TYPE SOURCE OPTIONS NOTFOUND)) (PROPS (FILEGETDEF.PROPS NAME TYPE SOURCE OPTIONS NOTFOUND)) (RECORDS (FILEGETDEF.RECORDS NAME TYPE SOURCE OPTIONS NOTFOUND)) (ALISTS (FILEGETDEF.ALISTS NAME TYPE SOURCE OPTIONS NOTFOUND)) (LISPXMACROS (FILEGETDEF.LISPXMACROS NAME TYPE SOURCE OPTIONS NOTFOUND)) (COND ((SETQ DEF (GET TYPE (QUOTE DEFINERS))) (LET ((VAL (LOADFNS NIL SOURCE (QUOTE GETDEF) (BQUOTE (LAMBDA (FIRST SECOND) (AND (MEMB FIRST (QUOTE (\, DEF))) (OR (EQ SECOND NAME) (AND (MEMB SECOND (QUOTE (%( %[))) (PROGN (RATOM) (RATOM) (RATOM) (EQ NAME (RATOM))))))))))) (* ; "ick!  Should use real closure") (if (EQ (CAAR VAL) (QUOTE NOT-FOUND)) then NOTFOUND elseif (CDR VAL) then (CONS (QUOTE PROGN) VAL) else (CAR VAL)))) (T (RESETLST (RESETSAVE (RESETUNDO)) (LET (LOAD-VERBOSE-STREAM) (DECLARE (SPECVARS LOAD-VERBOSE-STREAM)) (* ; "just in case we get a PRETTYCOMPRINT in here") (LOADFNS NIL SOURCE (QUOTE PROP) (COND ((LITATOM NAME) (* ; "If an atom, only bother with expressions that contain it") (CONS (LIST (QUOTE &) (QUOTE |..|) NAME))) (T T)))) (GETDEFCURRENT NAME TYPE (CONS (QUOTE NOERROR) (MKLIST OPTIONS)))))))))) NOTFOUND)) do (AND (EQ SOURCE (QUOTE FILE)) (OR (FMEMB FILE FILELST) (CL:FORMAT T "(from ~A)~%%" SOURCE))) (* ; "Copying and dwimifying are done in GETDEF") (RETURN DEF) finally (RETURN (GETDEFERR NAME TYPE OPTIONS (APPEND (QUOTE (no definition on)) (MKLIST SOURCE))))))
+)
+
+(GETDEFSAVED
+(LAMBDA (NAME TYPE OPTIONS) (* ; "Edited 11-Aug-87 18:14 by cutting") (* ; "Gets the `saved' definition--source=T") (SELECTQ TYPE (FNS (OR (GETPROP NAME (QUOTE EXPR)) (GETDEFERR NAME TYPE OPTIONS "no saved definition for"))) (VARS (* ; "The value of a variable is never substituted into and never COPIED") (for X on (GETPROPLIST NAME) by (CDDR X) when (EQ (CAR X) (QUOTE VALUE)) do (RETURN (CADR X)) finally (RETURN (GETDEFERR NAME TYPE OPTIONS "no saved value for ")))) (OR (CDR (SASSOC NAME (FASSOC TYPE SAVEDDEFS))) (GETDEFERR NAME TYPE OPTIONS "no saved definition for "))))
+)
+
+(PUTDEF
+(LAMBDA (NAME TYPE DEFINITION REASON) (* ; "Edited  8-Apr-87 12:52 by Pavel") (SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE))) (LET ((PUTDEF.METHOD (fetch PUTDEF of TYPE))) (COND (PUTDEF.METHOD (APPLY* PUTDEF.METHOD NAME TYPE DEFINITION REASON)) (T (SELECTQ TYPE (FNS (FNS.PUTDEF NAME TYPE DEFINITION REASON)) (VARS (VARS.PUTDEF NAME TYPE DEFINITION REASON)) (FILES (FILES.PUTDEF NAME TYPE DEFINITION REASON)) (FILEPKGCOMS (FILEPKGCOMS.PUTDEF NAME TYPE DEFINITION REASON)) (EVAL DEFINITION)) NAME))))
+)
+
+(EDITDEF
+(LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS) (DECLARE (LOCALVARS . T) (SPECVARS SOURCE)) (* ; "Edited 27-Jul-87 11:04 by cutting") (* ;; "lets you edit anything.  Given name and type, call editor on the definition (loading it in from SOURCE if necessary).  If you change it, then the definition gets unsaved.  OPTIONS is passed through from ED to the editor.") (SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE))) (COND ((AND (fetch EDITDEF of TYPE) (APPLY* (fetch EDITDEF of TYPE) NAME TYPE SOURCE EDITCOMS OPTIONS))) ((AND (EQ TYPE (QUOTE FNS)) (NULL SOURCE)) (* ; "special hack for EDITDEF of FNS because of ability to EDITLOADFNS") (EDITDEF.FNS NAME EDITCOMS OPTIONS)) (T (DEFAULT.EDITDEF NAME TYPE SOURCE EDITCOMS OPTIONS))) NAME)
+)
+
+(DEFAULT.EDITDEF
+  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)                (* ; "Edited 11-Jun-92 16:26 by cat")
+    (PROG [(DEF (COND
+                   [SOURCE (GETDEF NAME TYPE SOURCE '(EDIT NOCOPY]
+                   [(GETDEF NAME TYPE 'CURRENT '(EDIT NOCOPY NOERROR]
+                   [(GETDEF NAME TYPE 'SAVED '(EDIT NOCOPY NOERROR]
+                   (T (LET ((FILES (WHEREIS NAME TYPE T)))
+                           (CL:IF (NULL FILES)
+                               (CL:FORMAT T "~S has no ~A definition.~%%" NAME TYPE)
+                               [LET [(FILE (PROGN (CL:FORMAT T "~S is contained on~{ ~S~}.~%%" NAME 
+                                                         FILES)
+                                                  (CL:IF (CL:ENDP (CDR FILES))
+                                                      (CL:IF (CL:Y-OR-N-P 
+                                                                    "Shall I load this file PROP? ")
+                                                             (CAR FILES))
+                                                      (ASKUSER NIL NIL 
+                                                             "indicate which file to load PROP: "
+                                                             (MAKEKEYLST FILES)
+                                                             T))]
+                                    (CL:WHEN FILE
+                                        (LOAD FILE 'PROP)
+                                        (GETDEF NAME TYPE '? '(EDIT NOCOPY)))])]
+
+     (* ;; "the EDIT option says to return a COPY if editing this structure isn't enough, and some installation is necessary.")
+
+          (DECLARE (SPECVARS RETRY))
+
+     (* ;; "what is RETRY ???")
+
+          (SETQ RETRY)
+          (CL:WHEN DEF
+              (EDITE DEF EDITCOMS NAME TYPE [FUNCTION (LAMBDA (NAME DEF TYPE EXITFLG)
+                                                             (* ; 
+                                             "this function is called when there were changes made")
+                                                        (FIXEDITDATE DEF)
+                                                             (* ; "fix the edit date first - jtm")
+                                                        (PUTDEF NAME TYPE DEF)
+                                                        (MARKASCHANGED NAME TYPE 'CHANGED)
+
+                                 (* ;; "woz 1/25/91 MARKASCHANGED must be called after PUTDEF, so sedit's markaschangedfn will see the new definition.  doc for PUTDEF says it calls MARKASCHANGED, but it doesn't always, so do it here.  this sometimes results in MARKASCHANGED getting called twice.")
+
+                                                        ]
+                     OPTIONS))])
+
+(EDITDEF.FILES
+(LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS) (* ; "Edited 18-Mar-87 16:07 by woz") (EDITDEF (FILECOMS NAME) (QUOTE VARS) SOURCE EDITCOMS OPTIONS))
+)
+
+(LOADDEF
+(LAMBDA (NAME TYPE SOURCE) (* lmm "13-SEP-78 01:34") (PUTDEF NAME TYPE (GETDEF NAME TYPE SOURCE (QUOTE (NODWIM NOCOPY)))))
+)
+
+(DWIMDEF
+(LAMBDA (DEF FN SOURCE) (* lmm " 6-Jun-86 17:23") (AND (OR (EQ DWIMIFYCOMPFLG T) (EQ CLISPIFYPRETTYFLG T) (EQ (CAR (CADDR DEF)) (QUOTE CLISP%:)) (SELECTQ SOURCE ((CURRENT SAVED FILE ?) NIL) (AND (LITATOM SOURCE) (EQMEMB (QUOTE CLISP) (GETPROP SOURCE (QUOTE FILETYPE)))))) (LET ((NOSPELLFLG T) (DWIMESSGAG T) FILEPKGFLG LISPXHIST) (DECLARE (CL:SPECIAL NOSPELLFLG DWIMESSGAG FILEPKGFLG LISPXHIST)) (DWIMIFY0 DEF (COND ((OR (LISTP FN) (NULL FN)) (QUOTE ?)) (T FN)) NIL DEF))))
+)
+
+(DELDEF
+(LAMBDA (NAME TYPE) (* ; "Edited  5-Dec-86 06:20 by lmm") (PROG (TEM) (SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE))) LP (COND ((SETQ TEM (fetch DELDEF of TYPE)) (APPLY* TEM NAME TYPE)) (T (SELECTQ TYPE (FNS (* ; "special because GETDEF of a FNS is only its EXPR definition, and DELDEF should only remove such") (AND (EXPRP NAME) (/PUTD NAME)) (REMPROP NAME (QUOTE EXPR)) (AND MSDATABASELST (MASTERSCOPE (LIST (QUOTE ERASE) (KWOTE NAME))))) (VARS (/SETTOPVAL NAME (QUOTE NOBIND))) (FILES (for LST in (QUOTE (FILELST NOTCOMPILEDFILES NOTLISTEDFILES)) do (/SETTOPVAL LST (REMOVE NAME (GETTOPVAL LST)))) (/replace FILEPROP of NAME with NIL) (/replace FILECHANGES of NAME with NIL) (/replace FILEDATES of NAME with NIL) (FLUSHFILEMAPS NAME)) (FILEPKGCOMS (DELFROMLIST (QUOTE FILEPKGCOMSPLST) NAME) (DELFROMLIST (QUOTE FILEPKGTYPES) NAME) (for FIELD on (FILEPKGCOM NAME) by (CDDR FIELD) do (FILEPKGCOM NAME (CAR FIELD) NIL)) (for FIELD on (FILEPKGTYPE NAME) by (CDDR FIELD) do (FILEPKGTYPE NAME (CAR FIELD) NIL)) (/replace ALLFIELDS of NAME with NIL)) (ALISTS (AND (LISTP NAME) (DELFROMLIST (CAR NAME) (FASSOC (CADR NAME) (GETTOPVAL (CAR NAME)))))) (MACROS (for P in MACROPROPS do (/REMPROP NAME P))) (PROPS (AND (LISTP NAME) (/REMPROP (CAR NAME) (CADR NAME)))) (LISPXMACROS (DELFROMLIST (QUOTE LISPXMACROS) (FASSOC NAME LISPXMACROS)) (DELFROMLIST (QUOTE LISPXHISTORYMACROS) (FASSOC NAME LISPXHISTORYMACROS)) (DELFROMLIST (QUOTE LISPXCOMS) NAME) (DELFROMLIST (QUOTE HISTORYCOMS) NAME)) (PRIN1 (LIST "Note: deleting" TYPE "not implemented yet") T)))) (MARKASCHANGED NAME TYPE (QUOTE DELETED)) (RETURN NAME)))
+)
+
+(DELFROMLIST
+(LAMBDA (VAR VAL) (* rmk%: " 3-JAN-82 23:22") (AND (FMEMB VAL (GETTOPVAL VAR)) (/SETTOPVAL VAR (SUBSET (GETTOPVAL VAR) (FUNCTION (LAMBDA (X) (AND (NEQ X VAL) (OR (NLISTP X) (NEQ (CDR X) VAL)))))))))
+)
+
+(HASDEF
+(LAMBDA (NAME TYPE SOURCE SPELLFLG) (* ; "Edited 31-Aug-87 18:02 by drc:") (* ;; "is NAME the name of something of type TYPE?  NIL SOURCE means 0, not ?") (DECLARE (SPECVARS TYPE)) (COND ((OR (LISTP TYPE) (LISTP (SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE))))) (* ; "ignore SPELLFLG") (for TY in TYPE do (AND (SETQ $$VAL (HASDEF NAME TY SOURCE)) (RETURN $$VAL)))) (T (PROG ((NODEF (fetch NULLDEF of TYPE)) (OPTS (QUOTE (NODWIM NOCOPY NOERROR HASDEF)))) (COND ((NULL SOURCE) (SETQQ SOURCE CURRENT))) (RETURN (SELECTQ SOURCE ((CURRENT 0) (COND ((OR (MEMBER NAME (fetch CHANGED of TYPE)) (LET ((TM (fetch HASDEF of TYPE))) (COND (TM (APPLY* TM NAME TYPE SOURCE)) ((NOT (LITATOM NAME)) (SELECTQ TYPE (PROPS (AND (LISTP NAME) (GETPROP (CAR NAME) (CADR NAME)))) ((FILES TEMPLATES MACROS LISPXMACROS VARS I.S.OPRS FNS FIELDS USERMACROS FILEVARS FILEPKGCOMS) NIL) (NEQ NODEF (GETDEF NAME TYPE (QUOTE CURRENT) OPTS)))) (T (* ;; "symbol definitions") (SELECTQ TYPE (FILES (LET ((SYMBOL (CL:FIND-SYMBOL (CONCAT NAME "COMS") "INTERLISP"))) (AND SYMBOL (BOUNDP SYMBOL)))) (TEMPLATES (GETTEMPLATE NAME)) (MACROS (GETLIS NAME MACROPROPS)) (LISPXMACROS (OR (FASSOC NAME LISPXMACROS) (FASSOC NAME LISPXHISTORYMACROS))) (VARS (AND (NOT (CL:KEYWORDP NAME)) (NEQ (GETTOPVAL NAME) (QUOTE NOBIND)))) (RECORDS (RECLOOK NAME)) (I.S.OPRS (PROG ((TEM (GETPROP NAME (QUOTE CLISPWORD)))) (RETURN (AND TEM (EQ (CAR TEM) (QUOTE FORWORD)) (GETPROP (CDR TEM) (QUOTE I.S.OPR)))))) (FNS (AND (OR (AND (GETD NAME) (EXPRP (GETD NAME))) (GET NAME (QUOTE EXPR))) (NOT (HASDEF NAME (QUOTE FUNCTIONS) SOURCE)))) (FIELDS (RECORDFIELD? NAME)) (USERMACROS (FASSOC NAME USERMACROS)) (FILEVARS) ((PROPS ALISTS DEFS EXPRESSIONS) NIL) (FILEPKGCOMS (OR (FMEMB NAME FILEPKGCOMSPLST) (FMEMB NAME FILEPKGTYPES))) (NEQ NODEF (GETDEF NAME TYPE (QUOTE CURRENT) OPTS))))))) (OR NAME T)) (SPELLFLG (CL:WHEN (CL:SYMBOLP NAME) (FIXSPELL NAME NIL (SELECTQ TYPE (FILES FILELST) (FILEPKGCOMS (UNION FILEPKGCOMSPLST FILEPKGTYPES)) (FIELDS (for X in USERRECLST join (APPEND (RECORDFIELDNAMES X)))) (RECORDS (for X in USERRECLST when (LITATOM (CADR X)) collect (CADR X))) (LISPXMACROS LISPXCOMS) (I.S.OPRS I.S.OPRLST) (USERMACROS (MAPCAR USERMACROS (FUNCTION CAR))) USERWORDS) NIL (LISTP SPELLFLG) (FUNCTION (LAMBDA (X) (HASDEF X TYPE (QUOTE CURRENT)))) NIL T))))) (? (OR (HASDEF NAME TYPE (QUOTE CURRENT)) (AND (LITATOM NAME) (HASDEF NAME TYPE (QUOTE SAVED) SPELLFLG)) (WHEREIS NAME TYPE T))) ((SAVED T) (NEQ NODEF (GETDEF NAME TYPE (QUOTE SAVED) OPTS))) (NEQ NODEF (GETDEF NAME TYPE SOURCE OPTS))))))))
+)
+
+(GETFILEDEF
+(LAMBDA (FILENAME) (* lmm " 4-Jul-85 13:25") (* ;; "returns the official file name from a file name if NAME is FOO, look for FOO.LSP on FILELST") (COND ((FMEMB FILENAME FILELST) FILENAME) (T (for FILE in FILELST when (STRPOS FILENAME FILE 1 NIL T) do (COND ((EQ (FILENAMEFIELD FILE (QUOTE NAME)) FILENAME) (RETURN FILE)))))))
+)
+
+(SAVEDEF
+(LAMBDA (NAME TYPE DEFINITION) (* JonL "24-Jul-84 20:11") (COND ((AND (LISTP NAME) (NULL TYPE)) (MAPCAR NAME (FUNCTION (LAMBDA (I) (SAVEDEF I (QUOTE FNS)))))) (T (SELECTQ (SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE))) (FNS (AND (OR DEFINITION (SETQ DEFINITION (GETD NAME))) (/PUT NAME (SETQ TYPE (COND ((SUBRP DEFINITION) (QUOTE SUBR)) ((EXPRP DEFINITION) (QUOTE EXPR)) ((CCODEP DEFINITION) (QUOTE CODE)) (T (QUOTE LIST)))) DEFINITION))) (VARS (AND (NEQ (OR DEFINITION (SETQ DEFINITION (GETTOPVAL NAME))) (QUOTE NOBIND)) (EQ DEFINITION (GETTOPVAL NAME)) (/PUT NAME (SETQ TYPE (QUOTE VALUE)) DEFINITION))) (AND (OR DEFINITION (SETQ DEFINITION (GETDEF NAME TYPE (QUOTE CURRENT) (QUOTE (NOCOPY NOERROR NODWIM))))) (/PUTASSOC NAME DEFINITION (OR (CDR (FASSOC TYPE SAVEDDEFS)) (CAR (SETQ SAVEDDEFS (CONS (LIST TYPE (CONS NAME)) SAVEDDEFS))))))) TYPE)))
+)
+
+(UNSAVEDEF
+(LAMBDA (NAME TYPE DEF) (* lmm " 6-Jun-86 17:24") (SELECTQ TYPE ((NIL EXPR CODE SUBR LIST) (COND ((LISTP NAME) (* ; "for compatibility") (MAPCAR NAME (FUNCTION (LAMBDA (X) (UNSAVED1 X TYPE))))) (T (UNSAVED1 NAME TYPE)))) (PROG NIL (OR DEF (SETQ DEF (GETDEF NAME (SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE))) (QUOTE SAVED) 0)) (RETURN (CONS TYPE (QUOTE (not found))))) (COND ((NEQ DFNFLG T) (SAVEDEF NAME TYPE) (LET ((DFNFLG T)) (PUTDEF NAME TYPE DEF))) (T (PUTDEF NAME TYPE DEF))) (RETURN TYPE))))
+)
+
+(COMPAREDEFS
+(LAMBDA (NAME TYPE SOURCES) (* lmm " 4-Jul-85 14:37") (COND ((AND (LISTP TYPE) (GETFILEPKGTYPE SOURCES NIL T)) (swap TYPE SOURCES))) (SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE))) (PROG (DEF DEFS (SRCS (OR SOURCES (WHEREIS NAME TYPE T)))) (COND ((NULL SOURCES) (AND (OR (MEMBER NAME (FILEPKGCHANGES TYPE)) (SOME SRCS (FUNCTION (LAMBDA (FILE) (MEMBER NAME (CDR (ASSOC TYPE (fetch TOBEDUMPED of (fetch FILEPROP of FILE))))))))) (push SRCS (QUOTE CURRENT))))) (SETQ SRCS (for SRC in SRCS when (COND ((NEQ (SETQ DEF (GETDEF NAME TYPE SRC (QUOTE (NOERROR NOCOPY)))) (fetch NULLDEF of TYPE)) (OR (SOME DEFS (FUNCTION (LAMBDA (DP) (COMPARELST DEF (CDR DP))))) (push DEFS (CONS SRC DEF))) T) (T (PRINTOUT T "No " SRC " definition found for " NAME T) NIL)) collect SRC)) (RETURN (COND ((NULL SRCS) (QUOTE (no definitions found))) ((NULL (CDR SRCS)) (QUOTE (only one definition found))) ((CDR DEFS) (for S1 on (DREVERSE DEFS) do (for S2 on (CDR S1) do (PRIN2 NAME T T) (AND (CAAR S1) (PRIN1 " from " T) (PRIN2 (CAAR S1) T T)) (PRIN1 " and " T) (PRIN2 NAME T T) (COND ((CAAR S2) (PRIN1 " from " T) (PRIN2 (CAAR S2) T T))) (PRIN1 " differ:" T) (TERPRI T) (COMPARELISTS (CDAR S1) (CDAR S2)))) (QUOTE DIFFERENT)) (T (QUOTE SAME))))))
+)
+
+(COMPARE
+(LAMBDA (NAME1 NAME2 TYPE SOURCE1 SOURCE2) (* lmm " 5-SEP-78 13:37") (PROG ((DEF1 (GETDEF NAME1 TYPE SOURCE1 (QUOTE (NOERROR NOCOPY)))) (DEF2 (GETDEF NAME2 TYPE SOURCE2 (QUOTE (NOERROR NOCOPY))))) (COND ((COMPARELST DEF1 DEF2) (RETURN))) (PRIN2 NAME1 T T) (COND (SOURCE1 (PRIN1 " from " T) (PRIN2 SOURCE1 T T))) (PRIN1 " and " T) (PRIN2 NAME2 T T) (COND (SOURCE2 (PRIN1 " from " T) (PRIN2 SOURCE2 T T))) (PRIN1 " differ:" T) (TERPRI T) (COMPARELISTS DEF1 DEF2) (RETURN T)))
+)
+
+(TYPESOF
+  [LAMBDA (NAME POSSIBLETYPES IMPOSSIBLETYPES SOURCE FILTER)
+                                                          (* ; "Edited  2-Aug-88 02:08 by masinter")
+
+    (* ;; "return list of all known types which NAME names")
+
+    (LET
+     (FOUND SHADOWED)
+     (if (FMEMB SOURCE '(? NIL))
+         then (CL:FLET [(RSHADOW NIL (for X in FOUND
+                                            do (for Y in (CDR (FASSOC X SHADOW-TYPES))
+                                                      do (if (FMEMB Y FOUND)
+                                                                 then 
+                                                             (* ; "shadower found before shadowed")
+                                                                       (SETQ FOUND (REMOVE Y FOUND]
+                         (LET (NOTFOUND NEWTYPES)
+                              (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
+                                 when [AND (LITATOM TYPE)
+                                               (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
+                                               (OR (NULL FILTER)
+                                                   (CL:FUNCALL FILTER TYPE))
+                                               (NOT (find X in FOUND
+                                                       suchthat (FMEMB TYPE
+                                                                           (CDR (FASSOC X 
+                                                                                       SHADOW-TYPES]
+                                 do (if [OR (HASDEF NAME TYPE 'CURRENT)
+                                                    (AND (LITATOM NAME)
+                                                         (HASDEF NAME TYPE 'SAVED]
+                                            then (push FOUND TYPE)
+                                          else (push NOTFOUND TYPE)))
+                              (RSHADOW)
+                              [for FILE in FILELST while NOTFOUND
+                                 when [NEQ T (fetch LOADTYPE of (GETPROP FILE
+                                                                                   'FILE]
+                                 do (if (SETQ NEWTYPES (INFILECOMS? NAME NOTFOUND
+                                                                      (FILECOMS FILE)
+                                                                      'TYPESOF))
+                                            then [bind X for TYPE in NEWTYPES
+                                                        when (FMEMB TYPE NOTFOUND)
+                                                        do (push FOUND TYPE)
+                                                              (if (SETQ X (FASSOC TYPE 
+                                                                                     SHADOW-TYPES))
+                                                                  then (SETQ NOTFOUND
+                                                                            (LDIFFERENCE NOTFOUND X))
+                                                                else (SETQ NOTFOUND
+                                                                          (REMOVE TYPE NOTFOUND]
+                                                  (SETQ NOTFOUND (LDIFFERENCE NOTFOUND NEWTYPES]
+                              (if (AND NOTFOUND (GETD 'XCL::HASH-FILE-TYPES-OF))
+                                  then (SETQ NEWTYPES (XCL::HASH-FILE-TYPES-OF NAME NOTFOUND))
+                                        (SETQ FOUND (UNION NEWTYPES FOUND)))
+                              (RSHADOW)
+                              FOUND))
+       else (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
+                   when (AND (LITATOM TYPE)
+                                 (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
+                                 (OR (NULL FILTER)
+                                     (CL:FUNCALL FILTER TYPE))
+                                 (HASDEF NAME TYPE SOURCE)) do (push FOUND TYPE)))
+     FOUND])
+)
+
+(RPAQ? WHEREIS.HASH )
+
+
+
+(* ; "Must come after PUTDEF")
+
+(DEFINEQ
+
+(FIXEDITDATE
+  [LAMBDA (EXPR)                                             (* ; "Edited 17-Jul-89 11:13 by jtm:")
+                                                             (* NOBIND "18-JUL-78 21:11")
+                                                             (* Inserts or replaces previous edit 
+                                                           date)
+    (AND INITIALS (LISTP EXPR)
+         (LISTP (CDR EXPR))
+         (PROG (E)
+               (COND
+                  ((FMEMB (CAR EXPR)
+                          LAMBDASPLST)
+
+                   (* ;; "insert the edit date after the argument list")
+
+                   (SETQ E (CDDR EXPR)))
+                  [(FMEMB (GETPROP (CAR EXPR)
+                                 ':DEFINER-FOR)
+                          EDITDATE-ARGLIST-DEFINERS)
+
+                   (* ;; "insert the edit date after the argument list")
+
+                   (SETQ E (CDDR EXPR))
+                   (while (NOT (CL:LISTP (CAR E))) do (SETQ E (CDR E))
+                      finally (SETQ E (CDR E]
+                  ((FMEMB (GETPROP (CAR EXPR)
+                                 ':DEFINER-FOR)
+                          EDITDATE-NAME-DEFINERS)
+
+                   (* ;; "insert the edit date after the name")
+
+                   (SETQ E (CDDR EXPR)))
+                  (T (RETURN)))
+           RETRY
+               [COND
+                  ((NLISTP E)
+                   (RETURN))
+                  ((LISTP (CAR E))
+                   (SELECTQ (CAAR E)
+                       ((CLISP%: DECLARE) 
+                            (SETQ E (CDR E))
+                            (GO RETRY))
+                       (BREAK1 (COND
+                                  ((EQ (CAR (CADAR E))
+                                       'PROGN)
+                                   (SETQ E (CDR (CADAR E)))
+                                   (GO RETRY))))
+                       (ADV-PROG                             (* No easy way to mark cleanly the 
+                                                           date of an advised function)
+                                 (RETURN))
+                       (COND
+                          ((AND (EQ (CAAR E)
+                                    COMMENTFLG)
+                                (EQ (CADAR E)
+                                    'DECLARATIONS%:))
+                           (SETQ E (CDR E))
+                           (GO RETRY]
+               (COND
+                  ([for TAIL on E while (AND (LISTP (CAR TAIL))
+                                                         (EQ (CAAR TAIL)
+                                                             COMMENTFLG))
+                      do (COND
+                                ((AND (LISTP (CDR TAIL))
+                                      (EDITDATE? (CAR TAIL)))
+                                 (/RPLACA TAIL (EDITDATE (CAR TAIL)
+                                                      INITIALS))
+                                 (RETURN T]                  (* scans the comments for a 
+                                                           timestamp for this user.)
+                   NIL)
+                  (T                                         (* attach the new timestamp at the 
+                                                           beginning of the comments.)
+                     (/ATTACH (EDITDATE NIL INITIALS)
+                            E)))
+               (RETURN EXPR])
+
+(EDITDATE?
+  [LAMBDA (COMMENT)                                          (* ; "Edited 11-Jun-92 16:44 by cat")
+                                                             (* ; "Edited 13-Jul-89 09:30 by jtm:")
+                                                             (* lmm "21-Mar-85 08:45")
+
+         (* Tests to see if a given common is in fact an edit date --
+       this has to be general enough to recognize the most comment comment forms while 
+       specific enough to not recognize things that are not edit dates)
+
+    (DECLARE (LOCALVARS . T))                            (* jtm%: changed test so that it 
+                                                           creates one timestamp per user.)
+    (COND
+       [(LISTP COMMENT)
+        (COND
+           ((EQ (CAR COMMENT)
+                COMMENTFLG)
+            [COND
+               (NIL (NULL NORMALCOMMENTSFLG)
+                      (SETQ COMMENT (GETCOMMENT COMMENT]
+            (COND
+               ([OR (NOT (LISTP (CDR COMMENT)))
+                    (NOT (LISTP (CDDR COMMENT]
+                NIL)
+               [(EQ (CADR COMMENT)
+                    ';)                                      (* ; "CL style comment")
+                (STRPOS INITIALS (CADDR COMMENT)
+                       (IMINUS (NCHARS INITIALS]
+               (T                                            (* ; "IL style comment")
+                  (EQ (CADR COMMENT)
+                      INITIALS]
+       ((STRINGP COMMENT])
+)
+
+
+
+(* ; "Edit date support for all kinds of definers (from PARC 6/10/92)")
+
+
+(RPAQQ EDITDATE-ARGLIST-DEFINERS (FUNCTIONS TYPES))
+
+(RPAQQ EDITDATE-NAME-DEFINERS (STRUCTURES VARIABLES))
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
+)
+
+
+
+(* ;; 
+"how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started."
+)
+
+(DEFINEQ
+
+(FILEPKGCOM
+(LAMBDA N (* JonL "10-Jul-84 19:38") (PROG (TEM (COM (ARG N 1))) (RETURN (COND ((EQ N 1) (OR (for FIELD in (QUOTE (MACRO CONTENTS DELETE ADD)) when (SETQ TEM (FILEPKGCOM COM FIELD)) join (LIST FIELD TEM)) (AND (FMEMB COM (GETTOPVAL (QUOTE FILEPKGCOMSPLST))) (LIST (QUOTE COM) T)) (AND (SETQ TEM (CDR (ASSOC COM (GETTOPVAL (QUOTE FILEPKGCOMSPLST))))) (LIST (QUOTE COM) TEM)))) ((EQ N 2) (SELECTQ (ARG N 2) (ADD (fetch ADD of COM)) (DELETE (fetch DELETE of COM)) (MACRO (fetch MACRO of COM)) ((CONTENTS CONTAIN) (OR (fetch (FILEPKGCOM CONTENTS) of COM) (COND ((SETQ COM (fetch (FILEPKGCOM PRETTYTYPE) of COM)) (COND ((EQ COM (QUOTE NILL)) COM) ((EQ (CAR COM) (QUOTE LAMBDA)) (CONS (CAR COM) (CONS (CONS (CAADR COM) (CONS (OR (CADDR (CADR COM)) (QUOTE NAME)) (CONS (CADR (CADR COM)) (CDDDR (CADR COM))))) (SUBST (QUOTE INFILECOMTAIL) (QUOTE PRETTYCOM1) (CDDR COM))))) (T (LIST (QUOTE LAMBDA) (QUOTE (COM TYPE NAME)) (CONS COM (QUOTE (COM TYPE NAME)))))))))) (COM (OR (AND (FMEMB COM (GETTOPVAL (QUOTE FILEPKGCOMSPLST))) T) (CDR (ASSOC COM (GETTOPVAL (QUOTE FILEPKGCOMSPLST)))))) (ERROR (ARG N 2) "not file package command property"))) (T (for I TEM2 from 2 to N by 2 do (SETQ TEM (ARG N (ADD1 I))) (COND ((EQ (ARG N I) (QUOTE COM)) (SELECTQ TEM (NIL) (T (OR (FMEMB COM (GETTOPVAL (QUOTE FILEPKGCOMSPLST))) (/SETTOPVAL (QUOTE FILEPKGCOMSPLST) (CONS COM (GETTOPVAL (QUOTE FILEPKGCOMSPLST)))))) (COND ((SETQ TEM2 (ASSOC COM (GETTOPVAL (QUOTE FILEPKGCOMSPLST)))) (/RPLACD TEM2 TEM)) (T (/SETTOPVAL (QUOTE FILEPKGCOMSPLST) (CONS (CONS COM TEM) (GETTOPVAL (QUOTE FILEPKGCOMSPLST)))))))) (T (AND TEM (OR (FMEMB COM (GETTOPVAL (QUOTE FILEPKGCOMSPLST))) (/SETTOPVAL (QUOTE FILEPKGCOMSPLST) (CONS COM (GETTOPVAL (QUOTE FILEPKGCOMSPLST)))))) (SELECTQ (ARG N I) (ADD (/replace (FILEPKGCOM ADD) of COM with TEM)) (DELETE (/replace (FILEPKGCOM DELETE) of COM with TEM)) (MACRO (/replace (FILEPKGCOM MACRO) of COM with TEM)) ((CONTENTS CONTAIN) (/replace (FILEPKGCOM CONTENTS) of COM with TEM)) (ERROR (ARG N I) "not file package command property"))))) (MARKASCHANGED COM (QUOTE FILEPKGCOMS)))))))
+)
+
+(FILEPKGTYPE
+(LAMBDA N (* lmm " 5-Jul-85 09:07") (PROG ((TYPE (ARG N 1)) TEM) (RETURN (COND ((EQ N 1) (OR (for FIELD in (UNION (QUOTE (DESCRIPTION)) FILEPKGTYPEPROPS) when (SETQ TEM (FILEPKGTYPE TYPE FIELD)) join (LIST FIELD TEM)) (AND (FMEMB TYPE (GETTOPVAL (QUOTE FILEPKGTYPES))) (LIST (QUOTE TYPE) T)) (AND (SETQ TEM (CDR (ASSOC TYPE (GETTOPVAL (QUOTE FILEPKGTYPES))))) (LIST (QUOTE TYPE) TEM)))) ((EQ N 2) (if (FMEMB (ARG N 2) FILEPKGTYPEPROPS) then (GETPROP TYPE (ARG N 2)) else (SELECTQ (ARG N 2) (DESCRIPTION (fetch DESCRIPTION of TYPE)) (TYPE (OR (AND (FMEMB TYPE (GETTOPVAL (QUOTE FILEPKGTYPES))) T) (CDR (ASSOC TYPE (GETTOPVAL (QUOTE FILEPKGTYPES)))))) (ERROR (ARG N 2) "not file package type property")))) (T (for I TEM2 from 2 to N by 2 do (SETQ TEM (ARG N (ADD1 I))) (COND ((EQ (ARG N I) (QUOTE TYPE)) (SELECTQ TEM (NIL) (T (OR (FMEMB TYPE FILEPKGTYPES) (/SETTOPVAL (QUOTE FILEPKGTYPES) (CONS TYPE FILEPKGTYPES)))) (COND ((SETQ TEM2 (ASSOC TYPE FILEPKGTYPES)) (/RPLACD TEM2 TEM)) (T (/SETTOPVAL (QUOTE FILEPKGTYPES) (CONS (CONS TYPE TEM) FILEPKGTYPES)))))) (T (AND TEM (OR (FMEMB TYPE FILEPKGTYPES) (/SETTOPVAL (QUOTE FILEPKGTYPES) (CONS TYPE FILEPKGTYPES)))) (if (FMEMB (ARG N I) FILEPKGTYPEPROPS) then (if TEM then (/PUTPROP TYPE (ARG N I) TEM) else (/REMPROP TYPE (ARG N I))) else (SELECTQ (ARG N I) (DESCRIPTION (/replace DESCRIPTION of TYPE with TEM)) (ERROR (ARG N I) "not file package command/type property")))))) (MARKASCHANGED TYPE (QUOTE FILEPKGCOMS)))))))
+)
+)
+
+(PUTPROPS FILEPKGCOM ARGNAMES (COMMANDNAME (KEYWORDS%: MACRO ADD DELETE CONTENTS)))
+
+(ADDTOVAR FILEPKGCOMSPLST FILEPKGCOMS)
+
+(ADDTOVAR FILEPKGTYPES FILEPKGCOMS)
+(PUTDEF (QUOTE FILEPKGCOMS) (QUOTE FILEPKGCOMS) '([COM CONTENTS (LAMBDA (COM NAME TYPE)
+                                                                       (* Revert to NILL when no 
+                                                                          longer coercing 
+                                                                          PRETTYDEFMACROS to 
+                                                                          FILEPKGCOMS)
+                                                                       (AND (EQ TYPE 'FILEPKGCOMS)
+                                                                            (INFILECOMTAIL COM]
+                                                  (TYPE DESCRIPTION "file package commands/types" 
+                                                        GETDEF T PUTDEF FILEPKGCOMS.PUTDEF)))
+(PUTDEF (QUOTE ALISTS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEALISTCOMS . X]
+                                             (TYPE DESCRIPTION "alist entries" GETDEF ALISTS.GETDEF 
+                                                   WHENCHANGED (ALISTS.WHENCHANGED))))
+(PUTDEF (QUOTE DEFS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (COMS . X])
+(PUTDEF (QUOTE EDITMACROS) (QUOTE FILEPKGCOMS) '((TYPE TYPE USERMACROS)))
+(PUTDEF (QUOTE EXPRESSIONS) (QUOTE FILEPKGCOMS) '((TYPE DESCRIPTION "expressions" WHENCHANGED (
+                                                                              EXPRESSIONS.WHENCHANGED
+                                                                                               )
+                                                        EDITDEF NILL)))
+(PUTDEF (QUOTE FIELDS) (QUOTE FILEPKGCOMS) '((TYPE EDITDEF NILL)))
+(PUTDEF (QUOTE FILEPKGTYPES) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)
+                                                   (TYPE TYPE FILEPKGCOMS)))
+(PUTDEF (QUOTE FILES) (QUOTE FILEPKGCOMS) '([COM MACRO [X (P * (CONS (MAKEFILESCOMS . X]
+                                                 CONTENTS
+                                                 (LAMBDA (COM NAME TYPE)
+                                                        (AND (EQ TYPE 'FILES)
+                                                             (SUBSET (INFILECOMTAIL COM)
+                                                                    (FUNCTION LITATOM]
+                                            (TYPE PUTDEF FILES.PUTDEF WHENCHANGED (FILES.WHENCHANGED)
+                                                  EDITDEF EDITDEF.FILES)))
+(PUTDEF (QUOTE FILEVARS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (VARS . X)))
+                                               (TYPE NULLDEF NOBIND EDITDEF NILL)))
+(PUTDEF (QUOTE FNS) (QUOTE FILEPKGCOMS) '((COM MACRO
+                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
+                                                                         (FN)
+                                                                         (AND (GETPROP FN
+                                                                                     'FUNCTIONS)
+                                                                              (CL:WARN 
+                                                                      "~A has a FUNCTIONS definition"
+                                                                                     FN]
+                                                  (ORIGINAL (FNS . X)))
+                                               CONTENTS NILL)
+                                          (TYPE DESCRIPTION "functions" PUTDEF FNS.PUTDEF CANFILEDEF
+                                                T)))
+(PUTDEF (QUOTE INITRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (P * (RECORDALLOCATIONS . X)))
+                                                       CONTENTS
+                                                       (LAMBDA (COM NAME TYPE ONFILETYPE)
+                                                              (AND (NULL ONFILETYPE)
+                                                                   (EQ TYPE 'RECORDS)
+                                                                   (INFILECOMTAIL COM])
+(PUTDEF (QUOTE INITVARS) (QUOTE FILEPKGCOMS) '((COM COM T)))
+(PUTDEF (QUOTE LISPXCOMS) (QUOTE FILEPKGCOMS) '((TYPE TYPE LISPXMACROS)))
+(PUTDEF (QUOTE LISPXMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKELISPXMACROSCOMS . X)))
+                                                       CONTENTS NILL)
+                                                  (TYPE DESCRIPTION "LISPX commands")))
+(PUTDEF (QUOTE MACROS) (QUOTE FILEPKGCOMS) '((COM
+                                              MACRO
+                                              [X
+                                               (DECLARE%:
+                                                EVAL@COMPILE
+                                                (P
+                                                 *
+                                                 (MAPCAR
+                                                  'X
+                                                  (FUNCTION
+                                                   (LAMBDA (Y)
+                                                          (LET [[FNDEF (GETDEF Y 'FUNCTIONS
+                                                                              'CURRENT
+                                                                              '(NOCOPY NOERROR]
+                                                                (MACDEF (GETDEF Y 'MACROS
+                                                                               'CURRENT
+                                                                               '(NOCOPY NOERROR]
+                                                               (COND
+                                                                ((AND FNDEF (EQ (CAR FNDEF)
+                                                                                'DEFMACRO))
+                                                                 (CL:WARN 
+                           "Need to change MACROS to FUNCTIONS for writing out Common Lisp macro ~S."
+                                                                        FNDEF)
+                                                                 (LIST 'PROGN FNDEF MACDEF))
+                                                                (T (OR MACDEF (CL:CERROR 
+                                                          "Go ahead and finish writing out the file."
+                                                                                     
+                                                                       "No MACROS definition for ~A."
+                                                                                     Y)
+                                                                       (GETDEF Y 'MACROS 'CURRENT]
+                                              CONTENTS NILL)
+                                             (TYPE DESCRIPTION "Interlisp macros" GETDEF 
+                                                   MACROS.GETDEF WHENCHANGED (CLEARCLISPARRAY))))
+(PUTDEF (QUOTE PRETTYDEFMACROS) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)))
+(PUTDEF (QUOTE PROPS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEPROPSCOMS . X]
+                                            (TYPE DESCRIPTION "property lists" WHENCHANGED (
+                                                                                    PROPS.WHENCHANGED
+                                                                                            ))))
+(PUTDEF (QUOTE RECORDS) (QUOTE FILEPKGCOMS) '[[COM
+                                               MACRO
+                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
+                                                                         (RECORD)
+                                                                         (AND (GETPROP RECORD
+                                                                                     'STRUCTURES)
+                                                                              (CL:WARN 
+                                                                     "~A has a STRUCTURES definition"
+                                                                                     RECORD]
+                                                  (E (RECORDECLARATIONS . X))
+                                                  (INITRECORDS . X))
+                                               CONTENTS
+                                               (LAMBDA (COM NAME TYPE ONFILETYPE)
+                                                      (AND (EQ TYPE 'FIELDS)
+                                                           (NULL ONFILETYPE)
+                                                           (MAPCONC (INFILECOMTAIL COM)
+                                                                  (FUNCTION (LAMBDA
+                                                                             (X)
+                                                                             (APPEND (
+                                                                                     RECORDFIELDNAMES
+                                                                                      X]
+                                              (TYPE DESCRIPTION "records" DELDEF
+                                                    (LAMBDA (X)
+                                                           (/SETTOPVAL 'USERRECLST
+                                                                  (REMOVE (RECLOOK X)
+                                                                         USERRECLST])
+(PUTDEF (QUOTE OLDRECORDS) (QUOTE FILEPKGCOMS) '((COM COM T)))
+(PUTDEF (QUOTE SYSRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (SAVEONSYSRECLST . X)))
+                                                      CONTENTS
+                                                      (LAMBDA (COM NAME TYPE ONFILETYPE)
+                                                             (AND (NULL ONFILETYPE)
+                                                                  (EQ TYPE 'RECORDS)
+                                                                  (INFILECOMTAIL COM])
+(PUTDEF (QUOTE USERMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKEUSERMACROSCOMS . X)))
+                                                      CONTENTS NILL)
+                                                 (TYPE DESCRIPTION "edit macros")))
+(PUTDEF (QUOTE VARS) (QUOTE FILEPKGCOMS) '((COM MACRO
+                                                (X [E (MAPC 'X (FUNCTION (LAMBDA
+                                                                          (VAR)
+                                                                          (AND (GETPROP VAR
+                                                                                      'VARIABLES)
+                                                                               (CL:WARN 
+                                                                 "~A also has a VARIABLES definition"
+                                                                                      VAR]
+                                                   (ORIGINAL (VARS . X)))
+                                                CONTENTS NILL)
+                                           (TYPE DESCRIPTION "variables" NULLDEF NOBIND PUTDEF 
+                                                 VARS.PUTDEF)))
+(PUTDEF (QUOTE *) (QUOTE FILEPKGCOMS) '((COM CONTENTS NILL)))
+(PUTDEF (QUOTE CONSTANTS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (DECLARE%: EVAL@COMPILE (VARS . X)
+                                                                     (P (CONSTANTS . X])
+
+(ADDTOVAR SHADOW-TYPES (FUNCTIONS FNS)
+                           (VARIABLES VARS CONSTANTS))
+
+(RPAQ? SAVEDDEFS )
+
+
+
+(* ; "EDITCALLERS")
+
+(DEFINEQ
+
+(FINDCALLERS
+(LAMBDA (ATOMS FILES) (* lmm "30-SEP-78 01:36") (PROG ((X (EDITCALLERS ATOMS FILES T))) (RETURN (NCONC (DREVERSE (CDR X)) (AND (CAR X) (LIST (CONS (COND ((CDR X) (QUOTE "plus other places on")) (T (QUOTE on))) (CAR X))))))))
+)
+
+(EDITCALLERS
+(LAMBDA (ATOMS FILES COMS) (* bvm%: " 3-Nov-86 17:30") (LET (FFILEPOSPATTERNS FNS OTHERSFILES EDITPATTERN) (SETQ EDITPATTERN (EDITFPAT (CONS (QUOTE *ANY*) (SETQ ATOMS (MKLIST ATOMS))))) (for FILE in (COND ((NULL FILES) FILELST) ((EQ FILES T) (UNION SYSFILES FILELST)) ((LISTP FILES) FILES) (T (LIST FILES))) do (RESETLST (PROG (PATTERNS CA RDTBL MAP NOMAPFLG FULL FILESTREAM PRINTFLG ENV DUMMY TOP I) (OR (SETQ FULL (FINDFILE FILE)) (RETURN (LISPXPRINT (CONS FILE (QUOTE (not found))) T T))) (RESETSAVE NIL (LIST (QUOTE CLOSEF) (SETQ FILESTREAM (OPENSTREAM FULL (QUOTE INPUT))))) (CL:FORMAT T "~A: " (SETQ FULL (FULLNAME FILESTREAM))) (CL:MULTIPLE-VALUE-SETQ (ENV MAP TOP) (OR (GET-ENVIRONMENT-AND-FILEMAP FULL) (\PARSE-FILE-HEADER FILESTREAM))) (* ;; "Get reader environment of file.  The call to GET-ENVIRONMENT-AND-FILEMAP with the filename will get cached info if it exists.  Otherwise, read the top of the file") (SETQ RDTBL (AND ENV (fetch (READER-ENVIRONMENT REREADTABLE) of ENV))) (SETQ CA (SEPRCASE DWIMIFYCOMPFLG RDTBL)) (OR (SETQ PATTERNS (CDR (ASSOC RDTBL FFILEPOSPATTERNS))) (push FFILEPOSPATTERNS (CONS RDTBL (SETQ PATTERNS (for ATOM in ATOMS collect (CONCAT (COND ((EQ (CHCON1 ATOM) (CHARCODE ESCAPE)) (SETQ ATOM (SUBSTRING ATOM 2 -1)) "") (T " ")) (COND ((SETQ I (STRPOS (QUOTE ) ATOM)) (SUBSTRING ATOM 1 (SUB1 I))) (T (LET ((*PACKAGE* (CL:SYMBOL-PACKAGE ATOM))) (* ; "Keep MKSTRING from putting a prefix on") (MKSTRING ATOM T RDTBL)))) (COND (I "") (T " ")))))))) (for PATTERN in PATTERNS do (SETFILEPTR FILESTREAM (SETQ I (OR TOP 0))) (while (SETQ I (FFILEPOS PATTERN FILESTREAM I NIL NIL T CA)) do (COND ((NULL PRINTFLG) (* ; "cause the printing of the filename to be saved on history list") (SETQ PRINTFLG T) (LISPXPRIN2 FULL T T T) (* ;; "print with NODOFLG=T means just to record the printing;  the idea is that only those files in which something is found will be remembered on the history list") (LISPXPRIN1 ": " T NIL T))) (OR (AND (NEQ MAP T) (for X in (CDR (OR MAP (PROGN (SETFILEPTR FILESTREAM 0) (SETQ MAP (OR (GETFILEMAP FILESTREAM) (LOADFILEMAP FILESTREAM)))) (PROGN (* ; "file has no filemap") (SETQ MAP (SETQ NOMAPFLG T)) (LISPXPRIN1 " no filemap!" T) NIL))) thereis (AND (ILESSP (CAR X) I) (IGREATERP (CADR X) I) (for Z in (CDDR X) thereis (COND ((AND (ILESSP (CADR Z) I) (IGREATERP (CDDR Z) I)) (COND ((NOT (FMEMB (CAR Z) FNS)) (SETQ FNS (CONS (LISPXPRIN2 (CAR Z) T T) FNS)))) (SETQ I (CDDR Z)) T)))))) (PROGN (LISPXPRIN2 I T T) (OR (FMEMB FILE OTHERSFILES) (SETQ OTHERSFILES (CONS FILE OTHERSFILES))))) (LISPXSPACES 1 T))) (COND (PRINTFLG (LISPXTERPRI T)) (T (TERPRI T))) (COND ((NEQ COMS T) (COND ((OR FNS OTHERSFILES) (EDITFROMFILE (OR NOMAPFLG (DREVERSE FNS)) FULL EDITPATTERN COMS (NULL OTHERSFILES)) (SETQ OTHERSFILES) (SETQ FNS)))))))) (COND ((EQ COMS T) (CONS OTHERSFILES FNS)))))
+)
+
+(EDITFROMFILE
+(LAMBDA (FNS FILES EDITPATTERN EDITCOMS ONLYTYPES) (* rmk%: "14-Mar-85 21:51") (RESETVARS ((EDITLOADFNSFLG (COND ((EQ EDITLOADFNSFLG T) (QUOTE (T . NO))) (T EDITLOADFNSFLG)))) (PROG NIL (OR EDITCOMS (SETQ EDITCOMS (LIST (LIST (QUOTE EXAM) EDITPATTERN)))) (AND (SETQ FILES (for FILE inside (OR FILES FILELST) when (OR (AND EDITLOADFNSFLG (FMEMB (ROOTFILENAME FILE) FILELST)) (COND ((EQ (QUOTE Y) (ASKUSER DWIMWAIT (QUOTE Y) (LIST "load from" FILE) NIL T)) (LOADFROM FILE FNS (QUOTE ALLPROP)) T))) collect FILE)) (for TYPE in (COND ((LISTP ONLYTYPES)) (ONLYTYPES (QUOTE (FNS))) (T (* ;; "Move FNS to the front.  This means that all the fns will be dwimified and edited before anything else (like a rename of fields) is done.") (CONS (QUOTE FNS) (REMOVE (QUOTE FNS) FILEPKGTYPES)))) when (AND (LITATOM TYPE) (NEQ (fetch EDITDEF of TYPE) (QUOTE NILL))) do (PROG (SEEN) (for FILE inside FILES do (for NAME in (COND ((AND (EQ TYPE (QUOTE FNS)) (NEQ FNS T)) (* ; "for this type, we are given the list of items") (PROG1 FNS (SETQ FNS NIL))) (T (* ; "only want the values of `TYPE' which are not part of some other type") (FILECOMSLST FILE TYPE (QUOTE EDIT)))) unless (MEMBER NAME SEEN) do (ERSETQ (PROG ((DEF (OR (GETDEF NAME TYPE (QUOTE CURRENT) (QUOTE (NOCOPY NOERROR))) (GETDEF NAME TYPE (QUOTE SAVED) (QUOTE (NOCOPY NOERROR)))))) (* ;; "If definition has been loaded, it may have been editted.  Work on that explicitly instead of bringing in a file definition to smash the users previous changes.  Perhaps we should query the user about this, but until the interaction is worked out, it is better to avoid trashing his in core edits, given that he can always get the file definition from permanent storage with LOADFNS.  --- We might also be more discriminating about this: if the user specified a root file name, then he means the definition from the definition group, not the physical file.  But ...  rmk") (COND ((OR (AND (EQ TYPE (QUOTE FNS)) (NEQ FNS T)) (AND (LISTP DEF) (LOOKIN DEF EDITPATTERN))) (COND ((NULL SEEN) (LISPXPRIN1 "editing the " T) (LISPXPRIN1 (OR (fetch DESCRIPTION of TYPE) TYPE) T) (LISPXSPACES 1 T))) (SETQ SEEN (CONS NAME SEEN)) (LISPXPRIN2 NAME T T) (LISPXPRIN1 ":
+" T) (COND ((NOT (ERSETQ (EDITDEF NAME TYPE (OR (AND DEF (CONS (QUOTE =) DEF)) FILE) EDITCOMS))) (LISPXPRIN1 "failed" T))) (LISPXTERPRI T)))))))))))))
+)
+
+(FINDATS
+(LAMBDA (X L) (* lmm "11-FEB-78 16:03") (COND ((NLISTP X) (FMEMB X L)) (T (OR (FINDATS (CAR X) L) (FINDATS (CDR X) L)))))
+)
+
+(LOOKIN
+(LAMBDA (X PAT) (* lmm "11-MAR-78 14:20") (COND ((AND (EQ (CAR PAT) (QUOTE *ANY*)) (EVERY (CDR PAT) (FUNCTION (LAMBDA (X) (AND (LITATOM X) (NOT (STRPOS (QUOTE ) X))))))) (FINDATS X (CDR PAT))) (T (EDITFINDP X PAT T))))
+)
+)
+(DEFINEQ
+
+(SEPRCASE
+(LAMBDA (CLFLG RDTBL) (* bvm%: "24-Oct-86 18:16") (* ;; "make a case array for FFILEPOS in which all of the seprs, breaks, and (possibly) clisp chars are all equivalent.  Based on FILERDTBL, but others are close with respect to breaks and seprs") (OR RDTBL (SETQ RDTBL FILERDTBL)) (OR (ARRAYP (CDR (ASSOC RDTBL (COND (CLFLG CLISPCASEARRAYS) (T SEPRCASEARRAYS))))) (LET ((CA (CASEARRAY))) (if (READTABLEPROP RDTBL (QUOTE CASEINSENSITIVE)) then (* ; "map upper into lower case") (for I from (CHARCODE A) to (CHARCODE Z) do (SETCASEARRAY CA I (+ I (- (CHARCODE a) (CHARCODE A)))))) (for X in (NCONC (AND CLFLG (for Y in CLISPCHARS collect (CHCON1 Y))) (GETSEPR RDTBL) (GETBRK RDTBL)) do (SETCASEARRAY CA X 0)) (if *PACKAGE* then (* ; "symbols qualified with package prefix will otherwise be unfindable") (SETCASEARRAY CA (READTABLEPROP RDTBL (QUOTE PACKAGECHAR)) 0)) (SETQ CA (CONS RDTBL CA)) (COND (CLFLG (push CLISPCASEARRAYS CA)) (T (push SEPRCASEARRAYS CA))) (CDR CA))))
+)
+)
+
+(RPAQ? DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL))
+
+(RPAQ? SEPRCASEARRAYS )
+
+(RPAQ? CLISPCASEARRAYS )
+
+(MOVD? 'INFILEP 'FINDFILE)
+
+                                                             (* ; "or else from SPELLFILE")
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
+
+(BLOCK%: EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
+       (NOLINKFNS LOADFROM))
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS)
+)
+
+
+
+(* ; "EXPORT")
+
+(DEFINEQ
+
+(IMPORTFILE
+(LAMBDA (FILE RETURNFLG) (* lmm " 6-Jun-86 17:43") (RESETLST (RESETSAVE NIL (LIST (QUOTE CLOSEF) (SETQ FILE (OPENSTREAM FILE (QUOTE INPUT))))) (RESETSAVE (INPUT FILE)) (* ; "Reset INPUT in case some form on the file's action is to read the next expression") (NCONC (COND ((EQ RETURNFLG T) (* ; "Just creating EXPORTS.ALL, don't side-effect the world") (IMPORTFILESCAN FILE RETURNFLG)) (T (LET (FILEPKGFLG DFNFLG) (IMPORTFILESCAN FILE RETURNFLG)))) (IMPORTEVAL (LIST (QUOTE PUTPROP) (KWOTE (ROOTFILENAME FILE)) (QUOTE (QUOTE IMPORTDATE)) (LIST (QUOTE IDATE) (GETFILEINFO FILE (QUOTE CREATIONDATE)))) RETURNFLG))))
+)
+
+(IMPORTEVAL
+(LAMBDA (FORM RETURNFLG) (* ; "Edited  2-May-87 18:57 by Pavel") (* ;; "Ignore DONTEVAL@LOAD'S --- If RETURNFLG is on, return list of forms") (AND (LISTP FORM) (SELECTQ (CAR FORM) (DECLARE%: (FOR Z IN (CDR FORM) JOIN (IMPORTEVAL Z RETURNFLG))) (CL:EVAL-WHEN (FOR Z IN (CDDR FORM) JOIN (IMPORTEVAL Z RETURNFLG))) (/DECLAREDATATYPE (* ; "Ignore datatype initializations -- we only need the record declaration itself") NIL) (PROGN (* ; "default: eval and/or return it") (AND (NEQ RETURNFLG T) (EVAL FORM)) (AND RETURNFLG (LIST FORM))))))
+)
+
+(IMPORTFILESCAN
+(LAMBDA (FILE RETURNFLG) (* bvm%: "24-Oct-86 19:31") (WITH-READER-ENVIRONMENT (GET-ENVIRONMENT-AND-FILEMAP FILE) (while (FFILEPOS BEGINEXPORTDEFSTRING FILE NIL NIL NIL T) bind DEF join (until (EQUAL (SETQ DEF (READ FILE)) ENDEXPORTDEFFORM) join (IMPORTEVAL DEF RETURNFLG)))))
+)
+
+(CHECKIMPORTS
+(LAMBDA (FILES NOASKFLG) (* rmk%: "19-FEB-83 16:31") (* ; "Loads exported definitions from new versions of FILES.") (COND ((AND (SETQ FILES (for FILE inside FILES bind FULLFILENAME DATE when (AND (SETQ FULLFILENAME (FINDFILE FILE T)) (OR (NOT (SETQ DATE (GETPROP (ROOTFILENAME FILE) (QUOTE IMPORTDATE)))) (NOT (IEQP DATE (GETFILEINFO FULLFILENAME (QUOTE ICREATIONDATE)))))) collect (LIST FILE FULLFILENAME))) (OR NOASKFLG (SELECTQ (ASKUSER 5 (QUOTE Y) (LIST "load new exports from " (MAPCAR FILES (FUNCTION CAR))) (QUOTE ((Y "es
+") (N "o
+"))) T) (N NIL) T))) (for FILE in FILES do (IMPORTFILE (CADR FILE)))))))
+
+(GATHEREXPORTS
+(LAMBDA (FROMFILES TOFILE FLG) (* bvm%: "14-Oct-86 23:12") (* ; "Copies all exported definitions from FROMFILES to TOFILE.") (RESETLST (RESETSAVE NIL (LIST (FUNCTION CLOSE-AND-MAYBE-DELETE) (SETQ TOFILE (OPENSTREAM TOFILE (QUOTE OUTPUT))))) (RESETSAVE (OUTPUT TOFILE)) (LET ((ENV *DEFAULT-MAKEFILE-ENVIRONMENT*)) (SETQ ENV (if ENV then (\DO-DEFINE-FILE-INFO NIL ENV) else *OLD-INTERLISP-READ-ENVIRONMENT*)) (WITH-READER-ENVIRONMENT ENV (PRINT-READER-ENVIRONMENT ENV) (printout NIL "(LISPXPRIN1 %"EXPORTS GATHERED FROM " (DIRECTORYNAME T) " ON " (DATE) "%"  T)" T "(LISPXTERPRI T)" T) (for F inside FROMFILES do (MAPC (IMPORTFILE F (OR FLG T)) (FUNCTION PRINT)) (TERPRI)) (PRINT (QUOTE STOP)) (TERPRI) (FULLNAME TOFILE)))))
+)
+
+(\DUMPEXPORTS
+(NLAMBDA COMS (* bvm%: "24-Oct-86 19:42") (* ;;; "Dumps an EXPORT form.  IMPORTFILE looks for a string announcing imports, but we must print it in a way that lets the file be loaded ok.") (PRIN1 "(") (PRIN2 (QUOTE *)) (PRIN1 (SUBSTRING BEGINEXPORTDEFSTRING 2)) (* ; "BEGINEXPORTDEFSTRING starts with a * for benefit of IMPORTFILE") (for TAIL on COMS do (PRETTYCOM (CAR TAIL))) (TERPRI) (PRINT ENDEXPORTDEFFORM) (TERPRI))
+)
+)
+(PUTDEF (QUOTE EXPORT) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (\DUMPEXPORTS . X])
+
+(RPAQ? BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")
+
+(RPAQ? ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"))
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM)
+)
+
+
+
+(* ; "for GAINSPACE")
+
+(DEFINEQ
+
+(CLEARFILEPKG
+(LAMBDA (FLG) (* bvm%: "29-Aug-86 13:02") (PROG NIL (COND ((SELECTQ FLG ((E T) T) (Y (TERPRI T) (PRIN1 "you can delete just the filemaps -
+" T) (PROG1 (ASKUSER NIL NIL "are you sure you want to delete EVERYTHING ? " (QUOTE ((Y "es - everything" RETURN T) (N "o - just the filemaps" RETURN NIL) (E "verything" RETURN T) (F "ilemaps only" RETURN NIL)))) (TERPRI T))) NIL) (UPDATEFILES) (SETQ FILELST (SUBSET FILELST (FUNCTION (LAMBDA (FILE) (COND ((fetch TOBEDUMPED of (fetch FILEPROP of FILE)) (PRINT FILE T T) (PRIN1 " has changes, not wiped." T) (TERPRI T) T) (T (replace FILEPROP of FILE with NIL) (replace FILECHANGES of FILE with NIL) (SMASHFILECOMS FILE) (NCONC1 SYSFILES FILE) NIL)))))) (SETQ LOADEDFILELST))) (SELECTQ FLG ((NIL T)) (CLRHASH *FILEMAP-HASH*))))
+)
+)
+
+(ADDTOVAR GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
+                                    ((Y "es")
+                                     (N "o")
+                                     (E . "verything")
+                                     (F "ilemaps only
+"))))
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS SMASHPROPSLST1)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT DECLARETAGSLST 
+       DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 I.S.OPRLST LISPXCOMS 
+       LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS MAKEFILEOPTIONS MAKEFILEREMAKEFLG 
+       MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS SYSPROPS USERMACROS USERRECLST USERWORDS 
+       FILEPKGTYPEPROPS)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
+
+(BLOCK%: DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
+       (SPECVARS COMSNAME))
+
+(BLOCK%: ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
+       (NOLINKFNS . T)
+       (SPECVARS COMSNAME)
+       (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))
+
+(BLOCK%: INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL INFILECOMSVALS 
+       INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE
+       (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
+       INFILECOMSPROP)
+
+(BLOCK%: NIL MAKEFILE (LOCALVARS . T)
+       (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))
+
+(BLOCK%: ADDFILE ADDFILE ADDFILE0)
+
+(BLOCK%: FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))
+
+(BLOCK%: NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
+       COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES EDITDEF 
+       EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM FILEPKGCOMPROPS FILEPKGTYPE
+       FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES 
+       MAKEFILESCOMS MAKELISPXMACROSCOMS MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED 
+       MOVETOFILE POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
+       SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED UNSAVEDEF 
+       UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS COMPILE.EXT EDITMACROS 
+                          EDITLOADFNSFLG LOADOPTIONS)
+       (LOCALVARS . T))
+
+(BLOCK%: DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))
+
+(BLOCK%: GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
+       GETDEFSAVED (RETFNS GETDEFCOM)
+       (NOLINKFNS . T)
+       (GLOBALVARS NOT-FOUNDTAG))
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS 
+                          MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS 
+                          PRETTYDEFMACROS)
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES)
+)
+(PUTPROPS FILEPKG COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 
+1990 1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (21965 22767 (SEARCHPRETTYTYPELST 21975 . 22397) (PRETTYDEFMACROS 22399 . 22586) (
+FILEPKGCOMPROPS 22588 . 22765)) (23573 49781 (CLEANUP 23583 . 24321) (COMPILEFILES 24323 . 24507) (
+COMPILEFILES0 24509 . 24830) (CONTINUEDIT 24832 . 25550) (MAKEFILE 25552 . 37194) (FILECHANGES 37196
+ . 38466) (FILEPKG.MERGECHANGES 38468 . 38920) (FILEPKG.CHANGEDFNS 38922 . 39183) (MAKEFILE1 39185 . 
+43455) (COMPILE-FILE? 43457 . 44079) (MAKEFILES 44081 . 44771) (ADDFILE 44773 . 46270) (ADDFILE0 46272
+ . 49263) (LISTFILES 49265 . 49779)) (50471 77462 (FILEPKGCHANGES 50481 . 51098) (GETFILEPKGTYPE 51100
+ . 52893) (MARKASCHANGED 52895 . 53740) (FILECOMS 53742 . 53998) (WHEREIS 54000 . 55420) (
+SMASHFILECOMS 55422 . 55587) (FILEFNSLST 55589 . 55751) (FILECOMSLST 55753 . 56006) (UPDATEFILES 56008
+ . 58367) (INFILECOMS? 58369 . 60272) (INFILECOMTAIL 60274 . 61414) (INFILECOMS 61416 . 61509) (
+INFILECOM 61511 . 71720) (INFILECOMSVALS 71722 . 72049) (INFILECOMSVAL 72051 . 73053) (INFILECOMSPROP 
+73055 . 73440) (IFCPROPS 73442 . 73963) (IFCEXPRTYPE 73965 . 74278) (IFCPROPSCAN 74280 . 75333) (
+IFCDECLARE 75335 . 76646) (INFILEPAIRS 76648 . 76807) (INFILECOMSMACRO 76809 . 77460)) (77497 97479 (
+FILES? 77507 . 78549) (FILES?1 78551 . 79002) (FILES?PRINTLST 79004 . 79413) (ADDTOFILES? 79415 . 
+89396) (ADDTOFILE 89398 . 89957) (WHATIS 89959 . 91025) (ADDTOCOMS 91027 . 91923) (ADDTOCOM 91925 . 
+94430) (ADDTOCOM1 94432 . 95104) (ADDNEWCOM 95106 . 95827) (MAKENEWCOM 95829 . 96733) (
+DEFAULTMAKENEWCOM 96735 . 97477)) (97549 99307 (MERGEINSERT 97559 . 99003) (MERGEINSERT1 99005 . 99305
+)) (100438 105565 (DELFROMFILES 100448 . 100919) (DELFROMCOMS 100921 . 101897) (DELFROMCOM 101899 . 
+104099) (DELFROMCOM1 104101 . 104597) (REMOVEITEM 104599 . 105022) (MOVETOFILE 105024 . 105563)) (
+105783 107276 (SAVEPUT 105793 . 107274)) (107401 110819 (UNMARKASCHANGED 107411 . 108172) (PREEDITFN 
+108174 . 109124) (POSTEDITPROPS 109126 . 110063) (POSTEDITALISTS 110065 . 110817)) (110968 120538 (
+ALISTS.GETDEF 110978 . 111228) (ALISTS.WHENCHANGED 111230 . 111566) (CLEARCLISPARRAY 111568 . 112033) 
+(EXPRESSIONS.WHENCHANGED 112035 . 112272) (MAKEALISTCOMS 112274 . 112690) (MAKEFILESCOMS 112692 . 
+113381) (MAKELISPXMACROSCOMS 113383 . 114052) (MAKEPROPSCOMS 114054 . 114321) (MAKEUSERMACROSCOMS 
+114323 . 115022) (PROPS.WHENCHANGED 115024 . 115364) (FILEGETDEF.LISPXMACROS 115366 . 116066) (
+FILEGETDEF.ALISTS 116068 . 116423) (FILEGETDEF.RECORDS 116425 . 116864) (FILEGETDEF.PROPS 116866 . 
+117278) (FILEGETDEF.MACROS 117280 . 117716) (FILEGETDEF.VARS 117718 . 117992) (FILEGETDEF.FNS 117994
+ . 118687) (FILEPKGCOMS.PUTDEF 118689 . 119853) (FILES.PUTDEF 119855 . 120316) (VARS.PUTDEF 120318 . 
+120431) (FILES.WHENCHANGED 120433 . 120536)) (122562 126276 (RENAME 122572 . 123526) (CHANGECALLERS 
+123528 . 126274)) (126277 154034 (SHOWDEF 126287 . 126696) (COPYDEF 126698 . 127705) (GETDEF 127707 . 
+129362) (GETDEFCOM 129364 . 130186) (GETDEFCOM0 130188 . 130832) (GETDEFCURRENT 130834 . 133591) (
+GETDEFERR 133593 . 134298) (GETDEFFROMFILE 134300 . 136425) (GETDEFSAVED 136427 . 137024) (PUTDEF 
+137026 . 137538) (EDITDEF 137540 . 138283) (DEFAULT.EDITDEF 138285 . 141125) (EDITDEF.FILES 141127 . 
+141293) (LOADDEF 141295 . 141432) (DWIMDEF 141434 . 141922) (DELDEF 141924 . 143539) (DELFROMLIST 
+143541 . 143758) (HASDEF 143760 . 146314) (GETFILEDEF 146316 . 146659) (SAVEDEF 146661 . 147523) (
+UNSAVEDEF 147525 . 148040) (COMPAREDEFS 148042 . 149280) (COMPARE 149282 . 149770) (TYPESOF 149772 . 
+154032)) (154101 159142 (FIXEDITDATE 154111 . 157614) (EDITDATE? 157616 . 159140)) (159561 163157 (
+FILEPKGCOM 159571 . 161668) (FILEPKGTYPE 161670 . 163155)) (175194 181027 (FINDCALLERS 175204 . 175447
+) (EDITCALLERS 175449 . 178292) (EDITFROMFILE 178294 . 180652) (FINDATS 180654 . 180790) (LOOKIN 
+180792 . 181025)) (181028 182027 (SEPRCASE 181038 . 182025)) (182544 185856 (IMPORTFILE 182554 . 
+183184) (IMPORTEVAL 183186 . 183738) (IMPORTFILESCAN 183740 . 184037) (CHECKIMPORTS 184039 . 184667) (
+GATHEREXPORTS 184669 . 185412) (\DUMPEXPORTS 185414 . 185854)) (186194 186992 (CLEARFILEPKG 186204 . 
+186990)))))
+STOP
diff --git a/CLTL2/FILEPKG.LCOM b/CLTL2/FILEPKG.LCOM
new file mode 100644
index 00000000..61aa1510
Binary files /dev/null and b/CLTL2/FILEPKG.LCOM differ
diff --git a/CLTL2/I-NEW b/CLTL2/I-NEW
new file mode 100644
index 00000000..249e2cea
--- /dev/null
+++ b/CLTL2/I-NEW
@@ -0,0 +1,419 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
+(FILECREATED " 2-Dec-93 13:37:18" |{DSK}<king>export>lispcore>sources>CLTL2>I-NEW.;3|)
+
+
+(PRETTYCOMPRINT I-NEWCOMS)
+
+(RPAQQ I-NEWCOMS ((ADDVARS (LOCKEDFNS \\CLOCK0 \\GETINTERNALCLOCK \\BOXIDIFFERENCE \\BOXIPLUS \\BLT \\SLOWIQUOTIENT) (LOCKEDVARS \\RCLKSECOND \\RCLKMILLISECOND \\MISCSTATS)) (ADDVARS (LOCKEDFNS ERROR RAID \\M44ACTONVMEMFILE \\ACTONVMEMFILESUBR \\ACTONVMEMPAGES \\CLEANUPDISKQUEUE \\CLEARCB \\DISKERROR \\DOACTONDISKPAGES \\DODISKCOMMAND \\EXTENDISFMAP \\M44DOEXTENDVMEMFILE \\GETDISKCB \\INITBFS \\INSUREVMEMFILE \\LISPERROR \\LOOKUPFMAP \\REALDISKDA \\VIRTUALDISKDA \\CLEARWORDS \\TESTPARTITION \\EXTENDEDVMEMINIT \\WHICHPART \\INITIALIZESWAPDISK \\SWAPDISKERROR) (LOCKEDVARS \\DISKREQUESTBLOCK \\SWAPREQUESTBLOCK \\MAINDISK \\SWAPDSK1 \\SWAPDSK2 \\ISFCHUNKSIZE \\EMUSCRATCH \\EMUDISKBUFFERS \\EMUSWAPBUFFERS \\EMUDISKBUFEND \\MAXSWAPBUFFERS \\#DISKBUFFERS |\\InterfacePage| \\ISFMAP \\ISFSCRATCHCAS \\ISFSCRATCHDAS \\SYSDISK \\#SWAPBUFFERS \\MAXDISKDA\s \\DISKDEBUG \\SPAREDISKWRITEBUFFER \\#EMUBUFFERS \\EMUBUFFERS \\LASTVMEMFILEPAGE |\\XVmem| |\\XVmemFmapBase| |\\XVmemFmapHighBase| |\\XVmemDiskBase|)) (FNS I.MAKEINITBFS) (ADDVARS (LOCKEDFNS FLIPCURSORBAR \\SETIOPOINTERS \\KEYHANDLER \\KEYHANDLER1 \\CONTEXTAPPLY \\LOCKPAGES \\DECODETRANSITION \\SMASHLINK \\INCUSECOUNT LLSH \\MAKEFREEBLOCK \\DECUSECOUNT \\MAKENUMBER \\ADDBASE \\PERIODIC.INTERRUPTFRAME \\DOBUFFEREDTRANSITIONS \\TIMER.INTERRUPTFRAME \\CAUSEINTERRUPT \\DOMOUSECHORDING \\KEYBOARDOFF \\TRACKCURSOR \\HARDCURSORUP \\HARDCURSORPOSITION \\HARDCURSORDOWN \\SOFTCURSORUP \\SOFTCURSORUPCURRENT \\SOFTCURSORPOSITION \\SOFTCURSORDOWN \\SOFTCURSORPILOTBITBLT) (LOCKEDVARS |\\InterfacePage| \\CURSORHOTSPOTX \\CURSORHOTSPOTY \\CURRENTCURSOR \\SOFTCURSORWIDTH \\SOFTCURSORHEIGHT \\SOFTCURSORP \\SOFTCURSORUPP \\SOFTCURSORUPBM \\SOFTCURSORDOWNBM \\SOFTCURSORBBT1 \\SOFTCURSORBBT2 \\SOFTCURSORBBT3 \\SOFTCURSORBBT4 \\SOFTCURSORBBT5 \\SOFTCURSORBBT6 \\CURSORDESTINATION \\CURSORDESTHEIGHT \\CURSORDESTWIDTH \\CURSORDESTRASTERWIDTH \\CURSORDESTLINE \\CURSORDESTLINEBASE \\PENDINGINTERRUPT \\PERIODIC.INTERRUPT \\PERIODIC.INTERRUPT.FREQUENCY \\LASTUSERACTION \\MOUSECHORDTICKS \\KEYBOARDEVENTQUEUE \\KEYBUFFERING SCREENWIDTH SCREENHEIGHT \\TIMER.INTERRUPT.PENDING \\EM.MOUSEX \\EM.MOUSEY \\EM.CURSORX \\EM.CURSORY \\EM.UTILIN \\EM.REALUTILIN \\EM.KBDAD0 \\EM.KBDAD1 \\EM.KBDAD2 \\EM.KBDAD3 \\EM.DISPINTERRUPT \\EM.CURSORBITMAP \\EM.KBDAD4 \\EM.KBDAD5 \\MISCSTATS \\RCLKSECOND)) (FNS I.\\LOCKFN I.\\LOCKVAR I.\\LOCKCELL I.\\LOCKWORDS I.\\LOCKCODE) (ADDVARS (LOCKEDFNS \\FAULTHANDLER \\FAULTINIT \\DOVE.FAULTINIT \\D01.FAULTINIT \\DL.FAULTINIT \\CHAIN.UP.RPT \\MAKESPACEFORLOCKEDPAGE \\PAGEFAULT \\WRITEMAP \\LOOKUPPAGEMAP \\LOCKEDPAGEP \\LOADVMEMPAGE \\MOVEREALPAGE \\INVALIDADDR \\INVALIDVP \\SELECTREALPAGE \\TRANSFERPAGE \\SPECIALRP \\UPDATECHAIN \\MARKPAGEVACANT \\FLUSHPAGE \\CLEARWORDS \\FLUSHVM \\DONEWPAGE \\ASSURE.FPTOVP.PAGE \\DONEWEPHEMERALPAGE \\WRITEDIRTYPAGE1 \\COPYSYS0 \\COPYSYS0SUBR \\RELEASEWORKINGSET \\DOFLUSHVM \\DOLOCKPAGES \\DOTEMPLOCKPAGES \\TEMPUNLOCKPAGES \\MP.ERROR RAID \\DL.NEWFAULTINIT \\DL.MARK.PAGES.UNAVAILABLE \\DL.UNMAPPAGES \\DL.ASSIGNBUFFERS \\D01.ASSIGNBUFFERS \\DOCOMPRESSVMEM \\MOVEVMEMFILEPAGE \\SET.VMEM.FULL.STATE \\HINUM \\LONUM \\ATOMCELL SETTOPVAL) (LOCKEDVARS \\REALPAGETABLE \\RPTLAST \\PAGEFAULTCOUNTER \\UPDATECHAINFREQ \\RPOFFSET \\RPTSIZE \\LOCKEDPAGETABLE \\EMBUFBASE \\EMBUFVP \\EMBUFRP \\LASTACCESSEDVMEMPAGE \\MAXSHORTSEEK \\MAXCLEANPROBES \\MINSHORTSEEK \\DIRTYPAGECOUNTER \\DIRTYPAGEHINT \\VMEM.INHIBIT.WRITE \\VMEM.PURE.LIMIT \\VMEM.FULL.STATE \\GUARDVMEMFULL VMEM.COMPRESS.FLG \\KBDSTACKBASE \\MISCSTACKBASE \\DOFAULTINIT \\FPTOVP \\MACHINETYPE \\VMEMACCESSFN \\TELERAIDBUFFER \\EMUDISKBUFFERS \\EMUDISKBUFEND \\MAXSWAPBUFFERS \\EMUBUFFERS \\#EMUBUFFERS \\#SWAPBUFFERS \\#DISKBUFFERS \\RCLKSECOND \\RCLKMILLISECOND \\VALSPACE \\EMUSWAPBUFFERS \\EM.CURSORBITMAP \\PAGEMAP |\\PageMapTBL| \\IOCBPAGE \\IOPAGE \\MISCSTATS \\DEFSPACE |\\InterfacePage| \\LASTVMEMFILEPAGE |\\DoveIORegion| |\\MaxScreenPage| \\NEWVMEMPAGEADDED)) (FNS I.DUMPINITPAGES) (VARS INITCONSTANTS) (FNS I.SETUPPAGEMAP I.ADDPME I.MAKEROOMFORPME I.MAPPAGES) (FNS I.SETUPSTACK I.\\SETUPSTACK1 I.\\SETUPGUARDBLOCK I.\\MAKEFREEBLOCK) (ADDVARS (LOCKEDFNS \\RESETSTACK0 \\MAKEFRAME \\SETUPSTACK1 \\MAKEFREEBLOCK \\FAULTHANDLER \\KEYHANDLER \\DUMMYKEYHANDLER \\DOTELERAID \\DUMMYTELERAID \\DOHARDRETURN \\DOGC \\CAUSEINTERRUPT \\INTERRUPTFRAME \\CODEFORTFRAME \\DOSTACKOVERFLOW \\UNLOCKPAGES \\DOMISCAPPLY) (LOCKEDVARS |\\InterfacePage| \\DEFSPACE \\STACKSPACE \\KBDSTACKBASE \\MISCSTACKBASE \\SAVED.USER.CONTEXT \\RUNNING.PROCESS \\NEED.HARDRESET.CLEANUP)) (FNS I.INITGC) (FNS I.NTYPX I.\\ALLOCMDSPAGE I.\\MAKEMDSENTRY I.\\INITMDSPAGE I.\\ASSIGNDATATYPE1 I.\\TYPENUMBERFROMNAME I.\\CREATECELL I.\\NEW2PAGE) (FNS I.CREATEMDSTYPETABLE I.INITDATATYPES I.INITDATATYPENAMES) (VARS \\BUILT-IN-SYSTEM-TYPES) (FNS I.FSETVAL I.SETPROPLIST I.PUTDEFN I.\\BLT) (FNS I.\\MKATOM I.\\CREATE.SYMBOL I.\\INITATOMPAGE I.\\MOVEBYTES I.\\STKMIN) (FNS I.COPYATOM I.INITATOMS) (FNS I.MAKEINITFIRST I.\\COPY I.MAKEINITLAST) (FNS I.\\CONS.UFN I.\\MAIKO.CONS.UFN I.\\INITCONSPAGE I.\\NEXTCONSPAGE) (FNS I.\\GETBASEBYTE I.\\PUTBASEBYTE I.CREATEPAGES I.\\NEW4PAGE) (FILES (SYSLOAD FROM VALUEOF DIRECTORIES) CMLARRAY-SUPPORT) (FNS I.ALLOCSTRING I.%COPY-ONED-ARRAY I.%COPY-STRING-TO-ARRAY) (FNS I.\\#BLOCKDATACELLS I.\\PREFIXALIGNMENT? I.\\ALLOCBLOCK I.\\MAIKO.ALLOCBLOCK I.\\ALLOCBLOCK.NEW I.\\MAKEFREEARRAYBLOCK I.\\MERGEBACKWARD I.\\LINKBLOCK I.\\ALLOCHUNK) (FNS I.PREINITARRAYS I.POSTINITARRAYS I.FILEARRAYBASE I.FILEBLOCKTRAILER I.FILECODEBLOCK I.FILEPATCHBLOCK) (FNS I.\\SETUP.HUNK.TYPENUMBERS I.\\COMPUTE.HUNK.TYPEDECLS I.\\TURN.ON.HUNKING I.\\SETUP.TYPENUM.TABLE) (FNS I.DCODERD) (VARS \\OPCODES (I.CODERDTBL (COPYREADTABLE (QUOTE ORIG)))) (P (SETSYNTAX (CHARCODE ^Y) (QUOTE (MACRO (LAMBDA (FILE RDTBL) (EVALFORMAKEINIT (READ FILE RDTBL))))) I.CODERDTBL) (SETSYNTAX (CHARCODE \|) (QUOTE (MACRO ALWAYS READVBAR)) I.CODERDTBL) (READTABLEPROP I.CODERDTBL (QUOTE USESILPACKAGE) NIL)) (FNS I.INITUFNTABLE I.\\SETUFNENTRY) (VARS INITPTRS INITVALUES) (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) MAKEINIT)))
+)
+
+(ADDTOVAR LOCKEDFNS \\CLOCK0 \\GETINTERNALCLOCK \\BOXIDIFFERENCE \\BOXIPLUS \\BLT \\SLOWIQUOTIENT)
+
+(ADDTOVAR LOCKEDVARS \\RCLKSECOND \\RCLKMILLISECOND \\MISCSTATS)
+
+(ADDTOVAR LOCKEDFNS ERROR RAID \\M44ACTONVMEMFILE \\ACTONVMEMFILESUBR \\ACTONVMEMPAGES \\CLEANUPDISKQUEUE
+ \\CLEARCB \\DISKERROR \\DOACTONDISKPAGES \\DODISKCOMMAND \\EXTENDISFMAP \\M44DOEXTENDVMEMFILE \\GETDISKCB
+ \\INITBFS \\INSUREVMEMFILE \\LISPERROR \\LOOKUPFMAP \\REALDISKDA \\VIRTUALDISKDA \\CLEARWORDS \\TESTPARTITION
+ \\EXTENDEDVMEMINIT \\WHICHPART \\INITIALIZESWAPDISK \\SWAPDISKERROR)
+
+(ADDTOVAR LOCKEDVARS \\DISKREQUESTBLOCK \\SWAPREQUESTBLOCK \\MAINDISK \\SWAPDSK1 \\SWAPDSK2 \\ISFCHUNKSIZE
+ \\EMUSCRATCH \\EMUDISKBUFFERS \\EMUSWAPBUFFERS \\EMUDISKBUFEND \\MAXSWAPBUFFERS \\#DISKBUFFERS |\\InterfacePage|
+ \\ISFMAP \\ISFSCRATCHCAS \\ISFSCRATCHDAS \\SYSDISK \\#SWAPBUFFERS \\MAXDISKDA\s \\DISKDEBUG \\SPAREDISKWRITEBUFFER
+ \\#EMUBUFFERS \\EMUBUFFERS \\LASTVMEMFILEPAGE |\\XVmem| |\\XVmemFmapBase| |\\XVmemFmapHighBase| |\\XVmemDiskBase|
+)
+(DEFINEQ
+
+(I.MAKEINITBFS
+(LAMBDA NIL (*) (*) (PROGN (*) (I.\\LOCKWORDS (SETQ I.MAINDISK ((LAMBDA ($$1) (I.PUTBASEPTR $$1 0 NIL) $$1) (I.\\ALLOCBLOCK 18))) 36) (I.PUTBASEPTR I.MAINDISK 26 (I.\\COPY (QUOTE DSK))) (I.\\LOCKWORDS (SETQ I.SWAPDSK1 ((LAMBDA ($$1) (I.PUTBASEPTR $$1 0 NIL) $$1) (I.\\ALLOCBLOCK 18))) 36) (I.\\LOCKWORDS (SETQ I.SWAPDSK2 ((LAMBDA ($$1) (I.PUTBASEPTR $$1 0 NIL) $$1) (I.\\ALLOCBLOCK 18))) 36)) (PROGN (*) (I.\\LOCKWORDS (SETQ I.SWAPREQUESTBLOCK (I.\\ALLOCBLOCK (LRSH (IPLUS (IPLUS 42 60) 1) 1))) (+ 42 60)) (I.\\LOCKWORDS (SETQ I.DISKREQUESTBLOCK (I.\\ALLOCBLOCK (LRSH (IPLUS (IPLUS 42 60) 1) 1))) (+ 42 60))) (|to| 3 |bind| PREV (FIRSTCB _ (I.\\ALLOCBLOCK 3)) |first| (I.\\LOCKWORDS (SETQ PREV FIRSTCB) 6) |do| (I.\\LOCKWORDS (SETQ PREV ((LAMBDA ($$1) (PROG1 (SETQ $$1 (I.\\ALLOCBLOCK 3)) (I.PUTBASEPTR $$1 0 PREV))) NIL)) 6) |finally| (I.PUTBASEPTR FIRSTCB 0 PREV) (*) (I.PUTBASEPTR I.MAINDISK 14 FIRSTCB)) (SETQ I.FREEPAGEFID (I.\\ALLOCBLOCK 3)) (*) (|for| I |from| 0 |to| 4 |do| (I.PUTBASE I.FREEPAGEFID I (UNSIGNED -1 16))))
+)
+)
+
+(ADDTOVAR LOCKEDFNS FLIPCURSORBAR \\SETIOPOINTERS \\KEYHANDLER \\KEYHANDLER1 \\CONTEXTAPPLY \\LOCKPAGES
+ \\DECODETRANSITION \\SMASHLINK \\INCUSECOUNT LLSH \\MAKEFREEBLOCK \\DECUSECOUNT \\MAKENUMBER \\ADDBASE
+ \\PERIODIC.INTERRUPTFRAME \\DOBUFFEREDTRANSITIONS \\TIMER.INTERRUPTFRAME \\CAUSEINTERRUPT \\DOMOUSECHORDING
+ \\KEYBOARDOFF \\TRACKCURSOR \\HARDCURSORUP \\HARDCURSORPOSITION \\HARDCURSORDOWN \\SOFTCURSORUP \\SOFTCURSORUPCURRENT
+ \\SOFTCURSORPOSITION \\SOFTCURSORDOWN \\SOFTCURSORPILOTBITBLT)
+
+(ADDTOVAR LOCKEDVARS |\\InterfacePage| \\CURSORHOTSPOTX \\CURSORHOTSPOTY \\CURRENTCURSOR \\SOFTCURSORWIDTH
+ \\SOFTCURSORHEIGHT \\SOFTCURSORP \\SOFTCURSORUPP \\SOFTCURSORUPBM \\SOFTCURSORDOWNBM \\SOFTCURSORBBT1
+ \\SOFTCURSORBBT2 \\SOFTCURSORBBT3 \\SOFTCURSORBBT4 \\SOFTCURSORBBT5 \\SOFTCURSORBBT6 \\CURSORDESTINATION
+ \\CURSORDESTHEIGHT \\CURSORDESTWIDTH \\CURSORDESTRASTERWIDTH \\CURSORDESTLINE \\CURSORDESTLINEBASE \\PENDINGINTERRUPT
+ \\PERIODIC.INTERRUPT \\PERIODIC.INTERRUPT.FREQUENCY \\LASTUSERACTION \\MOUSECHORDTICKS \\KEYBOARDEVENTQUEUE
+ \\KEYBUFFERING SCREENWIDTH SCREENHEIGHT \\TIMER.INTERRUPT.PENDING \\EM.MOUSEX \\EM.MOUSEY \\EM.CURSORX
+ \\EM.CURSORY \\EM.UTILIN \\EM.REALUTILIN \\EM.KBDAD0 \\EM.KBDAD1 \\EM.KBDAD2 \\EM.KBDAD3 \\EM.DISPINTERRUPT
+ \\EM.CURSORBITMAP \\EM.KBDAD4 \\EM.KBDAD5 \\MISCSTATS \\RCLKSECOND)
+(DEFINEQ
+
+(I.\\LOCKFN
+(LAMBDA (FN) (*) (I.\\LOCKCELL (SETQ FN (I.\\ATOMCELL (PROGN (I.\\COPY FN)) 10))) (COND ((NEQ 0 (LRSH (I.GETBASE FN 0) 15)) (I.\\LOCKCODE (I.GETBASEPTR FN 0)))))
+)
+
+(I.\\LOCKVAR
+(LAMBDA (VAR) (*) (I.\\LOCKCELL (I.\\ATOMCELL (PROGN (I.\\COPY VAR)) 12))))
+
+(I.\\LOCKCELL
+(LAMBDA (X NPGS) (*) (MKI.LOCKPAGES (I.VAG2 (I.HILOC X) (LOGAND (I.LOLOC X) 65280)) (OR NPGS 1))))
+
+(I.\\LOCKWORDS
+(LAMBDA (BASE NWORDS) (*) (MKI.LOCKPAGES (I.VAG2 (I.HILOC BASE) (LOGAND (I.LOLOC BASE) 65280)) (COND (NWORDS (LRSH (IPLUS (IPLUS (LOGAND (I.LOLOC BASE) 255) NWORDS) 255) 8)) (T 1))))
+)
+
+(I.\\LOCKCODE
+(LAMBDA (CODEBLOCK) (*) (I.\\LOCKWORDS CODEBLOCK (LLSH (I.\\#BLOCKDATACELLS CODEBLOCK) 1))))
+)
+
+(ADDTOVAR LOCKEDFNS \\FAULTHANDLER \\FAULTINIT \\DOVE.FAULTINIT \\D01.FAULTINIT \\DL.FAULTINIT \\CHAIN.UP.RPT
+ \\MAKESPACEFORLOCKEDPAGE \\PAGEFAULT \\WRITEMAP \\LOOKUPPAGEMAP \\LOCKEDPAGEP \\LOADVMEMPAGE \\MOVEREALPAGE
+ \\INVALIDADDR \\INVALIDVP \\SELECTREALPAGE \\TRANSFERPAGE \\SPECIALRP \\UPDATECHAIN \\MARKPAGEVACANT \\FLUSHPAGE
+ \\CLEARWORDS \\FLUSHVM \\DONEWPAGE \\ASSURE.FPTOVP.PAGE \\DONEWEPHEMERALPAGE \\WRITEDIRTYPAGE1 \\COPYSYS0
+ \\COPYSYS0SUBR \\RELEASEWORKINGSET \\DOFLUSHVM \\DOLOCKPAGES \\DOTEMPLOCKPAGES \\TEMPUNLOCKPAGES \\MP.ERROR
+ RAID \\DL.NEWFAULTINIT \\DL.MARK.PAGES.UNAVAILABLE \\DL.UNMAPPAGES \\DL.ASSIGNBUFFERS \\D01.ASSIGNBUFFERS
+ \\DOCOMPRESSVMEM \\MOVEVMEMFILEPAGE \\SET.VMEM.FULL.STATE \\HINUM \\LONUM \\ATOMCELL SETTOPVAL)
+
+(ADDTOVAR LOCKEDVARS \\REALPAGETABLE \\RPTLAST \\PAGEFAULTCOUNTER \\UPDATECHAINFREQ \\RPOFFSET \\RPTSIZE
+ \\LOCKEDPAGETABLE \\EMBUFBASE \\EMBUFVP \\EMBUFRP \\LASTACCESSEDVMEMPAGE \\MAXSHORTSEEK \\MAXCLEANPROBES
+ \\MINSHORTSEEK \\DIRTYPAGECOUNTER \\DIRTYPAGEHINT \\VMEM.INHIBIT.WRITE \\VMEM.PURE.LIMIT \\VMEM.FULL.STATE
+ \\GUARDVMEMFULL VMEM.COMPRESS.FLG \\KBDSTACKBASE \\MISCSTACKBASE \\DOFAULTINIT \\FPTOVP \\MACHINETYPE
+ \\VMEMACCESSFN \\TELERAIDBUFFER \\EMUDISKBUFFERS \\EMUDISKBUFEND \\MAXSWAPBUFFERS \\EMUBUFFERS \\#EMUBUFFERS
+ \\#SWAPBUFFERS \\#DISKBUFFERS \\RCLKSECOND \\RCLKMILLISECOND \\VALSPACE \\EMUSWAPBUFFERS \\EM.CURSORBITMAP
+ \\PAGEMAP |\\PageMapTBL| \\IOCBPAGE \\IOPAGE \\MISCSTATS \\DEFSPACE |\\InterfacePage| \\LASTVMEMFILEPAGE
+ |\\DoveIORegion| |\\MaxScreenPage| \\NEWVMEMPAGEADDED)
+(DEFINEQ
+
+(I.DUMPINITPAGES
+(LAMBDA (CODEFIRSTPAGE CODENEXTPAGE VERSIONS) (*) (*) (I.ADDPME (IPLUS (LLSH (I.HILOC (I.VAG2 6 0)) 8) (LRSH (I.LOLOC (I.VAG2 6 0)) 8)) T) (*) (|for| I |from| CODEFIRSTPAGE |to| (SUB1 CODENEXTPAGE) |do| (*) (I.ADDPME I T)) (I.MAPPAGES 0 (ADD1 65533) (FUNCTION I.MAKEROOMFORPME)) (I.MAPPAGES 0 (ADD1 65533) (FUNCTION I.ADDPME)) (PROGN (*) (I.PUTBASE (I.VAG2 6 0) 19 NEXTPM) (I.PUTBASEFIXP (I.VAG2 6 0) 82 (SUB1 NEXTVMEM)) (I.PUTBASEFIXP (I.VAG2 6 0) 84 (SUB1 NEXTVMEM)) (I.PUTBASE (I.VAG2 6 0) 22 (I.GETBASE (I.VAG2 5 0) 0)) (I.PUTBASE (I.VAG2 6 0) 23 (I.GETBASE ((LAMBDA (VPAGE) (DECLARE (LOCALVARS VPAGE)) (I.ADDBASE (I.VAG2 5 0) (IPLUS (I.GETBASE (I.VAG2 6 512) (LRSH VPAGE 5)) (LOGAND VPAGE 31)))) (IPLUS (LLSH (I.HILOC (I.VAG2 6 512)) 8) (LRSH (I.LOLOC (I.VAG2 6 512)) 8))) 0)) (COND (VERSIONS (I.PUTBASE (I.VAG2 6 0) 8 (CAR VERSIONS)) (I.PUTBASE (I.VAG2 6 0) 10 (CADDR VERSIONS)) (I.PUTBASE (I.VAG2 6 0) 9 (CADR VERSIONS)))) (I.PUTBASE (I.VAG2 6 0) 15 5603)) (I.MAPPAGES 0 (ADD1 65533) (FUNCTION DUMPVP)) (PROG ((FILE (OUTPUT))) (COND ((NOT (RANDACCESSP FILE)) (* \; "SYSOUT file is sequential;  have to get it random access for this") (OUTPUT (SETQ FILE (OPENFILE (CLOSEF FILE) (QUOTE BOTH)))))) (SETFILEPTR FILE |MKI.Page0Byte|)) (DUMPVP (IPLUS (LLSH (I.HILOC (I.VAG2 6 0)) 8) (LRSH (I.LOLOC (I.VAG2 6 0)) 8))))
+)
+)
+
+(RPAQQ INITCONSTANTS ((* |;;;| "(LISPNAME VALUE BCPLNAME UCODENAME)") (CDRCODING 1 T T) (* \; "IF CDRCODING=0, CDR CODING IS OFF, OTHERWISE ON") (* |;;| "type numbers -- repeated on LLBASIC too") (\\SMALLP 1 SMALLTYPE |SmallType|) (\\FIXP 2 INTEGERTYPE |FixpType|) (\\FLOATP 3 FLTPTTYPE |FloatpType|) (\\LITATOM 4 ATOMTYPE |AtomType|) (\\LISTP 5 LISTTYPE |ListType|) (\\ARRAYP 6 ARRAYPTRTYPE |ArrayType|) (\\STRINGP 7 STRINGPTRTYPE) (\\STACKP 8) (\\CHARACTERP 9) (\\VMEMPAGEP 10 NIL |VMemPagePType|) (\\STREAM 11 NIL STREAMTYPE) (* |;;| "TYPE TABLE CONSTANTS") (\\TT.TYPEMASK 2047 |TTTypeMask| T) (\\TT.NOREF 32768 NIL T) (\\TT.SYMBOLP 16384 NIL T) (\\TT.FIXP 8192) (\\TT.NUMBERP 4096) (\\TT.ATOM 2048) (* |;;| "page map") (|\\PMblockSize| 32 PMBLOCKSIZE) (|\\STATSsize| 8 T) (|\\NumPMTpages| 8) (|\\EmptyPMTEntry| 65535 T) (|\\FirstVmemBlock| 2 T) (\\MAXVMPAGE 65533) (\\MAXVMSEGMENT 255) (* |;;| "interface page") (|\\IFPValidKey| 5603 T) (* |;;| "MDS") (|\\FirstMDSPage| 16382) (|\\MaxMDSPage| 65533) (|\\DefaultSecondMDSPage| 65532) (|\\MDSIncrement| 512) (|\\PagesPerMDSUnit| 2) (* \; "(FOLDLO \\MDSIncrement WORDSPERPAGE)") (* |;;| "arrays") (\\ARRAYSPACE (23 0)) (|\\FirstArraySegment| 23) (|\\FirstArrayPage| 5888) (\\ARRAYSPACE2 (64 0)) (|\\DefaultSecondArrayPage| 16384) (* |;;| "stack block constants") (|\\StackMask| 57344 T T) (|\\FxtnBlock| 49152 T T) (|\\GuardBlock| 57344 T T) (|\\BFBlock| 32768 T T) (|\\FreeStackBlock| 40960 T T) (|\\NotStackBlock| 0) (* \; "none of the above") (|\\MinExtraStackWords| 32 T T) (* |;;| "backspace kludge") (ERASECHARCODE 0 T) (* |;;| "GC constants") (\\HT1CNT 1024 NIL T) (\\HTSTKBIT 512 NIL T) (\\HTCNTMASK 64512 NIL T) (\\HTMAINSIZE 65536 NIL T) (\\HTCOLLSIZE 262144 NIL T) (\\HTENDFREE 1 NIL T) (\\HTFREEPTR 0 NIL T) (* |;;| "pointers and lengths of various data spaces") (\\ATOMSPACE (0 0) (|ATOMspace| NIL) (|atomHiVal| NIL)) (|\\AtomHI| 0) (\\CHARHI 7) (* \; "overlap character space and the atom hash table space") (|\\AtomHashTable| (7 0) (|AHTspace| |AHTbase|)) (|\\AtomHTpages| 256 AHTSIZE) (|\\LastAtomPage| 255) (|\\MaxAtomFrLst| 65535) (\\SMALLPOSPSPACE (14 0)) (|\\SmallPosHi| 14 |SMALLPOSspace| |smallpl|) (\\SMALLNEGSPACE (15 0)) (|\\SmallNegHi| 15 |SMALLNEGspace| |smallneg|) (|\\NumSmallPages| 512) (\\PNPSPACE (8 0) (|PNPspace| |PNPbase|)) (\\PNAME.HI 8) (\\DEFSPACE (10 0) (|DEFspace| |DEFbase|) (|DEFspace| |DEFbase|)) (\\DEF.HI 10) (\\VALSPACE (12 0) (|TOPVALspace| |TOPVALbase|) (|VALspace| |VALbase|)) (\\VAL.HI 12) (\\PLISTSPACE (2 0) (|PLISTspace| |PLISTbase|)) (\\PLIST.HI 2) (\\PAGEMAP (5 0) (|PAGEMAPspace| |PAGEMAPbase|)) (|\\NumPageMapPages| 256) (|\\PageMapTBL| (6 512) (|PMTspace| |PMTbase|)) (|\\InterfacePage| (6 0) (|INTERFACEspace| |INTERFACEbase|) (|INTERFACEspace| |INTERFACEbase|)) (\\IOPAGE (0 65280)) (|\\DoveIORegion| (0 16384)) (\\IOCBPAGE (0 256)) (\\FPTOVP (2 0)) (|\\MDSTypeTable| (20 0) (|MDSTYPEspace| |MDSTYPEbase|) (|MDSTYPEspace| |MDSTYPEbase|)) (|\\MDSTTsize| 256 T) (\\MISCSTATS (6 2560) (|STATSspace| |MISCSTATSbase|)) (|\\UFNTable| (6 3072) NIL (|STATSspace| |UFNTablebase|)) (|\\UFNTableSize| 2) (|\\DTDSpaceBase| (6 4096) (|DTDspace| |DTDbase|) (|DTDspace| |DTDbase|)) (|\\DTDSize| 18 T) (\\LISTPDTD (6 4186)) (|\\EndTypeNumber| 2047) (\\LOCKEDPAGETABLE (6 28672)) (|\\NumLPTPages| 16) (\\STACKSPACE (1 0) (|STACKspace| NIL) (|STACKspace| NIL)) (|\\GuardStackAddr| 61440) (|\\LastStackAddr| 65534) (\\STACKHI 1 T T) (\\HTMAIN (16 0) (|HTMAINspace| |HTMAINbase|) (|HTMAINspace| |HTMAINbase|)) (|\\HTMAINnpages| 256 T) (\\HTOVERFLOW (17 0) NIL (NIL |HTOVERFLOWbase|)) (\\HTBIGCOUNT (17 32768)) (\\HTCOLL (10 0) NIL (|HTCOLLspace| |HTCOLLbase|)) (\\DISPLAYREGION (18 0)) (|\\D1BCPLspace| 0 T |LEmubrHiVal|) (|\\D0BCPLspace| 0 T) (* |;;| "Interface Page locations") (|\\CurrentFXP| 0 T T) (|\\ResetFXP| 1 T T) (|\\SubovFXP| 2 T T) (|\\KbdFXP| 3 T T) (|\\HardReturnFXP| 4 T T) (\\GCFXP 5) (\\FAULTFXP 6 T T) (|\\MiscFXP| 14 T T) (|\\TeleRaidFXP| 24 T T) (* |;;| "emulator segment locations") (DCB.EM 272) (DISPINTERRUPT.EM 273) (CURSORBITMAP.EM 281) (KBDAD0.EM 65052) (KBDAD1.EM 65053) (KBDAD2.EM 65054) (KBDAD3.EM 65055) (UTILIN.EM 65048) (CURSORX.EM 278) (CURSORY.EM 279) (MOUSEX.EM 276) (MOUSEY.EM 277) (|\\LispKeyMask| 8192 T T) (|\\BcplKeyMask| 4352 T T) (* \; "Machine types") (\\MAIKO 3) (\\DOLPHIN 4) (\\DORADO 5) (\\DANDELION 6) (\\DAYBREAK 8) (* |;;| "FOR DLION (AND DAYBREAK)") (\\VP.DISPLAY 4608) (\\NP.DISPLAY 202) (* \; "for Dorado display 1024x808 pixels / (16 pixels/word x 256 words/page)") (\\NP.WIDEDOVEDISPLAY 243) (* \; "Wide Dove display 1152x864 pixels") (\\WIDEDOVEDISPLAYWIDTH 1152) (\\RP.AFTERDISPLAY 206) (* \; "Includes 4 pages for cursor") (\\RP.AFTERDOVEDISPLAY 243) (* \; "if big screen") (\\RP.DISPLAY 0) (\\RP.TEMPDISPLAY 2561) (\\RP.MISCLOCKED 2804) (* \; "(+ \\RP.TEMPDISPLAY \\NP.WIDEDOVEDISPLAY)") (\\RP.STACK 768) (\\VP.STACK 256) (\\RP.MAP 256) (\\NP.MAP 256) (\\RP.IOPAGE 512) (* \; "The DOVE IOCBPAGE can go anywhere, but should be under the 1mbyte range") (\\RP.DOVEIOCBPAGE 543) (\\RP.DOVEIORGN 544) (\\VP.DOVEIORGN 64) (\\DOVEIORGNSIZE 64) (\\VP.IOPAGE 255) (\\VP.IFPAGE 1536) (\\VP.FPTOVP 512) (\\NP.FPTOVP 1024) (\\RP.FPTOVP 1024) (\\RP.STARTBUFFERS 640) (\\VP.TYPETABLE 5120) (\\NP.TYPETABLE 256) (\\RP.TYPETABLE 2048) (\\VP.GCTABLE 4096) (\\NP.GCTABLE 256) (\\RP.GCTABLE 2304) (\\VP.GCOVERFLOW 4352) (\\NP.GCOVERFLOW 1) (\\RP.GCOVERFLOW 2560) (\\FP.IFPAGE 2) (\\VP.IOCBS 1) (\\VP.PRIMARYMAP 1538) (\\VP.SECONDARYMAP 1280) (\\VP.LPT 1648) (\\VP.INITSCRATCH 8) (\\VP.RPT 128) (\\VP.BUFFERS 218) (* \; "DLion processor commands") (\\DL.PROCESSORBUSY 32768) (\\DL.SETTOD 32769) (\\DL.READTOD 32770) (\\DL.READPID 32771) (\\DL.BOOTBUTTON 32772))
+)
+(DEFINEQ
+
+(I.SETUPPAGEMAP
+(LAMBDA NIL (*) (*) (PROG NIL (*) (MKI.NEWPAGE (I.VAG2 5 0) NIL T) (*) (I.CREATEPAGES (I.VAG2 6 512) 8 NIL T) (*) (*) (|for| I |from| 0 |to| (SUB1 (LLSH 8 8)) |do| (I.PUTBASE (I.VAG2 6 512) I 65535)) (SETQ NEXTPM 0) (|for| I |from| 0 |to| (SUB1 (LRSH 256 5)) |bind| (PAGEMAPKEY _ (LRSH (PROGN (IPLUS (LLSH (I.HILOC (I.VAG2 5 0)) 8) (LRSH (I.LOLOC (I.VAG2 5 0)) 8))) 5)) |do| (*) (I.PUTBASE (I.VAG2 6 512) (IPLUS PAGEMAPKEY I) NEXTPM) (SETQ NEXTPM (IPLUS NEXTPM 32))) (SETQ NEXTVMEM 2) (*) (I.CREATEPAGES (I.VAG2 6 28672) 16 NIL T)))
+)
+
+(I.ADDPME
+(LAMBDA (VP NEWPAGEOK) (*) (*) (PROG (PX PMP LOCKBASE) (COND ((IEQ (SETQ PMP (I.GETBASE (I.VAG2 6 512) (LRSH VP 5))) 65535) (*) (COND ((EVENP NEXTPM 256) (*) (SETQ PX (I.ADDBASE (I.VAG2 5 0) NEXTPM)) (OR NEWPAGEOK (IGREATERP (IPLUS (LLSH (I.HILOC PX) 8) (LRSH (I.LOLOC PX) 8)) VP) (HELP "page map needs new page after page map written out")) (MKI.NEWPAGE PX NIL T))) (I.PUTBASE (I.VAG2 6 512) (LRSH VP 5) (SETQ PMP NEXTPM)) (SETQ NEXTPM (IPLUS NEXTPM 32)))) (SETQ PX (IPLUS PMP (LOGAND VP 31))) (COND ((NEQ (I.GETBASE (I.VAG2 5 0) PX) 0) (HELP "page already in pagemap" VP)) (T (I.PUTBASE (I.VAG2 5 0) PX NEXTVMEM) (COND ((MKI.LOCKEDPAGEP VP) (*) (I.PUTBASE (SETQ LOCKBASE (I.ADDBASE (I.VAG2 6 28672) (LRSH VP 4))) 0 (LOGOR (LLSH 1 (IMOD VP 16)) (I.GETBASE LOCKBASE 0))))) (SETQ NEXTVMEM (ADD1 NEXTVMEM))))))
+)
+
+(I.MAKEROOMFORPME
+(LAMBDA (VP) (*) (*) (COND ((IEQ (I.GETBASE (I.VAG2 6 512) (LRSH VP 5)) 65535) (*) (COND ((EVENP NEXTPM 256) (*) (MKI.NEWPAGE (I.ADDBASE (I.VAG2 5 0) NEXTPM) NIL T))) (I.PUTBASE (I.VAG2 6 512) (LRSH VP 5) NEXTPM) (SETQ NEXTPM (IPLUS NEXTPM 32)))))
+)
+
+(I.MAPPAGES
+(LAMBDA (BOT TOP FN) (*) (*) (PROG ((VP BOT) (IVP (IPLUS (LLSH (I.HILOC (I.VAG2 6 0)) 8) (LRSH (I.LOLOC (I.VAG2 6 0)) 8)))) LP (COND ((AND (SETQ VP (MKI.NEXTPAGE VP)) (IGREATERP TOP VP)) (COND ((NOT (IEQ VP IVP)) (APPLY* FN VP))) (SETQ VP (ADD1 VP)) (GO LP)))))
+)
+)
+(DEFINEQ
+
+(I.SETUPSTACK
+(LAMBDA (INITFLG) (*) (*) (I.CREATEPAGES (I.VAG2 1 0) (IQUOTIENT 9216 256) NIL T) (*) (I.\\SETUPGUARDBLOCK 0 2) (*) (I.PUTBASE (I.VAG2 6 0) 0 (I.\\SETUPSTACK1 2 0 0 (IDIFFERENCE 768 2) 0 RESETPC RESETPTR NIL INITFLG)) (I.PUTBASE (I.VAG2 6 0) 1 0) (I.PUTBASE (I.VAG2 6 0) 6 0) (I.PUTBASE (I.VAG2 6 0) 2 0) (I.PUTBASE (I.VAG2 6 0) 3 0) (I.\\SETUPGUARDBLOCK (IDIFFERENCE 768 2) 2) (I.PUTBASE (I.VAG2 6 0) 30 (I.\\SETUPGUARDBLOCK 768 (IDIFFERENCE (IDIFFERENCE 9216 768) 2))) (I.PUTBASE (I.VAG2 6 0) 7 (I.\\SETUPGUARDBLOCK (IDIFFERENCE 9216 2) 2)))
+)
+
+(I.\\SETUPSTACK1
+(LAMBDA (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG ARGSLENGTH) (*) (COND ((OR INITFLG (IGREATERP (IDIFFERENCE STKEND STKP) (IPLUS (PROG1 (I.GETBASE DEFPTR 0) (*)) (PROG1 4 (*))))) (*) (PROG ((SP STKP)) (|if| ARGSLENGTH |then| (SETQ ARGSLENGTH (MIN ARGSLENGTH NARGS)) (I.\\BLT (I.VAG2 1 SP) ARGS (LLSH ARGSLENGTH 1)) (SETQ SP (PLUS SP (TIMES ARGSLENGTH 2))) (SETQ ARGS)) (FRPTQ NARGS (I.PUTBASEPTR (I.VAG2 1 0) SP (AND ARGS (PROG1 (CAR ARGS) (SETQ ARGS (CDR ARGS))))) (*) (SETQ SP (PLUS SP 2))) (AND (PROG1 (COND ((ODDP SP 4) (I.PUTBASEPTR (I.VAG2 1 0) SP NIL) (*) (SETQ SP (PLUS SP 2)) T)) (I.PUTBASE (I.VAG2 1 SP) 0 32768)) (LOGAND (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 65279) (LLSH (LOGAND 1 1) 8)))) (I.VAG2 1 SP)) 8) 1)) (I.PUTBASE (I.VAG2 1 SP) 1 STKP) (SETQ STKP (IPLUS SP 2)) (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 255) (LLSH (CONSTANT (CL:READ-FROM-STRING "#B11000001")) 8)))) (I.VAG2 1 STKP)) 8) (*) (LOGAND ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 65280) (LOGAND 0 255)))) (I.VAG2 1 STKP)) 255) (I.PUTBASE (I.VAG2 1 STKP) 8 SP) (I.PUTBASE (I.VAG2 1 STKP) 1 (IPLUS ALINK 10 1)) (I.PUTBASE (I.VAG2 1 STKP) 9 (IPLUS CLINK 10)) (I.PUTBASEPTR (I.VAG2 1 STKP) 2 DEFPTR) (I.PUTBASE (I.VAG2 1 STKP) 5 PC) (SETQ SP (IPLUS STKP (PROGN 10))) (COND ((NOT INITFLG) (*) (RPTQ (LLSH (ADD1 (SIGNED (I.GETBASE DEFPTR 2) 16)) 1) (PROGN (*) (I.PUTBASE (I.VAG2 1 0) SP 65535) (SETQ SP (PLUS SP 2)))))) (I.PUTBASE (I.VAG2 1 STKP) 4 (SETQ SP (PLUS SP (PROGN 4)))) (*) (I.\\MAKEFREEBLOCK SP (IDIFFERENCE STKEND SP)) (RETURN STKP)))))
+)
+
+(I.\\SETUPGUARDBLOCK
+(LAMBDA (STKP LEN) (*) (I.PUTBASE (I.VAG2 1 STKP) 0 57344) (I.PUTBASE (I.VAG2 1 STKP) 1 LEN) STKP))
+
+(I.\\MAKEFREEBLOCK
+(LAMBDA (STK SIZE) (*) (PROGN (*) (I.PUTBASE (I.VAG2 1 STK) 1 SIZE) (I.PUTBASE (I.VAG2 1 STK) 0 40960)))
+)
+)
+
+(ADDTOVAR LOCKEDFNS \\RESETSTACK0 \\MAKEFRAME \\SETUPSTACK1 \\MAKEFREEBLOCK \\FAULTHANDLER \\KEYHANDLER
+ \\DUMMYKEYHANDLER \\DOTELERAID \\DUMMYTELERAID \\DOHARDRETURN \\DOGC \\CAUSEINTERRUPT \\INTERRUPTFRAME
+ \\CODEFORTFRAME \\DOSTACKOVERFLOW \\UNLOCKPAGES \\DOMISCAPPLY)
+
+(ADDTOVAR LOCKEDVARS |\\InterfacePage| \\DEFSPACE \\STACKSPACE \\KBDSTACKBASE \\MISCSTACKBASE \\SAVED.USER.CONTEXT
+ \\RUNNING.PROCESS \\NEED.HARDRESET.CLEANUP)
+(DEFINEQ
+
+(I.INITGC
+(LAMBDA NIL (*) (I.CREATEPAGES (I.VAG2 16 0) (LRSH (IPLUS 65536 255) 8) T T) (I.CREATEPAGES (I.VAG2 17 0) 1 T T) (I.CREATEPAGES (I.VAG2 17 32768) 1 T) (I.CREATEPAGES (I.VAG2 10 0) 1 NIL T) (I.CREATEPAGES (I.ADDBASE (I.VAG2 10 0) 256) (SUB1 (LRSH (IPLUS 262144 255) 8)) T) (I.PUTBASEFIXP (I.VAG2 10 0) 0 0) (I.PUTBASEFIXP (I.VAG2 10 0) 2 2))
+)
+)
+(DEFINEQ
+
+(I.NTYPX
+(LAMBDA (X) (*) (*) (LOGAND (I.GETBASE (I.VAG2 20 0) (LRSH (IPLUS (LLSH (I.HILOC X) 8) (LRSH (I.LOLOC X) 8)) 1)) 2047))
+)
+
+(I.\\ALLOCMDSPAGE
+(LAMBDA (TYP) (*) (PROG (VP VPTR) BEG (COND ((SETQ VP I.MDSFREELISTPAGE) (SETQ VPTR ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 VP) 8) (LLSH (LOGAND $$1 255) 8))) NIL)) (PROG ((NXT (I.GETBASEPTR VPTR 0))) (COND ((AND NXT (NOT (SMALLP NXT))) (\\MP.ERROR 26 "MDS Free Page link bad.  ^N to continue" (PROG1 I.MDSFREELISTPAGE (SETQ I.MDSFREELISTPAGE))) (GO BEG)) (T (SETQ I.MDSFREELISTPAGE NXT))))) (T (NILL) (SETQ VP |I.NxtMDSPage|) (I.PUTBASEFIXP |I.NxtMDSPage| 0 (IDIFFERENCE VP (LRSH 512 8))) (*) (SETQ VPTR ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 VP) 8) (LLSH (LOGAND $$1 255) 8))) NIL)) (MKI.NEWPAGE (I.ADDBASE (MKI.NEWPAGE VPTR) 256)))) (I.\\MAKEMDSENTRY VP TYP) (RETURN VPTR)))
+)
+
+(I.\\MAKEMDSENTRY
+(LAMBDA (VP V) (*) (*) (I.PUTBASE (I.VAG2 20 0) (LRSH VP 1) (COND ((NILL) (LOGOR 32768 V)) (T V)))))
+
+(I.\\INITMDSPAGE
+(LAMBDA (BASE SIZE PREV) (*) (*) (PROG ((SLOP (IREMAINDER 256 SIZE)) NPAGES LIMIT) (*) (COND ((AND (NEQ SLOP 0) (ILESSP SLOP (LRSH SIZE 1)) (ILESSP SIZE 256)) (*) (SETQ NPAGES (IQUOTIENT 512 256)) (SETQ LIMIT 256)) (T (SETQ NPAGES 1) (SETQ LIMIT 512))) (|to| NPAGES |do| (|for| (DISP _ 0) |while| (ILEQ (SETQ DISP (PLUS DISP SIZE)) LIMIT) |do| (I.PUTBASEPTR BASE 0 PREV) (SETQ PREV BASE) (SETQ BASE (I.ADDBASE BASE SIZE))) (SETQ BASE (I.ADDBASE BASE SLOP))) (RETURN PREV)))
+)
+
+(I.\\ASSIGNDATATYPE1
+(LAMBDA (NAME DESCRIPTORS SIZE SPECS PTRFIELDS SUPERTYPE) (*) (*) (PROG ((I.NTYPX (I.\\TYPENUMBERFROMNAME NAME)) (SUPERTYPENUMBER (COND (SUPERTYPE (OR (I.\\TYPENUMBERFROMNAME SUPERTYPE) (ERROR SUPERTYPE ":INCLUDEd datatype but not currently declared"))) (T 0))) DTD REDECLARED NEWTYPENUM NEWDTD) (COND (I.NTYPX (*) (SETQ DTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES I.NTYPX 18))) (COND ((AND (EQUAL PTRFIELDS (I.GETBASEPTR DTD 10)) (EQUAL SIZE (I.GETBASE DTD 3))) (*) (I.PUTBASEPTR DTD 6 DESCRIPTORS) (I.PUTBASE DTD 17 SUPERTYPENUMBER) (RETURN I.NTYPX)) ((EQ (I.GETBASE DTD 3) 0) (*)) ((OR (EQ CROSSCOMPILING T) (AND CROSSCOMPILING (NEQ (QUOTE Y) (ASKUSER 30 (SELECTQ CROSSCOMPILING (Y (QUOTE Y)) (QUOTE N)) (LIST (COND (SIZE "OK TO REDECLARE DATATYPE ") (T "OK to deallocate DATATYPE ")) NAME))))) (*) (RETURN I.NTYPX)) ((IGREATERP I.NTYPX |I.MaxSysTypeNum|) (*) (SETQ REDECLARED T)) (T (*) (ERROR "ILLEGAL DATA TYPE" NAME))))) (*) (COND ((NOT SIZE) (*)) (T (COND ((AND (EQ |I.MaxTypeNumber| 2047) (OR (NULL I.NTYPX) REDECLARED)) (LISPERROR "DATA TYPES FULL" NAME))) (PROGN (COND ((OR (NULL I.NTYPX) REDECLARED) (*) (SETQ NEWTYPENUM (SETQ |I.MaxTypeNumber| (PLUS |I.MaxTypeNumber| 1))) (SETQ NEWDTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES NEWTYPENUM 18))) (*) (COND ((IGEQ (IPLUS (LOGAND (I.LOLOC NEWDTD) 255) 18) 256) (*) (MKI.NEWPAGE (I.ADDBASE NEWDTD 18) T))) (COND (REDECLARED (*) (LET ((NEWTYPEENTRY (LOGOR NEWTYPENUM (LOGAND (I.GETBASE DTD 16) (LOGNOT 2047)))) FOUNDSOME) (\\MAPMDS I.NTYPX (FUNCTION (LAMBDA (PAGE) (I.\\MAKEMDSENTRY PAGE NEWTYPEENTRY) (SETQ FOUNDSOME T)))) (COND ((NOT FOUNDSOME) (*) (SETQ |I.MaxTypeNumber| (PLUS |I.MaxTypeNumber| -1))) (T (I.PUTBASEPTR DTD 6 NIL) (I.PUTBASEPTR DTD 8 NIL) (I.\\BLT NEWDTD DTD 18) (*) (PROGN (I.GETBASEPTR NEWDTD 10)) (NEQ (LOGAND (LRSH (I.PUTBASE NEWDTD 0 (LOGOR (LOGAND (I.GETBASE NEWDTD 0) 57343) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 13))) 13) 1) 0) (I.PUTBASE NEWDTD 16 NEWTYPEENTRY) (I.PUTBASEPTR NEWDTD 0 (NEW-SYMBOL-CODE (PACK* "Obsolete-" NAME) (I.ATOMNUMBER (PACK* "Obsolete-" NAME)))) (I.PUTBASEPTR DTD 4 NIL) (*))))) (T (*) (SETQ I.NTYPX NEWTYPENUM) (I.PUTBASEPTR (SETQ DTD NEWDTD) 0 (NEW-SYMBOL-CODE NAME (I.ATOMNUMBER NAME))))))) (COND ((NEQ SIZE 0) (*) (I.PUTBASE DTD 3 SIZE) (I.PUTBASEPTR DTD 6 (I.\\COPY DESCRIPTORS)) (I.PUTBASEPTR DTD 8 (I.\\COPY SPECS)) (I.PUTBASEPTR DTD 10 PTRFIELDS) (I.PUTBASE DTD 17 SUPERTYPENUMBER) (I.PUTBASE DTD 16 I.NTYPX) (*))) (*)) (RETURN (CL:VALUES I.NTYPX REDECLARED))))))
+)
+
+(I.\\TYPENUMBERFROMNAME
+(LAMBDA (TYPE) (*) (AND TYPE (BIND (INDEX _ (NEW-SYMBOL-CODE TYPE (I.ATOMNUMBER TYPE))) |for| I |from| 1 |to| |I.MaxTypeNumber| |do| (COND ((EQ INDEX (I.GETBASEPTR (I.ADDBASE (I.VAG2 6 4096) (ITIMES I 18)) 0)) (RETURN I))))))
+)
+
+(I.\\CREATECELL
+(LAMBDA (TYP) (*) (COND ((AND (NEQ 1 0) (EQ TYP 5)) (HELP "CREATECELL \\LISTP"))) (LET ((DTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES TYP 18))) NEWCELL) (|while| (EQ (I.GETBASE DTD 3) 0) |do| (ERROR "Attempt to CREATE a type not declared yet" (\\TYPENAMEFROMNUMBER TYP))) (PROGN (COND ((SETQ NEWCELL (I.GETBASEPTR DTD 4)) (*) (I.PUTBASEPTR DTD 4 (I.GETBASEPTR NEWCELL 0)) (*) (LET ((CNT (SUB1 (I.GETBASE DTD 3)))) (*) (I.PUTBASE NEWCELL CNT 0) (I.\\BLT NEWCELL (I.ADDBASE NEWCELL 1) CNT)) (PROGN NEWCELL) NEWCELL) (T (*) (*) (*) (I.PUTBASEPTR DTD 4 (I.\\INITMDSPAGE (I.\\ALLOCMDSPAGE (I.GETBASE DTD 16)) (I.GETBASE DTD 3) (I.GETBASEPTR DTD 4))) (I.\\CREATECELL TYP))))))
+)
+
+(I.\\NEW2PAGE
+(LAMBDA (BASE) (*) (MKI.NEWPAGE (I.ADDBASE (MKI.NEWPAGE BASE) 256))))
+)
+(DEFINEQ
+
+(I.CREATEMDSTYPETABLE
+(LAMBDA NIL (*) (*) (*) (*) (*) (*) (*) (I.CREATEPAGES (I.VAG2 20 0) 256 NIL T) (PROG (VP) (*) (SETQ VP 0) (FRPTQ (LLSH 256 8) (I.PUTBASE (I.VAG2 20 0) VP 32768) (SETQ VP (PLUS VP 1))) (*) (|for| SEGMENT |in| (LIST 14 15) |do| (|for| PAGE |from| 0 |to| (SUB1 256) |by| (LRSH 512 8) |do| (I.\\MAKEMDSENTRY (LOGOR PAGE (LLSH SEGMENT 8)) (LOGOR 32768 8192 4096 2048 1)))) (|for| PAGE |from| 0 |to| (SUB1 256) |by| (LRSH 512 8) |do| (I.\\MAKEMDSENTRY (LOGOR PAGE (LLSH 7 8)) (LOGOR 32768 9)))) (I.CREATEPAGES (I.VAG2 6 2560) (LRSH 512 8) NIL T) (I.\\MAKEMDSENTRY (IPLUS (LLSH (I.HILOC (I.VAG2 6 2560)) 8) (LRSH (I.LOLOC (I.VAG2 6 2560)) 8)) (LOGOR 32768 8192 4096 2048 2)))
+)
+
+(I.INITDATATYPES
+(LAMBDA NIL (*) (*) (LET ((NSYSTYPES (LENGTH INITIALDTDCONTENTS))) (I.CREATEPAGES (I.VAG2 6 4096) 1 NIL T) (*) (I.CREATEPAGES (I.ADDBASE (I.VAG2 6 4096) 256) (SUB1 (LRSH (IPLUS (ADD1 (TIMES (ADD1 NSYSTYPES) 18)) 255) 8))) (*) (*) (|for| D |in| INITIALDTDCONTENTS |bind| DTD |as| TYPENO |from| 1 |do| (*) (SETQ DTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES TYPENO 18))) (*) (I.PUTBASE DTD 16 (LOGOR TYPENO (COND ((FMEMB (CAR D) (QUOTE (SMALLP FIXP FLOATP))) 4096) (T 0)) (COND ((FMEMB (CAR D) (QUOTE (SMALLP FIXP FLOATP LITATOM NEW-ATOM))) 2048) (T 0)) (COND ((FMEMB (CAR D) (QUOTE (SMALLP FIXP))) 8192) (T 0)) (COND ((EQ (CAR D) (QUOTE NEW-ATOM)) (*) 32768) (T 0)) (COND ((FMEMB (CAR D) (QUOTE (LITATOM NEW-ATOM))) (*) (CONSTANT 16384)) (T 0)) (COND ((NOT (CADR D)) (*) 32768) (T 0)))) (*) (COND ((EQ (CAR D) (QUOTE NEW-ATOM)) (*) (I.PUTBASE DTD 17 4))) (COND ((AND (CAR D) (CADR D)) (*) (I.PUTBASE DTD 3 (CADR D))))) (COND ((NEQ 1 0) (SETQ I.LISTPDTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES 5 18))))) (SETQ |I.MaxSysTypeNum| (SETQ |I.MaxTypeNumber| NSYSTYPES)) NIL))
+)
+
+(I.INITDATATYPENAMES
+(LAMBDA NIL (*) (*) (*) (SETQ I.FINALIZATION.FUNCTIONS (I.\\ALLOCBLOCK (ADD1 2047) T)) (|for| D |in| INITIALDTDCONTENTS |as| I.NTYPX |from| 1 |do| (LET ((DTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES I.NTYPX 18))) (FINAL (CADDDR D))) (*) (I.PUTBASEPTR DTD 0 (I.ATOMNUMBER (CAR D))) (*) (I.PUTBASEPTR DTD 10 (I.\\COPY (CADDR D))) (*) (|if| FINAL |then| (*) (NEQ (LOGAND (LRSH (I.PUTBASE DTD 0 (LOGOR (LOGAND (I.GETBASE DTD 0) 61439) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 12))) 12) 1) 0) (I.PUTBASEPTR I.FINALIZATION.FUNCTIONS (LLSH I.NTYPX 1) (I.\\COPY FINAL))))) (PROGN (*) (NEQ (LOGAND (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 61439) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 12)))) (I.ADDBASE (I.VAG2 6 4096) (ITIMES 0 18))) 12) 1) 0) (I.PUTBASEPTR I.FINALIZATION.FUNCTIONS 0 (I.\\COPY (QUOTE \\RECLAIMARRAYBLOCK)))))
+)
+)
+
+(RPAQQ \\BUILT-IN-SYSTEM-TYPES ((SMALLP) (FIXP 2) (FLOATP 2) (LITATOM) (LISTP 4 (0 2)) (ARRAYP 6 (0)) (STRINGP 6 (0)) (STACKP 2 NIL \\RECLAIMSTACKP) (CHARACTER) (VMEMPAGEP 256 NIL RELEASINGVMEMPAGE) (STREAM) (BITMAP) (COMPILED-CLOSURE 4 (0 2)) (ONED-ARRAY 8 (0)) (TWOD-ARRAY 10 (0)) (GENERAL-ARRAY 10 (0 8)) (BIGNUM) (RATIO) (COMPLEX) (PATHNAME) (NEW-ATOM 10 (2 4 6)) (FILLER22) (FILLER23) (FILLER24) (FILLER25) (FILLER26) (FILLER27) (FILLER28) (FILLER29) (FILLER30))
+)
+(DEFINEQ
+
+(I.FSETVAL
+(LAMBDA (ATM VAL) (*) (*) (I.PUTBASEPTR (I.\\ATOMCELL ATM 12) 0 VAL)))
+
+(I.SETPROPLIST
+(LAMBDA (ATM LST) (*) (I.PUTBASEPTR (I.\\ATOMCELL ATM (CONSTANT 2)) 0 LST)))
+
+(I.PUTDEFN
+(LAMBDA (FN CA SIZE) (*) (*) (PROG ((DCELL (I.\\ATOMCELL FN 10)) (BLOCKINFO (PROGN (*) (I.FILECODEBLOCK (LRSH (IPLUS SIZE 3) 2) (IPLUS (LOGOR (LLSH (\\BYTELT CA 12) 8) (\\BYTELT CA (ADD1 12))) (PROGN 8))))) (BASE (I.FILEARRAYBASE))) (I.PUTBASEPTR DCELL 0 BASE) (LOGAND (LRSH (I.PUTBASE DCELL 0 (LOGOR (LOGAND (I.GETBASE DCELL 0) 53247) (LLSH (LOGAND (LOGAND (LRSH (\\BYTELT CA 8) 4) 3) 3) 12))) 12) 3) (NEQ (LOGAND (LRSH (I.PUTBASE DCELL 0 (LOGOR (LOGAND (I.GETBASE DCELL 0) 49151) (LLSH (LOGAND (COND ((EQ (LOGOR (LLSH (\\BYTELT CA 12) 8) (\\BYTELT CA (ADD1 12))) 0) 1) (T 0)) 1) 14))) 14) 1) 0) (NEQ (LRSH (I.PUTBASE DCELL 0 (LOGOR (LOGAND (I.GETBASE DCELL 0) 32767) (LLSH (COND (T 1) (T 0)) 15))) 15) 0) (NEQ (LOGAND (LRSH (I.PUTBASE DCELL 4 (LOGOR (LOGAND (I.GETBASE DCELL 4) 65527) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 3))) 3) 1) 0) (COND ((FMEMB FN LOCKEDFNS) (I.\\LOCKCELL DCELL 1) (I.\\LOCKCELL BASE (LRSH (IPLUS (IPLUS (LOGAND (I.LOLOC BASE) 255) (LRSH (IPLUS SIZE 1) 1)) 255) 8)))) (COND ((EQ FN (FUNCTION \\RESETSTACK)) (*) (SETQ RESETPTR (I.FILEARRAYBASE)) (SETQ RESETPC (LOGOR (LLSH (\\BYTELT CA 6) 8) (\\BYTELT CA (ADD1 6)))))) (AOUT CA 0 SIZE OUTX (QUOTE CODE)) (BOUTZEROS (IDIFFERENCE (SUB1 4) (IMOD (SUB1 SIZE) 4))) (I.FILEBLOCKTRAILER BLOCKINFO)))
+)
+
+(I.\\BLT
+(LAMBDA (DBASE SBASE NWORDS) (*) (*) (PROG ((NN (CONSTANT (EXPT 2 14)))) (RETURN (COND ((GREATERP NWORDS NN) (*) (I.\\BLT (I.ADDBASE DBASE NN) (I.ADDBASE SBASE NN) (DIFFERENCE NWORDS NN)) (I.\\BLT DBASE SBASE NN)) (T (|for| I |from| (SUB1 NWORDS) |by| -1 |to| 0 |do| (I.PUTBASE DBASE I (I.GETBASE SBASE I))) DBASE)))))
+)
+)
+(DEFINEQ
+
+(I.\\MKATOM
+(LAMBDA (BASE OFFST LEN FATP NONNUMERICP) (*) (PROG ((FATCHARSEENP (AND FATP (NOT (NULL (|for| I |from| OFFST |to| (SUB1 (IPLUS OFFST LEN)) |suchthat| (IGREATERP (I.GETBASE BASE I) 255)))))) HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE) (*) (COND ((EQ LEN 0) (*) (SETQ HASH 0) (SETQ FIRSTBYTE 255) (GO LP))) (SETQ FIRSTCHAR (COND (FATP (I.GETBASE BASE OFFST)) (T (I.\\GETBASEBYTE BASE OFFST)))) (*) (COND ((AND (EQ LEN 1) (ILEQ FIRSTCHAR 255) |I.OneCharAtomBase|) (*) (RETURN (COND ((IGREATERP FIRSTCHAR (CHARCODE "9")) (I.ADDBASE |I.OneCharAtomBase| (IDIFFERENCE FIRSTCHAR 10))) ((IGEQ FIRSTCHAR (CHARCODE "0")) (*) (IDIFFERENCE FIRSTCHAR (CHARCODE "0"))) (T (I.ADDBASE |I.OneCharAtomBase| FIRSTCHAR))))) ((AND (NOT NONNUMERICP) (ILEQ FIRSTCHAR (CHARCODE "9")) (SETQ HASHENT (NILL BASE OFFST LEN FATP 10 \\ORIGREADTABLE))) (*) (RETURN HASHENT))) (*) (SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255)) (*) (PROGN (*) (SETQ HASH (LLSH FIRSTBYTE 8)) (|for| CHAR# |from| (ADD1 OFFST) |to| (SUB1 (IPLUS OFFST LEN)) |do| (SETQ HASH (IPLUS16 (IPLUS16 (SETQ HASH (IPLUS16 HASH (LLSH (LOGAND HASH 4095) 2))) (LLSH (LOGAND HASH 255) 8)) (COND (FATP (LOGAND (I.GETBASE BASE CHAR#) 255)) (T (I.\\GETBASEBYTE BASE CHAR#))))))) (*) LP (*) (COND ((NEQ 0 (SETQ HASHENT (I.GETBASE (I.VAG2 7 0) HASH))) (*) (COND ((AND (EQ (LRSH (I.GETBASE (SETQ PNBASE ((LAMBDA ($$1) (I.GETBASEPTR (COND ((AND (FIXP (PROGN $$1)) (ILESSP $$1 65535)) (I.ADDBASE (I.VAG2 8 0) (IPLUS 0 (ITIMES 10 (PROGN $$1))))) (T (I.ADDBASE (PROGN $$1) 0))) 0)) (SETQ ATM# (SUB1 HASHENT)))) 0) 8) LEN) (EQ FATCHARSEENP (AND (PROG1 (EQ 0 (LOGAND (I.GETBASE PNBASE 0) 255)) (*)) (NEQ 0 (LOGAND (LRSH (I.GETBASE (I.\\ATOMCELL (PROGN (I.ADDBASE (I.VAG2 0 0) ATM#)) (CONSTANT 2)) 3) 13) 1)))) (COND (FATCHARSEENP (*) (|for| B1 |from| 1 |to| LEN |as| B2 |from| OFFST |always| (*) (EQ (I.GETBASE PNBASE B1) (I.GETBASE BASE B2)))) (FATP (*) (|for| B1 |from| 1 |to| LEN |as| B2 |from| OFFST |always| (EQ (I.\\GETBASEBYTE PNBASE B1) (I.GETBASE BASE B2)))) (T (*) (|for| B1 |from| 1 |to| LEN |as| B2 |from| OFFST |always| (EQ (I.\\GETBASEBYTE PNBASE B1) (I.\\GETBASEBYTE BASE B2)))))) (RETURN (I.ADDBASE (I.VAG2 0 0) ATM#))) (T (*) (SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (LOGAND 63 (LOGOR 1 (LOGXOR FIRSTBYTE HASH))))))) (GO LP))))) (*) (RETURN (PROGN (LET ((NEWATOM (I.\\CREATE.SYMBOL BASE OFFST LEN FATP FATCHARSEENP))) (I.PUTBASE (I.VAG2 7 0) HASH (ADD1 (I.ATOMNUMBER NEWATOM))) NEWATOM)))))
+)
+
+(I.\\CREATE.SYMBOL
+(LAMBDA (BASE OFFSET LEN FATP FATCHARSEENP) (*) (*) (*) (LET ((PNBASE (I.\\ALLOCBLOCK (COND (FATCHARSEENP (*) (LRSH (IPLUS (ADD1 LEN) 1) 1)) (T (*) (LRSH (IPLUS (ADD1 LEN) 3) 2))))) PB CPP ATM) (COND ((IGEQ (SETQ ATM |I.AtomFrLst|) 12287) (*) (IGEQ (SETQ ATM |I.AtomFrLst|) 65535) (*) (*) (*) (SETQ ATM (I.\\CREATECELL 21)) (I.PUTBASEPTR (COND ((AND (FIXP ATM) (ILESSP ATM 65535)) ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) (I.VAG2 8 0) (IPLUS 2 (ITIMES 10 ATM)))) (T (I.ADDBASE ATM 2))) 0 (QUOTE NOBIND))) ((EVENP ATM 256) (*) (*) (EVENP ATM 512) (*) (*) (LET ((PN (ITIMES 10 (LRSH ATM 8)))) (COND ((NEW-SYMBOL-CODE NIL (IGEQ PN (IDIFFERENCE 255 1))) (*) (NILL))) (I.\\MAKEMDSENTRY (LRSH ATM 8) (LOGOR 32768 16384 2048 4)) (*) (I.\\INITATOMPAGE PN) (*)))) ((LAMBDA (DATUMA0064) (DECLARE (LOCALVARS DATUMA0064)) (PROGN (I.PUTBASE DATUMA0064 0 (LOGOR (LOGAND 61440 (I.GETBASE DATUMA0064 0)) (LOGAND (I.HILOC PNBASE) 4095))) (I.PUTBASE DATUMA0064 (ADD1 0) (I.LOLOC PNBASE)) PNBASE)) (COND ((AND (FIXP ATM) (ILESSP ATM 65535)) (I.ADDBASE (I.VAG2 8 0) (IPLUS 0 (ITIMES 10 ATM)))) (T (I.ADDBASE ATM 0)))) (*) (COND (FATCHARSEENP (I.\\BLT (I.ADDBASE PNBASE 1) (I.ADDBASE BASE OFFSET) LEN)) (FATP (|for| I |from| OFFSET |as| J |from| 1 |to| LEN |do| (I.\\PUTBASEBYTE PNBASE J (I.GETBASE BASE I)))) (T (I.\\MOVEBYTES BASE OFFSET PNBASE 1 LEN))) (LRSH (I.PUTBASE PNBASE 0 (LOGOR (LOGAND (I.GETBASE PNBASE 0) 255) (LLSH LEN 8))) 8) (COND ((NOT T) (*) (PROGN PNBASE))) (SETQ |I.AtomFrLst| (ADD1 |I.AtomFrLst|)) (*) (AND (FIXP ATM) (SETQ ATM (I.ADDBASE (I.VAG2 0 0) ATM))) (COND (FATCHARSEENP (NEQ (LOGAND (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 3 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 3) 57343) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 13)))) (I.\\ATOMCELL ATM (CONSTANT 2))) 13) 1) 0))) ATM))
+)
+
+(I.\\INITATOMPAGE
+(LAMBDA (PN) (*) (COND (NIL (PROG ((OFFSET (LLSH PN 8)) VALBASE) (*) (*) (I.\\NEW4PAGE (I.ADDBASE (I.ADDBASE (I.VAG2 8 0) OFFSET) OFFSET)) (I.\\NEW4PAGE (I.ADDBASE (I.ADDBASE (I.VAG2 10 0) OFFSET) OFFSET)) (I.\\NEW4PAGE (I.ADDBASE (I.ADDBASE (I.VAG2 2 0) OFFSET) OFFSET)) (I.\\NEW4PAGE (SETQ VALBASE (I.ADDBASE (I.ADDBASE (I.VAG2 12 0) OFFSET) OFFSET))) (FRPTQ (ITIMES 128 4) (*) (I.PUTBASEPTR VALBASE 0 (I.\\COPY (QUOTE NOBIND))) (SETQ VALBASE (I.ADDBASE VALBASE 2))))) (T (*) (LET ((OFFSET (LLSH PN 8)) (ATM (LLSH (IQUOTIENT PN 10) 8)) VALBASE) (*) (FOR I FROM 0 TO 9 AS OFF FROM OFFSET BY 256 DO (MKI.NEWPAGE (I.ADDBASE (I.VAG2 8 0) OFF))) (*) (FOR I FROM 0 TO 255 AS OFF FROM OFFSET BY 10 DO (I.PUTBASEPTR (I.VAG2 8 0) (IPLUS OFF 2) (QUOTE NOBIND)))))))
+)
+
+(I.\\MOVEBYTES
+(LAMBDA (SBASE SBYTE DBASE DBYTE NBYTES) (*) (*) (COND ((IGREATERP NBYTES 0) (PROG ((SB (I.ADDBASE SBASE (LRSH SBYTE 1))) (DB (I.ADDBASE DBASE (LRSH DBYTE 1))) SBN DBN NWORDS) (COND ((EQ (SETQ SBN (IMOD SBYTE 2)) (SETQ DBN (IMOD DBYTE 2))) (*) (COND ((EQ SBN 1) (I.\\PUTBASEBYTE DB 1 (I.\\GETBASEBYTE SB 1)) (SETQ DB (I.ADDBASE DB 1)) (SETQ SB (I.ADDBASE SB 1)) (SETQ NBYTES (PLUS NBYTES -1)))) (I.\\BLT DB SB (SETQ NWORDS (LRSH NBYTES 1))) (COND ((EQ (IMOD NBYTES 2) 1) (I.\\PUTBASEBYTE (I.ADDBASE DB NWORDS) 0 (I.\\GETBASEBYTE (I.ADDBASE SB NWORDS) 0))))) (T (FRPTQ NBYTES (I.\\PUTBASEBYTE DB (PROG1 DBN (SETQ DBN (PLUS DBN 1))) (I.\\GETBASEBYTE SB (PROG1 SBN (SETQ SBN (PLUS SBN 1))))))))))))
+)
+
+(I.\\STKMIN
+(LAMBDA (CODE CODEISBLOCK PRINT) (DECLARE (LOCALVARS)) (*) (*) (*) (PROGN (* |;;| "can be run renamed but will work on local space.") (|if| (NOT \\OPSTACKEFFECT) |then| (SETQ \\OPSTACKEFFECT (\\ALLOCBLOCK (FOLDHI 256 BYTESPERCELL))) (SETQ \\OPLENGTH (\\ALLOCBLOCK (FOLDHI 256 BYTESPERCELL))) (|for| I |from| 0 |to| 255 |do| (\\PUTBASEBYTE \\OPSTACKEFFECT I (- 2 (LET ((OP (\\FINDOP I)) LEVADJ) (SELECTQ (|fetch| (OPCODE OPCODENAME) OP) ((FN0 FN1 FN2 FN3 FN4 FNX SWAP NOP APPLYFN RETURN) 2) ((UNBIND DUNBIND UNWIND POP.N) -1) ((BIND SUBRCALL MISCN) 1) (OR (NUMBERP (|if| (LISTP (SETQ LEVADJ (|fetch| (OPCODE LEVADJ) OP))) |then| (SETQ LEVADJ (CAR LEVADJ)) |else| LEVADJ)) (SELECTQ LEVADJ ((CJUMP NCJUMP) (* \; "these only check if they jump") -1) ((JUMP) 2) (PROGN 2)))))))) (|for| I |from| 0 |to| 255 |do| (\\PUTBASEBYTE \\OPLENGTH I (ADD1 (OR (CADDR (\\FINDOP I)) -1))))) (IF (NOT CODEISBLOCK) THEN (SETQ CODE (OR (\\GET-COMPILED-CODE-BASE CODE) (|fetch| (ARRAYP BASE) CODE)))) (LLSH (PROG (MAX OP STKE (PC (|fetch| (FNHEADER STARTPC) CODE)) (DEPTH (IPLUS (IMAX (|fetch| (FNHEADER NA) |of| CODE) 0) 8 (UNFOLD (ADD1 (|fetch| (FNHEADER PV) |of| CODE)) CELLSPERQUAD) 4))) (SETQ MAX (PLUS DEPTH 8)) (* |;;| "this PROG computes the depth in cells. The llsh around converts it to D-machine words.") (* |;;| "the initial maximum is the actual size of the frame, plus 4 extra cells for space to store info in case of an overflow. The default maximum is 8 more than that. By walking the code, it finds if there are any other runs that would increase it beyond that. At jumps or \"Maiko check\" opcodes, the depth is reset to 0.  ") LP (|if| (EQ 0 (SETQ OP (\\GETBASEBYTE CODE PC))) |then| (* |;;| "end of the function") (RETURN MAX)) (* |;;| "the following is for debugging") (AND PRINT (CL:FORMAT T "~%~3o: ~3o d<~3d> mx<~3d>" PC OP DEPTH MAX)) (SELECTQ (SETQ STKE (- 2 (\\GETBASEBYTE \\OPSTACKEFFECT OP))) (2 (* |;;| "special code indicating that this opcode checks the stack level") (AND PRINT (PRIN1 "*")) (SETQ DEPTH 0)) (|add| DEPTH STKE)) (|if| (GREATERP DEPTH MAX) |then| (SETQ MAX DEPTH)) (CL:INCF PC (\\GETBASEBYTE \\OPLENGTH OP)) (GO LP)) 1)))
+)
+)
+(DEFINEQ
+
+(I.COPYATOM
+(LAMBDA (X) (*) (*) (LET ((PKG (CL:SYMBOL-PACKAGE X))) (* \; "SYMBOL-PACKAGE and *INTERLISP-PACKAGE* both NIL in non-package world") (COND ((EQ PKG *INTERLISP-PACKAGE*)) ((NULL PKG) (* \; "This is an uninterned symbol, so add  prefix.") (SETQ X (CONCAT "" X))) ((EQ PKG *KEYWORD-PACKAGE*) (* \; "keywords eval to self, so also set top val") (MKI.DSET X X) (SETQ X (CONCAT ":" X))) (T (* |;;| "Kludge time.  We don't yet have the machinery to create packages in the init.sysout, so anything that isn't an Interlisp symbol has to be turned into a flat-space symbol with appropriate prefix") (CL:MULTIPLE-VALUE-BIND (SYM WHERE) (CL:FIND-SYMBOL (CL:SYMBOL-NAME X) PKG) (SETQ WHERE (SELECTQ WHERE (:INTERNAL "::") (:EXTERNAL ":") (ERROR "Where is this symbol?" X))) (COND ((EQ PKG *LISP-PACKAGE*) (SETQ SYM "LISP")) ((EQ PKG *COMMON-LISP-PACKAGE*) (SETQ SYM "CL")) ((CL:STRING= (CL:PACKAGE-NAME PKG) "SYSTEM") (SETQ SYM "SI")) ((CL:STRING= (CL:PACKAGE-NAME PKG) "CONDITIONS") (SETQ SYM "CONDITIONS")) ((CL:STRING= (CL:PACKAGE-NAME PKG) "XEROX-COMMON-LISP") (SETQ SYM "XCL")) ((CL:STRING= (CL:PACKAGE-NAME PKG) "COMPILER") (SETQ SYM "COMPILER")) ((CL:STRING= (CL:PACKAGE-NAME PKG) "FASL") (SETQ SYM "FASL")) (T (HELP "Can only translate symbols in IL, CL, XCL, CONDITIONS, SI, COMPILER, FASL and keywords" X))) (SETQ X (CONCAT SYM WHERE (CL:SYMBOL-NAME X))))))) (LET ((N (NCHARS X)) (BASE (COND ((NEQ 0 (LOGAND (LRSH (I.GETBASE I.SCRATCHSTRING 2) 14) 1)) (%ARRAY-BASE I.SCRATCHSTRING)) (T (I.GETBASEPTR I.SCRATCHSTRING 0)))) (OFFST (COND ((NEQ 0 (LOGAND (LRSH (I.GETBASE I.SCRATCHSTRING 2) 14) 1)) (%ARRAY-OFFSET I.SCRATCHSTRING)) (T (I.GETBASE I.SCRATCHSTRING 3))))) (*) (|for| I |from| 1 |to| N |do| (I.\\PUTBASEBYTE BASE (IPLUS OFFST I -1) (NTHCHARCODE X I))) (I.ATOMNUMBER (I.\\MKATOM BASE OFFST N))))
+)
+
+(I.INITATOMS
+(LAMBDA NIL (*) (*) (I.CREATEPAGES (I.VAG2 7 0) 256) (SETQ I.SCRATCHSTRING (I.ALLOCSTRING 255)) (*) (*) (I.COPYATOM NIL) (*) (I.COPYATOM (QUOTE NOBIND)) (*) (*) (|for| C |from| 0 |to| 255 |when| (OR (ILESSP C (CHARCODE 0)) (IGREATERP C (CHARCODE 9))) |do| (I.COPYATOM (CHARACTER C))) (SETQ |I.OneCharAtomBase| (I.ADDBASE (I.VAG2 0 0) 2)) (*) (I.COPYATOM (FUNCTION \\EVALFORM)) (*) (I.COPYATOM (FUNCTION \\GC.HANDLEOVERFLOW)) (*) (I.COPYATOM (FUNCTION \\DTEST.UFN)) (*) (I.COPYATOM (FUNCTION \\OVERFLOWMAKENUMBER)) (*) (I.COPYATOM (FUNCTION \\MAKENUMBER)) (*) (I.COPYATOM (FUNCTION \\SETGLOBAL.UFN)) (*) (I.COPYATOM (FUNCTION \\SETFVAR.UFN)) (*) (I.COPYATOM (FUNCTION \\GCMAPTABLE)) (*) (I.COPYATOM (FUNCTION \\INTERPRETER)) (*) (OR (EQ (I.ATOMNUMBER (FUNCTION \\INTERPRETER)) 256) (HELP (FUNCTION \\INTERPRETER) " not atom 400Q")))
+)
+)
+(DEFINEQ
+
+(I.MAKEINITFIRST
+(LAMBDA NIL (*) (I.CREATEMDSTYPETABLE) (I.\\SETUP.HUNK.TYPENUMBERS) (I.INITDATATYPES) (I.PREINITARRAYS) (I.\\TURN.ON.HUNKING) (I.INITATOMS) (I.INITDATATYPENAMES) (I.INITUFNTABLE) (I.INITGC) (MKI.NEWPAGE (I.VAG2 6 0) NIL T))
+)
+
+(I.\\COPY
+(LAMBDA (X) (*) (*) (SELECTQ (TYPENAME X) ((LITATOM NEW-ATOM) (MKI.ATOM X)) (LISTP (PROG ((R (REVERSE X)) (V (I.\\COPY (CDR (LAST X))))) LP (COND ((LISTP R) (SETQ V (I.\\CONS.UFN (I.\\COPY (CAR R)) V)) (SETQ R (CDR R)) (GO LP))) (RETURN V))) ((FIXP SMALLP) (PROG (V) (COND ((IGREATERP 0 X) (*) (COND ((IGREATERP X -65537) (*) (RETURN (I.ADDBASE (I.VAG2 15 0) (LOGAND X 65535)))))) ((ILESSP X 65536) (*) (RETURN (I.ADDBASE (I.VAG2 14 0) X)))) (*) (SETQ V (I.\\CREATECELL 2)) (I.PUTBASE V 0 (LOGOR (COND ((IGREATERP 0 X) 32768) (T 0)) (LOGAND (LRSH X 16) 32767))) (I.PUTBASE V 1 (LOGAND X 65535)) (RETURN V))) (ONED-ARRAY (I.%COPY-ONED-ARRAY X)) (STRINGP (*) (I.%COPY-STRING-TO-ARRAY X)) (FLOATP (PROG ((VAL (I.\\CREATECELL 3))) (SELECTQ (SYSTEMTYPE) ((ALTO D) (I.PUTBASE VAL 0 (\\GETBASE X 0)) (I.PUTBASE VAL 1 (\\GETBASE X 1))) (MKI.IEEE X VAL)) (RETURN VAL))) (CHARACTER (I.VAG2 7 (CL:CHAR-CODE X))) (ERROR X "can't be copied to remote file")))
+)
+
+(I.MAKEINITLAST
+(LAMBDA (VERSIONS) (*) (I.SETUPSTACK T) (I.MAKEINITBFS) (PROGN (*) (SELECTQ (SYSTEMTYPE) ((D ALTO) (MAPHASH MKI.PLHA (FUNCTION (LAMBDA (P A) (I.SETPROPLIST A (I.\\COPY P))))) (MAPHASH MKI.TVHA (FUNCTION (LAMBDA (V A) (I.FSETVAL A (I.\\COPY (CDR V))))))) (PROG (AL GAG) (*) (PROGN (MINFS (IMAX (MINFS) (ITIMES 2 (ARRAYSIZE (CAR MKI.PLHA))) (ARRAYSIZE (CAR MKI.TVHA)))) (RECLAIM) (SETQ GAG (GCGAG "[***** GARBAGE COLLECTION - ERROR ******]")) (MAPHASH MKI.PLHA (FUNCTION (LAMBDA (P A) (|push| AL (CONS A P))))) (SETQ GAG (GCGAG GAG))) (MAPC AL (FUNCTION (LAMBDA (X) (I.SETPROPLIST (CAR X) (I.\\COPY (CDR X)))))) (PROGN (SETQ AL) (RECLAIM) (SETQ GAG (GCGAG GAG)) (MAPHASH MKI.TVHA (FUNCTION (LAMBDA (V A) (|push| AL (RPLACA V A))))) (GCGAG GAG)) (MAPC AL (FUNCTION (LAMBDA (X) (I.FSETVAL (CAR X) (I.\\COPY (CDR X)))))))) (*)) (PROG ((AFL (I.FILEARRAYBASE))) (*) (BOUTZEROS (IDIFFERENCE (TIMES 2 512) (LLSH (IMOD (I.LOLOC AFL) (TIMES 2 256)) 1))) (SETQ MKI.CODELASTPAGE ((LAMBDA (PTR) (DECLARE (LOCALVARS PTR)) (IPLUS (LLSH (I.HILOC PTR) 8) (LRSH (I.LOLOC PTR) 8))) (I.FILEARRAYBASE))) (*) (I.POSTINITARRAYS AFL (IPLUS 5888 MKI.CODESTARTOFFSET) MKI.CODELASTPAGE)) (MAPC (APPEND INITVALUES INITPTRS) (FUNCTION (LAMBDA (X) (*) (I.ATOMNUMBER (CAR X))))) (|for| X |in| INITVALUES |as| A |in| MKI.VALUES |do| (SETQ A (EVALV A)) (I.FSETVAL (CAR X) (COND ((OR (EQ A T) (EQ A NIL) (AND (FIXP A) (IGEQ A -65536) (ILEQ A 65535))) (I.\\COPY A)) (T (SHOULDNT))))) (|for| X |in| INITPTRS |as| A |in| MKI.PTRS |do| (I.FSETVAL (CAR X) (EVALV A))) (|for| X |in| LOCKEDVARS |do| (*) (IF (GETHASH X MKI.ATOMARRAY) THEN (I.\\LOCKVAR X) ELSE (|printout| T "***Note: Locked var " X " does not exist, proceeding anyway." T))) (I.SETUPPAGEMAP) (I.DUMPINITPAGES (IPLUS 5888 MKI.CODESTARTOFFSET) MKI.CODELASTPAGE VERSIONS))
+)
+)
+(DEFINEQ
+
+(I.\\CONS.UFN
+(LAMBDA (X Y) (*) (COND ((ZEROP 1) (HELP) (PROG ((CELL (I.\\CREATECELL 5))) (I.PUTBASEPTR CELL 0 X) (I.PUTBASEPTR CELL 2 Y) (RETURN CELL)))) (PROGN (PROGN X) (PROGN Y) (*) (PROGN 1) (PROG (CNS.PAGE CELL) (SETQ CNS.PAGE (COND ((NOT Y) (COND ((AND (SETQ CNS.PAGE ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 (I.GETBASEFIXP I.LISTPDTD 14)) 8) (LLSH (LOGAND $$1 255) 8))) NIL)) (IGREATERP (LRSH (I.GETBASE CNS.PAGE 0) 8) 0))) (T (SETQ CNS.PAGE (I.\\NEXTCONSPAGE)))) (PROG ((.MK.NEWCELL (I.ADDBASE CNS.PAGE (LOGAND (I.GETBASE CNS.PAGE 0) 255)))) (*) (LOGAND (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 65280) (LOGAND (LRSH (I.GETBASE .MK.NEWCELL 0) 8) 255))) 255) (*) (LRSH (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE CNS.PAGE 0) 8)) -1) 8))) 8) (I.PUTBASEPTR .MK.NEWCELL 0 X) (LRSH (I.PUTBASE .MK.NEWCELL 0 (LOGOR (LOGAND (I.GETBASE .MK.NEWCELL 0) 4095) (LLSH 8 12))) 12) (RETURN .MK.NEWCELL))) ((AND (EQ (I.NTYPX Y) 5) (IGREATERP (LRSH (I.GETBASE (SETQ CNS.PAGE (I.VAG2 (I.HILOC Y) (LOGAND (I.LOLOC Y) 65280))) 0) 8) 0) (SETQ CELL (LET ((CDROFFSET (LOGAND (I.LOLOC Y) 255)) (OFFSET (LOGAND (I.GETBASE CNS.PAGE 0) 255)) CELL PRIOR) (WHILE (NEQ OFFSET 0) DO (COND ((AND (ILEQ OFFSET CDROFFSET) (IGEQ OFFSET (IDIFFERENCE CDROFFSET 14))) (*) (COND (PRIOR (*) (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 255) (LLSH (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE CNS.PAGE OFFSET)) 0) 8) 8)))) (I.ADDBASE CNS.PAGE PRIOR)) 8)) (T (*) (LOGAND (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 65280) (LOGAND (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE CNS.PAGE OFFSET)) 0) 8) 255))) 255))) (LRSH (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE CNS.PAGE 0) 8)) -1) 8))) 8) (I.PUTBASEPTR CELL 0 X) (LRSH (I.PUTBASE CELL 0 (LOGOR (LOGAND (I.GETBASE CELL 0) 4095) (LLSH (LOGOR 8 (LRSH (IDIFFERENCE CDROFFSET OFFSET) 1)) 12))) 12) (RETURN CELL))) (SETQ PRIOR OFFSET) (SETQ OFFSET (LRSH (I.GETBASE (I.ADDBASE CNS.PAGE OFFSET) 0) 8)))))) (*) (*) CELL) (T (LET ((PG (I.GETBASEFIXP I.LISTPDTD 14)) CELL CPG) (WHILE (IGREATERP PG 0) DO (COND ((SETQ CELL ((LAMBDA (PGA0065) (DECLARE (LOCALVARS PGA0065)) (LET ((OFFSET (LOGAND (I.GETBASE PGA0065 0) 255)) CELL PRIOR PRIORPRIOR) (AND (IGEQ (LRSH (I.GETBASE PGA0065 0) 8) 2) (WHILE (NEQ OFFSET 0) DO (COND ((AND PRIOR (ILEQ OFFSET PRIOR) (IGEQ OFFSET (IDIFFERENCE PRIOR 14))) (*) (COND (PRIORPRIOR (*) (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 255) (LLSH (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE PGA0065 OFFSET)) 0) 8) 8)))) (I.ADDBASE PGA0065 PRIORPRIOR)) 8)) (T (*) (LOGAND (I.PUTBASE PGA0065 0 (LOGOR (LOGAND (I.GETBASE PGA0065 0) 65280) (LOGAND (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE PGA0065 OFFSET)) 0) 8) 255))) 255))) (LRSH (I.PUTBASE PGA0065 0 (LOGOR (LOGAND (I.GETBASE PGA0065 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE PGA0065 0) 8)) -2) 8))) 8) (I.PUTBASEPTR (I.ADDBASE PGA0065 PRIOR) 0 Y) (I.PUTBASEPTR CELL 0 X) (LRSH (I.PUTBASE CELL 0 (LOGOR (LOGAND (I.GETBASE CELL 0) 4095) (LLSH (LRSH (IDIFFERENCE PRIOR OFFSET) 1) 12))) 12) (RETURN CELL))) (SETQ PRIORPRIOR PRIOR) (SETQ PRIOR OFFSET) (SETQ OFFSET (LRSH (I.GETBASE (I.ADDBASE PGA0065 OFFSET) 0) 8)))))) (SETQ CPG ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 PG) 8) (LLSH (LOGAND $$1 255) 8))) NIL)))) (RETURN CELL)) (T (SETQ PG (I.GETBASEFIXP CPG 2))))) (OR CELL ((LAMBDA (PGA0066) (DECLARE (LOCALVARS PGA0066)) (LET ((OFFSET (LOGAND (I.GETBASE PGA0066 0) 255)) CELL PRIOR PRIORPRIOR) (AND (IGEQ (LRSH (I.GETBASE PGA0066 0) 8) 2) (WHILE (NEQ OFFSET 0) DO (COND ((AND PRIOR (ILEQ OFFSET PRIOR) (IGEQ OFFSET (IDIFFERENCE PRIOR 14))) (*) (COND (PRIORPRIOR (*) (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 255) (LLSH (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE PGA0066 OFFSET)) 0) 8) 8)))) (I.ADDBASE PGA0066 PRIORPRIOR)) 8)) (T (*) (LOGAND (I.PUTBASE PGA0066 0 (LOGOR (LOGAND (I.GETBASE PGA0066 0) 65280) (LOGAND (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE PGA0066 OFFSET)) 0) 8) 255))) 255))) (LRSH (I.PUTBASE PGA0066 0 (LOGOR (LOGAND (I.GETBASE PGA0066 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE PGA0066 0) 8)) -2) 8))) 8) (I.PUTBASEPTR (I.ADDBASE PGA0066 PRIOR) 0 Y) (I.PUTBASEPTR CELL 0 X) (LRSH (I.PUTBASE CELL 0 (LOGOR (LOGAND (I.GETBASE CELL 0) 4095) (LLSH (LRSH (IDIFFERENCE PRIOR OFFSET) 1) 12))) 12) (RETURN CELL))) (SETQ PRIORPRIOR PRIOR) (SETQ PRIOR OFFSET) (SETQ OFFSET (LRSH (I.GETBASE (I.ADDBASE PGA0066 OFFSET) 0) 8)))))) (I.\\NEXTCONSPAGE))))))) (PROGN CNS.PAGE) (RETURN CNS.PAGE))))
+)
+
+(I.\\MAIKO.CONS.UFN
+(LAMBDA (X Y) (*) (*) (COND ((ZEROP 1) (HELP) (PROG ((CELL (I.\\CREATECELL 5))) (I.PUTBASEPTR CELL 0 X) (I.PUTBASEPTR CELL 2 Y) (RETURN CELL)))) (PROGN (PROGN X) (PROGN Y) (*) (PROGN 1) (PROG (CNS.PAGE) (SETQ CNS.PAGE (COND ((AND (EQ (I.NTYPX Y) 5) (IGREATERP (LRSH (I.GETBASE (SETQ CNS.PAGE (I.VAG2 (I.HILOC Y) (LOGAND (I.LOLOC Y) 65280))) 0) 8) 0)) (*) ((LAMBDA (PAGE A D) (DECLARE (LOCALVARS PAGE A D)) (PROG ((.MK.NEWCELL (I.ADDBASE PAGE (LOGAND (I.GETBASE PAGE 0) 255)))) (*) (LOGAND (I.PUTBASE PAGE 0 (LOGOR (LOGAND (I.GETBASE PAGE 0) 65280) (LOGAND (LRSH (I.GETBASE .MK.NEWCELL 0) 8) 255))) 255) (*) (LRSH (I.PUTBASE PAGE 0 (LOGOR (LOGAND (I.GETBASE PAGE 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE PAGE 0) 8)) -1) 8))) 8) (I.PUTBASEPTR .MK.NEWCELL 0 A) (LRSH (I.PUTBASE .MK.NEWCELL 0 (LOGOR (LOGAND (I.GETBASE .MK.NEWCELL 0) 4095) (LLSH D 12))) 12) (RETURN .MK.NEWCELL))) CNS.PAGE X (IPLUS 8 (LRSH (LOGAND (I.LOLOC Y) 255) 1)))) (T ((LAMBDA (PAGE A D) (DECLARE (LOCALVARS PAGE A D)) (PROG ((.MK.NEWCELL (I.ADDBASE PAGE (LOGAND (I.GETBASE PAGE 0) 255)))) (*) (LOGAND (I.PUTBASE PAGE 0 (LOGOR (LOGAND (I.GETBASE PAGE 0) 65280) (LOGAND (LRSH (I.GETBASE .MK.NEWCELL 0) 8) 255))) 255) (*) (LRSH (I.PUTBASE PAGE 0 (LOGOR (LOGAND (I.GETBASE PAGE 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE PAGE 0) 8)) -1) 8))) 8) (I.PUTBASEPTR .MK.NEWCELL 0 A) (LRSH (I.PUTBASE .MK.NEWCELL 0 (LOGOR (LOGAND (I.GETBASE .MK.NEWCELL 0) 4095) (LLSH D 12))) 12) (RETURN .MK.NEWCELL))) (SETQ CNS.PAGE (I.\\NEXTCONSPAGE)) X (COND ((NULL Y) 8) (T (IPLUS 0 (LRSH (LOGAND (I.LOLOC (PROGN (PROGN (PROGN (PROG ((.MK.NEWCELL (I.ADDBASE CNS.PAGE (LOGAND (I.GETBASE CNS.PAGE 0) 255)))) (*) (LOGAND (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 65280) (LOGAND (LRSH (I.GETBASE .MK.NEWCELL 0) 8) 255))) 255) (*) (LRSH (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE CNS.PAGE 0) 8)) -1) 8))) 8) (I.PUTBASEPTR .MK.NEWCELL 0 Y) (LRSH (I.PUTBASE .MK.NEWCELL 0 (LOGOR (LOGAND (I.GETBASE .MK.NEWCELL 0) 4095) (LLSH 0 12))) 12) (RETURN .MK.NEWCELL)))))) 255) 1)))))))) (PROGN CNS.PAGE) (RETURN CNS.PAGE))))
+)
+
+(I.\\INITCONSPAGE
+(LAMBDA (BASE LINK) (*) (COND ((ZEROP 1) (HELP)) (T (PROG ((J (LOGAND (I.PUTBASE BASE 0 (LOGOR (LOGAND (I.GETBASE BASE 0) 65280) (LOGAND 254 255))) 255)) CELL) LP (COND ((IGREATERP J 4) (SETQ CELL (I.ADDBASE BASE J)) (I.PUTBASEPTR CELL 0 NIL) (LRSH (I.PUTBASE CELL 0 (LOGOR (LOGAND (I.GETBASE CELL 0) 255) (LLSH (SETQ J (IDIFFERENCE J 2)) 8))) 8) (GO LP))) (LRSH (I.PUTBASE BASE 0 (LOGOR (LOGAND (I.GETBASE BASE 0) 255) (LLSH 126 8))) 8) (*) (I.PUTBASEFIXP BASE 2 (IPLUS (LLSH (I.HILOC LINK) 8) (LRSH (I.LOLOC LINK) 8))) (RETURN BASE)))))
+)
+
+(I.\\NEXTCONSPAGE
+(LAMBDA NIL (*) (*) (PROG ((N (I.GETBASEFIXP I.LISTPDTD 14)) PG) (SETQ PG (I.\\ALLOCMDSPAGE (I.GETBASE I.LISTPDTD 16))) (I.\\INITCONSPAGE PG (I.\\INITCONSPAGE (I.ADDBASE PG 256) ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 N) 8) (LLSH (LOGAND $$1 255) 8))) NIL))) (I.PUTBASEFIXP I.LISTPDTD 14 (IPLUS (LLSH (I.HILOC PG) 8) (LRSH (I.LOLOC PG) 8))) (RETURN PG)))
+)
+)
+(DEFINEQ
+
+(I.\\GETBASEBYTE
+(LAMBDA (PTR N) (*) (*) (COND ((EVENP N) (LRSH (PROGN (I.GETBASE PTR (LRSH N 1))) 8)) (T (LOGAND (PROGN (I.GETBASE PTR (LRSH N 1))) 255))))
+)
+
+(I.\\PUTBASEBYTE
+(LAMBDA (PTR DISP BYTE) (*) (*) (SETQ BYTE (PROG1 BYTE)) (I.PUTBASE PTR (LRSH (SETQ DISP (\\DTEST DISP (QUOTE SMALLP))) 1) (COND ((EVENP DISP 2) ((LAMBDA ($$1) (IPLUS (LLSH BYTE 8) (LOGAND $$1 255))) (I.GETBASE PTR (LRSH DISP 1)))) (T ((LAMBDA ($$1) (IPLUS (LLSH (LRSH $$1 8) 8) BYTE)) (I.GETBASE PTR (LRSH DISP 1)))))) BYTE)
+)
+
+(I.CREATEPAGES
+(LAMBDA (VA N BLANKFLG LOCKFLG) (*) (*) (|for| I |from| 0 |to| (SUB1 N) |do| (MKI.NEWPAGE (I.ADDBASE VA (LLSH I 8)) NIL LOCKFLG BLANKFLG)) VA)
+)
+
+(I.\\NEW4PAGE
+(LAMBDA (PTR) (*) (*) (MKI.NEWPAGE (I.ADDBASE (MKI.NEWPAGE (I.ADDBASE (MKI.NEWPAGE (I.ADDBASE (MKI.NEWPAGE PTR) 256)) 256)) 256)))
+)
+)
+
+(FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES) CMLARRAY-SUPPORT)
+(DEFINEQ
+
+(I.ALLOCSTRING
+(LAMBDA (N INITCHAR OLD FATFLG) (*) (SETQ N (FIX N)) (*) (COND ((OR (ILESSP N 0) (IGREATERP N 65535)) (LISPERROR "ILLEGAL ARG" N))) (COND ((NULL INITCHAR) (SETQ INITCHAR 0)) ((PROGN (*) (AND (SMALLP INITCHAR) (IGEQ INITCHAR 0)))) (T (SETQ INITCHAR (CHCON1 INITCHAR)))) (LET ((FATP (OR FATFLG (IGREATERP INITCHAR 255))) STRINGBASE) (*) (SETQ STRINGBASE (I.\\ALLOCBLOCK (COND (FATP (LRSH (IPLUS N 1) 1)) (T (LRSH (IPLUS N 3) 2))))) (COND ((STRINGP OLD) (PROGN ((LAMBDA ($$1) (PROG1 (SETQ $$1 (PROGN (NEQ (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 32767) (LLSH (COND (NIL 1) (T 0)) 15))) 15) 0) (PROGN (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 49151) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 14))) 14) 1) 0) (I.PUTBASEPTR OLD 0 NIL) NIL) ((LAMBDA (STRING NV) (DECLARE (LOCALVARS STRING NV)) (LET ((%NEW-TYPE-NUMBER (SELECTC NV (0 %THIN-CHAR-TYPENUMBER) (1 %FAT-CHAR-TYPENUMBER) (SHOULDNT "Unknown typ value")))) (COND ((NEQ 0 (LOGAND (LRSH (I.GETBASE STRING 2) 14) 1)) (%SET-ARRAY-TYPE-NUMBER STRING %NEW-TYPE-NUMBER)) (T (LOGAND (I.PUTBASE STRING 2 (LOGOR (LOGAND (I.GETBASE STRING 2) 65280) (LOGAND %NEW-TYPE-NUMBER 255))) 255))))) OLD (PROGN (COND (FATP 1) (T 0)))) ((LAMBDA (STRING NV) (DECLARE (LOCALVARS STRING NV)) (I.PUTBASEFIXP STRING 4 NV) (I.PUTBASEFIXP STRING 6 NV) (COND ((%GENERAL-ARRAY-P STRING) (I.PUTBASEPTR STRING 8 (LIST NV)))) NV) OLD (PROGN N)) (PROGN (COND ((NOT (EQ 0 0)) (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 64511) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 10))) 10) 1) 0))) (COND ((NEQ 0 (LOGAND (LRSH (I.GETBASE OLD 2) 14) 1)) (%SET-ARRAY-OFFSET OLD 0)) (T (I.PUTBASE OLD 3 0)))) (PROGN (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 63487) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 11))) 11) 1) 0) (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 64511) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 10))) 10) 1) 0) (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 65023) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 9))) 9) 1) 0) (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 65279) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 8))) 8) 1) 0)) OLD)) (PROGN (NEQ (LOGAND (LRSH (I.PUTBASE $$1 2 (LOGOR (LOGAND (I.GETBASE $$1 2) 49151) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 14))) 14) 1) 0) (I.PUTBASEPTR $$1 0 STRINGBASE) STRINGBASE))) NIL))) (T (SETQ OLD ((LAMBDA ($$1 $$2) (PROG1 (SETQ $$2 ((LAMBDA (DATUMA0077) (DECLARE (LOCALVARS DATUMA0077)) (PROG1 DATUMA0077 (I.PUTBASEFIXP DATUMA0077 6 $$1))) ((LAMBDA (DATUMA0076 NEWVALUEA0075) (DECLARE (LOCALVARS DATUMA0076 NEWVALUEA0075)) (PROG1 DATUMA0076 (I.PUTBASEFIXP DATUMA0076 4 NEWVALUEA0075))) ((LAMBDA (DATUMA0074) (DECLARE (LOCALVARS DATUMA0074)) (PROG1 DATUMA0074 (I.PUTBASE DATUMA0074 3 0))) ((LAMBDA (DATUMA0073 NEWVALUEA0072) (DECLARE (LOCALVARS DATUMA0073 NEWVALUEA0072)) (PROG1 DATUMA0073 (LOGAND (I.PUTBASE DATUMA0073 2 (LOGOR (LOGAND (I.GETBASE DATUMA0073 2) 65280) (LOGAND NEWVALUEA0072 255))) 255))) ((LAMBDA (DATUMA0071 NEWVALUEA0070) (DECLARE (LOCALVARS DATUMA0071 NEWVALUEA0070)) (PROG1 DATUMA0071 (NEQ (LOGAND (LRSH (I.PUTBASE DATUMA0071 2 (LOGOR (LOGAND (I.GETBASE DATUMA0071 2) 64511) (LLSH (LOGAND (COND (NEWVALUEA0070 1) (T 0)) 1) 10))) 10) 1) 0))) ((LAMBDA (DATUMA0069) (DECLARE (LOCALVARS DATUMA0069)) (PROG1 DATUMA0069 (NEQ (LOGAND (LRSH (I.PUTBASE DATUMA0069 2 (LOGOR (LOGAND (I.GETBASE DATUMA0069 2) 61439) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 12))) 12) 1) 0))) ((LAMBDA (DATUMA0068) (DECLARE (LOCALVARS DATUMA0068)) (PROG1 DATUMA0068 (NEQ (LRSH (I.PUTBASE DATUMA0068 2 (LOGOR (LOGAND (I.GETBASE DATUMA0068 2) 32767) (LLSH (COND (NIL 1) (T 0)) 15))) 15) 0))) ((LAMBDA (DATUMA0067) (DECLARE (LOCALVARS DATUMA0067)) (PROG1 DATUMA0067 (I.PUTBASEPTR DATUMA0067 0 NIL))) (I.\\CREATECELL 14)))) (NOT (EQ 0 0))) (COND ((EQ (COND (FATP 1) (T 0)) 1) %FAT-CHAR-TYPENUMBER) (T %THIN-CHAR-TYPENUMBER)))) (SETQ $$1 N)))) (PROGN (NEQ (LOGAND (LRSH (I.PUTBASE $$2 2 (LOGOR (LOGAND (I.GETBASE $$2 2) 49151) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 14))) 14) 1) 0) (I.PUTBASEPTR $$2 0 STRINGBASE) STRINGBASE))) NIL NIL)))) (COND ((NEQ 0 INITCHAR) (*) (COND (FATP (|for| I |from| 0 |to| (SUB1 N) |do| (I.PUTBASE STRINGBASE I INITCHAR))) (T (|for| I |from| 0 |to| (SUB1 N) |do| (I.\\PUTBASEBYTE STRINGBASE I INITCHAR))))))) OLD)
+)
+
+(I.%COPY-ONED-ARRAY
+(LAMBDA (LOCAL-ARRAY) (*) (PROG ((SIZE (|ffetch| (ONED-ARRAY TOTAL-SIZE) |of| LOCAL-ARRAY)) (BASE (|ffetch| (ONED-ARRAY BASE) |of| LOCAL-ARRAY)) (OFFSET (|ffetch| (ONED-ARRAY OFFSET) |of| LOCAL-ARRAY)) (TYPENUMBER (|ffetch| (ONED-ARRAY TYPE-NUMBER) |of| LOCAL-ARRAY)) NCELLS REMOTE-ARRAY REMOTE-BASE) (|if| (NEQ OFFSET 0) |then| (ERROR "Can't copy an array with non-zero offset")) (|if| (EQ (%TYPENUMBER-TO-GC-TYPE TYPENUMBER) 1) |then| (ERROR "Can't copy pointer arrays")) (SETQ NCELLS (LRSH (IPLUS (ITIMES (IPLUS SIZE OFFSET) (%TYPENUMBER-TO-BITS-PER-ELEMENT TYPENUMBER)) 31) 5)) (SETQ REMOTE-ARRAY ((LAMBDA (DATUMA0087) (DECLARE (LOCALVARS DATUMA0087)) (PROG1 DATUMA0087 (I.PUTBASEFIXP DATUMA0087 6 SIZE))) ((LAMBDA (DATUMA0086 NEWVALUEA0085) (DECLARE (LOCALVARS DATUMA0086 NEWVALUEA0085)) (PROG1 DATUMA0086 (I.PUTBASEFIXP DATUMA0086 4 NEWVALUEA0085))) ((LAMBDA (DATUMA0084) (DECLARE (LOCALVARS DATUMA0084)) (PROG1 DATUMA0084 (LOGAND (I.PUTBASE DATUMA0084 2 (LOGOR (LOGAND (I.GETBASE DATUMA0084 2) 65280) (LOGAND TYPENUMBER 255))) 255))) ((LAMBDA (DATUMA0083 NEWVALUEA0082) (DECLARE (LOCALVARS DATUMA0083 NEWVALUEA0082)) (PROG1 DATUMA0083 (NEQ (LOGAND (LRSH (I.PUTBASE DATUMA0083 2 (LOGOR (LOGAND (I.GETBASE DATUMA0083 2) 65023) (LLSH (LOGAND (COND (NEWVALUEA0082 1) (T 0)) 1) 9))) 9) 1) 0))) ((LAMBDA (DATUMA0081 NEWVALUEA0080) (DECLARE (LOCALVARS DATUMA0081 NEWVALUEA0080)) (PROG1 DATUMA0081 (NEQ (LOGAND (LRSH (I.PUTBASE DATUMA0081 2 (LOGOR (LOGAND (I.GETBASE DATUMA0081 2) 61439) (LLSH (LOGAND (COND (NEWVALUEA0080 1) (T 0)) 1) 12))) 12) 1) 0))) ((LAMBDA (DATUMA0079 NEWVALUEA0078) (DECLARE (LOCALVARS DATUMA0079 NEWVALUEA0078)) (PROG1 DATUMA0079 (I.PUTBASEPTR DATUMA0079 0 NEWVALUEA0078))) (I.\\CREATECELL 14) (I.\\ALLOCBLOCK NCELLS)) (%CHAR-TYPE-P TYPENUMBER)) (NEQ 0 (LOGAND (LRSH (I.GETBASE LOCAL-ARRAY 2) 9) 1)))) (I.GETBASEFIXP LOCAL-ARRAY 4)))) (SETQ REMOTE-BASE (I.GETBASEPTR REMOTE-ARRAY 0)) (|for| I |from| 0 |to| (SUB1 (LLSH NCELLS 1)) |do| (I.PUTBASE REMOTE-BASE I (\\GETBASE BASE I))) (RETURN REMOTE-ARRAY)))
+)
+
+(I.%COPY-STRING-TO-ARRAY
+(LAMBDA (LOCAL-STRING) (*) (*) (PROG ((SIZE (NCHARS LOCAL-STRING)) REMOTE-BASE REMOTE-ARRAY) (SETQ REMOTE-BASE (I.\\ALLOCBLOCK (LRSH (IPLUS (ITIMES SIZE 8) 31) 5))) (SETQ REMOTE-ARRAY ((LAMBDA (DATUMA0092) (DECLARE (LOCALVARS DATUMA0092)) (PROG1 DATUMA0092 (I.PUTBASEFIXP DATUMA0092 6 SIZE))) ((LAMBDA (DATUMA0091) (DECLARE (LOCALVARS DATUMA0091)) (PROG1 DATUMA0091 (I.PUTBASEFIXP DATUMA0091 4 SIZE))) ((LAMBDA (DATUMA0090) (DECLARE (LOCALVARS DATUMA0090)) (PROG1 DATUMA0090 (LOGAND (I.PUTBASE DATUMA0090 2 (LOGOR (LOGAND (I.GETBASE DATUMA0090 2) 65280) (LOGAND 67 255))) 255))) ((LAMBDA (DATUMA0089) (DECLARE (LOCALVARS DATUMA0089)) (PROG1 DATUMA0089 (NEQ (LOGAND (LRSH (I.PUTBASE DATUMA0089 2 (LOGOR (LOGAND (I.GETBASE DATUMA0089 2) 61439) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 12))) 12) 1) 0))) ((LAMBDA (DATUMA0088) (DECLARE (LOCALVARS DATUMA0088)) (PROG1 DATUMA0088 (I.PUTBASEPTR DATUMA0088 0 REMOTE-BASE))) (I.\\CREATECELL 14))))))) (|for| I |from| 0 |to| (SUB1 SIZE) |do| (I.\\PUTBASEBYTE REMOTE-BASE I (NTHCHARCODE LOCAL-STRING (ADD1 I)))) (RETURN REMOTE-ARRAY)))
+)
+)
+(DEFINEQ
+
+(I.\\#BLOCKDATACELLS
+(LAMBDA (DATAWORD) (*) (*) (PROG ((TYPENO (I.NTYPX DATAWORD))) (RETURN (COND ((EQ 0 TYPENO) (COND ((AND (EQ 0 (I.NTYPX DATAWORD)) (IGEQ (I.HILOC DATAWORD) 23)) (IDIFFERENCE (I.GETBASE (I.ADDBASE DATAWORD (IMINUS 2)) 1) 2)) (T (\\ILLEGAL.ARG DATAWORD)))) (T (OR (AND (OR I.HUNKING? (NEQ 0 (LOGAND (LRSH (I.GETBASE (I.ADDBASE (I.VAG2 6 4096) (ITIMES TYPENO 18)) 6) 14) 1))) (LRSH (I.GETBASE (I.ADDBASE (I.VAG2 6 4096) (ITIMES TYPENO 18)) 3) 1)) (\\ILLEGAL.ARG DATAWORD)))))))
+)
+
+(I.\\PREFIXALIGNMENT?
+(LAMBDA (ARLEN INITONPAGE ALIGN GCTYPE BASE) (*) (*) (PROG ((DAT (LRSH (I.LOLOC (PROGN (PROGN (I.ADDBASE BASE 2)))) 1)) (ADJUSTMENT 0) FUDGE) (*) LP (COND ((AND ALIGN (NEQ (SETQ FUDGE (IREMAINDER DAT ALIGN)) 0)) (*) (SETQ ADJUSTMENT (PLUS ADJUSTMENT (SETQ FUDGE (IDIFFERENCE ALIGN FUDGE)))) (SETQ DAT (PLUS DAT FUDGE)))) (COND ((AND INITONPAGE (NEQ (LOGAND DAT (CONSTANT (LOGXOR (SUB1 128) -1))) (LOGAND (IPLUS DAT INITONPAGE -1) (CONSTANT (LOGXOR (SUB1 128) -1))))) (*) (SETQ ADJUSTMENT (PLUS ADJUSTMENT (SETQ FUDGE (IDIFFERENCE 128 (IMOD DAT 128))))) (SETQ DAT (PLUS DAT FUDGE)) (*))) (COND ((AND (EQ GCTYPE 2) (IGREATERP (IDIFFERENCE ARLEN 2) (SETQ FUDGE (IDIFFERENCE 32768 (SETQ DAT (IMOD DAT 32768)))))) (*) (SETQ ADJUSTMENT (PLUS ADJUSTMENT FUDGE)) (SETQ DAT (PLUS DAT FUDGE)) (*))) (*) (RETURN ADJUSTMENT)))
+)
+
+(I.\\ALLOCBLOCK
+(LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN) (*) (*) (DECLARE (GLOBALVARS |I.ArrayFrLst|)) (COND ((ILESSP NCELLS 2) (COND ((ILESSP NCELLS 0) (\\ILLEGAL.ARG NCELLS))) (SETQ NCELLS 2)) ((IGREATERP NCELLS 65533) (\\LISPERROR NCELLS "ARRAY STORAGE BLOCK TOO LARGE"))) (*) (SELECTQ GCTYPE (NIL (SETQ GCTYPE 0)) (T (SETQ GCTYPE 1)) NIL) (*) (COND ((AND INITONPAGE (OR (ILESSP INITONPAGE 0) (IGREATERP INITONPAGE 128))) (\\ILLEGAL.ARG INITONPAGE))) (COND ((NULL ALIGN)) ((OR (ILESSP ALIGN 0) (IGREATERP ALIGN 128)) (\\ILLEGAL.ARG ALIGN)) ((ILEQ ALIGN 1) (SETQ ALIGN)) ((AND INITONPAGE (PROGN (*) NIL)) (ERROR "INITONPAGE and ALIGN too high"))) (OR (AND I.HUNKING? (ILEQ NCELLS 64) (I.\\ALLOCHUNK NCELLS GCTYPE INITONPAGE ALIGN)) (PROG ((ARLEN (IPLUS NCELLS 2)) ABLOCK) RETRY (PROGN (*) (SETQ ABLOCK (OR (NILL ARLEN GCTYPE INITONPAGE ALIGN) (I.\\ALLOCBLOCK.NEW ARLEN GCTYPE INITONPAGE ALIGN) (PROGN (FRPTQ 10 (RECLAIM)) (*) (NILL ARLEN GCTYPE INITONPAGE ALIGN)) (GO FULL))) (*) (NEQ (LOGAND (I.PUTBASE ABLOCK 0 (LOGOR (LOGAND (I.GETBASE ABLOCK 0) 65534) (LOGAND (COND (T 1) (T 0)) 1))) 1) 0) (NEQ (LOGAND ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 65534) (LOGAND (COND (T 1) (T 0)) 1)))) ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) ABLOCK (IDIFFERENCE (I.GETBASE ABLOCK 1) 1))) 1) 0) (LOGAND (LRSH (I.PUTBASE ABLOCK 0 (LOGOR (LOGAND (I.GETBASE ABLOCK 0) 65529) (LLSH (LOGAND GCTYPE 3) 1))) 1) 3) (NILL ABLOCK NIL) (PROGN NCELLS) (*) (SETQ ABLOCK (I.ADDBASE ABLOCK 2)) (PROGN ABLOCK) (RETURN ABLOCK)) FULL (LISPERROR "ARRAYS FULL" NIL T) (*) (GO RETRY))))
+)
+
+(I.\\MAIKO.ALLOCBLOCK
+(LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN) (*) (*) (*) (DECLARE (GLOBALVARS |I.ArrayFrLst|)) (COND ((ILESSP NCELLS 2) (COND ((ILESSP NCELLS 0) (\\ILLEGAL.ARG NCELLS))) (SETQ NCELLS 2)) ((IGREATERP NCELLS 65533) (\\LISPERROR NCELLS "ARRAY STORAGE BLOCK TOO LARGE"))) (*) (SELECTQ GCTYPE (NIL (SETQ GCTYPE 0)) (T (SETQ GCTYPE 1)) NIL) (*) (*) (*) (COND ((NULL ALIGN)) ((OR (ILESSP ALIGN 0) (IGREATERP ALIGN 128)) (\\ILLEGAL.ARG ALIGN)) ((ILEQ ALIGN 1) (SETQ ALIGN)) ((AND INITONPAGE (PROGN (*) NIL)) (ERROR "INITONPAGE and ALIGN too high"))) (OR (AND I.HUNKING? (ILEQ NCELLS 64) (*) (I.\\ALLOCHUNK NCELLS GCTYPE NIL ALIGN)) (PROG ((ARLEN (IPLUS NCELLS 2)) ABLOCK) RETRY (PROGN (*) (SETQ ABLOCK (OR (NILL ARLEN GCTYPE NIL ALIGN) (I.\\ALLOCBLOCK.NEW ARLEN GCTYPE NIL ALIGN) (PROGN (FRPTQ 10 (RECLAIM)) (*) (NILL ARLEN GCTYPE INITONPAGE ALIGN)) (GO FULL))) (*) (NEQ (LOGAND (I.PUTBASE ABLOCK 0 (LOGOR (LOGAND (I.GETBASE ABLOCK 0) 65534) (LOGAND (COND (T 1) (T 0)) 1))) 1) 0) (NEQ (LOGAND ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 65534) (LOGAND (COND (T 1) (T 0)) 1)))) ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) ABLOCK (IDIFFERENCE (I.GETBASE ABLOCK 1) 1))) 1) 0) (LOGAND (LRSH (I.PUTBASE ABLOCK 0 (LOGOR (LOGAND (I.GETBASE ABLOCK 0) 65529) (LLSH (LOGAND GCTYPE 3) 1))) 1) 3) (NILL ABLOCK NIL) (PROGN NCELLS) (SETQ ABLOCK (I.ADDBASE ABLOCK 2)) (PROG1 (PROGN ABLOCK) (PROGN 1)) (RETURN ABLOCK)) FULL (LISPERROR "ARRAYS FULL" NIL T) (*) (GO RETRY))))
+)
+
+(I.\\ALLOCBLOCK.NEW
+(LAMBDA (ARLEN GCTYPE INITONPAGE ALIGN) (*) (DECLARE (GLOBALVARS |I.ArrayFrLst| |I.NxtArrayPage|)) (*) (PROG (FINALWORD FINALPAGE NEXTFREEBLOCK PREFIXLEN) RETRY (COND ((AND (OR INITONPAGE ALIGN) (NEQ 0 (SETQ PREFIXLEN (I.\\PREFIXALIGNMENT? ARLEN INITONPAGE ALIGN GCTYPE |I.ArrayFrLst|)))) (*) (COND ((SETQ PREFIXLEN (I.\\ALLOCBLOCK.NEW PREFIXLEN)) (I.\\MERGEBACKWARD PREFIXLEN) (*)) (T (RETURN))))) (SETQ FINALWORD (I.ADDBASE (I.ADDBASE |I.ArrayFrLst| ARLEN) (SUB1 ARLEN))) (*) (SETQ NEXTFREEBLOCK (I.ADDBASE FINALWORD 1)) (COND ((IGREATERP (SETQ FINALPAGE (IPLUS (LLSH (I.HILOC FINALWORD) 8) (LRSH (I.LOLOC FINALWORD) 8))) (IDIFFERENCE |I.NxtMDSPage| 128)) (*) (SELECTQ (NILL (ADD1 (IDIFFERENCE FINALPAGE |I.NxtArrayPage|))) (T (*)) (0 (*) (GO RETRY)) (RETURN NIL)))) (*) (|until| (IGREATERP |I.NxtArrayPage| FINALPAGE) |do| (I.\\MAKEMDSENTRY |I.NxtArrayPage| 0) (I.\\NEW2PAGE ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 |I.NxtArrayPage|) 8) (LLSH (LOGAND $$1 255) 8))) NIL)) (I.PUTBASEFIXP |I.NxtArrayPage| 0 (IPLUS |I.NxtArrayPage| 2))) (RETURN (PROG1 (I.\\MAKEFREEARRAYBLOCK |I.ArrayFrLst| ARLEN) (SETQ |I.ArrayFrLst| NEXTFREEBLOCK)))))
+)
+
+(I.\\MAKEFREEARRAYBLOCK
+(LAMBDA (BLOCK LENGTH) (*) (I.PUTBASE BLOCK 0 43688) (I.PUTBASE BLOCK 1 LENGTH) (I.PUTBASE ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) BLOCK (IDIFFERENCE (I.GETBASE BLOCK 1) 1)) 0 43688) (I.PUTBASE ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) BLOCK (IDIFFERENCE (I.GETBASE BLOCK 1) 1)) 1 LENGTH) BLOCK)
+)
+
+(I.\\MERGEBACKWARD
+(LAMBDA (BASE) (*) (*) (PROG (ARLEN PARLEN PBASE PTRAILER SPLIT) (COND ((NULL BASE) (RETURN NIL)) ((OR (NOT (PROGN NIL)) (EQ BASE (I.VAG2 23 0)) (EQ BASE (I.VAG2 64 0)) (NEQ 0 (LOGAND (I.GETBASE (SETQ PTRAILER (I.ADDBASE BASE (IMINUS 2))) 0) 1))) (*) (RETURN (I.\\LINKBLOCK BASE)))) (SETQ PBASE ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) BASE (IMINUS (I.GETBASE PTRAILER 1)))) (NILL PBASE T) (\\DELETEBLOCK? PBASE) (RETURN (\\ARRAYBLOCKMERGER PBASE BASE))))
+)
+
+(I.\\LINKBLOCK
+(LAMBDA (BASE) (*) (*) (COND (I.FREEBLOCKBUCKETS (COND ((ILESSP (I.GETBASE BASE 1) 4) (NILL BASE T)) (T (PROG ((FBL ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) I.FREEBLOCKBUCKETS (IMIN (INTEGERLENGTH (I.GETBASE BASE 1)) 30))) FREEBLOCK) (SETQ FREEBLOCK (I.GETBASEPTR FBL 0)) (COND ((NULL FREEBLOCK) (I.PUTBASEPTR BASE 2 BASE) (I.PUTBASEPTR BASE 4 BASE)) (T (I.PUTBASEPTR BASE 2 FREEBLOCK) (I.PUTBASEPTR BASE 4 (I.GETBASEPTR FREEBLOCK 4)) (I.PUTBASEPTR (I.GETBASEPTR FREEBLOCK 4) 2 BASE) (I.PUTBASEPTR FREEBLOCK 4 BASE))) (I.PUTBASEPTR FBL 0 BASE) (NILL BASE T T)))))) BASE)
+)
+
+(I.\\ALLOCHUNK
+(LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN) (*) (COND ((AND ALIGN (OR (IGREATERP ALIGN 64) (NOT (FMEMB ALIGN (SELECTC GCTYPE (0 (CONSTANT (|for| X |in| (QUOTE (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64)) |when| (AND (IGREATERP X 1) (ILEQ X 64) (POWEROFTWOP X)) |collect| X))) (1 (CONSTANT (|for| X |in| (QUOTE (2 4 5 6 7 8 10 12 16 24 32 42 64)) |when| (AND (IGREATERP X 1) (ILEQ X 64) (POWEROFTWOP X)) |collect| X))) (2 (CONSTANT (LIST 2))) NIL))))) (*) (ERROR "Oddball alignment request" ALIGN))) (PROG ((TYPENUM.TABLE (SELECTC GCTYPE (0 I.UNBOXEDHUNK.TYPENUM.TABLE) (2 I.CODEHUNK.TYPENUM.TABLE) (1 I.PTRHUNK.TYPENUM.TABLE) (SHOULDNT))) (FAILCNT 0) DTNUMBER HUNK HUNKSIZE ONPAGE STRADDLERS) BEG (|do| (SETQ DTNUMBER (I.\\GETBASEBYTE TYPENUM.TABLE NCELLS)) (SETQ HUNKSIZE (LRSH (I.GETBASE (I.ADDBASE (I.VAG2 6 4096) (ITIMES DTNUMBER 18)) 3) 1)) |repeatuntil| (OR (NOT ALIGN) (EQ 0 (IREMAINDER (LRSH (I.GETBASE (I.ADDBASE (I.VAG2 6 4096) (ITIMES DTNUMBER 18)) 3) 1) ALIGN)) (COND ((IGREATERP (SETQ NCELLS (ADD1 HUNKSIZE)) 64) (GO LOSE)) (T (*) NIL)))) LP (SETQ HUNK (I.\\CREATECELL DTNUMBER)) (COND ((OR (NULL INITONPAGE) (ILESSP INITONPAGE (SETQ ONPAGE (IDIFFERENCE 128 (LRSH (LOGAND (I.LOLOC HUNK) 255) 1))))) (*) (RETURN HUNK))) (*) (COND (T (*) (HELP "Call to \\ALLOCBLOCK with non-NIL INITONPAGE demand" INITONPAGE)) (T (COND ((AND (EQ GCTYPE 2) (ILEQ (IQUOTIENT (ITIMES 10 ONPAGE) HUNKSIZE) (COND ((ILEQ HUNKSIZE 24) 60) ((ILEQ HUNKSIZE 50) 50) (T 30)))) (*) (PROGN HUNK)) (T (*) (SETQ STRADDLERS (I.\\CONS.UFN HUNK STRADDLERS)))) (COND ((IGREATERP (SETQ FAILCNT (PLUS FAILCNT 1)) 16) (*) (GO LOSE)) ((EQ FAILCNT 8) (*) (SETQ NCELLS (ADD1 HUNKSIZE)) (AND STRADDLERS (SETQ \\HUNKREJECTS (NCONC STRADDLERS \\HUNKREJECTS))) (GO BEG))) (GO LP))) LOSE (AND STRADDLERS (SETQ \\HUNKREJECTS (NCONC STRADDLERS \\HUNKREJECTS))) (RETURN)))
+)
+)
+(DEFINEQ
+
+(I.PREINITARRAYS
+(LAMBDA NIL (*) (*) (DECLARE (GLOBALVARS |I.ArrayFrLst| |I.ArrayFrLst2| |I.NxtArrayPage|)) (SETQ |I.ArrayFrLst| (I.VAG2 23 0)) (SETQ |I.ArrayFrLst2| (I.VAG2 64 0)) (SETQ |I.NxtArrayPage| (IPLUS (LLSH (I.HILOC |I.ArrayFrLst|) 8) (LRSH (I.LOLOC |I.ArrayFrLst|) 8))))
+)
+
+(I.POSTINITARRAYS
+(LAMBDA (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (*) (*) (SETQ I.FREEBLOCKBUCKETS (I.\\ALLOCBLOCK (ADD1 30))) (PROG ((EXTRACELLS (IDIFFERENCE (LLSH CODESTARTPAGE 7) (IPLUS (LLSH (I.HILOC |I.ArrayFrLst|) 15) (LRSH (I.LOLOC |I.ArrayFrLst|) 1))))) (*) (COND ((IGREATERP EXTRACELLS 65535) (|printout| T T T "POSTINITARRAYS:  You pre-allocated too much string space." T 19 "MKI.CODESTARTOFFSET on MAKEINIT should be reduced by about " (IDIFFERENCE (LRSH EXTRACELLS 7) 10) "." T) (HELP)) ((IGEQ EXTRACELLS 4) (*) (|printout| T T T "POSTINITARRAYS:  There were " (LRSH EXTRACELLS 7) " allocated but unused array pages." T T)) (T (|printout| T T "POSTINITARRAYS:  String space overflowed into code-arrays" T 19 "You should add at least " (ADD1 (LRSH (IMINUS EXTRACELLS) 7)) " to MKI.CODESTARTOFFSET on MAKEINIT." T) (HELP))) (*) (I.\\LINKBLOCK (I.\\ALLOCBLOCK.NEW EXTRACELLS)) (SETQ |I.ArrayFrLst| AFTERCODEPTR) (*) (SETQ |I.NxtArrayPage| CODENEXTPAGE) (|for| VP |from| (IPLUS (LLSH (I.HILOC (I.VAG2 23 0)) 8) (LRSH (I.LOLOC (I.VAG2 23 0)) 8)) |to| (IPLUS (LLSH (I.HILOC |I.NxtArrayPage|) 8) (LRSH (I.LOLOC |I.NxtArrayPage|) 8)) |by| (LRSH 512 8) |do| (I.\\MAKEMDSENTRY VP 0))))
+)
+
+(I.FILEARRAYBASE
+(LAMBDA NIL (*) (I.ADDBASE (I.VAG2 23 0) (IPLUS (LLSH MKI.CODESTARTOFFSET 8) (LRSH (IDIFFERENCE (GETFILEPTR (OUTPUT)) |MKI.FirstDataByte|) 1))))
+)
+
+(I.FILEBLOCKTRAILER
+(LAMBDA (BLOCKINFO) (*) (*) (BOUT16 OUTX 43689) (BOUT16 OUTX BLOCKINFO)))
+
+(I.FILECODEBLOCK
+(LAMBDA (NCELLS INITONPAGE) (*) (*) (PROG (PREFIXLEN (ARLEN (IPLUS NCELLS 2))) (*) (COND ((NEQ 0 (SETQ PREFIXLEN (I.\\PREFIXALIGNMENT? ARLEN INITONPAGE 2 2 (I.FILEARRAYBASE)))) (*) (I.FILEPATCHBLOCK PREFIXLEN))) (BOUT16 OUTX 43693) (BOUT16 OUTX ARLEN) (RETURN ARLEN)))
+)
+
+(I.FILEPATCHBLOCK
+(LAMBDA (ARLEN) (*) (*) (BOUT16 OUTX 43688) (*) (BOUT16 OUTX ARLEN) (*) (COND ((IGREATERP ARLEN 1) (*) (BOUTZEROS (LLSH (IDIFFERENCE ARLEN 2) 2)) (*) (BOUT16 OUTX 43688) (*) (BOUT16 OUTX ARLEN))) NIL)
+)
+)
+(DEFINEQ
+
+(I.\\SETUP.HUNK.TYPENUMBERS
+(LAMBDA NIL (*) (*) (*) (SETQ INITIALDTDCONTENTS (APPEND \\BUILT-IN-SYSTEM-TYPES (I.\\COMPUTE.HUNK.TYPEDECLS (QUOTE (2 4 5 6 7 8 10 12 16 24 32 42 64)) 1 (QUOTE \\PTRHUNK)) (I.\\COMPUTE.HUNK.TYPEDECLS (QUOTE (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64)) 0 (QUOTE \\UNBOXEDHUNK)) (I.\\COMPUTE.HUNK.TYPEDECLS (QUOTE (12 16 20 24 28 32 36 42 50 64)) 2 (QUOTE \\CODEHUNK)))))
+)
+
+(I.\\COMPUTE.HUNK.TYPEDECLS
+(LAMBDA (SIZELST GCTYPE PREFIX) (*) (*) (|for| HUNKSIZE |in| SIZELST BIND (FINAL _ (AND (EQ GCTYPE CODEBLOCK.GCT) (QUOTE \\RECLAIMCODEBLOCK))) |until| (> HUNKSIZE \\MAX.CELLSPERHUNK) |collect| (LIST (PACK* PREFIX HUNKSIZE) (UNFOLD HUNKSIZE WORDSPERCELL) (COND ((EQ GCTYPE PTRBLOCK.GCT) (* \; "Compute DTDPTRS list, i.e., which fields are pointers (all of them)") (|for| I |from| 0 |by| 2 |to| (SUB1 (UNFOLD HUNKSIZE WORDSPERCELL)) |collect| I))) FINAL)))
+)
+
+(I.\\TURN.ON.HUNKING
+(LAMBDA NIL (*) (*) (SETQ I.UNBOXEDHUNK.TYPENUM.TABLE (I.\\SETUP.TYPENUM.TABLE (QUOTE (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64)) 0 (QUOTE \\UNBOXEDHUNK))) (SETQ I.CODEHUNK.TYPENUM.TABLE (I.\\SETUP.TYPENUM.TABLE (QUOTE (12 16 20 24 28 32 36 42 50 64)) 2 (QUOTE \\CODEHUNK))) (SETQ I.PTRHUNK.TYPENUM.TABLE (I.\\SETUP.TYPENUM.TABLE (QUOTE (2 4 5 6 7 8 10 12 16 24 32 42 64)) 1 (QUOTE \\PTRHUNK))) (SETQ I.HUNKING? T))
+)
+
+(I.\\SETUP.TYPENUM.TABLE
+(LAMBDA (SIZELST GCTYPE PREFIX) (*) (*) (|for| I |from| 0 |to| 64 |bind| (HUNKSIZE _ -1) (SIZEL _ SIZELST) (TABLE _ (I.\\ALLOCBLOCK (LRSH (IPLUS (IPLUS 4 64) 3) 2) 0)) TNAME DTD DTNUMBER |do| (COND ((IGREATERP I HUNKSIZE) (*) (SETQ HUNKSIZE (OR (FIXP (PROG1 (CAR SIZEL) (SETQ SIZEL (CDR SIZEL)))) 64)) (SETQ TNAME (PACK* PREFIX HUNKSIZE)) (COND ((|for| |old| DTNUMBER |from| 1 |as| TYPE |in| INITIALDTDCONTENTS |when| (EQ (CAR TYPE) TNAME) |do| (*) (RETURN DTNUMBER)) (SETQ DTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES DTNUMBER 18))) (LOGAND (LRSH (I.PUTBASE DTD 6 (LOGOR (LOGAND (I.GETBASE DTD 6) 53247) (LLSH (LOGAND GCTYPE 3) 12))) 12) 3) (NEQ (LOGAND (LRSH (I.PUTBASE DTD 6 (LOGOR (LOGAND (I.GETBASE DTD 6) 49151) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 14))) 14) 1) 0)) (T (HELP "No type declaration for" TNAME))))) (I.\\PUTBASEBYTE TABLE I DTNUMBER) |finally| (RETURN TABLE)))
+)
+)
+(DEFINEQ
+
+(I.DCODERD
+(LAMBDA (FN) (*) (*) (*) (READC) (LET ((INSTREAM (GETSTREAM NIL (QUOTE INPUT))) (*READTABLE* (|if| (EQ *READTABLE* FILERDTBL) |then| (*) I.CODERDTBL |else| (*) *READTABLE*))) (PROG ((NAMETABLE (PROG1 (READ) (READC))) (CODELEN (IPLUS (LLSH (\\BIN INSTREAM) 8) (\\BIN INSTREAM))) (NLOCALS (\\BIN INSTREAM)) (NFREEVARS (\\BIN INSTREAM)) (ARGTYPE (\\BIN INSTREAM)) (NARGS (\\BIN INSTREAM)) (NTSIZE 0) (FRAMENAME FN) REALSIZE STARTPC NTWORDS CA FVAROFFSET LOCALARGS STARTLOCALS LOCALSIZE) (COND ((EQ (CAR NAMETABLE) (QUOTE NAME)) (SETQ FRAMENAME (CADR NAMETABLE)) (SETQ NAMETABLE (CDDR NAMETABLE)))) (COND ((EQ (CAR NAMETABLE) (QUOTE L)) (SETQ LOCALARGS (CADR NAMETABLE)) (SETQ NAMETABLE (CDDR NAMETABLE)))) (COND (NAMETABLE (*) (|on| NAMETABLE |by| CDDDR |do| (SETQ NTSIZE (PLUS NTSIZE 1))) (SETQ NTSIZE (LOGAND (IPLUS (ADD1 (LLSH NTSIZE 1)) (CONSTANT (SUB1 4))) (CONSTANT (LOGXOR (SUB1 4) -1)))))) (SETQ NTWORDS (COND (NAMETABLE (IPLUS NTSIZE NTSIZE)) (T (CONSTANT 4)))) (*) (SETQ STARTPC (LLSH (IPLUS (PROGN 8) NTWORDS) 1)) (*) (COND (LOCALARGS (SETQ STARTLOCALS STARTPC) (*) (SETQ LOCALSIZE (LOGAND (IPLUS (ADD1 (LLSH (LRSH (FLENGTH LOCALARGS) 1) 1)) (CONSTANT (SUB1 (IQUOTIENT 4 2)))) (CONSTANT (LOGXOR (SUB1 (IQUOTIENT 4 2)) -1)))) (*) (SETQ LOCALSIZE (LLSH LOCALSIZE 1)) (*) (SETQ STARTPC (PLUS STARTPC (LLSH LOCALSIZE 1))))) (SETQ REALSIZE (LOGAND (IPLUS (IPLUS STARTPC CODELEN) (CONSTANT (SUB1 8))) (CONSTANT (LOGXOR (SUB1 8) -1)))) (SETQ CA (SCRATCHARRAY REALSIZE (LOGAND (IPLUS (ADD1 (LRSH (IPLUS STARTPC 3) 2)) (CONSTANT (SUB1 2))) (CONSTANT (LOGXOR (SUB1 2) -1))))) (AIN CA STARTPC CODELEN INSTREAM) (*) (|for| X |on| NAMETABLE |by| (CDDDR X) |as| NT1 |from| (IPLUS (SUB1 (LLSH (CONSTANT (I.WORDSPERNAMEENTRY)) 1)) (LLSH (PROGN 8) 1)) |by| (LLSH (CONSTANT (I.WORDSPERNAMEENTRY)) 1) |bind| (NTBYTESIZE _ (LLSH NTSIZE 1)) |do| (I.FIXUPSYM CA NT1 (CADDR X) -1) (*) (I.SETSTKNTOFFSET CA (IPLUS NT1 NTBYTESIZE) (SELECTQ (CAR X) (P (CONSTANT (LLSH 2 14))) (F (OR FVAROFFSET (SETQ FVAROFFSET (LLSH (LRSH NT1 2) 1))) (*) (CONSTANT (LLSH 3 14))) (I (CONSTANT (LLSH 0 14))) (SHOULDNT)) (CADR X)) (*)) (COND (LOCALARGS (*) (|for| X |on| LOCALARGS |by| (CDDR X) |as| NT |from| (IPLUS (SUB1 (LLSH (CONSTANT (I.WORDSPERNAMEENTRY)) 1)) STARTLOCALS) |by| (CONSTANT (LLSH (CONSTANT (I.WORDSPERNAMEENTRY)) 1)) |do| (I.FIXUPSYM CA NT (CADR X) -1) (*) (I.SETSTKNTOFFSET CA (IPLUS NT LOCALSIZE) (CONSTANT (LLSH 0 14)) (CAR X)) (*)))) (PROGN (*) ((LAMBDA (DEFA0094 VALUEA0093) (DECLARE (LOCALVARS DEFA0094 VALUEA0093)) (\\BYTESETA DEFA0094 2 (LRSH VALUEA0093 8)) (\\BYTESETA DEFA0094 (ADD1 2) (IMOD VALUEA0093 (CONSTANT (LLSH 1 8))))) CA (UNSIGNED (PROGN (COND ((EQ ARGTYPE 2) -1) (T NARGS))) 16)) ((LAMBDA (DEFA0096 VALUEA0095) (DECLARE (LOCALVARS DEFA0096 VALUEA0095)) (\\BYTESETA DEFA0096 4 (LRSH VALUEA0095 8)) (\\BYTESETA DEFA0096 (ADD1 4) (IMOD VALUEA0095 (CONSTANT (LLSH 1 8))))) CA (UNSIGNED (PROGN (SUB1 (LRSH (IPLUS (IPLUS NLOCALS NFREEVARS) 1) 1))) 16)) (PROGN (\\BYTESETA CA 6 (LRSH STARTPC 8)) (\\BYTESETA CA (ADD1 6) (IMOD STARTPC (CONSTANT (LLSH 1 8))))) (\\BYTESETA CA 8 (LOGOR (LOGAND (\\BYTELT CA 8) 207) (LLSH (LOGAND ARGTYPE 3) 4))) (I.FIXUPPTR CA 11 (I.\\COPY FRAMENAME)) (PROGN (\\BYTESETA CA 12 (LRSH NTSIZE 8)) (\\BYTESETA CA (ADD1 12) (IMOD NTSIZE (CONSTANT (LLSH 1 8))))) (\\BYTESETA CA 14 NLOCALS) (\\BYTESETA CA 15 (PROGN (OR FVAROFFSET 0))) ((LAMBDA (DEFA0098 VALUEA0097) (DECLARE (LOCALVARS DEFA0098 VALUEA0097)) (\\BYTESETA DEFA0098 0 (LRSH VALUEA0097 8)) (\\BYTESETA DEFA0098 (ADD1 0) (IMOD VALUEA0097 (CONSTANT (LLSH 1 8))))) CA (PROGN (I.\\STKMIN CA)))) (*) (|for| X |on| (READ) |by| (CDDR X) |do| (I.FIXUPSYM CA (IPLUS (CAR X) STARTPC) (CADR X) -1)) (|for| X |on| (READ) |by| (CDDR X) |do| (I.FIXUPSYM CA (IPLUS (CAR X) STARTPC) (CADR X) -1)) (|for| X |on| (READ) |by| (CDDR X) |do| (I.FIXUPPTR CA (IPLUS (CAR X) STARTPC) (I.\\COPY (CADR X)))) (I.PUTDEFN FN CA (IPLUS STARTPC CODELEN)))))
+)
+)
+
+(RPAQQ \\OPCODES ((0 -X- 0) (1 CAR 0 T 0 \\CAR.UFN) (2 CDR 0 T 0 \\CDR.UFN) (3 LISTP 0 T 0 LISTP) (4 NTYPX 0 T 0 NTYPX) (5 TYPEP 1 TYPEP 0 \\TYPEP.UFN) (6 DTEST 4 ATOM 0 \\DTEST.UFN) (7 UNWIND 2 T (UNWIND 1) \\UNWIND.UFN) (8 FN0 4 FN 1) (9 FN1 4 FN 0) (10 FN2 4 FN -1) (11 FN3 4 FN -2) (12 FN4 4 FN -3) (13 FNX 5 FNX FNX) (14 APPLYFN 0 T -1) (15 CHECKAPPLY* 0 T 0 \\CHECKAPPLY* (4K 12K)) (16 RETURN 0 T (JUMP 1) \\HARDRETURN) (17 BIND 2) (18 UNBIND 0) (19 DUNBIND 0) (20 RPLPTR.N 1 T -1 \\RPLPTR.UFN (4K)) (21 GCREF 1 T 0 \\HTFIND) (22 ASSOC 0 T -1 ASSOC (4K DORADO)) (23 GVAR_ 4 ATOM 0 \\SETGLOBALVAL.UFN) (24 RPLACA 0 T -1 \\RPLACA.UFN 4K) (25 RPLACD 0 T -1 \\RPLACD.UFN 4K) (26 CONS 0 T -1 \\CONS.UFN) (27 CMLASSOC 0 T -1 CL::%SIMPLE-ASSOC (4K DORADO)) (28 FMEMB 0 T -1 FMEMB (4K DORADO)) (29 CMLMEMBER 0 T -1 CL::%SIMPLE-MEMBER (4K DORADO)) (30 FINDKEY 1 T 0 \\FINDKEY.UFN) (31 CREATECELL 0 T 0 \\CREATECELL 4K) (32 BIN 0 T 0 \\BIN 4K) (33 BOUT 0 T -1 \\BOUT (4K DORADO)) (34 POPDISP 0 T 0 \\POPDISP.UFN (4K DORADO)) (35 RESTLIST 1 T -1 \\RESTLIST.UFN) (36 MISCN 2 T 1 \\MISCN.UFN (DORADO DLION DBREAK)) (37 |unused|) (38 RPLCONS 0 T -1 \\RPLCONS (4K DORADO)) (39 LISTGET 0 T -1 LISTGET (4K DORADO)) (40 |unused|) (41 |unused|) (42 |unused|) (43 |unused|) (44 EVAL 0 T 0 \\EVAL) (45 ENVCALL 0 T (JUMP 0) \\ENVCALL.UFN) (46 TYPECHECK 0 T 0 \\TYPECHECK.UFN) (47 STKSCAN 0 T 0 \\STKSCAN) (48 BUSBLT 1 (WORDSOUT BYTESOUT BYTESOUTSWAPPED NYBBLESOUT WORDSIN BYTESIN BYTESINSWAPPED NYBBLESINSWAPPED) -3 \\BUSBLT.UFN (4K DORADO)) (49 MISC8 1 (IBLT1 IBLT2) -7 \\MISC8.UFN (4K DORADO)) (50 UBFLOAT3 1 (POLY MATRIX.3X3 MATRIX.4X4 MATRIX.133 MATRIX.331 MATRIX.144 MATRIX.441 UBASET1) (-2 1) \\UNBOXFLOAT3 (4K DORADO)) (51 TYPEMASK.N 1 T 0 \\TYPEMASK.UFN) (52 RDPROLOGPTR 0 T 0 RAID (4K DORADO)) (53 RDPROLOGTAG 0 T 0 RAID (4K DORADO)) (54 WRTPTR&TAG 0 T -2 RAID (4K DORADO)) (55 WRTPTR&0TAG 0 T -1 RAID (4K DORADO)) (56 MISC7 1 (PSEUDOCOLOR \\FASTBITMAPBIT) -6 \\MISC7.UFN (4K DORADO)) (57 DOVEMISC 1 (READIW WRITEIO WRITEMP RDTIMER BYTESWAP LOCKMEM NOTIFYIOP SETWP) (0 -1 0 0 0 -3 0 0)) (58 EQL 0 T -1 EQL) (59 DRAWLINE 0 T -8 \\DRAWLINE.UFN (4K DORADO)) (60 STORE.N 1 T 0 \\STORE.N.UFN) (61 COPY.N 1 T 1 \\COPY.N.UFN) (62 RAID 0 T 0 RAID T) (63 \\RETURN 0 T 0 \\RETURN) ((64 70) IVAR 0 IVAR 1) (71 IVARX 1 IVAR 1) ((72 78) PVAR 0 PVAR 1) (79 PVARX 1 PVAR 1) ((80 86) FVAR 0 FVAR 1) (87 FVARX 1 FVAR 1) ((88 94) PVAR_ 0 PVAR 0) (95 PVARX_ 1 PVAR 0) (96 GVAR 4 ATOM 1) (97 ARG0 0 T 0 \\ARG0 T) (98 IVARX_ 1 IVAR 0) (99 FVARX_ 1 FVAR 0) (100 COPY 0 T 1) (101 MYARGCOUNT 0 T 1 \\MYARGCOUNT T) (102 MYALINK 0 T 1) (103 ACONST 4 ATOM 1) (104 \'NIL 0 T 1) (105 \'T 0 T 1) (106 \'0 0 T 1) (107 \'1 0 T 1) (108 SIC 1 SIC 1) (109 SNIC 1 SNIC 1) (110 SICX 2 SICX 1) (111 GCONST 4 GCONST 1) (112 |unused|) (113 READFLAGS 0 T 0 \\READFLAGS) (114 READRP 0 T 0 \\READRP) (115 WRITEMAP 0 T -2 \\WRITEMAP DORADO) (116 READPRINTERPORT 0 T 1 \\READPRINTERPORT.UFN 4K) (117 WRITEPRINTERPORT 0 T 0 \\WRITEPRINTERPORT.UFN 4K) (118 PILOTBITBLT 0 T -1 \\PILOTBITBLT) (119 RCLK 0 T 0 \\RCLKSUBR) (120 MISC1 1 (|error| INPUT OUTPUT |error| |error| |error| |error| |error| |error| RWMUFMAN) 0 \\MISC1.UFN) (121 MISC2 1 (?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?10) -1 \\MISC2.UFN) (122 RECLAIMCELL 0 T 0 \\GCRECLAIMCELL DORADO) (123 GCSCAN1 0 T 0 \\GCSCAN1) (124 GCSCAN2 0 T 0 \\GCSCAN2) (125 SUBRCALL 2 SUBRCALL) (126 CONTEXTSWITCH 0 T 0 \\CONTEXTSWITCH) (127 RETCALL 4 FNX (JUMP 1) \\RETCALL) ((128 143) JUMP 0 JUMP JUMP NIL) ((144 159) FJUMP 0 JUMP CJUMP NIL) ((160 175) TJUMP 0 JUMP CJUMP NIL) (176 JUMPX 1 JUMPX JUMP) (177 JUMPXX 2 JUMPXX JUMP) (178 FJUMPX 1 JUMPX CJUMP) (179 TJUMPX 1 JUMPX CJUMP) (180 NFJUMPX 1 JUMPX NCJUMP) (181 NTJUMPX 1 JUMPX NCJUMP) (182 AREF1 0 T -1 %AREF1 (4K DORADO)) (183 ASET1 0 T -2 %ASET1 (4K DORADO)) ((184 190) PVAR_^ 0 PVAR -1 NIL) (191 POP 0 T -1) (192 POP.N 1 T (POP.N 1) \\POP.N.UFN) (193 ATOMCELL.N 1 T 0 \\ATOMCELL) (194 GETBASEBYTE 0 T -1 \\GETBASEBYTE) (195 INSTANCEP 4 ATOM 0 \\INSTANCEP.UFN NIL) (196 BLT 0 T -2 \\BLT) (197 MISC10 1 T -9 \\MISC10.UFN (4K DORADO)) (198 P-MISC2 1 (GET-NEXT-RUN) -1 \\P-MISC2.UFN) (199 PUTBASEBYTE 0 T -2 \\PUTBASEBYTE) (200 GETBASE.N 1 T 0) (201 GETBASEPTR.N 1 T 0) (202 GETBITS.N.FD 2 T 0) (203 |unused|) (204 CMLEQUAL 0 T -1 CL:EQUAL (4K 12K DORADO)) (205 PUTBASE.N 1 T -1 \\PUTBASE.UFN) (206 PUTBASEPTR.N 1 T -1 \\PUTBASEPTR.UFN) (207 PUTBITS.N.FD 2 T -1 \\PUTBITS.UFN) (208 ADDBASE 0 T -1 \\ADDBASE) (209 VAG2 0 T -1 \\VAG2) (210 HILOC 0 T 0) (211 LOLOC 0 T 0) (212 PLUS2 0 T -1 \\SLOWPLUS2 *) (213 DIFFERENCE 0 T -1 \\SLOWDIFFERENCE *) (214 TIMES2 0 T -1 \\SLOWTIMES2 *) (215 QUOTIENT 0 T -1 \\SLOWQUOTIENT *) (216 IPLUS2 0 T -1 \\SLOWIPLUS2) (217 IDIFFERENCE 0 T -1 \\SLOWIDIFFERENCE) (218 ITIMES2 0 T -1 \\SLOWITIMES2) (219 IQUOTIENT 0 T -1 \\SLOWIQUOTIENT) (220 IREMAINDER 0 T -1 IREMAINDER) (221 IPLUS.N 1 T 0 \\SLOWIPLUS2 (4K 12K)) (222 IDIFFERENCE.N 1 T 0 \\SLOWIDIFFERENCE (4K 12K)) (223 BASE-< 0 T -1 \\BASE-<.UFN (4K 12K DORADO)) (224 LLSH1 0 T 0 \\SLOWLLSH1) (225 LLSH8 0 T 0 \\SLOWLLSH8) (226 LRSH1 0 T 0 \\SLOWLRSH1) (227 LRSH8 0 T 0 \\SLOWLRSH8) (228 LOGOR2 0 T -1 \\SLOWLOGOR2) (229 LOGAND2 0 T -1 \\SLOWLOGAND2) (230 LOGXOR2 0 T -1 \\SLOWLOGXOR2) (231 LSH 0 T -1 LSH T) (232 FPLUS2 0 T -1 \\SLOWFPLUS2 4K) (233 FDIFFERENCE 0 T -1 \\SLOWFDIFFERENCE 4K) (234 FTIMES2 0 T -1 \\SLOWFTIMES2 4K) (235 FQUOTIENT 0 T -1 \\SLOWFQUOTIENT 4K) (236 UBFLOAT2 1 (UFADD UFSUB UFISUB UFMULT UFDIV UFGREAT UFMAX UFMIN UFREM UBAREF1) (-1 1) \\UNBOXFLOAT2 (4K DORADO)) (237 UBFLOAT1 1 (BOX UNBOX UFABS UFNEGATE UFIX) (0 1) \\UNBOXFLOAT1 (4K DORADO)) (238 AREF2 0 T -2 %AREF2 (4K DORADO)) (239 ASET2 0 T -3 %ASET2 (4K DORADO)) (240 EQ 0 T -1) (241 IGREATERP 0 T -1 \\SLOWIGREATERP) (242 FGREATERP 0 T -1 \\SLOWFGREATERP) (243 GREATERP 0 T -1 GREATERP) (244 EQUAL 0 T -1 EQUAL) (245 MAKENUMBER 0 T -1 \\MAKENUMBER 4K) (246 BOXIPLUS 0 T -1 \\BOXIPLUS 4K) (247 BOXIDIFFERENCE 0 T -1 \\BOXIDIFFERENCE 4K) (248 FLOATBLT 1 (FLOATWRAP FLOATUNWRAP FLOAT FIX FPLUS FDIFFERENCE FDIFFERENCE FPLUSABS ABSDIFFERENCE ABSFPLUS FTIMES) -3 \\FLOATBLT (4K DORADO)) (249 FFTSTEP 0 T -1 \\FFTSTEP (4K DORADO)) (250 MISC3 1 (EXPONENT MAGNITUDE FLOAT COMP BLKFMAX BLKFMIN BLKFABSMAX BLKFABSMIN FLOATTOBYTE ARRAYREAD LINES-EQUAL-P) -2 \\MISC3.UFN (4K DORADO)) (251 MISC4 1 (ARRAY.TIMES ARRAY.PERM ARRAY.PLUS ARRAY.DIFFERENCE ARRAY.MAGIC 3MATCH BMBIT ARRAYWRITE) -3 \\MISC4.UFN) (252 UPCTRACE 0 T 0 NILL (4K 12K)) (253 SWAP 0 T 0) (254 NOP 0 T 0) (255 = 0 T -1 CL::%= (4K DORADO)))
+)
+
+(RPAQ I.CODERDTBL (COPYREADTABLE (QUOTE ORIG)))
+
+(SETSYNTAX (CHARCODE ^Y) (QUOTE (MACRO (LAMBDA (FILE RDTBL) (EVALFORMAKEINIT (READ FILE RDTBL))))) I.CODERDTBL)
+
+(SETSYNTAX (CHARCODE \|) (QUOTE (MACRO ALWAYS READVBAR)) I.CODERDTBL)
+
+(READTABLEPROP I.CODERDTBL (QUOTE USESILPACKAGE) NIL)
+(DEFINEQ
+
+(I.INITUFNTABLE
+(LAMBDA NIL (*) (I.CREATEPAGES (I.VAG2 6 3072) 2 NIL T) (|for| I |from| 0 |to| 255 |do| (I.\\SETUFNENTRY I (QUOTE \\UNKNOWN.UFN) 0 0)) (|for| X |in| \\OPCODES |when| (CADDDR (CDDR X)) |do| (I.\\SETUFNENTRY (PROG ((OP (CAR X))) (RETURN (|if| (LISTP OP) |then| (CAR OP) |else| OP))) (CADDDR (CDDR X)) (COND ((LISTP (CADDDR (CDR X))) (CADR (CADDDR (CDR X)))) (T (IDIFFERENCE (IPLUS 1 (COND ((EQ (CADDR X) 0) 0) (T 1))) (CADDDR (CDR X))))) (SELECTQ (CADDR X) (0 0) (1 1) (2 2) (3 (*) 3) (4 4) (5 5) (SHOULDNT)))))
+)
+
+(I.\\SETUFNENTRY
+(LAMBDA (INDEX FN NARGS NEXTRA) (*) (SETQ INDEX (I.ADDBASE (I.ADDBASE (I.VAG2 6 3072) INDEX) INDEX)) (I.PUTBASE INDEX 0 (I.ATOMNUMBER FN)) (LRSH (I.PUTBASE INDEX 1 (LOGOR (LOGAND (I.GETBASE INDEX 1) 255) (LLSH NEXTRA 8))) 8) (LOGAND (I.PUTBASE INDEX 1 (LOGOR (LOGAND (I.GETBASE INDEX 1) 65280) (LOGAND NARGS 255))) 255))
+)
+)
+
+(RPAQQ INITPTRS ((\\MAINDISK) (\\SWAPDSK1) (\\SWAPDSK2) (\\SWAPREQUESTBLOCK) (\\DISKREQUESTBLOCK) (\\FREEPAGEFID) (\\FINALIZATION.FUNCTIONS) (|\\OneCharAtomBase| NIL) (\\SCRATCHSTRING) (\\LISTPDTD) (\\FREEBLOCKBUCKETS) (|\\ArrayFrLst|) (|\\ArrayFrLst2|) (\\UNBOXEDHUNK.TYPENUM.TABLE) (\\CODEHUNK.TYPENUM.TABLE) (\\PTRHUNK.TYPENUM.TABLE))
+)
+
+(RPAQQ INITVALUES ((|\\NxtMDSPage| |\\FirstMDSPage|) (|\\LeastMDSPage| |\\FirstMDSPage|) (|\\SecondMDSPage| |\\DefaultSecondMDSPage|) (|\\SecondArrayPage| |\\DefaultSecondArrayPage|) (\\MDSFREELISTPAGE) (|\\MaxSysTypeNum| 0) (|\\MaxTypeNumber|) (|\\AtomFrLst| 0) (|\\NxtArrayPage|) (\\HUNKING?))
+)
+(DECLARE\: EVAL@COMPILE DONTCOPY 
+
+(FILESLOAD (LOADCOMP) MAKEINIT)
+)
+STOP
diff --git a/CLTL2/I-NEW.LCOM b/CLTL2/I-NEW.LCOM
new file mode 100644
index 00000000..e117aa66
Binary files /dev/null and b/CLTL2/I-NEW.LCOM differ
diff --git a/CLTL2/I-NEW.~3~ b/CLTL2/I-NEW.~3~
new file mode 100644
index 00000000..249e2cea
--- /dev/null
+++ b/CLTL2/I-NEW.~3~
@@ -0,0 +1,419 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
+(FILECREATED " 2-Dec-93 13:37:18" |{DSK}<king>export>lispcore>sources>CLTL2>I-NEW.;3|)
+
+
+(PRETTYCOMPRINT I-NEWCOMS)
+
+(RPAQQ I-NEWCOMS ((ADDVARS (LOCKEDFNS \\CLOCK0 \\GETINTERNALCLOCK \\BOXIDIFFERENCE \\BOXIPLUS \\BLT \\SLOWIQUOTIENT) (LOCKEDVARS \\RCLKSECOND \\RCLKMILLISECOND \\MISCSTATS)) (ADDVARS (LOCKEDFNS ERROR RAID \\M44ACTONVMEMFILE \\ACTONVMEMFILESUBR \\ACTONVMEMPAGES \\CLEANUPDISKQUEUE \\CLEARCB \\DISKERROR \\DOACTONDISKPAGES \\DODISKCOMMAND \\EXTENDISFMAP \\M44DOEXTENDVMEMFILE \\GETDISKCB \\INITBFS \\INSUREVMEMFILE \\LISPERROR \\LOOKUPFMAP \\REALDISKDA \\VIRTUALDISKDA \\CLEARWORDS \\TESTPARTITION \\EXTENDEDVMEMINIT \\WHICHPART \\INITIALIZESWAPDISK \\SWAPDISKERROR) (LOCKEDVARS \\DISKREQUESTBLOCK \\SWAPREQUESTBLOCK \\MAINDISK \\SWAPDSK1 \\SWAPDSK2 \\ISFCHUNKSIZE \\EMUSCRATCH \\EMUDISKBUFFERS \\EMUSWAPBUFFERS \\EMUDISKBUFEND \\MAXSWAPBUFFERS \\#DISKBUFFERS |\\InterfacePage| \\ISFMAP \\ISFSCRATCHCAS \\ISFSCRATCHDAS \\SYSDISK \\#SWAPBUFFERS \\MAXDISKDA\s \\DISKDEBUG \\SPAREDISKWRITEBUFFER \\#EMUBUFFERS \\EMUBUFFERS \\LASTVMEMFILEPAGE |\\XVmem| |\\XVmemFmapBase| |\\XVmemFmapHighBase| |\\XVmemDiskBase|)) (FNS I.MAKEINITBFS) (ADDVARS (LOCKEDFNS FLIPCURSORBAR \\SETIOPOINTERS \\KEYHANDLER \\KEYHANDLER1 \\CONTEXTAPPLY \\LOCKPAGES \\DECODETRANSITION \\SMASHLINK \\INCUSECOUNT LLSH \\MAKEFREEBLOCK \\DECUSECOUNT \\MAKENUMBER \\ADDBASE \\PERIODIC.INTERRUPTFRAME \\DOBUFFEREDTRANSITIONS \\TIMER.INTERRUPTFRAME \\CAUSEINTERRUPT \\DOMOUSECHORDING \\KEYBOARDOFF \\TRACKCURSOR \\HARDCURSORUP \\HARDCURSORPOSITION \\HARDCURSORDOWN \\SOFTCURSORUP \\SOFTCURSORUPCURRENT \\SOFTCURSORPOSITION \\SOFTCURSORDOWN \\SOFTCURSORPILOTBITBLT) (LOCKEDVARS |\\InterfacePage| \\CURSORHOTSPOTX \\CURSORHOTSPOTY \\CURRENTCURSOR \\SOFTCURSORWIDTH \\SOFTCURSORHEIGHT \\SOFTCURSORP \\SOFTCURSORUPP \\SOFTCURSORUPBM \\SOFTCURSORDOWNBM \\SOFTCURSORBBT1 \\SOFTCURSORBBT2 \\SOFTCURSORBBT3 \\SOFTCURSORBBT4 \\SOFTCURSORBBT5 \\SOFTCURSORBBT6 \\CURSORDESTINATION \\CURSORDESTHEIGHT \\CURSORDESTWIDTH \\CURSORDESTRASTERWIDTH \\CURSORDESTLINE \\CURSORDESTLINEBASE \\PENDINGINTERRUPT \\PERIODIC.INTERRUPT \\PERIODIC.INTERRUPT.FREQUENCY \\LASTUSERACTION \\MOUSECHORDTICKS \\KEYBOARDEVENTQUEUE \\KEYBUFFERING SCREENWIDTH SCREENHEIGHT \\TIMER.INTERRUPT.PENDING \\EM.MOUSEX \\EM.MOUSEY \\EM.CURSORX \\EM.CURSORY \\EM.UTILIN \\EM.REALUTILIN \\EM.KBDAD0 \\EM.KBDAD1 \\EM.KBDAD2 \\EM.KBDAD3 \\EM.DISPINTERRUPT \\EM.CURSORBITMAP \\EM.KBDAD4 \\EM.KBDAD5 \\MISCSTATS \\RCLKSECOND)) (FNS I.\\LOCKFN I.\\LOCKVAR I.\\LOCKCELL I.\\LOCKWORDS I.\\LOCKCODE) (ADDVARS (LOCKEDFNS \\FAULTHANDLER \\FAULTINIT \\DOVE.FAULTINIT \\D01.FAULTINIT \\DL.FAULTINIT \\CHAIN.UP.RPT \\MAKESPACEFORLOCKEDPAGE \\PAGEFAULT \\WRITEMAP \\LOOKUPPAGEMAP \\LOCKEDPAGEP \\LOADVMEMPAGE \\MOVEREALPAGE \\INVALIDADDR \\INVALIDVP \\SELECTREALPAGE \\TRANSFERPAGE \\SPECIALRP \\UPDATECHAIN \\MARKPAGEVACANT \\FLUSHPAGE \\CLEARWORDS \\FLUSHVM \\DONEWPAGE \\ASSURE.FPTOVP.PAGE \\DONEWEPHEMERALPAGE \\WRITEDIRTYPAGE1 \\COPYSYS0 \\COPYSYS0SUBR \\RELEASEWORKINGSET \\DOFLUSHVM \\DOLOCKPAGES \\DOTEMPLOCKPAGES \\TEMPUNLOCKPAGES \\MP.ERROR RAID \\DL.NEWFAULTINIT \\DL.MARK.PAGES.UNAVAILABLE \\DL.UNMAPPAGES \\DL.ASSIGNBUFFERS \\D01.ASSIGNBUFFERS \\DOCOMPRESSVMEM \\MOVEVMEMFILEPAGE \\SET.VMEM.FULL.STATE \\HINUM \\LONUM \\ATOMCELL SETTOPVAL) (LOCKEDVARS \\REALPAGETABLE \\RPTLAST \\PAGEFAULTCOUNTER \\UPDATECHAINFREQ \\RPOFFSET \\RPTSIZE \\LOCKEDPAGETABLE \\EMBUFBASE \\EMBUFVP \\EMBUFRP \\LASTACCESSEDVMEMPAGE \\MAXSHORTSEEK \\MAXCLEANPROBES \\MINSHORTSEEK \\DIRTYPAGECOUNTER \\DIRTYPAGEHINT \\VMEM.INHIBIT.WRITE \\VMEM.PURE.LIMIT \\VMEM.FULL.STATE \\GUARDVMEMFULL VMEM.COMPRESS.FLG \\KBDSTACKBASE \\MISCSTACKBASE \\DOFAULTINIT \\FPTOVP \\MACHINETYPE \\VMEMACCESSFN \\TELERAIDBUFFER \\EMUDISKBUFFERS \\EMUDISKBUFEND \\MAXSWAPBUFFERS \\EMUBUFFERS \\#EMUBUFFERS \\#SWAPBUFFERS \\#DISKBUFFERS \\RCLKSECOND \\RCLKMILLISECOND \\VALSPACE \\EMUSWAPBUFFERS \\EM.CURSORBITMAP \\PAGEMAP |\\PageMapTBL| \\IOCBPAGE \\IOPAGE \\MISCSTATS \\DEFSPACE |\\InterfacePage| \\LASTVMEMFILEPAGE |\\DoveIORegion| |\\MaxScreenPage| \\NEWVMEMPAGEADDED)) (FNS I.DUMPINITPAGES) (VARS INITCONSTANTS) (FNS I.SETUPPAGEMAP I.ADDPME I.MAKEROOMFORPME I.MAPPAGES) (FNS I.SETUPSTACK I.\\SETUPSTACK1 I.\\SETUPGUARDBLOCK I.\\MAKEFREEBLOCK) (ADDVARS (LOCKEDFNS \\RESETSTACK0 \\MAKEFRAME \\SETUPSTACK1 \\MAKEFREEBLOCK \\FAULTHANDLER \\KEYHANDLER \\DUMMYKEYHANDLER \\DOTELERAID \\DUMMYTELERAID \\DOHARDRETURN \\DOGC \\CAUSEINTERRUPT \\INTERRUPTFRAME \\CODEFORTFRAME \\DOSTACKOVERFLOW \\UNLOCKPAGES \\DOMISCAPPLY) (LOCKEDVARS |\\InterfacePage| \\DEFSPACE \\STACKSPACE \\KBDSTACKBASE \\MISCSTACKBASE \\SAVED.USER.CONTEXT \\RUNNING.PROCESS \\NEED.HARDRESET.CLEANUP)) (FNS I.INITGC) (FNS I.NTYPX I.\\ALLOCMDSPAGE I.\\MAKEMDSENTRY I.\\INITMDSPAGE I.\\ASSIGNDATATYPE1 I.\\TYPENUMBERFROMNAME I.\\CREATECELL I.\\NEW2PAGE) (FNS I.CREATEMDSTYPETABLE I.INITDATATYPES I.INITDATATYPENAMES) (VARS \\BUILT-IN-SYSTEM-TYPES) (FNS I.FSETVAL I.SETPROPLIST I.PUTDEFN I.\\BLT) (FNS I.\\MKATOM I.\\CREATE.SYMBOL I.\\INITATOMPAGE I.\\MOVEBYTES I.\\STKMIN) (FNS I.COPYATOM I.INITATOMS) (FNS I.MAKEINITFIRST I.\\COPY I.MAKEINITLAST) (FNS I.\\CONS.UFN I.\\MAIKO.CONS.UFN I.\\INITCONSPAGE I.\\NEXTCONSPAGE) (FNS I.\\GETBASEBYTE I.\\PUTBASEBYTE I.CREATEPAGES I.\\NEW4PAGE) (FILES (SYSLOAD FROM VALUEOF DIRECTORIES) CMLARRAY-SUPPORT) (FNS I.ALLOCSTRING I.%COPY-ONED-ARRAY I.%COPY-STRING-TO-ARRAY) (FNS I.\\#BLOCKDATACELLS I.\\PREFIXALIGNMENT? I.\\ALLOCBLOCK I.\\MAIKO.ALLOCBLOCK I.\\ALLOCBLOCK.NEW I.\\MAKEFREEARRAYBLOCK I.\\MERGEBACKWARD I.\\LINKBLOCK I.\\ALLOCHUNK) (FNS I.PREINITARRAYS I.POSTINITARRAYS I.FILEARRAYBASE I.FILEBLOCKTRAILER I.FILECODEBLOCK I.FILEPATCHBLOCK) (FNS I.\\SETUP.HUNK.TYPENUMBERS I.\\COMPUTE.HUNK.TYPEDECLS I.\\TURN.ON.HUNKING I.\\SETUP.TYPENUM.TABLE) (FNS I.DCODERD) (VARS \\OPCODES (I.CODERDTBL (COPYREADTABLE (QUOTE ORIG)))) (P (SETSYNTAX (CHARCODE ^Y) (QUOTE (MACRO (LAMBDA (FILE RDTBL) (EVALFORMAKEINIT (READ FILE RDTBL))))) I.CODERDTBL) (SETSYNTAX (CHARCODE \|) (QUOTE (MACRO ALWAYS READVBAR)) I.CODERDTBL) (READTABLEPROP I.CODERDTBL (QUOTE USESILPACKAGE) NIL)) (FNS I.INITUFNTABLE I.\\SETUFNENTRY) (VARS INITPTRS INITVALUES) (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) MAKEINIT)))
+)
+
+(ADDTOVAR LOCKEDFNS \\CLOCK0 \\GETINTERNALCLOCK \\BOXIDIFFERENCE \\BOXIPLUS \\BLT \\SLOWIQUOTIENT)
+
+(ADDTOVAR LOCKEDVARS \\RCLKSECOND \\RCLKMILLISECOND \\MISCSTATS)
+
+(ADDTOVAR LOCKEDFNS ERROR RAID \\M44ACTONVMEMFILE \\ACTONVMEMFILESUBR \\ACTONVMEMPAGES \\CLEANUPDISKQUEUE
+ \\CLEARCB \\DISKERROR \\DOACTONDISKPAGES \\DODISKCOMMAND \\EXTENDISFMAP \\M44DOEXTENDVMEMFILE \\GETDISKCB
+ \\INITBFS \\INSUREVMEMFILE \\LISPERROR \\LOOKUPFMAP \\REALDISKDA \\VIRTUALDISKDA \\CLEARWORDS \\TESTPARTITION
+ \\EXTENDEDVMEMINIT \\WHICHPART \\INITIALIZESWAPDISK \\SWAPDISKERROR)
+
+(ADDTOVAR LOCKEDVARS \\DISKREQUESTBLOCK \\SWAPREQUESTBLOCK \\MAINDISK \\SWAPDSK1 \\SWAPDSK2 \\ISFCHUNKSIZE
+ \\EMUSCRATCH \\EMUDISKBUFFERS \\EMUSWAPBUFFERS \\EMUDISKBUFEND \\MAXSWAPBUFFERS \\#DISKBUFFERS |\\InterfacePage|
+ \\ISFMAP \\ISFSCRATCHCAS \\ISFSCRATCHDAS \\SYSDISK \\#SWAPBUFFERS \\MAXDISKDA\s \\DISKDEBUG \\SPAREDISKWRITEBUFFER
+ \\#EMUBUFFERS \\EMUBUFFERS \\LASTVMEMFILEPAGE |\\XVmem| |\\XVmemFmapBase| |\\XVmemFmapHighBase| |\\XVmemDiskBase|
+)
+(DEFINEQ
+
+(I.MAKEINITBFS
+(LAMBDA NIL (*) (*) (PROGN (*) (I.\\LOCKWORDS (SETQ I.MAINDISK ((LAMBDA ($$1) (I.PUTBASEPTR $$1 0 NIL) $$1) (I.\\ALLOCBLOCK 18))) 36) (I.PUTBASEPTR I.MAINDISK 26 (I.\\COPY (QUOTE DSK))) (I.\\LOCKWORDS (SETQ I.SWAPDSK1 ((LAMBDA ($$1) (I.PUTBASEPTR $$1 0 NIL) $$1) (I.\\ALLOCBLOCK 18))) 36) (I.\\LOCKWORDS (SETQ I.SWAPDSK2 ((LAMBDA ($$1) (I.PUTBASEPTR $$1 0 NIL) $$1) (I.\\ALLOCBLOCK 18))) 36)) (PROGN (*) (I.\\LOCKWORDS (SETQ I.SWAPREQUESTBLOCK (I.\\ALLOCBLOCK (LRSH (IPLUS (IPLUS 42 60) 1) 1))) (+ 42 60)) (I.\\LOCKWORDS (SETQ I.DISKREQUESTBLOCK (I.\\ALLOCBLOCK (LRSH (IPLUS (IPLUS 42 60) 1) 1))) (+ 42 60))) (|to| 3 |bind| PREV (FIRSTCB _ (I.\\ALLOCBLOCK 3)) |first| (I.\\LOCKWORDS (SETQ PREV FIRSTCB) 6) |do| (I.\\LOCKWORDS (SETQ PREV ((LAMBDA ($$1) (PROG1 (SETQ $$1 (I.\\ALLOCBLOCK 3)) (I.PUTBASEPTR $$1 0 PREV))) NIL)) 6) |finally| (I.PUTBASEPTR FIRSTCB 0 PREV) (*) (I.PUTBASEPTR I.MAINDISK 14 FIRSTCB)) (SETQ I.FREEPAGEFID (I.\\ALLOCBLOCK 3)) (*) (|for| I |from| 0 |to| 4 |do| (I.PUTBASE I.FREEPAGEFID I (UNSIGNED -1 16))))
+)
+)
+
+(ADDTOVAR LOCKEDFNS FLIPCURSORBAR \\SETIOPOINTERS \\KEYHANDLER \\KEYHANDLER1 \\CONTEXTAPPLY \\LOCKPAGES
+ \\DECODETRANSITION \\SMASHLINK \\INCUSECOUNT LLSH \\MAKEFREEBLOCK \\DECUSECOUNT \\MAKENUMBER \\ADDBASE
+ \\PERIODIC.INTERRUPTFRAME \\DOBUFFEREDTRANSITIONS \\TIMER.INTERRUPTFRAME \\CAUSEINTERRUPT \\DOMOUSECHORDING
+ \\KEYBOARDOFF \\TRACKCURSOR \\HARDCURSORUP \\HARDCURSORPOSITION \\HARDCURSORDOWN \\SOFTCURSORUP \\SOFTCURSORUPCURRENT
+ \\SOFTCURSORPOSITION \\SOFTCURSORDOWN \\SOFTCURSORPILOTBITBLT)
+
+(ADDTOVAR LOCKEDVARS |\\InterfacePage| \\CURSORHOTSPOTX \\CURSORHOTSPOTY \\CURRENTCURSOR \\SOFTCURSORWIDTH
+ \\SOFTCURSORHEIGHT \\SOFTCURSORP \\SOFTCURSORUPP \\SOFTCURSORUPBM \\SOFTCURSORDOWNBM \\SOFTCURSORBBT1
+ \\SOFTCURSORBBT2 \\SOFTCURSORBBT3 \\SOFTCURSORBBT4 \\SOFTCURSORBBT5 \\SOFTCURSORBBT6 \\CURSORDESTINATION
+ \\CURSORDESTHEIGHT \\CURSORDESTWIDTH \\CURSORDESTRASTERWIDTH \\CURSORDESTLINE \\CURSORDESTLINEBASE \\PENDINGINTERRUPT
+ \\PERIODIC.INTERRUPT \\PERIODIC.INTERRUPT.FREQUENCY \\LASTUSERACTION \\MOUSECHORDTICKS \\KEYBOARDEVENTQUEUE
+ \\KEYBUFFERING SCREENWIDTH SCREENHEIGHT \\TIMER.INTERRUPT.PENDING \\EM.MOUSEX \\EM.MOUSEY \\EM.CURSORX
+ \\EM.CURSORY \\EM.UTILIN \\EM.REALUTILIN \\EM.KBDAD0 \\EM.KBDAD1 \\EM.KBDAD2 \\EM.KBDAD3 \\EM.DISPINTERRUPT
+ \\EM.CURSORBITMAP \\EM.KBDAD4 \\EM.KBDAD5 \\MISCSTATS \\RCLKSECOND)
+(DEFINEQ
+
+(I.\\LOCKFN
+(LAMBDA (FN) (*) (I.\\LOCKCELL (SETQ FN (I.\\ATOMCELL (PROGN (I.\\COPY FN)) 10))) (COND ((NEQ 0 (LRSH (I.GETBASE FN 0) 15)) (I.\\LOCKCODE (I.GETBASEPTR FN 0)))))
+)
+
+(I.\\LOCKVAR
+(LAMBDA (VAR) (*) (I.\\LOCKCELL (I.\\ATOMCELL (PROGN (I.\\COPY VAR)) 12))))
+
+(I.\\LOCKCELL
+(LAMBDA (X NPGS) (*) (MKI.LOCKPAGES (I.VAG2 (I.HILOC X) (LOGAND (I.LOLOC X) 65280)) (OR NPGS 1))))
+
+(I.\\LOCKWORDS
+(LAMBDA (BASE NWORDS) (*) (MKI.LOCKPAGES (I.VAG2 (I.HILOC BASE) (LOGAND (I.LOLOC BASE) 65280)) (COND (NWORDS (LRSH (IPLUS (IPLUS (LOGAND (I.LOLOC BASE) 255) NWORDS) 255) 8)) (T 1))))
+)
+
+(I.\\LOCKCODE
+(LAMBDA (CODEBLOCK) (*) (I.\\LOCKWORDS CODEBLOCK (LLSH (I.\\#BLOCKDATACELLS CODEBLOCK) 1))))
+)
+
+(ADDTOVAR LOCKEDFNS \\FAULTHANDLER \\FAULTINIT \\DOVE.FAULTINIT \\D01.FAULTINIT \\DL.FAULTINIT \\CHAIN.UP.RPT
+ \\MAKESPACEFORLOCKEDPAGE \\PAGEFAULT \\WRITEMAP \\LOOKUPPAGEMAP \\LOCKEDPAGEP \\LOADVMEMPAGE \\MOVEREALPAGE
+ \\INVALIDADDR \\INVALIDVP \\SELECTREALPAGE \\TRANSFERPAGE \\SPECIALRP \\UPDATECHAIN \\MARKPAGEVACANT \\FLUSHPAGE
+ \\CLEARWORDS \\FLUSHVM \\DONEWPAGE \\ASSURE.FPTOVP.PAGE \\DONEWEPHEMERALPAGE \\WRITEDIRTYPAGE1 \\COPYSYS0
+ \\COPYSYS0SUBR \\RELEASEWORKINGSET \\DOFLUSHVM \\DOLOCKPAGES \\DOTEMPLOCKPAGES \\TEMPUNLOCKPAGES \\MP.ERROR
+ RAID \\DL.NEWFAULTINIT \\DL.MARK.PAGES.UNAVAILABLE \\DL.UNMAPPAGES \\DL.ASSIGNBUFFERS \\D01.ASSIGNBUFFERS
+ \\DOCOMPRESSVMEM \\MOVEVMEMFILEPAGE \\SET.VMEM.FULL.STATE \\HINUM \\LONUM \\ATOMCELL SETTOPVAL)
+
+(ADDTOVAR LOCKEDVARS \\REALPAGETABLE \\RPTLAST \\PAGEFAULTCOUNTER \\UPDATECHAINFREQ \\RPOFFSET \\RPTSIZE
+ \\LOCKEDPAGETABLE \\EMBUFBASE \\EMBUFVP \\EMBUFRP \\LASTACCESSEDVMEMPAGE \\MAXSHORTSEEK \\MAXCLEANPROBES
+ \\MINSHORTSEEK \\DIRTYPAGECOUNTER \\DIRTYPAGEHINT \\VMEM.INHIBIT.WRITE \\VMEM.PURE.LIMIT \\VMEM.FULL.STATE
+ \\GUARDVMEMFULL VMEM.COMPRESS.FLG \\KBDSTACKBASE \\MISCSTACKBASE \\DOFAULTINIT \\FPTOVP \\MACHINETYPE
+ \\VMEMACCESSFN \\TELERAIDBUFFER \\EMUDISKBUFFERS \\EMUDISKBUFEND \\MAXSWAPBUFFERS \\EMUBUFFERS \\#EMUBUFFERS
+ \\#SWAPBUFFERS \\#DISKBUFFERS \\RCLKSECOND \\RCLKMILLISECOND \\VALSPACE \\EMUSWAPBUFFERS \\EM.CURSORBITMAP
+ \\PAGEMAP |\\PageMapTBL| \\IOCBPAGE \\IOPAGE \\MISCSTATS \\DEFSPACE |\\InterfacePage| \\LASTVMEMFILEPAGE
+ |\\DoveIORegion| |\\MaxScreenPage| \\NEWVMEMPAGEADDED)
+(DEFINEQ
+
+(I.DUMPINITPAGES
+(LAMBDA (CODEFIRSTPAGE CODENEXTPAGE VERSIONS) (*) (*) (I.ADDPME (IPLUS (LLSH (I.HILOC (I.VAG2 6 0)) 8) (LRSH (I.LOLOC (I.VAG2 6 0)) 8)) T) (*) (|for| I |from| CODEFIRSTPAGE |to| (SUB1 CODENEXTPAGE) |do| (*) (I.ADDPME I T)) (I.MAPPAGES 0 (ADD1 65533) (FUNCTION I.MAKEROOMFORPME)) (I.MAPPAGES 0 (ADD1 65533) (FUNCTION I.ADDPME)) (PROGN (*) (I.PUTBASE (I.VAG2 6 0) 19 NEXTPM) (I.PUTBASEFIXP (I.VAG2 6 0) 82 (SUB1 NEXTVMEM)) (I.PUTBASEFIXP (I.VAG2 6 0) 84 (SUB1 NEXTVMEM)) (I.PUTBASE (I.VAG2 6 0) 22 (I.GETBASE (I.VAG2 5 0) 0)) (I.PUTBASE (I.VAG2 6 0) 23 (I.GETBASE ((LAMBDA (VPAGE) (DECLARE (LOCALVARS VPAGE)) (I.ADDBASE (I.VAG2 5 0) (IPLUS (I.GETBASE (I.VAG2 6 512) (LRSH VPAGE 5)) (LOGAND VPAGE 31)))) (IPLUS (LLSH (I.HILOC (I.VAG2 6 512)) 8) (LRSH (I.LOLOC (I.VAG2 6 512)) 8))) 0)) (COND (VERSIONS (I.PUTBASE (I.VAG2 6 0) 8 (CAR VERSIONS)) (I.PUTBASE (I.VAG2 6 0) 10 (CADDR VERSIONS)) (I.PUTBASE (I.VAG2 6 0) 9 (CADR VERSIONS)))) (I.PUTBASE (I.VAG2 6 0) 15 5603)) (I.MAPPAGES 0 (ADD1 65533) (FUNCTION DUMPVP)) (PROG ((FILE (OUTPUT))) (COND ((NOT (RANDACCESSP FILE)) (* \; "SYSOUT file is sequential;  have to get it random access for this") (OUTPUT (SETQ FILE (OPENFILE (CLOSEF FILE) (QUOTE BOTH)))))) (SETFILEPTR FILE |MKI.Page0Byte|)) (DUMPVP (IPLUS (LLSH (I.HILOC (I.VAG2 6 0)) 8) (LRSH (I.LOLOC (I.VAG2 6 0)) 8))))
+)
+)
+
+(RPAQQ INITCONSTANTS ((* |;;;| "(LISPNAME VALUE BCPLNAME UCODENAME)") (CDRCODING 1 T T) (* \; "IF CDRCODING=0, CDR CODING IS OFF, OTHERWISE ON") (* |;;| "type numbers -- repeated on LLBASIC too") (\\SMALLP 1 SMALLTYPE |SmallType|) (\\FIXP 2 INTEGERTYPE |FixpType|) (\\FLOATP 3 FLTPTTYPE |FloatpType|) (\\LITATOM 4 ATOMTYPE |AtomType|) (\\LISTP 5 LISTTYPE |ListType|) (\\ARRAYP 6 ARRAYPTRTYPE |ArrayType|) (\\STRINGP 7 STRINGPTRTYPE) (\\STACKP 8) (\\CHARACTERP 9) (\\VMEMPAGEP 10 NIL |VMemPagePType|) (\\STREAM 11 NIL STREAMTYPE) (* |;;| "TYPE TABLE CONSTANTS") (\\TT.TYPEMASK 2047 |TTTypeMask| T) (\\TT.NOREF 32768 NIL T) (\\TT.SYMBOLP 16384 NIL T) (\\TT.FIXP 8192) (\\TT.NUMBERP 4096) (\\TT.ATOM 2048) (* |;;| "page map") (|\\PMblockSize| 32 PMBLOCKSIZE) (|\\STATSsize| 8 T) (|\\NumPMTpages| 8) (|\\EmptyPMTEntry| 65535 T) (|\\FirstVmemBlock| 2 T) (\\MAXVMPAGE 65533) (\\MAXVMSEGMENT 255) (* |;;| "interface page") (|\\IFPValidKey| 5603 T) (* |;;| "MDS") (|\\FirstMDSPage| 16382) (|\\MaxMDSPage| 65533) (|\\DefaultSecondMDSPage| 65532) (|\\MDSIncrement| 512) (|\\PagesPerMDSUnit| 2) (* \; "(FOLDLO \\MDSIncrement WORDSPERPAGE)") (* |;;| "arrays") (\\ARRAYSPACE (23 0)) (|\\FirstArraySegment| 23) (|\\FirstArrayPage| 5888) (\\ARRAYSPACE2 (64 0)) (|\\DefaultSecondArrayPage| 16384) (* |;;| "stack block constants") (|\\StackMask| 57344 T T) (|\\FxtnBlock| 49152 T T) (|\\GuardBlock| 57344 T T) (|\\BFBlock| 32768 T T) (|\\FreeStackBlock| 40960 T T) (|\\NotStackBlock| 0) (* \; "none of the above") (|\\MinExtraStackWords| 32 T T) (* |;;| "backspace kludge") (ERASECHARCODE 0 T) (* |;;| "GC constants") (\\HT1CNT 1024 NIL T) (\\HTSTKBIT 512 NIL T) (\\HTCNTMASK 64512 NIL T) (\\HTMAINSIZE 65536 NIL T) (\\HTCOLLSIZE 262144 NIL T) (\\HTENDFREE 1 NIL T) (\\HTFREEPTR 0 NIL T) (* |;;| "pointers and lengths of various data spaces") (\\ATOMSPACE (0 0) (|ATOMspace| NIL) (|atomHiVal| NIL)) (|\\AtomHI| 0) (\\CHARHI 7) (* \; "overlap character space and the atom hash table space") (|\\AtomHashTable| (7 0) (|AHTspace| |AHTbase|)) (|\\AtomHTpages| 256 AHTSIZE) (|\\LastAtomPage| 255) (|\\MaxAtomFrLst| 65535) (\\SMALLPOSPSPACE (14 0)) (|\\SmallPosHi| 14 |SMALLPOSspace| |smallpl|) (\\SMALLNEGSPACE (15 0)) (|\\SmallNegHi| 15 |SMALLNEGspace| |smallneg|) (|\\NumSmallPages| 512) (\\PNPSPACE (8 0) (|PNPspace| |PNPbase|)) (\\PNAME.HI 8) (\\DEFSPACE (10 0) (|DEFspace| |DEFbase|) (|DEFspace| |DEFbase|)) (\\DEF.HI 10) (\\VALSPACE (12 0) (|TOPVALspace| |TOPVALbase|) (|VALspace| |VALbase|)) (\\VAL.HI 12) (\\PLISTSPACE (2 0) (|PLISTspace| |PLISTbase|)) (\\PLIST.HI 2) (\\PAGEMAP (5 0) (|PAGEMAPspace| |PAGEMAPbase|)) (|\\NumPageMapPages| 256) (|\\PageMapTBL| (6 512) (|PMTspace| |PMTbase|)) (|\\InterfacePage| (6 0) (|INTERFACEspace| |INTERFACEbase|) (|INTERFACEspace| |INTERFACEbase|)) (\\IOPAGE (0 65280)) (|\\DoveIORegion| (0 16384)) (\\IOCBPAGE (0 256)) (\\FPTOVP (2 0)) (|\\MDSTypeTable| (20 0) (|MDSTYPEspace| |MDSTYPEbase|) (|MDSTYPEspace| |MDSTYPEbase|)) (|\\MDSTTsize| 256 T) (\\MISCSTATS (6 2560) (|STATSspace| |MISCSTATSbase|)) (|\\UFNTable| (6 3072) NIL (|STATSspace| |UFNTablebase|)) (|\\UFNTableSize| 2) (|\\DTDSpaceBase| (6 4096) (|DTDspace| |DTDbase|) (|DTDspace| |DTDbase|)) (|\\DTDSize| 18 T) (\\LISTPDTD (6 4186)) (|\\EndTypeNumber| 2047) (\\LOCKEDPAGETABLE (6 28672)) (|\\NumLPTPages| 16) (\\STACKSPACE (1 0) (|STACKspace| NIL) (|STACKspace| NIL)) (|\\GuardStackAddr| 61440) (|\\LastStackAddr| 65534) (\\STACKHI 1 T T) (\\HTMAIN (16 0) (|HTMAINspace| |HTMAINbase|) (|HTMAINspace| |HTMAINbase|)) (|\\HTMAINnpages| 256 T) (\\HTOVERFLOW (17 0) NIL (NIL |HTOVERFLOWbase|)) (\\HTBIGCOUNT (17 32768)) (\\HTCOLL (10 0) NIL (|HTCOLLspace| |HTCOLLbase|)) (\\DISPLAYREGION (18 0)) (|\\D1BCPLspace| 0 T |LEmubrHiVal|) (|\\D0BCPLspace| 0 T) (* |;;| "Interface Page locations") (|\\CurrentFXP| 0 T T) (|\\ResetFXP| 1 T T) (|\\SubovFXP| 2 T T) (|\\KbdFXP| 3 T T) (|\\HardReturnFXP| 4 T T) (\\GCFXP 5) (\\FAULTFXP 6 T T) (|\\MiscFXP| 14 T T) (|\\TeleRaidFXP| 24 T T) (* |;;| "emulator segment locations") (DCB.EM 272) (DISPINTERRUPT.EM 273) (CURSORBITMAP.EM 281) (KBDAD0.EM 65052) (KBDAD1.EM 65053) (KBDAD2.EM 65054) (KBDAD3.EM 65055) (UTILIN.EM 65048) (CURSORX.EM 278) (CURSORY.EM 279) (MOUSEX.EM 276) (MOUSEY.EM 277) (|\\LispKeyMask| 8192 T T) (|\\BcplKeyMask| 4352 T T) (* \; "Machine types") (\\MAIKO 3) (\\DOLPHIN 4) (\\DORADO 5) (\\DANDELION 6) (\\DAYBREAK 8) (* |;;| "FOR DLION (AND DAYBREAK)") (\\VP.DISPLAY 4608) (\\NP.DISPLAY 202) (* \; "for Dorado display 1024x808 pixels / (16 pixels/word x 256 words/page)") (\\NP.WIDEDOVEDISPLAY 243) (* \; "Wide Dove display 1152x864 pixels") (\\WIDEDOVEDISPLAYWIDTH 1152) (\\RP.AFTERDISPLAY 206) (* \; "Includes 4 pages for cursor") (\\RP.AFTERDOVEDISPLAY 243) (* \; "if big screen") (\\RP.DISPLAY 0) (\\RP.TEMPDISPLAY 2561) (\\RP.MISCLOCKED 2804) (* \; "(+ \\RP.TEMPDISPLAY \\NP.WIDEDOVEDISPLAY)") (\\RP.STACK 768) (\\VP.STACK 256) (\\RP.MAP 256) (\\NP.MAP 256) (\\RP.IOPAGE 512) (* \; "The DOVE IOCBPAGE can go anywhere, but should be under the 1mbyte range") (\\RP.DOVEIOCBPAGE 543) (\\RP.DOVEIORGN 544) (\\VP.DOVEIORGN 64) (\\DOVEIORGNSIZE 64) (\\VP.IOPAGE 255) (\\VP.IFPAGE 1536) (\\VP.FPTOVP 512) (\\NP.FPTOVP 1024) (\\RP.FPTOVP 1024) (\\RP.STARTBUFFERS 640) (\\VP.TYPETABLE 5120) (\\NP.TYPETABLE 256) (\\RP.TYPETABLE 2048) (\\VP.GCTABLE 4096) (\\NP.GCTABLE 256) (\\RP.GCTABLE 2304) (\\VP.GCOVERFLOW 4352) (\\NP.GCOVERFLOW 1) (\\RP.GCOVERFLOW 2560) (\\FP.IFPAGE 2) (\\VP.IOCBS 1) (\\VP.PRIMARYMAP 1538) (\\VP.SECONDARYMAP 1280) (\\VP.LPT 1648) (\\VP.INITSCRATCH 8) (\\VP.RPT 128) (\\VP.BUFFERS 218) (* \; "DLion processor commands") (\\DL.PROCESSORBUSY 32768) (\\DL.SETTOD 32769) (\\DL.READTOD 32770) (\\DL.READPID 32771) (\\DL.BOOTBUTTON 32772))
+)
+(DEFINEQ
+
+(I.SETUPPAGEMAP
+(LAMBDA NIL (*) (*) (PROG NIL (*) (MKI.NEWPAGE (I.VAG2 5 0) NIL T) (*) (I.CREATEPAGES (I.VAG2 6 512) 8 NIL T) (*) (*) (|for| I |from| 0 |to| (SUB1 (LLSH 8 8)) |do| (I.PUTBASE (I.VAG2 6 512) I 65535)) (SETQ NEXTPM 0) (|for| I |from| 0 |to| (SUB1 (LRSH 256 5)) |bind| (PAGEMAPKEY _ (LRSH (PROGN (IPLUS (LLSH (I.HILOC (I.VAG2 5 0)) 8) (LRSH (I.LOLOC (I.VAG2 5 0)) 8))) 5)) |do| (*) (I.PUTBASE (I.VAG2 6 512) (IPLUS PAGEMAPKEY I) NEXTPM) (SETQ NEXTPM (IPLUS NEXTPM 32))) (SETQ NEXTVMEM 2) (*) (I.CREATEPAGES (I.VAG2 6 28672) 16 NIL T)))
+)
+
+(I.ADDPME
+(LAMBDA (VP NEWPAGEOK) (*) (*) (PROG (PX PMP LOCKBASE) (COND ((IEQ (SETQ PMP (I.GETBASE (I.VAG2 6 512) (LRSH VP 5))) 65535) (*) (COND ((EVENP NEXTPM 256) (*) (SETQ PX (I.ADDBASE (I.VAG2 5 0) NEXTPM)) (OR NEWPAGEOK (IGREATERP (IPLUS (LLSH (I.HILOC PX) 8) (LRSH (I.LOLOC PX) 8)) VP) (HELP "page map needs new page after page map written out")) (MKI.NEWPAGE PX NIL T))) (I.PUTBASE (I.VAG2 6 512) (LRSH VP 5) (SETQ PMP NEXTPM)) (SETQ NEXTPM (IPLUS NEXTPM 32)))) (SETQ PX (IPLUS PMP (LOGAND VP 31))) (COND ((NEQ (I.GETBASE (I.VAG2 5 0) PX) 0) (HELP "page already in pagemap" VP)) (T (I.PUTBASE (I.VAG2 5 0) PX NEXTVMEM) (COND ((MKI.LOCKEDPAGEP VP) (*) (I.PUTBASE (SETQ LOCKBASE (I.ADDBASE (I.VAG2 6 28672) (LRSH VP 4))) 0 (LOGOR (LLSH 1 (IMOD VP 16)) (I.GETBASE LOCKBASE 0))))) (SETQ NEXTVMEM (ADD1 NEXTVMEM))))))
+)
+
+(I.MAKEROOMFORPME
+(LAMBDA (VP) (*) (*) (COND ((IEQ (I.GETBASE (I.VAG2 6 512) (LRSH VP 5)) 65535) (*) (COND ((EVENP NEXTPM 256) (*) (MKI.NEWPAGE (I.ADDBASE (I.VAG2 5 0) NEXTPM) NIL T))) (I.PUTBASE (I.VAG2 6 512) (LRSH VP 5) NEXTPM) (SETQ NEXTPM (IPLUS NEXTPM 32)))))
+)
+
+(I.MAPPAGES
+(LAMBDA (BOT TOP FN) (*) (*) (PROG ((VP BOT) (IVP (IPLUS (LLSH (I.HILOC (I.VAG2 6 0)) 8) (LRSH (I.LOLOC (I.VAG2 6 0)) 8)))) LP (COND ((AND (SETQ VP (MKI.NEXTPAGE VP)) (IGREATERP TOP VP)) (COND ((NOT (IEQ VP IVP)) (APPLY* FN VP))) (SETQ VP (ADD1 VP)) (GO LP)))))
+)
+)
+(DEFINEQ
+
+(I.SETUPSTACK
+(LAMBDA (INITFLG) (*) (*) (I.CREATEPAGES (I.VAG2 1 0) (IQUOTIENT 9216 256) NIL T) (*) (I.\\SETUPGUARDBLOCK 0 2) (*) (I.PUTBASE (I.VAG2 6 0) 0 (I.\\SETUPSTACK1 2 0 0 (IDIFFERENCE 768 2) 0 RESETPC RESETPTR NIL INITFLG)) (I.PUTBASE (I.VAG2 6 0) 1 0) (I.PUTBASE (I.VAG2 6 0) 6 0) (I.PUTBASE (I.VAG2 6 0) 2 0) (I.PUTBASE (I.VAG2 6 0) 3 0) (I.\\SETUPGUARDBLOCK (IDIFFERENCE 768 2) 2) (I.PUTBASE (I.VAG2 6 0) 30 (I.\\SETUPGUARDBLOCK 768 (IDIFFERENCE (IDIFFERENCE 9216 768) 2))) (I.PUTBASE (I.VAG2 6 0) 7 (I.\\SETUPGUARDBLOCK (IDIFFERENCE 9216 2) 2)))
+)
+
+(I.\\SETUPSTACK1
+(LAMBDA (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG ARGSLENGTH) (*) (COND ((OR INITFLG (IGREATERP (IDIFFERENCE STKEND STKP) (IPLUS (PROG1 (I.GETBASE DEFPTR 0) (*)) (PROG1 4 (*))))) (*) (PROG ((SP STKP)) (|if| ARGSLENGTH |then| (SETQ ARGSLENGTH (MIN ARGSLENGTH NARGS)) (I.\\BLT (I.VAG2 1 SP) ARGS (LLSH ARGSLENGTH 1)) (SETQ SP (PLUS SP (TIMES ARGSLENGTH 2))) (SETQ ARGS)) (FRPTQ NARGS (I.PUTBASEPTR (I.VAG2 1 0) SP (AND ARGS (PROG1 (CAR ARGS) (SETQ ARGS (CDR ARGS))))) (*) (SETQ SP (PLUS SP 2))) (AND (PROG1 (COND ((ODDP SP 4) (I.PUTBASEPTR (I.VAG2 1 0) SP NIL) (*) (SETQ SP (PLUS SP 2)) T)) (I.PUTBASE (I.VAG2 1 SP) 0 32768)) (LOGAND (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 65279) (LLSH (LOGAND 1 1) 8)))) (I.VAG2 1 SP)) 8) 1)) (I.PUTBASE (I.VAG2 1 SP) 1 STKP) (SETQ STKP (IPLUS SP 2)) (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 255) (LLSH (CONSTANT (CL:READ-FROM-STRING "#B11000001")) 8)))) (I.VAG2 1 STKP)) 8) (*) (LOGAND ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 65280) (LOGAND 0 255)))) (I.VAG2 1 STKP)) 255) (I.PUTBASE (I.VAG2 1 STKP) 8 SP) (I.PUTBASE (I.VAG2 1 STKP) 1 (IPLUS ALINK 10 1)) (I.PUTBASE (I.VAG2 1 STKP) 9 (IPLUS CLINK 10)) (I.PUTBASEPTR (I.VAG2 1 STKP) 2 DEFPTR) (I.PUTBASE (I.VAG2 1 STKP) 5 PC) (SETQ SP (IPLUS STKP (PROGN 10))) (COND ((NOT INITFLG) (*) (RPTQ (LLSH (ADD1 (SIGNED (I.GETBASE DEFPTR 2) 16)) 1) (PROGN (*) (I.PUTBASE (I.VAG2 1 0) SP 65535) (SETQ SP (PLUS SP 2)))))) (I.PUTBASE (I.VAG2 1 STKP) 4 (SETQ SP (PLUS SP (PROGN 4)))) (*) (I.\\MAKEFREEBLOCK SP (IDIFFERENCE STKEND SP)) (RETURN STKP)))))
+)
+
+(I.\\SETUPGUARDBLOCK
+(LAMBDA (STKP LEN) (*) (I.PUTBASE (I.VAG2 1 STKP) 0 57344) (I.PUTBASE (I.VAG2 1 STKP) 1 LEN) STKP))
+
+(I.\\MAKEFREEBLOCK
+(LAMBDA (STK SIZE) (*) (PROGN (*) (I.PUTBASE (I.VAG2 1 STK) 1 SIZE) (I.PUTBASE (I.VAG2 1 STK) 0 40960)))
+)
+)
+
+(ADDTOVAR LOCKEDFNS \\RESETSTACK0 \\MAKEFRAME \\SETUPSTACK1 \\MAKEFREEBLOCK \\FAULTHANDLER \\KEYHANDLER
+ \\DUMMYKEYHANDLER \\DOTELERAID \\DUMMYTELERAID \\DOHARDRETURN \\DOGC \\CAUSEINTERRUPT \\INTERRUPTFRAME
+ \\CODEFORTFRAME \\DOSTACKOVERFLOW \\UNLOCKPAGES \\DOMISCAPPLY)
+
+(ADDTOVAR LOCKEDVARS |\\InterfacePage| \\DEFSPACE \\STACKSPACE \\KBDSTACKBASE \\MISCSTACKBASE \\SAVED.USER.CONTEXT
+ \\RUNNING.PROCESS \\NEED.HARDRESET.CLEANUP)
+(DEFINEQ
+
+(I.INITGC
+(LAMBDA NIL (*) (I.CREATEPAGES (I.VAG2 16 0) (LRSH (IPLUS 65536 255) 8) T T) (I.CREATEPAGES (I.VAG2 17 0) 1 T T) (I.CREATEPAGES (I.VAG2 17 32768) 1 T) (I.CREATEPAGES (I.VAG2 10 0) 1 NIL T) (I.CREATEPAGES (I.ADDBASE (I.VAG2 10 0) 256) (SUB1 (LRSH (IPLUS 262144 255) 8)) T) (I.PUTBASEFIXP (I.VAG2 10 0) 0 0) (I.PUTBASEFIXP (I.VAG2 10 0) 2 2))
+)
+)
+(DEFINEQ
+
+(I.NTYPX
+(LAMBDA (X) (*) (*) (LOGAND (I.GETBASE (I.VAG2 20 0) (LRSH (IPLUS (LLSH (I.HILOC X) 8) (LRSH (I.LOLOC X) 8)) 1)) 2047))
+)
+
+(I.\\ALLOCMDSPAGE
+(LAMBDA (TYP) (*) (PROG (VP VPTR) BEG (COND ((SETQ VP I.MDSFREELISTPAGE) (SETQ VPTR ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 VP) 8) (LLSH (LOGAND $$1 255) 8))) NIL)) (PROG ((NXT (I.GETBASEPTR VPTR 0))) (COND ((AND NXT (NOT (SMALLP NXT))) (\\MP.ERROR 26 "MDS Free Page link bad.  ^N to continue" (PROG1 I.MDSFREELISTPAGE (SETQ I.MDSFREELISTPAGE))) (GO BEG)) (T (SETQ I.MDSFREELISTPAGE NXT))))) (T (NILL) (SETQ VP |I.NxtMDSPage|) (I.PUTBASEFIXP |I.NxtMDSPage| 0 (IDIFFERENCE VP (LRSH 512 8))) (*) (SETQ VPTR ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 VP) 8) (LLSH (LOGAND $$1 255) 8))) NIL)) (MKI.NEWPAGE (I.ADDBASE (MKI.NEWPAGE VPTR) 256)))) (I.\\MAKEMDSENTRY VP TYP) (RETURN VPTR)))
+)
+
+(I.\\MAKEMDSENTRY
+(LAMBDA (VP V) (*) (*) (I.PUTBASE (I.VAG2 20 0) (LRSH VP 1) (COND ((NILL) (LOGOR 32768 V)) (T V)))))
+
+(I.\\INITMDSPAGE
+(LAMBDA (BASE SIZE PREV) (*) (*) (PROG ((SLOP (IREMAINDER 256 SIZE)) NPAGES LIMIT) (*) (COND ((AND (NEQ SLOP 0) (ILESSP SLOP (LRSH SIZE 1)) (ILESSP SIZE 256)) (*) (SETQ NPAGES (IQUOTIENT 512 256)) (SETQ LIMIT 256)) (T (SETQ NPAGES 1) (SETQ LIMIT 512))) (|to| NPAGES |do| (|for| (DISP _ 0) |while| (ILEQ (SETQ DISP (PLUS DISP SIZE)) LIMIT) |do| (I.PUTBASEPTR BASE 0 PREV) (SETQ PREV BASE) (SETQ BASE (I.ADDBASE BASE SIZE))) (SETQ BASE (I.ADDBASE BASE SLOP))) (RETURN PREV)))
+)
+
+(I.\\ASSIGNDATATYPE1
+(LAMBDA (NAME DESCRIPTORS SIZE SPECS PTRFIELDS SUPERTYPE) (*) (*) (PROG ((I.NTYPX (I.\\TYPENUMBERFROMNAME NAME)) (SUPERTYPENUMBER (COND (SUPERTYPE (OR (I.\\TYPENUMBERFROMNAME SUPERTYPE) (ERROR SUPERTYPE ":INCLUDEd datatype but not currently declared"))) (T 0))) DTD REDECLARED NEWTYPENUM NEWDTD) (COND (I.NTYPX (*) (SETQ DTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES I.NTYPX 18))) (COND ((AND (EQUAL PTRFIELDS (I.GETBASEPTR DTD 10)) (EQUAL SIZE (I.GETBASE DTD 3))) (*) (I.PUTBASEPTR DTD 6 DESCRIPTORS) (I.PUTBASE DTD 17 SUPERTYPENUMBER) (RETURN I.NTYPX)) ((EQ (I.GETBASE DTD 3) 0) (*)) ((OR (EQ CROSSCOMPILING T) (AND CROSSCOMPILING (NEQ (QUOTE Y) (ASKUSER 30 (SELECTQ CROSSCOMPILING (Y (QUOTE Y)) (QUOTE N)) (LIST (COND (SIZE "OK TO REDECLARE DATATYPE ") (T "OK to deallocate DATATYPE ")) NAME))))) (*) (RETURN I.NTYPX)) ((IGREATERP I.NTYPX |I.MaxSysTypeNum|) (*) (SETQ REDECLARED T)) (T (*) (ERROR "ILLEGAL DATA TYPE" NAME))))) (*) (COND ((NOT SIZE) (*)) (T (COND ((AND (EQ |I.MaxTypeNumber| 2047) (OR (NULL I.NTYPX) REDECLARED)) (LISPERROR "DATA TYPES FULL" NAME))) (PROGN (COND ((OR (NULL I.NTYPX) REDECLARED) (*) (SETQ NEWTYPENUM (SETQ |I.MaxTypeNumber| (PLUS |I.MaxTypeNumber| 1))) (SETQ NEWDTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES NEWTYPENUM 18))) (*) (COND ((IGEQ (IPLUS (LOGAND (I.LOLOC NEWDTD) 255) 18) 256) (*) (MKI.NEWPAGE (I.ADDBASE NEWDTD 18) T))) (COND (REDECLARED (*) (LET ((NEWTYPEENTRY (LOGOR NEWTYPENUM (LOGAND (I.GETBASE DTD 16) (LOGNOT 2047)))) FOUNDSOME) (\\MAPMDS I.NTYPX (FUNCTION (LAMBDA (PAGE) (I.\\MAKEMDSENTRY PAGE NEWTYPEENTRY) (SETQ FOUNDSOME T)))) (COND ((NOT FOUNDSOME) (*) (SETQ |I.MaxTypeNumber| (PLUS |I.MaxTypeNumber| -1))) (T (I.PUTBASEPTR DTD 6 NIL) (I.PUTBASEPTR DTD 8 NIL) (I.\\BLT NEWDTD DTD 18) (*) (PROGN (I.GETBASEPTR NEWDTD 10)) (NEQ (LOGAND (LRSH (I.PUTBASE NEWDTD 0 (LOGOR (LOGAND (I.GETBASE NEWDTD 0) 57343) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 13))) 13) 1) 0) (I.PUTBASE NEWDTD 16 NEWTYPEENTRY) (I.PUTBASEPTR NEWDTD 0 (NEW-SYMBOL-CODE (PACK* "Obsolete-" NAME) (I.ATOMNUMBER (PACK* "Obsolete-" NAME)))) (I.PUTBASEPTR DTD 4 NIL) (*))))) (T (*) (SETQ I.NTYPX NEWTYPENUM) (I.PUTBASEPTR (SETQ DTD NEWDTD) 0 (NEW-SYMBOL-CODE NAME (I.ATOMNUMBER NAME))))))) (COND ((NEQ SIZE 0) (*) (I.PUTBASE DTD 3 SIZE) (I.PUTBASEPTR DTD 6 (I.\\COPY DESCRIPTORS)) (I.PUTBASEPTR DTD 8 (I.\\COPY SPECS)) (I.PUTBASEPTR DTD 10 PTRFIELDS) (I.PUTBASE DTD 17 SUPERTYPENUMBER) (I.PUTBASE DTD 16 I.NTYPX) (*))) (*)) (RETURN (CL:VALUES I.NTYPX REDECLARED))))))
+)
+
+(I.\\TYPENUMBERFROMNAME
+(LAMBDA (TYPE) (*) (AND TYPE (BIND (INDEX _ (NEW-SYMBOL-CODE TYPE (I.ATOMNUMBER TYPE))) |for| I |from| 1 |to| |I.MaxTypeNumber| |do| (COND ((EQ INDEX (I.GETBASEPTR (I.ADDBASE (I.VAG2 6 4096) (ITIMES I 18)) 0)) (RETURN I))))))
+)
+
+(I.\\CREATECELL
+(LAMBDA (TYP) (*) (COND ((AND (NEQ 1 0) (EQ TYP 5)) (HELP "CREATECELL \\LISTP"))) (LET ((DTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES TYP 18))) NEWCELL) (|while| (EQ (I.GETBASE DTD 3) 0) |do| (ERROR "Attempt to CREATE a type not declared yet" (\\TYPENAMEFROMNUMBER TYP))) (PROGN (COND ((SETQ NEWCELL (I.GETBASEPTR DTD 4)) (*) (I.PUTBASEPTR DTD 4 (I.GETBASEPTR NEWCELL 0)) (*) (LET ((CNT (SUB1 (I.GETBASE DTD 3)))) (*) (I.PUTBASE NEWCELL CNT 0) (I.\\BLT NEWCELL (I.ADDBASE NEWCELL 1) CNT)) (PROGN NEWCELL) NEWCELL) (T (*) (*) (*) (I.PUTBASEPTR DTD 4 (I.\\INITMDSPAGE (I.\\ALLOCMDSPAGE (I.GETBASE DTD 16)) (I.GETBASE DTD 3) (I.GETBASEPTR DTD 4))) (I.\\CREATECELL TYP))))))
+)
+
+(I.\\NEW2PAGE
+(LAMBDA (BASE) (*) (MKI.NEWPAGE (I.ADDBASE (MKI.NEWPAGE BASE) 256))))
+)
+(DEFINEQ
+
+(I.CREATEMDSTYPETABLE
+(LAMBDA NIL (*) (*) (*) (*) (*) (*) (*) (I.CREATEPAGES (I.VAG2 20 0) 256 NIL T) (PROG (VP) (*) (SETQ VP 0) (FRPTQ (LLSH 256 8) (I.PUTBASE (I.VAG2 20 0) VP 32768) (SETQ VP (PLUS VP 1))) (*) (|for| SEGMENT |in| (LIST 14 15) |do| (|for| PAGE |from| 0 |to| (SUB1 256) |by| (LRSH 512 8) |do| (I.\\MAKEMDSENTRY (LOGOR PAGE (LLSH SEGMENT 8)) (LOGOR 32768 8192 4096 2048 1)))) (|for| PAGE |from| 0 |to| (SUB1 256) |by| (LRSH 512 8) |do| (I.\\MAKEMDSENTRY (LOGOR PAGE (LLSH 7 8)) (LOGOR 32768 9)))) (I.CREATEPAGES (I.VAG2 6 2560) (LRSH 512 8) NIL T) (I.\\MAKEMDSENTRY (IPLUS (LLSH (I.HILOC (I.VAG2 6 2560)) 8) (LRSH (I.LOLOC (I.VAG2 6 2560)) 8)) (LOGOR 32768 8192 4096 2048 2)))
+)
+
+(I.INITDATATYPES
+(LAMBDA NIL (*) (*) (LET ((NSYSTYPES (LENGTH INITIALDTDCONTENTS))) (I.CREATEPAGES (I.VAG2 6 4096) 1 NIL T) (*) (I.CREATEPAGES (I.ADDBASE (I.VAG2 6 4096) 256) (SUB1 (LRSH (IPLUS (ADD1 (TIMES (ADD1 NSYSTYPES) 18)) 255) 8))) (*) (*) (|for| D |in| INITIALDTDCONTENTS |bind| DTD |as| TYPENO |from| 1 |do| (*) (SETQ DTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES TYPENO 18))) (*) (I.PUTBASE DTD 16 (LOGOR TYPENO (COND ((FMEMB (CAR D) (QUOTE (SMALLP FIXP FLOATP))) 4096) (T 0)) (COND ((FMEMB (CAR D) (QUOTE (SMALLP FIXP FLOATP LITATOM NEW-ATOM))) 2048) (T 0)) (COND ((FMEMB (CAR D) (QUOTE (SMALLP FIXP))) 8192) (T 0)) (COND ((EQ (CAR D) (QUOTE NEW-ATOM)) (*) 32768) (T 0)) (COND ((FMEMB (CAR D) (QUOTE (LITATOM NEW-ATOM))) (*) (CONSTANT 16384)) (T 0)) (COND ((NOT (CADR D)) (*) 32768) (T 0)))) (*) (COND ((EQ (CAR D) (QUOTE NEW-ATOM)) (*) (I.PUTBASE DTD 17 4))) (COND ((AND (CAR D) (CADR D)) (*) (I.PUTBASE DTD 3 (CADR D))))) (COND ((NEQ 1 0) (SETQ I.LISTPDTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES 5 18))))) (SETQ |I.MaxSysTypeNum| (SETQ |I.MaxTypeNumber| NSYSTYPES)) NIL))
+)
+
+(I.INITDATATYPENAMES
+(LAMBDA NIL (*) (*) (*) (SETQ I.FINALIZATION.FUNCTIONS (I.\\ALLOCBLOCK (ADD1 2047) T)) (|for| D |in| INITIALDTDCONTENTS |as| I.NTYPX |from| 1 |do| (LET ((DTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES I.NTYPX 18))) (FINAL (CADDDR D))) (*) (I.PUTBASEPTR DTD 0 (I.ATOMNUMBER (CAR D))) (*) (I.PUTBASEPTR DTD 10 (I.\\COPY (CADDR D))) (*) (|if| FINAL |then| (*) (NEQ (LOGAND (LRSH (I.PUTBASE DTD 0 (LOGOR (LOGAND (I.GETBASE DTD 0) 61439) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 12))) 12) 1) 0) (I.PUTBASEPTR I.FINALIZATION.FUNCTIONS (LLSH I.NTYPX 1) (I.\\COPY FINAL))))) (PROGN (*) (NEQ (LOGAND (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 61439) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 12)))) (I.ADDBASE (I.VAG2 6 4096) (ITIMES 0 18))) 12) 1) 0) (I.PUTBASEPTR I.FINALIZATION.FUNCTIONS 0 (I.\\COPY (QUOTE \\RECLAIMARRAYBLOCK)))))
+)
+)
+
+(RPAQQ \\BUILT-IN-SYSTEM-TYPES ((SMALLP) (FIXP 2) (FLOATP 2) (LITATOM) (LISTP 4 (0 2)) (ARRAYP 6 (0)) (STRINGP 6 (0)) (STACKP 2 NIL \\RECLAIMSTACKP) (CHARACTER) (VMEMPAGEP 256 NIL RELEASINGVMEMPAGE) (STREAM) (BITMAP) (COMPILED-CLOSURE 4 (0 2)) (ONED-ARRAY 8 (0)) (TWOD-ARRAY 10 (0)) (GENERAL-ARRAY 10 (0 8)) (BIGNUM) (RATIO) (COMPLEX) (PATHNAME) (NEW-ATOM 10 (2 4 6)) (FILLER22) (FILLER23) (FILLER24) (FILLER25) (FILLER26) (FILLER27) (FILLER28) (FILLER29) (FILLER30))
+)
+(DEFINEQ
+
+(I.FSETVAL
+(LAMBDA (ATM VAL) (*) (*) (I.PUTBASEPTR (I.\\ATOMCELL ATM 12) 0 VAL)))
+
+(I.SETPROPLIST
+(LAMBDA (ATM LST) (*) (I.PUTBASEPTR (I.\\ATOMCELL ATM (CONSTANT 2)) 0 LST)))
+
+(I.PUTDEFN
+(LAMBDA (FN CA SIZE) (*) (*) (PROG ((DCELL (I.\\ATOMCELL FN 10)) (BLOCKINFO (PROGN (*) (I.FILECODEBLOCK (LRSH (IPLUS SIZE 3) 2) (IPLUS (LOGOR (LLSH (\\BYTELT CA 12) 8) (\\BYTELT CA (ADD1 12))) (PROGN 8))))) (BASE (I.FILEARRAYBASE))) (I.PUTBASEPTR DCELL 0 BASE) (LOGAND (LRSH (I.PUTBASE DCELL 0 (LOGOR (LOGAND (I.GETBASE DCELL 0) 53247) (LLSH (LOGAND (LOGAND (LRSH (\\BYTELT CA 8) 4) 3) 3) 12))) 12) 3) (NEQ (LOGAND (LRSH (I.PUTBASE DCELL 0 (LOGOR (LOGAND (I.GETBASE DCELL 0) 49151) (LLSH (LOGAND (COND ((EQ (LOGOR (LLSH (\\BYTELT CA 12) 8) (\\BYTELT CA (ADD1 12))) 0) 1) (T 0)) 1) 14))) 14) 1) 0) (NEQ (LRSH (I.PUTBASE DCELL 0 (LOGOR (LOGAND (I.GETBASE DCELL 0) 32767) (LLSH (COND (T 1) (T 0)) 15))) 15) 0) (NEQ (LOGAND (LRSH (I.PUTBASE DCELL 4 (LOGOR (LOGAND (I.GETBASE DCELL 4) 65527) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 3))) 3) 1) 0) (COND ((FMEMB FN LOCKEDFNS) (I.\\LOCKCELL DCELL 1) (I.\\LOCKCELL BASE (LRSH (IPLUS (IPLUS (LOGAND (I.LOLOC BASE) 255) (LRSH (IPLUS SIZE 1) 1)) 255) 8)))) (COND ((EQ FN (FUNCTION \\RESETSTACK)) (*) (SETQ RESETPTR (I.FILEARRAYBASE)) (SETQ RESETPC (LOGOR (LLSH (\\BYTELT CA 6) 8) (\\BYTELT CA (ADD1 6)))))) (AOUT CA 0 SIZE OUTX (QUOTE CODE)) (BOUTZEROS (IDIFFERENCE (SUB1 4) (IMOD (SUB1 SIZE) 4))) (I.FILEBLOCKTRAILER BLOCKINFO)))
+)
+
+(I.\\BLT
+(LAMBDA (DBASE SBASE NWORDS) (*) (*) (PROG ((NN (CONSTANT (EXPT 2 14)))) (RETURN (COND ((GREATERP NWORDS NN) (*) (I.\\BLT (I.ADDBASE DBASE NN) (I.ADDBASE SBASE NN) (DIFFERENCE NWORDS NN)) (I.\\BLT DBASE SBASE NN)) (T (|for| I |from| (SUB1 NWORDS) |by| -1 |to| 0 |do| (I.PUTBASE DBASE I (I.GETBASE SBASE I))) DBASE)))))
+)
+)
+(DEFINEQ
+
+(I.\\MKATOM
+(LAMBDA (BASE OFFST LEN FATP NONNUMERICP) (*) (PROG ((FATCHARSEENP (AND FATP (NOT (NULL (|for| I |from| OFFST |to| (SUB1 (IPLUS OFFST LEN)) |suchthat| (IGREATERP (I.GETBASE BASE I) 255)))))) HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE) (*) (COND ((EQ LEN 0) (*) (SETQ HASH 0) (SETQ FIRSTBYTE 255) (GO LP))) (SETQ FIRSTCHAR (COND (FATP (I.GETBASE BASE OFFST)) (T (I.\\GETBASEBYTE BASE OFFST)))) (*) (COND ((AND (EQ LEN 1) (ILEQ FIRSTCHAR 255) |I.OneCharAtomBase|) (*) (RETURN (COND ((IGREATERP FIRSTCHAR (CHARCODE "9")) (I.ADDBASE |I.OneCharAtomBase| (IDIFFERENCE FIRSTCHAR 10))) ((IGEQ FIRSTCHAR (CHARCODE "0")) (*) (IDIFFERENCE FIRSTCHAR (CHARCODE "0"))) (T (I.ADDBASE |I.OneCharAtomBase| FIRSTCHAR))))) ((AND (NOT NONNUMERICP) (ILEQ FIRSTCHAR (CHARCODE "9")) (SETQ HASHENT (NILL BASE OFFST LEN FATP 10 \\ORIGREADTABLE))) (*) (RETURN HASHENT))) (*) (SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255)) (*) (PROGN (*) (SETQ HASH (LLSH FIRSTBYTE 8)) (|for| CHAR# |from| (ADD1 OFFST) |to| (SUB1 (IPLUS OFFST LEN)) |do| (SETQ HASH (IPLUS16 (IPLUS16 (SETQ HASH (IPLUS16 HASH (LLSH (LOGAND HASH 4095) 2))) (LLSH (LOGAND HASH 255) 8)) (COND (FATP (LOGAND (I.GETBASE BASE CHAR#) 255)) (T (I.\\GETBASEBYTE BASE CHAR#))))))) (*) LP (*) (COND ((NEQ 0 (SETQ HASHENT (I.GETBASE (I.VAG2 7 0) HASH))) (*) (COND ((AND (EQ (LRSH (I.GETBASE (SETQ PNBASE ((LAMBDA ($$1) (I.GETBASEPTR (COND ((AND (FIXP (PROGN $$1)) (ILESSP $$1 65535)) (I.ADDBASE (I.VAG2 8 0) (IPLUS 0 (ITIMES 10 (PROGN $$1))))) (T (I.ADDBASE (PROGN $$1) 0))) 0)) (SETQ ATM# (SUB1 HASHENT)))) 0) 8) LEN) (EQ FATCHARSEENP (AND (PROG1 (EQ 0 (LOGAND (I.GETBASE PNBASE 0) 255)) (*)) (NEQ 0 (LOGAND (LRSH (I.GETBASE (I.\\ATOMCELL (PROGN (I.ADDBASE (I.VAG2 0 0) ATM#)) (CONSTANT 2)) 3) 13) 1)))) (COND (FATCHARSEENP (*) (|for| B1 |from| 1 |to| LEN |as| B2 |from| OFFST |always| (*) (EQ (I.GETBASE PNBASE B1) (I.GETBASE BASE B2)))) (FATP (*) (|for| B1 |from| 1 |to| LEN |as| B2 |from| OFFST |always| (EQ (I.\\GETBASEBYTE PNBASE B1) (I.GETBASE BASE B2)))) (T (*) (|for| B1 |from| 1 |to| LEN |as| B2 |from| OFFST |always| (EQ (I.\\GETBASEBYTE PNBASE B1) (I.\\GETBASEBYTE BASE B2)))))) (RETURN (I.ADDBASE (I.VAG2 0 0) ATM#))) (T (*) (SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (LOGAND 63 (LOGOR 1 (LOGXOR FIRSTBYTE HASH))))))) (GO LP))))) (*) (RETURN (PROGN (LET ((NEWATOM (I.\\CREATE.SYMBOL BASE OFFST LEN FATP FATCHARSEENP))) (I.PUTBASE (I.VAG2 7 0) HASH (ADD1 (I.ATOMNUMBER NEWATOM))) NEWATOM)))))
+)
+
+(I.\\CREATE.SYMBOL
+(LAMBDA (BASE OFFSET LEN FATP FATCHARSEENP) (*) (*) (*) (LET ((PNBASE (I.\\ALLOCBLOCK (COND (FATCHARSEENP (*) (LRSH (IPLUS (ADD1 LEN) 1) 1)) (T (*) (LRSH (IPLUS (ADD1 LEN) 3) 2))))) PB CPP ATM) (COND ((IGEQ (SETQ ATM |I.AtomFrLst|) 12287) (*) (IGEQ (SETQ ATM |I.AtomFrLst|) 65535) (*) (*) (*) (SETQ ATM (I.\\CREATECELL 21)) (I.PUTBASEPTR (COND ((AND (FIXP ATM) (ILESSP ATM 65535)) ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) (I.VAG2 8 0) (IPLUS 2 (ITIMES 10 ATM)))) (T (I.ADDBASE ATM 2))) 0 (QUOTE NOBIND))) ((EVENP ATM 256) (*) (*) (EVENP ATM 512) (*) (*) (LET ((PN (ITIMES 10 (LRSH ATM 8)))) (COND ((NEW-SYMBOL-CODE NIL (IGEQ PN (IDIFFERENCE 255 1))) (*) (NILL))) (I.\\MAKEMDSENTRY (LRSH ATM 8) (LOGOR 32768 16384 2048 4)) (*) (I.\\INITATOMPAGE PN) (*)))) ((LAMBDA (DATUMA0064) (DECLARE (LOCALVARS DATUMA0064)) (PROGN (I.PUTBASE DATUMA0064 0 (LOGOR (LOGAND 61440 (I.GETBASE DATUMA0064 0)) (LOGAND (I.HILOC PNBASE) 4095))) (I.PUTBASE DATUMA0064 (ADD1 0) (I.LOLOC PNBASE)) PNBASE)) (COND ((AND (FIXP ATM) (ILESSP ATM 65535)) (I.ADDBASE (I.VAG2 8 0) (IPLUS 0 (ITIMES 10 ATM)))) (T (I.ADDBASE ATM 0)))) (*) (COND (FATCHARSEENP (I.\\BLT (I.ADDBASE PNBASE 1) (I.ADDBASE BASE OFFSET) LEN)) (FATP (|for| I |from| OFFSET |as| J |from| 1 |to| LEN |do| (I.\\PUTBASEBYTE PNBASE J (I.GETBASE BASE I)))) (T (I.\\MOVEBYTES BASE OFFSET PNBASE 1 LEN))) (LRSH (I.PUTBASE PNBASE 0 (LOGOR (LOGAND (I.GETBASE PNBASE 0) 255) (LLSH LEN 8))) 8) (COND ((NOT T) (*) (PROGN PNBASE))) (SETQ |I.AtomFrLst| (ADD1 |I.AtomFrLst|)) (*) (AND (FIXP ATM) (SETQ ATM (I.ADDBASE (I.VAG2 0 0) ATM))) (COND (FATCHARSEENP (NEQ (LOGAND (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 3 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 3) 57343) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 13)))) (I.\\ATOMCELL ATM (CONSTANT 2))) 13) 1) 0))) ATM))
+)
+
+(I.\\INITATOMPAGE
+(LAMBDA (PN) (*) (COND (NIL (PROG ((OFFSET (LLSH PN 8)) VALBASE) (*) (*) (I.\\NEW4PAGE (I.ADDBASE (I.ADDBASE (I.VAG2 8 0) OFFSET) OFFSET)) (I.\\NEW4PAGE (I.ADDBASE (I.ADDBASE (I.VAG2 10 0) OFFSET) OFFSET)) (I.\\NEW4PAGE (I.ADDBASE (I.ADDBASE (I.VAG2 2 0) OFFSET) OFFSET)) (I.\\NEW4PAGE (SETQ VALBASE (I.ADDBASE (I.ADDBASE (I.VAG2 12 0) OFFSET) OFFSET))) (FRPTQ (ITIMES 128 4) (*) (I.PUTBASEPTR VALBASE 0 (I.\\COPY (QUOTE NOBIND))) (SETQ VALBASE (I.ADDBASE VALBASE 2))))) (T (*) (LET ((OFFSET (LLSH PN 8)) (ATM (LLSH (IQUOTIENT PN 10) 8)) VALBASE) (*) (FOR I FROM 0 TO 9 AS OFF FROM OFFSET BY 256 DO (MKI.NEWPAGE (I.ADDBASE (I.VAG2 8 0) OFF))) (*) (FOR I FROM 0 TO 255 AS OFF FROM OFFSET BY 10 DO (I.PUTBASEPTR (I.VAG2 8 0) (IPLUS OFF 2) (QUOTE NOBIND)))))))
+)
+
+(I.\\MOVEBYTES
+(LAMBDA (SBASE SBYTE DBASE DBYTE NBYTES) (*) (*) (COND ((IGREATERP NBYTES 0) (PROG ((SB (I.ADDBASE SBASE (LRSH SBYTE 1))) (DB (I.ADDBASE DBASE (LRSH DBYTE 1))) SBN DBN NWORDS) (COND ((EQ (SETQ SBN (IMOD SBYTE 2)) (SETQ DBN (IMOD DBYTE 2))) (*) (COND ((EQ SBN 1) (I.\\PUTBASEBYTE DB 1 (I.\\GETBASEBYTE SB 1)) (SETQ DB (I.ADDBASE DB 1)) (SETQ SB (I.ADDBASE SB 1)) (SETQ NBYTES (PLUS NBYTES -1)))) (I.\\BLT DB SB (SETQ NWORDS (LRSH NBYTES 1))) (COND ((EQ (IMOD NBYTES 2) 1) (I.\\PUTBASEBYTE (I.ADDBASE DB NWORDS) 0 (I.\\GETBASEBYTE (I.ADDBASE SB NWORDS) 0))))) (T (FRPTQ NBYTES (I.\\PUTBASEBYTE DB (PROG1 DBN (SETQ DBN (PLUS DBN 1))) (I.\\GETBASEBYTE SB (PROG1 SBN (SETQ SBN (PLUS SBN 1))))))))))))
+)
+
+(I.\\STKMIN
+(LAMBDA (CODE CODEISBLOCK PRINT) (DECLARE (LOCALVARS)) (*) (*) (*) (PROGN (* |;;| "can be run renamed but will work on local space.") (|if| (NOT \\OPSTACKEFFECT) |then| (SETQ \\OPSTACKEFFECT (\\ALLOCBLOCK (FOLDHI 256 BYTESPERCELL))) (SETQ \\OPLENGTH (\\ALLOCBLOCK (FOLDHI 256 BYTESPERCELL))) (|for| I |from| 0 |to| 255 |do| (\\PUTBASEBYTE \\OPSTACKEFFECT I (- 2 (LET ((OP (\\FINDOP I)) LEVADJ) (SELECTQ (|fetch| (OPCODE OPCODENAME) OP) ((FN0 FN1 FN2 FN3 FN4 FNX SWAP NOP APPLYFN RETURN) 2) ((UNBIND DUNBIND UNWIND POP.N) -1) ((BIND SUBRCALL MISCN) 1) (OR (NUMBERP (|if| (LISTP (SETQ LEVADJ (|fetch| (OPCODE LEVADJ) OP))) |then| (SETQ LEVADJ (CAR LEVADJ)) |else| LEVADJ)) (SELECTQ LEVADJ ((CJUMP NCJUMP) (* \; "these only check if they jump") -1) ((JUMP) 2) (PROGN 2)))))))) (|for| I |from| 0 |to| 255 |do| (\\PUTBASEBYTE \\OPLENGTH I (ADD1 (OR (CADDR (\\FINDOP I)) -1))))) (IF (NOT CODEISBLOCK) THEN (SETQ CODE (OR (\\GET-COMPILED-CODE-BASE CODE) (|fetch| (ARRAYP BASE) CODE)))) (LLSH (PROG (MAX OP STKE (PC (|fetch| (FNHEADER STARTPC) CODE)) (DEPTH (IPLUS (IMAX (|fetch| (FNHEADER NA) |of| CODE) 0) 8 (UNFOLD (ADD1 (|fetch| (FNHEADER PV) |of| CODE)) CELLSPERQUAD) 4))) (SETQ MAX (PLUS DEPTH 8)) (* |;;| "this PROG computes the depth in cells. The llsh around converts it to D-machine words.") (* |;;| "the initial maximum is the actual size of the frame, plus 4 extra cells for space to store info in case of an overflow. The default maximum is 8 more than that. By walking the code, it finds if there are any other runs that would increase it beyond that. At jumps or \"Maiko check\" opcodes, the depth is reset to 0.  ") LP (|if| (EQ 0 (SETQ OP (\\GETBASEBYTE CODE PC))) |then| (* |;;| "end of the function") (RETURN MAX)) (* |;;| "the following is for debugging") (AND PRINT (CL:FORMAT T "~%~3o: ~3o d<~3d> mx<~3d>" PC OP DEPTH MAX)) (SELECTQ (SETQ STKE (- 2 (\\GETBASEBYTE \\OPSTACKEFFECT OP))) (2 (* |;;| "special code indicating that this opcode checks the stack level") (AND PRINT (PRIN1 "*")) (SETQ DEPTH 0)) (|add| DEPTH STKE)) (|if| (GREATERP DEPTH MAX) |then| (SETQ MAX DEPTH)) (CL:INCF PC (\\GETBASEBYTE \\OPLENGTH OP)) (GO LP)) 1)))
+)
+)
+(DEFINEQ
+
+(I.COPYATOM
+(LAMBDA (X) (*) (*) (LET ((PKG (CL:SYMBOL-PACKAGE X))) (* \; "SYMBOL-PACKAGE and *INTERLISP-PACKAGE* both NIL in non-package world") (COND ((EQ PKG *INTERLISP-PACKAGE*)) ((NULL PKG) (* \; "This is an uninterned symbol, so add  prefix.") (SETQ X (CONCAT "" X))) ((EQ PKG *KEYWORD-PACKAGE*) (* \; "keywords eval to self, so also set top val") (MKI.DSET X X) (SETQ X (CONCAT ":" X))) (T (* |;;| "Kludge time.  We don't yet have the machinery to create packages in the init.sysout, so anything that isn't an Interlisp symbol has to be turned into a flat-space symbol with appropriate prefix") (CL:MULTIPLE-VALUE-BIND (SYM WHERE) (CL:FIND-SYMBOL (CL:SYMBOL-NAME X) PKG) (SETQ WHERE (SELECTQ WHERE (:INTERNAL "::") (:EXTERNAL ":") (ERROR "Where is this symbol?" X))) (COND ((EQ PKG *LISP-PACKAGE*) (SETQ SYM "LISP")) ((EQ PKG *COMMON-LISP-PACKAGE*) (SETQ SYM "CL")) ((CL:STRING= (CL:PACKAGE-NAME PKG) "SYSTEM") (SETQ SYM "SI")) ((CL:STRING= (CL:PACKAGE-NAME PKG) "CONDITIONS") (SETQ SYM "CONDITIONS")) ((CL:STRING= (CL:PACKAGE-NAME PKG) "XEROX-COMMON-LISP") (SETQ SYM "XCL")) ((CL:STRING= (CL:PACKAGE-NAME PKG) "COMPILER") (SETQ SYM "COMPILER")) ((CL:STRING= (CL:PACKAGE-NAME PKG) "FASL") (SETQ SYM "FASL")) (T (HELP "Can only translate symbols in IL, CL, XCL, CONDITIONS, SI, COMPILER, FASL and keywords" X))) (SETQ X (CONCAT SYM WHERE (CL:SYMBOL-NAME X))))))) (LET ((N (NCHARS X)) (BASE (COND ((NEQ 0 (LOGAND (LRSH (I.GETBASE I.SCRATCHSTRING 2) 14) 1)) (%ARRAY-BASE I.SCRATCHSTRING)) (T (I.GETBASEPTR I.SCRATCHSTRING 0)))) (OFFST (COND ((NEQ 0 (LOGAND (LRSH (I.GETBASE I.SCRATCHSTRING 2) 14) 1)) (%ARRAY-OFFSET I.SCRATCHSTRING)) (T (I.GETBASE I.SCRATCHSTRING 3))))) (*) (|for| I |from| 1 |to| N |do| (I.\\PUTBASEBYTE BASE (IPLUS OFFST I -1) (NTHCHARCODE X I))) (I.ATOMNUMBER (I.\\MKATOM BASE OFFST N))))
+)
+
+(I.INITATOMS
+(LAMBDA NIL (*) (*) (I.CREATEPAGES (I.VAG2 7 0) 256) (SETQ I.SCRATCHSTRING (I.ALLOCSTRING 255)) (*) (*) (I.COPYATOM NIL) (*) (I.COPYATOM (QUOTE NOBIND)) (*) (*) (|for| C |from| 0 |to| 255 |when| (OR (ILESSP C (CHARCODE 0)) (IGREATERP C (CHARCODE 9))) |do| (I.COPYATOM (CHARACTER C))) (SETQ |I.OneCharAtomBase| (I.ADDBASE (I.VAG2 0 0) 2)) (*) (I.COPYATOM (FUNCTION \\EVALFORM)) (*) (I.COPYATOM (FUNCTION \\GC.HANDLEOVERFLOW)) (*) (I.COPYATOM (FUNCTION \\DTEST.UFN)) (*) (I.COPYATOM (FUNCTION \\OVERFLOWMAKENUMBER)) (*) (I.COPYATOM (FUNCTION \\MAKENUMBER)) (*) (I.COPYATOM (FUNCTION \\SETGLOBAL.UFN)) (*) (I.COPYATOM (FUNCTION \\SETFVAR.UFN)) (*) (I.COPYATOM (FUNCTION \\GCMAPTABLE)) (*) (I.COPYATOM (FUNCTION \\INTERPRETER)) (*) (OR (EQ (I.ATOMNUMBER (FUNCTION \\INTERPRETER)) 256) (HELP (FUNCTION \\INTERPRETER) " not atom 400Q")))
+)
+)
+(DEFINEQ
+
+(I.MAKEINITFIRST
+(LAMBDA NIL (*) (I.CREATEMDSTYPETABLE) (I.\\SETUP.HUNK.TYPENUMBERS) (I.INITDATATYPES) (I.PREINITARRAYS) (I.\\TURN.ON.HUNKING) (I.INITATOMS) (I.INITDATATYPENAMES) (I.INITUFNTABLE) (I.INITGC) (MKI.NEWPAGE (I.VAG2 6 0) NIL T))
+)
+
+(I.\\COPY
+(LAMBDA (X) (*) (*) (SELECTQ (TYPENAME X) ((LITATOM NEW-ATOM) (MKI.ATOM X)) (LISTP (PROG ((R (REVERSE X)) (V (I.\\COPY (CDR (LAST X))))) LP (COND ((LISTP R) (SETQ V (I.\\CONS.UFN (I.\\COPY (CAR R)) V)) (SETQ R (CDR R)) (GO LP))) (RETURN V))) ((FIXP SMALLP) (PROG (V) (COND ((IGREATERP 0 X) (*) (COND ((IGREATERP X -65537) (*) (RETURN (I.ADDBASE (I.VAG2 15 0) (LOGAND X 65535)))))) ((ILESSP X 65536) (*) (RETURN (I.ADDBASE (I.VAG2 14 0) X)))) (*) (SETQ V (I.\\CREATECELL 2)) (I.PUTBASE V 0 (LOGOR (COND ((IGREATERP 0 X) 32768) (T 0)) (LOGAND (LRSH X 16) 32767))) (I.PUTBASE V 1 (LOGAND X 65535)) (RETURN V))) (ONED-ARRAY (I.%COPY-ONED-ARRAY X)) (STRINGP (*) (I.%COPY-STRING-TO-ARRAY X)) (FLOATP (PROG ((VAL (I.\\CREATECELL 3))) (SELECTQ (SYSTEMTYPE) ((ALTO D) (I.PUTBASE VAL 0 (\\GETBASE X 0)) (I.PUTBASE VAL 1 (\\GETBASE X 1))) (MKI.IEEE X VAL)) (RETURN VAL))) (CHARACTER (I.VAG2 7 (CL:CHAR-CODE X))) (ERROR X "can't be copied to remote file")))
+)
+
+(I.MAKEINITLAST
+(LAMBDA (VERSIONS) (*) (I.SETUPSTACK T) (I.MAKEINITBFS) (PROGN (*) (SELECTQ (SYSTEMTYPE) ((D ALTO) (MAPHASH MKI.PLHA (FUNCTION (LAMBDA (P A) (I.SETPROPLIST A (I.\\COPY P))))) (MAPHASH MKI.TVHA (FUNCTION (LAMBDA (V A) (I.FSETVAL A (I.\\COPY (CDR V))))))) (PROG (AL GAG) (*) (PROGN (MINFS (IMAX (MINFS) (ITIMES 2 (ARRAYSIZE (CAR MKI.PLHA))) (ARRAYSIZE (CAR MKI.TVHA)))) (RECLAIM) (SETQ GAG (GCGAG "[***** GARBAGE COLLECTION - ERROR ******]")) (MAPHASH MKI.PLHA (FUNCTION (LAMBDA (P A) (|push| AL (CONS A P))))) (SETQ GAG (GCGAG GAG))) (MAPC AL (FUNCTION (LAMBDA (X) (I.SETPROPLIST (CAR X) (I.\\COPY (CDR X)))))) (PROGN (SETQ AL) (RECLAIM) (SETQ GAG (GCGAG GAG)) (MAPHASH MKI.TVHA (FUNCTION (LAMBDA (V A) (|push| AL (RPLACA V A))))) (GCGAG GAG)) (MAPC AL (FUNCTION (LAMBDA (X) (I.FSETVAL (CAR X) (I.\\COPY (CDR X)))))))) (*)) (PROG ((AFL (I.FILEARRAYBASE))) (*) (BOUTZEROS (IDIFFERENCE (TIMES 2 512) (LLSH (IMOD (I.LOLOC AFL) (TIMES 2 256)) 1))) (SETQ MKI.CODELASTPAGE ((LAMBDA (PTR) (DECLARE (LOCALVARS PTR)) (IPLUS (LLSH (I.HILOC PTR) 8) (LRSH (I.LOLOC PTR) 8))) (I.FILEARRAYBASE))) (*) (I.POSTINITARRAYS AFL (IPLUS 5888 MKI.CODESTARTOFFSET) MKI.CODELASTPAGE)) (MAPC (APPEND INITVALUES INITPTRS) (FUNCTION (LAMBDA (X) (*) (I.ATOMNUMBER (CAR X))))) (|for| X |in| INITVALUES |as| A |in| MKI.VALUES |do| (SETQ A (EVALV A)) (I.FSETVAL (CAR X) (COND ((OR (EQ A T) (EQ A NIL) (AND (FIXP A) (IGEQ A -65536) (ILEQ A 65535))) (I.\\COPY A)) (T (SHOULDNT))))) (|for| X |in| INITPTRS |as| A |in| MKI.PTRS |do| (I.FSETVAL (CAR X) (EVALV A))) (|for| X |in| LOCKEDVARS |do| (*) (IF (GETHASH X MKI.ATOMARRAY) THEN (I.\\LOCKVAR X) ELSE (|printout| T "***Note: Locked var " X " does not exist, proceeding anyway." T))) (I.SETUPPAGEMAP) (I.DUMPINITPAGES (IPLUS 5888 MKI.CODESTARTOFFSET) MKI.CODELASTPAGE VERSIONS))
+)
+)
+(DEFINEQ
+
+(I.\\CONS.UFN
+(LAMBDA (X Y) (*) (COND ((ZEROP 1) (HELP) (PROG ((CELL (I.\\CREATECELL 5))) (I.PUTBASEPTR CELL 0 X) (I.PUTBASEPTR CELL 2 Y) (RETURN CELL)))) (PROGN (PROGN X) (PROGN Y) (*) (PROGN 1) (PROG (CNS.PAGE CELL) (SETQ CNS.PAGE (COND ((NOT Y) (COND ((AND (SETQ CNS.PAGE ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 (I.GETBASEFIXP I.LISTPDTD 14)) 8) (LLSH (LOGAND $$1 255) 8))) NIL)) (IGREATERP (LRSH (I.GETBASE CNS.PAGE 0) 8) 0))) (T (SETQ CNS.PAGE (I.\\NEXTCONSPAGE)))) (PROG ((.MK.NEWCELL (I.ADDBASE CNS.PAGE (LOGAND (I.GETBASE CNS.PAGE 0) 255)))) (*) (LOGAND (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 65280) (LOGAND (LRSH (I.GETBASE .MK.NEWCELL 0) 8) 255))) 255) (*) (LRSH (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE CNS.PAGE 0) 8)) -1) 8))) 8) (I.PUTBASEPTR .MK.NEWCELL 0 X) (LRSH (I.PUTBASE .MK.NEWCELL 0 (LOGOR (LOGAND (I.GETBASE .MK.NEWCELL 0) 4095) (LLSH 8 12))) 12) (RETURN .MK.NEWCELL))) ((AND (EQ (I.NTYPX Y) 5) (IGREATERP (LRSH (I.GETBASE (SETQ CNS.PAGE (I.VAG2 (I.HILOC Y) (LOGAND (I.LOLOC Y) 65280))) 0) 8) 0) (SETQ CELL (LET ((CDROFFSET (LOGAND (I.LOLOC Y) 255)) (OFFSET (LOGAND (I.GETBASE CNS.PAGE 0) 255)) CELL PRIOR) (WHILE (NEQ OFFSET 0) DO (COND ((AND (ILEQ OFFSET CDROFFSET) (IGEQ OFFSET (IDIFFERENCE CDROFFSET 14))) (*) (COND (PRIOR (*) (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 255) (LLSH (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE CNS.PAGE OFFSET)) 0) 8) 8)))) (I.ADDBASE CNS.PAGE PRIOR)) 8)) (T (*) (LOGAND (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 65280) (LOGAND (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE CNS.PAGE OFFSET)) 0) 8) 255))) 255))) (LRSH (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE CNS.PAGE 0) 8)) -1) 8))) 8) (I.PUTBASEPTR CELL 0 X) (LRSH (I.PUTBASE CELL 0 (LOGOR (LOGAND (I.GETBASE CELL 0) 4095) (LLSH (LOGOR 8 (LRSH (IDIFFERENCE CDROFFSET OFFSET) 1)) 12))) 12) (RETURN CELL))) (SETQ PRIOR OFFSET) (SETQ OFFSET (LRSH (I.GETBASE (I.ADDBASE CNS.PAGE OFFSET) 0) 8)))))) (*) (*) CELL) (T (LET ((PG (I.GETBASEFIXP I.LISTPDTD 14)) CELL CPG) (WHILE (IGREATERP PG 0) DO (COND ((SETQ CELL ((LAMBDA (PGA0065) (DECLARE (LOCALVARS PGA0065)) (LET ((OFFSET (LOGAND (I.GETBASE PGA0065 0) 255)) CELL PRIOR PRIORPRIOR) (AND (IGEQ (LRSH (I.GETBASE PGA0065 0) 8) 2) (WHILE (NEQ OFFSET 0) DO (COND ((AND PRIOR (ILEQ OFFSET PRIOR) (IGEQ OFFSET (IDIFFERENCE PRIOR 14))) (*) (COND (PRIORPRIOR (*) (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 255) (LLSH (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE PGA0065 OFFSET)) 0) 8) 8)))) (I.ADDBASE PGA0065 PRIORPRIOR)) 8)) (T (*) (LOGAND (I.PUTBASE PGA0065 0 (LOGOR (LOGAND (I.GETBASE PGA0065 0) 65280) (LOGAND (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE PGA0065 OFFSET)) 0) 8) 255))) 255))) (LRSH (I.PUTBASE PGA0065 0 (LOGOR (LOGAND (I.GETBASE PGA0065 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE PGA0065 0) 8)) -2) 8))) 8) (I.PUTBASEPTR (I.ADDBASE PGA0065 PRIOR) 0 Y) (I.PUTBASEPTR CELL 0 X) (LRSH (I.PUTBASE CELL 0 (LOGOR (LOGAND (I.GETBASE CELL 0) 4095) (LLSH (LRSH (IDIFFERENCE PRIOR OFFSET) 1) 12))) 12) (RETURN CELL))) (SETQ PRIORPRIOR PRIOR) (SETQ PRIOR OFFSET) (SETQ OFFSET (LRSH (I.GETBASE (I.ADDBASE PGA0065 OFFSET) 0) 8)))))) (SETQ CPG ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 PG) 8) (LLSH (LOGAND $$1 255) 8))) NIL)))) (RETURN CELL)) (T (SETQ PG (I.GETBASEFIXP CPG 2))))) (OR CELL ((LAMBDA (PGA0066) (DECLARE (LOCALVARS PGA0066)) (LET ((OFFSET (LOGAND (I.GETBASE PGA0066 0) 255)) CELL PRIOR PRIORPRIOR) (AND (IGEQ (LRSH (I.GETBASE PGA0066 0) 8) 2) (WHILE (NEQ OFFSET 0) DO (COND ((AND PRIOR (ILEQ OFFSET PRIOR) (IGEQ OFFSET (IDIFFERENCE PRIOR 14))) (*) (COND (PRIORPRIOR (*) (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 255) (LLSH (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE PGA0066 OFFSET)) 0) 8) 8)))) (I.ADDBASE PGA0066 PRIORPRIOR)) 8)) (T (*) (LOGAND (I.PUTBASE PGA0066 0 (LOGOR (LOGAND (I.GETBASE PGA0066 0) 65280) (LOGAND (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE PGA0066 OFFSET)) 0) 8) 255))) 255))) (LRSH (I.PUTBASE PGA0066 0 (LOGOR (LOGAND (I.GETBASE PGA0066 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE PGA0066 0) 8)) -2) 8))) 8) (I.PUTBASEPTR (I.ADDBASE PGA0066 PRIOR) 0 Y) (I.PUTBASEPTR CELL 0 X) (LRSH (I.PUTBASE CELL 0 (LOGOR (LOGAND (I.GETBASE CELL 0) 4095) (LLSH (LRSH (IDIFFERENCE PRIOR OFFSET) 1) 12))) 12) (RETURN CELL))) (SETQ PRIORPRIOR PRIOR) (SETQ PRIOR OFFSET) (SETQ OFFSET (LRSH (I.GETBASE (I.ADDBASE PGA0066 OFFSET) 0) 8)))))) (I.\\NEXTCONSPAGE))))))) (PROGN CNS.PAGE) (RETURN CNS.PAGE))))
+)
+
+(I.\\MAIKO.CONS.UFN
+(LAMBDA (X Y) (*) (*) (COND ((ZEROP 1) (HELP) (PROG ((CELL (I.\\CREATECELL 5))) (I.PUTBASEPTR CELL 0 X) (I.PUTBASEPTR CELL 2 Y) (RETURN CELL)))) (PROGN (PROGN X) (PROGN Y) (*) (PROGN 1) (PROG (CNS.PAGE) (SETQ CNS.PAGE (COND ((AND (EQ (I.NTYPX Y) 5) (IGREATERP (LRSH (I.GETBASE (SETQ CNS.PAGE (I.VAG2 (I.HILOC Y) (LOGAND (I.LOLOC Y) 65280))) 0) 8) 0)) (*) ((LAMBDA (PAGE A D) (DECLARE (LOCALVARS PAGE A D)) (PROG ((.MK.NEWCELL (I.ADDBASE PAGE (LOGAND (I.GETBASE PAGE 0) 255)))) (*) (LOGAND (I.PUTBASE PAGE 0 (LOGOR (LOGAND (I.GETBASE PAGE 0) 65280) (LOGAND (LRSH (I.GETBASE .MK.NEWCELL 0) 8) 255))) 255) (*) (LRSH (I.PUTBASE PAGE 0 (LOGOR (LOGAND (I.GETBASE PAGE 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE PAGE 0) 8)) -1) 8))) 8) (I.PUTBASEPTR .MK.NEWCELL 0 A) (LRSH (I.PUTBASE .MK.NEWCELL 0 (LOGOR (LOGAND (I.GETBASE .MK.NEWCELL 0) 4095) (LLSH D 12))) 12) (RETURN .MK.NEWCELL))) CNS.PAGE X (IPLUS 8 (LRSH (LOGAND (I.LOLOC Y) 255) 1)))) (T ((LAMBDA (PAGE A D) (DECLARE (LOCALVARS PAGE A D)) (PROG ((.MK.NEWCELL (I.ADDBASE PAGE (LOGAND (I.GETBASE PAGE 0) 255)))) (*) (LOGAND (I.PUTBASE PAGE 0 (LOGOR (LOGAND (I.GETBASE PAGE 0) 65280) (LOGAND (LRSH (I.GETBASE .MK.NEWCELL 0) 8) 255))) 255) (*) (LRSH (I.PUTBASE PAGE 0 (LOGOR (LOGAND (I.GETBASE PAGE 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE PAGE 0) 8)) -1) 8))) 8) (I.PUTBASEPTR .MK.NEWCELL 0 A) (LRSH (I.PUTBASE .MK.NEWCELL 0 (LOGOR (LOGAND (I.GETBASE .MK.NEWCELL 0) 4095) (LLSH D 12))) 12) (RETURN .MK.NEWCELL))) (SETQ CNS.PAGE (I.\\NEXTCONSPAGE)) X (COND ((NULL Y) 8) (T (IPLUS 0 (LRSH (LOGAND (I.LOLOC (PROGN (PROGN (PROGN (PROG ((.MK.NEWCELL (I.ADDBASE CNS.PAGE (LOGAND (I.GETBASE CNS.PAGE 0) 255)))) (*) (LOGAND (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 65280) (LOGAND (LRSH (I.GETBASE .MK.NEWCELL 0) 8) 255))) 255) (*) (LRSH (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE CNS.PAGE 0) 8)) -1) 8))) 8) (I.PUTBASEPTR .MK.NEWCELL 0 Y) (LRSH (I.PUTBASE .MK.NEWCELL 0 (LOGOR (LOGAND (I.GETBASE .MK.NEWCELL 0) 4095) (LLSH 0 12))) 12) (RETURN .MK.NEWCELL)))))) 255) 1)))))))) (PROGN CNS.PAGE) (RETURN CNS.PAGE))))
+)
+
+(I.\\INITCONSPAGE
+(LAMBDA (BASE LINK) (*) (COND ((ZEROP 1) (HELP)) (T (PROG ((J (LOGAND (I.PUTBASE BASE 0 (LOGOR (LOGAND (I.GETBASE BASE 0) 65280) (LOGAND 254 255))) 255)) CELL) LP (COND ((IGREATERP J 4) (SETQ CELL (I.ADDBASE BASE J)) (I.PUTBASEPTR CELL 0 NIL) (LRSH (I.PUTBASE CELL 0 (LOGOR (LOGAND (I.GETBASE CELL 0) 255) (LLSH (SETQ J (IDIFFERENCE J 2)) 8))) 8) (GO LP))) (LRSH (I.PUTBASE BASE 0 (LOGOR (LOGAND (I.GETBASE BASE 0) 255) (LLSH 126 8))) 8) (*) (I.PUTBASEFIXP BASE 2 (IPLUS (LLSH (I.HILOC LINK) 8) (LRSH (I.LOLOC LINK) 8))) (RETURN BASE)))))
+)
+
+(I.\\NEXTCONSPAGE
+(LAMBDA NIL (*) (*) (PROG ((N (I.GETBASEFIXP I.LISTPDTD 14)) PG) (SETQ PG (I.\\ALLOCMDSPAGE (I.GETBASE I.LISTPDTD 16))) (I.\\INITCONSPAGE PG (I.\\INITCONSPAGE (I.ADDBASE PG 256) ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 N) 8) (LLSH (LOGAND $$1 255) 8))) NIL))) (I.PUTBASEFIXP I.LISTPDTD 14 (IPLUS (LLSH (I.HILOC PG) 8) (LRSH (I.LOLOC PG) 8))) (RETURN PG)))
+)
+)
+(DEFINEQ
+
+(I.\\GETBASEBYTE
+(LAMBDA (PTR N) (*) (*) (COND ((EVENP N) (LRSH (PROGN (I.GETBASE PTR (LRSH N 1))) 8)) (T (LOGAND (PROGN (I.GETBASE PTR (LRSH N 1))) 255))))
+)
+
+(I.\\PUTBASEBYTE
+(LAMBDA (PTR DISP BYTE) (*) (*) (SETQ BYTE (PROG1 BYTE)) (I.PUTBASE PTR (LRSH (SETQ DISP (\\DTEST DISP (QUOTE SMALLP))) 1) (COND ((EVENP DISP 2) ((LAMBDA ($$1) (IPLUS (LLSH BYTE 8) (LOGAND $$1 255))) (I.GETBASE PTR (LRSH DISP 1)))) (T ((LAMBDA ($$1) (IPLUS (LLSH (LRSH $$1 8) 8) BYTE)) (I.GETBASE PTR (LRSH DISP 1)))))) BYTE)
+)
+
+(I.CREATEPAGES
+(LAMBDA (VA N BLANKFLG LOCKFLG) (*) (*) (|for| I |from| 0 |to| (SUB1 N) |do| (MKI.NEWPAGE (I.ADDBASE VA (LLSH I 8)) NIL LOCKFLG BLANKFLG)) VA)
+)
+
+(I.\\NEW4PAGE
+(LAMBDA (PTR) (*) (*) (MKI.NEWPAGE (I.ADDBASE (MKI.NEWPAGE (I.ADDBASE (MKI.NEWPAGE (I.ADDBASE (MKI.NEWPAGE PTR) 256)) 256)) 256)))
+)
+)
+
+(FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES) CMLARRAY-SUPPORT)
+(DEFINEQ
+
+(I.ALLOCSTRING
+(LAMBDA (N INITCHAR OLD FATFLG) (*) (SETQ N (FIX N)) (*) (COND ((OR (ILESSP N 0) (IGREATERP N 65535)) (LISPERROR "ILLEGAL ARG" N))) (COND ((NULL INITCHAR) (SETQ INITCHAR 0)) ((PROGN (*) (AND (SMALLP INITCHAR) (IGEQ INITCHAR 0)))) (T (SETQ INITCHAR (CHCON1 INITCHAR)))) (LET ((FATP (OR FATFLG (IGREATERP INITCHAR 255))) STRINGBASE) (*) (SETQ STRINGBASE (I.\\ALLOCBLOCK (COND (FATP (LRSH (IPLUS N 1) 1)) (T (LRSH (IPLUS N 3) 2))))) (COND ((STRINGP OLD) (PROGN ((LAMBDA ($$1) (PROG1 (SETQ $$1 (PROGN (NEQ (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 32767) (LLSH (COND (NIL 1) (T 0)) 15))) 15) 0) (PROGN (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 49151) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 14))) 14) 1) 0) (I.PUTBASEPTR OLD 0 NIL) NIL) ((LAMBDA (STRING NV) (DECLARE (LOCALVARS STRING NV)) (LET ((%NEW-TYPE-NUMBER (SELECTC NV (0 %THIN-CHAR-TYPENUMBER) (1 %FAT-CHAR-TYPENUMBER) (SHOULDNT "Unknown typ value")))) (COND ((NEQ 0 (LOGAND (LRSH (I.GETBASE STRING 2) 14) 1)) (%SET-ARRAY-TYPE-NUMBER STRING %NEW-TYPE-NUMBER)) (T (LOGAND (I.PUTBASE STRING 2 (LOGOR (LOGAND (I.GETBASE STRING 2) 65280) (LOGAND %NEW-TYPE-NUMBER 255))) 255))))) OLD (PROGN (COND (FATP 1) (T 0)))) ((LAMBDA (STRING NV) (DECLARE (LOCALVARS STRING NV)) (I.PUTBASEFIXP STRING 4 NV) (I.PUTBASEFIXP STRING 6 NV) (COND ((%GENERAL-ARRAY-P STRING) (I.PUTBASEPTR STRING 8 (LIST NV)))) NV) OLD (PROGN N)) (PROGN (COND ((NOT (EQ 0 0)) (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 64511) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 10))) 10) 1) 0))) (COND ((NEQ 0 (LOGAND (LRSH (I.GETBASE OLD 2) 14) 1)) (%SET-ARRAY-OFFSET OLD 0)) (T (I.PUTBASE OLD 3 0)))) (PROGN (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 63487) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 11))) 11) 1) 0) (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 64511) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 10))) 10) 1) 0) (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 65023) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 9))) 9) 1) 0) (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 65279) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 8))) 8) 1) 0)) OLD)) (PROGN (NEQ (LOGAND (LRSH (I.PUTBASE $$1 2 (LOGOR (LOGAND (I.GETBASE $$1 2) 49151) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 14))) 14) 1) 0) (I.PUTBASEPTR $$1 0 STRINGBASE) STRINGBASE))) NIL))) (T (SETQ OLD ((LAMBDA ($$1 $$2) (PROG1 (SETQ $$2 ((LAMBDA (DATUMA0077) (DECLARE (LOCALVARS DATUMA0077)) (PROG1 DATUMA0077 (I.PUTBASEFIXP DATUMA0077 6 $$1))) ((LAMBDA (DATUMA0076 NEWVALUEA0075) (DECLARE (LOCALVARS DATUMA0076 NEWVALUEA0075)) (PROG1 DATUMA0076 (I.PUTBASEFIXP DATUMA0076 4 NEWVALUEA0075))) ((LAMBDA (DATUMA0074) (DECLARE (LOCALVARS DATUMA0074)) (PROG1 DATUMA0074 (I.PUTBASE DATUMA0074 3 0))) ((LAMBDA (DATUMA0073 NEWVALUEA0072) (DECLARE (LOCALVARS DATUMA0073 NEWVALUEA0072)) (PROG1 DATUMA0073 (LOGAND (I.PUTBASE DATUMA0073 2 (LOGOR (LOGAND (I.GETBASE DATUMA0073 2) 65280) (LOGAND NEWVALUEA0072 255))) 255))) ((LAMBDA (DATUMA0071 NEWVALUEA0070) (DECLARE (LOCALVARS DATUMA0071 NEWVALUEA0070)) (PROG1 DATUMA0071 (NEQ (LOGAND (LRSH (I.PUTBASE DATUMA0071 2 (LOGOR (LOGAND (I.GETBASE DATUMA0071 2) 64511) (LLSH (LOGAND (COND (NEWVALUEA0070 1) (T 0)) 1) 10))) 10) 1) 0))) ((LAMBDA (DATUMA0069) (DECLARE (LOCALVARS DATUMA0069)) (PROG1 DATUMA0069 (NEQ (LOGAND (LRSH (I.PUTBASE DATUMA0069 2 (LOGOR (LOGAND (I.GETBASE DATUMA0069 2) 61439) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 12))) 12) 1) 0))) ((LAMBDA (DATUMA0068) (DECLARE (LOCALVARS DATUMA0068)) (PROG1 DATUMA0068 (NEQ (LRSH (I.PUTBASE DATUMA0068 2 (LOGOR (LOGAND (I.GETBASE DATUMA0068 2) 32767) (LLSH (COND (NIL 1) (T 0)) 15))) 15) 0))) ((LAMBDA (DATUMA0067) (DECLARE (LOCALVARS DATUMA0067)) (PROG1 DATUMA0067 (I.PUTBASEPTR DATUMA0067 0 NIL))) (I.\\CREATECELL 14)))) (NOT (EQ 0 0))) (COND ((EQ (COND (FATP 1) (T 0)) 1) %FAT-CHAR-TYPENUMBER) (T %THIN-CHAR-TYPENUMBER)))) (SETQ $$1 N)))) (PROGN (NEQ (LOGAND (LRSH (I.PUTBASE $$2 2 (LOGOR (LOGAND (I.GETBASE $$2 2) 49151) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 14))) 14) 1) 0) (I.PUTBASEPTR $$2 0 STRINGBASE) STRINGBASE))) NIL NIL)))) (COND ((NEQ 0 INITCHAR) (*) (COND (FATP (|for| I |from| 0 |to| (SUB1 N) |do| (I.PUTBASE STRINGBASE I INITCHAR))) (T (|for| I |from| 0 |to| (SUB1 N) |do| (I.\\PUTBASEBYTE STRINGBASE I INITCHAR))))))) OLD)
+)
+
+(I.%COPY-ONED-ARRAY
+(LAMBDA (LOCAL-ARRAY) (*) (PROG ((SIZE (|ffetch| (ONED-ARRAY TOTAL-SIZE) |of| LOCAL-ARRAY)) (BASE (|ffetch| (ONED-ARRAY BASE) |of| LOCAL-ARRAY)) (OFFSET (|ffetch| (ONED-ARRAY OFFSET) |of| LOCAL-ARRAY)) (TYPENUMBER (|ffetch| (ONED-ARRAY TYPE-NUMBER) |of| LOCAL-ARRAY)) NCELLS REMOTE-ARRAY REMOTE-BASE) (|if| (NEQ OFFSET 0) |then| (ERROR "Can't copy an array with non-zero offset")) (|if| (EQ (%TYPENUMBER-TO-GC-TYPE TYPENUMBER) 1) |then| (ERROR "Can't copy pointer arrays")) (SETQ NCELLS (LRSH (IPLUS (ITIMES (IPLUS SIZE OFFSET) (%TYPENUMBER-TO-BITS-PER-ELEMENT TYPENUMBER)) 31) 5)) (SETQ REMOTE-ARRAY ((LAMBDA (DATUMA0087) (DECLARE (LOCALVARS DATUMA0087)) (PROG1 DATUMA0087 (I.PUTBASEFIXP DATUMA0087 6 SIZE))) ((LAMBDA (DATUMA0086 NEWVALUEA0085) (DECLARE (LOCALVARS DATUMA0086 NEWVALUEA0085)) (PROG1 DATUMA0086 (I.PUTBASEFIXP DATUMA0086 4 NEWVALUEA0085))) ((LAMBDA (DATUMA0084) (DECLARE (LOCALVARS DATUMA0084)) (PROG1 DATUMA0084 (LOGAND (I.PUTBASE DATUMA0084 2 (LOGOR (LOGAND (I.GETBASE DATUMA0084 2) 65280) (LOGAND TYPENUMBER 255))) 255))) ((LAMBDA (DATUMA0083 NEWVALUEA0082) (DECLARE (LOCALVARS DATUMA0083 NEWVALUEA0082)) (PROG1 DATUMA0083 (NEQ (LOGAND (LRSH (I.PUTBASE DATUMA0083 2 (LOGOR (LOGAND (I.GETBASE DATUMA0083 2) 65023) (LLSH (LOGAND (COND (NEWVALUEA0082 1) (T 0)) 1) 9))) 9) 1) 0))) ((LAMBDA (DATUMA0081 NEWVALUEA0080) (DECLARE (LOCALVARS DATUMA0081 NEWVALUEA0080)) (PROG1 DATUMA0081 (NEQ (LOGAND (LRSH (I.PUTBASE DATUMA0081 2 (LOGOR (LOGAND (I.GETBASE DATUMA0081 2) 61439) (LLSH (LOGAND (COND (NEWVALUEA0080 1) (T 0)) 1) 12))) 12) 1) 0))) ((LAMBDA (DATUMA0079 NEWVALUEA0078) (DECLARE (LOCALVARS DATUMA0079 NEWVALUEA0078)) (PROG1 DATUMA0079 (I.PUTBASEPTR DATUMA0079 0 NEWVALUEA0078))) (I.\\CREATECELL 14) (I.\\ALLOCBLOCK NCELLS)) (%CHAR-TYPE-P TYPENUMBER)) (NEQ 0 (LOGAND (LRSH (I.GETBASE LOCAL-ARRAY 2) 9) 1)))) (I.GETBASEFIXP LOCAL-ARRAY 4)))) (SETQ REMOTE-BASE (I.GETBASEPTR REMOTE-ARRAY 0)) (|for| I |from| 0 |to| (SUB1 (LLSH NCELLS 1)) |do| (I.PUTBASE REMOTE-BASE I (\\GETBASE BASE I))) (RETURN REMOTE-ARRAY)))
+)
+
+(I.%COPY-STRING-TO-ARRAY
+(LAMBDA (LOCAL-STRING) (*) (*) (PROG ((SIZE (NCHARS LOCAL-STRING)) REMOTE-BASE REMOTE-ARRAY) (SETQ REMOTE-BASE (I.\\ALLOCBLOCK (LRSH (IPLUS (ITIMES SIZE 8) 31) 5))) (SETQ REMOTE-ARRAY ((LAMBDA (DATUMA0092) (DECLARE (LOCALVARS DATUMA0092)) (PROG1 DATUMA0092 (I.PUTBASEFIXP DATUMA0092 6 SIZE))) ((LAMBDA (DATUMA0091) (DECLARE (LOCALVARS DATUMA0091)) (PROG1 DATUMA0091 (I.PUTBASEFIXP DATUMA0091 4 SIZE))) ((LAMBDA (DATUMA0090) (DECLARE (LOCALVARS DATUMA0090)) (PROG1 DATUMA0090 (LOGAND (I.PUTBASE DATUMA0090 2 (LOGOR (LOGAND (I.GETBASE DATUMA0090 2) 65280) (LOGAND 67 255))) 255))) ((LAMBDA (DATUMA0089) (DECLARE (LOCALVARS DATUMA0089)) (PROG1 DATUMA0089 (NEQ (LOGAND (LRSH (I.PUTBASE DATUMA0089 2 (LOGOR (LOGAND (I.GETBASE DATUMA0089 2) 61439) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 12))) 12) 1) 0))) ((LAMBDA (DATUMA0088) (DECLARE (LOCALVARS DATUMA0088)) (PROG1 DATUMA0088 (I.PUTBASEPTR DATUMA0088 0 REMOTE-BASE))) (I.\\CREATECELL 14))))))) (|for| I |from| 0 |to| (SUB1 SIZE) |do| (I.\\PUTBASEBYTE REMOTE-BASE I (NTHCHARCODE LOCAL-STRING (ADD1 I)))) (RETURN REMOTE-ARRAY)))
+)
+)
+(DEFINEQ
+
+(I.\\#BLOCKDATACELLS
+(LAMBDA (DATAWORD) (*) (*) (PROG ((TYPENO (I.NTYPX DATAWORD))) (RETURN (COND ((EQ 0 TYPENO) (COND ((AND (EQ 0 (I.NTYPX DATAWORD)) (IGEQ (I.HILOC DATAWORD) 23)) (IDIFFERENCE (I.GETBASE (I.ADDBASE DATAWORD (IMINUS 2)) 1) 2)) (T (\\ILLEGAL.ARG DATAWORD)))) (T (OR (AND (OR I.HUNKING? (NEQ 0 (LOGAND (LRSH (I.GETBASE (I.ADDBASE (I.VAG2 6 4096) (ITIMES TYPENO 18)) 6) 14) 1))) (LRSH (I.GETBASE (I.ADDBASE (I.VAG2 6 4096) (ITIMES TYPENO 18)) 3) 1)) (\\ILLEGAL.ARG DATAWORD)))))))
+)
+
+(I.\\PREFIXALIGNMENT?
+(LAMBDA (ARLEN INITONPAGE ALIGN GCTYPE BASE) (*) (*) (PROG ((DAT (LRSH (I.LOLOC (PROGN (PROGN (I.ADDBASE BASE 2)))) 1)) (ADJUSTMENT 0) FUDGE) (*) LP (COND ((AND ALIGN (NEQ (SETQ FUDGE (IREMAINDER DAT ALIGN)) 0)) (*) (SETQ ADJUSTMENT (PLUS ADJUSTMENT (SETQ FUDGE (IDIFFERENCE ALIGN FUDGE)))) (SETQ DAT (PLUS DAT FUDGE)))) (COND ((AND INITONPAGE (NEQ (LOGAND DAT (CONSTANT (LOGXOR (SUB1 128) -1))) (LOGAND (IPLUS DAT INITONPAGE -1) (CONSTANT (LOGXOR (SUB1 128) -1))))) (*) (SETQ ADJUSTMENT (PLUS ADJUSTMENT (SETQ FUDGE (IDIFFERENCE 128 (IMOD DAT 128))))) (SETQ DAT (PLUS DAT FUDGE)) (*))) (COND ((AND (EQ GCTYPE 2) (IGREATERP (IDIFFERENCE ARLEN 2) (SETQ FUDGE (IDIFFERENCE 32768 (SETQ DAT (IMOD DAT 32768)))))) (*) (SETQ ADJUSTMENT (PLUS ADJUSTMENT FUDGE)) (SETQ DAT (PLUS DAT FUDGE)) (*))) (*) (RETURN ADJUSTMENT)))
+)
+
+(I.\\ALLOCBLOCK
+(LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN) (*) (*) (DECLARE (GLOBALVARS |I.ArrayFrLst|)) (COND ((ILESSP NCELLS 2) (COND ((ILESSP NCELLS 0) (\\ILLEGAL.ARG NCELLS))) (SETQ NCELLS 2)) ((IGREATERP NCELLS 65533) (\\LISPERROR NCELLS "ARRAY STORAGE BLOCK TOO LARGE"))) (*) (SELECTQ GCTYPE (NIL (SETQ GCTYPE 0)) (T (SETQ GCTYPE 1)) NIL) (*) (COND ((AND INITONPAGE (OR (ILESSP INITONPAGE 0) (IGREATERP INITONPAGE 128))) (\\ILLEGAL.ARG INITONPAGE))) (COND ((NULL ALIGN)) ((OR (ILESSP ALIGN 0) (IGREATERP ALIGN 128)) (\\ILLEGAL.ARG ALIGN)) ((ILEQ ALIGN 1) (SETQ ALIGN)) ((AND INITONPAGE (PROGN (*) NIL)) (ERROR "INITONPAGE and ALIGN too high"))) (OR (AND I.HUNKING? (ILEQ NCELLS 64) (I.\\ALLOCHUNK NCELLS GCTYPE INITONPAGE ALIGN)) (PROG ((ARLEN (IPLUS NCELLS 2)) ABLOCK) RETRY (PROGN (*) (SETQ ABLOCK (OR (NILL ARLEN GCTYPE INITONPAGE ALIGN) (I.\\ALLOCBLOCK.NEW ARLEN GCTYPE INITONPAGE ALIGN) (PROGN (FRPTQ 10 (RECLAIM)) (*) (NILL ARLEN GCTYPE INITONPAGE ALIGN)) (GO FULL))) (*) (NEQ (LOGAND (I.PUTBASE ABLOCK 0 (LOGOR (LOGAND (I.GETBASE ABLOCK 0) 65534) (LOGAND (COND (T 1) (T 0)) 1))) 1) 0) (NEQ (LOGAND ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 65534) (LOGAND (COND (T 1) (T 0)) 1)))) ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) ABLOCK (IDIFFERENCE (I.GETBASE ABLOCK 1) 1))) 1) 0) (LOGAND (LRSH (I.PUTBASE ABLOCK 0 (LOGOR (LOGAND (I.GETBASE ABLOCK 0) 65529) (LLSH (LOGAND GCTYPE 3) 1))) 1) 3) (NILL ABLOCK NIL) (PROGN NCELLS) (*) (SETQ ABLOCK (I.ADDBASE ABLOCK 2)) (PROGN ABLOCK) (RETURN ABLOCK)) FULL (LISPERROR "ARRAYS FULL" NIL T) (*) (GO RETRY))))
+)
+
+(I.\\MAIKO.ALLOCBLOCK
+(LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN) (*) (*) (*) (DECLARE (GLOBALVARS |I.ArrayFrLst|)) (COND ((ILESSP NCELLS 2) (COND ((ILESSP NCELLS 0) (\\ILLEGAL.ARG NCELLS))) (SETQ NCELLS 2)) ((IGREATERP NCELLS 65533) (\\LISPERROR NCELLS "ARRAY STORAGE BLOCK TOO LARGE"))) (*) (SELECTQ GCTYPE (NIL (SETQ GCTYPE 0)) (T (SETQ GCTYPE 1)) NIL) (*) (*) (*) (COND ((NULL ALIGN)) ((OR (ILESSP ALIGN 0) (IGREATERP ALIGN 128)) (\\ILLEGAL.ARG ALIGN)) ((ILEQ ALIGN 1) (SETQ ALIGN)) ((AND INITONPAGE (PROGN (*) NIL)) (ERROR "INITONPAGE and ALIGN too high"))) (OR (AND I.HUNKING? (ILEQ NCELLS 64) (*) (I.\\ALLOCHUNK NCELLS GCTYPE NIL ALIGN)) (PROG ((ARLEN (IPLUS NCELLS 2)) ABLOCK) RETRY (PROGN (*) (SETQ ABLOCK (OR (NILL ARLEN GCTYPE NIL ALIGN) (I.\\ALLOCBLOCK.NEW ARLEN GCTYPE NIL ALIGN) (PROGN (FRPTQ 10 (RECLAIM)) (*) (NILL ARLEN GCTYPE INITONPAGE ALIGN)) (GO FULL))) (*) (NEQ (LOGAND (I.PUTBASE ABLOCK 0 (LOGOR (LOGAND (I.GETBASE ABLOCK 0) 65534) (LOGAND (COND (T 1) (T 0)) 1))) 1) 0) (NEQ (LOGAND ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 65534) (LOGAND (COND (T 1) (T 0)) 1)))) ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) ABLOCK (IDIFFERENCE (I.GETBASE ABLOCK 1) 1))) 1) 0) (LOGAND (LRSH (I.PUTBASE ABLOCK 0 (LOGOR (LOGAND (I.GETBASE ABLOCK 0) 65529) (LLSH (LOGAND GCTYPE 3) 1))) 1) 3) (NILL ABLOCK NIL) (PROGN NCELLS) (SETQ ABLOCK (I.ADDBASE ABLOCK 2)) (PROG1 (PROGN ABLOCK) (PROGN 1)) (RETURN ABLOCK)) FULL (LISPERROR "ARRAYS FULL" NIL T) (*) (GO RETRY))))
+)
+
+(I.\\ALLOCBLOCK.NEW
+(LAMBDA (ARLEN GCTYPE INITONPAGE ALIGN) (*) (DECLARE (GLOBALVARS |I.ArrayFrLst| |I.NxtArrayPage|)) (*) (PROG (FINALWORD FINALPAGE NEXTFREEBLOCK PREFIXLEN) RETRY (COND ((AND (OR INITONPAGE ALIGN) (NEQ 0 (SETQ PREFIXLEN (I.\\PREFIXALIGNMENT? ARLEN INITONPAGE ALIGN GCTYPE |I.ArrayFrLst|)))) (*) (COND ((SETQ PREFIXLEN (I.\\ALLOCBLOCK.NEW PREFIXLEN)) (I.\\MERGEBACKWARD PREFIXLEN) (*)) (T (RETURN))))) (SETQ FINALWORD (I.ADDBASE (I.ADDBASE |I.ArrayFrLst| ARLEN) (SUB1 ARLEN))) (*) (SETQ NEXTFREEBLOCK (I.ADDBASE FINALWORD 1)) (COND ((IGREATERP (SETQ FINALPAGE (IPLUS (LLSH (I.HILOC FINALWORD) 8) (LRSH (I.LOLOC FINALWORD) 8))) (IDIFFERENCE |I.NxtMDSPage| 128)) (*) (SELECTQ (NILL (ADD1 (IDIFFERENCE FINALPAGE |I.NxtArrayPage|))) (T (*)) (0 (*) (GO RETRY)) (RETURN NIL)))) (*) (|until| (IGREATERP |I.NxtArrayPage| FINALPAGE) |do| (I.\\MAKEMDSENTRY |I.NxtArrayPage| 0) (I.\\NEW2PAGE ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 |I.NxtArrayPage|) 8) (LLSH (LOGAND $$1 255) 8))) NIL)) (I.PUTBASEFIXP |I.NxtArrayPage| 0 (IPLUS |I.NxtArrayPage| 2))) (RETURN (PROG1 (I.\\MAKEFREEARRAYBLOCK |I.ArrayFrLst| ARLEN) (SETQ |I.ArrayFrLst| NEXTFREEBLOCK)))))
+)
+
+(I.\\MAKEFREEARRAYBLOCK
+(LAMBDA (BLOCK LENGTH) (*) (I.PUTBASE BLOCK 0 43688) (I.PUTBASE BLOCK 1 LENGTH) (I.PUTBASE ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) BLOCK (IDIFFERENCE (I.GETBASE BLOCK 1) 1)) 0 43688) (I.PUTBASE ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) BLOCK (IDIFFERENCE (I.GETBASE BLOCK 1) 1)) 1 LENGTH) BLOCK)
+)
+
+(I.\\MERGEBACKWARD
+(LAMBDA (BASE) (*) (*) (PROG (ARLEN PARLEN PBASE PTRAILER SPLIT) (COND ((NULL BASE) (RETURN NIL)) ((OR (NOT (PROGN NIL)) (EQ BASE (I.VAG2 23 0)) (EQ BASE (I.VAG2 64 0)) (NEQ 0 (LOGAND (I.GETBASE (SETQ PTRAILER (I.ADDBASE BASE (IMINUS 2))) 0) 1))) (*) (RETURN (I.\\LINKBLOCK BASE)))) (SETQ PBASE ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) BASE (IMINUS (I.GETBASE PTRAILER 1)))) (NILL PBASE T) (\\DELETEBLOCK? PBASE) (RETURN (\\ARRAYBLOCKMERGER PBASE BASE))))
+)
+
+(I.\\LINKBLOCK
+(LAMBDA (BASE) (*) (*) (COND (I.FREEBLOCKBUCKETS (COND ((ILESSP (I.GETBASE BASE 1) 4) (NILL BASE T)) (T (PROG ((FBL ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) I.FREEBLOCKBUCKETS (IMIN (INTEGERLENGTH (I.GETBASE BASE 1)) 30))) FREEBLOCK) (SETQ FREEBLOCK (I.GETBASEPTR FBL 0)) (COND ((NULL FREEBLOCK) (I.PUTBASEPTR BASE 2 BASE) (I.PUTBASEPTR BASE 4 BASE)) (T (I.PUTBASEPTR BASE 2 FREEBLOCK) (I.PUTBASEPTR BASE 4 (I.GETBASEPTR FREEBLOCK 4)) (I.PUTBASEPTR (I.GETBASEPTR FREEBLOCK 4) 2 BASE) (I.PUTBASEPTR FREEBLOCK 4 BASE))) (I.PUTBASEPTR FBL 0 BASE) (NILL BASE T T)))))) BASE)
+)
+
+(I.\\ALLOCHUNK
+(LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN) (*) (COND ((AND ALIGN (OR (IGREATERP ALIGN 64) (NOT (FMEMB ALIGN (SELECTC GCTYPE (0 (CONSTANT (|for| X |in| (QUOTE (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64)) |when| (AND (IGREATERP X 1) (ILEQ X 64) (POWEROFTWOP X)) |collect| X))) (1 (CONSTANT (|for| X |in| (QUOTE (2 4 5 6 7 8 10 12 16 24 32 42 64)) |when| (AND (IGREATERP X 1) (ILEQ X 64) (POWEROFTWOP X)) |collect| X))) (2 (CONSTANT (LIST 2))) NIL))))) (*) (ERROR "Oddball alignment request" ALIGN))) (PROG ((TYPENUM.TABLE (SELECTC GCTYPE (0 I.UNBOXEDHUNK.TYPENUM.TABLE) (2 I.CODEHUNK.TYPENUM.TABLE) (1 I.PTRHUNK.TYPENUM.TABLE) (SHOULDNT))) (FAILCNT 0) DTNUMBER HUNK HUNKSIZE ONPAGE STRADDLERS) BEG (|do| (SETQ DTNUMBER (I.\\GETBASEBYTE TYPENUM.TABLE NCELLS)) (SETQ HUNKSIZE (LRSH (I.GETBASE (I.ADDBASE (I.VAG2 6 4096) (ITIMES DTNUMBER 18)) 3) 1)) |repeatuntil| (OR (NOT ALIGN) (EQ 0 (IREMAINDER (LRSH (I.GETBASE (I.ADDBASE (I.VAG2 6 4096) (ITIMES DTNUMBER 18)) 3) 1) ALIGN)) (COND ((IGREATERP (SETQ NCELLS (ADD1 HUNKSIZE)) 64) (GO LOSE)) (T (*) NIL)))) LP (SETQ HUNK (I.\\CREATECELL DTNUMBER)) (COND ((OR (NULL INITONPAGE) (ILESSP INITONPAGE (SETQ ONPAGE (IDIFFERENCE 128 (LRSH (LOGAND (I.LOLOC HUNK) 255) 1))))) (*) (RETURN HUNK))) (*) (COND (T (*) (HELP "Call to \\ALLOCBLOCK with non-NIL INITONPAGE demand" INITONPAGE)) (T (COND ((AND (EQ GCTYPE 2) (ILEQ (IQUOTIENT (ITIMES 10 ONPAGE) HUNKSIZE) (COND ((ILEQ HUNKSIZE 24) 60) ((ILEQ HUNKSIZE 50) 50) (T 30)))) (*) (PROGN HUNK)) (T (*) (SETQ STRADDLERS (I.\\CONS.UFN HUNK STRADDLERS)))) (COND ((IGREATERP (SETQ FAILCNT (PLUS FAILCNT 1)) 16) (*) (GO LOSE)) ((EQ FAILCNT 8) (*) (SETQ NCELLS (ADD1 HUNKSIZE)) (AND STRADDLERS (SETQ \\HUNKREJECTS (NCONC STRADDLERS \\HUNKREJECTS))) (GO BEG))) (GO LP))) LOSE (AND STRADDLERS (SETQ \\HUNKREJECTS (NCONC STRADDLERS \\HUNKREJECTS))) (RETURN)))
+)
+)
+(DEFINEQ
+
+(I.PREINITARRAYS
+(LAMBDA NIL (*) (*) (DECLARE (GLOBALVARS |I.ArrayFrLst| |I.ArrayFrLst2| |I.NxtArrayPage|)) (SETQ |I.ArrayFrLst| (I.VAG2 23 0)) (SETQ |I.ArrayFrLst2| (I.VAG2 64 0)) (SETQ |I.NxtArrayPage| (IPLUS (LLSH (I.HILOC |I.ArrayFrLst|) 8) (LRSH (I.LOLOC |I.ArrayFrLst|) 8))))
+)
+
+(I.POSTINITARRAYS
+(LAMBDA (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (*) (*) (SETQ I.FREEBLOCKBUCKETS (I.\\ALLOCBLOCK (ADD1 30))) (PROG ((EXTRACELLS (IDIFFERENCE (LLSH CODESTARTPAGE 7) (IPLUS (LLSH (I.HILOC |I.ArrayFrLst|) 15) (LRSH (I.LOLOC |I.ArrayFrLst|) 1))))) (*) (COND ((IGREATERP EXTRACELLS 65535) (|printout| T T T "POSTINITARRAYS:  You pre-allocated too much string space." T 19 "MKI.CODESTARTOFFSET on MAKEINIT should be reduced by about " (IDIFFERENCE (LRSH EXTRACELLS 7) 10) "." T) (HELP)) ((IGEQ EXTRACELLS 4) (*) (|printout| T T T "POSTINITARRAYS:  There were " (LRSH EXTRACELLS 7) " allocated but unused array pages." T T)) (T (|printout| T T "POSTINITARRAYS:  String space overflowed into code-arrays" T 19 "You should add at least " (ADD1 (LRSH (IMINUS EXTRACELLS) 7)) " to MKI.CODESTARTOFFSET on MAKEINIT." T) (HELP))) (*) (I.\\LINKBLOCK (I.\\ALLOCBLOCK.NEW EXTRACELLS)) (SETQ |I.ArrayFrLst| AFTERCODEPTR) (*) (SETQ |I.NxtArrayPage| CODENEXTPAGE) (|for| VP |from| (IPLUS (LLSH (I.HILOC (I.VAG2 23 0)) 8) (LRSH (I.LOLOC (I.VAG2 23 0)) 8)) |to| (IPLUS (LLSH (I.HILOC |I.NxtArrayPage|) 8) (LRSH (I.LOLOC |I.NxtArrayPage|) 8)) |by| (LRSH 512 8) |do| (I.\\MAKEMDSENTRY VP 0))))
+)
+
+(I.FILEARRAYBASE
+(LAMBDA NIL (*) (I.ADDBASE (I.VAG2 23 0) (IPLUS (LLSH MKI.CODESTARTOFFSET 8) (LRSH (IDIFFERENCE (GETFILEPTR (OUTPUT)) |MKI.FirstDataByte|) 1))))
+)
+
+(I.FILEBLOCKTRAILER
+(LAMBDA (BLOCKINFO) (*) (*) (BOUT16 OUTX 43689) (BOUT16 OUTX BLOCKINFO)))
+
+(I.FILECODEBLOCK
+(LAMBDA (NCELLS INITONPAGE) (*) (*) (PROG (PREFIXLEN (ARLEN (IPLUS NCELLS 2))) (*) (COND ((NEQ 0 (SETQ PREFIXLEN (I.\\PREFIXALIGNMENT? ARLEN INITONPAGE 2 2 (I.FILEARRAYBASE)))) (*) (I.FILEPATCHBLOCK PREFIXLEN))) (BOUT16 OUTX 43693) (BOUT16 OUTX ARLEN) (RETURN ARLEN)))
+)
+
+(I.FILEPATCHBLOCK
+(LAMBDA (ARLEN) (*) (*) (BOUT16 OUTX 43688) (*) (BOUT16 OUTX ARLEN) (*) (COND ((IGREATERP ARLEN 1) (*) (BOUTZEROS (LLSH (IDIFFERENCE ARLEN 2) 2)) (*) (BOUT16 OUTX 43688) (*) (BOUT16 OUTX ARLEN))) NIL)
+)
+)
+(DEFINEQ
+
+(I.\\SETUP.HUNK.TYPENUMBERS
+(LAMBDA NIL (*) (*) (*) (SETQ INITIALDTDCONTENTS (APPEND \\BUILT-IN-SYSTEM-TYPES (I.\\COMPUTE.HUNK.TYPEDECLS (QUOTE (2 4 5 6 7 8 10 12 16 24 32 42 64)) 1 (QUOTE \\PTRHUNK)) (I.\\COMPUTE.HUNK.TYPEDECLS (QUOTE (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64)) 0 (QUOTE \\UNBOXEDHUNK)) (I.\\COMPUTE.HUNK.TYPEDECLS (QUOTE (12 16 20 24 28 32 36 42 50 64)) 2 (QUOTE \\CODEHUNK)))))
+)
+
+(I.\\COMPUTE.HUNK.TYPEDECLS
+(LAMBDA (SIZELST GCTYPE PREFIX) (*) (*) (|for| HUNKSIZE |in| SIZELST BIND (FINAL _ (AND (EQ GCTYPE CODEBLOCK.GCT) (QUOTE \\RECLAIMCODEBLOCK))) |until| (> HUNKSIZE \\MAX.CELLSPERHUNK) |collect| (LIST (PACK* PREFIX HUNKSIZE) (UNFOLD HUNKSIZE WORDSPERCELL) (COND ((EQ GCTYPE PTRBLOCK.GCT) (* \; "Compute DTDPTRS list, i.e., which fields are pointers (all of them)") (|for| I |from| 0 |by| 2 |to| (SUB1 (UNFOLD HUNKSIZE WORDSPERCELL)) |collect| I))) FINAL)))
+)
+
+(I.\\TURN.ON.HUNKING
+(LAMBDA NIL (*) (*) (SETQ I.UNBOXEDHUNK.TYPENUM.TABLE (I.\\SETUP.TYPENUM.TABLE (QUOTE (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64)) 0 (QUOTE \\UNBOXEDHUNK))) (SETQ I.CODEHUNK.TYPENUM.TABLE (I.\\SETUP.TYPENUM.TABLE (QUOTE (12 16 20 24 28 32 36 42 50 64)) 2 (QUOTE \\CODEHUNK))) (SETQ I.PTRHUNK.TYPENUM.TABLE (I.\\SETUP.TYPENUM.TABLE (QUOTE (2 4 5 6 7 8 10 12 16 24 32 42 64)) 1 (QUOTE \\PTRHUNK))) (SETQ I.HUNKING? T))
+)
+
+(I.\\SETUP.TYPENUM.TABLE
+(LAMBDA (SIZELST GCTYPE PREFIX) (*) (*) (|for| I |from| 0 |to| 64 |bind| (HUNKSIZE _ -1) (SIZEL _ SIZELST) (TABLE _ (I.\\ALLOCBLOCK (LRSH (IPLUS (IPLUS 4 64) 3) 2) 0)) TNAME DTD DTNUMBER |do| (COND ((IGREATERP I HUNKSIZE) (*) (SETQ HUNKSIZE (OR (FIXP (PROG1 (CAR SIZEL) (SETQ SIZEL (CDR SIZEL)))) 64)) (SETQ TNAME (PACK* PREFIX HUNKSIZE)) (COND ((|for| |old| DTNUMBER |from| 1 |as| TYPE |in| INITIALDTDCONTENTS |when| (EQ (CAR TYPE) TNAME) |do| (*) (RETURN DTNUMBER)) (SETQ DTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES DTNUMBER 18))) (LOGAND (LRSH (I.PUTBASE DTD 6 (LOGOR (LOGAND (I.GETBASE DTD 6) 53247) (LLSH (LOGAND GCTYPE 3) 12))) 12) 3) (NEQ (LOGAND (LRSH (I.PUTBASE DTD 6 (LOGOR (LOGAND (I.GETBASE DTD 6) 49151) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 14))) 14) 1) 0)) (T (HELP "No type declaration for" TNAME))))) (I.\\PUTBASEBYTE TABLE I DTNUMBER) |finally| (RETURN TABLE)))
+)
+)
+(DEFINEQ
+
+(I.DCODERD
+(LAMBDA (FN) (*) (*) (*) (READC) (LET ((INSTREAM (GETSTREAM NIL (QUOTE INPUT))) (*READTABLE* (|if| (EQ *READTABLE* FILERDTBL) |then| (*) I.CODERDTBL |else| (*) *READTABLE*))) (PROG ((NAMETABLE (PROG1 (READ) (READC))) (CODELEN (IPLUS (LLSH (\\BIN INSTREAM) 8) (\\BIN INSTREAM))) (NLOCALS (\\BIN INSTREAM)) (NFREEVARS (\\BIN INSTREAM)) (ARGTYPE (\\BIN INSTREAM)) (NARGS (\\BIN INSTREAM)) (NTSIZE 0) (FRAMENAME FN) REALSIZE STARTPC NTWORDS CA FVAROFFSET LOCALARGS STARTLOCALS LOCALSIZE) (COND ((EQ (CAR NAMETABLE) (QUOTE NAME)) (SETQ FRAMENAME (CADR NAMETABLE)) (SETQ NAMETABLE (CDDR NAMETABLE)))) (COND ((EQ (CAR NAMETABLE) (QUOTE L)) (SETQ LOCALARGS (CADR NAMETABLE)) (SETQ NAMETABLE (CDDR NAMETABLE)))) (COND (NAMETABLE (*) (|on| NAMETABLE |by| CDDDR |do| (SETQ NTSIZE (PLUS NTSIZE 1))) (SETQ NTSIZE (LOGAND (IPLUS (ADD1 (LLSH NTSIZE 1)) (CONSTANT (SUB1 4))) (CONSTANT (LOGXOR (SUB1 4) -1)))))) (SETQ NTWORDS (COND (NAMETABLE (IPLUS NTSIZE NTSIZE)) (T (CONSTANT 4)))) (*) (SETQ STARTPC (LLSH (IPLUS (PROGN 8) NTWORDS) 1)) (*) (COND (LOCALARGS (SETQ STARTLOCALS STARTPC) (*) (SETQ LOCALSIZE (LOGAND (IPLUS (ADD1 (LLSH (LRSH (FLENGTH LOCALARGS) 1) 1)) (CONSTANT (SUB1 (IQUOTIENT 4 2)))) (CONSTANT (LOGXOR (SUB1 (IQUOTIENT 4 2)) -1)))) (*) (SETQ LOCALSIZE (LLSH LOCALSIZE 1)) (*) (SETQ STARTPC (PLUS STARTPC (LLSH LOCALSIZE 1))))) (SETQ REALSIZE (LOGAND (IPLUS (IPLUS STARTPC CODELEN) (CONSTANT (SUB1 8))) (CONSTANT (LOGXOR (SUB1 8) -1)))) (SETQ CA (SCRATCHARRAY REALSIZE (LOGAND (IPLUS (ADD1 (LRSH (IPLUS STARTPC 3) 2)) (CONSTANT (SUB1 2))) (CONSTANT (LOGXOR (SUB1 2) -1))))) (AIN CA STARTPC CODELEN INSTREAM) (*) (|for| X |on| NAMETABLE |by| (CDDDR X) |as| NT1 |from| (IPLUS (SUB1 (LLSH (CONSTANT (I.WORDSPERNAMEENTRY)) 1)) (LLSH (PROGN 8) 1)) |by| (LLSH (CONSTANT (I.WORDSPERNAMEENTRY)) 1) |bind| (NTBYTESIZE _ (LLSH NTSIZE 1)) |do| (I.FIXUPSYM CA NT1 (CADDR X) -1) (*) (I.SETSTKNTOFFSET CA (IPLUS NT1 NTBYTESIZE) (SELECTQ (CAR X) (P (CONSTANT (LLSH 2 14))) (F (OR FVAROFFSET (SETQ FVAROFFSET (LLSH (LRSH NT1 2) 1))) (*) (CONSTANT (LLSH 3 14))) (I (CONSTANT (LLSH 0 14))) (SHOULDNT)) (CADR X)) (*)) (COND (LOCALARGS (*) (|for| X |on| LOCALARGS |by| (CDDR X) |as| NT |from| (IPLUS (SUB1 (LLSH (CONSTANT (I.WORDSPERNAMEENTRY)) 1)) STARTLOCALS) |by| (CONSTANT (LLSH (CONSTANT (I.WORDSPERNAMEENTRY)) 1)) |do| (I.FIXUPSYM CA NT (CADR X) -1) (*) (I.SETSTKNTOFFSET CA (IPLUS NT LOCALSIZE) (CONSTANT (LLSH 0 14)) (CAR X)) (*)))) (PROGN (*) ((LAMBDA (DEFA0094 VALUEA0093) (DECLARE (LOCALVARS DEFA0094 VALUEA0093)) (\\BYTESETA DEFA0094 2 (LRSH VALUEA0093 8)) (\\BYTESETA DEFA0094 (ADD1 2) (IMOD VALUEA0093 (CONSTANT (LLSH 1 8))))) CA (UNSIGNED (PROGN (COND ((EQ ARGTYPE 2) -1) (T NARGS))) 16)) ((LAMBDA (DEFA0096 VALUEA0095) (DECLARE (LOCALVARS DEFA0096 VALUEA0095)) (\\BYTESETA DEFA0096 4 (LRSH VALUEA0095 8)) (\\BYTESETA DEFA0096 (ADD1 4) (IMOD VALUEA0095 (CONSTANT (LLSH 1 8))))) CA (UNSIGNED (PROGN (SUB1 (LRSH (IPLUS (IPLUS NLOCALS NFREEVARS) 1) 1))) 16)) (PROGN (\\BYTESETA CA 6 (LRSH STARTPC 8)) (\\BYTESETA CA (ADD1 6) (IMOD STARTPC (CONSTANT (LLSH 1 8))))) (\\BYTESETA CA 8 (LOGOR (LOGAND (\\BYTELT CA 8) 207) (LLSH (LOGAND ARGTYPE 3) 4))) (I.FIXUPPTR CA 11 (I.\\COPY FRAMENAME)) (PROGN (\\BYTESETA CA 12 (LRSH NTSIZE 8)) (\\BYTESETA CA (ADD1 12) (IMOD NTSIZE (CONSTANT (LLSH 1 8))))) (\\BYTESETA CA 14 NLOCALS) (\\BYTESETA CA 15 (PROGN (OR FVAROFFSET 0))) ((LAMBDA (DEFA0098 VALUEA0097) (DECLARE (LOCALVARS DEFA0098 VALUEA0097)) (\\BYTESETA DEFA0098 0 (LRSH VALUEA0097 8)) (\\BYTESETA DEFA0098 (ADD1 0) (IMOD VALUEA0097 (CONSTANT (LLSH 1 8))))) CA (PROGN (I.\\STKMIN CA)))) (*) (|for| X |on| (READ) |by| (CDDR X) |do| (I.FIXUPSYM CA (IPLUS (CAR X) STARTPC) (CADR X) -1)) (|for| X |on| (READ) |by| (CDDR X) |do| (I.FIXUPSYM CA (IPLUS (CAR X) STARTPC) (CADR X) -1)) (|for| X |on| (READ) |by| (CDDR X) |do| (I.FIXUPPTR CA (IPLUS (CAR X) STARTPC) (I.\\COPY (CADR X)))) (I.PUTDEFN FN CA (IPLUS STARTPC CODELEN)))))
+)
+)
+
+(RPAQQ \\OPCODES ((0 -X- 0) (1 CAR 0 T 0 \\CAR.UFN) (2 CDR 0 T 0 \\CDR.UFN) (3 LISTP 0 T 0 LISTP) (4 NTYPX 0 T 0 NTYPX) (5 TYPEP 1 TYPEP 0 \\TYPEP.UFN) (6 DTEST 4 ATOM 0 \\DTEST.UFN) (7 UNWIND 2 T (UNWIND 1) \\UNWIND.UFN) (8 FN0 4 FN 1) (9 FN1 4 FN 0) (10 FN2 4 FN -1) (11 FN3 4 FN -2) (12 FN4 4 FN -3) (13 FNX 5 FNX FNX) (14 APPLYFN 0 T -1) (15 CHECKAPPLY* 0 T 0 \\CHECKAPPLY* (4K 12K)) (16 RETURN 0 T (JUMP 1) \\HARDRETURN) (17 BIND 2) (18 UNBIND 0) (19 DUNBIND 0) (20 RPLPTR.N 1 T -1 \\RPLPTR.UFN (4K)) (21 GCREF 1 T 0 \\HTFIND) (22 ASSOC 0 T -1 ASSOC (4K DORADO)) (23 GVAR_ 4 ATOM 0 \\SETGLOBALVAL.UFN) (24 RPLACA 0 T -1 \\RPLACA.UFN 4K) (25 RPLACD 0 T -1 \\RPLACD.UFN 4K) (26 CONS 0 T -1 \\CONS.UFN) (27 CMLASSOC 0 T -1 CL::%SIMPLE-ASSOC (4K DORADO)) (28 FMEMB 0 T -1 FMEMB (4K DORADO)) (29 CMLMEMBER 0 T -1 CL::%SIMPLE-MEMBER (4K DORADO)) (30 FINDKEY 1 T 0 \\FINDKEY.UFN) (31 CREATECELL 0 T 0 \\CREATECELL 4K) (32 BIN 0 T 0 \\BIN 4K) (33 BOUT 0 T -1 \\BOUT (4K DORADO)) (34 POPDISP 0 T 0 \\POPDISP.UFN (4K DORADO)) (35 RESTLIST 1 T -1 \\RESTLIST.UFN) (36 MISCN 2 T 1 \\MISCN.UFN (DORADO DLION DBREAK)) (37 |unused|) (38 RPLCONS 0 T -1 \\RPLCONS (4K DORADO)) (39 LISTGET 0 T -1 LISTGET (4K DORADO)) (40 |unused|) (41 |unused|) (42 |unused|) (43 |unused|) (44 EVAL 0 T 0 \\EVAL) (45 ENVCALL 0 T (JUMP 0) \\ENVCALL.UFN) (46 TYPECHECK 0 T 0 \\TYPECHECK.UFN) (47 STKSCAN 0 T 0 \\STKSCAN) (48 BUSBLT 1 (WORDSOUT BYTESOUT BYTESOUTSWAPPED NYBBLESOUT WORDSIN BYTESIN BYTESINSWAPPED NYBBLESINSWAPPED) -3 \\BUSBLT.UFN (4K DORADO)) (49 MISC8 1 (IBLT1 IBLT2) -7 \\MISC8.UFN (4K DORADO)) (50 UBFLOAT3 1 (POLY MATRIX.3X3 MATRIX.4X4 MATRIX.133 MATRIX.331 MATRIX.144 MATRIX.441 UBASET1) (-2 1) \\UNBOXFLOAT3 (4K DORADO)) (51 TYPEMASK.N 1 T 0 \\TYPEMASK.UFN) (52 RDPROLOGPTR 0 T 0 RAID (4K DORADO)) (53 RDPROLOGTAG 0 T 0 RAID (4K DORADO)) (54 WRTPTR&TAG 0 T -2 RAID (4K DORADO)) (55 WRTPTR&0TAG 0 T -1 RAID (4K DORADO)) (56 MISC7 1 (PSEUDOCOLOR \\FASTBITMAPBIT) -6 \\MISC7.UFN (4K DORADO)) (57 DOVEMISC 1 (READIW WRITEIO WRITEMP RDTIMER BYTESWAP LOCKMEM NOTIFYIOP SETWP) (0 -1 0 0 0 -3 0 0)) (58 EQL 0 T -1 EQL) (59 DRAWLINE 0 T -8 \\DRAWLINE.UFN (4K DORADO)) (60 STORE.N 1 T 0 \\STORE.N.UFN) (61 COPY.N 1 T 1 \\COPY.N.UFN) (62 RAID 0 T 0 RAID T) (63 \\RETURN 0 T 0 \\RETURN) ((64 70) IVAR 0 IVAR 1) (71 IVARX 1 IVAR 1) ((72 78) PVAR 0 PVAR 1) (79 PVARX 1 PVAR 1) ((80 86) FVAR 0 FVAR 1) (87 FVARX 1 FVAR 1) ((88 94) PVAR_ 0 PVAR 0) (95 PVARX_ 1 PVAR 0) (96 GVAR 4 ATOM 1) (97 ARG0 0 T 0 \\ARG0 T) (98 IVARX_ 1 IVAR 0) (99 FVARX_ 1 FVAR 0) (100 COPY 0 T 1) (101 MYARGCOUNT 0 T 1 \\MYARGCOUNT T) (102 MYALINK 0 T 1) (103 ACONST 4 ATOM 1) (104 \'NIL 0 T 1) (105 \'T 0 T 1) (106 \'0 0 T 1) (107 \'1 0 T 1) (108 SIC 1 SIC 1) (109 SNIC 1 SNIC 1) (110 SICX 2 SICX 1) (111 GCONST 4 GCONST 1) (112 |unused|) (113 READFLAGS 0 T 0 \\READFLAGS) (114 READRP 0 T 0 \\READRP) (115 WRITEMAP 0 T -2 \\WRITEMAP DORADO) (116 READPRINTERPORT 0 T 1 \\READPRINTERPORT.UFN 4K) (117 WRITEPRINTERPORT 0 T 0 \\WRITEPRINTERPORT.UFN 4K) (118 PILOTBITBLT 0 T -1 \\PILOTBITBLT) (119 RCLK 0 T 0 \\RCLKSUBR) (120 MISC1 1 (|error| INPUT OUTPUT |error| |error| |error| |error| |error| |error| RWMUFMAN) 0 \\MISC1.UFN) (121 MISC2 1 (?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?10) -1 \\MISC2.UFN) (122 RECLAIMCELL 0 T 0 \\GCRECLAIMCELL DORADO) (123 GCSCAN1 0 T 0 \\GCSCAN1) (124 GCSCAN2 0 T 0 \\GCSCAN2) (125 SUBRCALL 2 SUBRCALL) (126 CONTEXTSWITCH 0 T 0 \\CONTEXTSWITCH) (127 RETCALL 4 FNX (JUMP 1) \\RETCALL) ((128 143) JUMP 0 JUMP JUMP NIL) ((144 159) FJUMP 0 JUMP CJUMP NIL) ((160 175) TJUMP 0 JUMP CJUMP NIL) (176 JUMPX 1 JUMPX JUMP) (177 JUMPXX 2 JUMPXX JUMP) (178 FJUMPX 1 JUMPX CJUMP) (179 TJUMPX 1 JUMPX CJUMP) (180 NFJUMPX 1 JUMPX NCJUMP) (181 NTJUMPX 1 JUMPX NCJUMP) (182 AREF1 0 T -1 %AREF1 (4K DORADO)) (183 ASET1 0 T -2 %ASET1 (4K DORADO)) ((184 190) PVAR_^ 0 PVAR -1 NIL) (191 POP 0 T -1) (192 POP.N 1 T (POP.N 1) \\POP.N.UFN) (193 ATOMCELL.N 1 T 0 \\ATOMCELL) (194 GETBASEBYTE 0 T -1 \\GETBASEBYTE) (195 INSTANCEP 4 ATOM 0 \\INSTANCEP.UFN NIL) (196 BLT 0 T -2 \\BLT) (197 MISC10 1 T -9 \\MISC10.UFN (4K DORADO)) (198 P-MISC2 1 (GET-NEXT-RUN) -1 \\P-MISC2.UFN) (199 PUTBASEBYTE 0 T -2 \\PUTBASEBYTE) (200 GETBASE.N 1 T 0) (201 GETBASEPTR.N 1 T 0) (202 GETBITS.N.FD 2 T 0) (203 |unused|) (204 CMLEQUAL 0 T -1 CL:EQUAL (4K 12K DORADO)) (205 PUTBASE.N 1 T -1 \\PUTBASE.UFN) (206 PUTBASEPTR.N 1 T -1 \\PUTBASEPTR.UFN) (207 PUTBITS.N.FD 2 T -1 \\PUTBITS.UFN) (208 ADDBASE 0 T -1 \\ADDBASE) (209 VAG2 0 T -1 \\VAG2) (210 HILOC 0 T 0) (211 LOLOC 0 T 0) (212 PLUS2 0 T -1 \\SLOWPLUS2 *) (213 DIFFERENCE 0 T -1 \\SLOWDIFFERENCE *) (214 TIMES2 0 T -1 \\SLOWTIMES2 *) (215 QUOTIENT 0 T -1 \\SLOWQUOTIENT *) (216 IPLUS2 0 T -1 \\SLOWIPLUS2) (217 IDIFFERENCE 0 T -1 \\SLOWIDIFFERENCE) (218 ITIMES2 0 T -1 \\SLOWITIMES2) (219 IQUOTIENT 0 T -1 \\SLOWIQUOTIENT) (220 IREMAINDER 0 T -1 IREMAINDER) (221 IPLUS.N 1 T 0 \\SLOWIPLUS2 (4K 12K)) (222 IDIFFERENCE.N 1 T 0 \\SLOWIDIFFERENCE (4K 12K)) (223 BASE-< 0 T -1 \\BASE-<.UFN (4K 12K DORADO)) (224 LLSH1 0 T 0 \\SLOWLLSH1) (225 LLSH8 0 T 0 \\SLOWLLSH8) (226 LRSH1 0 T 0 \\SLOWLRSH1) (227 LRSH8 0 T 0 \\SLOWLRSH8) (228 LOGOR2 0 T -1 \\SLOWLOGOR2) (229 LOGAND2 0 T -1 \\SLOWLOGAND2) (230 LOGXOR2 0 T -1 \\SLOWLOGXOR2) (231 LSH 0 T -1 LSH T) (232 FPLUS2 0 T -1 \\SLOWFPLUS2 4K) (233 FDIFFERENCE 0 T -1 \\SLOWFDIFFERENCE 4K) (234 FTIMES2 0 T -1 \\SLOWFTIMES2 4K) (235 FQUOTIENT 0 T -1 \\SLOWFQUOTIENT 4K) (236 UBFLOAT2 1 (UFADD UFSUB UFISUB UFMULT UFDIV UFGREAT UFMAX UFMIN UFREM UBAREF1) (-1 1) \\UNBOXFLOAT2 (4K DORADO)) (237 UBFLOAT1 1 (BOX UNBOX UFABS UFNEGATE UFIX) (0 1) \\UNBOXFLOAT1 (4K DORADO)) (238 AREF2 0 T -2 %AREF2 (4K DORADO)) (239 ASET2 0 T -3 %ASET2 (4K DORADO)) (240 EQ 0 T -1) (241 IGREATERP 0 T -1 \\SLOWIGREATERP) (242 FGREATERP 0 T -1 \\SLOWFGREATERP) (243 GREATERP 0 T -1 GREATERP) (244 EQUAL 0 T -1 EQUAL) (245 MAKENUMBER 0 T -1 \\MAKENUMBER 4K) (246 BOXIPLUS 0 T -1 \\BOXIPLUS 4K) (247 BOXIDIFFERENCE 0 T -1 \\BOXIDIFFERENCE 4K) (248 FLOATBLT 1 (FLOATWRAP FLOATUNWRAP FLOAT FIX FPLUS FDIFFERENCE FDIFFERENCE FPLUSABS ABSDIFFERENCE ABSFPLUS FTIMES) -3 \\FLOATBLT (4K DORADO)) (249 FFTSTEP 0 T -1 \\FFTSTEP (4K DORADO)) (250 MISC3 1 (EXPONENT MAGNITUDE FLOAT COMP BLKFMAX BLKFMIN BLKFABSMAX BLKFABSMIN FLOATTOBYTE ARRAYREAD LINES-EQUAL-P) -2 \\MISC3.UFN (4K DORADO)) (251 MISC4 1 (ARRAY.TIMES ARRAY.PERM ARRAY.PLUS ARRAY.DIFFERENCE ARRAY.MAGIC 3MATCH BMBIT ARRAYWRITE) -3 \\MISC4.UFN) (252 UPCTRACE 0 T 0 NILL (4K 12K)) (253 SWAP 0 T 0) (254 NOP 0 T 0) (255 = 0 T -1 CL::%= (4K DORADO)))
+)
+
+(RPAQ I.CODERDTBL (COPYREADTABLE (QUOTE ORIG)))
+
+(SETSYNTAX (CHARCODE ^Y) (QUOTE (MACRO (LAMBDA (FILE RDTBL) (EVALFORMAKEINIT (READ FILE RDTBL))))) I.CODERDTBL)
+
+(SETSYNTAX (CHARCODE \|) (QUOTE (MACRO ALWAYS READVBAR)) I.CODERDTBL)
+
+(READTABLEPROP I.CODERDTBL (QUOTE USESILPACKAGE) NIL)
+(DEFINEQ
+
+(I.INITUFNTABLE
+(LAMBDA NIL (*) (I.CREATEPAGES (I.VAG2 6 3072) 2 NIL T) (|for| I |from| 0 |to| 255 |do| (I.\\SETUFNENTRY I (QUOTE \\UNKNOWN.UFN) 0 0)) (|for| X |in| \\OPCODES |when| (CADDDR (CDDR X)) |do| (I.\\SETUFNENTRY (PROG ((OP (CAR X))) (RETURN (|if| (LISTP OP) |then| (CAR OP) |else| OP))) (CADDDR (CDDR X)) (COND ((LISTP (CADDDR (CDR X))) (CADR (CADDDR (CDR X)))) (T (IDIFFERENCE (IPLUS 1 (COND ((EQ (CADDR X) 0) 0) (T 1))) (CADDDR (CDR X))))) (SELECTQ (CADDR X) (0 0) (1 1) (2 2) (3 (*) 3) (4 4) (5 5) (SHOULDNT)))))
+)
+
+(I.\\SETUFNENTRY
+(LAMBDA (INDEX FN NARGS NEXTRA) (*) (SETQ INDEX (I.ADDBASE (I.ADDBASE (I.VAG2 6 3072) INDEX) INDEX)) (I.PUTBASE INDEX 0 (I.ATOMNUMBER FN)) (LRSH (I.PUTBASE INDEX 1 (LOGOR (LOGAND (I.GETBASE INDEX 1) 255) (LLSH NEXTRA 8))) 8) (LOGAND (I.PUTBASE INDEX 1 (LOGOR (LOGAND (I.GETBASE INDEX 1) 65280) (LOGAND NARGS 255))) 255))
+)
+)
+
+(RPAQQ INITPTRS ((\\MAINDISK) (\\SWAPDSK1) (\\SWAPDSK2) (\\SWAPREQUESTBLOCK) (\\DISKREQUESTBLOCK) (\\FREEPAGEFID) (\\FINALIZATION.FUNCTIONS) (|\\OneCharAtomBase| NIL) (\\SCRATCHSTRING) (\\LISTPDTD) (\\FREEBLOCKBUCKETS) (|\\ArrayFrLst|) (|\\ArrayFrLst2|) (\\UNBOXEDHUNK.TYPENUM.TABLE) (\\CODEHUNK.TYPENUM.TABLE) (\\PTRHUNK.TYPENUM.TABLE))
+)
+
+(RPAQQ INITVALUES ((|\\NxtMDSPage| |\\FirstMDSPage|) (|\\LeastMDSPage| |\\FirstMDSPage|) (|\\SecondMDSPage| |\\DefaultSecondMDSPage|) (|\\SecondArrayPage| |\\DefaultSecondArrayPage|) (\\MDSFREELISTPAGE) (|\\MaxSysTypeNum| 0) (|\\MaxTypeNumber|) (|\\AtomFrLst| 0) (|\\NxtArrayPage|) (\\HUNKING?))
+)
+(DECLARE\: EVAL@COMPILE DONTCOPY 
+
+(FILESLOAD (LOADCOMP) MAKEINIT)
+)
+STOP
diff --git a/CLTL2/IOCHAR b/CLTL2/IOCHAR
new file mode 100644
index 00000000..cfd92496
--- /dev/null
+++ b/CLTL2/IOCHAR
@@ -0,0 +1,309 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED " 3-Sep-91 10:15:51" {DSK}<new>sources>lispcore>sources>IOCHAR.;3 55124  
+
+      changes to%:  (FNS MAKEBITTABLE)
+
+      previous date%: " 4-Apr-91 22:29:21" {DSK}<new>sources>lispcore>sources>IOCHAR.;2)
+
+
+(* ; "
+Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT IOCHARCOMS)
+
+(RPAQQ IOCHARCOMS ((COMS (FNS CHCON UNPACK DCHCON DUNPACK) (FNS UALPHORDER ALPHORDER CONCAT CONCATCODES PACKC PACK PACK* \PACK.ITEM STRPOS) (FUNCTIONS XCL:PACK XCL:PACK*) (GLOBALVARS \SIGNFLAG \PRINTRADIX) (DECLARE%: DONTCOPY (MACROS \CATRANSLATE))) (COMS (FNS STRPOSL MAKEBITTABLE) (DECLARE%: DONTCOPY (RESOURCES \STRPOSLARRAY)) (INITRESOURCES \STRPOSLARRAY)) (COMS (FNS CASEARRAY UPPERCASEARRAY LOWERCASEARRAY FLIPCASEARRAY) (P (MOVD? (QUOTE SETA) (QUOTE SETCASEARRAY)) (MOVD? (QUOTE ELT) (QUOTE GETCASEARRAY))) (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (\TRANSPARENT (CASEARRAY)) (UPPERCASEARRAY (UPPERCASEARRAY)) (LOWERCASEARRAY (LOWERCASEARRAY)) (FLIPCASEARRAY (FLIPCASEARRAY)))) (DECLARE%: EVAL@COMPILE (PROP GLOBALVAR UPPERCASEARRAY LOWERCASEARRAY FLIPCASEARRAY) DONTCOPY (GLOBALVARS \TRANSPARENT))) (COMS (FNS FILEPOS FFILEPOS \SETUP.FFILEPOS) (DECLARE%: EVAL@COMPILE DONTCOPY (RESOURCES \FFDELTA1 \FFDELTA2 \FFPATCHAR) (CONSTANTS (\MAX.PATTERN.SIZE 128) (\MIN.PATTERN.SIZE 3) (FILEPOS.SEGMENT.SIZE 32768) (\MIN.SEARCH.LENGTH 100))) (INITRESOURCES \FFDELTA1 \FFDELTA2 \FFPATCHAR)) (COMS (* ;; "DATE Functions") (FNS DATE DATEFORMAT GDATE IDATE \IDATESCANTOKEN \IDATE-PARSE-MONTH \OUTDATE \OUTDATE-STRING \RPLRIGHT \UNPACKDATE \PACKDATE \DTSCAN \ISDST? \CHECKDSTCHANGE) (OPTIMIZERS DATEFORMAT) (* ;; "Because DST begins the FIRST weekend in April now, \BeginDST changed from 120 to 98 as of 4/3/87 (JDS)  Note: this only affects standalone users--those with time servers automatically get correct local info (bvm)") (INITVARS (\TimeZoneComp 8) (\BeginDST 98) (\EndDST 304) (\DayLightSavings T)) (ADDVARS (TIME.ZONES (8 "PST" "PDT") (7 "MST" "MDT") (6 "CST" "CDT") (5 "EST" "EDT") (0 "GMT" "BST") (0 "UT") (-1 "MET" "MET DST") (-2 "EET" "EET DST"))) (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \TimeZoneComp \BeginDST \EndDST \DayLightSavings TIME.ZONES) (CONSTANTS (\4YearsDays (ADD1 (ITIMES 365 4)))))) (LOCALVARS . T) (PROP FILETYPE IOCHAR) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DATEFORMAT) (NLAML) (LAMA PACK* CONCAT)))))
+(DEFINEQ
+
+(CHCON
+(LAMBDA (X FLG RDTBL) (* bvm%: "24-Mar-86 16:29") (PROG (BASE OFFST LEN \CHCONLST \CHCONLSTAIL FATP) (COND (FLG (GO SLOWCASE))) (COND ((LITATOM X) (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) (SETQ OFFST 1) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) ((STRINGP X) (SETQ BASE (ffetch (STRINGP BASE) of X)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)) (SETQ OFFST (ffetch (STRINGP OFFST) of X)) (SETQ LEN (ffetch (STRINGP LENGTH) of X))) (T (GO SLOWCASE))) (RETURN (for I from OFFST to (IPLUS OFFST LEN -1) collect (\GETBASECHAR FATP BASE I))) SLOWCASE (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (* ; "Open code COLLECT") (COND (\CHCONLSTAIL (FRPLACD \CHCONLSTAIL (SETQ \CHCONLSTAIL (LIST CODE)))) (T (SETQ \CHCONLST (SETQ \CHCONLSTAIL (LIST CODE))))))) X FLG RDTBL) (RETURN \CHCONLST)))
+)
+
+(UNPACK
+(LAMBDA (X FLG RDTBL) (* bvm%: "24-Mar-86 16:29") (PROG (BASE OFFST LEN \CHCONLST \CHCONLSTAIL FATP) (COND (FLG (GO SLOWCASE))) (COND ((LITATOM X) (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) (SETQ OFFST 1) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) ((STRINGP X) (SETQ BASE (ffetch (STRINGP BASE) of X)) (SETQ OFFST (ffetch (STRINGP OFFST) of X)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)) (SETQ LEN (ffetch (STRINGP LENGTH) of X))) (T (GO SLOWCASE))) (RETURN (for I from OFFST to (IPLUS OFFST LEN -1) collect (FCHARACTER (\GETBASECHAR FATP BASE I)))) SLOWCASE (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (SETQ CODE (FCHARACTER CODE)) (* ; "Open code COLLECT") (COND (\CHCONLSTAIL (FRPLACD \CHCONLSTAIL (SETQ \CHCONLSTAIL (LIST CODE)))) (T (SETQ \CHCONLST (SETQ \CHCONLSTAIL (LIST CODE))))))) X FLG RDTBL) (RETURN \CHCONLST)))
+)
+
+(DCHCON
+(LAMBDA (X SCRATCHLIST FLG RDTBL) (* ; "Edited 24-Dec-86 14:04 by jds") (* ;;; "Unpack the character codes that make up the print-representation of X into the scratch list SCRATCHLIST.  If FLG, use the PRIN2-pname.  Do the printing according to RDTBL readtable, if supplied.") (SCRATCHLIST SCRATCHLIST (PROG (BASE OFFST LEN FATP) (COND (FLG (GO SLOWCASE))) (COND ((LITATOM X) (* ; "LITATOM case:  Set up the indexing info for the \GETBASECHAR loop below.") (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) (SETQ OFFST 1) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) ((STRINGP X) (* ; "STRING case:  Set up the indexing info for the \GETBASECHAR loop below.") (SETQ BASE (ffetch (STRINGP BASE) of X)) (SETQ OFFST (ffetch (STRINGP OFFST) of X)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)) (SETQ LEN (ffetch (STRINGP LENGTH) of X))) (T (GO SLOWCASE))) (RETURN (for I from OFFST to (IPLUS OFFST LEN -1) do (* ;; "Copy the characters from the string/atom-pname into the list") (ADDTOSCRATCHLIST (\GETBASECHAR FATP BASE I)))) SLOWCASE (* ;; "Slow case:  Use \MAPPNAME to generate the characters, and grab onto them.") (RETURN (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (ADDTOSCRATCHLIST CODE))) X FLG RDTBL)))))
+)
+
+(DUNPACK
+(LAMBDA (X SCRATCHLIST FLG RDTBL) (* bvm%: "24-Mar-86 16:30") (SCRATCHLIST SCRATCHLIST (PROG (BASE OFFST LEN FATP) (COND (FLG (GO SLOWCASE))) (COND ((LITATOM X) (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) (SETQ OFFST 1) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) ((STRINGP X) (SETQ BASE (ffetch (STRINGP BASE) of X)) (SETQ OFFST (ffetch (STRINGP OFFST) of X)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)) (SETQ LEN (ffetch (STRINGP LENGTH) of X))) (T (GO SLOWCASE))) (RETURN (for I from OFFST to (IPLUS OFFST LEN -1) do (ADDTOSCRATCHLIST (FCHARACTER (\GETBASECHAR FATP BASE I))))) SLOWCASE (RETURN (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (ADDTOSCRATCHLIST (FCHARACTER CODE)))) X FLG RDTBL)))))
+)
+)
+(DEFINEQ
+
+(UALPHORDER
+(LAMBDA (ARG1 B) (* rmk%: " 2-Apr-85 11:20") (ALPHORDER ARG1 B UPPERCASEARRAY)))
+
+(ALPHORDER
+(LAMBDA (A B CASEARRAY) (* rmk%: "27-Mar-85 17:43") (DECLARE (GLOBALVARS \TRANSPARENT)) (PROG (CABASE ABASE ALEN AOFFSET AFATP BBASE BLEN BOFFSET BFATP C1 C2) (COND ((LITATOM A) (SETQ ABASE (ffetch (LITATOM PNAMEBASE) of A)) (SETQ AOFFSET 1) (SETQ ALEN (ffetch (LITATOM PNAMELENGTH) of A)) (SETQ AFATP (ffetch (LITATOM FATPNAMEP) of A))) ((STRINGP A) (SETQ ABASE (ffetch (STRINGP BASE) of A)) (SETQ AOFFSET (ffetch (STRINGP OFFST) of A)) (SETQ ALEN (ffetch (STRINGP LENGTH) of A)) (SETQ AFATP (ffetch (STRINGP FATSTRINGP) of A))) (T (RETURN (COND ((NUMBERP A) (* ; "Numbers are less than all other types") (OR (NOT (NUMBERP B)) (NOT (GREATERP A B)))) ((OR (NUMBERP B) (LITATOM B) (STRINGP B)) NIL) (T T))))) (COND ((LITATOM B) (SETQ BBASE (ffetch (LITATOM PNAMEBASE) of B)) (SETQ BOFFSET 1) (SETQ BLEN (ffetch (LITATOM PNAMELENGTH) of B)) (SETQ BFATP (ffetch (LITATOM FATPNAMEP) of B))) ((STRINGP B) (SETQ BBASE (ffetch (STRINGP BASE) of B)) (SETQ BOFFSET (ffetch (STRINGP OFFST) of B)) (SETQ BLEN (ffetch (STRINGP LENGTH) of B)) (SETQ BFATP (ffetch (STRINGP FATSTRINGP) of B))) (T (* ; "Only numbers are 'less than' atoms and strings") (RETURN (NOT (NUMBERP B))))) (SETQ CABASE (fetch (ARRAYP BASE) of (SETQ CASEARRAY (\DTEST (OR CASEARRAY \TRANSPARENT) (QUOTE ARRAYP))))) (RETURN (for I (CAFAT _ (EQ \ST.POS16 (fetch (ARRAYP TYP) of CASEARRAY))) (CASIZE _ (fetch (ARRAYP LENGTH) of CASEARRAY)) from 0 do (COND ((IGEQ I ALEN) (RETURN (COND ((EQ ALEN BLEN) (QUOTE EQUAL)) (T (QUOTE LESSP))))) ((IGEQ I BLEN) (RETURN NIL)) ((EQ (SETQ C1 (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR AFATP ABASE (IPLUS I AOFFSET)))) (SETQ C2 (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR BFATP BBASE (IPLUS I BOFFSET)))))) ((ILESSP C1 C2) (RETURN (QUOTE LESSP))) (T (* ; "Greater") (RETURN NIL)))))))
+)
+
+(CONCAT
+(LAMBDA N (* rmk%: "26-Mar-85 19:08") (PROG ((J N) (LEN 0) (POS 1) S NM FATSEENP) L1 (COND ((NEQ J 0) (COND ((STRINGP (SETQ NM (ARG N J))) (OR FATSEENP (SETQ FATSEENP (ffetch (STRINGP FATSTRINGP) of NM)))) ((LITATOM NM) (OR FATSEENP (SETQ FATSEENP (ffetch (LITATOM FATPNAMEP) of NM)))) (T (SETARG N J (SETQ NM (MKSTRING NM))) (OR FATSEENP (SETQ FATSEENP (ffetch (STRINGP FATSTRINGP) of NM))))) (SETQ LEN (IPLUS LEN (NCHARS NM))) (SETQ J (SUB1 J)) (GO L1))) (SETQ S (ALLOCSTRING LEN NIL NIL FATSEENP)) L2 (COND ((NEQ J N) (SETQ J (ADD1 J)) (RPLSTRING S POS (ARG N J)) (SETQ POS (IPLUS POS (NCHARS (ARG N J)))) (GO L2))) (RETURN S)))
+)
+
+(CONCATCODES
+(LAMBDA (CHARCODES) (* bvm%: " 6-May-84 21:56") (PROG ((STR (ALLOCSTRING (LENGTH CHARCODES)))) (for X in CHARCODES as I from 1 do (RPLCHARCODE STR I X)) (RETURN STR)))
+)
+
+(PACKC
+(LAMBDA (X) (* rmk%: "11-Apr-85 15:35") (* ;; "Takes character codes in X, stuffs them into the \PNAMESTRING, and then calls \MKATOM") (WITH-RESOURCE (\PNAMESTRING) (BIND (PBASE _ (ffetch (STRINGP XBASE) of \PNAMESTRING)) for N from 0 as C in X do (AND (IGREATERP N \PNAMELIMIT) (LISPERROR "ATOM TOO LONG")) (\PNAMESTRINGPUTCHAR PBASE N C) finally (RETURN (\MKATOM PBASE 0 N \FATPNAMESTRINGP)))))
+)
+
+(PACK
+(LAMBDA (X) (* ; "Edited 21-Mar-88 15:29 by bvm") (AND X (NLISTP X) (\ILLEGAL.ARG X)) (DECLARE (SPECVARS PACK.INDEX \PNAMESTRING)) (WITH-RESOURCE (\PNAMESTRING) (PROG ((PACK.INDEX 1) ITEM) LP (COND ((NULL X) (RETURN (\MKATOM (fetch (STRINGP XBASE) of \PNAMESTRING) 0 (SUB1 PACK.INDEX) \FATPNAMESTRINGP)))) (COND ((OR (STRINGP (SETQ ITEM (CAR X))) (LITATOM ITEM)) (RPLSTRING \PNAMESTRING (PROG1 PACK.INDEX (AND (IGREATERP (add PACK.INDEX (NCHARS ITEM)) (ADD1 \PNAMELIMIT)) (LISPERROR "ATOM TOO LONG"))) ITEM)) (T (\PACK.ITEM ITEM))) (SETQ X (LISTP (CDR X))) (GO LP))))
+)
+
+(PACK*
+(LAMBDA U (* ; "Edited 21-Mar-88 15:29 by bvm") (DECLARE (SPECVARS PACK.INDEX \PNAMESTRING)) (WITH-RESOURCE (\PNAMESTRING) (PROG ((PACK.INDEX 1) (M 1) ITEM) LP (COND ((IGREATERP M U) (RETURN (\MKATOM (fetch (STRINGP XBASE) of \PNAMESTRING) 0 (SUB1 PACK.INDEX) \FATPNAMESTRINGP)))) (SETQ ITEM (ARG U M)) (COND ((AND (NULL *PACKAGE*) (LITATOM ITEM)) (* ;; "If we're in that nasty region of the INIT process before packages have been turned on, then we want to be careful to strip off any pseudo-package prefixes in the symbol's pname.  We use the utility NAMESTRING-CONVERSION-CLAUSE from LLPACKAGE for this search.") (LET* ((BASE (ffetch (LISP:SYMBOL PNAMEBASE) of ITEM)) (LEN (ffetch (LISP:SYMBOL PNAMELENGTH) of ITEM)) (FATP (ffetch (LISP:SYMBOL FATPNAMEP) of ITEM)) (CLAUSE (NAMESTRING-CONVERSION-CLAUSE BASE 1 LEN FATP))) (COND ((NULL CLAUSE) (* ; "Nothing special to do; this symbol didn't match any of the conversion clauses.") (RPLSTRING \PNAMESTRING (PROG1 PACK.INDEX (AND (IGREATERP (add PACK.INDEX (NCHARS ITEM)) (ADD1 \PNAMELIMIT)) (LISPERROR "ATOM TOO LONG"))) ITEM)) (T (* ; "The symbol matched a clause.  We should use only that part of the symbol that comes after the matching prefix.") (LET ((PREFIX-LENGTH (ffetch (STRINGP LENGTH) (LISP:FIRST CLAUSE)))) (RPLSTRING \PNAMESTRING (PROG1 PACK.INDEX (AND (IGREATERP (add PACK.INDEX (IDIFFERENCE (NCHARS ITEM) PREFIX-LENGTH)) (ADD1 \PNAMELIMIT)) (LISPERROR "ATOM TOO LONG"))) (SUBSTRING ITEM (IPLUS 1 PREFIX-LENGTH)))))))) ((OR (STRINGP ITEM) (LITATOM ITEM)) (RPLSTRING \PNAMESTRING (PROG1 PACK.INDEX (AND (IGREATERP (add PACK.INDEX (NCHARS ITEM)) (ADD1 \PNAMELIMIT)) (LISPERROR "ATOM TOO LONG"))) ITEM)) (T (\PACK.ITEM ITEM))) (SETQ M (ADD1 M)) (GO LP))))
+)
+
+(\PACK.ITEM
+(LAMBDA (ITEM) (* ; "Edited 21-Mar-88 15:30 by bvm") (DECLARE (USEDFREE PACK.INDEX \PNAMESTRING)) (* ;;; "Slow case for PACK and PACK* -- append characters of ITEM to \PNAMESTRING, updating PACK.INDEX accordingly") (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (AND (IGREATERP PACK.INDEX \PNAMELIMIT) (LISPERROR "ATOM TOO LONG")) (\PNAMESTRINGPUTCHAR (fetch (STRINGP BASE) of \PNAMESTRING) (SUB1 PACK.INDEX) CODE) (add PACK.INDEX 1))) ITEM))
+)
+
+(STRPOS
+(LAMBDA (PAT STRING START SKIP ANCHOR TAIL CASEARRAY BACKWARDSFLG) (* ; "Edited  6-Jan-88 12:44 by jds") (DECLARE (GLOBALVARS \TRANSPARENT)) (PROG (PATLEN PATBASE PATOFFST STRINGLEN STRINGBASE STRINGOFFST MAXI JMAX 1stPATchar jthPATchar STRFAT PATFAT) (COND ((LITATOM PAT) (SETQ PATBASE (fetch (LITATOM PNAMEBASE) of PAT)) (SETQ PATOFFST 1) (SETQ PATLEN (fetch (LITATOM PNAMELENGTH) of PAT)) (SETQ PATFAT (fetch (LITATOM FATPNAMEP) of PAT))) (T (OR (STRINGP PAT) (SETQ PAT (MKSTRING PAT))) (SETQ PATBASE (fetch (STRINGP BASE) of PAT)) (SETQ PATOFFST (fetch (STRINGP OFFST) of PAT)) (SETQ PATLEN (fetch (STRINGP LENGTH) of PAT)) (SETQ PATFAT (fetch (STRINGP FATSTRINGP) of PAT)))) (COND ((LITATOM STRING) (SETQ STRINGBASE (fetch (LITATOM PNAMEBASE) of STRING)) (SETQ STRINGOFFST 1) (SETQ STRINGLEN (fetch (LITATOM PNAMELENGTH) of STRING)) (SETQ STRFAT (fetch (LITATOM FATPNAMEP) of STRING))) (T (OR (STRINGP STRING) (SETQ STRING (MKSTRING STRING))) (SETQ STRINGBASE (fetch (STRINGP BASE) of STRING)) (SETQ STRINGOFFST (fetch (STRINGP OFFST) of STRING)) (SETQ STRINGLEN (fetch (STRINGP LENGTH) of STRING)) (SETQ STRFAT (fetch (STRINGP FATSTRINGP) of STRING)))) (COND ((IGEQ 0 (SETQ MAXI (ADD1 (IDIFFERENCE STRINGLEN PATLEN)))) (* ; "Who's he kidding?  The PATTERN length is greater than the STRING length") (RETURN))) (COND ((NULL START) (SETQ START (COND (BACKWARDSFLG MAXI) (T 1)))) ((ILESSP START 0) (add START (ADD1 STRINGLEN)) (COND ((ILESSP START 1) (RETURN)))) ((IGREATERP START MAXI) (RETURN))) (* ; "Normalize start to a 1-origin index between 1 and LEN") (COND ((ILEQ PATLEN 0) (RETURN (AND TAIL START)))) (* ; "Null pattern matches anything -- but (STRPOS %"%" %"%") is NIL unless TAIL is T.") (AND SKIP (SETQ SKIP (CHCON1 SKIP))) (COND ((NULL CASEARRAY) (SETQ CASEARRAY \TRANSPARENT)) ((NOT (AND (ARRAYP CASEARRAY) (OR (EQ \ST.BYTE (fetch (ARRAYP TYP) of CASEARRAY)) (EQ \ST.POS16 (fetch (ARRAYP TYP) of CASEARRAY))))) (\ILLEGAL.ARG CASEARRAY))) (* ; "Oh, for a LET here!") (add STRINGOFFST -1) (add PATOFFST -1) (RETURN (PROG ((CAOFFST (fetch (ARRAYP OFFST) of CASEARRAY)) (CABASE (fetch (ARRAYP BASE) of CASEARRAY)) (CAFAT (EQ \ST.POS16 (fetch (ARRAYP TYP) of CASEARRAY))) (CASIZE (fetch (ARRAYP LENGTH) of CASEARRAY)) (OFFST.I (IPLUS STRINGOFFST START (COND (BACKWARDSFLG 1) (T -1)))) (LASTI (IPLUS STRINGOFFST (COND (ANCHOR START) (BACKWARDSFLG 1) (T MAXI)))) (JSTART (IPLUS PATOFFST 2)) (JMAX (IPLUS PATOFFST PATLEN))) (* ; "Remember! START is a 1-origin index") (* ; "There will be at least one pass thru the following loop, or else we would have (RETURN) before now") (OR (EQ 0 CAOFFST) (ERROR "CASEARRAY can't be a sub-array: " CASEARRAY)) (SETQ 1stPATchar (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR PATFAT PATBASE (ADD1 PATOFFST)))) LP (COND ((COND (BACKWARDSFLG (ILESSP (add OFFST.I -1) LASTI)) (T (IGREATERP (add OFFST.I 1) LASTI))) (RETURN)) ((AND (OR (EQ 1stPATchar SKIP) (EQ 1stPATchar (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR STRFAT STRINGBASE OFFST.I)))) (for J from JSTART to JMAX as K from (ADD1 OFFST.I) always (OR (EQ SKIP (SETQ jthPATchar (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR PATFAT PATBASE J)))) (EQ jthPATchar (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR STRFAT STRINGBASE K)))))) (RETURN (IDIFFERENCE (COND (TAIL (IPLUS OFFST.I PATLEN)) (T OFFST.I)) STRINGOFFST)))) (GO LP) (* ; "Fall out thru bottom if didn't find it")))))
+)
+)
+
+(CL:DEFUN XCL:PACK (NAMES &OPTIONAL (PACKAGE *PACKAGE*)) (* ;;; "NAMES should be a list of symbols and strings.  A new symbol is created in the given package with a print name equal to the concatenation of the of the NAMES. ") (CL:INTERN (CONCATLIST NAMES) PACKAGE))
+
+(CL:DEFUN XCL:PACK* (&REST NAMES) (* ;;; "NAMES should be a list of symbols and strings.  A new symbol is created in the current package with a print name equal to the concatenation of the of the NAMES. ") (CL:INTERN (CONCATLIST NAMES)))
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \SIGNFLAG \PRINTRADIX)
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \CATRANSLATE MACRO (OPENLAMBDA (CABASE CASIZE CAFAT CHAR) (COND ((ILEQ CHAR CASIZE) (* ; "If it's in the table, use the table value") (\GETBASEBYTE CABASE CHAR)) (T (* ; "Off the end -- assume it's itself") CHAR))))
+)
+)
+(DEFINEQ
+
+(STRPOSL
+(LAMBDA (A STRING START NEG BACKWARDSFLG) (* edited%: "18-Mar-86 17:20") (* ;; "Given a list of charcodes, A, find the first one in STRING.") (GLOBALRESOURCE \STRPOSLARRAY (PROG (BASE OFFST LEN I LASTI STRFAT CH) (OR (type? CHARTABLE A) (SETQ A (MAKEBITTABLE A NIL \STRPOSLARRAY))) (if (LITATOM STRING) then (SETQ BASE (fetch (LITATOM PNAMEBASE) of STRING)) (SETQ LEN (fetch (LITATOM PNAMELENGTH) of STRING)) (SETQ OFFST 1) (SETQ STRFAT (fetch (LITATOM FATPNAMEP) of STRING)) else (OR (STRINGP STRING) (SETQ STRING (MKSTRING STRING))) (SETQ BASE (fetch (STRINGP BASE) of STRING)) (SETQ LEN (fetch (STRINGP LENGTH) of STRING)) (SETQ OFFST (fetch (STRINGP OFFST) of STRING)) (SETQ STRFAT (fetch (STRINGP FATSTRINGP) of STRING))) (if (NULL START) then (SETQ START (if BACKWARDSFLG then LEN else 1)) elseif (ILESSP START 0) then (add START (ADD1 LEN)) (if (ILESSP START 1) then (RETURN)) elseif (IGREATERP START LEN) then (RETURN)) (* ; "Normalize start to a 1-origin index between 1 and LEN") (add OFFST -1) (* ; "Bias the OFFST since START is 1-origin and the loop deals in 0-origin") (SETQ NEG (if NEG then (* ; "Convert NEG to match the correct value returned by \SYNCODE") 0 else 1)) (SETQ I (IPLUS OFFST START)) (SETQ LASTI (IPLUS OFFST (if BACKWARDSFLG then (add I 1) 1 else (add I -1) LEN))) (* ; "There will be at least one pass thru the following loop, or else we would have (RETURN) before now") LP (if (if BACKWARDSFLG then (ILESSP (add I -1) LASTI) else (IGREATERP (add I 1) LASTI)) then (RETURN) elseif (EQ NEG (\SYNCODE A (\GETBASECHAR STRFAT BASE I))) then (RETURN (IDIFFERENCE I OFFST))) (GO LP))))
+)
+
+(MAKEBITTABLE
+(LAMBDA (L NEG A) (* ; "Edited  2-Sep-91 20:43 by jrb:") (COND ((type? CHARTABLE A) (* ; "Clear it") (\ZEROBYTES A 0 \MAXTHINCHAR) (if (fetch (CHARTABLE NSCHARHASH) of A) then (CLRHASH (fetch (CHARTABLE NSCHARHASH) of A)))) (T (SETQ A (create CHARTABLE)))) (for X in L do (\SETSYNCODE A (OR (SMALLP X) (CHCON1 X)) 1)) (* ; "Invert 1 and 0 if NEG") (AND NEG (for I from 0 to \MAXCHAR do (\SETSYNCODE A I (LOGXOR 1 (\SYNCODE A I))))) A)
+)
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTDEF (QUOTE \STRPOSLARRAY) (QUOTE RESOURCES) (QUOTE (NEW (NCREATE (QUOTE CHARTABLE)))))
+)
+)
+
+(/SETTOPVAL (QUOTE \\STRPOSLARRAY.GLOBALRESOURCE) NIL)
+(DEFINEQ
+
+(CASEARRAY
+(LAMBDA (OLDAR) (* lmm "20-MAR-81 10:21") (COND (OLDAR (COPYARRAY OLDAR)) (T (PROG ((AR (ARRAY 256 (QUOTE BYTE) 0 0))) (for I from 0 to 255 do (SETA AR I I)) (RETURN AR)))))
+)
+
+(UPPERCASEARRAY
+(LAMBDA NIL (* rmk%: " 2-Apr-85 11:22") (OR (ARRAYP UPPERCASEARRAY) (LET ((CA (CASEARRAY))) (for I from (CHARCODE a) to (CHARCODE z) do (SETCASEARRAY CA I (IDIFFERENCE I (CONSTANT (IDIFFERENCE (CHARCODE a) (CHARCODE A)))))) (SETQ UPPERCASEARRAY CA))))
+)
+
+(LOWERCASEARRAY
+(LAMBDA NIL (* ; "Edited  7-Feb-91 10:21 by jrb:") (OR (ARRAYP LOWERCASEARRAY) (LET ((CA (CASEARRAY))) (for I from (CHARCODE A) to (CHARCODE Z) do (SETCASEARRAY CA I (IPLUS I (CONSTANT (IDIFFERENCE (CHARCODE a) (CHARCODE A)))))) (SETQ LOWERCASEARRAY CA))))
+)
+
+(FLIPCASEARRAY
+(LAMBDA NIL (* ; "Edited  7-Feb-91 10:24 by jrb:") (OR (ARRAYP FLIPCASEARRAY) (LET ((CA (CASEARRAY))) (for I from (CHARCODE A) to (CHARCODE Z) do (SETCASEARRAY CA I (IPLUS I (CONSTANT (IDIFFERENCE (CHARCODE a) (CHARCODE A)))))) (for I from (CHARCODE a) to (CHARCODE z) do (SETCASEARRAY CA I (IDIFFERENCE I (CONSTANT (IDIFFERENCE (CHARCODE a) (CHARCODE A)))))) (SETQ FLIPCASEARRAY CA))))
+)
+)
+
+(MOVD? (QUOTE SETA) (QUOTE SETCASEARRAY))
+
+(MOVD? (QUOTE ELT) (QUOTE GETCASEARRAY))
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(RPAQ \TRANSPARENT (CASEARRAY))
+
+(RPAQ UPPERCASEARRAY (UPPERCASEARRAY))
+
+(RPAQ LOWERCASEARRAY (LOWERCASEARRAY))
+
+(RPAQ FLIPCASEARRAY (FLIPCASEARRAY))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS UPPERCASEARRAY GLOBALVAR T)
+DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \TRANSPARENT)
+)
+)
+(DEFINEQ
+
+(FILEPOS
+(LAMBDA (STR FILE START END SKIP TAIL CASEARRAY) (* Pavel "12-Oct-86 15:13") (* ;; "NB: this function now works on non-PAGEMAPPED files.  It must use only IO functions that respect that.") (PROG ((SKIPCHAR (AND SKIP (CHCON1 SKIP))) (CA (fetch (ARRAYP BASE) of (COND (CASEARRAY (COND ((AND (ARRAYP CASEARRAY) (EQ (fetch (ARRAYP TYP) of CASEARRAY) \ST.BYTE)) CASEARRAY) (T (CASEARRAY CASEARRAY)))) (T \TRANSPARENT)))) (STREAM (\GETSTREAM FILE (QUOTE INPUT))) CHAR FIRSTCHAR STRBASE STRINDEX PATLEN PATINDEX ORGFILEPTR LASTINDEX STARTBYTE ENDBYTE BIGENDBYTE STARTSEG ENDSEG) (COND ((LITATOM STR) (SETQ STRBASE (fetch (LITATOM PNAMEBASE) of STR)) (SETQ STRINDEX 1) (SETQ PATLEN (fetch (LITATOM PNAMELENGTH) of STR))) (T (OR (STRINGP STR) (SETQ STR (MKSTRING STR))) (SETQ STRBASE (fetch (STRINGP BASE) of STR)) (SETQ STRINDEX (fetch (STRINGP OFFST) of STR)) (SETQ PATLEN (fetch (STRINGP LENGTH) of STR)))) (* ; "calculate start addr and set file ptr.") (SETQ STARTBYTE (COND (START (COND ((NOT (AND (FIXP START) (IGEQ START 0))) (LISPERROR "ILLEGAL ARG" START))) (SETQ ORGFILEPTR (\GETFILEPTR STREAM)) (\SETFILEPTR STREAM START) START) (T (SETQ ORGFILEPTR (\GETFILEPTR STREAM))))) (* ; "calculate the character address of the character after the last possible match.") (SETQ ENDBYTE (ADD1 (COND ((NULL END) (* ; "Default is end of file") (IDIFFERENCE (\GETEOFPTR STREAM) PATLEN)) ((IGEQ END 0) (* ; "Absolute byte pointer given") (IMIN END (IDIFFERENCE (\GETEOFPTR STREAM) PATLEN))) ((IGREATERP PATLEN (IMINUS END)) (* ; "END is too far, use eof less length") (IDIFFERENCE (\GETEOFPTR STREAM) PATLEN)) (T (IDIFFERENCE (IPLUS (\GETEOFPTR STREAM) END 1) PATLEN))))) (* ;; "use STARTBYTE and ENDBYTE instead of START and END because vm functions shouldn't change their arguments.") (COND ((IGEQ STARTBYTE ENDBYTE) (* ; "nothing to search") (GO FAILED))) (SETQ LASTINDEX PATLEN) SKIPLP (* ; "set the first character to FIRSTCHAR, handling leading skips.") (COND ((EQ LASTINDEX 0) (* ; "null case") (GO FOUNDIT)) ((EQ (SETQ FIRSTCHAR (\GETBASEBYTE CA (\GETBASEBYTE STRBASE STRINDEX))) SKIPCHAR) (* ; "first character in pattern is skip.") (SETQ LASTINDEX (SUB1 LASTINDEX)) (\BIN STREAM) (* ; "Move forward a character.") (add STRINDEX 1) (add STARTBYTE 1) (GO SKIPLP))) (SETQ LASTINDEX (IPLUS LASTINDEX STRINDEX)) (* ; "Used for end of pattern check, comparing against current INDEX") (COND ((SMALLP ENDBYTE) (SETQ STARTSEG (SETQ ENDSEG 0))) (T (* ;; "The search will be in the large integers at least part of the time, so split the start and end fileptrs into hi and lo parts.  The `segment' size we choose is smaller than 2^16 so that we are still smallp near the boundary (can get around that here by decrementing everyone, but can't in FFILEPOS).  Note that STARTBYTE and ENDBYTE are never actually used as file ptrs, just for counting.") (SETQ ENDSEG (FOLDLO ENDBYTE FILEPOS.SEGMENT.SIZE)) (SETQ BIGENDBYTE (IMOD ENDBYTE FILEPOS.SEGMENT.SIZE)) (SETQ STARTSEG (FOLDLO STARTBYTE FILEPOS.SEGMENT.SIZE)) (SETQ STARTBYTE (IMOD STARTBYTE FILEPOS.SEGMENT.SIZE)) (SETQ ENDBYTE (COND ((EQ STARTSEG ENDSEG) BIGENDBYTE) (T (* ;; "In different segments, so we'll have to search all the way to the end of this seg;  hence, `end' is currently as big as it gets") FILEPOS.SEGMENT.SIZE))))) FIRSTCHARLP (* ;; "STARTBYTE is the possible beginning of a match.  the file ptr of the file is always at STARTBYTE position when the FIRSTCHAR loop is passed.") (COND ((EQ STARTBYTE ENDBYTE) (* ; "end of this part of search") (COND ((EQ STARTSEG ENDSEG) (* ; "failed") (GO FAILED))) (* ; "Finished this segment, roll over into new one") (SETQ STARTBYTE 0) (* ; "= STARTBYTE-FILEPOS.SEGMENT.SIZE") (COND ((EQ (add STARTSEG 1) ENDSEG) (* ; "Entering final segment, so set ENDBYTE to actual end instead of segment end") (COND ((EQ (SETQ ENDBYTE BIGENDBYTE) 0) (GO FAILED))))) (GO FIRSTCHARLP)) ((NEQ FIRSTCHAR (\GETBASEBYTE CA (\BIN STREAM))) (add STARTBYTE 1) (GO FIRSTCHARLP))) (SETQ PATINDEX STRINDEX) MATCHLP (* ; "At this point, STR is matched thru offset PATINDEX") (COND ((EQ (SETQ PATINDEX (ADD1 PATINDEX)) LASTINDEX) (* ; "matched for entire length") (GO FOUNDIT)) ((OR (EQ (SETQ CHAR (\GETBASEBYTE CA (\GETBASEBYTE STRBASE PATINDEX))) (\GETBASEBYTE CA (\BIN STREAM))) (EQ CHAR SKIPCHAR)) (* ; "Char from file matches char from STR") (GO MATCHLP)) (T (* ; "Match failed, so we have to start again with first char") (\SETFILEPTR STREAM (IDIFFERENCE (\GETFILEPTR STREAM) (IDIFFERENCE PATINDEX STRINDEX))) (* ;; "Back up over the chars we have just read in trying to match, less one.  I.e.  go back to one past the previous starting point") (add STARTBYTE 1) (GO FIRSTCHARLP))) FOUNDIT (* ; "set fileptr, adjust for beginning skips and return proper value.") (COND ((NOT TAIL) (* ; "Fileptr wants to be at start of string") (\SETFILEPTR STREAM (IDIFFERENCE (\GETFILEPTR STREAM) PATLEN)))) (RETURN (\GETFILEPTR STREAM)) FAILED (* ; "return the fileptr to its initial position.") (\SETFILEPTR STREAM ORGFILEPTR) (RETURN NIL)))
+)
+
+(FFILEPOS
+(LAMBDA (PATTERN FILE START END SKIP TAIL CASEARRAY) (* Pavel "12-Oct-86 15:20") (PROG ((OFD (\GETOFD (OR FILE (INPUT)))) PATBASE PATOFFSET PATLEN ORGFILEPTR STARTOFFSET ENDOFFSET BIGENDOFFSET STARTSEG ENDSEG EOF) (COND (SKIP (* ; "Slow case--use FILEPOS") (GO TRYFILEPOS)) ((NOT (fetch PAGEMAPPED of (fetch (STREAM DEVICE) of OFD))) (* ; "This is a non-page-oriented file.  Use FILEPOS instead.") (GO TRYFILEPOS))) (* ; "calculate start addr and set file ptr.") (COND ((LITATOM PATTERN) (SETQ PATBASE (fetch (LITATOM PNAMEBASE) of PATTERN)) (SETQ PATOFFSET 1) (SETQ PATLEN (fetch (LITATOM PNAMELENGTH) of PATTERN))) (T (OR (STRINGP PATTERN) (SETQ PATTERN (MKSTRING PATTERN))) (SETQ PATBASE (fetch (STRINGP BASE) of PATTERN)) (SETQ PATOFFSET (fetch (STRINGP OFFST) of PATTERN)) (SETQ PATLEN (fetch (STRINGP LENGTH) of PATTERN)))) (COND ((OR (IGREATERP PATLEN \MAX.PATTERN.SIZE) (ILESSP PATLEN \MIN.PATTERN.SIZE)) (GO TRYFILEPOS))) (SETQ ORGFILEPTR (\GETFILEPTR OFD)) (SETQ STARTOFFSET (IPLUS (COND (START (COND ((NOT (AND (FIXP START) (IGEQ START 0))) (LISPERROR "ILLEGAL ARG" START))) START) (T ORGFILEPTR)) (SUB1 PATLEN))) (* ; "STARTOFFSET is the address of the character corresponding to the last character of PATTERN.") (SETQ EOF (\GETEOFPTR OFD)) (* ; "calculate the character address of the character after the last possible match.") (SETQ ENDOFFSET (COND ((NULL END) (* ; "Default is end of file") EOF) (T (IMIN (IPLUS (COND ((ILESSP END 0) (IPLUS EOF END 1)) (T END)) PATLEN) EOF)))) (* ;; "use STARTOFFSET and ENDOFFSET instead of START and END because vm functions shouldn't change their arguments.") (COND ((IGEQ STARTOFFSET ENDOFFSET) (* ; "nothing to search") (RETURN)) ((ILESSP (IDIFFERENCE ENDOFFSET STARTOFFSET) \MIN.SEARCH.LENGTH) (* ; "too small to make FFILEPOS worthwhile") (GO TRYFILEPOS))) (\SETFILEPTR OFD STARTOFFSET) (RETURN (GLOBALRESOURCE (\FFDELTA1 \FFDELTA2 \FFPATCHAR) (PROG ((CASE (fetch (ARRAYP BASE) of (COND (CASEARRAY (COND ((AND (ARRAYP CASEARRAY) (EQ (fetch (ARRAYP TYP) of CASEARRAY) \ST.BYTE)) CASEARRAY) (T (CASEARRAY CASEARRAY)))) (T \TRANSPARENT)))) (DELTA1 (fetch (ARRAYP BASE) of \FFDELTA1)) (DELTA2 (fetch (ARRAYP BASE) of \FFDELTA2)) (PATCHAR (fetch (ARRAYP BASE) of \FFPATCHAR)) (MAXPATINDEX (SUB1 PATLEN)) CHAR CURPATINDEX LASTCHAR INC) (* ;; "Use Boyer-Moore string search algorithm.  Use two auxiliary tables, DELTA1 and DELTA2, to tell how far ahead to move in the file when a partial match fails.  DELTA1 contains, for each character code, the distance of that character from the right end of the pattern, or PATLEN if the character does not occur in the pattern.  DELTA2 contains, for each character position in the pattern, how far ahead to move such that the partial substring discovered to the right of the position now matches some other substring (to the left) in the pattern.  PATCHAR is just PATTERN translated thru CASEARRAY") (\SETUP.FFILEPOS PATBASE PATOFFSET PATLEN PATCHAR DELTA1 DELTA2 CASE) (COND ((SMALLP ENDOFFSET) (SETQ STARTSEG (SETQ ENDSEG 0))) (T (* ;; "The search will be in the large integers at least part of the time, so split the start and end fileptrs into hi and lo parts.  The `segment' size we choose is smaller than 2^16 so that we are still smallp near the boundary.  Note that STARTOFFSET and ENDOFFSET are never actually used as file ptrs, just for counting.") (SETQ ENDSEG (FOLDLO ENDOFFSET FILEPOS.SEGMENT.SIZE)) (SETQ BIGENDOFFSET (MOD ENDOFFSET FILEPOS.SEGMENT.SIZE)) (SETQ STARTSEG (FOLDLO STARTOFFSET FILEPOS.SEGMENT.SIZE)) (SETQ STARTOFFSET (MOD STARTOFFSET FILEPOS.SEGMENT.SIZE)) (SETQ ENDOFFSET (COND ((EQ STARTSEG ENDSEG) BIGENDOFFSET) (T (* ;; "In different segments, so we'll have to search all the way to the end of this seg;  hence, `end' is currently as big as it gets") FILEPOS.SEGMENT.SIZE))))) (SETQ LASTCHAR (GETBASEBYTE PATCHAR MAXPATINDEX)) FIRSTCHARLP (COND ((IGEQ STARTOFFSET ENDOFFSET) (* ; "End of this chunk") (COND ((EQ STARTSEG ENDSEG) (* ; "failed") (GO FAILED)) (T (* ; "Finished this segment, roll over into new one") (add STARTSEG 1) (SETQ STARTOFFSET (IDIFFERENCE STARTOFFSET FILEPOS.SEGMENT.SIZE)) (COND ((EQ STARTSEG ENDSEG) (SETQ ENDOFFSET BIGENDOFFSET))) (GO FIRSTCHARLP)))) ((NEQ (SETQ CHAR (GETBASEBYTE CASE (\BIN OFD))) LASTCHAR) (add STARTOFFSET (SETQ INC (GETBASEBYTE DELTA1 CHAR))) (OR (EQ INC 1) (\INCFILEPTR OFD (SUB1 INC))) (* ; "advance file pointer accordingly (\BIN already advanced it one)") (GO FIRSTCHARLP))) (SETQ CURPATINDEX (SUB1 MAXPATINDEX)) MATCHLP (COND ((ILESSP CURPATINDEX 0) (GO FOUNDIT))) (\DECFILEPTR OFD 2) (* ; "back up to read previous char") (COND ((NEQ (SETQ CHAR (GETBASEBYTE CASE (\BIN OFD))) (GETBASEBYTE PATCHAR CURPATINDEX)) (* ; "Mismatch, advance by greater of delta1 and delta2") (add STARTOFFSET (IDIFFERENCE (SETQ INC (IMAX (GETBASEBYTE DELTA1 CHAR) (GETBASEBYTE DELTA2 CURPATINDEX))) (IDIFFERENCE MAXPATINDEX CURPATINDEX))) (OR (EQ INC 1) (\INCFILEPTR OFD (SUB1 INC))) (GO FIRSTCHARLP))) (SETQ CURPATINDEX (SUB1 CURPATINDEX)) (GO MATCHLP) FOUNDIT (* ; "set fileptr, adjust for beginning skips and return proper value.") (\INCFILEPTR OFD (COND (TAIL (* ; "Put fileptr at end of string") (SUB1 PATLEN)) (T (* ; "back up over the last char we looked at, i.e.  the first char of string") -1))) (RETURN (\GETFILEPTR OFD)) FAILED (* ; "return the fileptr to its initial position.") (\SETFILEPTR OFD ORGFILEPTR) (RETURN NIL)))) TRYFILEPOS (RETURN (FILEPOS PATTERN OFD START END SKIP TAIL CASEARRAY))))
+)
+
+(\SETUP.FFILEPOS
+(LAMBDA (PATBASE PATOFFSET PATLEN PATCHAR DELTA1 DELTA2 CASE) (* jop%: "25-Sep-86 11:44") (* ;;; "Set up PATCHAR, DELTA1 and DELTA2 arrays from string.  This is a separate function currently so I can gather stats on it") (PROG ((PATLEN,PATLEN (IPLUS (LLSH PATLEN BITSPERBYTE) PATLEN)) (MAXPATINDEX (SUB1 PATLEN)) CHAR) (for I from 0 to (FOLDLO \MAXCHAR BYTESPERWORD) do (PUTBASE DELTA1 I PATLEN,PATLEN)) (* ;; "DELTA1 initially all PATLEN, the default for chars not in the pattern.  I assume array is word-aligned") (for I from 0 to MAXPATINDEX do (PUTBASEBYTE PATCHAR I (SETQ CHAR (GETBASEBYTE CASE (GETBASEBYTE PATBASE (IPLUS PATOFFSET I))))) (* ; "Translate STR now so we don't have to do it repeatedly") (PUTBASEBYTE DELTA1 CHAR (IDIFFERENCE MAXPATINDEX I)) (* ; "DELTA1 = how far ahead to move when we mismatch with this char")) (* ;; "Now set up DELTA2.  Scan pattern backwards.  For each character, we want to find the rightmost reoccurrence of the substring consisting of the chars to the right of the current char.  This is slightly different than Boyer-Moore, in that we do not insist that it be the rightmost reoccurrence that is not preceded by the current char.  Small difference, noticeable only in patterns that contain multiple occurrences of tails of the pattern.  The following loop calculates DELTA2 in almost the obvious way, using the observation that DELTA2 is strictly increasing (by our definition) as the pattern index decreases.  This algorithm is potentially quadratic, as it amounts to searching a string (PATTERN, backwards) for a given substring in the 'dumb' way;  fortunately, it is rarely so in practice for 'normal' patterns") (for P from (SUB1 MAXPATINDEX) to 0 by -1 bind (LASTD2 _ 1) (LASTMATCHPOS _ MAXPATINDEX) do (PUTBASEBYTE DELTA2 P (SETQ LASTD2 (COND ((OR (IGEQ LASTD2 PATLEN) (EQ (GETBASEBYTE PATCHAR (IDIFFERENCE MAXPATINDEX LASTD2)) (GETBASEBYTE PATCHAR (ADD1 P)))) (* ;; "The last time around we matched a terminal substring somehow, and now the next char matches the char before that substring, so DELTA2 is just one more, i.e. the match continues.  Once we've overflowed the pattern, the 'match' continues trivially") (ADD1 LASTD2)) (T (do (SETQ LASTMATCHPOS (SUB1 LASTMATCHPOS)) repeatuntil (for I from MAXPATINDEX to (ADD1 P) by -1 as J from LASTMATCHPOS to 0 by -1 always (EQ (GETBASEBYTE PATCHAR I) (GETBASEBYTE PATCHAR J)))) (* ; "Substring from P+1 onward matches substring that ends at LASTMATCHPOS") (IPLUS (IDIFFERENCE MAXPATINDEX LASTMATCHPOS) (IDIFFERENCE MAXPATINDEX P)))))))))
+)
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTDEF (QUOTE \FFDELTA1) (QUOTE RESOURCES) (QUOTE (NEW (ARRAY (ADD1 \MAXCHAR) (QUOTE BYTE)))))
+
+(PUTDEF (QUOTE \FFDELTA2) (QUOTE RESOURCES) (QUOTE (NEW (ARRAY \MAX.PATTERN.SIZE (QUOTE BYTE)))))
+
+(PUTDEF (QUOTE \FFPATCHAR) (QUOTE RESOURCES) (QUOTE (NEW (ARRAY \MAX.PATTERN.SIZE (QUOTE BYTE)))))
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \MAX.PATTERN.SIZE 128)
+
+(RPAQQ \MIN.PATTERN.SIZE 3)
+
+(RPAQQ FILEPOS.SEGMENT.SIZE 32768)
+
+(RPAQQ \MIN.SEARCH.LENGTH 100)
+
+
+(CONSTANTS (\MAX.PATTERN.SIZE 128) (\MIN.PATTERN.SIZE 3) (FILEPOS.SEGMENT.SIZE 32768) (\MIN.SEARCH.LENGTH 100))
+)
+)
+
+(/SETTOPVAL (QUOTE \\FFDELTA1.GLOBALRESOURCE) NIL)
+
+(/SETTOPVAL (QUOTE \\FFDELTA2.GLOBALRESOURCE) NIL)
+
+(/SETTOPVAL (QUOTE \\FFPATCHAR.GLOBALRESOURCE) NIL)
+
+
+
+(* ;; "DATE Functions")
+
+(DEFINEQ
+
+(DATE
+(LAMBDA (FORMAT) (* raf "16-Oct-86 17:16") (\OUTDATE (\UNPACKDATE) FORMAT)))
+
+(DATEFORMAT
+(NLAMBDA FORMAT (* raf "16-Oct-86 17:17") (CONS (QUOTE DATEFORMAT) FORMAT)))
+
+(GDATE
+(LAMBDA (DATE FORMAT STRPTR) (* raf "16-Oct-86 17:17") (\OUTDATE (\UNPACKDATE DATE) FORMAT STRPTR)))
+
+(IDATE
+(LAMBDA (STR DEFAULTTIME) (* ; "Edited  4-May-89 18:22 by bvm") (if (NULL STR) then (DAYTIME) else (PROG ((*STR* (MKSTRING STR)) (*POS* 1) MONTH DAY YEAR HOUR MINUTES SECONDS N1 N2 CH DLS TIMEZONE) (DECLARE (LISP:SPECIAL *STR* *POS*)) TOP (OR (SETQ N1 (\IDATESCANTOKEN)) (RETURN NIL)) (SELCHARQ (NTHCHARCODE *STR* *POS*) ((/ - SPACE) (* ; "Okay to put inside date") (add *POS* 1)) ("," (if (LISTP N1) then (* ; "Assume str was something like Mon, Apr 1....  Trash the day.") (add *POS* 1) (GO TOP))) ("." (if (LISTP N1) then (* ; "Abbreviated month?") (add *POS* 1))) NIL) (OR (SETQ N2 (\IDATESCANTOKEN)) (RETURN NIL)) (SELCHARQ (NTHCHARCODE *STR* *POS*) ((/ - SPACE %,) (add *POS* 1)) ("." (if (LISTP N2) then (* ; "Abbreviated month?") (add *POS* 1))) NIL) (if (NOT (FIXP (SETQ YEAR (\IDATESCANTOKEN)))) then (RETURN NIL) elseif (< YEAR 100) then (* ; "default to this century") (add YEAR 1900) elseif (OR (< YEAR 1900) (> YEAR 2037)) then (* ; "out of range") (RETURN NIL)) (* ; "Now figure out day and month") (if (FIXP N2) then (* ; "Must be month-day") (SETQ DAY N2) (SETQ MONTH N1) elseif (FIXP (SETQ DAY N1)) then (* ; "day-month") (SETQ MONTH N2) else (RETURN NIL)) (if (FIXP MONTH) then (if (OR (< MONTH 1) (> MONTH 12)) then (* ; "invalid month") (RETURN NIL)) elseif (SETQ MONTH (\IDATE-PARSE-MONTH MONTH)) else (RETURN NIL)) (if (OR (< DAY 1) (> DAY (SELECTQ MONTH ((9 4 6 11) (* ; "30 days hath September...") 30) (2 (if (EVENP YEAR 4) then 29 else 28)) 31))) then (RETURN NIL)) (while (EQ (SETQ CH (NTHCHARCODE *STR* *POS*)) (CHARCODE SPACE)) do (* ; "Skip spaces") (add *POS* 1)) (SELCHARQ (NTHCHARCODE *STR* *POS*) ("," (* ; "Ok to terminate date with comma") (add *POS* 1)) (NIL (* ; "No time.  Ok if DEFAULTTIME passed in") (if (NULL DEFAULTTIME) then (RETURN NIL)) (SETQ SECONDS (IREMAINDER DEFAULTTIME 60)) (SETQ MINUTES (IREMAINDER (SETQ DEFAULTTIME (IQUOTIENT DEFAULTTIME 60)) 60)) (SETQ HOUR (IQUOTIENT DEFAULTTIME 60)) (GO DONE)) NIL) (* ;; "Now scan time") (if (NOT (FIXP (SETQ HOUR (\IDATESCANTOKEN)))) then (RETURN NIL)) (if (EQ (SETQ CH (NTHCHARCODE *STR* *POS*)) (CHARCODE %:)) then (* ; "hh:mm") (add *POS* 1) (OR (FIXP (SETQ MINUTES (\IDATESCANTOKEN))) (RETURN NIL)) (if (EQ (SETQ CH (NTHCHARCODE *STR* *POS*)) (CHARCODE %:)) then (* ; "hh:mm:ss") (add *POS* 1) (OR (FIXP (SETQ SECONDS (\IDATESCANTOKEN))) (RETURN NIL)) (SETQ CH (NTHCHARCODE *STR* *POS*))) else (* ; "break apart time given without colon") (SETQ MINUTES (IREMAINDER HOUR 100)) (SETQ HOUR (IQUOTIENT HOUR 100))) (if CH then (* ; "There's more") (while (EQ CH (CHARCODE SPACE)) do (* ; "Skip spaces") (SETQ CH (NTHCHARCODE *STR* (add *POS* 1)))) (if (AND (FMEMB CH (CHARCODE (A P a p))) (FMEMB (NTHCHARCODE *STR* (ADD1 *POS*)) (CHARCODE (M m))) (FMEMB (NTHCHARCODE *STR* (+ *POS* 2)) (CHARCODE (SPACE - NIL)))) then (* ; "AM or PM appended") (if (NOT (< HOUR 13)) then (* ; "bogus") (RETURN NIL)) (if (EQ HOUR 12) then (* ; "wrap to zero") (SETQ HOUR 0)) (if (FMEMB CH (CHARCODE (P p))) then (* ; "PM = 12 hours later") (add HOUR 12)) (SETQ CH (NTHCHARCODE *STR* (add *POS* 2))) (while (EQ CH (CHARCODE SPACE)) do (* ; "Skip spaces") (SETQ CH (NTHCHARCODE *STR* (add *POS* 1))))) (* ;; "Now check for time zone") (if (AND (EQ CH (CHARCODE -)) (ALPHACHARP (NTHCHARCODE *STR* (ADD1 *POS*)))) then (* ; "Some obsolete date forms gave time zone separated from time by hyphen") (SETQ CH (NTHCHARCODE *STR* (add *POS* 1)))) (SELCHARQ CH ((+ -) (* ; "Explicit offset +-hhmm from GMT") (add *POS* 1) (if (NOT (FIXP (SETQ TIMEZONE (\IDATESCANTOKEN)))) then (RETURN NIL)) (LISP:MULTIPLE-VALUE-BIND (H M) (LISP:TRUNCATE TIMEZONE 100) (SETQ TIMEZONE (if (EQ M 0) then H else (* ; "Non-hour timezone.  Use ratios.") (+ H (/ M 60))))) (if (EQ CH (CHARCODE +)) then (* ; "we represent time zones the other way around, so have to negate") (SETQ TIMEZONE (- TIMEZONE)))) (if (AND CH (ALPHACHARP CH)) then (* ; "Perhaps symbolic time zone") (PROG ((START *POS*)) LP (if (NULL (SETQ CH (NTHCHARCODE *STR* (add *POS* 1)))) elseif (ALPHACHARP CH) then (GO LP) elseif (EQ CH (CHARCODE SPACE)) then (* ; "Space may terminate, except that some time zones have space in middle, e.g., EET DST.") (if (AND (SETQ CH (NTHCHARCODE *STR* (ADD1 *POS*))) (ALPHACHARP CH)) then (add *POS* 1) (GO LP)) else (* ; "Non-alphabetic in timezone") (RETURN NIL)) (* ;; "Potential time zone from START to before POS") (SETQ TIMEZONE (SUBSTRING *STR* START (SUB1 *POS*))) (RETURN (SETQ TIMEZONE (for ZONE in TIME.ZONES bind DST do (if (STRING-EQUAL TIMEZONE (CADR ZONE)) then (RETURN (CAR ZONE)) elseif (AND (SETQ DST (CADDR ZONE)) (STRING-EQUAL TIMEZONE DST)) then (* ; "The daylight equivalent is off by one hour") (RETURN (SUB1 (CAR ZONE))))))))))) DONE (RETURN (AND (< HOUR 24) (< MINUTES 60) (OR (NOT SECONDS) (< SECONDS 60)) (\PACKDATE YEAR (SUB1 MONTH) DAY HOUR MINUTES (OR SECONDS 0) TIMEZONE))))))
+)
+
+(\IDATESCANTOKEN
+(LAMBDA NIL (* ; "Edited  4-May-89 15:20 by bvm") (DECLARE (LISP:SPECIAL *STR* *POS*)) (* ;; "Returns next token in STR, starting at POS.  Is either an integer or list of alphabetic charcodes.  Skips blanks") (PROG (RESULT CH) LP (SETQ CH (NTHCHARCODE *STR* *POS*)) (RETURN (COND ((NULL CH) NIL) ((EQ CH (CHARCODE SPACE)) (* ; "Skip leading spaces") (add *POS* 1) (GO LP)) ((DIGITCHARP CH) (SETQ RESULT (- CH (CHARCODE 0))) (while (AND (SETQ CH (NTHCHARCODE *STR* (add *POS* 1))) (DIGITCHARP CH)) do (SETQ RESULT (+ (- CH (CHARCODE 0)) (TIMES RESULT 10)))) RESULT) ((ALPHACHARP CH) (CONS (UCASECODE CH) (while (AND (SETQ CH (NTHCHARCODE *STR* (add *POS* 1))) (ALPHACHARP CH)) collect (UCASECODE CH))))))))
+)
+
+(\IDATE-PARSE-MONTH
+(LAMBDA (MONTH) (* ; "Edited  4-May-89 14:54 by bvm") (* ;; "MONTH is a list of upper case character codes.  Figure out which month (1-12) we mean.  We require that MONTH be at least 3 characters long and a prefix of month name") (* ;; "These ugly macros produce code, essentially a decision tree, that walks down the list of char codes looking for exactly the right ones.") (LISP:MACROLET ((DISCRIMINATE (FORMS) (* ;; "The entry -- start MINCHARS at 3 and turn the month names into char codes.  FORMS is quoted list to workaround masterscope stupidity") (BQUOTE (DISCRIMINATE-1 3 (\,@ (FOR F IN (CADR FORMS) COLLECT (CONS (CHCON (CAR F)) (CDR F))))))) (DISCRIMINATE-1 (MINCHARS &BODY FORMS) (IF (NULL (CDR FORMS)) THEN (* ; "only one case") (BQUOTE (COND ((DISCRIMINATE-2 (\, MINCHARS) (\, (CAAR FORMS))) (\,@ (CDAR FORMS))))) ELSE (* ; "Discriminate on the first code and recur on the tails") (LIST* (QUOTE CASE) (BQUOTE (CAR CODEVAR)) (WHILE FORMS BIND REST C COLLECT (SETQ REST (LISP:REMOVE (SETQ C (CAAAR FORMS)) FORMS :KEY (QUOTE CAAR))) (BQUOTE ((\, C) (SETQ CODEVAR (CDR CODEVAR)) (DISCRIMINATE-1 (\, (SUB1 MINCHARS)) (\,@ (FOR F IN (LISP:SET-DIFFERENCE FORMS (SETQ FORMS REST)) COLLECT (CONS (CDAR F) (CDR F))))))))))) (DISCRIMINATE-2 (MINCHARS MATCHLST) (* ;; "True if codes match MATCHLST, with prefix at least MINCHARS long.") (IF (NULL MATCHLST) THEN (BQUOTE (NULL CODEVAR)) ELSE (LET ((CODE (BQUOTE (AND (EQ (CAR CODEVAR) (\, (POP MATCHLST))) (PROGN (SETQ CODEVAR (CDR CODEVAR)) (DISCRIMINATE-2 (\, (SUB1 MINCHARS)) (\, MATCHLST))))))) (IF (<= MINCHARS 0) THEN (* ; "Ok to match null") (BQUOTE (OR (NULL CODEVAR) (\, CODE))) ELSE (* ; "Must match exactly so far") CODE))))) (LET ((CODEVAR MONTH)) (* ; "This LET is solely to allow more compact code (PVAR_ is one byte less than IVARX_)") (DISCRIMINATE (QUOTE (("JANUARY" 1) ("FEBRUARY" 2) ("MARCH" 3) ("APRIL" 4) ("MAY" 5) ("JUNE" 6) ("JULY" 7) ("AUGUST" 8) ("SEPTEMBER" 9) ("OCTOBER" 10) ("NOVEMBER" 11) ("DECEMBER" 12)))))))
+)
+
+(\OUTDATE
+(LAMBDA (UD FORMAT STRING) (* ; "Edited 30-May-89 12:28 by bvm") (DESTRUCTURING-BIND (YEAR MONTH DAY HOUR MINUTE SECOND DST WDAY) UD (LET ((SEPR (CHARCODE -)) (HOUR.LENGTH 2) SIZE S N NO.DATE NO.TIME NO.LEADING.SPACES TIME.ZONE TIME.ZONE.LENGTH YEAR.LENGTH MONTH.LENGTH DAY.LENGTH WDAY.LENGTH NO.SECONDS NUMBER.OF.MONTH MONTH.LONG MONTH.LEADING YEAR.LONG DAY.OF.WEEK DAY.SHORT CIVILIAN.TIME) (if (NOT FORMAT) then NIL elseif (NEQ (CAR (LISTP FORMAT)) (QUOTE DATEFORMAT)) then (LISPERROR "ILLEGAL ARG" FORMAT) else (for TOKEN in FORMAT do (SELECTQ TOKEN (NO.DATE (SETQ NO.DATE T)) (NO.TIME (SETQ NO.TIME T)) (NUMBER.OF.MONTH (SETQ NUMBER.OF.MONTH T)) (YEAR.LONG (SETQ YEAR.LONG T)) (MONTH.LONG (SETQ MONTH.LONG T)) (MONTH.LEADING (SETQ MONTH.LEADING T)) (SLASHES (SETQ SEPR (CHARCODE /))) (SPACES (SETQ SEPR (CHARCODE SPACE))) (NO.LEADING.SPACES (SETQ NO.LEADING.SPACES T)) (TIME.ZONE (SETQ TIME.ZONE (OR (LISTP (CDR (if (FIXP \TimeZoneComp) then (ASSOC \TimeZoneComp TIME.ZONES) else (* ; "Ugh, not a small integer") (LISP:ASSOC \TimeZoneComp TIME.ZONES :TEST (QUOTE =))))) \TimeZoneComp))) (NO.SECONDS (SETQ NO.SECONDS T)) (DAY.OF.WEEK (SETQ DAY.OF.WEEK T)) (DAY.SHORT (SETQ DAY.SHORT T)) (CIVILIAN.TIME (SETQ CIVILIAN.TIME T)) NIL))) (SETQ SIZE (+ (if NO.DATE then 0 else (+ (if MONTH.LEADING then (SETQ SEPR (CHARCODE SPACE)) (SETQ NUMBER.OF.MONTH NIL) (* ; "Will use a comma") 1 else 0) (SETQ MONTH.LENGTH (if NUMBER.OF.MONTH then (* ; "Month input is zero-based") (if (AND (< (add MONTH 1) 10) NO.LEADING.SPACES) then 1 else 2) else (SETQ MONTH (LISP:NTH MONTH (QUOTE ("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December")))) (if MONTH.LONG then (NCHARS MONTH) else 3))) (SETQ DAY.LENGTH (if (AND (OR NO.LEADING.SPACES MONTH.LEADING) (< DAY 10)) then 1 else 2)) (SETQ YEAR.LENGTH (if (OR YEAR.LONG (> YEAR 1999)) then 4 else (SETQ YEAR (IREMAINDER YEAR 100)) 2)) (if DAY.OF.WEEK then (SETQ DAY.OF.WEEK (LISP:NTH WDAY (QUOTE ("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")))) (+ 3 (SETQ WDAY.LENGTH (if DAY.SHORT then (* ; "3 letters plus %" ()%"") 3 else (NCHARS DAY.OF.WEEK)))) else 0) 2)) (if NO.TIME then 0 else (+ (if NO.DATE then 5 else 6) (if NO.SECONDS then 0 else 3) (if CIVILIAN.TIME then (* ; "Use AM/PM") (SETQ CIVILIAN.TIME (if (> HOUR 11) then (* ; "PM") (if (> HOUR 12) then (add HOUR -12)) (CHARCODE p) else (if (EQ HOUR 0) then (SETQ HOUR 12)) (CHARCODE a))) (if (AND (< HOUR 10) NO.LEADING.SPACES) then (SETQ HOUR.LENGTH 1) else 2) else 0) (if (NULL TIME.ZONE) then 0 elseif (NUMBERP TIME.ZONE) then (* ; "Use the -0800 format") 6 else (* ; "Depends on dst: (normal dst).  If missing, we are forced to use numeric format") (SETQ TIME.ZONE (OR (if DST then (CADR TIME.ZONE) else (CAR TIME.ZONE)) \TimeZoneComp)) (ADD1 (SETQ TIME.ZONE.LENGTH (NCHARS TIME.ZONE)))))))) (SETQ S (ALLOCSTRING SIZE (CHARCODE SPACE))) (if (NOT NO.DATE) then (if MONTH.LEADING then (* ; "Month day, year") (RPLSTRING S 1 MONTH) (SETQ N MONTH.LENGTH) (RPLCHARCODE S (add N 1) SEPR) (\RPLRIGHT S (add N (if (< DAY 10) then 1 else 2)) DAY 1) (RPLCHARCODE S (add N 1) (CHARCODE ",")) else (* ; "Day<sepr>month<sepr>year") (\RPLRIGHT S (SETQ N DAY.LENGTH) DAY 1) (RPLCHARCODE S (add N 1) SEPR) (if NUMBER.OF.MONTH then (\RPLRIGHT S (add N MONTH.LENGTH) MONTH MONTH.LENGTH) else (\OUTDATE-STRING S N MONTH (NOT MONTH.LONG)) (add N MONTH.LENGTH))) (RPLCHARCODE S (add N 1) SEPR) (\RPLRIGHT S (add N YEAR.LENGTH) YEAR 2) (OR NO.TIME (add N 1)) (if DAY.OF.WEEK then (* ; "Day of week at very end in parens") (LET ((START (SUB1 (- SIZE WDAY.LENGTH)))) (RPLCHARCODE S START (CHARCODE "(")) (\OUTDATE-STRING S START DAY.OF.WEEK DAY.SHORT) (RPLCHARCODE S SIZE (CHARCODE ")")))) else (SETQ N 0)) (if (NOT NO.TIME) then (\RPLRIGHT S (add N HOUR.LENGTH) HOUR (if CIVILIAN.TIME then 1 else 2)) (RPLCHARCODE S (ADD1 N) (CHARCODE %:)) (\RPLRIGHT S (add N 3) MINUTE 2) (if (NOT NO.SECONDS) then (RPLCHARCODE S (ADD1 N) (CHARCODE %:)) (\RPLRIGHT S (add N 3) SECOND 2)) (if CIVILIAN.TIME then (RPLCHARCODE S (ADD1 N) CIVILIAN.TIME) (RPLCHARCODE S (add N 2) (CHARCODE m))) (if TIME.ZONE then (if (NUMBERP TIME.ZONE) then (* ; "+0800 etc") (if DST then (* ; "Daylight savings is in effect, so time zone is off by an hour") (SETQ TIME.ZONE (SUB1 TIME.ZONE))) (RPLCHARCODE S (+ N 2) (if (<= TIME.ZONE 0) then (* ; "East of GMT, which is denoted + in this notation") (SETQ TIME.ZONE (- TIME.ZONE)) (CHARCODE +) else (CHARCODE -))) (if (FIXP TIME.ZONE) then (* ; "integral number of hours") (\RPLRIGHT S (+ N 4) TIME.ZONE 2) (RPLSTRING S (+ N 5) "00") else (LISP:MULTIPLE-VALUE-BIND (H M) (LISP:TRUNCATE TIME.ZONE) (\RPLRIGHT S (+ N 4) H 2) (\RPLRIGHT S (+ N 6) (ROUND (TIMES M 60)) 2))) else (RPLSTRING S (+ N 2) TIME.ZONE)))) (if STRING then (SUBSTRING S 1 -1 STRING) else S))))
+)
+
+(\OUTDATE-STRING
+(LAMBDA (S N STRING SHORTP) (* ; "Edited 18-May-89 18:38 by bvm") (* ;; "Append STRING to S, using only the first 3 chars if SHORTP is true.  N is the index of the last char appended to S.  Returns new N") (if SHORTP then (* ; "Use only first 3 chars") (for I from 1 to 3 do (RPLCHARCODE S (+ N I) (NTHCHARCODE STRING I))) else (RPLSTRING S (ADD1 N) STRING)))
+)
+
+(\RPLRIGHT
+(LAMBDA (S AT N MINDIGITS) (* bvm%: "21-NOV-83 17:19") (RPLCHARCODE S AT (IPLUS (CHARCODE 0) (IREMAINDER N 10))) (COND ((OR (IGREATERP MINDIGITS 1) (IGEQ N 10)) (\RPLRIGHT S (SUB1 AT) (IQUOTIENT N 10) (SUB1 MINDIGITS)))))
+)
+
+(\UNPACKDATE
+(LAMBDA (D) (* ; "Edited  4-May-89 18:18 by bvm") (* ;; "Converts an internal Lisp date D into a list of integers (Year Month Day Hours Minutes Seconds daylightp DayOfWeek).  D defaults to current date.  --- DayOfWeek is zero for Monday --- --- D is first converted to the alto standard, a 32-bit unsigned integer, representing the number of seconds since jan 1, 1901-Gmt.  We have to be a little tricky in our computations to avoid the sign bit.") (SETQ D (OR D (DAYTIME))) (PROG ((CHECKDLS \DayLightSavings) (DQ (IQUOTIENT (LRSH (LISP.TO.ALTO.DATE D) 1) 30)) MONTH SEC HR DAY4 YDAY WDAY YEAR4 TOTALDAYS MIN DLS FRAC) (* ; "DQ is number of minutes since day 0, getting us past the sign bit problem.") (SETQ SEC (IMOD (+ D (CONSTANT (- 60 (IMOD MIN.FIXP 60)))) 60)) (SETQ MIN (IREMAINDER DQ 60)) (* ;; "Now we can adjust to the current time zone.  Since this might cause DQ to go negative, first add in 4 years worth of hours, making the base date be Jan 1, 1897") (LET ((ZONE \TimeZoneComp)) (if (NOT (FIXP ZONE)) then (* ; "Gack, a non-hour offset.  Use the integer here, then adjust the minutes, etc.") (LISP:MULTIPLE-VALUE-SETQ (ZONE FRAC) (LISP:FLOOR ZONE))) (SETQ HR (IREMAINDER (SETQ DQ (- (+ (IQUOTIENT DQ 60) (CONSTANT (ITIMES 24 \4YearsDays))) ZONE)) 24)) (if FRAC then (SETQ FRAC (ROUND (TIMES FRAC -60))) (* ; "Minutes to add (time zones are never below the minute offset)") (LISP:MULTIPLE-VALUE-SETQ (FRAC MIN) (LISP:FLOOR (+ MIN FRAC) 60)) (if (NEQ FRAC 0) then (* ; "Adjust the hours") (LISP:MULTIPLE-VALUE-SETQ (FRAC HR) (LISP:FLOOR (+ HR FRAC) 24))))) (SETQ TOTALDAYS (IQUOTIENT DQ 24)) (if FRAC then (* ; "For non-integral time zones, here's the last of the leftover.") (add TOTALDAYS FRAC)) DTLOOP (SETQ DAY4 (IREMAINDER TOTALDAYS \4YearsDays)) (* ; "DAY4 = number of days since last leap year day 0") (SETQ DAY4 (+ DAY4 (CDR (\DTSCAN DAY4 (QUOTE ((789 . 3) (424 . 2) (59 . 1) (0 . 0))))))) (* ; "pretend every year is a leap year, adding one for days after Feb 28") (SETQ YEAR4 (IQUOTIENT TOTALDAYS \4YearsDays)) (* ; "YEAR4 = number of years til that last leap year / 4") (SETQ YDAY (IREMAINDER DAY4 366)) (* ; "YDAY is the ordinal day in the year (jan 1 = zero)") (SETQ WDAY (IREMAINDER (+ TOTALDAYS 3) 7)) (if (AND CHECKDLS (SETQ DLS (\ISDST? YDAY HR WDAY))) then (* ;; "This date is during daylight savings, so add 1 hour.  Third arg is day of the week, which we determine by taking days mod 7 plus offset.  Monday = zero in this scheme.  Jan 1 1897 was actually a Friday (not Thursday=3), but we're cheating--1900 was not a leap year") (if (> (SETQ HR (ADD1 HR)) 23) then (* ;; "overflowed into the next day.  This case is too hard (we might have overflowed the month, for example), so just go back and recompute") (SETQ TOTALDAYS (ADD1 TOTALDAYS)) (SETQ HR 0) (SETQ CHECKDLS NIL) (GO DTLOOP))) (SETQ MONTH (\DTSCAN YDAY (QUOTE ((335 . 11) (305 . 10) (274 . 9) (244 . 8) (213 . 7) (182 . 6) (152 . 5) (121 . 4) (91 . 3) (60 . 2) (31 . 1) (0 . 0))))) (* ; "Now return year, month, day, hr, min, sec") (RETURN (LIST (+ 1897 (ITIMES YEAR4 4) (IQUOTIENT DAY4 366)) (CDR MONTH) (ADD1 (- YDAY (CAR MONTH))) HR MIN SEC DLS WDAY))))
+)
+
+(\PACKDATE
+(LAMBDA (YR MONTH DAY HR MIN SEC TIMEZONE) (* ; "Edited 22-Mar-88 05:33 by jds") (* ;; "Packs indicated date into a single integer in Lisp date format.  Returns NIL on errors.") (PROG (YDAY DAYSSINCEDAY0) (COND ((NOT (AND YR MONTH DAY HR MIN SEC)) (* ; "Values missing") (RETURN))) (SETQ DAYSSINCEDAY0 (+ (SETQ YDAY (+ (SELECTQ MONTH (0 0) (1 31) (2 59) (3 90) (4 120) (5 151) (6 181) (7 212) (8 243) (9 273) (10 304) (11 334) NIL) (SUB1 DAY))) (TIMES 365 (SETQ YR (- YR 1901))) (IQUOTIENT YR 4))) (COND ((> MONTH 1) (* ; "After February 28") (add YDAY 1) (* ; "Day-of-year for dst is based on 366-day year") (COND ((AND (EQ 3 (IREMAINDER YR 4)) (NEQ YR -1)) (* ; "It is a leap year, so real day count also incremented.  Note that YR is years since 1901 at this point") (add DAYSSINCEDAY0 1))))) (COND ((OR (< DAYSSINCEDAY0 -1) (< (add HR (TIMES 24 DAYSSINCEDAY0) (COND (TIMEZONE) ((AND \DayLightSavings (\ISDST? YDAY HR (IREMAINDER (+ DAYSSINCEDAY0 1) 7))) (* ;; "Subtract one to go from daylight to standard time.  This time we computed weekday based on day 0 = Jan 1, 1901, which was a Tuesday = 1") (SUB1 \TimeZoneComp)) (T \TimeZoneComp))) 0)) (* ;; "Earlier than day 0 -- second check is needed because day 0 west of GMT is sometime during Dec 31, 1900") (RETURN))) (RETURN (+ SEC (PROGN (* ;; "Add the seconds to the converted date, rather than the raw one, and use LLSH instead of multiplying by 60, to avoid creating a bignum") (ALTO.TO.LISP.DATE (LLSH (TIMES 30 (+ MIN (TIMES 60 HR))) 1)))))))
+)
+
+(\DTSCAN
+(LAMBDA (X L) (* lmm%: 22 NOV 75 1438) (PROG NIL LP (COND ((IGREATERP (CAAR L) X) (SETQ L (CDR L)) (GO LP))) (RETURN (CAR L))))
+)
+
+(\ISDST?
+(LAMBDA (YDAY HOUR WDAY) (* ; "Edited 27-Oct-87 18:51 by bvm:") (* ;; "Returns true if YDAY, HOUR is during the daylight savings period.  WDAY is day of week, zero = Monday.  YDAY is the ordinal day of the year, pretending it is a leap year, with zero = Jan 1.") (* ;; "Unfortunately, \BeginDST and \EndDST are 1-based and so documented, so we have to convert to zero base inside here.") (AND (\CHECKDSTCHANGE (add YDAY 1) HOUR WDAY \BeginDST) (NOT (\CHECKDSTCHANGE YDAY HOUR WDAY \EndDST))))
+)
+
+(\CHECKDSTCHANGE
+(LAMBDA (YDAY HOUR WDAY DSTDAY) (* bvm%: " 2-NOV-80 15:34") (* ;; "Tests to see if YDAY, HOUR is after the start of daylight (or standard) time.  WDAY is the day of the week, Monday=zero.  DSTDAY is the last day of the month in which time changes, as a YDAY, usually Apr 30 or Oct 31") (COND ((IGREATERP YDAY DSTDAY) (* ; "Day is in the next month already") T) ((ILESSP YDAY (IDIFFERENCE DSTDAY 6)) (* ; "day is at least a week before end of month, so time hasn't changed yet") NIL) ((EQ WDAY 6) (* ;; "It's Sunday, so time changes today at 2am.  Check for hour being past that.  Note that there is a hopeless ambiguity when the time is between 1:00 and 2:00 am the day that DST goes into effect, as that hour happens twice") (IGREATERP HOUR 1)) (T (* ; "okay if last Monday (YDAY-WDAY) is less than a week before end of month") (IGREATERP (IDIFFERENCE YDAY WDAY) (IDIFFERENCE DSTDAY 6)))))
+)
+)
+
+(DEFOPTIMIZER DATEFORMAT (&REST X) (KWOTE (CONS (QUOTE DATEFORMAT) X)))
+
+
+
+(* ;; 
+"Because DST begins the FIRST weekend in April now, \BeginDST changed from 120 to 98 as of 4/3/87 (JDS)  Note: this only affects standalone users--those with time servers automatically get correct local info (bvm)"
+)
+
+
+(RPAQ? \TimeZoneComp 8)
+
+(RPAQ? \BeginDST 98)
+
+(RPAQ? \EndDST 304)
+
+(RPAQ? \DayLightSavings T)
+
+(ADDTOVAR TIME.ZONES (8 "PST" "PDT") (7 "MST" "MDT") (6 "CST" "CDT") (5 "EST" "EDT") (0 "GMT" "BST") (0 "UT") (-1 "MET" "MET DST") (-2 "EET" "EET DST"))
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \TimeZoneComp \BeginDST \EndDST \DayLightSavings TIME.ZONES)
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQ \4YearsDays (ADD1 (ITIMES 365 4)))
+
+
+(CONSTANTS (\4YearsDays (ADD1 (ITIMES 365 4))))
+)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+
+(PUTPROPS IOCHAR FILETYPE CL:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA DATEFORMAT)
+
+(ADDTOVAR NLAML)
+
+(ADDTOVAR LAMA PACK* CONCAT)
+)
+(PUTPROPS IOCHAR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 
+1991))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (2531 6325 (CHCON 2541 . 3391) (UNPACK 3393 . 4287) (DCHCON 4289 . 5556) (DUNPACK 5558
+ . 6323)) (6326 15655 (UALPHORDER 6336 . 6432) (ALPHORDER 6434 . 8237) (CONCAT 8239 . 8884) (
+CONCATCODES 8886 . 9072) (PACKC 9074 . 9483) (PACK 9485 . 10064) (PACK* 10066 . 11796) (\PACK.ITEM 
+11798 . 12253) (STRPOS 12255 . 15653)) (16513 18607 (STRPOSL 16523 . 18149) (MAKEBITTABLE 18151 . 
+18605)) (18806 19972 (CASEARRAY 18816 . 19006) (UPPERCASEARRAY 19008 . 19281) (LOWERCASEARRAY 19283 . 
+19561) (FLIPCASEARRAY 19563 . 19970)) (20384 33451 (FILEPOS 20394 . 25407) (FFILEPOS 25409 . 30886) (
+\SETUP.FFILEPOS 30888 . 33449)) (34270 53930 (DATE 34280 . 34366) (DATEFORMAT 34368 . 34460) (GDATE 
+34462 . 34573) (IDATE 34575 . 39447) (\IDATESCANTOKEN 39449 . 40177) (\IDATE-PARSE-MONTH 40179 . 42195
+) (\OUTDATE 42197 . 47044) (\OUTDATE-STRING 47046 . 47428) (\RPLRIGHT 47430 . 47668) (\UNPACKDATE 
+47670 . 50838) (\PACKDATE 50840 . 52360) (\DTSCAN 52362 . 52504) (\ISDST? 52506 . 53013) (
+\CHECKDSTCHANGE 53015 . 53928)))))
+STOP
diff --git a/CLTL2/IOCHAR.LCOM b/CLTL2/IOCHAR.LCOM
new file mode 100644
index 00000000..9ea9d649
Binary files /dev/null and b/CLTL2/IOCHAR.LCOM differ
diff --git a/CLTL2/LISP-PACKAGE b/CLTL2/LISP-PACKAGE
new file mode 100644
index 00000000..5ecda9c9
--- /dev/null
+++ b/CLTL2/LISP-PACKAGE
@@ -0,0 +1,49 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "LISP")
+(IL:FILECREATED "16-May-90 18:44:49" IL:{DSK}<usr>local>lde>lispcore>sources>LISP-PACKAGE.;2 1900   
+
+      IL:changes IL:to%:  (IL:VARS IL:LISP-PACKAGECOMS)
+
+      IL:previous IL:date%: "20-Mar-87 12:50:03" IL:{DSK}<usr>local>lde>lispcore>sources>LISP-PACKAGE.;1
+)
+
+
+(IL:* ; "
+Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(IL:PRETTYCOMPRINT IL:LISP-PACKAGECOMS)
+
+(IL:RPAQQ IL:LISP-PACKAGECOMS
+          (
+
+(IL:* IL:;;; "This file should eventually contain the entire external description of the LISP package, which is currently in package-startup.  It exports a few fixup and non-critical symbols right now.")
+
+           (IL:P (XCL:DEFPACKAGE "LISP" (:USE)
+                        (:EXPORT SIGNED-BYTE UNSIGNED-BYTE LAMBDA VARIABLE STRUCTURE SPEED SPACE 
+                               SAFETY COMPILATION-SPEED)))
+           
+           (IL:* IL:;; "Arrange for the proper makefile environment")
+
+           (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:LISP-PACKAGE)))
+
+
+
+(IL:* IL:;;; 
+"This file should eventually contain the entire external description of the LISP package, which is currently in package-startup.  It exports a few fixup and non-critical symbols right now."
+)
+
+
+(XCL:DEFPACKAGE "LISP" (:USE)
+       (:EXPORT SIGNED-BYTE UNSIGNED-BYTE LAMBDA VARIABLE STRUCTURE SPEED SPACE SAFETY 
+              COMPILATION-SPEED))
+
+
+
+(IL:* IL:;; "Arrange for the proper makefile environment")
+
+
+(IL:PUTPROPS IL:LISP-PACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "LISP"))
+(IL:PUTPROPS IL:LISP-PACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990))
+(IL:DECLARE%: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/LISP-PACKAGE.LCOM b/CLTL2/LISP-PACKAGE.LCOM
new file mode 100644
index 00000000..b13b963a
--- /dev/null
+++ b/CLTL2/LISP-PACKAGE.LCOM
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "LISP")
(IL:FILECREATED " 4-Nov-93 17:19:42" ("compiled on " 
IL:{DSK}<king>export>lispcore>sources>CLTL2>LISP-PACKAGE.;1) "19-Feb-93 17:03:08" IL:bcompl'd IL:in 
"Medley 19-Feb-93 ..." IL:dated "19-Feb-93 18:20:42")
(IL:FILECREATED "16-May-90 18:44:49" IL:{DSK}<usr>local>lde>lispcore>sources>LISP-PACKAGE.;2 1900 
IL:changes IL:to%: (IL:VARS IL:LISP-PACKAGECOMS) IL:previous IL:date%: "20-Mar-87 12:50:03" 
IL:{DSK}<usr>local>lde>lispcore>sources>LISP-PACKAGE.;1)
(IL:PRETTYCOMPRINT IL:LISP-PACKAGECOMS)
(IL:RPAQQ IL:LISP-PACKAGECOMS ((IL:* IL:;;; 
"This file should eventually contain the entire external description of the LISP package, which is currently in package-startup.  It exports a few fixup and non-critical symbols right now."
) (IL:P (XCL:DEFPACKAGE "LISP" (:USE) (:EXPORT SIGNED-BYTE UNSIGNED-BYTE LAMBDA VARIABLE STRUCTURE 
SPEED SPACE SAFETY COMPILATION-SPEED))) (IL:* IL:;; "Arrange for the proper makefile environment") (
IL:PROP IL:MAKEFILE-ENVIRONMENT IL:LISP-PACKAGE)))
(XCL:DEFPACKAGE "LISP" (:USE) (:EXPORT SIGNED-BYTE UNSIGNED-BYTE LAMBDA VARIABLE STRUCTURE SPEED SPACE
 SAFETY COMPILATION-SPEED))
(IL:PUTPROPS IL:LISP-PACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "LISP"))
(IL:PUTPROPS IL:LISP-PACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990))
IL:NIL
\ No newline at end of file
diff --git a/CLTL2/LLARITH b/CLTL2/LLARITH
new file mode 100644
index 00000000..e1dfcf91
--- /dev/null
+++ b/CLTL2/LLARITH
@@ -0,0 +1,1843 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+(FILECREATED "18-Oct-93 15:42:46" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLARITH.;2" 74822  
+
+      |previous| |date:| " 3-Sep-91 17:57:33" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLARITH.;1")
+
+
+; Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+; The following program was created in 1982 but has not been published
+; within the meaning of the copyright law, is furnished under license,
+; and may not be used, copied and/or disclosed except in accordance
+; with the terms of said license.
+
+(PRETTYCOMPRINT LLARITHCOMS)
+
+(RPAQQ LLARITHCOMS
+       ((COMS                                                (* \; "OPCODES")
+              (FNS IDIFFERENCE IGREATERP IQUOTIENT)
+              
+              (* |;;| 
+            "\\slowplus2 \\slowdifference \\slowtimes2 \\slowquotient are redefined in cmlarith")
+
+              (FNS \\SLOWIPLUS2 \\SLOWPLUS2 \\SLOWIDIFFERENCE \\SLOWDIFFERENCE \\SLOWIGREATERP 
+                   \\SLOWLLSH1 \\SLOWLLSH8 \\SLOWLOGAND2 \\SLOWLOGOR2 \\SLOWLOGXOR2 \\SLOWLRSH1 
+                   \\SLOWLRSH8 \\SLOWITIMES2 \\SLOWTIMES2 \\SLOWIQUOTIENT \\SLOWQUOTIENT))
+        (COMS                                                (* \; 
+                                     "IPLUS and IDIFFERENCE that smash result into their first arg")
+              (FNS \\BOXIPLUS \\BOXIDIFFERENCE))
+                                                             (* \; "subfunctions")
+        (FNS \\MAKENUMBER)
+        (FNS OVERFLOW)
+        (INITVARS (\\OVERFLOW T))
+        (CONSTANTS (MAX.SMALLP 65535)
+               (MIN.SMALLP -65536)
+               (MAX.FIXP 2147483647)
+               (MIN.FIXP -2147483648)
+               (\\SIGNBIT 32768))
+        (FNS \\GETBASEFIXP \\PUTBASEFIXP \\PUTBASEFIXP.UFN)
+        (EXPORT (DECLARE\: DONTCOPY (RECORDS FIXP)
+                       (CONSTANTS (MAX.SMALL.INTEGER 65535)
+                              (MAX.POS.HINUM 32767))
+                       
+                       (* |;;| "Unbox changed to handle ratios")
+
+                       (MACROS .UNBOX. .NEGATE. .LLSH1. .LRSH1. .BOXIPLUS.)))
+        (DECLARE\: DONTCOPY (MACROS OLD.UNBOX.))
+        
+        (* |;;| "Eqp modified to be like =")
+
+        (FNS EQP FIX IQUOTIENT IREMAINDER LLSH LRSH LSH RSH \\RSH)
+        (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS NBITS.OR.LESS .SUBSMALL. \\IQUOTREM))
+                                                             (* \; 
+                                                         "Machine independent arithmetic functions")
+        
+        (* |;;| "MINUSP redefined in cmlarith ")
+
+        (FNS MINUSP ILESSP IMINUS IPLUS ITIMES LOGAND LOGOR LOGXOR SUB1 ZEROP ADD1 GCD IEQP 
+             INTEGERLENGTH)
+        
+        (* |;;| "abs, difference, greaterp, plus, lessp, and times  redefined in cmlarith. ")
+
+        
+        (* |;;| "quotient and minus modified to handle ratios")
+
+        
+        (* |;;| "remainder remains as is")
+
+        (FNS ABS DIFFERENCE GREATERP PLUS QUOTIENT REMAINDER LESSP MINUS TIMES)
+        (FNS FMINUS FREMAINDER)
+        (FNS RANDSET RAND EXPT)
+        (DECLARE\: DONTEVAL@LOAD DOCOPY (VARS (RANDSTATE)
+                                              (\\TOL 9.9999925E-6)))
+        (GLOBALVARS RANDSTATE \\TOL)
+        (COMS (FNS |PutUnboxed| \\PUTFIXP \\PUTSWAPPEDFIXP \\HINUM \\LONUM)
+              (EXPORT (DECLARE\: DONTCOPY (MACROS |PutUnboxed|))))
+        (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML)
+                      (LAMA MIN MAX IMIN IMAX FMIN FMAX ODDP TIMES PLUS LOGXOR LOGOR LOGAND ITIMES 
+                            IPLUS)))
+        
+        (* |;;| "ODDP redefined in cmlarith")
+
+        (COMS (FNS POWEROFTWOP IMOD ODDP)
+              (DECLARE\: DONTCOPY (MACROS .2^NP.)))
+        (COMS                                                (* \; "MIN and MAX")
+              (FNS FLESSP FMAX FMIN GEQ IGEQ ILEQ IMAX IMIN LEQ MAX MIN)
+              (DECLARE\: EVAL@COMPILE (ADDVARS (GLOBALVARS MAX.INTEGER MIN.INTEGER MAX.FLOAT 
+                                                      MIN.FLOAT))))
+        (DECLARE\: DONTCOPY DOEVAL@COMPILE DONTEVAL@LOAD (LOCALVARS . T))))
+
+
+
+(* \; "OPCODES")
+
+(DEFINEQ
+
+(IDIFFERENCE
+  (LAMBDA (X Y)                                              (* |lmm| "11-FEB-82 14:02")
+    ((OPCODES IDIFFERENCE)
+     X Y)))
+
+(IGREATERP
+  (LAMBDA (X Y)                                              (* |lmm| "11-FEB-82 14:02")
+    ((OPCODES IGREATERP)
+     X Y)))
+
+(IQUOTIENT
+  (LAMBDA (X Y)                                              (* |lmm| "11-FEB-82 14:02")
+    ((OPCODES IQUOTIENT)
+     X Y)))
+)
+
+
+
+(* |;;| "\\slowplus2 \\slowdifference \\slowtimes2 \\slowquotient are redefined in cmlarith")
+
+(DEFINEQ
+
+(\\SLOWIPLUS2
+  (LAMBDA (X Y)                                              (* \; "Edited  8-Apr-87 11:23 by jop")
+    (\\CALLME 'IPLUS)
+    (PROG (HX LX HY LY SIGNX)
+          (.UNBOX. X HX LX (GO RETBIG))
+          (.UNBOX. Y HY LY (GO RETBIG))
+          (SETQ SIGNX (IGREATERP HX MAX.POS.HINUM))
+          (SETQ HX (COND
+                      ((IGREATERP HX (IDIFFERENCE MAX.SMALL.INTEGER HY))
+                       (IDIFFERENCE HX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY))))
+                      (T (IPLUS HX HY))))                (* \; "Add high parts")
+          (SETQ LX (COND
+                      ((IGREATERP LX (IDIFFERENCE MAX.SMALL.INTEGER LY))
+                                                             (* \; "Carry into high part.")
+                       (SETQ HX (COND
+                                   ((EQ HX MAX.SMALL.INTEGER)
+                                    0)
+                                   (T (ADD1 HX))))
+                       (IDIFFERENCE LX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY))))
+                      (T (IPLUS LX LY))))
+          (COND
+             ((AND (EQ SIGNX (IGREATERP HY MAX.POS.HINUM))
+                   (NEQ SIGNX (IGREATERP HX MAX.POS.HINUM)))
+                                                             (* \; 
+                            "overflow occurs if X and Y are same sign, but result is opposite sign")
+              (GO RETBIG)))
+          (RETURN (\\MAKENUMBER HX LX))
+      RETBIG
+          (RETURN (\\BIGNUM.PLUS X Y)))))
+
+(\\SLOWPLUS2
+  (LAMBDA (X Y)                                              (* \; "Edited  8-Apr-87 11:24 by jop")
+
+    (* |;;| "UFN for PLUS Microcode generally handles the case of two args both FIXPs")
+
+    (\\CALLME 'PLUS)
+    (PROG NIL
+      LP  (RETURN (COND
+                     ((OR (FLOATP X)
+                          (FLOATP Y))
+                      (FPLUS X Y))
+                     ((NOT (FIXP X))
+                      (SETQ X (LISPERROR "NON-NUMERIC ARG" X T))
+                      (GO LP))
+                     ((NOT (FIXP Y))
+                      (SETQ Y (LISPERROR "NON-NUMERIC ARG" Y T))
+                      (GO LP))
+                     (T (IPLUS X Y)))))))
+
+(\\SLOWIDIFFERENCE
+  (LAMBDA (X Y)                                              (* \; "Edited  8-Apr-87 11:24 by jop")
+    (\\CALLME 'IDIFFERENCE)
+    (PROG (HX LX HY LY SIGNX)
+          (.UNBOX. X HX LX (GO RETBIG))
+          (.UNBOX. Y HY LY (GO RETBIG))
+
+     (* |;;| 
+   "Allow this unboxing before the following test so that error checking will be performed on Y")
+
+          (COND
+             ((EQ Y 0)
+              (RETURN (\\MAKENUMBER HX LX))))
+          (.NEGATE. HY LY)
+          (SETQ SIGNX (IGREATERP HX MAX.POS.HINUM))
+          (COND
+             ((COND
+                 ((AND (ZEROP LY)
+                       (EQ HY \\SIGNBIT))                    (* \; 
+                                          "Y = -Y = Min.integer.  Overflow occurs if X is positive")
+                  (SETQ HX (LOGXOR HX HY))
+                  (NOT SIGNX))
+                 (T (SETQ HX (COND
+                                ((IGREATERP HX (IDIFFERENCE MAX.SMALL.INTEGER HY))
+                                 (IDIFFERENCE HX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY)
+                                                            )))
+                                (T (IPLUS HX HY))))      (* \; "Add high parts")
+                    (SETQ LX (COND
+                                ((IGREATERP LX (IDIFFERENCE MAX.SMALL.INTEGER LY))
+                                                             (* \; "Carry into high part.")
+                                 (SETQ HX (COND
+                                             ((EQ HX MAX.SMALL.INTEGER)
+                                              0)
+                                             (T (ADD1 HX))))
+                                 (IDIFFERENCE LX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY)
+                                                            )))
+                                (T (IPLUS LX LY))))      (* \; 
+                            "overflow occurs if X and Y are same sign, but result is opposite sign")
+                    (AND (EQ SIGNX (IGREATERP HY MAX.POS.HINUM))
+                         (NEQ SIGNX (IGREATERP HX MAX.POS.HINUM)))))
+              (GO RETBIG)))
+          (RETURN (\\MAKENUMBER HX LX))
+      RETBIG
+          (RETURN (\\BIGNUM.DIFFERENCE X Y)))))
+
+(\\SLOWDIFFERENCE
+  (LAMBDA (X Y)                                              (* \; "Edited  8-Apr-87 11:24 by jop")
+
+    (* |;;| "UFN for DIFFERENCE Microcode generally handles the case of two args both FIXPs")
+
+    (\\CALLME 'DIFFERENCE)
+    (PROG NIL
+      LP  (RETURN (COND
+                     ((OR (FLOATP X)
+                          (FLOATP Y))
+                      (FDIFFERENCE X Y))
+                     ((NOT (FIXP X))
+                      (SETQ X (LISPERROR "NON-NUMERIC ARG" X T))
+                      (GO LP))
+                     ((NOT (FIXP Y))
+                      (SETQ Y (LISPERROR "NON-NUMERIC ARG" Y T))
+                      (GO LP))
+                     (T (IDIFFERENCE X Y)))))))
+
+(\\SLOWIGREATERP
+  (LAMBDA (X Y)                                              (* |lmm| "12-Apr-85 07:35")
+    (\\CALLME 'IGREATERP)
+    (PROG (HX LX HY LY)
+          (.UNBOX. X HX LX (GO RETBIG))
+          (.UNBOX. Y HY LY (GO RETBIG))
+          (RETURN (COND
+                     ((EQ HX HY)
+                      (IGREATERP LX LY))
+                     (T (IGREATERP (LOGXOR HX \\SIGNBIT)
+                               (LOGXOR HY \\SIGNBIT)))))
+      RETBIG
+          (RETURN (EQ 1 (\\BIGNUM.COMPARE X Y))))))
+
+(\\SLOWLLSH1
+  (LAMBDA (X)                                                (* |lmm| "13-OCT-82 15:27")
+    (PROG (LO HI)
+          (.UNBOX. X HI LO)
+          (RETURN (\\MAKENUMBER (IPLUS (LLSH (LOGAND HI 32767)
+                                                      1)
+                                           (COND
+                                              ((IGREATERP LO 32767)
+                                               1)
+                                              (T 0)))
+                         (LLSH (LOGAND LO 32767)
+                                1))))))
+
+(\\SLOWLLSH8
+  (LAMBDA (X)                                                (* |lmm| "13-OCT-82 15:28")
+    (PROG (HI LO)
+          (.UNBOX. X HI LO)
+          (RETURN (\\MAKENUMBER (IPLUS (LLSH (LOGAND HI 255)
+                                                      8)
+                                           (LRSH LO 8))
+                         (LLSH (LOGAND LO 255)
+                                8))))))
+
+(\\SLOWLOGAND2
+  (LAMBDA (X Y)                                              (* |lmm| "12-Apr-85 07:44")
+    (\\CALLME 'LOGAND)
+    (PROG (XH XL YH YL)
+          (.UNBOX. X XH XL (GO RETBIG))
+          (.UNBOX. Y YH YL (GO RETBIG))
+          (RETURN (\\MAKENUMBER (LOGAND XH YH)
+                         (LOGAND XL YL)))
+      RETBIG
+          (RETURN (\\BIGNUM.LOGAND X Y)))))
+
+(\\SLOWLOGOR2
+  (LAMBDA (X Y)                                              (* |lmm| "12-Apr-85 07:48")
+    (\\CALLME 'LOGOR)
+    (PROG (XH XL YH YL)
+          (.UNBOX. X XH XL (GO RETBIG))
+          (.UNBOX. Y YH YL (GO RETBIG))
+          (RETURN (\\MAKENUMBER (LOGOR XH YH)
+                         (LOGOR XL YL)))
+      RETBIG
+          (RETURN (\\BIGNUM.LOGOR X Y)))))
+
+(\\SLOWLOGXOR2
+  (LAMBDA (X Y)                                              (* |lmm| "12-Apr-85 07:51")
+    (\\CALLME 'LOGXOR)
+    (PROG (XH XL YH YL)
+          (.UNBOX. X XH XL (GO RETBIG))
+          (.UNBOX. Y YH YL (GO RETBIG))
+          (RETURN (\\MAKENUMBER (LOGXOR XH YH)
+                         (LOGXOR XL YL)))
+      RETBIG
+          (RETURN (\\BIGNUM.LOGXOR X Y)))))
+
+(\\SLOWLRSH1
+  (LAMBDA (X)                                                (* |JonL| "27-Sep-84 22:59")
+    (PROG (HI LO)
+          (.UNBOX. X HI LO)
+          (RETURN (\\MAKENUMBER (LRSH HI 1)
+                         (IPLUS (LRSH LO 1)
+                                (COND
+                                   ((EQ 0 (LOGAND HI 1))
+                                    0)
+                                   (T 32768))))))))
+
+(\\SLOWLRSH8
+  (LAMBDA (X)                                                (* |lmm| "13-OCT-82 15:29")
+    (PROG (HI LO)
+          (.UNBOX. X HI LO)
+          (RETURN (\\MAKENUMBER (LRSH HI 8)
+                         (IPLUS (LLSH (LOGAND HI 255)
+                                           8)
+                                (LRSH LO 8)))))))
+
+(\\SLOWITIMES2
+  (LAMBDA (X Y)                                              (* \; "Edited  8-Apr-87 11:26 by jop")
+    (\\CALLME 'ITIMES)
+    (COND
+       ((OR (EQ X 0)
+            (EQ Y 0))
+        0)
+       (T (PROG (HX HY LX LY SIGN (HR 0)
+                    (LR 0)
+                    CARRY)
+                (.UNBOX. X HX LX (GO RETBIG))
+                (.UNBOX. Y HY LY (GO RETBIG))
+                (COND
+                   ((IGREATERP HX MAX.POS.HINUM)
+                    (|if| (EQUAL X MIN.FIXP)
+                        |then| (GO RETBIG))
+                    (.NEGATE. HX LX)
+                    (SETQ SIGN T)))
+                (COND
+                   ((IGREATERP HY MAX.POS.HINUM)
+                    (|if| (EQUAL Y MIN.FIXP)
+                        |then| (GO RETBIG))
+                    (.NEGATE. HY LY)
+                    (SETQ SIGN (NOT SIGN))))
+                (COND
+                   ((NEQ HY 0)
+                    (COND
+                       ((NEQ HX 0)
+                        (GO OVER)))
+                    (|swap| LX LY)
+                    (|swap| HX HY)))
+            MLP (COND
+                   ((ODDP (PROG1 LY
+                                  (SETQ LY (LRSH LY 1))))
+                    (COND
+                       ((IGREATERP LR (IDIFFERENCE MAX.SMALL.INTEGER LX))
+                                                             (* \; "low parts overflow")
+                                                             (* \; 
+                             "make the low word be the less significant bits and return the carry.")
+                        (SETQ LR (IDIFFERENCE LR (IDIFFERENCE MAX.SMALL.INTEGER (SUB1
+                                                                                         LX))))
+                        (SETQ CARRY 1))
+                       (T                                    (* \; 
+                                                           "no carry just add the low halves.")
+                          (SETQ LR (IPLUS LR LX))
+                          (SETQ CARRY 0)))
+
+                    (* |;;| "the low order part of the answer has been set and CARRY is the numeric value of the carry from the low part either 0 or 1")
+
+                    (COND
+                       ((IGREATERP (SETQ HR (IPLUS HR HX CARRY))
+                               MAX.POS.HINUM)
+                        (COND
+                           ((AND (EQ LY 0)
+                                 SIGN
+                                 (EQ HR (ADD1 MAX.POS.HINUM))
+                                 (EQ LR 0))
+                            (RETURN MIN.FIXP)))
+                        (GO OVER)))))
+                (COND
+                   ((ZEROP LY)
+                    (GO RET)))
+                (COND
+                   ((IGEQ HX (LRSH (ADD1 MAX.POS.HINUM)
+                                        1))
+                    (GO OVERTEST)))
+                (.LLSH1. HX LX)
+                (GO MLP)
+            OVERTEST
+                (COND
+                   ((AND (EQ HX (LRSH (ADD1 MAX.POS.HINUM)
+                                       1))
+                         (ZEROP LX)
+                         SIGN
+                         (EQ LY 1)
+                         (EQ HR 0)
+                         (EQ LR 0))                          (* \; "odd special case")
+                    (RETURN MIN.FIXP)))
+            OVER
+                (GO RETBIG)
+            RET (COND
+                   (SIGN (.NEGATE. HR LR)))
+                (RETURN (\\MAKENUMBER HR LR))
+            RETBIG
+                (RETURN (\\BIGNUM.TIMES X Y)))))))
+
+(\\SLOWTIMES2
+  (LAMBDA (X Y)                                              (* |lmm| "21-Aug-84 16:22")
+                                                             (* UFN |for| TIMES |Microcode| 
+                                                           |generally| |handles| |the| |case| 
+                                                           |of| |two| |args| |both| FIXPS)
+    (\\CALLME 'TIMES)
+    (PROG NIL
+      LP  (RETURN (COND
+                     ((OR (FLOATP X)
+                          (FLOATP Y))
+                      (FTIMES X Y))
+                     ((NOT (FIXP X))
+                      (SETQ X (LISPERROR "NON-NUMERIC ARG" X T))
+                      (GO LP))
+                     ((NOT (FIXP Y))
+                      (SETQ Y (LISPERROR "NON-NUMERIC ARG" Y T))
+                      (GO LP))
+                     (T (ITIMES X Y)))))))
+
+(\\SLOWIQUOTIENT
+  (LAMBDA (X Y)                                              (* |lmm| " 2-Jul-84 17:12")
+    (\\CALLME 'IQUOTIENT)
+    (\\IQUOTREM X Y X)
+    X))
+
+(\\SLOWQUOTIENT
+  (LAMBDA (X Y)                                              (* \; "Edited  8-Apr-87 11:26 by jop")
+
+    (* |;;| "UFN for QUOTIENT Microcode generally handles the case of two args both FIXPs")
+
+    (\\CALLME 'QUOTIENT)
+    (PROG NIL
+      LP  (RETURN (COND
+                     ((OR (FLOATP X)
+                          (FLOATP Y))
+                      (FQUOTIENT X Y))
+                     ((NOT (FIXP X))
+                      (SETQ X (LISPERROR "NON-NUMERIC ARG" X T))
+                      (GO LP))
+                     ((NOT (FIXP Y))
+                      (SETQ Y (LISPERROR "NON-NUMERIC ARG" Y T))
+                      (GO LP))
+                     (T (IQUOTIENT X Y)))))))
+)
+
+
+
+(* \; "IPLUS and IDIFFERENCE that smash result into their first arg")
+
+(DEFINEQ
+
+(\\BOXIPLUS
+  (LAMBDA (X Y)                                              (* \; "Edited  8-Apr-87 11:27 by jop")
+
+    (* |;;| "UFN for BOXIPLUS ipcode")
+
+    (.BOXIPLUS. X Y)))
+
+(\\BOXIDIFFERENCE
+  (LAMBDA (X Y)                                              (* \; "Edited  8-Apr-87 11:27 by jop")
+    (PROG ((HX (\\GETBASE X 0))
+           (LX (\\GETBASE X 1))
+           HY LY)
+          (.UNBOX. Y HY LY)
+          (.NEGATE. HY LY)
+          (SETQ HX (COND
+                      ((IGREATERP HX (IDIFFERENCE MAX.SMALL.INTEGER HY))
+                       (IDIFFERENCE HX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY))))
+                      (T (IPLUS HX HY))))                (* \; "Add high parts")
+          (\\PUTBASE X 1 (COND
+                            ((IGREATERP LX (IDIFFERENCE MAX.SMALL.INTEGER LY))
+                                                             (* \; "Carry into high part.")
+                             (SETQ HX (COND
+                                         ((EQ HX MAX.SMALL.INTEGER)
+                                          0)
+                                         (T (ADD1 HX))))
+                             (IDIFFERENCE LX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY))))
+                            (T (IPLUS LX LY))))
+          (\\PUTBASE X 0 HX)
+          (RETURN X))))
+)
+
+
+
+(* \; "subfunctions")
+
+(DEFINEQ
+
+(\\MAKENUMBER
+  (LAMBDA (N0 N1)                                            (* \; "Edited  8-Apr-87 11:28 by jop")
+
+    (* |;;| "used as punt case for arith opcodes which create large numbers")
+
+    (SETQ N1 (.COERCE.TO.SMALLPOSP. N1))
+    (SELECTC (SETQ N0 (.COERCE.TO.SMALLPOSP. N0))
+        (0 N1)
+        (65535                                               (* \; 
+                                                           "This is a word's worth of 1 bits")
+               (\\VAG2 |\\SmallNegHi| N1))
+        (|create| FIXP
+               HINUM _ N0
+               LONUM _ N1))))
+)
+(DEFINEQ
+
+(OVERFLOW
+  (LAMBDA (FLG)                                              (* |lmm:| 14-JAN-76 1 6)
+    (PROG1 \\OVERFLOW
+        (SETQ \\OVERFLOW (SELECTQ FLG
+                             (NIL NIL)
+                             (T T)
+                             0)))))
+)
+
+(RPAQ? \\OVERFLOW T)
+(DECLARE\: EVAL@COMPILE 
+
+(RPAQQ MAX.SMALLP 65535)
+
+(RPAQQ MIN.SMALLP -65536)
+
+(RPAQQ MAX.FIXP 2147483647)
+
+(RPAQQ MIN.FIXP -2147483648)
+
+(RPAQQ \\SIGNBIT 32768)
+
+
+(CONSTANTS (MAX.SMALLP 65535)
+       (MIN.SMALLP -65536)
+       (MAX.FIXP 2147483647)
+       (MIN.FIXP -2147483648)
+       (\\SIGNBIT 32768))
+)
+(DEFINEQ
+
+(\\GETBASEFIXP
+  (LAMBDA (BASE OFFST)                                       (* |lmm| " 5-Jan-85 23:11")
+    ((LAMBDA (|\\NewBaseAddr|)
+       (\\MAKENUMBER (\\GETBASE |\\NewBaseAddr| 0)
+              (\\GETBASE |\\NewBaseAddr| 1)))
+     (\\ADDBASE BASE OFFST))))
+
+(\\PUTBASEFIXP
+  (LAMBDA (BASE OFFST VAL)                                   (* |lmm| " 5-Jan-85 23:16")
+    (PROG (HI LO)
+          (.XUNBOX. VAL HI LO)
+          (\\PUTBASE BASE OFFST HI)
+          (\\PUTBASE BASE (ADD1 OFFST)
+                 LO)
+      VAL (RETURN VAL))))
+
+(\\PUTBASEFIXP.UFN
+  (LAMBDA (BASE VAL OFFST)                                   (* |lmm| " 5-Jan-85 23:25")
+    (PROG (HI LO)
+          (.XUNBOX. VAL HI LO)
+          (\\PUTBASE BASE OFFST HI)
+          (\\PUTBASE BASE (ADD1 OFFST)
+                 LO)
+      VAL (RETURN VAL))))
+)
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE\: DONTCOPY 
+(DECLARE\: EVAL@COMPILE
+
+(BLOCKRECORD FIXP ((HINUM WORD)
+                       (LONUM WORD))
+                      (CREATE (CREATECELL \\FIXP))
+                      (TYPE? (EQ (NTYPX DATUM)
+                                     \\FIXP)))
+)
+
+(DECLARE\: EVAL@COMPILE 
+
+(RPAQQ MAX.SMALL.INTEGER 65535)
+
+(RPAQQ MAX.POS.HINUM 32767)
+
+
+(CONSTANTS (MAX.SMALL.INTEGER 65535)
+       (MAX.POS.HINUM 32767))
+)
+
+(DECLARE\: EVAL@COMPILE 
+
+(PUTPROPS .UNBOX. MACRO
+          (ARGS (LET ((ARG-FORM (CAR ARGS))
+                      (HIGH-VAR (CADR ARGS))
+                      (LOW-VAR (CADDR ARGS))
+                      (BIGNUM-FORM (CADDDR ARGS)))
+                     `(PROG NIL
+                        UBLP
+                            (SELECTC (NTYPX ,ARG-FORM)
+                                (\\FIXP (SETQ ,HIGH-VAR (|ffetch| (FIXP HINUM)
+                                                           |of| ,ARG-FORM))
+                                        (SETQ ,LOW-VAR (|ffetch| (FIXP LONUM) |of|
+                                                                                  ,ARG-FORM)))
+                                (\\SMALLP (COND
+                                             ((ILEQ 0 ,ARG-FORM)
+                                              (SETQ ,HIGH-VAR 0)
+                                              (SETQ ,LOW-VAR ,ARG-FORM))
+                                             (T (SETQ ,HIGH-VAR 65535)
+                                                (SETQ ,LOW-VAR (\\LOLOC ,ARG-FORM)))))
+                                (\\FLOATP (SETQ ,ARG-FORM (\\FIXP.FROM.FLOATP ,ARG-FORM))
+                                          (GO UBLP))
+                                (COND
+                                   ((TYPENAMEP ,ARG-FORM 'RATIO)
+                                    (SETQ ,ARG-FORM (IQUOTIENT (LISP::RATIO-NUMERATOR
+                                                                    ,ARG-FORM)
+                                                           (LISP::RATIO-DENOMINATOR ,ARG-FORM)))
+                                    (GO UBLP))
+                                   ,@(COND
+                                        (BIGNUM-FORM `(((LISP:INTEGERP ,ARG-FORM)
+                                                        ,BIGNUM-FORM)))
+                                        (T `(((LISP:INTEGERP ,ARG-FORM)
+                                              (\\ILLEGAL.ARG ,ARG-FORM)))))
+                                   (T (LISP::%NOT-NONCOMPLEX-NUMBER-ERROR ,ARG-FORM))))))))
+
+(PUTPROPS .NEGATE. MACRO ((HY LY)
+                                  (COND
+                                     ((EQ 0 LY)
+                                      (AND (NEQ HY 0)
+                                           (SETQ HY (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY))
+                                            )))
+                                     (T (SETQ HY (IDIFFERENCE MAX.SMALL.INTEGER HY))
+                                        (SETQ LY (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY)))))
+                                  ))
+
+(PUTPROPS .LLSH1. MACRO ((HI LO)                     (* \; 
+                                                    "shift the pair left one, assuming no overflow")
+                                 (SETQ HI (LLSH HI 1))
+                                 (SETQ LO (LLSH (COND
+                                                       ((IGREATERP LO MAX.POS.HINUM)
+                                                        (|add| HI 1)
+                                                        (LOGAND LO MAX.POS.HINUM))
+                                                       (T LO))
+                                                 1))))
+
+(PUTPROPS .LRSH1. MACRO ((HI LO)
+                                 (SETQ LO (LRSH LO 1))
+                                 (COND
+                                    ((NEQ (LOGAND HI 1)
+                                          0)
+                                     (SETQ LO (IPLUS LO \\SIGNBIT))))
+                                 (SETQ HI (LRSH HI 1))))
+
+(PUTPROPS .BOXIPLUS. MACRO (OPENLAMBDA (X Y)
+                                          (PROG ((HX (\\GETBASE X 0))
+                                                 (LX (\\GETBASE X 1))
+                                                 HY LY)
+                                                (.UNBOX. Y HY LY)
+                                                (SETQ HX (COND
+                                                            ((IGREATERP HX (IDIFFERENCE
+                                                                                MAX.SMALL.INTEGER HY)
+                                                                    )
+                                                             (IDIFFERENCE HX
+                                                                    (ADD1 (IDIFFERENCE 
+                                                                                    MAX.SMALL.INTEGER
+                                                                                     HY))))
+                                                            (T (IPLUS HX HY))))
+                                                             (* |Add| |high| |parts|)
+                                                (\\PUTBASE X 1 (COND
+                                                                  ((IGREATERP LX (IDIFFERENCE
+                                                                                      
+                                                                                    MAX.SMALL.INTEGER
+                                                                                      LY))
+                                                             (* |Carry| |into| |high| |part.|)
+                                                                   (SETQ HX (COND
+                                                                               ((EQ HX 
+                                                                                    MAX.SMALL.INTEGER
+                                                                                    )
+                                                                                0)
+                                                                               (T (ADD1 HX))))
+                                                                   (IDIFFERENCE
+                                                                    LX
+                                                                    (ADD1 (IDIFFERENCE 
+                                                                                    MAX.SMALL.INTEGER
+                                                                                     LY))))
+                                                                  (T (IPLUS LX LY))))
+                                                (\\PUTBASE X 0 HX)
+                                                (RETURN X))))
+)
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+(DECLARE\: DONTCOPY 
+(DECLARE\: EVAL@COMPILE 
+
+(PUTPROPS OLD.UNBOX. MACRO ((V HV LV BIGNUMFORM)
+                                    (PROG NIL
+                                      UBLP
+                                          (SELECTC (NTYPX V)
+                                              (\\FIXP (SETQ HV (|ffetch| (FIXP HINUM)
+                                                                  |of| V))
+                                                      (SETQ LV (|ffetch| (FIXP LONUM)
+                                                                  |of| V)))
+                                              (\\SMALLP (COND
+                                                           ((ILEQ 0 V)
+                                                            (SETQ HV 0)
+                                                            (SETQ LV V))
+                                                           (T (SETQ HV 65535)
+                                                              (SETQ LV (\\LOLOC V)))))
+                                              (\\FLOATP (SETQ V (\\FIXP.FROM.FLOATP V))
+                                                        (GO UBLP))
+                                              (|if| (TYPENAMEP V 'BIGNUM)
+                                                  |then| (|if| 'BIGNUMFORM
+                                                                 |then| BIGNUMFORM
+                                                               |else| (SETQ V
+                                                                           (\\LISPERROR V 
+                                                                                  "ARG NOT FIXP" T))
+                                                                     (GO UBLP))
+                                                |else| (SETQ V (LISPERROR "NON-NUMERIC ARG" V T))
+                                                      (GO UBLP))))))
+)
+)
+
+
+
+(* |;;| "Eqp modified to be like =")
+
+(DEFINEQ
+
+(EQP
+  (LAMBDA (X Y)                                              (* \; "Edited  7-Dec-88 09:04 by jds")
+    (COND
+       ((EQ X Y)
+        T)
+       ((AND (FIXP X)
+             (FIXP Y))
+        (IEQP X Y))
+       ((AND (OR (FLOATP X)
+                 (FIXP X))
+             (OR (FLOATP Y)
+                 (FIXP Y)))
+        (FEQP X Y))
+       ((AND (NUMBERP X)
+             (NUMBERP Y))
+        (= X Y))
+       (T (\\EXTENDED.EQP X Y)))))
+
+(FIX
+  (LAMBDA (N)                                                (* \; "Edited  8-Apr-87 11:30 by jop")
+
+    (* |;;| "FIX compiles open")
+
+    (IPLUS N 0)))
+
+(IQUOTIENT
+  (LAMBDA (X Y)                                              (* |lmm| "11-FEB-82 14:02")
+    ((OPCODES IQUOTIENT)
+     X Y)))
+
+(IREMAINDER
+  (LAMBDA (X Y)                                              (* |edited:| "29-APR-82 05:01")
+    (\\IQUOTREM X Y NIL Y)
+    Y))
+
+(LLSH
+  (LAMBDA (X N)                                              (* |lmm| "13-OCT-82 15:30")
+    (COND
+       ((IGREATERP 0 N)
+        (LRSH X (IMINUS N)))
+       (T (PROG (XHI XLO)
+                (.UNBOX. X XHI XLO)
+                (COND
+                   ((IGREATERP N 31)
+                    (RETURN 0)))
+                (COND
+                   ((IGREATERP N 15)
+                    (SETQ XHI XLO)
+                    (SETQ XLO 0)
+                    (SETQ N (IDIFFERENCE N 16))))
+                (COND
+                   ((IGREATERP N 7)
+                    (SETQ XHI (IPLUS (LLSH (LOGAND XHI 255)
+                                                8)
+                                     (LRSH XLO 8)))
+                    (SETQ XLO (LLSH (LOGAND XLO 255)
+                                     8))
+                    (SETQ N (IDIFFERENCE N 8))))
+                (FRPTQ N (SETQ XHI (LOGAND XHI MAX.POS.HINUM))
+                       (.LLSH1. XHI XLO))
+                (RETURN (\\MAKENUMBER XHI XLO)))))))
+
+(LRSH
+  (LAMBDA (X N)                                              (* \; "Edited  8-Apr-87 11:30 by jop")
+
+    (* |;;| "assumes case where n is constant and 8 or 1 handled in microcode or by \\SLOWLRSHn")
+
+    (COND
+       ((IGREATERP 0 N)
+        (LLSH X (IMINUS N)))
+       (T (PROG (XHI XLO)
+                (.UNBOX. X XHI XLO)
+                (COND
+                   ((IGREATERP N 31)
+                    (RETURN 0)))
+                (COND
+                   ((IGREATERP N 15)
+                    (SETQ XLO XHI)
+                    (SETQ XHI 0)
+                    (SETQ N (IDIFFERENCE N 16))))
+                (COND
+                   ((IGREATERP N 7)
+                    (SETQ XLO (IPLUS (LRSH XLO 8)
+                                     (LLSH (LOGAND XHI 255)
+                                            8)))
+                    (SETQ XHI (LRSH XHI 8))
+                    (SETQ N (IDIFFERENCE N 8))))
+                (FRPTQ N (.LRSH1. XHI XLO))
+                (RETURN (\\MAKENUMBER XHI XLO)))))))
+
+(LSH
+  (LAMBDA (X N)                                              (* \; "Edited  7-Apr-89 16:19 by jds")
+
+    (* |;;| "Arithmetic left shift.  Since this punts on the dorado, and RSH is optimized to be LSH for the Sun, we have to use \\RSH here (the bottoming-out version of RSH).")
+
+    (COND
+       ((ILEQ N 0)
+        (COND
+           ((EQ N 0)
+            X)
+           (T (\\RSH X (IMINUS N)))))
+       ((EQ X 0)
+        0)
+       ((IGREATERP N (CONSTANT (INTEGERLENGTH MAX.FIXP)))
+        (\\BIGNUM.LSH X N))
+       (T (FRPTQ N (SETQ X (IPLUS X X)))
+          X))))
+
+(RSH
+  (LAMBDA (X N)                                              (* \; "Edited  7-Apr-89 16:20 by jds")
+
+    (* |;;| "Arithmetic Right-shift.  There's an optimizer on this function, so just call the underlying implementation.")
+
+    (\\RSH X N)))
+
+(\\RSH
+  (LAMBDA (X N)                                              (* \; "Edited  7-Apr-89 16:21 by jds")
+
+    (* |;;| 
+ "This is the version of RSH where things bottom out if LSH doesn't handle all the possible cases.")
+
+    (COND
+       ((IGREATERP 0 N)
+        (LSH X (IMINUS N)))
+       ((EQ X 0)
+        0)
+       (T (PROG (XHI XLO)
+                (.UNBOX. X XHI XLO (GO RETBIG))
+                (COND
+                   ((IGREATERP N 31)
+                    (RETURN (COND
+                               ((IGREATERP XHI 32767)    (* \; "X WAS NEGATIVE")
+                                -1)
+                               (T 0)))))
+                (COND
+                   ((IGREATERP N 15)
+                    (SETQ XLO XHI)
+                    (SETQ XHI (COND
+                                 ((IGREATERP XHI 32767)
+                                  65535)
+                                 (T 0)))
+                    (SETQ N (IDIFFERENCE N 16))))
+                (COND
+                   ((IGREATERP N 7)
+                    (SETQ XLO (IPLUS (LRSH XLO 8)
+                                     (LLSH (LOGAND XHI 255)
+                                            8)))
+                    (SETQ XHI (IPLUS (LRSH XHI 8)
+                                     (COND
+                                        ((IGREATERP XHI 32767)
+                                         65280)
+                                        (T 0))))
+                    (SETQ N (IDIFFERENCE N 8))))
+                (FRPTQ N (SETQ XLO (IPLUS (LRSH XLO 1)
+                                          (COND
+                                             ((EQ 0 (LOGAND XHI 1))
+                                              0)
+                                             (T 32768))))
+                       (SETQ XHI (IPLUS (LRSH XHI 1)
+                                        (LOGAND XHI 32768))))
+                (RETURN (\\MAKENUMBER XHI XLO))
+            RETBIG
+                (RETURN (\\BIGNUM.LSH X (IMINUS N))))))))
+)
+(DECLARE\: EVAL@COMPILE DONTCOPY 
+(DECLARE\: EVAL@COMPILE 
+
+(PUTPROPS NBITS.OR.LESS MACRO ((X N)
+                                       (ILESSP X (CONSTANT (LLSH 1 N)))))
+
+(PUTPROPS .SUBSMALL. MACRO ((X Y)                    (* \; 
+                                     "Subtract Y from X, returning the borrow out of the next word")
+                                    (COND
+                                       ((ILEQ Y X)
+                                        (SETQ X (IDIFFERENCE X Y))
+                                        0)
+                                       (T (SETQ X (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER
+                                                                   (IDIFFERENCE Y X))))
+                                          1))))
+
+(PUTPROPS \\IQUOTREM MACRO ((X Y QUO REM)
+                                    (PROG (HX LX HY LY SIGNQUOTIENT SIGNREMAINDER (CNT 0)
+                                              (HZ 0)
+                                              (LZ 0))
+                                          (.UNBOX. X HX LX (GO RETBIG))
+                                          (.UNBOX. Y HY LY (GO RETBIG))
+                                          (COND
+                                             ((IGREATERP HX MAX.POS.HINUM)
+                                              (.NEGATE. HX LX)
+                                              (SETQ SIGNQUOTIENT (SETQ SIGNREMAINDER T))))
+                                                             (* \; "Remainder has sign of dividend")
+                                          (COND
+                                             ((IGREATERP HY MAX.POS.HINUM)
+                                              (.NEGATE. HY LY)
+                                              (SETQ SIGNQUOTIENT (NOT SIGNQUOTIENT))))
+                                          (COND
+                                             ((NEQ HX 0)
+                                              (GO BIGDIVIDEND))
+                                             ((NEQ HY 0)     (* \; 
+                                                           "Y is big, X is small, so result is 0")
+                                              (GO DONE))
+                                             ((EQ 0 LX)
+                                              (GO RET0))
+                                             ((EQ 0 LY)
+                                              (GO DIVZERO))
+                                             ((EQ LY 1)
+                                              (SETQ LZ LX)
+                                              (SETQ LX 0)
+                                              (GO DONE)))    (* \; 
+                                      "here we are dividing small X by small Y, and we know Y gt 1")
+                                      LP1                    (* \; 
+                                   "shift Y left until it is as big as X, and count how many times")
+                                          (COND
+                                             ((AND (ILESSP LY LX)
+                                                   (ILEQ LY MAX.POS.HINUM))
+                                              (SETQ LY (LLSH LY 1))
+                                              (SETQ CNT (ADD1 CNT))
+                                              (GO LP1)))
+                                      LP2 
+
+                                     (* |;;| "now start dividing Y into X by subtracting and shifting, ending up with Y shifted back where it started")
+
+                                          (COND
+                                             ((ILEQ LY LX)
+                                              (SETQ LX (IDIFFERENCE LX LY))
+                                                             (* \; 
+                                                       "Y divides X once, so add bit into quotient")
+                                              (SETQ LZ (ADD1 LZ))))
+                                          (SETQ LY (LRSH LY 1))
+                                          (SETQ CNT (SUB1 CNT))
+                                          (COND
+                                             ((IGEQ CNT 0)
+                                              (SETQ LZ (LLSH LZ 1))
+                                              (GO LP2)))
+                                          (GO DONE)
+                                      BIGDIVIDEND
+                                                             (* \; 
+ "X is big, so result may be big.  Algorithm is same as above, but everything is doubled in length")
+                                          (COND
+                                             ((EQ 0 HY)
+                                              (COND
+                                                 ((EQ 0 (SETQ HY LY))
+                                                  (GO DIVZERO))
+                                                 ((AND SIGNREMAINDER (NULL SIGNQUOTIENT)
+                                                       (EQ 1 LY)
+                                                       (EQ HX \\SIGNBIT)
+                                                       (EQ 0 LX))
+                                                             (* \; 
+                                                           "Means that X is MIN.FIXP and Y is -1")
+                                                  (GO RETBIG)))
+                                              (SETQ LY 0)
+                                              (SETQ CNT 16))
+                                             ((AND SIGNREMAINDER (NULL SIGNQUOTIENT)
+                                                   (EQ 0 LX)
+                                                   (EQ HX \\SIGNBIT)
+                                                   (EQ 0 HY)
+                                                   (EQ 1 LY))(* \; 
+                                                           "Means that X is MIN.FIXP and Y is -1")
+                                              (GO RETBIG)))
+                                      BIGLP
+                                          (COND
+                                             ((AND (OR (AND (EQ HY HX)
+                                                            (ILESSP LY LX))
+                                                       (ILESSP HY HX))
+                                                   (ILESSP HY MAX.POS.HINUM))
+                                              (.LLSH1. HY LY)
+                                              (SETQ CNT (ADD1 CNT))
+                                              (GO BIGLP)))
+                                      BIGLP2
+                                          (COND
+                                             ((OR (ILESSP HY HX)
+                                                  (AND (EQ HY HX)
+                                                       (ILEQ LY LX)))
+                                                             (* \; 
+                                      "Y divides X, so subtract Y from X and put a bit in quotient")
+                                              (SETQ HX (IDIFFERENCE (IDIFFERENCE HX HY)
+                                                              (.SUBSMALL. LX LY)))
+                                              (SETQ LZ (ADD1 LZ))
+                                                             (* \; 
+                              "note that this never overflows, because of the preceding left shift")
+                                              ))
+                                          (.LRSH1. HY LY)
+                                          (SETQ CNT (SUB1 CNT))
+                                          (COND
+                                             ((IGEQ CNT 0)
+                                              (.LLSH1. HZ LZ)
+                                              (GO BIGLP2)))
+                                      DONE
+                                          (COND
+                                             ('REM           (* \; "remainder is left in X")
+                                                   (COND
+                                                      (SIGNREMAINDER (.NEGATE. HX LX)))
+                                                   (SETQ REM (\\MAKENUMBER HX LX))))
+                                          (COND
+                                             ('QUO (COND
+                                                      (SIGNQUOTIENT (.NEGATE. HZ LZ)))
+                                                   (SETQ QUO (\\MAKENUMBER HZ LZ))))
+                                          (RETURN)
+                                      DIVZERO
+                                          (SELECTQ \\OVERFLOW
+                                              (T (ERROR "DIVIDE BY ZERO" Y))
+                                              (GO RET0))
+                                      RET0
+                                          (COND
+                                             ('REM (SETQ REM 0)))
+                                          (COND
+                                             ('QUO (SETQ QUO 0)))
+                                          (RETURN)
+                                      RETBIG
+                                          (|if| 'QUO
+                                              |then| (SETQ QUO (\\BIGNUM.QUOTIENT X Y)))
+                                          (|if| 'REM
+                                              |then| (SETQ REM (\\BIGNUM.REMAINDER X Y)))
+                                          (RETURN))))
+)
+)
+
+
+
+(* \; "Machine independent arithmetic functions")
+
+
+
+
+(* |;;| "MINUSP redefined in cmlarith ")
+
+(DEFINEQ
+
+(MINUSP
+  (LAMBDA (X)                                                (* FS "22-Nov-86 20:47")
+                                                             (* 
+                                        "Replaced by Roach (via MOVD) in CMLARITH to handle RATIOS")
+    (COND
+       ((FLOATP X)
+        (FGREATERP 0.0 X))
+       (T (IGREATERP 0 X)))))
+
+(ILESSP
+  (LAMBDA (X Y)
+    (IGREATERP Y X)))
+
+(IMINUS
+  (LAMBDA (X)
+    (IDIFFERENCE 0 X)))
+
+(IPLUS
+  (LAMBDA N                                                  (* \; "Edited  8-Apr-87 11:34 by jop")
+
+    (* |;;| "called only by interpreted code --- this defn relies on fact that compiler turns IPLUS calls into sequences of opcodes")
+
+    (SELECTQ N
+        (2 (IPLUS (ARG N 1)
+                  (ARG N 2)))
+        (1 (IPLUS (ARG N 1)))
+        (0 (IPLUS))
+        (PROG ((R (IPLUS (ARG N 1)
+                         (ARG N 2)
+                         (ARG N 3)))
+               (J 4))
+          LP  (COND
+                 ((ILEQ J N)
+                  (SETQ R (IPLUS R (ARG N J)))
+                  (SETQ J (ADD1 J))
+                  (GO LP)))
+              (RETURN R)))))
+
+(ITIMES
+  (LAMBDA N                                                  (* \; "Edited  8-Apr-87 11:34 by jop")
+
+    (* |;;| "called only by interpreted code --- this defn relies on fact that compiler turns ITIMES calls into sequences of opcodes")
+
+    (SELECTQ N
+        (2 (ITIMES (ARG N 1)
+                  (ARG N 2)))
+        (1 (ITIMES (ARG N 1)))
+        (0 (ITIMES))
+        (PROG ((R (ITIMES (ARG N 1)
+                         (ARG N 2)
+                         (ARG N 3)))
+               (J 4))
+          LP  (COND
+                 ((ILEQ J N)
+                  (SETQ R (ITIMES R (ARG N J)))
+                  (SETQ J (ADD1 J))
+                  (GO LP)))
+              (RETURN R)))))
+
+(LOGAND
+  (LAMBDA N                                                  (* \; "Edited  8-Apr-87 11:34 by jop")
+
+    (* |;;| "called only by interpreted code --- this defn relies on fact that compiler turns LOGAND calls into sequences of opcodes")
+
+    (SELECTQ N
+        (2 (LOGAND (ARG N 1)
+                  (ARG N 2)))
+        (1 (LOGAND (ARG N 1)))
+        (0 (LOGAND))
+        (PROG ((R (LOGAND (ARG N 1)
+                         (ARG N 2)
+                         (ARG N 3)))
+               (J 4))
+          LP  (COND
+                 ((ILEQ J N)
+                  (SETQ R (LOGAND R (ARG N J)))
+                  (SETQ J (ADD1 J))
+                  (GO LP)))
+              (RETURN R)))))
+
+(LOGOR
+  (LAMBDA N                                                  (* \; "Edited  8-Apr-87 11:34 by jop")
+
+    (* |;;| "called only by interpreted code --- this defn relies on fact that compiler turns LOGOR calls into sequences of opcodes")
+
+    (SELECTQ N
+        (2 (LOGOR (ARG N 1)
+                  (ARG N 2)))
+        (1 (LOGOR (ARG N 1)))
+        (0 (LOGOR))
+        (PROG ((R (LOGOR (ARG N 1)
+                         (ARG N 2)
+                         (ARG N 3)))
+               (J 4))
+          LP  (COND
+                 ((ILEQ J N)
+                  (SETQ R (LOGOR R (ARG N J)))
+                  (SETQ J (ADD1 J))
+                  (GO LP)))
+              (RETURN R)))))
+
+(LOGXOR
+  (LAMBDA N                                                  (* \; "Edited  8-Apr-87 11:35 by jop")
+
+    (* |;;| "called only by interpreted code --- this defn relies on fact that compiler turns LOGXOR calls into sequences of opcodes")
+
+    (SELECTQ N
+        (2 (LOGXOR (ARG N 1)
+                  (ARG N 2)))
+        (1 (LOGXOR (ARG N 1)))
+        (0 (LOGXOR))
+        (PROG ((R (LOGXOR (ARG N 1)
+                         (ARG N 2)
+                         (ARG N 3)))
+               (J 4))
+          LP  (COND
+                 ((ILEQ J N)
+                  (SETQ R (LOGXOR R (ARG N J)))
+                  (SETQ J (ADD1 J))
+                  (GO LP)))
+              (RETURN R)))))
+
+(SUB1
+  (LAMBDA (X)                                                (* \; "Edited  8-Apr-87 11:35 by jop")
+    (IDIFFERENCE X 1)))
+
+(ZEROP
+  (LAMBDA (X)                                                (* |Pavel| " 6-Oct-86 22:13")
+    (COND
+       ((EQ X 0)
+        T)
+       ((FLOATP X)
+        (\\FZEROP X)))))
+
+(ADD1
+  (LAMBDA (X)                                                (* \; "Edited  8-Apr-87 11:35 by jop")
+    (IPLUS X 1)))
+
+(GCD
+  (LAMBDA (N1 N2)                                            (* \; "Edited  8-Apr-87 11:35 by jop")
+
+    (* |;;| "Greatest common divisor, using Euler's Method")
+
+    (COND
+       ((EQ 0 N2)
+        N1)
+       ((MINUSP N2)                                      (* \; "GCD is always positive")
+        (GCD (MINUS N2)
+               N1))
+       (T (GCD N2 (IREMAINDER N1 N2))))))
+
+(IEQP
+  (LAMBDA (X Y)                                              (* |JonL| " 1-May-84 22:23")
+    (EQ 0 (IDIFFERENCE X Y))))
+
+(INTEGERLENGTH
+  (LAMBDA (X)                                                (* \; "Edited  8-Apr-87 11:37 by jop")
+    (SELECTC (NTYPX X)
+        (\\SMALLP (COND
+                     ((ILESSP X 0)
+                      (SETQ X (IDIFFERENCE 0 X))))
+                  (COND
+                     ((NBITS.OR.LESS X 16)
+                      (COND
+                         ((NBITS.OR.LESS X 8)
+                          (COND
+                             ((NBITS.OR.LESS X 4)
+                              (COND
+                                 ((NBITS.OR.LESS X 2)
+                                  (COND
+                                     ((NBITS.OR.LESS X 1)
+                                      (COND
+                                         ((EQ X 0)
+                                          0)
+                                         (T 1)))
+                                     (T 2)))
+                                 ((NBITS.OR.LESS X 3)
+                                  3)
+                                 (T 4)))
+                             ((NBITS.OR.LESS X 6)
+                              (COND
+                                 ((NBITS.OR.LESS X 5)
+                                  5)
+                                 (T 6)))
+                             ((NBITS.OR.LESS X 7)
+                              7)
+                             (T 8)))
+                         ((NBITS.OR.LESS X 12)
+                          (COND
+                             ((NBITS.OR.LESS X 10)
+                              (COND
+                                 ((NBITS.OR.LESS X 9)
+                                  9)
+                                 (T 10)))
+                             ((NBITS.OR.LESS X 11)
+                              11)
+                             (T 12)))
+                         ((NBITS.OR.LESS X 14)
+                          (COND
+                             ((NBITS.OR.LESS X 13)
+                              13)
+                             (T 14)))
+                         ((NBITS.OR.LESS X 15)
+                          15)
+                         (T 16)))
+                     (T (SHOULDNT))))
+        (\\FIXP (PROG ((HX (|fetch| (FIXP HINUM) |of| X)))
+                      (COND
+                         ((IGREATERP HX MAX.POS.HINUM)   (* \; "So X is negative")
+                          ((LAMBDA (LX)
+                             (COND
+                                ((AND (EQ HX \\SIGNBIT)
+                                      (EQ LX 0))             (* \; 
+                                                          "So X is EQP to the minimum FIXP integer")
+                                 (RETURN (CONSTANT BITS.PER.FIXP)))
+                                (T (.NEGATE. HX LX))))
+                           (|fetch| (FIXP LONUM) |of| X))))
+                      (RETURN (COND
+                                 ((EQ HX 0)
+
+                                 (* |;;| "This bizarre case shouldn't really happen, but I wouldn't like to rule it out -- a non-normalized FIXP that realy should be a SMALLP")
+
+                                  (INTEGERLENGTH (|fetch| (FIXP LONUM) |of| X)))
+                                 (T (IPLUS (INTEGERLENGTH HX)
+                                           BITSPERWORD))))))
+        (COND
+           ((TYPENAMEP X 'BIGNUM)
+            (\\BIGNUM.INTEGERLENGTH X))
+           (T (LISP::%NOT-INTEGER-ERROR X))))))
+)
+
+
+
+(* |;;| "abs, difference, greaterp, plus, lessp, and times  redefined in cmlarith. ")
+
+
+
+
+(* |;;| "quotient and minus modified to handle ratios")
+
+
+
+
+(* |;;| "remainder remains as is")
+
+(DEFINEQ
+
+(ABS
+  (LAMBDA (X)                                                (* FS "22-Nov-86 20:58")
+                                                             (* 
+                                                           "Replaced in CMLARITH to handle RATIOS")
+    (LISP:CTYPECASE X ((OR INTEGER FLOAT)
+                       (COND
+                          ((< X 0)
+                           (- 0 X))
+                          (T X)))
+           (RATIO (COND
+                     ((< (LISP:NUMERATOR X)
+                         0)
+                      (%MAKE-RATIO (- 0 (LISP:NUMERATOR X))
+                             (LISP:DENOMINATOR X)))
+                     (T X)))
+           (COMPLEX (%COMPLEX-ABS X)))))
+
+(DIFFERENCE
+  (LAMBDA (X Y)                                              (* \; "Edited  8-Apr-87 11:39 by jop")
+    ((OPCODES DIFFERENCE)
+     X Y)))
+
+(GREATERP
+  (LAMBDA (X Y)                                              (* \; "Edited  8-Apr-87 11:39 by jop")
+    (COND
+       ((AND (FIXP X)
+             (FIXP Y))
+        (IGREATERP X Y))
+       (T (FGREATERP X Y)))))
+
+(PLUS
+  (LAMBDA N                                                  (* \; "Edited  8-Apr-87 11:39 by jop")
+
+    (* |;;| "Microcode generally handles the case of two args both FIXPs")
+
+    (PROG (R (J 0))
+      LP  (COND
+             ((NEQ J N)
+              (SETQ J (ADD1 J))
+              (SETQ R (COND
+                         ((AND (FIXP (ARG N J))
+                               (NOT (FLOATP R)))
+                          (IPLUS (OR R 0)
+                                 (ARG N J)))
+                         (T (FPLUS (OR R 0.0)
+                                   (ARG N J)))))
+              (GO LP)))
+          (RETURN R))))
+
+(QUOTIENT
+  (LAMBDA (X Y)                                              (* \; "Edited 12-Feb-87 14:59 by jop")
+                                                             (* |lmm:| 17-DEC-75 25 36)
+    (COND
+       ((AND (FIXP X)
+             (FIXP Y))
+        (IQUOTIENT X Y))
+       ((OR (FLOATP X)
+            (FLOATP Y))
+        (FQUOTIENT X Y))
+       (T (/ X Y)))))
+
+(REMAINDER
+  (LAMBDA (X Y)                                              (* |lmm:| 17-DEC-75 21 30)
+    (COND
+       ((AND (FIXP X)
+             (FIXP Y))
+        (IREMAINDER X Y))
+       (T (FREMAINDER X Y)))))
+
+(LESSP
+  (LAMBDA (X Y)                                              (* \; "Edited  8-Apr-87 11:40 by jop")
+    (COND
+       ((AND (FIXP Y)
+             (FIXP X))
+        (IGREATERP Y X))
+       (T (FGREATERP Y X)))))
+
+(MINUS
+  (LAMBDA (X)                                                (* \; "Edited  1-Mar-87 18:10 by jop")
+    (COND
+       ((FLOATP X)
+        (FDIFFERENCE 0.0 X))
+       (T (DIFFERENCE 0 X)))))
+
+(TIMES
+  (LAMBDA N                                                  (* \; "Edited  8-Apr-87 11:40 by jop")
+    (PROG (R (J 0))
+      LP  (COND
+             ((NEQ J N)
+              (SETQ J (ADD1 J))
+              (SETQ R (COND
+                         ((AND (FIXP (ARG N J))
+                               (NOT (FLOATP R)))
+                          (ITIMES (OR R 1)
+                                 (ARG N J)))
+                         (T (FTIMES (OR R 1.0)
+                                   (ARG N J)))))
+              (GO LP)))
+          (RETURN R))))
+)
+(DEFINEQ
+
+(FMINUS
+  (LAMBDA (X)                                                (* |lmm| " 5-MAR-80 23:12")
+    (FDIFFERENCE 0.0 X)))
+
+(FREMAINDER
+  (LAMBDA (X Y)                                              (* |rrb| "24-APR-80 10:37")
+    (FDIFFERENCE X (FTIMES (FLOAT (FIX (FQUOTIENT X Y)))
+                          Y))))
+)
+(DEFINEQ
+
+(RANDSET
+  (LAMBDA (X)                                                (* \; "Edited  8-Apr-87 11:40 by jop")
+    (PROG (RS RS1 RS2)
+          (COND
+             ((NULL X)
+              (GO OUT))
+             ((EQ X T)                                       (* \; "initialize with clock")
+              (SETQ RS1 (CLOCK))
+              (SETQ RS2 (IDATE)))
+             ((AND (FIXP (CDR (LISTP X)))
+                   (FIXP (CAR X)))                           (* \; 
+                                                          "user supplies initialization, old-style")
+              (SETQ RS1 (CAR X))
+              (SETQ RS2 (CDR X)))
+             ((AND (EQ (LENGTH X)
+                       55)
+                   (EVERY X (FUNCTION FIXP)))
+              (SETQ RS (MAPCAR X (FUNCTION (LAMBDA (N)
+                                             (IPLUS N)))))
+              (GO XX))
+             (T (ERROR '"ARG NOT PREVIOUS VALUE OF RANDSET" X)))
+          (PROG ((\\OVERFLOW 0))
+                (DECLARE (SPECVARS \\OVERFLOW))
+                (SETQ RS
+                 (MAPCAR '(53375 47430 1274 55702 61592 27723 11236 16824 35838 62289 11525 37822 
+                                 34676 105 58750 27759 9988 4217 56951 30292 24550 1397 54588 54264 
+                                 43300 3862 39006 11386 52259 1055 955 16320 19910 58470 3263 64657 
+                                 1704 17373 56820 17255 51637 47962 26272 4464 2884 51773 39422 64835
+                                 57733 34919 5315 12110 15116 10133 10816)
+                        (FUNCTION (LAMBDA (Z)
+                                    (SETQ RS1 (LOGAND RS1 65535))
+                                    (LOGXOR Z (SETQ RS2 (PROG1 (LOGAND (IPLUS
+                                                                                (ITIMES RS1 19869
+                                                                                       )
+                                                                                RS1)
+                                                                          65535)
+                                                                   (SETQ RS1 RS2)))))))))
+      XX  (FRPLACD (LAST RS)
+                 RS)
+          (SETQ RANDSTATE (CONS RS (FNTH RS 31)))
+      OUT (RETURN (|for| X |in| (CAR RANDSTATE) |as| I |from| 1 |to| 55
+                     |collect| X)))))
+
+(RAND
+  (LAMBDA (LOWER UPPER)                                      (* \; "Edited  3-Sep-87 19:03 by jds")
+
+    (* |;;| "This function implements the XRAND subroutine described in Stanford memo STAN-CS-77-601, Analysis of Additive Random Number Generators, by John F.  Reiser, on p 28.0 Rather than storing the X values in an array and computing indexes I and J, however, I have elected to retain state in a circular list of 51 elements.  RANDSTATE is (CONS X (NTH X 31));  each time RAND is called, both CAR and CDR of RANDSTATE are CDR'ed to effectively increment the index.  In addition, the numbers are stored as 16 bit binary fractions (i.e.  the decimal point is on the left of the 16-bit quantity)")
+
+    (PROG (I J)
+          (OR (LISTP RANDSTATE)
+              (PROGN (RANDSET T)
+                     RANDSTATE))
+          (SETQ I (CDAR RANDSTATE))
+          (SETQ J (CDDR RANDSTATE))
+          (RPLNODE RANDSTATE I J)
+          (RPLACA I (LOGAND (IDIFFERENCE (CAR I)
+                                       (CAR J))
+                           MAX.SMALLP)))
+    (COND
+       ((NOT UPPER)
+        (COND
+           ((NULL LOWER)                                     (* \; 
+                 "both UPPER and LOWER nil.  Return number (0 (\\, MAX.SMALLP)) --- not documented")
+            (CAAR RANDSTATE))
+           ((ZEROP LOWER)                                (* \; "(RAND 0) = 0")
+            0)
+           ((FIXP LOWER)                                     (* \; "(RAND n) = (RAND 0 n-1)")
+            (IREMAINDER (CAAR RANDSTATE)
+                   LOWER))
+           (T                                                (* \; 
+                                                          "(RAND N) N floating.  Return (RAND 0 N)")
+              (FTIMES LOWER (FQUOTIENT (CAAR RANDSTATE)
+                                   (CONSTANT (FLOAT (ADD1 MAX.SMALLP))))))))
+       ((AND (FIXP LOWER)
+             (FIXP UPPER))
+        (OR (IGREATERP UPPER LOWER)
+            (|swap| UPPER LOWER))
+        (SETQ UPPER (IDIFFERENCE UPPER LOWER))
+        (COND
+           ((IGREATERP UPPER MAX.SMALLP)
+            (IPLUS (IMOD (\\MAKENUMBER (CAAR RANDSTATE)
+                                        (CADAR RANDSTATE))
+                              (ADD1 UPPER))
+                   LOWER))
+           (T (IPLUS (IREMAINDER (CAAR RANDSTATE)
+                                (ADD1 UPPER))
+                     LOWER))))
+       (T (FPLUS (FTIMES (FDIFFERENCE UPPER LOWER)
+                        (FQUOTIENT (CAAR RANDSTATE)
+                               (CONSTANT (FLOAT (ADD1 MAX.SMALLP)))))
+                 LOWER)))))
+
+(EXPT
+  (LAMBDA (A N)                                              (* \; "Edited  8-Apr-87 11:41 by jop")
+    (COND
+       ((FIXP N)
+        (COND
+           ((FIXP A)
+            (COND
+               ((NOT (IGREATERP N 0))
+                (COND
+                   ((EQ 0 N)
+                    1)
+                   (T (FEXPT A N))))
+               ((EQ 0 A)
+                0)
+               (T 
+                  (* |;;| "Integer EXPonentiation -- works by clever bit-dissection method")
+
+                  (PROG ((V 1))
+                    LP  (COND
+                           ((ODDP N)
+                            (SETQ V (TIMES A V))))
+                        (COND
+                           ((EQ 0 (SETQ N (RSH N 1)))
+                            (RETURN V)))
+                        (SETQ A (TIMES A A))
+                        (GO LP)))))
+           ((FEQP 0.0 (SETQ A (FLOAT A)))
+            (COND
+               ((EQ 0 N)
+                1.0)
+               (T 0.0)))
+           (T 
+              (* |;;| "Real EXPonentiation -- works by clever bit-dissection method")
+
+              (PROG ((V 1.0))
+                    (COND
+                       ((ILESSP N 0)
+                        (SETQ A (FQUOTIENT 1.0 A))
+                        (SETQ N (IMINUS N))))
+                LP  (COND
+                       ((ODDP N)
+                        (SETQ V (TIMES A V))))
+                    (COND
+                       ((EQ 0 (SETQ N (LRSH N 1)))
+                        (RETURN V)))
+                    (SETQ A (TIMES A A))
+                    (GO LP)))))
+       (T (FEXPT A N)))))
+)
+(DECLARE\: DONTEVAL@LOAD DOCOPY 
+
+(RPAQQ RANDSTATE NIL)
+
+(RPAQQ \\TOL 9.9999925E-6)
+)
+(DECLARE\: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS RANDSTATE \\TOL)
+)
+(DEFINEQ
+
+(|PutUnboxed|
+  (LAMBDA (PTR NUM)                                          (* |JonL| "25-JUL-83 02:29")
+    (\\PUTFIXP PTR NUM)))
+
+(\\PUTFIXP
+  (LAMBDA (PTR NUM)                                          (* |lmm| "11-DEC-80 15:10")
+    (PROG (HI LO)
+          (.UNBOX. NUM HI LO)
+          (|replace| (FIXP HINUM) |of| PTR |with| HI)
+          (|replace| (FIXP LONUM) |of| PTR |with| LO)
+          (RETURN NUM))))
+
+(\\PUTSWAPPEDFIXP
+  (LAMBDA (PTR NUM)                                          (* \; "Edited  8-Apr-87 11:41 by jop")
+
+    (* |;;| "store in MESA order rather than LISP order")
+
+    (PROG (HI LO)
+          (.UNBOX. NUM HI LO)
+          (|replace| (FIXP LONUM) |of| PTR |with| HI)
+          (|replace| (FIXP HINUM) |of| PTR |with| LO)
+          (RETURN NUM))))
+
+(\\HINUM
+  (LAMBDA (NUM)                                              (* |lmm| "12-APR-81 22:01")
+    (PROG (HI LO)
+          (.UNBOX. NUM HI LO)
+          (RETURN HI))))
+
+(\\LONUM
+  (LAMBDA (NUM)                                              (* |lmm| "12-APR-81 22:02")
+    (PROG (HI LO)
+          (.UNBOX. NUM HI LO)
+          (RETURN LO))))
+)
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE\: DONTCOPY 
+(DECLARE\: EVAL@COMPILE 
+
+(PUTPROPS |PutUnboxed| DMACRO (= . \\PUTFIXP))
+)
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA MIN MAX IMIN IMAX FMIN FMAX ODDP TIMES PLUS LOGXOR LOGOR LOGAND ITIMES IPLUS)
+)
+
+
+
+(* |;;| "ODDP redefined in cmlarith")
+
+(DEFINEQ
+
+(POWEROFTWOP
+  (LAMBDA (X)
+    (DECLARE (LOCALVARS . T))                            (* \; "Edited  8-Apr-87 11:42 by jop")
+
+    (* |;;| "Non-NIL iff arg is some power of 2")
+
+    (|if| (AND (EQ (SYSTEMTYPE)
+                       'D)
+                   (NOT (SMALLP X)))
+        |then| (AND (FIXP X)
+                        (IGREATERP X 0)
+                        (|if| (EQ (LOGAND X (CONSTANT (SUB1 (EXPT 2 16))))
+                                      0)
+                            |then| (POWEROFTWOP (RSH X 16))
+                          |else| (AND (EQ (RSH X 16)
+                                              0)
+                                          (.2^NP. (LOGAND X (SUB1 (EXPT 2 16)))))))
+      |else| (|if| (IGREATERP X 0)
+                     |then| (.2^NP. X)))))
+
+(IMOD
+  (LAMBDA (X N)                                              (* |lmm| "20-OCT-82 15:07")
+    (COND
+       ((IGEQ (SETQ X (IREMAINDER X N))
+               0)
+        X)
+       (T (IPLUS N X)))))
+
+(ODDP
+  (LISP:LAMBDA (LISP:NUMBER &OPTIONAL (MODULUS 2))           (* |lmm| "22-May-86 17:26")
+         (NOT (ZEROP (LISP:MOD LISP:NUMBER MODULUS)))))
+)
+(DECLARE\: DONTCOPY 
+(DECLARE\: EVAL@COMPILE 
+
+(PUTPROPS .2^NP. MACRO (OPENLAMBDA (X)
+                                      (EQ (LOGAND X (SUB1 X))
+                                          0)))
+)
+)
+
+
+
+(* \; "MIN and MAX")
+
+(DEFINEQ
+
+(FLESSP
+  (LAMBDA (X Y)
+    (FGREATERP Y X)))
+
+(FMAX
+  (LAMBDA K                                                  (* |bvm:| "14-Feb-85 23:48")
+    (COND
+       ((EQ K 0)
+        MIN.FLOAT)
+       (T (PROG ((J 1)
+                 (X (FLOAT (ARG K 1)))
+                 Y)
+                (OR (NUMBERP X)
+                    (ERRORX (LIST 10 X)))
+            LP  (COND
+                   ((EQ J K)
+                    (RETURN X)))
+                (ADD1VAR J)
+                (COND
+                   ((FGREATERP (SETQ Y (FLOAT (ARG K J)))
+                           X)
+                    (SETQ X Y)))
+                (GO LP))))))
+
+(FMIN
+  (LAMBDA K                                                  (* |bvm:| "14-Feb-85 23:49")
+    (COND
+       ((EQ K 0)
+        MAX.FLOAT)
+       (T (PROG ((J 1)
+                 (X (FLOAT (ARG K 1)))
+                 Y)
+                (OR (NUMBERP X)
+                    (ERRORX (LIST 10 X)))
+            LP  (COND
+                   ((EQ J K)
+                    (RETURN X)))
+                (ADD1VAR J)
+                (COND
+                   ((FGREATERP X (SETQ Y (FLOAT (ARG K J))))
+                    (SETQ X Y)))
+                (GO LP))))))
+
+(GEQ
+  (LAMBDA (X Y)
+    (NOT (LESSP X Y))))
+
+(IGEQ
+  (LAMBDA (X Y)
+    (NOT (ILESSP X Y))))
+
+(ILEQ
+  (LAMBDA (X Y)
+    (NOT (IGREATERP X Y))))
+
+(IMAX
+  (LAMBDA K                                                  (* |bvm:| "14-Feb-85 23:49")
+    (COND
+       ((EQ K 0)
+        MIN.INTEGER)
+       (T (PROG ((J 1)
+                 (X (ARG K 1)))
+            LP  (COND
+                   ((EQ J K)
+                    (RETURN X)))
+                (ADD1VAR J)
+                (COND
+                   ((ILESSP X (ARG K J))
+                    (SETQ X (ARG K J))))
+                (GO LP))))))
+
+(IMIN
+  (LAMBDA K                                                  (* |bvm:| "14-Feb-85 23:49")
+    (COND
+       ((EQ K 0)
+        MAX.INTEGER)
+       (T (PROG ((J 1)
+                 (X (ARG K 1)))
+            LP  (COND
+                   ((EQ J K)
+                    (RETURN X)))
+                (ADD1VAR J)
+                (COND
+                   ((IGREATERP X (ARG K J))
+                    (SETQ X (ARG K J))))
+                (GO LP))))))
+
+(LEQ
+  (LAMBDA (X Y)
+    (NOT (GREATERP X Y))))
+
+(MAX
+  (LAMBDA K                                                  (* |lmm| "12-Apr-85 08:42")
+    (COND
+       ((EQ K 0)
+        MIN.INTEGER)
+       (T (PROG ((J 1)
+                 (X (ARG K 1))
+                 Y)
+                (OR (NUMBERP X)
+                    (ERRORX (LIST 10 X)))
+            LP  (COND
+                   ((EQ J K)
+                    (RETURN X)))
+                (ADD1VAR J)
+                (COND
+                   ((GREATERP (SETQ Y (ARG K J))
+                           X)
+                    (SETQ X Y)))
+                (GO LP))))))
+
+(MIN
+  (LAMBDA K                                                  (* |lmm| "12-Apr-85 08:42")
+    (COND
+       ((EQ K 0)
+        MAX.INTEGER)
+       (T (PROG ((J 1)
+                 (X (ARG K 1))
+                 Y)
+                (OR (NUMBERP X)
+                    (ERRORX (LIST 10 X)))
+            LP  (COND
+                   ((EQ J K)
+                    (RETURN X)))
+                (ADD1VAR J)
+                (COND
+                   ((GREATERP X (SETQ Y (ARG K J)))
+                    (SETQ X Y)))
+                (GO LP))))))
+)
+(DECLARE\: EVAL@COMPILE 
+
+(ADDTOVAR GLOBALVARS MAX.INTEGER MIN.INTEGER MAX.FLOAT MIN.FLOAT)
+)
+(DECLARE\: DONTCOPY DOEVAL@COMPILE DONTEVAL@LOAD 
+(DECLARE\: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(PUTPROPS LLARITH COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 
+1990 1991 1993))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (4399 4855 (IDIFFERENCE 4409 . 4557) (IGREATERP 4559 . 4707) (IQUOTIENT 4709 . 4853)) 
+(4958 19432 (\\SLOWIPLUS2 4968 . 6552) (\\SLOWPLUS2 6554 . 7251) (\\SLOWIDIFFERENCE 7253 . 9595) (
+\\SLOWDIFFERENCE 9597 . 10323) (\\SLOWIGREATERP 10325 . 10861) (\\SLOWLLSH1 10863 . 11476) (
+\\SLOWLLSH8 11478 . 11922) (\\SLOWLOGAND2 11924 . 12320) (\\SLOWLOGOR2 12322 . 12713) (\\SLOWLOGXOR2 
+12715 . 13111) (\\SLOWLRSH1 13113 . 13563) (\\SLOWLRSH8 13565 . 13938) (\\SLOWITIMES2 13940 . 17651) (
+\\SLOWTIMES2 17653 . 18540) (\\SLOWIQUOTIENT 18542 . 18712) (\\SLOWQUOTIENT 18714 . 19430)) (19511 
+20902 (\\BOXIPLUS 19521 . 19708) (\\BOXIDIFFERENCE 19710 . 20900)) (20933 21553 (\\MAKENUMBER 20943 . 
+21551)) (21554 21843 (OVERFLOW 21564 . 21841)) (22198 23064 (\\GETBASEFIXP 22208 . 22482) (
+\\PUTBASEFIXP 22484 . 22770) (\\PUTBASEFIXP.UFN 22772 . 23062)) (32269 38354 (EQP 32279 . 32732) (FIX 
+32734 . 32907) (IQUOTIENT 32909 . 33053) (IREMAINDER 33055 . 33204) (LLSH 33206 . 34288) (LRSH 34290
+ . 35364) (LSH 35366 . 35973) (RSH 35975 . 36238) (\\RSH 36240 . 38352)) (48260 56883 (MINUSP 48270 . 
+48635) (ILESSP 48637 . 48690) (IMINUS 48692 . 48745) (IPLUS 48747 . 49470) (ITIMES 49472 . 50202) (
+LOGAND 50204 . 50934) (LOGOR 50936 . 51659) (LOGXOR 51661 . 52391) (SUB1 52393 . 52534) (ZEROP 52536
+ . 52723) (ADD1 52725 . 52860) (GCD 52862 . 53280) (IEQP 53282 . 53420) (INTEGERLENGTH 53422 . 56881))
+ (57085 60494 (ABS 57095 . 57820) (DIFFERENCE 57822 . 57979) (GREATERP 57981 . 58212) (PLUS 58214 . 
+58863) (QUOTIENT 58865 . 59252) (REMAINDER 59254 . 59480) (LESSP 59482 . 59710) (MINUS 59712 . 59919) 
+(TIMES 59921 . 60492)) (60495 60840 (FMINUS 60505 . 60635) (FREMAINDER 60637 . 60838)) (60841 67657 (
+RANDSET 60851 . 63290) (RAND 63292 . 66004) (EXPT 66006 . 67655)) (67821 69046 (|PutUnboxed| 67831 . 
+67972) (\\PUTFIXP 67974 . 68287) (\\PUTSWAPPEDFIXP 68289 . 68684) (\\HINUM 68686 . 68864) (\\LONUM 
+68866 . 69044)) (69477 70745 (POWEROFTWOP 69487 . 70358) (IMOD 70360 . 70579) (ODDP 70581 . 70743)) (
+70990 74478 (FLESSP 71000 . 71049) (FMAX 71051 . 71640) (FMIN 71642 . 72204) (GEQ 72206 . 72258) (IGEQ
+ 72260 . 72314) (ILEQ 72316 . 72373) (IMAX 72375 . 72830) (IMIN 72832 . 73290) (LEQ 73292 . 73347) (
+MAX 73349 . 73925) (MIN 73927 . 74476)))))
+STOP
diff --git a/CLTL2/LLARITH.LCOM b/CLTL2/LLARITH.LCOM
new file mode 100644
index 00000000..7f9a07da
Binary files /dev/null and b/CLTL2/LLARITH.LCOM differ
diff --git a/CLTL2/LLARRAYELT b/CLTL2/LLARRAYELT
new file mode 100644
index 00000000..889fa5e4
--- /dev/null
+++ b/CLTL2/LLARRAYELT
@@ -0,0 +1,2948 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "19-Jan-93 10:43:28" {DSK}<python>lde>lispcore>sources>LLARRAYELT.;2 154426 
+
+      changes to%:  (RECORDS HARRAYP HASHSLOT SEQUENCEDESCRIPTOR ARRAYP ARRAYBLOCK SAFTABLE)
+
+      previous date%: " 4-Jan-93 23:51:47" {DSK}<python>lde>lispcore>sources>LLARRAYELT.;1)
+
+
+(* ; "
+Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT LLARRAYELTCOMS)
+
+(RPAQQ LLARRAYELTCOMS 
+       [(PROPS (LLARRAYELT FILETYPE))
+        (COMS                                                (* ; "ARRAY entries")
+              (FNS AIN AOUT ARRAY ARRAYSIZE ARRAYTYP ARRAYORIG COPYARRAY)
+              (DECLARE%: DONTCOPY (MACROS ARRAYSIZE))
+              (FNS ELT ELTD SETA SETD SUBARRAY))
+        [COMS                                                (* ; "HASHARRAY entries")
+              (FNS HARRAY HASHARRAY HARRAYP HARRAYPROP HARRAYSIZE CLRHASH MAPHASH GETHASH PUTHASH 
+                   LISP::PUTHASH REMHASH \HASHRECLAIM \HASHACCESS REHASH \COPYHARRAYP 
+                   \HASHTABLE.DEFPRINT)
+              (FNS STRINGHASHBITS STRING-EQUAL-HASHBITS)
+              (FNS \STRINGHASHBITS-UFN \STRING-EQUAL-HASHBITS-UFN)
+              (DECLARE%: DONTCOPY (EXPORT (RECORDS HARRAYP)
+                                         (MACROS \EQHASHINGBITS))
+                     (RECORDS HASHSLOT)
+                     (MACROS \FIRSTINDEX \HASHSLOT \REPROBE)
+                     (CONSTANTS (CELLSPERSLOT 2))
+                     (GLOBALVARS \HASH.NULL.VALUE SYSHASHARRAY))
+              [DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'HARRAYP '\HASHTABLE.DEFPRINT]
+              (INITRECORDS HARRAYP)
+              (SYSRECORDS HARRAYP)
+              (VARS (\HASH.NULL.VALUE '\Hash\Null\Value\]
+        (COMS                                                (* ; "System entries for CODE")
+              (FNS \CODEARRAY \FIXCODENUM \FIXCODEPTR \FIXCODESYM))
+        (COMS                                                (* ; "Internal")
+              (DECLARE%: DONTCOPY (MACROS EQPTR BUCKETINDEX FREEBLOCKCHAIN.N)
+                     (CONSTANTS \MAXBUCKETINDEX)
+                                                             (* ; 
+                                "\ADDBASE2 and \ADDBASE4 do \ADDBASE of 2*N and 4*N without boxing")
+                     (EXPORT (MACROS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER \BYTELT \BYTESETA 
+                                    \WORDELT)
+                            (CONSTANTS * BLOCKGCTYPECONSTANTS)
+                            (CONSTANTS * ARRAYCONSTANTS)
+                            (CONSTANTS * ARRAYTYPES)
+                            (CONSTANTS \MAX.CELLSPERHUNK)
+                            (CONSTANTS (\IN.MAKEINIT))
+                            (RECORDS SEQUENCEDESCRIPTOR ARRAYP ARRAYBLOCK)
+                            (GLOBALVARS \NxtArrayPage \FREEBLOCKBUCKETS \HUNKING?))
+                     (GLOBALVARS \ArrayFrLst \ArrayFrLst2 \RECLAIM.COUNTDOWN))
+              (FNS \ALLOCBLOCK \MAIKO.ALLOCBLOCK \ALLOCBLOCK.OLD \ALLOCBLOCK.NEW \PREFIXALIGNMENT? 
+                   \MAKEFREEARRAYBLOCK \DELETEBLOCK? \LINKBLOCK \MERGEBACKWARD \MERGEFORWARD 
+                   \ARRAYBLOCKMERGER \#BLOCKDATACELLS \COPYARRAYBLOCK \RECLAIMARRAYBLOCK 
+                   \ADVANCE.ARRAY.SEGMENTS)
+              (ADDVARS (\MAIKO.MOVDS (\MAIKO.ALLOCBLOCK \ALLOCBLOCK)))
+              (FNS \BYTELT \BYTESETA \WORDELT)
+              (FNS \ARRAYTYPENAME)
+              (VARS (\ARRAYMERGING T))
+              (GLOBALVARS \ARRAYMERGING)
+              (COMS                                          (* ; "for STORAGE")
+                    (FNS \SHOW.ARRAY.FREELISTS)
+                    (INITVARS (\ABSTORAGETABLE NIL))
+                    (GLOBALVARS \ABSTORAGETABLE)
+                    (DECLARE%: DONTCOPY (RECORDS SAFTABLE)))
+              (COMS                                          (* ; "Debugging and RDSYS")
+                    (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE \PARSEARRAYSPACE1)
+                    (INITVARS (ARRAYBLOCKCHECKING))
+                    (GLOBALVARS ARRAYBLOCKCHECKING)))
+        (COMS                                                (* ; "Basic hunking")
+              (FNS \ALLOCHUNK)
+              (VARS \HUNK.PTRSIZES)
+                                                             (* ; 
+                                  "Compiler needs \HUNK.PTRSIZES for creating closure environments")
+              (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS HUNKSIZEFROMNUMBER))
+                     (CONSTANTS \HUNK.UNBOXEDSIZES \HUNK.CODESIZES \HUNK.PTRSIZES)
+                     (GLOBALVARS \HUNKING? \UNBOXEDHUNK.TYPENUM.TABLE \CODEHUNK.TYPENUM.TABLE 
+                            \PTRHUNK.TYPENUM.TABLE))
+              (COMS 
+                    (* ;; "Keep a list of all the hunks rejected due to poor page-straddling alignment, or to code falling off the end of a doublepage")
+
+                    (VARS (\HUNKREJECTS))
+                    (GLOBALVARS \HUNKREJECTS)))
+        [COMS                                                (* ; "for MAKEINIT")
+              (FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK 
+                   FILEPATCHBLOCK)
+              (COMS                                          (* ; "Hunk Initialization")
+                    (FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING 
+                         \SETUP.TYPENUM.TABLE))
+              (DECLARE%: DONTCOPY (ADDVARS (INITVALUES (\NxtArrayPage)
+                                                  (\HUNKING?))
+                                         (INITPTRS (\FREEBLOCKBUCKETS)
+                                                (\ArrayFrLst)
+                                                (\ArrayFrLst2)
+                                                (\UNBOXEDHUNK.TYPENUM.TABLE)
+                                                (\CODEHUNK.TYPENUM.TABLE)
+                                                (\PTRHUNK.TYPENUM.TABLE))
+                                         (INEWCOMS (FNS \#BLOCKDATACELLS \PREFIXALIGNMENT? 
+                                                        \ALLOCBLOCK \MAIKO.ALLOCBLOCK \ALLOCBLOCK.NEW
+                                                        \MAKEFREEARRAYBLOCK \MERGEBACKWARD \LINKBLOCK
+                                                        \ALLOCHUNK)
+                                                (FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE 
+                                                     FILEBLOCKTRAILER FILECODEBLOCK FILEPATCHBLOCK)
+                                                (FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS
+                                                     \TURN.ON.HUNKING \SETUP.TYPENUM.TABLE))
+                                         (MKI.SUBFNS (\IN.MAKEINIT . T)
+                                                (\ALLOCBLOCK.OLD . NILL)
+                                                (\MERGEFORWARD . NILL)
+                                                (\FIXCODENUM . I.FIXUPNUM)
+                                                (\FIXCODESYM . I.FIXUPSYM)
+                                                (\FIXCODEPTR . I.FIXUPPTR)
+                                                (\CHECKARRAYBLOCK . NILL)
+                                                (\ARRAYMERGING PROGN NIL))
+                                         (EXPANDMACROFNS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER 
+                                                BUCKETINDEX FREEBLOCKCHAIN.N)
+                                         (RDCOMS (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE 
+                                                      \PARSEARRAYSPACE1))
+                                         (RD.SUBFNS (EQPTR . EQUAL)
+                                                (ARRAYBLOCKCHECKING . T))
+                                         (RDPTRS (\FREEBLOCKBUCKETS))
+                                         (RDVALS (\ArrayFrLst)
+                                                (\ArrayFrLst2)))
+                     EVAL@COMPILE
+                     (ADDVARS (DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE 
+                                     FILEBLOCKTRAILER FILECODEBLOCK FILEPATCHBLOCK)
+                            (DONTCOMPILEFNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS 
+                                   \TURN.ON.HUNKING \SETUP.TYPENUM.TABLE]
+        (COMS                                                (* ; "Debugging aids")
+              (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \ArrayFrLst)
+                     (CONSTANTS \ArrayBlockPassword)
+                     (ADDVARS (DONTCOMPILEFNS \HUNKFIT? \AB.NEXT \AB.BACK)))
+              (FNS \HUNKFIT? \AB.NEXT \AB.BACK))
+        (LOCALVARS . T)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML)
+                                                                             (LAMA LISP::PUTHASH 
+                                                                                   HARRAYPROP])
+
+(PUTPROPS LLARRAYELT FILETYPE :BCOMPL)
+
+
+
+(* ; "ARRAY entries")
+
+(DEFINEQ
+
+(AIN
+  [LAMBDA (APTR INDEX N FILE)                            (* ; "Edited 23-Nov-86 16:44 by jop:")
+
+    (* ;; "Reads N elements into APTR starting at INDEX.  INDEX and N are in terms of the array's indexing units")
+
+    (COND
+       ((NOT (OR (STRINGP APTR)
+                 (ARRAYP APTR)))
+        (LISPERROR "ILLEGAL ARG" APTR))
+       ((IGREATERP 0 INDEX)
+        (LISPERROR "ILLEGAL ARG" INDEX)))
+    (LET (BASE LENGTH OFFST TYP ORIG STBYTE)
+         (if (STRINGP APTR)
+             then (SETQ BASE (ffetch (STRINGP BASE) of APTR))
+                   (SETQ LENGTH (ffetch (STRINGP LENGTH) of APTR))
+                   (SETQ OFFST (ffetch (STRINGP OFFST) of APTR))
+                   (SETQ TYP (ffetch (STRINGP TYP) of APTR))
+                   (SETQ ORIG 1)
+           else (SETQ BASE (ffetch (ARRAYP BASE) of APTR))
+                 (SETQ LENGTH (ffetch (ARRAYP LENGTH) of APTR))
+                 (SETQ OFFST (ffetch (ARRAYP OFFST) of APTR))
+                 (SETQ TYP (ffetch (ARRAYP TYP) of APTR))
+                 (SETQ ORIG (ffetch (ARRAYP ORIG) of APTR)))
+         (SETQ STBYTE (IDIFFERENCE INDEX ORIG))
+         (COND
+            ((ILESSP (SELECTC TYP
+                         ((LIST \ST.BYTE \ST.CODE) 
+                              LENGTH)
+                         (\ST.POS16 (SETQ OFFST (UNFOLD OFFST BYTESPERWORD))
+                                    (SETQ N (UNFOLD N BYTESPERWORD))
+                                    (SETQ STBYTE (UNFOLD STBYTE BYTESPERWORD))
+                                    (UNFOLD LENGTH BYTESPERWORD))
+                         ((LIST \ST.INT32 \ST.FLOAT) 
+                              (SETQ OFFST (UNFOLD OFFST BYTESPERCELL))
+                              (SETQ N (UNFOLD N BYTESPERCELL))
+                              (SETQ STBYTE (UNFOLD STBYTE BYTESPERCELL))
+                              (UNFOLD LENGTH BYTESPERCELL))
+                         (\ST.BIT)
+                         (LISPERROR "ILLEGAL ARG" APTR))
+                    (IPLUS STBYTE N))
+             (LISPERROR "ILLEGAL ARG" APTR)))
+         (\BINS (\GETOFD FILE 'INPUT)
+                BASE
+                (IPLUS STBYTE OFFST)
+                N)
+         APTR])
+
+(AOUT
+  [LAMBDA (APTR INDEX N FILE)                            (* ; "Edited 23-Nov-86 16:49 by jop:")
+                                                             (* ; 
+                                            "INDEX and N are in terms of the array's indexing unit")
+    (COND
+       ((NOT (OR (STRINGP APTR)
+                 (ARRAYP APTR)))
+        (LISPERROR "ILLEGAL ARG" APTR))
+       ((IGREATERP 0 INDEX)
+        (LISPERROR "ILLEGAL ARG" INDEX)))
+
+    (* ;; "Used to be in terms of the block record SEQUENCEDESCRIPTOR, but changed to refer explicitly to arrayp's and stringp's since stringp's no longer look like arrayp's")
+
+    (LET (BASE LENGTH OFFST TYP ORIG STBYTE)
+         (if (STRINGP APTR)
+             then (SETQ BASE (ffetch (STRINGP BASE) of APTR))
+                   (SETQ LENGTH (ffetch (STRINGP LENGTH) of APTR))
+                   (SETQ OFFST (ffetch (STRINGP OFFST) of APTR))
+                   (SETQ TYP (ffetch (STRINGP TYP) of APTR))
+                   (SETQ ORIG 1)
+           else (SETQ BASE (ffetch (ARRAYP BASE) of APTR))
+                 (SETQ LENGTH (ffetch (ARRAYP LENGTH) of APTR))
+                 (SETQ OFFST (ffetch (ARRAYP OFFST) of APTR))
+                 (SETQ TYP (ffetch (ARRAYP TYP) of APTR))
+                 (SETQ ORIG (ffetch (ARRAYP ORIG) of APTR)))
+         (SETQ STBYTE (IDIFFERENCE INDEX ORIG))              (* ; 
+                                                           "Standardize units before comparing")
+         (COND
+            ((ILESSP (SELECTC TYP
+                         ((LIST \ST.BYTE \ST.CODE) 
+                              LENGTH)
+                         (\ST.POS16 (SETQ N (UNFOLD N BYTESPERWORD))
+                                    (SETQ STBYTE (UNFOLD STBYTE BYTESPERWORD))
+                                    (SETQ OFFST (UNFOLD OFFST BYTESPERWORD))
+                                    (UNFOLD LENGTH BYTESPERWORD))
+                         ((LIST \ST.INT32 \ST.FLOAT) 
+                              (SETQ N (UNFOLD N BYTESPERCELL))
+                              (SETQ STBYTE (UNFOLD STBYTE BYTESPERCELL))
+                              (SETQ OFFST (UNFOLD OFFST BYTESPERCELL))
+                              (UNFOLD LENGTH BYTESPERCELL))
+                         (LISPERROR "ILLEGAL ARG" APTR))
+                    (IPLUS STBYTE N))
+             (LISPERROR "ILLEGAL ARG" APTR)))
+         (\BOUTS (\GETOFD FILE 'OUTPUT)
+                BASE
+                (IPLUS STBYTE OFFST)
+                N)
+         APTR])
+
+(ARRAY
+  [LAMBDA (SIZE TYPE INITVAL ORIG ALIGN)                 (* JonL "20-Sep-84 19:46")
+
+    (* ;; "extension of the normal VM definition of an array to allow many different TYPEs, and also allows ORIG of 0")
+
+    (SETQ SIZE (FIX SIZE))
+    (COND
+       ((OR (IGREATERP 0 SIZE)
+            (IGREATERP SIZE \MaxArrayLen))
+        (LISPERROR "ILLEGAL ARG" SIZE)))                     (* ; 
+                                                 "Coerce floats at outset;  \ALLOCARRAY wants fixp")
+    (PROG (AP TYP GCTYPE (NCELLS SIZE))
+          [SETQ TYP (SELECTQ TYPE
+                        (BYTE (SETQ NCELLS (FOLDHI SIZE BYTESPERCELL))
+                              \ST.BYTE)
+                        ((SMALLP SMALLPOSP WORD) 
+                             (SETQ NCELLS (FOLDHI SIZE WORDSPERCELL))
+                             \ST.POS16)
+                        ((NIL POINTER FLAG) 
+                             (SETQ GCTYPE PTRBLOCK.GCT)
+                             \ST.PTR)
+                        ((0 DOUBLEPOINTER)                   (* ; 
+                                               "INTERLISP-10 style arrays--each element is 2 cells")
+                             (SETQ NCELLS (UNFOLD SIZE 2))
+                             (SETQ GCTYPE PTRBLOCK.GCT)
+                             \ST.PTR2)
+                        (FIXP \ST.INT32)
+                        (FLOATP [COND
+                                   (INITVAL (SETQ INITVAL (FLOAT INITVAL]
+                                \ST.FLOAT)
+                        (BIT (SETQ NCELLS (FOLDHI SIZE BITSPERCELL))
+                             \ST.BIT)
+                        (SIGNEDWORD \ST.INT32)
+                        (COND
+                           ((EQ SIZE TYPE)                   (* ; "= FIXP")
+                            \ST.INT32)
+                           ((AND (LISTP TYPE)
+                                 (EQ (CAR TYPE)
+                                     'BITS))
+                            (COND
+                               ((IGREATERP (CADR TYPE)
+                                       16)
+                                \ST.INT32)
+                               ((IGREATERP (CADR TYPE)
+                                       8)
+                                (SETQ NCELLS (FOLDHI SIZE WORDSPERCELL))
+                                \ST.POS16)
+                               ((IGREATERP (CADR TYPE)
+                                       1)
+                                (SETQ NCELLS (FOLDHI SIZE BYTESPERCELL))
+                                \ST.BYTE)
+                               (T (SETQ NCELLS (FOLDHI SIZE BITSPERCELL))
+                                  \ST.BIT)))
+                           (T (\ILLEGAL.ARG TYPE]
+          (SETQ AP (create ARRAYP
+                          TYP _ TYP
+                          LENGTH _ SIZE
+                          ORIG _ (SELECTQ ORIG
+                                     ((0 1) 
+                                          ORIG)
+                                     (NIL 1)
+                                     (LISPERROR "ILLEGAL ARG" ORIG))
+                          OFFST _ 0
+                          BASE _ (\ALLOCBLOCK NCELLS GCTYPE NIL ALIGN)))
+          [AND INITVAL
+               (PROG ((BASE (fetch (ARRAYP BASE) of AP))
+                      (NWORDS (SUB1 (UNFOLD NCELLS WORDSPERCELL)))
+                      LASTWORD2BASE)
+                     (SETQ LASTWORD2BASE (\ADDBASE BASE (SUB1 NWORDS)))
+                     (SELECTC TYP
+                         (\ST.BYTE (OR (EQ 0 INITVAL)
+                                       (PROGN (\PUTBASE LASTWORD2BASE 1
+                                                     (create WORD
+                                                            HIBYTE _ INITVAL
+                                                            LOBYTE _ INITVAL))
+                                              (\BLT BASE (\ADDBASE BASE 1)
+                                                    NWORDS))))
+                         (\ST.POS16 (OR (EQ 0 INITVAL)
+                                        (PROGN (\PUTBASE LASTWORD2BASE 1 INITVAL)
+                                               (\BLT BASE (\ADDBASE BASE 1)
+                                                     NWORDS))))
+                         (\ST.INT32 [OR (EQ 0 INITVAL)
+                                        (PROGN (\PUTBASEFIXP LASTWORD2BASE 0 INITVAL)
+                                               (\BLT BASE (\ADDBASE BASE WORDSPERCELL)
+                                                     (SUB1 NWORDS])
+                         ((LIST \ST.PTR \ST.PTR2)            (* ; 
+                                    "Remove \ST.FLOAT when FLOATP is no longer stored in PTR mode.")
+                              [PROG ((P BASE))
+                                    (FRPTQ NCELLS (\RPLPTR P 0 INITVAL)
+                                           (SETQ P (\ADDBASE P WORDSPERCELL])
+                         (\ST.FLOAT [OR (FEQP 0.0 INITVAL)
+                                        (PROGN (\PUTBASEFLOATP LASTWORD2BASE 0 INITVAL)
+                                               (\BLT BASE (\ADDBASE BASE WORDSPERCELL)
+                                                     (SUB1 NWORDS])
+                         (\ST.BIT (OR (EQ 0 INITVAL)
+                                      (PROGN (\PUTBASE LASTWORD2BASE 1 MASKWORD1'S)
+                                             (\BLT BASE (\ADDBASE BASE 1)
+                                                   NWORDS))))
+                         (SHOULDNT]
+          (RETURN AP])
+
+(ARRAYSIZE
+  [LAMBDA (X)                                            (* JonL " 4-NOV-83 12:44")
+    (\MACRO.MX (ARRAYSIZE X])
+
+(ARRAYTYP
+  [LAMBDA (ARRAY)                                    (* rmk%: "30-Dec-83 13:12")
+
+    (* ;; "This is a VM function which returns valid 2nd argument to ARRAY")
+
+    (SELECTC (fetch (ARRAYP TYP) of (\DTEST ARRAY 'ARRAYP))
+        (\ST.BYTE 'BYTE)
+        (\ST.PTR2 'DOUBLEPOINTER)
+        (\ST.PTR 'POINTER)
+        (\ST.POS16 'SMALLPOSP)
+        (\ST.CODE                                            (* ; "not valid 2nd arg to ARRAY")
+                  'CODE)
+        (\ST.INT32 'FIXP)
+        (\ST.FLOAT 'FLOATP)
+        (\ST.BIT 'BIT)
+        (SHOULDNT])
+
+(ARRAYORIG
+  [LAMBDA (ARRAY)                                    (* rmk%: "30-Dec-83 13:12")
+    (fetch (ARRAYP ORIG) of (\DTEST ARRAY 'ARRAYP])
+
+(COPYARRAY
+  [LAMBDA (ARRAY)                                    (* JonL "16-Oct-84 20:38")
+    (COND
+       [(HARRAYP ARRAY)
+        (PROG [(NHARRAY (HASHARRAY (HARRAYSIZE ARRAY]
+              (\COPYHARRAYP ARRAY NHARRAY)
+              (RETURN (REHASH ARRAY NHARRAY]
+       (T (PROG (NEWARRAY INDEX (ORIG (ARRAYORIG ARRAY))
+                       (TYPE (ARRAYTYP ARRAY))
+                       (SIZE (ARRAYSIZE ARRAY)))
+                (SETQ NEWARRAY (ARRAY SIZE TYPE NIL ORIG))
+                (SETQ INDEX ORIG)
+                (FRPTQ SIZE (SETA NEWARRAY INDEX (ELT ARRAY INDEX))
+                       (add INDEX 1))
+                (SELECTQ TYPE
+                    ((DOUBLEPOINTER) 
+                         (SETQ INDEX ORIG)
+                         (FRPTQ SIZE (SETD NEWARRAY INDEX (ELTD ARRAY INDEX))
+                                (add INDEX 1)))
+                    NIL)
+                (RETURN NEWARRAY])
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+[PUTPROPS ARRAYSIZE DMACRO ((A)
+                            (ffetch (ARRAYP LENGTH) of (\DTEST A 'ARRAYP]
+)
+)
+(DEFINEQ
+
+(ELT
+  [LAMBDA (A N)                                          (* lmm " 7-Jun-84 17:53")
+    (\DTEST A 'ARRAYP)
+    (PROG [(BASE (fetch (ARRAYP BASE) of A))
+           (N0 (IDIFFERENCE N (fetch (ARRAYP ORIG) of A]
+          (COND
+             ((OR (IGREATERP 0 N0)
+                  (IGEQ N0 (fetch (ARRAYP LENGTH) of A)))
+              (LISPERROR "ILLEGAL ARG" N)))
+          (SETQ N0 (IPLUS N0 (fetch (ARRAYP OFFST) of A)))
+          (RETURN (SELECTC (fetch (ARRAYP TYP) of A)
+                      ((LIST \ST.PTR \ST.PTR2) 
+                           (\GETBASEPTR (\ADDBASE2 BASE N0)
+                                  0))
+                      (\ST.INT32 (SETQ BASE (\ADDBASE2 BASE N0))
+                                 (\MAKENUMBER (\GETBASE BASE 0)
+                                        (\GETBASE BASE 1)))
+                      ((LIST \ST.BYTE \ST.CODE) 
+                           (\GETBASEBYTE BASE N0))
+                      (\ST.POS16 (\GETBASE BASE N0))
+                      (\ST.BIT (LOGAND (LRSH (\GETBASE BASE (FOLDLO N0 BITSPERWORD))
+                                             (IDIFFERENCE (SUB1 BITSPERWORD)
+                                                    (IMOD N0 BITSPERWORD)))
+                                      1))
+                      (\ST.FLOAT (\GETBASEFLOATP BASE (UNFOLD N0 WORDSPERCELL)))
+                      (LISPERROR "ILLEGAL ARG" A])
+
+(ELTD
+  [LAMBDA (A N)                                          (* rmk%: "30-Dec-83 13:13")
+    (\DTEST A 'ARRAYP)
+    (SELECTC (fetch (ARRAYP TYP) of A)
+        (\ST.PTR2 (PROG [(BASE (fetch (ARRAYP BASE) of A))
+                         (N0 (IDIFFERENCE N (fetch (ARRAYP ORIG) of A]
+                        (COND
+                           ((OR (IGREATERP 0 N0)
+                                (IGEQ N0 (fetch (ARRAYP LENGTH) of A)))
+                            (LISPERROR "ILLEGAL ARG" N)))
+                        (SETQ N0 (IPLUS N0 (fetch (ARRAYP OFFST) of A)))
+                        (RETURN (\GETBASEPTR (\ADDBASE2 (\ADDBASE2 BASE (fetch (ARRAYP LENGTH)
+                                                                           of A))
+                                                    N0)
+                                       0))))
+        (ELT A N])
+
+(SETA
+  [LAMBDA (A N V)                                        (* bvm%: " 6-Feb-85 15:54")
+    (COND
+       ([fetch (ARRAYP READONLY) of (SETQ A (\DTEST A 'ARRAYP]
+        (LISPERROR "ILLEGAL ARG" A)))
+    (PROG [(BASE (fetch (ARRAYP BASE) of A))
+           (N0 (IDIFFERENCE N (fetch (ARRAYP ORIG) of A]
+          (COND
+             ((OR (ILESSP N0 0)
+                  (IGEQ N0 (fetch (ARRAYP LENGTH) of A)))
+              (LISPERROR "ILLEGAL ARG" N)))
+          (SETQ N0 (IPLUS N0 (fetch (ARRAYP OFFST) of A)))
+          (RETURN (SELECTC (fetch (ARRAYP TYP) of A)
+                      ((LIST \ST.PTR \ST.PTR2) 
+                           (\RPLPTR (\ADDBASE2 BASE N0)
+                                  0 V))
+                      (\ST.INT32                             (* ; "32-bit 2's complement integers")
+                                 (\PUTBASEFIXP (\ADDBASE2 BASE N0)
+                                        0 V))
+                      ((LIST \ST.BYTE \ST.CODE) 
+                           (\PUTBASEBYTE BASE N0 V))
+                      (\ST.POS16                             (* ; "Unsigned 16-bit numbers")
+                                 (\PUTBASE BASE N0 V))
+                      (\ST.BIT [\PUTBASE BASE (FOLDLO N0 BITSPERWORD)
+                                      (COND
+                                         [(EQ 0 V)
+                                          (LOGAND (\GETBASE BASE (FOLDLO N0 BITSPERWORD))
+                                                 (LOGXOR (LLSH 1 (IDIFFERENCE (SUB1 BITSPERWORD)
+                                                                        (IMOD N0 BITSPERWORD)))
+                                                        (SUB1 (LLSH 1 BITSPERWORD]
+                                         (T (LOGOR (\GETBASE BASE (FOLDLO N0 BITSPERWORD))
+                                                   (LLSH 1 (IDIFFERENCE (SUB1 BITSPERWORD)
+                                                                  (IMOD N0 BITSPERWORD]
+                               V)
+                      (\ST.FLOAT (\PUTBASEFLOATP BASE (UNFOLD N0 WORDSPERCELL)
+                                        (FLOAT V)))
+                      (LISPERROR "ILLEGAL ARG" A])
+
+(SETD
+  [LAMBDA (A N V)                                        (* rmk%: "30-Dec-83 13:14")
+    (\DTEST A 'ARRAYP)
+    (SELECTC (fetch (ARRAYP TYP) of A)
+        (\ST.PTR2 (COND
+                     ((fetch (ARRAYP READONLY) of A)
+                      (LISPERROR "ILLEGAL ARG" A)))
+                  (PROG [(BASE (fetch (ARRAYP BASE) of A))
+                         (N0 (IDIFFERENCE N (fetch (ARRAYP ORIG) of A]
+                        (COND
+                           ((OR (IGREATERP 0 N0)
+                                (IGEQ N0 (fetch (ARRAYP LENGTH) of A)))
+                            (LISPERROR "ILLEGAL ARG" N)))
+                        (SETQ N0 (IPLUS N0 (fetch (ARRAYP OFFST) of A)))
+                        (\RPLPTR (\ADDBASE2 (\ADDBASE2 BASE (fetch (ARRAYP LENGTH) of A))
+                                        N0)
+                               0 V)
+                        (RETURN V)))
+        (SETA A N V])
+
+(SUBARRAY
+  [LAMBDA (X N M OLD NEWORIG)                            (* rmk%: "30-Dec-83 13:15")
+    (\DTEST X 'ARRAYP)
+    (PROG ((LEN (fetch (ARRAYP LENGTH) of X))
+           (ORIG (fetch (ARRAYP ORIG) of X))
+           (N1 N)
+           (M1 M))                                           (* ; 
+                                                           "N1 and M1 so don't reset user arg")
+          [COND
+             ((IGREATERP 0 N1)                               (* ; "Coerce the first index")
+              (SETQ N1 (IPLUS N1 LEN 1]
+          [COND
+             ((NULL M1)                                      (* ; "Now coerce the second index")
+              (SETQ M1 LEN))
+             ((IGREATERP 0 M1)
+              (SETQ M1 (IPLUS M1 LEN 1]                      (* ; 
+                                                 "Go uninterruptable to protect the OLD~=NIL case.")
+          (RETURN (AND (IGEQ N1 ORIG)
+                       (ILEQ N1 M1)
+                       (ILEQ M1 LEN)
+                       (UNINTERRUPTABLY
+                           (create ARRAYP smashing (OR (ARRAYP OLD)
+                                                               (create ARRAYP))
+                                                    BASE _ (fetch (ARRAYP BASE) of X)
+                                                    LENGTH _ (ADD1 (IDIFFERENCE M1 N1))
+                                                    TYP _ (fetch (ARRAYP TYP) of X)
+                                                    OFFST _ (IDIFFERENCE (IPLUS (fetch
+                                                                                 (ARRAYP OFFST)
+                                                                                   of X)
+                                                                                N1)
+                                                                   ORIG)
+                                                    ORIG _ ORIG))])
+)
+
+
+
+(* ; "HASHARRAY entries")
+
+(DEFINEQ
+
+(HARRAY
+  [LAMBDA (MINKEYS)                                      (* rmk%: " 3-Jan-84 13:09")
+
+    (* ;; "For backward compatibility--produces a non-growing hasharray")
+
+    (HASHARRAY MINKEYS 'ERROR])
+
+(HASHARRAY
+  [LAMBDA (MINKEYS OVERFLOW HASHBITSFN EQUIVFN RECLAIMABLE REHASH-THRESHOLD)
+                                                             (* ; "Edited  3-Oct-91 13:35 by jds")
+
+    (* ;; "MINKEYS is the number of required slots;  actual number of slots is greater by the vacancy factor REHASH-THRESHOLD default 0.75 --- MINKEYS is first adjusted by the vacancy factor, then bumped up to the next highest power of 2, so that hashkey can be computed with LOGAND instead of IREMAINDER.")
+
+    [COND
+       ((FIXP REHASH-THRESHOLD)                              (* ; "Scale it")
+        (SETQ REHASH-THRESHOLD (AND (FIXP OVERFLOW)
+                                    (ILESSP REHASH-THRESHOLD OVERFLOW)
+                                    (FQUOTIENT REHASH-THRESHOLD OVERFLOW]
+    (LET ((PHYSLOTS (OR (bind [IDEALSIZE _ (IMAX MINKEYS
+                                                     (IMIN (- (FOLDLO \MaxArrayNCells CELLSPERSLOT)
+                                                              2)
+                                                           (COND
+                                                              (REHASH-THRESHOLD
+                                                               (FIXR (FQUOTIENT (SUB1 MINKEYS)
+                                                                            REHASH-THRESHOLD)))
+                                                              (T (LLSH (IQUOTIENT (SUB1 MINKEYS)
+                                                                              3)
+                                                                       2] find I from 8
+                           to 16384 by I suchthat (IGREATERP I IDEALSIZE))
+                        [for I from [IMAX MINKEYS (IMIN 32749 (- (FOLDLO \MaxArrayNCells 
+                                                                                CELLSPERSLOT)
+                                                                         2)
+                                                                (COND
+                                                                   (REHASH-THRESHOLD
+                                                                    (FIXR (FQUOTIENT (SUB1 MINKEYS)
+                                                                                 REHASH-THRESHOLD)))
+                                                                   (T (LLSH (IQUOTIENT (SUB1 MINKEYS)
+                                                                                   3)
+                                                                            2] to 32749
+                           suchthat 
+
+                                 (* ;; "Find a prime table-size between our ideal and the maximum, which is 32749 (largest prime < array limit)")
+
+                                 (for J from 2 to (FIXR (SQRT I))
+                                    never (ZEROP (IREMAINDER I J]
+                        32768))
+          LOGSLOTS NCELLS)
+         (SETQ NCELLS (UNFOLD PHYSLOTS CELLSPERSLOT))
+         (COND
+            ((IGREATERP NCELLS \MaxArrayNCells)
+             (ERROR "HARRAY TOO LARGE" MINKEYS))
+            (T [SETQ LOGSLOTS (COND
+                                 (REHASH-THRESHOLD (FIXR (FTIMES REHASH-THRESHOLD PHYSLOTS)))
+                                 (T (IPLUS (LRSH PHYSLOTS 1)
+                                           (LRSH PHYSLOTS 2] (* ; 
+                           "Number of logical slots is REHASH-THRESHOLD * number of physical slots")
+               (create HARRAYP
+                      HARRAYPBASE _ (\ALLOCBLOCK NCELLS PTRBLOCK.GCT)
+                      LASTINDEX _ (SUB1 PHYSLOTS)
+                      RECLAIMABLE _ RECLAIMABLE
+                      OVERFLOWACTION _ OVERFLOW
+                      NUMSLOTS _ LOGSLOTS
+                      NULLSLOTS _ LOGSLOTS
+                      NUMKEYS _ 0
+                      HASHBITSFN _ HASHBITSFN
+                      EQUIVFN _ EQUIVFN])
+
+(HARRAYP
+  [LAMBDA (X)                                            (* rmk%: "21-Dec-83 22:20")
+    (AND (type? HARRAYP X)
+         X])
+
+(HARRAYPROP
+  [LAMBDA NARGS                                          (* bvm%: "21-Jan-86 11:02")
+                                                             (* ; 
+                                        "Nospread so we can tell whether a new value was specified")
+    (PROG ((HARRAY (AND (IGREATERP NARGS 0)
+                            (ARG NARGS 1)))
+           (PROP (AND (IGREATERP NARGS 1)
+                      (ARG NARGS 2)))
+           (NEWVALP (IGREATERP NARGS 2))
+           HA NEWVALUE)
+          (SETQ HA (\DTEST HARRAY 'HARRAYP))                 (* ; 
+                                                    "Keep HARRAY explicitly so can tell LISTP case")
+          (AND NEWVALP (SETQ NEWVALUE (ARG NARGS 3)))
+          [RETURN (SELECTQ PROP
+                      (SIZE (AND NEWVALP (GO CANTUPDATE))
+                            (HARRAYSIZE HA))
+                      (OVERFLOW [COND
+                                   [(LISTP HARRAY)           (* ; 
+                                  "For compatibility with old code that would enlist the hasharray")
+                                    (PROG1 (CDR HARRAY)
+                                        (AND NEWVALP (RPLACD HARRAY NEWVALUE)))]
+                                   (T (PROG1 (fetch (HARRAYP OVERFLOWACTION) of HA)
+                                          (AND NEWVALP (replace (HARRAYP OVERFLOWACTION)
+                                                          of HA with NEWVALUE)))])
+                      (NUMKEYS (AND NEWVALP (GO CANTUPDATE))
+                               (fetch (HARRAYP NUMKEYS) of HA))
+                      (EQUIVFN (PROG1 (fetch (HARRAYP EQUIVFN) of HA)
+                                   [AND NEWVALP (COND
+                                                   ((NEQ (fetch (HARRAYP NUMKEYS)
+                                                            of HA)
+                                                         0)  (* ; 
+                                               "Absurd to change equivalence relation in midstream")
+                                                    (GO CANTUPDATE))
+                                                   (T (replace (HARRAYP EQUIVFN) of
+                                                                                         HA
+                                                         with NEWVALUE]))
+                      (RECLAIMABLE (PROG1 (fetch (HARRAYP RECLAIMABLE) of HA)
+                                       (AND NEWVALP (replace (HARRAYP RECLAIMABLE)
+                                                       of HA with NEWVALUE))))
+                      (HASHBITSFN (PROG1 (fetch (HARRAYP HASHBITSFN) of HA)
+                                      [AND NEWVALP (COND
+                                                      ((NEQ (fetch (HARRAYP NUMKEYS)
+                                                               of HA)
+                                                            0)
+                                                       (GO CANTUPDATE))
+                                                      (T (replace (HARRAYP HASHBITSFN)
+                                                            of HA with NEWVALUE]))
+                      (PROG1 (LISTGET (SETQ HARRAY (fetch (HARRAYP HASHUSERDATA) of
+                                                                                         HA))
+                                    PROP)
+                          [AND NEWVALP (COND
+                                          ((NULL HARRAY)
+                                           (replace (HARRAYP HASHUSERDATA) of HA
+                                              with (LIST PROP NEWVALUE)))
+                                          (T (LISTPUT HARRAY PROP NEWVALUE])]
+      CANTUPDATE
+          (ERROR "Can't update this hash array property" PROP])
+
+(HARRAYSIZE
+  [LAMBDA (HARRAY)                                   (* rmk%: "21-Dec-83 23:33")
+    (fetch NUMSLOTS of (\DTEST HARRAY 'HARRAYP])
+
+(CLRHASH
+  [LAMBDA (HARRAY)                                   (* bvm%: "21-Jan-86 11:32")
+    (PROG ((HA (\DTEST HARRAY 'HARRAYP))
+           SLOT)
+          (SETQ SLOT (fetch HARRAYPBASE of HA))
+          (UNINTERRUPTABLY
+              (bind [LASTSLOT _ (fetch (HASHSLOT NEXTSLOT) of (\HASHSLOT
+                                                                           SLOT
+                                                                           (fetch (HARRAYP
+                                                                                       LASTINDEX)
+                                                                              of HA]
+                 do (replace (HASHSLOT KEY) of SLOT with NIL)
+                       (replace (HASHSLOT VALUE) of SLOT with NIL)
+                 repeatuntil (EQ (SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT))
+                                     LASTSLOT))
+              (replace (HARRAYP NULLSLOTS) of HA with (fetch (HARRAYP 
+                                                                                        NUMSLOTS)
+                                                                         of HA))
+              (replace (HARRAYP NUMKEYS) of HA with 0))
+          (RETURN HARRAY])
+
+(MAPHASH
+  [LAMBDA (HARRAY MAPHFN)                            (* bvm%: "21-Jan-86 11:28")
+    (DECLARE (LOCALVARS . T))
+    (LET ((HA (\DTEST HARRAY 'HARRAYP))
+          SLOT)
+         (SETQ SLOT (fetch HARRAYPBASE of HA))
+         (bind V [LASTSLOT _ (fetch (HASHSLOT NEXTSLOT) of (\HASHSLOT SLOT
+                                                                              (fetch (HARRAYP
+                                                                                          LASTINDEX)
+                                                                                 of HA]
+                (NULLVALUE _ \HASH.NULL.VALUE) when (SETQ V (fetch (HASHSLOT VALUE)
+                                                                   of SLOT))
+            do (APPLY* MAPHFN (AND (NEQ V NULLVALUE)
+                                       V)
+                          (fetch (HASHSLOT KEY) of SLOT))
+            repeatuntil (EQ (SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT))
+                                LASTSLOT) finally (RETURN HARRAY])
+
+(GETHASH
+  [LAMBDA (ITEM HARRAY DEFAULT RETURNMVS)                (* ; "Edited 26-Feb-91 13:07 by jds")
+
+(* ;;; "RETURNMVS, if true return multiple values, else don't.")
+
+    (PROG ((HA (\DTEST HARRAY 'HARRAYP))
+           INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT BITS EQFN ABASE VALUE)
+          [SETQ BITS (COND
+                        ((SETQ BITS (fetch (HARRAYP HASHBITSFN) of HA))
+                         (APPLY* BITS ITEM))
+                        (T (\EQHASHINGBITS ITEM]
+          (SETQ INDEX (\FIRSTINDEX BITS HA))                 (* ; 
+                           "Do first index outside of loop, so don't have to do setup on fast case")
+          (SETQ ABASE (fetch HARRAYPBASE of HA))
+          (SETQ SLOT (\HASHSLOT ABASE INDEX))
+          [COND
+             ((SETQ VALUE (fetch (HASHSLOT VALUE) of SLOT))
+                                                             (* ; "Slot is occupied")
+              (COND
+                 ((OR (EQ ITEM (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT)))
+                      (AND (SETQ EQFN (fetch (HARRAYP EQUIVFN) of HA))
+                           (APPLY* EQFN ITEM SKEY)))
+                  (GO FOUND)))                               (* ; "else try again")
+              )
+             [(NULL (fetch (HASHSLOT KEY) of SLOT))  (* ; "Null slot")
+              (RETURN (COND
+                         (RETURNMVS (LISP:VALUES DEFAULT NIL))
+                         (T DEFAULT]
+             (T                                              (* ; 
+                                                           "Deleted slot: null value, non-nil key")
+                (SETQ EQFN (fetch (HARRAYP EQUIVFN) of HA]
+                                                             (* ; "Perhaps we hit right on")
+          (SETQ FIRSTINDEX INDEX)
+          (SETQ REPROBE (\REPROBE BITS HA))                  (* ; "Compute reprobe interval")
+          (SETQ LIMIT (ADD1 (fetch (HARRAYP LASTINDEX) of HA)))
+      LP  (SETQ INDEX (IREMAINDER (IPLUS INDEX REPROBE)
+                             LIMIT))
+
+     (* ;; "Since table size is a power of two, any wraparound in the IPLUS16 will be consistent with the LOGAND")
+
+          (COND
+             ((EQ INDEX FIRSTINDEX)                          (* ; 
+                                         "Should never happen, since we don't allow full occupancy")
+              (SHOULDNT "Hashing in full hash table")))
+          (SETQ SLOT (\HASHSLOT ABASE INDEX))
+          (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT))
+          [COND
+             [(SETQ VALUE (fetch (HASHSLOT VALUE) of SLOT))
+                                                             (* ; "Slot is occupied")
+              (COND
+                 ((OR (EQ (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT))
+                          ITEM)
+                      (AND EQFN (APPLY* EQFN ITEM SKEY)))    (* ; "Found it")
+                  (GO FOUND]
+             ((NULL (fetch (HASHSLOT KEY) of SLOT))  (* ; "Empty slot")
+              (RETURN (COND
+                         (RETURNMVS (LISP:VALUES DEFAULT NIL))
+                         (T DEFAULT]
+          (GO LP)
+      FOUND
+          (RETURN (COND
+                     (RETURNMVS (LISP:VALUES (AND (NEQ VALUE \HASH.NULL.VALUE)
+                                                VALUE)
+                                       T))
+                     (T (AND (NEQ VALUE \HASH.NULL.VALUE)
+                             VALUE])
+
+(PUTHASH
+  [LAMBDA (KEY VAL HARRAY)                               (* raf "22-Aug-86 16:55")
+
+(* ;;; "Store new value VAL, or remove old value if VAL = NIL")
+
+    (\HASHACCESS KEY VAL HARRAY (NULL VAL))
+    VAL])
+
+(LISP::PUTHASH
+  (LISP:LAMBDA (KEY LISP:HASH-TABLE VALUE &OPTIONAL (EXTRA NIL EXTRA-P))
+                                                             (* ; "Edited 23-Mar-87 12:00 by bvm:")
+
+         (* ;; "SETF inverse for LISP:GETHASH.  Subtlety is that LISP:GETHASH has an optional arg DEFAULT, so if you passed one of those 3-argument forms to SETF, you'd get 4 arguments in this call.  In this case, the fourth argument is the new value and you should ignore the third.")
+
+         (LISP:CHECK-TYPE LISP:HASH-TABLE LISP:HASH-TABLE)
+         (\HASHACCESS KEY (LISP:IF EXTRA-P
+                                  EXTRA
+                                  VALUE)
+                LISP:HASH-TABLE NIL)
+         VALUE))
+
+(REMHASH
+  [LAMBDA (KEY HARRAY)                                   (* bvm%: "20-Jan-86 18:54")
+    (\HASHACCESS KEY NIL HARRAY T])
+
+(\HASHRECLAIM
+  [LAMBDA (HARRAY)                                   (* bvm%: "21-Jan-86 11:36")
+
+(* ;;; "Remove from HARRAY any keys whose ref cnt is 1")
+
+    (PROG ((HA (\DTEST HARRAY 'HARRAYP))
+           SLOT)
+          (SETQ SLOT (fetch (HARRAYP HARRAYPBASE) of HA))
+          (UNINTERRUPTABLY
+              (bind KEY [LASTSLOT _ (fetch (HASHSLOT NEXTSLOT)
+                                           of (\HASHSLOT SLOT (fetch (HARRAYP LASTINDEX)
+                                                                     of HA]
+                     (NUMDELETED _ 0) when (AND (SETQ KEY (fetch (HASHSLOT KEY) of SLOT))
+                                                    (NEQ KEY T)
+                                                    (\EQREFCNT1 KEY))
+                 do                                      (* ; 
+                                           "Slot is occupied with key with ref cnt 1, so delete it")
+                       (replace (HASHSLOT KEY) of SLOT with T)
+                       (replace (HASHSLOT VALUE) of SLOT with NIL)
+                       (add NUMDELETED 1) repeatuntil (EQ LASTSLOT (SETQ SLOT
+                                                                            (fetch (HASHSLOT
+                                                                                        NEXTSLOT)
+                                                                               of SLOT)))
+                 finally (replace (HARRAYP NUMKEYS) of HA
+                                with (IDIFFERENCE (fetch (HARRAYP NUMKEYS) of HA)
+                                                NUMDELETED))))
+          (RETURN HARRAY])
+
+(\HASHACCESS
+  [LAMBDA (ITEM VAL HARRAY REMOVE)                       (* ; "Edited 26-Feb-91 13:16 by jds")
+
+(* ;;; "Add or remove something from hash array HARRAY -- REMOVE = T means remove the item, which is necessarily distinct from adding a VAL = NIL")
+
+    (PROG ((HA (\DTEST HARRAY 'HARRAYP))
+           DELSLOT INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT BITS HASHBITSFN EQFN ABASE)
+          [SETQ BITS (COND
+                        ((SETQ HASHBITSFN (fetch (HARRAYP HASHBITSFN) of HA))
+                         (APPLY* HASHBITSFN ITEM))
+                        (T (\EQHASHINGBITS ITEM]
+      PHTOP
+          (SETQ INDEX (\FIRSTINDEX BITS HA))                 (* ; 
+                                                  "Handle first probe outside loop in case it wins")
+          (SETQ ABASE (fetch HARRAYPBASE of HA))
+          (SETQ SLOT (\HASHSLOT ABASE INDEX))
+          [COND
+             ((fetch (HASHSLOT VALUE) of SLOT)       (* ; "Slot is occupied")
+              (COND
+                 ((OR (EQ ITEM (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT)))
+                      (AND (SETQ EQFN (fetch (HARRAYP EQUIVFN) of HA))
+                           (APPLY* EQFN ITEM SKEY)))
+                  (GO FOUND)))                               (* ; "else try again")
+              )
+             ((NULL (fetch (HASHSLOT KEY) of SLOT))  (* ; "Null slot")
+              (GO ADDNEWENTRY))
+             (T                                              (* ; 
+                                                           "Deleted slot: null value, non-nil key")
+                (SETQ DELSLOT SLOT)
+                (SETQ EQFN (fetch (HARRAYP EQUIVFN) of HA]
+          (SETQ FIRSTINDEX INDEX)
+          (SETQ REPROBE (\REPROBE BITS HA))
+          (SETQ LIMIT (ADD1 (fetch (HARRAYP LASTINDEX) of HA)))
+      LP  (SETQ INDEX (IREMAINDER (IPLUS INDEX REPROBE)
+                             LIMIT))
+          (COND
+             ((EQ INDEX FIRSTINDEX)
+
+              (* ;; "We don't allow full occupancy, so if we get to the beginning without finding an empty slot, we must have found a deleted one")
+
+              (SETQ SLOT (OR DELSLOT (ERROR "No vacant slot in hasharray")))
+              (GO ADDNEWENTRY)))
+          (SETQ SLOT (\HASHSLOT ABASE INDEX))
+          [COND
+             [(fetch (HASHSLOT VALUE) of SLOT)       (* ; "Slot is occupied")
+              (COND
+                 ((OR (EQ (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT))
+                          ITEM)
+                      (AND EQFN (APPLY* EQFN ITEM SKEY)))    (* ; "Found it")
+                  (GO FOUND]
+             (T (COND
+                   ((NULL (fetch (HASHSLOT KEY) of SLOT))
+
+                    (* ;; "NIL as both key and value means empty slot.  New entry goes here, unless there was an earlier deleted slot")
+
+                    (AND DELSLOT (SETQ SLOT DELSLOT))
+                    (GO ADDNEWENTRY))
+                   ((NULL DELSLOT)                           (* ; 
+                                                         "Key non-NIL but value NIL means deleted.")
+                    (SETQ DELSLOT SLOT]
+          (GO LP)
+      FOUND
+          (UNINTERRUPTABLY
+              [COND
+                 (REMOVE                                     (* ; 
+                                           "Deleted slots are noted by value = NIL and key non-NIL")
+                        (replace (HASHSLOT KEY) of SLOT with T)
+                        (replace (HASHSLOT VALUE) of SLOT with NIL)
+                        (add (fetch (HARRAYP NUMKEYS) of HA)
+                               -1))
+                 (T 
+                    (* ;; "If writing value NIL must write distinguished non-NIL value.  Ultimately, this should be a non-interned symbol, so that nobody could mistakenly type it (!) but it still wouldn't be ref counted (in present world)")
+
+                    (replace (HASHSLOT VALUE) of SLOT with (OR VAL \HASH.NULL.VALUE])
+          (RETURN T)
+      ADDNEWENTRY
+                                                             (* ; 
+                                  "Didn't find this item in table.  If REMOVE is T, nothing to do.")
+          (COND
+             (REMOVE (RETURN NIL)))
+          (COND
+             ((EQ 0 (fetch (HARRAYP NULLSLOTS) of HA))
+              (COND
+                 ((fetch (HARRAYP RECLAIMABLE) of HA)
+                                                             (* ; 
+                                                 "Before rehashing, remove anything with ref cnt 1")
+                  (\HASHRECLAIM HA)))
+              (SETQ HARRAY (HASHOVERFLOW (OR HARRAY SYSHASHARRAY)))
+              (SETQ HA (\DTEST HARRAY 'HARRAYP))
+
+              (* ;; "ERRORX2 doesn't handle SYSHASHARRAY specially;  on 10, SYSHASHARRAY is rehashed directly in PUTHASH, without going through ERRORX2 and independent of the normal LISTP conventions.")
+
+              (SETQ DELSLOT NIL)                             (* ; 
+                                                  "Non-NIL DELSLOT is a pointer into the old array")
+              (GO PHTOP)))
+          (UNINTERRUPTABLY
+              (OR (EQ SLOT DELSLOT)
+                  (add (fetch (HARRAYP NULLSLOTS) of HA)
+                         -1))
+              (add (fetch (HARRAYP NUMKEYS) of HA)
+                     1)
+              (replace (HASHSLOT KEY) of SLOT with ITEM)
+              (replace (HASHSLOT VALUE) of SLOT with (OR VAL \HASH.NULL.VALUE)))
+          (RETURN VAL])
+
+(REHASH
+  [LAMBDA (OLDAR NEWAR)                                  (* rmk%: "26-Dec-83 11:50")
+    (CLRHASH NEWAR)
+    (PROG [SLOT LASTSLOT V (APTR1 (\DTEST OLDAR 'HARRAYP]    (* ; "This is maphash expanded out")
+          (SETQ SLOT (fetch HARRAYPBASE of APTR1))
+          (SETQ LASTSLOT (\ADDBASE4 SLOT (fetch (HARRAYP LASTINDEX) of APTR1)))
+      LP  (COND
+             ((SETQ V (fetch (HASHSLOT VALUE) of SLOT))
+              (PUTHASH (fetch (HASHSLOT KEY) of SLOT)
+                     V NEWAR)))
+          (COND
+             ((EQ SLOT LASTSLOT)
+              (RETURN NEWAR)))
+          (SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT))
+          (GO LP])
+
+(\COPYHARRAYP
+  [LAMBDA (SOURCE TARGET)                                (* rmk%: "31-Dec-83 13:58")
+
+    (* ;; "Copies all properties of SOURCE into TARGET;  called from HASHOVERFLOW")
+
+    (replace NULLSLOTS of TARGET with (fetch NULLSLOTS of SOURCE))
+    (replace LASTINDEX of TARGET with (fetch LASTINDEX of SOURCE))
+    (replace HARRAYPBASE of TARGET with (fetch HARRAYPBASE of SOURCE))
+    (replace OVERFLOWACTION of TARGET with (fetch OVERFLOWACTION of SOURCE))
+    (replace NUMSLOTS of TARGET with (fetch NUMSLOTS of SOURCE))
+    (replace NUMKEYS of TARGET with (fetch NUMKEYS of SOURCE])
+
+(\HASHTABLE.DEFPRINT
+  [LAMBDA (LISP:HASH-TABLE STREAM)                         (* ; "Edited 23-Mar-87 11:38 by bvm:")
+
+    (* ;; "For benefit of common lisp, print harrayp by name %"hash table%", for example, #<Hash-Table @ 76,5432>")
+
+    [.SPACECHECK. STREAM (CONSTANT (+ (NCHARS "<Hash-Table @ >")
+                                      (PROGN                 (* ; "Longest address is `177,177777'")
+                                             10]
+    (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))
+    (\SOUT "<Hash-Table @ " STREAM)
+    (\PRINTADDR LISP:HASH-TABLE STREAM)
+    (\OUTCHAR STREAM (CHARCODE >))                           (* ; 
+                                                          "Return T to say we printed it ourselves")
+    T])
+)
+(DEFINEQ
+
+(STRINGHASHBITS
+  [LAMBDA (STRING)                                       (* ; "Edited  2-Mar-89 14:11 by jds")
+    (MISCN STRINGHASHBITS STRING])
+
+(STRING-EQUAL-HASHBITS
+  [LAMBDA (STRING)                                       (* ; "Edited  2-Mar-89 14:14 by jds")
+
+(* ;;; "A hashbits function for the hash equivalence STRING-EQUAL.")
+
+(* ;;; "This is similar to the atom hash algorithm, but we OR in 40Q to cause uppercase and lowercase chars to have the same codes.")
+
+    (MISCN STRING-EQUAL-HASHBITS STRING])
+)
+(DEFINEQ
+
+(\STRINGHASHBITS-UFN
+  [LAMBDA (INDEX ARGCOUNT ARG-PTR)                       (* ; "Edited  2-Mar-89 14:06 by jds")
+
+    (* ;; "UFN for the STRINGHASHBITS MISCN opcode.  Computes a hash index for strings and symbols, so identical string CONTENTS hash to the same place.")
+
+    (LET ((STRING (\GETBASEPTR ARG-PTR 0)))
+         (for C inpname STRING bind (HASHBITS _ 0)
+            do                                           (* ; 
+                                                       "This is similar to the atom hash algorithm")
+                  [SETQ HASHBITS (IPLUS16 C (IPLUS16 (SETQ HASHBITS (IPLUS16 HASHBITS
+                                                                           (LLSH (LOGAND HASHBITS 
+                                                                                        4095)
+                                                                                 2)))
+                                                   (LLSH (LOGAND HASHBITS 255)
+                                                         8] finally (RETURN HASHBITS])
+
+(\STRING-EQUAL-HASHBITS-UFN
+  [LAMBDA (INDEX ARGCOUNT ARG-PTR)                       (* ; "Edited  2-Mar-89 14:09 by jds")
+
+(* ;;; "A hashbits function for the hash equivalence STRING-EQUAL.")
+
+(* ;;; "This is similar to the atom hash algorithm, but we OR in 40Q to cause uppercase and lowercase chars to have the same codes.")
+
+    (LET ((STRING (\GETBASEPTR ARG-PTR 0)))
+         (for C inpname STRING bind (HASHBITS _ 0)
+            do [SETQ HASHBITS (IPLUS16 (LOGOR C 32)
+                                         (IPLUS16 (SETQ HASHBITS (IPLUS16 HASHBITS
+                                                                        (LLSH (LOGAND HASHBITS 4095)
+                                                                              2)))
+                                                (LLSH (LOGAND HASHBITS 255)
+                                                      8] finally (RETURN HASHBITS])
+)
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
+
+(DATATYPE HARRAYP ((NULLSLOTS WORD)                      (* ; 
+                                                      "Number of NIL-NIL slots, which break chains")
+                       (LASTINDEX WORD)                      (* ; "Slot offset of last slot.  Used in probe computations computations.  Microcode support for \ADDBASE4 would help")
+                       (HARRAYPBASE POINTER)
+                       (RECLAIMABLE FLAG)                    (* ; 
+                                                      "True if keys can go away when no other refs")
+                       (OVERFLOWACTION POINTER)
+                       (NUMSLOTS WORD)                       (* ; 
+                                      "The maximum number of logical slots--returned by HARRAYSIZE")
+                       (NUMKEYS WORD)                        (* ; 
+                                                         "The number of distinct keys in the array")
+                       (HASHBITSFN POINTER)
+                       (EQUIVFN POINTER)
+                       (HASHUSERDATA POINTER)))
+)
+
+(/DECLAREDATATYPE 'HARRAYP '(WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER)
+       '((HARRAYP 0 (BITS . 15))
+         (HARRAYP 1 (BITS . 15))
+         (HARRAYP 2 POINTER)
+         (HARRAYP 2 (FLAGBITS . 0))
+         (HARRAYP 4 POINTER)
+         (HARRAYP 6 (BITS . 15))
+         (HARRAYP 7 (BITS . 15))
+         (HARRAYP 8 POINTER)
+         (HARRAYP 10 POINTER)
+         (HARRAYP 12 POINTER))
+       '14)
+(DECLARE%: EVAL@COMPILE 
+
+[PUTPROPS \EQHASHINGBITS MACRO (OPENLAMBDA (X)               (* ; 
+                 "Spread out objects whose low bits are in small arithmetic progression, esp atoms")
+                                      (LOGXOR (\HILOC X)
+                                             (LOGXOR (LLSH (LOGAND (\LOLOC X)
+                                                                  8191)
+                                                           3)
+                                                    (LRSH (\LOLOC X)
+                                                          9]
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DECLARE%: EVAL@COMPILE
+
+(BLOCKRECORD HASHSLOT ((KEY POINTER)
+                           (VALUE POINTER))
+                          [ACCESSFNS ((NEXTSLOT (\ADDBASE DATUM (UNFOLD WORDSPERCELL CELLSPERSLOT])
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+[PUTPROPS \FIRSTINDEX MACRO ((BITS APTR1)
+                             (IREMAINDER BITS (ADD1 (fetch (HARRAYP LASTINDEX) of APTR1]
+
+(PUTPROPS \HASHSLOT MACRO (= . \ADDBASE4))
+
+(PUTPROPS \REPROBE MACRO ((BITS HA)
+                          (LOGOR [IREMAINDER (LOGXOR BITS (LRSH BITS 8))
+                                        (IMIN 64 (ADD1 (fetch (HARRAYP LASTINDEX)
+                                                          of HA]
+                                 1)))
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ CELLSPERSLOT 2)
+
+
+(CONSTANTS (CELLSPERSLOT 2))
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \HASH.NULL.VALUE SYSHASHARRAY)
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(DEFPRINT 'HARRAYP '\HASHTABLE.DEFPRINT)
+)
+
+(/DECLAREDATATYPE 'HARRAYP '(WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER)
+       '((HARRAYP 0 (BITS . 15))
+         (HARRAYP 1 (BITS . 15))
+         (HARRAYP 2 POINTER)
+         (HARRAYP 2 (FLAGBITS . 0))
+         (HARRAYP 4 POINTER)
+         (HARRAYP 6 (BITS . 15))
+         (HARRAYP 7 (BITS . 15))
+         (HARRAYP 8 POINTER)
+         (HARRAYP 10 POINTER)
+         (HARRAYP 12 POINTER))
+       '14)
+(ADDTOVAR SYSTEMRECLST
+
+(DATATYPE HARRAYP ((NULLSLOTS WORD)
+                       (LASTINDEX WORD)
+                       (HARRAYPBASE POINTER)
+                       (RECLAIMABLE FLAG)
+                       (OVERFLOWACTION POINTER)
+                       (NUMSLOTS WORD)
+                       (NUMKEYS WORD)
+                       (HASHBITSFN POINTER)
+                       (EQUIVFN POINTER)
+                       (HASHUSERDATA POINTER)))
+)
+
+(RPAQQ \HASH.NULL.VALUE \Hash\Null\Value\)
+
+
+
+(* ; "System entries for CODE")
+
+(DEFINEQ
+
+(\CODEARRAY
+  [LAMBDA (NBYTES INITONPAGE)                            (* lmm "15-Aug-84 11:51")
+    (PROG NIL
+
+     (* ;; "NBYTES is the number of bytes required, INITONPAGE is the number of CELLS which must reside on same page")
+
+          (COND
+             ((OR (IGREATERP 0 NBYTES)
+                  (IGREATERP NBYTES 65535))
+              (LISPERROR "ILLEGAL ARG" NBYTES)))             (* ; 
+                                                    "dolphin requires code blocks aligned quadword")
+          (RETURN (create ARRAYP
+                         TYP _ \ST.CODE
+                         BASE _ (\ALLOCBLOCK (FOLDHI NBYTES BYTESPERCELL)
+                                       CODEBLOCK.GCT INITONPAGE CELLSPERQUAD)
+                         LENGTH _ NBYTES
+                         ORIG _ 0])
+
+(\FIXCODENUM
+  [LAMBDA (CA BN NUM MASK)                               (* ; "Edited  7-Jan-91 13:29 by jds")
+    (DECLARE (IGNORE MASK))                              (* ; 
+                                            "MASK is used by the renamed version of this function.")
+
+    (* ;; "Do fixup for a 2-byte number in the code stream.  Used for type numbers only, for now.")
+
+    (PROG ((BASE (fetch (ARRAYP BASE) of CA)))
+          (\PUTBASEBYTE BASE BN (LOGAND 255 NUM))
+          (\PUTBASEBYTE BASE (SETQ BN (SUB1 BN))
+                 (LOGOR (\GETBASEBYTE BASE BN)
+                        (LRSH NUM 8)))
+          (RETURN NUM])
+
+(\FIXCODEPTR
+  [LAMBDA (CA BN PTR MASK)                    (* ; 
+                                                "Edited 12-Nov-92 17:03 by sybalsky:mv:envos")
+    (DECLARE (IGNORE MASK))                              (* ; 
+                                            "MASK is used by the renamed version of this function.")
+    (PROG ((BASE (fetch (ARRAYP BASE) of CA))
+           (LO (\LOLOC PTR)))
+          (UNINTERRUPTABLY
+              (\ADDREF PTR)
+              (\PUTBASEBYTE BASE BN (LOGAND LO 255))
+              (\PUTBASEBYTE BASE (SUB1 BN)
+                     (LRSH LO 8))
+              (\PUTBASEBYTE BASE (IDIFFERENCE BN 2)
+                     (LOGOR (\GETBASEBYTE BASE (IDIFFERENCE BN 2))
+                            (LOGAND (\HILOC PTR)
+                                   255)))
+              (\PUTBASEBYTE BASE (IDIFFERENCE BN 3)
+                     (LOGOR (\GETBASEBYTE BASE (IDIFFERENCE BN 3))
+                            (LRSH (\HILOC PTR)
+                                  8))))
+          (RETURN PTR])
+
+(\FIXCODESYM
+  [LAMBDA (CA BN SYM MASK)                    (* ; 
+                                                "Edited 13-Nov-92 04:56 by sybalsky:mv:envos")
+    (DECLARE (IGNORE MASK))                              (* ; 
+                                            "MASK is used by the renamed version of this function.")
+
+    (* ;; "Perform fix-up for a symbol in an IL-Compiled function -- either 2 or 4 bytes, depending on the architecture.")
+
+    (* ;; "CA -- the code array")
+
+    (* ;; "BN -- byte number of the low-order byte to be fixed up")
+
+    (* ;; "SYM -- the symbol, expressed as a FIXP or a NEW-ATOM.")
+
+    (NEW-SYMBOL-CODE (PROG (HIBYTE NUM (BASE (fetch (ARRAYP BASE) of CA)))
+
+                      (* ;; "For 3-byte-symbol machines, handle 3 bytes worth of atom number.")
+
+                           [COND
+                              ((SMALLP SYM)
+                               (SETQ NUM SYM)
+                               (SETQ HIBYTE 0))
+                              ((FIXP SYM)
+                               (SETQ NUM (LOGAND SYM 65535))
+                               (SETQ HIBYTE (LRSH SYM 16)))
+                              (T (SETQ NUM (\LOLOC SYM))
+                                 (SETQ HIBYTE (\HILOC SYM]
+                           (UNINTERRUPTABLY
+                               (\PUTBASEBYTE BASE BN (LOGAND NUM 255))
+                               (\PUTBASEBYTE BASE (SUB1 BN)
+                                      (LOGAND (LRSH NUM 8)
+                                             255))
+                               (\PUTBASEBYTE BASE (IDIFFERENCE BN 2)
+                                      (LOGOR (\GETBASEBYTE BASE (IDIFFERENCE BN 2))
+                                             (LOGAND HIBYTE 255)))
+                               (\PUTBASEBYTE BASE (IDIFFERENCE BN 3)
+                                      (LOGOR (\GETBASEBYTE BASE (IDIFFERENCE BN 3))
+                                             (LRSH HIBYTE 8))))
+                           (RETURN (+ (LLSH HIBYTE 16)
+                                      NUM)))
+           (PROG ((NUM (\LOLOC SYM))
+                  (BASE (fetch (ARRAYP BASE) of CA)))
+
+            (* ;; "2-BYTE case:  Just fill it in.")
+
+                 (\PUTBASEBYTE BASE BN (LOGAND 255 NUM))
+                 (\PUTBASEBYTE BASE (SETQ BN (SUB1 BN))
+                        (LOGOR (\GETBASEBYTE BASE BN)
+                               (LRSH NUM 8)))
+                 (RETURN NUM])
+)
+
+
+
+(* ; "Internal")
+
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS EQPTR DMACRO (= . EQ))
+
+(PUTPROPS BUCKETINDEX MACRO ((N)
+                             (IMIN (INTEGERLENGTH N)
+                                   \MAXBUCKETINDEX)))
+
+[PUTPROPS FREEBLOCKCHAIN.N MACRO ((N)
+                                  (\ADDBASE2 \FREEBLOCKBUCKETS (BUCKETINDEX N]
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \MAXBUCKETINDEX 30)
+
+
+(CONSTANTS \MAXBUCKETINDEX)
+)
+
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \ADDBASE2 MACRO (OPENLAMBDA (BASE N)
+                                 (\ADDBASE (\ADDBASE BASE N)
+                                        N)))
+
+(PUTPROPS \ADDBASE4 MACRO (OPENLAMBDA (BASE N)
+                                 (\ADDBASE2 (\ADDBASE2 BASE N)
+                                        N)))
+
+(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX)
+                                    (FOLDLO (fetch DTDSIZE of (\GETDTD NTYPX))
+                                           WORDSPERCELL)))
+
+[PUTPROPS \BYTELT DMACRO (OPENLAMBDA (A J)
+                                (\GETBASEBYTE (fetch (ARRAYP BASE) of A)
+                                       (IPLUS (fetch (ARRAYP OFFST) of A)
+                                              J]
+
+(PUTPROPS \BYTESETA DMACRO (OPENLAMBDA (A J V)
+                                  (\PUTBASEBYTE (fetch (ARRAYP BASE) of A)
+                                         (IPLUS (fetch (ARRAYP OFFST) of A)
+                                                J)
+                                         V)))
+
+[PUTPROPS \WORDELT DMACRO (OPENLAMBDA (A J)
+                                 [CHECK (AND (ARRAYP A)
+                                             (EQ 0 (fetch (ARRAYP ORIG) of A))
+                                             (EQ \ST.POS16 (fetch (ARRAYP TYP) of A]
+                                 (CHECK (IGREATERP (fetch (ARRAYP LENGTH) of A)
+                                               J))
+                                 (\GETBASE (fetch (ARRAYP BASE) of A)
+                                        (IPLUS (fetch (ARRAYP OFFST) of A)
+                                               J]
+)
+
+(RPAQQ BLOCKGCTYPECONSTANTS ((CODEBLOCK.GCT 2)
+                                 (PTRBLOCK.GCT 1)
+                                 (UNBOXEDBLOCK.GCT 0)))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ CODEBLOCK.GCT 2)
+
+(RPAQQ PTRBLOCK.GCT 1)
+
+(RPAQQ UNBOXEDBLOCK.GCT 0)
+
+
+(CONSTANTS (CODEBLOCK.GCT 2)
+       (PTRBLOCK.GCT 1)
+       (UNBOXEDBLOCK.GCT 0))
+)
+
+(RPAQQ ARRAYCONSTANTS (\ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells 
+                                 \ArrayBlockTrailerWords (\ArrayBlockOverheadCells (IPLUS 
+                                                                               \ArrayBlockHeaderCells
+                                                                                          
+                                                                              \ArrayBlockTrailerCells
+                                                                                          ))
+                                 (\ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords 
+                                                                  \ArrayBlockTrailerWords))
+                                 \ArrayBlockLinkingCells
+                                 (\MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells 
+                                                            \ArrayBlockLinkingCells))
+                                 (\MaxArrayBlockSize 65535)
+                                 (\MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize 
+                                                         \ArrayBlockOverheadCells))
+                                 \MaxArrayLen
+                                 (\ABPASSWORDSHIFT 3)
+                                 (\ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT))
+                                 (\FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword 
+                                                                  \ABPASSWORDSHIFT)
+                                                            (LLSH UNBOXEDBLOCK.GCT 1)))
+                                 (\UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword 
+                                                                  \ABPASSWORDSHIFT)
+                                                            1))
+                                 (\CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword 
+                                                                  \ABPASSWORDSHIFT)
+                                                            (LLSH CODEBLOCK.GCT 1)
+                                                            1))))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \ArrayBlockHeaderCells 1)
+
+(RPAQQ \ArrayBlockHeaderWords 2)
+
+(RPAQQ \ArrayBlockTrailerCells 1)
+
+(RPAQQ \ArrayBlockTrailerWords 2)
+
+(RPAQ \ArrayBlockOverheadCells (IPLUS \ArrayBlockHeaderCells \ArrayBlockTrailerCells))
+
+(RPAQ \ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords \ArrayBlockTrailerWords))
+
+(RPAQQ \ArrayBlockLinkingCells 2)
+
+(RPAQ \MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells \ArrayBlockLinkingCells))
+
+(RPAQQ \MaxArrayBlockSize 65535)
+
+(RPAQ \MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize \ArrayBlockOverheadCells))
+
+(RPAQQ \MaxArrayLen 65535)
+
+(RPAQQ \ABPASSWORDSHIFT 3)
+
+(RPAQ \ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT))
+
+(RPAQ \FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
+                                    (LLSH UNBOXEDBLOCK.GCT 1)))
+
+(RPAQ \UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
+                                    1))
+
+(RPAQ \CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
+                                    (LLSH CODEBLOCK.GCT 1)
+                                    1))
+
+
+(CONSTANTS \ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells 
+       \ArrayBlockTrailerWords (\ArrayBlockOverheadCells (IPLUS \ArrayBlockHeaderCells 
+                                                                \ArrayBlockTrailerCells))
+       (\ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords \ArrayBlockTrailerWords))
+       \ArrayBlockLinkingCells
+       (\MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells \ArrayBlockLinkingCells))
+       (\MaxArrayBlockSize 65535)
+       (\MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize \ArrayBlockOverheadCells))
+       \MaxArrayLen
+       (\ABPASSWORDSHIFT 3)
+       (\ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT))
+       (\FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
+                                  (LLSH UNBOXEDBLOCK.GCT 1)))
+       (\UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
+                                  1))
+       (\CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
+                                  (LLSH CODEBLOCK.GCT 1)
+                                  1)))
+)
+
+(RPAQQ ARRAYTYPES ((\ST.BYTE 0)
+                       (\ST.POS16 1)
+                       (\ST.INT32 2)
+                       (\ST.CODE 4)
+                       (\ST.PTR 6)
+                       (\ST.FLOAT 7)
+                       (\ST.BIT 8)
+                       (\ST.PTR2 11)))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \ST.BYTE 0)
+
+(RPAQQ \ST.POS16 1)
+
+(RPAQQ \ST.INT32 2)
+
+(RPAQQ \ST.CODE 4)
+
+(RPAQQ \ST.PTR 6)
+
+(RPAQQ \ST.FLOAT 7)
+
+(RPAQQ \ST.BIT 8)
+
+(RPAQQ \ST.PTR2 11)
+
+
+(CONSTANTS (\ST.BYTE 0)
+       (\ST.POS16 1)
+       (\ST.INT32 2)
+       (\ST.CODE 4)
+       (\ST.PTR 6)
+       (\ST.FLOAT 7)
+       (\ST.BIT 8)
+       (\ST.PTR2 11))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \MAX.CELLSPERHUNK 64)
+
+
+(CONSTANTS \MAX.CELLSPERHUNK)
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \IN.MAKEINIT NIL)
+
+
+(CONSTANTS (\IN.MAKEINIT))
+)
+(DECLARE%: EVAL@COMPILE
+
+(BLOCKRECORD SEQUENCEDESCRIPTOR ((ORIG BITS 1)
+                                     (NIL BITS 1)
+                                     (READONLY FLAG)
+                                     (NIL BITS 1)
+                                     (BASE POINTER)
+                                     (TYP BITS 4)
+                                     (NIL BITS 4)
+                                     (LENGTH BITS 24)
+                                     (OFFST FIXP)))
+
+(DATATYPE ARRAYP ((ORIG BITS 1)
+                      (NIL BITS 1)
+                      (READONLY FLAG)                        (* ; "probably no READONLY arrays now")
+                      (NIL BITS 1)
+                      (BASE POINTER)
+                      (TYP BITS 4)
+                      (NIL BITS 4)
+                      (LENGTH BITS 24)
+                      (OFFST FIXP))
+
+                     (* ;; "note that while ARRAYP is a DATATYPE, the allocation of it actually happens at MAKEINIT time under INITDATATYPE{NAMES}")
+
+                     )
+
+(BLOCKRECORD ARRAYBLOCK ((PASSWORD BITS 13)
+                             (GCTYPE BITS 2)                 (* ; "Unboxed, Pointers, or Code")
+                             (INUSE FLAG)
+                             (ARLEN WORD)
+                             (FWD FULLXPOINTER)              (* ; "Only when on free list")
+                             (BKWD FULLXPOINTER))
+                            (BLOCKRECORD ARRAYBLOCK ((ABFLAGS WORD)
+                                                             (* ; "Used for header and trailer")
+                                                     ))
+                            [ACCESSFNS ARRAYBLOCK ((DAT (\ADDBASE DATUM \ArrayBlockHeaderWords))
+                                                   (TRAILER (\ADDBASE2 DATUM
+                                                                   (IDIFFERENCE (fetch
+                                                                                 (ARRAYBLOCK ARLEN)
+                                                                                   of DATUM)
+                                                                          \ArrayBlockTrailerCells]
+                            (TYPE? (AND (EQ 0 (NTYPX DATUM))
+                                            (IGEQ (\HILOC DATUM)
+                                                  \FirstArraySegment))))
+)
+
+(/DECLAREDATATYPE 'ARRAYP '((BITS 1)
+                            (BITS 1)
+                            FLAG
+                            (BITS 1)
+                            POINTER
+                            (BITS 4)
+                            (BITS 4)
+                            (BITS 24)
+                            FIXP)
+       '((ARRAYP 0 (BITS . 0))
+         (ARRAYP 0 (BITS . 16))
+         (ARRAYP 0 (FLAGBITS . 32))
+         (ARRAYP 0 (BITS . 48))
+         (ARRAYP 0 POINTER)
+         (ARRAYP 2 (BITS . 3))
+         (ARRAYP 2 (BITS . 67))
+         (ARRAYP 2 (LONGBITS . 135))
+         (ARRAYP 4 FIXP))
+       '6)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \NxtArrayPage \FREEBLOCKBUCKETS \HUNKING?)
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \ArrayFrLst \ArrayFrLst2 \RECLAIM.COUNTDOWN)
+)
+)
+(DEFINEQ
+
+(\ALLOCBLOCK
+  [LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN)               (* bvm%: " 7-Feb-85 15:30")
+
+    (* ;; "NCELLS is number of cells wanted not counting overhead cell.  For code arrays, INITONPAGE is number of cells to be kept on a single page.  It might be necessary to flag a block with an aligned indicator, to help a compacting garbage collector preserve the align proprty.  --- Does not assume that caller is uninterruptable --- Returns NIL if NCELLS = 0 --- GCTYPE is one of the constants PTRBLOCK.GCT, CODEBLOCK.GCT, UNBOXEDBLOCK.GCT, indicating any special behavior to be performed when the block is reclaimed.  NIL defaults to UNBOXEDBLOCK.GCT")
+
+    (DECLARE (GLOBALVARS \ArrayFrLst))
+    (COND
+       ((ILESSP NCELLS \ArrayBlockLinkingCells)
+        (COND
+           ((ILESSP NCELLS 0)
+            (\ILLEGAL.ARG NCELLS)))
+        (SETQ NCELLS \ArrayBlockLinkingCells))
+       ((IGREATERP NCELLS \MaxArrayNCells)
+        (\LISPERROR NCELLS "ARRAY STORAGE BLOCK TOO LARGE")))(* ; 
+                           "NCELLS is number of data cells;  remember for allocation counter below")
+    (SELECTQ GCTYPE
+        (NIL (SETQ GCTYPE UNBOXEDBLOCK.GCT))
+        (T (SETQ GCTYPE PTRBLOCK.GCT))
+        NIL)                                                 (* ; 
+                           "This SELECTQ can be removed when all callers are upgraded to constants")
+    (COND
+       ((AND INITONPAGE (OR (ILESSP INITONPAGE 0)
+                            (IGREATERP INITONPAGE CELLSPERPAGE)))
+        (\ILLEGAL.ARG INITONPAGE)))
+    (COND
+       ((NULL ALIGN))
+       ((OR (ILESSP ALIGN 0)
+            (IGREATERP ALIGN CELLSPERPAGE))
+        (\ILLEGAL.ARG ALIGN))
+       ((ILEQ ALIGN 1)
+        (SETQ ALIGN))
+       ((AND INITONPAGE (PROGN                               (* ; 
+                           "Some check for consistency between ALIGN and INITONPAGE is needed here")
+                               NIL))
+        (ERROR "INITONPAGE and ALIGN too high")))
+    (OR (AND \HUNKING? (ILEQ NCELLS \MAX.CELLSPERHUNK)
+             (\ALLOCHUNK NCELLS GCTYPE INITONPAGE ALIGN))
+        (PROG ((ARLEN (IPLUS NCELLS \ArrayBlockOverheadCells))
+               ABLOCK)
+          RETRY
+              (UNINTERRUPTABLY
+                                                             (* ; "Comment PPLossage")
+                  (SETQ ABLOCK (OR (\ALLOCBLOCK.OLD ARLEN GCTYPE INITONPAGE ALIGN)
+                                   (\ALLOCBLOCK.NEW ARLEN GCTYPE INITONPAGE ALIGN)
+                                   (PROGN (FRPTQ 10 (RECLAIM))
+
+                                          (* ;; "We're probably out of array space;  our last chance is to collect and hope something shows up on the free list.")
+
+                                          (\ALLOCBLOCK.OLD ARLEN GCTYPE INITONPAGE ALIGN))
+                                   (GO FULL)))               (* ; 
+                     "ABLOCK now points to the beginning of the actual block of storage to be used")
+                  (replace (ARRAYBLOCK INUSE) of ABLOCK with T)
+                  (replace (ARRAYBLOCK INUSE) of (fetch (ARRAYBLOCK TRAILER) of
+                                                                                         ABLOCK)
+                     with T)
+                  (replace (ARRAYBLOCK GCTYPE) of ABLOCK with GCTYPE)
+                  (\CHECKARRAYBLOCK ABLOCK NIL)
+                  (.INCREMENT.ALLOCATION.COUNT. NCELLS)      (* ; 
+                                              "NCELLS because CREATEREF accounts for overhead cell")
+                  (SETQ ABLOCK (\ADDBASE ABLOCK \ArrayBlockHeaderWords))
+                  (\CREATEREF ABLOCK)
+                  (RETURN ABLOCK))
+          FULL
+              (LISPERROR "ARRAYS FULL" NIL T)                (* ; 
+                                                          "User might release something, so retry.")
+              (GO RETRY])
+
+(\MAIKO.ALLOCBLOCK
+  [LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN)               (* ; "Edited 29-Jun-90 12:17 by ON")
+
+    (* ;; "Maiko specific \ALLOCBLOCK. Does not decrement \RECLAIM.COUNTDOWN.")
+
+    (* ;; "NCELLS is number of cells wanted not counting overhead cell.  For code arrays, INITONPAGE is number of cells to be kept on a single page.  It might be necessary to flag a block with an aligned indicator, to help a compacting garbage collector preserve the align proprty.  --- Does not assume that caller is uninterruptable --- Returns NIL if NCELLS = 0 --- GCTYPE is one of the constants PTRBLOCK.GCT, CODEBLOCK.GCT, UNBOXEDBLOCK.GCT, indicating any special behavior to be performed when the block is reclaimed.  NIL defaults to UNBOXEDBLOCK.GCT")
+
+    (DECLARE (GLOBALVARS \ArrayFrLst))
+    (COND
+       ((ILESSP NCELLS \ArrayBlockLinkingCells)
+        (COND
+           ((ILESSP NCELLS 0)
+            (\ILLEGAL.ARG NCELLS)))
+        (SETQ NCELLS \ArrayBlockLinkingCells))
+       ((IGREATERP NCELLS \MaxArrayNCells)
+        (\LISPERROR NCELLS "ARRAY STORAGE BLOCK TOO LARGE")))(* ; 
+                           "NCELLS is number of data cells;  remember for allocation counter below")
+    (SELECTQ GCTYPE
+        (NIL (SETQ GCTYPE UNBOXEDBLOCK.GCT))
+        (T (SETQ GCTYPE PTRBLOCK.GCT))
+        NIL)                                                 (* ; 
+                           "This SELECTQ can be removed when all callers are upgraded to constants")
+
+    (* ;; "Maiko doesn't have to worry about INITONPAGE.   ----- '90/06/29 on.")
+
+    (* ;; "(COND ((AND INITONPAGE (OR (ILESSP INITONPAGE 0) (IGREATERP INITONPAGE CELLSPERPAGE))) (\ILLEGAL.ARG INITONPAGE)))")
+
+    (COND
+       ((NULL ALIGN))
+       ((OR (ILESSP ALIGN 0)
+            (IGREATERP ALIGN CELLSPERPAGE))
+        (\ILLEGAL.ARG ALIGN))
+       ((ILEQ ALIGN 1)
+        (SETQ ALIGN))
+       ((AND INITONPAGE (PROGN                               (* ; 
+                           "Some check for consistency between ALIGN and INITONPAGE is needed here")
+                               NIL))
+        (ERROR "INITONPAGE and ALIGN too high")))
+    (OR (AND \HUNKING? (ILEQ NCELLS \MAX.CELLSPERHUNK)       (* ; 
+      "Maiko doesn't have to worry about INITONPAGE so call \ALLOCHUNK with arg INITONPAGE as NIL.")
+             (\ALLOCHUNK NCELLS GCTYPE NIL ALIGN))
+        (PROG ((ARLEN (IPLUS NCELLS \ArrayBlockOverheadCells))
+               ABLOCK)
+          RETRY
+              (UNINTERRUPTABLY
+                                                             (* ; "Comment PPLossage")
+                  (SETQ ABLOCK (OR (\ALLOCBLOCK.OLD ARLEN GCTYPE NIL ALIGN)
+                                   (\ALLOCBLOCK.NEW ARLEN GCTYPE NIL ALIGN)
+                                   (PROGN (FRPTQ 10 (RECLAIM))
+
+                                          (* ;; "We're probably out of array space;  our last chance is to collect and hope something shows up on the free list.")
+
+                                          (\ALLOCBLOCK.OLD ARLEN GCTYPE INITONPAGE ALIGN))
+                                   (GO FULL)))               (* ; 
+                     "ABLOCK now points to the beginning of the actual block of storage to be used")
+                  (replace (ARRAYBLOCK INUSE) of ABLOCK with T)
+                  (replace (ARRAYBLOCK INUSE) of (fetch (ARRAYBLOCK TRAILER) of
+                                                                                         ABLOCK)
+                     with T)
+                  (replace (ARRAYBLOCK GCTYPE) of ABLOCK with GCTYPE)
+                  (\CHECKARRAYBLOCK ABLOCK NIL)
+                  (.CHECK.ALLOCATION.COUNT. NCELLS)
+                  (SETQ ABLOCK (\ADDBASE ABLOCK \ArrayBlockHeaderWords))
+                  (PROG1 (\DELREF ABLOCK)
+                         (.CHECK.ALLOCATION.COUNT. 1))
+                  (RETURN ABLOCK))
+          FULL
+              (LISPERROR "ARRAYS FULL" NIL T)                (* ; 
+                                                          "User might release something, so retry.")
+              (GO RETRY])
+
+(\ALLOCBLOCK.OLD
+  [LAMBDA (ARLEN GCTYPE INITONPAGE ALIGN)                (* bvm%: "15-Feb-85 11:01")
+
+    (* ;; "Returns a block of the right size and alignment, or NIL if one couldn't be found.")
+
+    (for BKTI from (BUCKETINDEX ARLEN) to \MAXBUCKETINDEX bind ABLOCK
+       when (AND (SETQ ABLOCK (\GETBASEPTR (\ADDBASE2 \FREEBLOCKBUCKETS BKTI)
+                                         0))
+                     (bind (1STBLOCK.IN.FREECHAIN _ ABLOCK)
+                            USABLELEN REMAINDERLEN PREFIXLEN
+                        repeatuntil (EQ (SETQ ABLOCK (fetch (ARRAYBLOCK FWD) of ABLOCK))
+                                            1STBLOCK.IN.FREECHAIN)
+                        when (PROGN [COND
+                                           ((OR (NEQ (fetch (ARRAYBLOCK PASSWORD) of ABLOCK)
+                                                     \ArrayBlockPassword)
+                                                (NEQ (fetch (ARRAYBLOCK PASSWORD)
+                                                        of (fetch (ARRAYBLOCK TRAILER)
+                                                                  of ABLOCK))
+                                                     \ArrayBlockPassword))
+                                            (RETURN (\MP.ERROR \MP.BADARRAYBLOCK "Bad Array Block" 
+                                                           ABLOCK]
+                                        (SETQ PREFIXLEN (COND
+                                                           ((OR ALIGN INITONPAGE)
+                                                            (\PREFIXALIGNMENT? ARLEN INITONPAGE 
+                                                                   ALIGN GCTYPE ABLOCK))
+                                                           (T 0)))
+                                        (IGEQ (SETQ USABLELEN (IDIFFERENCE (fetch (ARRAYBLOCK
+                                                                                       ARLEN)
+                                                                              of ABLOCK)
+                                                                     PREFIXLEN))
+                                              ARLEN))
+                        do (\CHECKARRAYBLOCK ABLOCK T T)
+                              (\DELETEBLOCK? ABLOCK)     (* ; "take it off the free list")
+                              [COND
+                                 ((NEQ PREFIXLEN 0)          (* ; 
+                   "We must split off a bit initially, in order to preserve the INITONPAGE request")
+                                  (\MERGEBACKWARD (\MAKEFREEARRAYBLOCK ABLOCK PREFIXLEN))
+                                  (SETQ ABLOCK (\ADDBASE2 ABLOCK PREFIXLEN]
+                              (SETQ REMAINDERLEN (IDIFFERENCE USABLELEN ARLEN))
+                              (COND
+                                 [(IGREATERP REMAINDERLEN (COND
+                                                             (\HUNKING? (IPLUS \MAX.CELLSPERHUNK 
+                                                                             \ArrayBlockOverheadCells
+                                                                               ))
+                                                             (T 0)))
+                                                             (* ; 
+                                             "Split off any extra space from the end of the block.")
+                                  (\MERGEFORWARD (\LINKBLOCK (\MAKEFREEARRAYBLOCK
+                                                                      (\ADDBASE2 ABLOCK ARLEN)
+                                                                      REMAINDERLEN]
+                                 (\HUNKING?                  (* ; 
+                                         "Coerce the length upwards so as not to have a runt block")
+                                        (SETQ ARLEN USABLELEN)))
+                              (COND
+                                 ((OR (NEQ PREFIXLEN 0)
+                                      (NEQ USABLELEN ARLEN)) (* ; 
+                                  "If we changed the length of the block, store the new length now")
+                                  (\MAKEFREEARRAYBLOCK ABLOCK ARLEN)))
+                              (\CHECKARRAYBLOCK ABLOCK T)
+                              (\CLEARCELLS (\ADDBASE ABLOCK \ArrayBlockHeaderWords)
+                                     (IDIFFERENCE ARLEN \ArrayBlockOverheadCells)) 
+                                                             (* ; "clear out old garbage")
+                                                             (* ; "signal that we found one")
+                              (RETURN T))) do (RETURN ABLOCK])
+
+(\ALLOCBLOCK.NEW
+  [LAMBDA (ARLEN GCTYPE INITONPAGE ALIGN)                (* ; "Edited  4-Jan-93 02:06 by jds")
+    (DECLARE (GLOBALVARS \ArrayFrLst \NxtArrayPage))
+
+    (* ;; "Patch up a new section of memory beginning at the end of current arrayspace, and make it a freeblock for subsequent usage.  Also used to increment to the next page/segment boundary when allocating code arrays")
+
+    (PROG (FINALWORD FINALPAGE NEXTFREEBLOCK PREFIXLEN)
+      RETRY
+          [COND
+             ([AND (OR INITONPAGE ALIGN)
+                   (NEQ 0 (SETQ PREFIXLEN (\PREFIXALIGNMENT? ARLEN INITONPAGE ALIGN GCTYPE 
+                                                 \ArrayFrLst](* ; 
+                         "Gobble up a modest amount of space in order to insure correct alignment.")
+              (COND
+                 ((SETQ PREFIXLEN (\ALLOCBLOCK.NEW PREFIXLEN))
+                  (\MERGEBACKWARD PREFIXLEN)             (* ; 
+               "Problem: what happens if array space switch happened inside this \ALLOCBLOCK.NEW ?")
+                  )
+                 (T (RETURN]
+          (SETQ FINALWORD (\ADDBASE (\ADDBASE \ArrayFrLst ARLEN)
+                                 (SUB1 ARLEN)))
+
+     (* ;; "FINALWORD is pointer to the last word of the new block.  The new \ArrayFrLst will be one past that, i.e., at (\ADDBASE2 \ArrayFrLst ARLEN) -- The double \ADDBASE avoids large integer arithmetic and computing FINALWORD first avoids negative arguments to \ADDBASE")
+
+          (SETQ NEXTFREEBLOCK (\ADDBASE FINALWORD 1))
+          [COND
+             ((IGREATERP (SETQ FINALPAGE (fetch (POINTER PAGE#) of FINALWORD))
+                     (IDIFFERENCE \NxtMDSPage \GUARDSTORAGEFULL))
+                                                             (* ; 
+ "Make sure that there are enough pages to satisfy this request before we make any global changes.")
+              (SELECTQ (\CHECKFORSTORAGEFULL (ADD1 (IDIFFERENCE FINALPAGE \NxtArrayPage)))
+                  (T                                         (* ; "Is ok, go ahead"))
+                  (0                                         (* ; "Is ok, but \NxtArrayPage moved.")
+                     (GO RETRY))
+                  (RETURN NIL]
+
+     (* ;; "\NxtArrayPage is the page after the page of FINALWORD, the next one that needs to be \NEWPAGEd.  \ArrayFrLst's page will be (SUB1 \NxtArrayPage) except when it is allowed to be EQ to the first word on \NxtArrayPage")
+
+          (until (IGREATERP \NxtArrayPage FINALPAGE)
+             do (\MAKEMDSENTRY \NxtArrayPage 0)
+                   (\NEW2PAGE (create POINTER
+                                     PAGE# _ \NxtArrayPage))
+                   (\PUTBASEFIXP \NxtArrayPage 0 (IPLUS \NxtArrayPage 2)))
+          (RETURN (PROG1 (\MAKEFREEARRAYBLOCK \ArrayFrLst ARLEN)
+                         (SETQ.NOREF \ArrayFrLst NEXTFREEBLOCK])
+
+(\PREFIXALIGNMENT?
+  [LAMBDA (ARLEN INITONPAGE ALIGN GCTYPE BASE)           (* Pavel "16-Oct-86 14:15")
+
+    (* ;; "how many cells must be added to to the base address of BASE to get a block whose first data word is aligned according to ALIGN and which has its first INITONPAGE cells all on one page")
+
+    (PROG ((DAT (fetch (POINTER CELLINSEGMENT) of (\ADDBASE BASE \ArrayBlockHeaderWords)))
+           (ADJUSTMENT 0)
+           FUDGE)
+
+     (* ;; "DAT will hold the cell-in-segment offset of the first dataword of the arrayblock;  it is this first dataword which must be aligned etc rather than the true beginning of the block.")
+
+      LP  (COND
+             ((AND ALIGN (NEQ (SETQ FUDGE (IREMAINDER DAT ALIGN))
+                              0))                            (* ; 
+                                                           "Not aligned, so adjust first for that.")
+              (add ADJUSTMENT (SETQ FUDGE (IDIFFERENCE ALIGN FUDGE)))
+              (add DAT FUDGE)))
+          (COND
+             ((AND INITONPAGE (NEQ (FLOOR DAT CELLSPERPAGE)
+                                   (FLOOR (IPLUS DAT INITONPAGE -1)
+                                          CELLSPERPAGE)))    (* ; 
+                           "There aren't INITONPAGE cells on the page, so go to next page boundary")
+              [add ADJUSTMENT (SETQ FUDGE (IDIFFERENCE CELLSPERPAGE (IMOD DAT CELLSPERPAGE]
+              (add DAT FUDGE)
+
+              (* ;; "No need to realign at this point.  ALIGN must be a power of two, so it's either an alignment less than CELLSPERPAGE, in which case this page boundary satisfies it, or it's a multiple of CELLSPERPAGE, in which case the first COND satisfied it and we didn't have to touch it in this COND")
+
+              ))
+          (COND
+             ([AND (EQ GCTYPE CODEBLOCK.GCT)
+                   (IGREATERP (IDIFFERENCE ARLEN \ArrayBlockOverheadCells)
+                          (SETQ FUDGE (IDIFFERENCE CELLSPERSEGMENT (SETQ DAT (IMOD DAT 
+                                                                                   CELLSPERSEGMENT]
+
+              (* ;; "Code arrays cannot cross segment boundaries.  Note that ARLEN includes the overhead cells, hence the extra subtraction.")
+
+              (add ADJUSTMENT FUDGE)
+              (add DAT FUDGE)
+
+              (* ;; "No need to re-check the alignment since ALIGN and INITONPAGE are both guaranteed satisified by a block starting on a segment boundary")
+
+              ))
+
+     (* ;; "The following code claims to prevent splitting off too small a block, but it's not clear this is intrinsically bad, and the code does not appear to do anything rational.  -- bvm --- (COND ((AND (NEQ ADJUSTMENT 0) \HUNKING?  (IGREATERP (SETQ FUDGE (IDIFFERENCE (IPLUS \MAX.CELLSPERHUNK \ArrayBlockOverheadCells) ADJUSTMENT)) 0) (PROGN (* * Account for potential merging backwards when this initial piece is split off.) (AND (EQ (fetch (ARRAYBLOCK PASSWORD) of (SETQ PREVTRAILER (\ADDBASE BASE (IMINUS \ArrayBlockTrailerCells)))) \ArrayBlockPassword) (NOT (fetch (ARRAYBLOCK INUSE) of PREVTRAILER)) (ILESSP (fetch (ARRAYBLOCK ARLEN) of PREVTRAILER) FUDGE)))) (* Just to ensure that we don't break up a large arrayblocks into two pieces one of which is too small to be usable.) (add ADJUSTMENT FUDGE) (SETQ DAT (IPLUS DAT FUDGE)) (* Go around again, since this function wouldn't have been called unless one of INITONPAGE or ALIGN were non-null.) (GO LP)))")
+
+          (RETURN ADJUSTMENT])
+
+(\MAKEFREEARRAYBLOCK
+  [LAMBDA (BLOCK LENGTH)                                 (* lmm "25-Jul-84 13:07")
+    (replace (ARRAYBLOCK ABFLAGS) of BLOCK with \FreeArrayFlagWord)
+    (replace (ARRAYBLOCK ARLEN) of BLOCK with LENGTH)
+    (replace (ARRAYBLOCK ABFLAGS) of (fetch (ARRAYBLOCK TRAILER) of BLOCK)
+       with \FreeArrayFlagWord)
+    (replace (ARRAYBLOCK ARLEN) of (fetch (ARRAYBLOCK TRAILER) of BLOCK) with
+                                                                                         LENGTH)
+    BLOCK])
+
+(\DELETEBLOCK?
+  [LAMBDA (BASE)                                         (* bvm%: "15-Feb-85 11:04")
+    (COND
+       ((AND (IGEQ (fetch (ARRAYBLOCK ARLEN) of BASE)
+                   \MinArrayBlockSize)
+             (fetch (ARRAYBLOCK FWD) of BASE))       (* ; 
+                                           "Allegedly, BASE has been 'checked' before coming here.")
+        (PROG [(F (fetch (ARRAYBLOCK FWD) of BASE))
+               (B (fetch (ARRAYBLOCK BKWD) of BASE))
+               (FBL (FREEBLOCKCHAIN.N (fetch ARLEN of BASE]
+              (COND
+                 ((EQ BASE F)
+                  (COND
+                     ((EQ BASE (\GETBASEPTR FBL 0))
+                      (\PUTBASEPTR FBL 0 NIL))
+                     (T (\MP.ERROR \MP.BADDELETEBLOCK "deleting last block # FREEBLOCKLIST")))
+                  (RETURN))
+                 ((EQ BASE (\GETBASEPTR FBL 0))
+                  (\PUTBASEPTR FBL 0 F)))
+              (replace (ARRAYBLOCK BKWD) of F with B)
+              (replace (ARRAYBLOCK FWD) of B with F])
+
+(\LINKBLOCK
+  [LAMBDA (BASE)                                         (* JonL "16-Jan-85 02:46")
+
+    (* ;; "Add BASE to the free list.  Assumes that BASE is a well-formed free block.")
+
+    [COND
+       (\FREEBLOCKBUCKETS (COND
+                             ((ILESSP (fetch (ARRAYBLOCK ARLEN) of BASE)
+                                     \MinArrayBlockSize)
+                              (\CHECKARRAYBLOCK BASE T))
+                             (T (PROG ((FBL (FREEBLOCKCHAIN.N (fetch ARLEN of BASE)))
+                                       FREEBLOCK)
+                                      (SETQ FREEBLOCK (\GETBASEPTR FBL 0))
+                                      (COND
+                                         ((NULL FREEBLOCK)
+                                          (replace (ARRAYBLOCK FWD) of BASE with BASE)
+                                          (replace (ARRAYBLOCK BKWD) of BASE with BASE))
+                                         (T (replace (ARRAYBLOCK FWD) of BASE with 
+                                                                                            FREEBLOCK
+                                                   )
+                                            (replace (ARRAYBLOCK BKWD) of BASE
+                                               with (fetch (ARRAYBLOCK BKWD) of FREEBLOCK
+                                                               ))
+                                            (replace (ARRAYBLOCK FWD) of (fetch
+                                                                                  (ARRAYBLOCK BKWD)
+                                                                                    of FREEBLOCK)
+                                               with BASE)
+                                            (replace (ARRAYBLOCK BKWD) of FREEBLOCK
+                                               with BASE)))
+                                      (\PUTBASEPTR FBL 0 BASE)
+                                      (\CHECKARRAYBLOCK BASE T T]
+    BASE])
+
+(\MERGEBACKWARD
+  [LAMBDA (BASE)                                         (* bvm%: " 6-Feb-85 16:53")
+
+    (* ;; "Caller is uninterruptable and asserts that a non-NIL BASE is a free but unlinked arrayblock.  We return a linked (if possible) block, either BASE itself or an enlarged previous free block that is linked (if possible) and includes the BASE storage.")
+
+    (PROG (ARLEN PARLEN PBASE PTRAILER SPLIT)
+          [COND
+             ((NULL BASE)
+              (RETURN NIL))
+             ([OR (NOT \ARRAYMERGING)
+                  (EQ BASE \ARRAYSPACE)
+                  (EQ BASE \ARRAYSPACE2)
+                  (fetch (ARRAYBLOCK INUSE) of (SETQ PTRAILER (\ADDBASE BASE (IMINUS 
+                                                                              \ArrayBlockTrailerWords
+                                                                                            ]
+
+              (* ;; "If this is the absolute 'first' block of array space, then there is nothing behind it to merge;  similarly, if the block behind it is in use, then don't merge.")
+
+              (RETURN (\LINKBLOCK BASE]
+          [SETQ PBASE (\ADDBASE2 BASE (IMINUS (fetch (ARRAYBLOCK ARLEN) of PTRAILER]
+          (\CHECKARRAYBLOCK PBASE T)
+          (\DELETEBLOCK? PBASE)
+          (RETURN (\ARRAYBLOCKMERGER PBASE BASE])
+
+(\MERGEFORWARD
+  [LAMBDA (BASE)                                         (* bvm%: "15-Feb-85 11:18")
+
+    (* ;; "BASE is a free and linked (if possible) block.  Merge with the next block if it is free and not too big.  Caller must be uninterruptable.")
+
+    (PROG (NBASE NBINUSE)
+          (COND
+             ((OR (NOT \ARRAYMERGING)
+                  (NULL BASE)
+                  (\CHECKARRAYBLOCK BASE T T)
+                  (EQ (SETQ NBASE (\ADDBASE2 BASE (fetch (ARRAYBLOCK ARLEN) of BASE)))
+                      \ArrayFrLst)
+                  (EQ NBASE \ArrayFrLst2)
+                  [\CHECKARRAYBLOCK NBASE (NOT (SETQ NBINUSE (fetch (ARRAYBLOCK INUSE)
+                                                                    of NBASE]
+                  NBINUSE)
+              (RETURN NIL)))                                 (* ; 
+                                "Note that if we ever get to here, both blocks have been 'checked'")
+          (\DELETEBLOCK? NBASE)
+          (\DELETEBLOCK? BASE)
+          (\ARRAYBLOCKMERGER BASE NBASE])
+
+(\ARRAYBLOCKMERGER
+  [LAMBDA (BASE NBASE)                                   (* bvm%: "13-Feb-85 14:57")
+
+(* ;;; "BASE and NBASE are two consecutive unlinked freeblocks.  (Called only after the two blocks have been 'checked')")
+
+    (PROG ((ARLEN (fetch (ARRAYBLOCK ARLEN) of BASE))
+           (NARLEN (fetch (ARRAYBLOCK ARLEN) of NBASE))
+           SECONDBITE MINBLOCKSIZE SHAVEBACK)
+          (SETQ SECONDBITE (IDIFFERENCE \MaxArrayBlockSize ARLEN))
+          (COND
+             ((IGREATERP NARLEN SECONDBITE)
+
+              (* ;; "check if sum of NARLEN+ARLEN is leq maximum.  (Written this way to stay within small number range.) If not, then break up into two freeblocks since one can't hold all the cells.")
+
+              (SETQ ARLEN \MaxArrayBlockSize)
+              (SETQ NARLEN (IDIFFERENCE NARLEN SECONDBITE))
+
+              (* ;; "Normal overflow case is just to make the first block as big as possible, then leave the rest in the second block.  So the code above adds to ARLEN and subtracts from NARLEN an equal amount to achieve the desired split.  However, check that the remaining NBASE block is not too small")
+
+              (COND
+                 ([ILESSP NARLEN (SETQ MINBLOCKSIZE (COND
+                                                       (\HUNKING? (IPLUS \ArrayBlockOverheadCells 
+                                                                         \MAX.CELLSPERHUNK))
+                                                       (T \MinArrayBlockSize]
+
+                  (* ;; "Decrease ARLEN and SECONDBITE by the amount it will take to get NARLEN up to MINBLOCKSIZE -- SHAVEBACK is negative")
+
+                  (SETQ SHAVEBACK (IDIFFERENCE NARLEN (SETQ NARLEN MINBLOCKSIZE)))
+                  (add ARLEN SHAVEBACK)
+                  (add SECONDBITE SHAVEBACK)))
+
+              (* ;; "Okay, make a tail of the second block into a free block of its own")
+
+              (\LINKBLOCK (\MAKEFREEARRAYBLOCK (\ADDBASE2 NBASE SECONDBITE)
+                                     NARLEN))
+              (SETQ NARLEN 0)))
+          (RETURN (\LINKBLOCK (\MAKEFREEARRAYBLOCK BASE (IPLUS ARLEN NARLEN])
+
+(\#BLOCKDATACELLS
+  [LAMBDA (DATAWORD)                                     (* JonL "20-Sep-84 19:07")
+
+    (* ;; "DATAWORD is a pointer as would be returned by \ALLOCBLOCK Returns the number of cells available to the caller.  Compiled closed so that we can change internal representations without clients needing to be recompiled.")
+
+    (PROG ((TYPENO (NTYPX DATAWORD)))
+          (RETURN (COND
+                     [(EQ 0 TYPENO)
+                      (COND
+                         ((type? ARRAYBLOCK DATAWORD)
+                          (IDIFFERENCE (fetch (ARRAYBLOCK ARLEN) of (\ADDBASE DATAWORD
+                                                                                   (IMINUS 
+                                                                               \ArrayBlockHeaderWords
+                                                                                          )))
+                                 \ArrayBlockOverheadCells))
+                         (T (\ILLEGAL.ARG DATAWORD]
+                     (T (OR (AND (OR \HUNKING? (fetch DTDHUNKP of (\GETDTD TYPENO)))
+                                 (HUNKSIZEFROMNUMBER TYPENO))
+                            (\ILLEGAL.ARG DATAWORD])
+
+(\COPYARRAYBLOCK
+  [LAMBDA (OLD)                                      (* ; "Edited  3-Mar-87 22:28 by bvm:")
+    (LET [(HEADER (\ADDBASE OLD (IMINUS \ArrayBlockHeaderWords]
+         (COND
+            [(AND (IEQ \ArrayBlockPassword (fetch PASSWORD of HEADER))
+                  (fetch (ARRAYBLOCK INUSE) of HEADER))
+             (LET* ((LEN (- (fetch (ARRAYBLOCK ARLEN) of HEADER)
+                            \ArrayBlockOverheadCells))
+                    (TYP (fetch (ARRAYBLOCK GCTYPE) of HEADER))
+                    (NEW (\ALLOCBLOCK LEN TYP)))
+                   (PROG1 NEW
+                       (SELECTC TYP
+                           (PTRBLOCK.GCT                     (* ; 
+                                                  "Have to reference count the pointers as we copy")
+                                         (FRPTQ LEN (\RPLPTR NEW 0 (COPYALL (\GETBASEPTR OLD 0)))
+                                                (SETQ NEW (\ADDBASE NEW WORDSPERCELL))
+                                                (SETQ OLD (\ADDBASE OLD WORDSPERCELL))))
+                           (CODEBLOCK.GCT                    (* ; 
+                                                           "should increment references from code")
+                                          (\COPYCODEBLOCK NEW OLD (UNFOLD LEN WORDSPERCELL)))
+                           (\BLT NEW OLD (UNFOLD LEN WORDSPERCELL))))]
+            (T                                               (* ; "Not an array block")
+               OLD])
+
+(\RECLAIMARRAYBLOCK
+  [LAMBDA (P)                                            (* ; "Edited  8-Jan-88 18:31 by jop")
+
+    (* ;; "Called to reclaim objects of type 0.  This is called with interrupts turned off.  Returns T to tell GC that we reclaimed it.")
+
+    (PROG ((B (\ADDBASE P (IMINUS \ArrayBlockHeaderWords)))
+           (RECLAIM-P T))
+
+     (* ;; "B points to arrayblock header, P to first and subsequent data words")
+
+          (IF (OR (< (\HILOC P)
+                         \FirstArraySegment)
+                      (NOT (IEQ \ArrayBlockPassword (fetch PASSWORD of B)))
+                      (NOT (fetch (ARRAYBLOCK INUSE) of B)))
+              THEN 
+
+                    (* ;; "RAID instead of \GCERROR because this error is continuable with ^N.")
+
+                    (\MP.ERROR \MP.BADARRAYRECLAIM 
+                           "Bad array block reclaimed--continue with ^N but save state ASAP")
+                    (RETURN T))
+          (SELECTC (fetch (ARRAYBLOCK GCTYPE) of B)
+              (PTRBLOCK.GCT                                  (* ; "Release all pointers")
+                            (for old P (TRAILER _ (fetch (ARRAYBLOCK TRAILER)
+                                                             of B)) by (\ADDBASE P 
+                                                                                      WORDSPERCELL)
+                               until (EQ P TRAILER) do (\RPLPTR P 0 NIL)))
+              (CODEBLOCK.GCT                                 (* ; "Release literals")
+
+                             (* ;; "Since \reclaimcodeblock is a finalization function -- returns nil if do reclaim and t if don't reclaim")
+
+                             (SETQ RECLAIM-P (NOT (\RECLAIMCODEBLOCK P))))
+              NIL)
+          [IF RECLAIM-P
+              THEN (\MERGEFORWARD (\MERGEBACKWARD (\MAKEFREEARRAYBLOCK B
+                                                                     (fetch ARLEN of B]
+
+     (* ;; "Always tell GC that we have reclaimed it")
+
+          (RETURN T])
+
+(\ADVANCE.ARRAY.SEGMENTS
+  [LAMBDA (NXTPAGE)                                      (* ; "Edited  4-Jan-93 02:08 by jds")
+
+(* ;;; "Called when the first 8mb are exhausted, and we want to switch array space into the next area, starting with page NXTPAGE -- have to first clean up what's left in the old area")
+
+    (PROG (NCELLSLEFT)
+          (SETQ.NOREF \ArrayFrLst2 (COND
+                                      ((IGEQ [SETQ NCELLSLEFT
+                                              (IPLUS (UNFOLD (SUB1 (IDIFFERENCE \NxtArrayPage
+                                                                          (fetch (POINTER PAGE#)
+                                                                             of \ArrayFrLst)))
+                                                            CELLSPERPAGE)
+                                                     (IDIFFERENCE CELLSPERPAGE (fetch
+                                                                                (POINTER CELLINPAGE)
+                                                                                  of \ArrayFrLst]
+                                             \MinArrayBlockSize)
+                                                             (* ; 
+                            "Make the rest of the already allocated array space into a small block")
+                                       (\MERGEBACKWARD (\MAKEFREEARRAYBLOCK \ArrayFrLst 
+                                                                  NCELLSLEFT))
+                                       (create POINTER
+                                              PAGE# _ \LeastMDSPage))
+                                      (T \ArrayFrLst)))
+          [SETQ.NOREF \ARRAYSPACE2 (SETQ.NOREF \ArrayFrLst (create POINTER
+                                                                  PAGE# _ (\PUTBASEFIXP \NxtArrayPage
+                                                                                 0 NXTPAGE]
+                                                             (* ; 
+                                "Return code to tell \ALLOCBLOCK.NEW to notice the new arrangement")
+          (RETURN 0])
+)
+
+(ADDTOVAR \MAIKO.MOVDS (\MAIKO.ALLOCBLOCK \ALLOCBLOCK))
+(DEFINEQ
+
+(\BYTELT
+  [LAMBDA (A J)                                          (* JonL "20-Sep-84 20:01")
+
+    (* ;; "A special function for system accesses to 0-origin byte arrays, of which syntax-tables are the primary example.  This compiles open into a GETBASEBYTE, with no checking for argument validity!")
+
+    (OR [AND [EQ 0 (fetch (ARRAYP ORIG) of (SETQ A (\DTEST A 'ARRAYP]
+             (OR (EQ \ST.BYTE (fetch (ARRAYP TYP) of A))
+                 (EQ \ST.CODE (fetch (ARRAYP TYP) of A]
+        (LISPERROR "ILLEGAL ARG" A))
+    (OR (IGREATERP (fetch (ARRAYP LENGTH) of A)
+               J)
+        (LISPERROR "ILLEGAL ARG" J))
+    (\GETBASEBYTE (fetch (ARRAYP BASE) of A)
+           (IPLUS (fetch (ARRAYP OFFST) of A)
+                  J])
+
+(\BYTESETA
+  [LAMBDA (A J V)                                        (* JonL "20-Sep-84 20:01")
+
+    (* ;; "A special function for system setting of 0-origin byte arrays, of which syntax-tables are the primary example.  This compiles open into a GETBASEBYTE, with no checking for argument validity! --- NOTE: The value is undefined, not V!")
+
+    (OR [AND [EQ 0 (fetch (ARRAYP ORIG) of (SETQ A (\DTEST A 'ARRAYP]
+             (OR (EQ \ST.BYTE (fetch (ARRAYP TYP) of A))
+                 (EQ \ST.CODE (fetch (ARRAYP TYP) of A]
+        (LISPERROR "ILLEGAL ARG" A))
+    (OR (IGREATERP (fetch (ARRAYP LENGTH) of A)
+               J)
+        (LISPERROR "ILLEGAL ARG" J))
+    (AND (fetch (ARRAYP READONLY) of A)
+         (LISPERROR "ILLEGAL ARG" A))
+    (\PUTBASEBYTE (fetch (ARRAYP BASE) of A)
+           (IPLUS (fetch (ARRAYP OFFST) of A)
+                  J)
+           V])
+
+(\WORDELT
+  [LAMBDA (A J)                                          (* JonL "20-Sep-84 20:02")
+
+    (* ;; "A special function for system accesses to 0-origin word arrays, This compiles open into a GETBASE, with no checking for argument validity!")
+
+    (OR (AND [EQ 0 (fetch (ARRAYP ORIG) of (SETQ A (\DTEST A 'ARRAYP]
+             (EQ \ST.POS16 (fetch (ARRAYP TYP) of A)))
+        (LISPERROR "ILLEGAL ARG" A))
+    (OR (IGREATERP (fetch (ARRAYP LENGTH) of A)
+               J)
+        (LISPERROR "ILLEGAL ARG" J))
+    (\GETBASE (fetch (ARRAYP BASE) of A)
+           (IPLUS (fetch (ARRAYP OFFST) of A)
+                  J])
+)
+(DEFINEQ
+
+(\ARRAYTYPENAME
+  [LAMBDA (X)                                            (* rmk%: "21-Dec-83 14:55")
+
+    (* ;; 
+  "This is called from the VM function TYPENAME to determine the 'logical' type of the array X")
+
+    (SELECTC (fetch (ARRAYP TYP) of X)
+        (\ST.CODE 'CCODEP)
+        'ARRAYP])
+)
+
+(RPAQQ \ARRAYMERGING T)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \ARRAYMERGING)
+)
+
+
+
+(* ; "for STORAGE")
+
+(DEFINEQ
+
+(\SHOW.ARRAY.FREELISTS
+  [LAMBDA (SIZESLST)                                     (* bvm%: "12-Feb-85 15:25")
+    (COND
+       ((OR SIZESLST (SETQ SIZESLST STORAGE.ARRAYSIZES))
+        (RESETFORM (RECLAIMMIN MAX.SMALLP)
+               (PROG ((TABLE \ABSTORAGETABLE)
+                      (N (LENGTH SIZESLST))
+                      (TOTAL 0)
+                      FBL ABLOCK ARLEN)
+                     [COND
+                        ((OR (NOT (\BLOCKDATAP TABLE))
+                             (IGEQ N (FOLDLO (\#BLOCKDATACELLS TABLE)
+                                            2)))
+
+                         (* ;; "Need bigger table if someone has enlarged SIZESLST since last time.  There are 2 cells per table entry")
+
+                         (SETQ \ABSTORAGETABLE (SETQ TABLE (\ALLOCBLOCK (UNFOLD (IPLUS N 4)
+                                                                                   2)
+                                                                  UNBOXEDBLOCK.GCT]
+                     (\CLEARCELLS TABLE (\#BLOCKDATACELLS TABLE))
+                     [for BKTI from 0 to \MAXBUCKETINDEX
+                        do (COND
+                                  ((SETQ FBL (\GETBASEPTR (\ADDBASE2 \FREEBLOCKBUCKETS BKTI)
+                                                    0))
+                                   (SETQ ABLOCK FBL)
+                                   (repeatuntil (EQ FBL (SETQ ABLOCK (fetch (ARRAYBLOCK
+                                                                                     FWD)
+                                                                            of ABLOCK)))
+                                      do (add TOTAL (SETQ ARLEN (fetch (ARRAYBLOCK ARLEN)
+                                                                           of ABLOCK)))
+                                            (for (SAFENTRY _ TABLE)
+                                               by (\ADDBASE SAFENTRY (TIMES 2 WORDSPERCELL))
+                                               as X in SIZESLST
+                                               when (OR (NULL X)
+                                                            (ILEQ ARLEN X))
+                                               do (add (fetch SAFITEMS of SAFENTRY)
+                                                             1)
+                                                     (add (fetch SAFCELLS of SAFENTRY)
+                                                            ARLEN)
+                                                     (RETURN]
+                     (printout NIL T " variable-datum free list: " T)
+                     (for (SAFENTRY _ TABLE) by (\ADDBASE SAFENTRY (TIMES 2 WORDSPERCELL))
+                        as X in SIZESLST do (COND
+                                                           (X (printout NIL "le " X))
+                                                           (T (printout NIL "others ")))
+                                                       (printout NIL 10 .I8 (fetch SAFITEMS
+                                                                               of SAFENTRY)
+                                                              " items; " .I8 (fetch SAFCELLS
+                                                                                of SAFENTRY)
+                                                              " cells." T))
+                     (printout NIL T "Total cells free: " .I8 TOTAL "  total pages: " .I4
+                            (FOLDHI TOTAL CELLSPERPAGE)
+                            T T])
+)
+
+(RPAQ? \ABSTORAGETABLE NIL)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \ABSTORAGETABLE)
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE
+
+(BLOCKRECORD SAFTABLE ((SAFITEMS WORD)
+                           (NIL WORD)
+                           (SAFCELLS FIXP)))
+)
+)
+
+
+
+(* ; "Debugging and RDSYS")
+
+(DEFINEQ
+
+(\CHECKARRAYBLOCK
+  [LAMBDA (BASE FREE ONFREELIST)                         (* bvm%: "13-Feb-85 14:50")
+    (COND
+       (ARRAYBLOCKCHECKING (PROG (ERROR TRAILER)
+                                 (COND
+                                    ((NEQ (fetch (ARRAYBLOCK PASSWORD) of BASE)
+                                          \ArrayBlockPassword)
+                                     (SETQ ERROR "ARRAYBLOCK Password wrong"))
+                                    ((NEQ (fetch (ARRAYBLOCK INUSE) of BASE)
+                                          (NOT FREE))
+                                     (SETQ ERROR "ARRAYBLOCK INUSE bit set wrong"))
+                                    ((UNLESSRDSYS (AND FREE (NEQ (\REFCNT BASE)
+                                                                 1))
+                                            NIL)
+                                     (SETQ ERROR "Free ARRAYBLOCK with RefCnt not 1"))
+                                    ((NEQ (fetch (ARRAYBLOCK PASSWORD)
+                                             of (SETQ TRAILER (fetch (ARRAYBLOCK TRAILER)
+                                                                     of BASE)))
+                                          \ArrayBlockPassword)
+                                     (SETQ ERROR "ARRAYBLOCK Trailer password wrong"))
+                                    ((NEQ (fetch (ARRAYBLOCK ARLEN) of BASE)
+                                          (fetch (ARRAYBLOCK ARLEN) of TRAILER))
+                                     (SETQ ERROR "ARRAYBLOCK Header and Trailer length don't match"))
+                                    ((NEQ (fetch (ARRAYBLOCK INUSE) of BASE)
+                                          (NOT FREE))
+                                     (SETQ ERROR "ARRAYBLOCK Trailer INUSE bit set wrong"))
+                                    ((OR (NOT ONFREELIST)
+                                         (ILESSP (fetch (ARRAYBLOCK ARLEN) of BASE)
+                                                \MinArrayBlockSize))
+                                                             (* ; 
+                                                     "Remaining tests only for blocks on free list")
+                                     (RETURN))
+                                    ((OR (NOT (EQPTR (fetch (ARRAYBLOCK FWD)
+                                                        of (fetch (ARRAYBLOCK BKWD)
+                                                                  of BASE))
+                                                     BASE))
+                                         (NOT (EQPTR (fetch (ARRAYBLOCK BKWD)
+                                                        of (fetch (ARRAYBLOCK FWD)
+                                                                  of BASE))
+                                                     BASE)))
+                                     (SETQ ERROR "ARRAYBLOCK links fouled"))
+                                    [(bind (FBL _ (FREEBLOCKCHAIN.N (fetch (ARRAYBLOCK ARLEN)
+                                                                           of BASE)))
+                                            ROVER first (OR (SETQ ROVER (\GETBASEPTR FBL 0))
+                                                                (RETURN (SETQ ERROR 
+                                                                         "Free block's bucket empty")
+                                                                       ))
+                                        do (AND (EQPTR ROVER BASE)
+                                                    (RETURN))
+                                              (\CHECKARRAYBLOCK ROVER T)
+                                        repeatuntil (EQ (SETQ ROVER (fetch (ARRAYBLOCK FWD)
+                                                                           of ROVER))
+                                                            (\GETBASEPTR FBL 0]
+                                    (T                       (* ; "Everything ok")
+                                       (RETURN)))
+                                 (UNLESSRDSYS (\MP.ERROR \MP.BADARRAYBLOCK ERROR BASE T)
+                                        (ERROR BASE ERROR))
+                                 (RETURN ERROR])
+
+(\PARSEARRAYSPACE
+  [LAMBDA (FN)                                           (* bvm%: "16-Apr-86 17:05")
+    (COND
+       ((NEQ \ArrayFrLst2 \ARRAYSPACE2)                      (* ; "Array space is in two chunks")
+        (\PARSEARRAYSPACE1 FN \ARRAYSPACE \ArrayFrLst2)
+        (\PARSEARRAYSPACE1 FN \ARRAYSPACE2 \ArrayFrLst))
+       (T (\PARSEARRAYSPACE1 FN \ARRAYSPACE \ArrayFrLst])
+
+(\PARSEARRAYSPACE1
+  [LAMBDA (FN START END)                                 (* bvm%: " 9-Jan-85 17:10")
+    (for (ROVER _ START) repeatuntil [EQPTR END (SETQ ROVER (\ADDBASE2 ROVER
+                                                                           (fetch (ARRAYBLOCK
+                                                                                       ARLEN)
+                                                                              of ROVER]
+       do (\CHECKARRAYBLOCK ROVER (NOT (fetch (ARRAYBLOCK INUSE) of ROVER))
+                     (AND (NOT (fetch (ARRAYBLOCK INUSE) of ROVER))
+                          (fetch (ARRAYBLOCK FWD) of ROVER)))
+             (AND FN (APPLY* FN ROVER (fetch (ARRAYBLOCK ARLEN) of ROVER)
+                            (fetch (ARRAYBLOCK INUSE) of ROVER)
+                            (fetch (ARRAYBLOCK GCTYPE) of ROVER])
+)
+
+(RPAQ? ARRAYBLOCKCHECKING )
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS ARRAYBLOCKCHECKING)
+)
+
+
+
+(* ; "Basic hunking")
+
+(DEFINEQ
+
+(\ALLOCHUNK
+  [LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN)               (* bvm%: "13-Jun-86 15:21")
+    (COND
+       ([AND ALIGN (OR (IGREATERP ALIGN \MAX.CELLSPERHUNK)
+                       (NOT (FMEMB ALIGN (SELECTC GCTYPE
+                                             (UNBOXEDBLOCK.GCT 
+                                                  (CONSTANT (for X in \HUNK.UNBOXEDSIZES
+                                                               when (AND (IGREATERP X 1)
+                                                                             (ILEQ X 
+                                                                                   \MAX.CELLSPERHUNK)
+                                                                             (POWEROFTWOP X))
+                                                               collect X)))
+                                             (PTRBLOCK.GCT (CONSTANT (for X in \HUNK.PTRSIZES
+                                                                        when (AND (IGREATERP
+                                                                                       X 1)
+                                                                                      (ILEQ X 
+                                                                                    \MAX.CELLSPERHUNK
+                                                                                            )
+                                                                                      (POWEROFTWOP
+                                                                                       X))
+                                                                        collect X)))
+                                             (CODEBLOCK.GCT (CONSTANT (LIST CELLSPERQUAD)))
+                                             NIL]            (* ; 
+                                                "Certify that the alignment request is legitimate.")
+        (ERROR "Oddball alignment request" ALIGN)))
+    (PROG ((TYPENUM.TABLE (SELECTC GCTYPE
+                              (UNBOXEDBLOCK.GCT 
+                                   \UNBOXEDHUNK.TYPENUM.TABLE)
+                              (CODEBLOCK.GCT \CODEHUNK.TYPENUM.TABLE)
+                              (PTRBLOCK.GCT \PTRHUNK.TYPENUM.TABLE)
+                              (SHOULDNT)))
+           (FAILCNT 0)
+           DTNUMBER HUNK HUNKSIZE ONPAGE STRADDLERS)
+      BEG [do (SETQ DTNUMBER (\GETBASEBYTE TYPENUM.TABLE NCELLS))
+                 (SETQ HUNKSIZE (HUNKSIZEFROMNUMBER DTNUMBER))
+             repeatuntil (OR (NOT ALIGN)
+                                 (EQ 0 (IREMAINDER (FOLDLO (fetch DTDSIZE of (\GETDTD 
+                                                                                            DTNUMBER)
+                                                                  )
+                                                          WORDSPERCELL)
+                                              ALIGN))
+                                 (COND
+                                    ((IGREATERP (SETQ NCELLS (ADD1 HUNKSIZE))
+                                            \MAX.CELLSPERHUNK)
+                                     (GO LOSE))
+                                    (T 
+
+                                 (* ;; "We're allowed to chunk up the size of the request in order to meet the alignment;  ultimately we should top off at \MAX.CELLSPERHUNK")
+
+                                       NIL]
+      LP  (SETQ HUNK (CREATECELL DTNUMBER))
+          (COND
+             ([OR (NULL INITONPAGE)
+                  (ILESSP INITONPAGE (SETQ ONPAGE (IDIFFERENCE CELLSPERPAGE (fetch (POINTER
+                                                                                        CELLINPAGE)
+                                                                               of HUNK]
+                                                             (* ; 
+                                                      "Ah, happy case -- all constraints satisfied")
+              (RETURN HUNK)))
+
+     (* ;; "Sigh, gotta try to get one with more of the initial `run' of cells on the same page.")
+
+          (COND
+             (\IN.MAKEINIT                                   (* ; "Lose!  Only code has an INITONPAGE requirement, and makeinit does not allocate code via \ALLOCBLOCK")
+                    (HELP "Call to \ALLOCBLOCK with non-NIL INITONPAGE demand" INITONPAGE))
+             (T (COND
+                   ([AND (EQ GCTYPE CODEBLOCK.GCT)
+                         (ILEQ (IQUOTIENT (ITIMES 10 ONPAGE)
+                                      HUNKSIZE)
+                               (COND
+                                  ((ILEQ HUNKSIZE 24)
+                                   60)
+                                  ((ILEQ HUNKSIZE 50)
+                                   50)
+                                  (T 30]
+
+                    (* ;; "If the percentage of the page-straddling codehunk that is on the first page is too small, then just toss this loser into the `black hole' This heuristic is based on empirical data taken about Sep 1984 which observed the ratio of `on-page' requirements to code length.")
+
+                    (\ADDREF HUNK))
+                   (T                                        (* ; 
+                          "So that a GC doesn't sneak in and put it back on the freelist too soon.")
+                      (push STRADDLERS HUNK)))
+                (COND
+                   ((IGREATERP (add FAILCNT 1)
+                           16)                               (* ; 
+                       "Put a limit to this nonsense of trying to find a non-page-straddling hunk!")
+                    (GO LOSE))
+                   ((EQ FAILCNT 8)                           (* ; 
+                  "After too many failures with this size of hunk, try the next container size up.")
+                    (SETQ NCELLS (ADD1 HUNKSIZE))
+                    (AND STRADDLERS (SETQ \HUNKREJECTS (NCONC STRADDLERS \HUNKREJECTS)))
+                    (GO BEG)))
+                (GO LP)))
+      LOSE
+          (AND STRADDLERS (SETQ \HUNKREJECTS (NCONC STRADDLERS \HUNKREJECTS)))
+          (RETURN])
+)
+
+(RPAQQ \HUNK.PTRSIZES (2 4 5 6 7 8 10 12 16 24 32 42 64))
+
+
+
+(* ; "Compiler needs \HUNK.PTRSIZES for creating closure environments")
+
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX)
+                                    (FOLDLO (fetch DTDSIZE of (\GETDTD NTYPX))
+                                           WORDSPERCELL)))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \HUNK.UNBOXEDSIZES 
+       (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64))
+
+(RPAQQ \HUNK.CODESIZES (12 16 20 24 28 32 36 42 50 64))
+
+(RPAQQ \HUNK.PTRSIZES (2 4 5 6 7 8 10 12 16 24 32 42 64))
+
+
+(CONSTANTS \HUNK.UNBOXEDSIZES \HUNK.CODESIZES \HUNK.PTRSIZES)
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \HUNKING? \UNBOXEDHUNK.TYPENUM.TABLE \CODEHUNK.TYPENUM.TABLE \PTRHUNK.TYPENUM.TABLE)
+)
+)
+
+
+
+(* ;; 
+"Keep a list of all the hunks rejected due to poor page-straddling alignment, or to code falling off the end of a doublepage"
+)
+
+
+(RPAQQ \HUNKREJECTS NIL)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \HUNKREJECTS)
+)
+
+
+
+(* ; "for MAKEINIT")
+
+(DEFINEQ
+
+(PREINITARRAYS
+  [LAMBDA NIL                                            (* bvm%: " 9-Jan-85 16:50")
+
+    (* ;; "This is called only at the very beginning of MAKEINIT.  \ARRAYspace and \ARRAYbase are INITCONSTANTS.  This sets up the array allocator so that MAKEINIT can do, e.g., string allocations.")
+
+    (DECLARE (GLOBALVARS \ArrayFrLst \ArrayFrLst2 \NxtArrayPage))
+    (SETQ.NOREF \ArrayFrLst (\VAG2 \FirstArraySegment 0))
+    (SETQ.NOREF \ArrayFrLst2 \ARRAYSPACE2)
+    (SETQ.NOREF \NxtArrayPage (PAGELOC \ArrayFrLst])
+
+(POSTINITARRAYS
+  [LAMBDA (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE)      (* bvm%: " 7-Feb-85 15:30")
+
+    (* ;; "Called only from MAKEINIT after all code and data has been copied to the new image.  AFTERCODEPTR is a pointer to the first word after the last code byte.  CODESTARTPAGE is the page at which MAKEINIT code arrays being.  This function makes sure that any unused space between the strings and the beginning of the code gets linked in as free arrayblocks.")
+
+    (SETQ \FREEBLOCKBUCKETS (\ALLOCBLOCK (ADD1 \MAXBUCKETINDEX)))
+    (PROG [(EXTRACELLS (IDIFFERENCE (UNFOLD CODESTARTPAGE CELLSPERPAGE)
+                              (IPLUS (UNFOLD (fetch SEGMENT# of \ArrayFrLst)
+                                            CELLSPERSEGMENT)
+                                     (fetch CELLINSEGMENT of \ArrayFrLst]
+
+     (* ;; "First, tell the makeiniter how many pages were left over in the string space.  He may want to adjust the constants to keep this down to just a couple of pages.")
+
+          (COND
+             ((IGREATERP EXTRACELLS \MaxArrayBlockSize)
+              (printout T T T "POSTINITARRAYS:  You pre-allocated too much string space." T 19 
+                     "MKI.CODESTARTOFFSET on MAKEINIT should be reduced by about "
+                     (IDIFFERENCE (FOLDLO EXTRACELLS CELLSPERPAGE)
+                            10)
+                     "." T)
+              (HELP))
+             ((IGEQ EXTRACELLS \MinArrayBlockSize)           (* ; 
+                                                  "We don't allow more than one array-block extra.")
+              (printout T T T "POSTINITARRAYS:  There were " (FOLDLO EXTRACELLS CELLSPERPAGE)
+                     " allocated but unused array pages." T T))
+             (T (printout T T "POSTINITARRAYS:  String space overflowed into code-arrays" T 19 
+                       "You should add at least " (ADD1 (FOLDLO (IMINUS EXTRACELLS)
+                                                               CELLSPERPAGE))
+                       " to MKI.CODESTARTOFFSET on MAKEINIT." T)
+                (HELP)))                                     (* ; 
+                                                           "Cause those pages to get allocated")
+          (\LINKBLOCK (\ALLOCBLOCK.NEW EXTRACELLS))
+          (SETQ.NOREF \ArrayFrLst AFTERCODEPTR)              (* ; 
+                                         "\NxtArrayPage is the next page that needs to be NEWPAGEd")
+          (SETQ.NOREF \NxtArrayPage CODENEXTPAGE)
+          (for VP from (PAGELOC \ARRAYSPACE) to (PAGELOC \NxtArrayPage)
+             by (FOLDLO \MDSIncrement WORDSPERPAGE) do (\MAKEMDSENTRY VP 0])
+
+(FILEARRAYBASE
+  [LAMBDA NIL                                            (* rmk%: "15-MAR-82 21:55")
+    (\ADDBASE \ARRAYSPACE (LOCAL (IPLUS (UNFOLD MKI.CODESTARTOFFSET WORDSPERPAGE)
+                                        (FOLDLO (IDIFFERENCE (GETFILEPTR (OUTPUT))
+                                                       MKI.FirstDataByte)
+                                               BYTESPERWORD])
+
+(FILEBLOCKTRAILER
+  [LAMBDA (BLOCKINFO)                                    (* rmk%: "18-NOV-82 09:49")
+
+    (* ;; 
+  "Sets up block trailer, assuming file is currently positioned just past the last dataword")
+
+    (BOUT16 OUTX \UsedArrayFlagWord)
+    (BOUT16 OUTX BLOCKINFO])
+
+(FILECODEBLOCK
+  [LAMBDA (NCELLS INITONPAGE)                            (* JonL "20-Sep-84 13:29")
+
+    (* ;; "sort of like CODEARRAY at MAKEINIT time for allocating space on the file;  this code borrowed from CODEARRAY and \ALLOCBLOCK.  Returns ARLEN, which is then passed to FILEBLOCKTRAILER to set trailer length.")
+
+    (PROG (PREFIXLEN (ARLEN (IPLUS NCELLS \ArrayBlockOverheadCells)))
+
+     (* ;; "ARLEN is the number of cells in the array .  INITONPAGE is number of cells which must reside on same page")
+
+          (COND
+             ([NEQ 0 (SETQ PREFIXLEN (\PREFIXALIGNMENT? ARLEN INITONPAGE CELLSPERQUAD 
+                                            CODEBLOCK.GCT (FILEARRAYBASE]
+
+              (* ;; "Check page first, cause if we did segment first and succeeded but then failed on page, we would have to check segment again.")
+
+              (FILEPATCHBLOCK PREFIXLEN)))
+          (BOUT16 OUTX \CodeArrayFlagWord)
+          (BOUT16 OUTX ARLEN)
+          (RETURN ARLEN])
+
+(FILEPATCHBLOCK
+  [LAMBDA (ARLEN)                                        (* rmk%: "18-NOV-82 09:50")
+
+    (* ;; "like \PATCHBLOCK for array allocation on files at MAKEINIT time")
+
+    (LOCAL (BOUT16 OUTX \FreeArrayFlagWord))                 (* ; "in-use bit off, password set")
+    (LOCAL (BOUT16 OUTX ARLEN))                              (* ; "number of cells in this block")
+    [COND
+       ((IGREATERP ARLEN \ArrayBlockHeaderCells)             (* ; 
+  "Assumes that header and trailer look alike, so that we only need one instance for a tiny block.")
+        (LOCAL (BOUTZEROS (UNFOLD (IDIFFERENCE ARLEN \ArrayBlockOverheadCells)
+                                 BYTESPERCELL)))             (* ; "zeros for data words")
+        (LOCAL (BOUT16 OUTX \FreeArrayFlagWord))             (* ; "Set up trailer")
+        (LOCAL (BOUT16 OUTX ARLEN]
+    NIL])
+)
+
+
+
+(* ; "Hunk Initialization")
+
+(DEFINEQ
+
+(\SETUP.HUNK.TYPENUMBERS
+  [LAMBDA NIL                                            (* ; "Edited  4-Mar-87 11:04 by bvm:")
+
+(* ;;; "Called before datatype table is initialized.  We add to the list of initial datatypes (\built-in-system-types) entries for all the hunk types we will want.")
+
+(* ;;; "Note: the compiler knows about the pointer hunk names, so it is important to coordinate any future changes to \HUNK.PTRSIZES with the compiler.")
+
+    (SETQ INITIALDTDCONTENTS (APPEND \BUILT-IN-SYSTEM-TYPES (\COMPUTE.HUNK.TYPEDECLS 
+                                                                   \HUNK.PTRSIZES PTRBLOCK.GCT
+                                                                   '\PTRHUNK)
+                                    (\COMPUTE.HUNK.TYPEDECLS \HUNK.UNBOXEDSIZES UNBOXEDBLOCK.GCT
+                                           '\UNBOXEDHUNK)
+                                    (\COMPUTE.HUNK.TYPEDECLS \HUNK.CODESIZES CODEBLOCK.GCT
+                                           '\CODEHUNK])
+
+(\COMPUTE.HUNK.TYPEDECLS
+  [LAMBDA (SIZELST GCTYPE PREFIX)                        (* ; "Edited  4-Mar-87 11:03 by bvm:")
+
+    (* ;; "Add type entries to INITIALDTDCONTENTS for the hunks in SIZELST of type GCTYPE.  PREFIX is the start of the name, e.g., \PTRHUNK.  Entries are of the form (name size ptrs finalization)")
+
+    (ALLOCAL (for HUNKSIZE in SIZELST BIND (FINAL _ (AND (EQ GCTYPE CODEBLOCK.GCT)
+                                                                     '\RECLAIMCODEBLOCK))
+                until (> HUNKSIZE \MAX.CELLSPERHUNK)
+                collect (LIST (PACK* PREFIX HUNKSIZE)
+                                  (UNFOLD HUNKSIZE WORDSPERCELL)
+                                  (COND
+                                     ((EQ GCTYPE PTRBLOCK.GCT)
+                                                             (* ; 
+                              "Compute DTDPTRS list, i.e., which fields are pointers (all of them)")
+                                      (for I from 0 by 2
+                                         to (SUB1 (UNFOLD HUNKSIZE WORDSPERCELL)) collect
+                                                                                      I)))
+                                  FINAL])
+
+(\TURN.ON.HUNKING
+  [LAMBDA NIL                                            (* bvm%: "13-Jun-86 17:27")
+
+(* ;;; "create all the datatypes, and the tables used to calculate a hunk datatype number from the allocation size request.")
+
+    (SETQ \UNBOXEDHUNK.TYPENUM.TABLE (\SETUP.TYPENUM.TABLE \HUNK.UNBOXEDSIZES UNBOXEDBLOCK.GCT
+                                            '\UNBOXEDHUNK))
+    (SETQ \CODEHUNK.TYPENUM.TABLE (\SETUP.TYPENUM.TABLE \HUNK.CODESIZES CODEBLOCK.GCT
+                                         '\CODEHUNK))
+    (SETQ \PTRHUNK.TYPENUM.TABLE (\SETUP.TYPENUM.TABLE \HUNK.PTRSIZES PTRBLOCK.GCT '\PTRHUNK))
+    (SETQ \HUNKING? T])
+
+(\SETUP.TYPENUM.TABLE
+  [LAMBDA (SIZELST GCTYPE PREFIX)                        (* ; "Edited  5-Mar-87 10:12 by bvm:")
+
+(* ;;; "Create a table that maps from number of cells desired to the closest hunk size that fits for a given GCTYPE.  SIZELST is  list of sizes in cells.  PREFIX is the datatype name prefix for this kind of hunk.")
+
+    (for I from 0 to \MAX.CELLSPERHUNK bind (HUNKSIZE _ -1)
+                                                         (SIZEL _ SIZELST)
+                                                         (TABLE _ (\ALLOCBLOCK
+                                                                   (FOLDHI (IPLUS 4 \MAX.CELLSPERHUNK
+                                                                                  )
+                                                                          BYTESPERCELL)
+                                                                   UNBOXEDBLOCK.GCT))
+                                                         TNAME DTD DTNUMBER
+       do [COND
+                 ((IGREATERP I HUNKSIZE)                     (* ; 
+                                                     "Advance to next quantum range in the SIZELST")
+                  (SETQ HUNKSIZE (OR (FIXP (pop SIZEL))
+                                     \MAX.CELLSPERHUNK))
+                  (SETQ TNAME (PACK* PREFIX HUNKSIZE))
+                  (COND
+                     ((for old DTNUMBER from 1 as TYPE in (LOCAL 
+                                                                                   INITIALDTDCONTENTS
+                                                                                     )
+                         when (EQ (LOCAL (CAR TYPE))
+                                      TNAME) do 
+
+                                 (* ;; "Find the type number that has been assigned to this hunk type.  Ordinarily would use \TYPENUMBERFROMNAME, but atoms haven't been initialized yet, so we can only talk locally")
+
+                                                   (RETURN DTNUMBER))
+                      (SETQ DTD (\GETDTD DTNUMBER))
+                      (replace DTDGCTYPE of DTD with GCTYPE)
+                      (replace DTDHUNKP of DTD with T))
+                     (T (HELP "No type declaration for" TNAME]
+             (\PUTBASEBYTE TABLE I DTNUMBER) finally (RETURN TABLE])
+)
+(DECLARE%: DONTCOPY 
+
+(ADDTOVAR INITVALUES (\NxtArrayPage)
+                         (\HUNKING?))
+
+(ADDTOVAR INITPTRS (\FREEBLOCKBUCKETS)
+                       (\ArrayFrLst)
+                       (\ArrayFrLst2)
+                       (\UNBOXEDHUNK.TYPENUM.TABLE)
+                       (\CODEHUNK.TYPENUM.TABLE)
+                       (\PTRHUNK.TYPENUM.TABLE))
+
+(ADDTOVAR INEWCOMS (FNS \#BLOCKDATACELLS \PREFIXALIGNMENT? \ALLOCBLOCK \MAIKO.ALLOCBLOCK 
+                            \ALLOCBLOCK.NEW \MAKEFREEARRAYBLOCK \MERGEBACKWARD \LINKBLOCK \ALLOCHUNK)
+                       (FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK
+                            FILEPATCHBLOCK)
+                       (FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING 
+                            \SETUP.TYPENUM.TABLE))
+
+(ADDTOVAR MKI.SUBFNS (\IN.MAKEINIT . T)
+                         (\ALLOCBLOCK.OLD . NILL)
+                         (\MERGEFORWARD . NILL)
+                         (\FIXCODENUM . I.FIXUPNUM)
+                         (\FIXCODESYM . I.FIXUPSYM)
+                         (\FIXCODEPTR . I.FIXUPPTR)
+                         (\CHECKARRAYBLOCK . NILL)
+                         (\ARRAYMERGING PROGN NIL))
+
+(ADDTOVAR EXPANDMACROFNS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER BUCKETINDEX FREEBLOCKCHAIN.N)
+
+(ADDTOVAR RDCOMS (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE \PARSEARRAYSPACE1))
+
+(ADDTOVAR RD.SUBFNS (EQPTR . EQUAL)
+                        (ARRAYBLOCKCHECKING . T))
+
+(ADDTOVAR RDPTRS (\FREEBLOCKBUCKETS))
+
+(ADDTOVAR RDVALS (\ArrayFrLst)
+                     (\ArrayFrLst2))
+EVAL@COMPILE 
+
+(ADDTOVAR DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER 
+                                   FILECODEBLOCK FILEPATCHBLOCK)
+
+(ADDTOVAR DONTCOMPILEFNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING 
+                                   \SETUP.TYPENUM.TABLE)
+)
+
+
+
+(* ; "Debugging aids")
+
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \ArrayFrLst)
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \ArrayBlockPassword 5461)
+
+
+(CONSTANTS \ArrayBlockPassword)
+)
+
+
+(ADDTOVAR DONTCOMPILEFNS \HUNKFIT? \AB.NEXT \AB.BACK)
+)
+(DEFINEQ
+
+(\HUNKFIT?
+  [LAMBDA (N)                                            (* JonL "15-Jan-85 00:48")
+
+    (* ;; "Show how an MDS unit of 2 pages would accomodate chunks of size N cells.")
+
+    (printout NIL T "Hunk size = " N " cells,  " (IQUOTIENT (FOLDLO \MDSIncrement WORDSPERCELL)
+                                                        N)
+           " fit in a MDS unit with "
+           (IREMAINDER (FOLDLO \MDSIncrement WORDSPERCELL)
+                  N)
+           " cells left over." T .TAB 8 "('unit' is split with " (IREMAINDER CELLSPERPAGE N)
+           " cells kept on first page)" T)
+    T])
+
+(\AB.NEXT
+  [LAMBDA (ABHI ABLO)                                    (* JonL "10-Sep-84 05:04")
+
+    (* ;; "ABHI and ABLO form the \HILOC and \LOLOC of some arrayblock which we want to 'go' to the predecessor of;  alternatively, ABHI can be a list of these two address parts, or just a random arrayblock address.")
+
+    (* ;; "Returns a 4-list;  size of the next block, whether or not it is free, and the \HILOC and the \LOLOC of that block")
+
+    [COND
+       [(AND (LISTP ABHI)
+             (NULL ABLO))
+        [COND
+           ((AND (EQ 4 (LENGTH ABHI))
+                 (FIXP (CAR ABHI))
+                 (SELECTQ (CADR ABHI)
+                     ((INUSE FREE) 
+                          T)
+                     NIL))                                   (* ; 
+                                                           "Result is output of \AB.NEXT itself")
+            (SETQ ABHI (CDDR ABHI]
+        (COND
+           ((EQ 2 (LENGTH ABHI))                             (* ; "A 2-list of \HILOC and \LOLOC")
+            (SETQ ABLO (CADR ABHI))
+            (SETQ ABHI (CAR ABHI]
+       ((OR (EQ ABHI \ArrayFrLst)
+            (type? ARRAYBLOCK ABHI))
+        (SETQ ABLO (\LOLOC ABHI))
+        (SETQ ABHI (\HILOC ABHI]
+    (OR (IGEQ ABHI 0)
+        (ERROR "Negative segment number?" ABHI))
+    (AND (IGREATERP ABHI (\HILOC \ArrayFrLst))
+         (ERROR "Segment number too high?" ABHI))
+    (OR (IGEQ ABLO 0)
+        (ERROR "Negative offset number?" ABLO))
+    (PROG (PW SIZE SIZE.WORDS (ABADDR (\VAG2 ABHI ABLO)))
+          [PROGN                                             (* ; "Checking on current block")
+                 (SETQ PW (\GETBASE ABADDR 0))
+                 [COND
+                    ((NEQ \ArrayBlockPassword (LOADBYTE PW 3 13))
+                     (SETQ ABADDR)
+                     (ERROR "Array Password not found at this loc" (LIST ABHI ABLO]
+                 (SETQ SIZE.WORDS (UNFOLD (SETQ SIZE (\GETBASE ABADDR 1))
+                                         WORDSPERCELL))
+                 (COND
+                    [(NEQ \ArrayBlockPassword (LOADBYTE (\GETBASE ABADDR (IDIFFERENCE SIZE.WORDS 2))
+                                                     3 13))
+                     (ERROR "Array Password not found just below this" (PROG1 (LIST ABHI ABLO)
+                                                                              (SETQ ABADDR]
+                    ((NEQ SIZE (\GETBASE ABADDR (IDIFFERENCE SIZE.WORDS 1)))
+                     (ERROR "Header and Trailer lengths disagree" (PROG1 (LIST ABHI ABLO)
+                                                                         (SETQ ABADDR]
+          (SETQ ABADDR (\ADDBASE ABADDR SIZE.WORDS))
+          (SETQ PW (\GETBASE ABADDR 0))
+          [COND
+             ((NEQ \ArrayBlockPassword (LOADBYTE PW 3 13))
+              (SETQ ABADDR)
+              (ERROR "Array Password not found at this loc" (LIST ABHI ABLO]
+          (RETURN (LIST (\GETBASE ABADDR 1)
+                        (COND
+                           ((ODDP PW)
+                            'INUSE)
+                           (T 'FREE))
+                        (\HILOC ABADDR)
+                        (\LOLOC ABADDR])
+
+(\AB.BACK
+  [LAMBDA (ABHI ABLO)                                    (* JonL " 9-Sep-84 16:28")
+
+    (* ;; "ABHI and ABLO form the \HILOC and \LOLOC of some arrayblock which we want to 'go' to the predecessor of;  alternatively, ABHI can be a list of these two address parts, or just a random arrayblock address.")
+
+    (* ;; "Returns a 4-list;  size of the block we are starting from, whether or not it is free, and the \HILOC and the \LOLOC of the predecessor block")
+
+    [COND
+       [(AND (LISTP ABHI)
+             (NULL ABLO))
+        [COND
+           ((AND (EQ 4 (LENGTH ABHI))
+                 (FIXP (CAR ABHI))
+                 (SELECTQ (CADR ABHI)
+                     ((INUSE FREE) 
+                          T)
+                     NIL))                                   (* ; 
+                                                           "Result is output of \AB.BACK itself")
+            (SETQ ABHI (CDDR ABHI]
+        (COND
+           ((EQ 2 (LENGTH ABHI))                             (* ; "A 2-list of \HILOC and \LOLOC")
+            (SETQ ABLO (CADR ABHI))
+            (SETQ ABHI (CAR ABHI]
+       ((OR (EQ ABHI \ArrayFrLst)
+            (type? ARRAYBLOCK ABHI))
+        (SETQ ABLO (\LOLOC ABHI))
+        (SETQ ABHI (\HILOC ABHI]
+    (OR (IGEQ ABHI 0)
+        (ERROR "Negative segment number?" ABHI))
+    (AND (IGREATERP ABHI (\HILOC \ArrayFrLst))
+         (ERROR "Segment number too high?" ABHI))
+    (OR (IGEQ ABLO 0)
+        (ERROR "Negative offset number?" ABLO))
+    (PROG (PW SIZE (ABADDR (\ADDBASE (\VAG2 ABHI ABLO)
+                                  -2)))
+          (SETQ PW (\GETBASE ABADDR 0))
+          [COND
+             ((NEQ \ArrayBlockPassword (LOADBYTE PW 3 13))
+              (SETQ ABADDR)
+              (ERROR "Array Password not found just below this" (LIST ABHI ABLO]
+          (SETQ SIZE (\GETBASE ABADDR 1))
+          [SETQ ABADDR (\ADDBASE ABADDR (IMINUS (UNFOLD (SUB1 SIZE)
+                                                       WORDSPERCELL]
+          [COND
+             [(NEQ \ArrayBlockPassword (LOADBYTE (\GETBASE ABADDR 0)
+                                              3 13))
+              (ERROR "Array Password not found just below this" (PROG1 (LIST ABHI ABLO)
+                                                                       (SETQ ABADDR]
+             ((NEQ SIZE (\GETBASE ABADDR 1))
+              (ERROR "Header and Trailer lengths disagree" (PROG1 (LIST ABHI ABLO)
+                                                                  (SETQ ABADDR]
+          (RETURN (LIST SIZE (COND
+                                ((ODDP PW)
+                                 'INUSE)
+                                (T 'FREE))
+                        (\HILOC ABADDR)
+                        (\LOLOC ABADDR])
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA LISP::PUTHASH HARRAYPROP)
+)
+(PUTPROPS LLARRAYELT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1989 
+1990 1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (9331 21709 (AIN 9341 . 11614) (AOUT 11616 . 14218) (ARRAY 14220 . 19805) (ARRAYSIZE 
+19807 . 19947) (ARRAYTYP 19949 . 20545) (ARRAYORIG 20547 . 20714) (COPYARRAY 20716 . 21707)) (21875 
+29520 (ELT 21885 . 23314) (ELTD 23316 . 24241) (SETA 24243 . 26500) (SETD 26502 . 27496) (SUBARRAY 
+27498 . 29518)) (29555 55164 (HARRAY 29565 . 29785) (HASHARRAY 29787 . 33810) (HARRAYP 33812 . 33961) 
+(HARRAYPROP 33963 . 37998) (HARRAYSIZE 38000 . 38165) (CLRHASH 38167 . 39539) (MAPHASH 39541 . 40670) 
+(GETHASH 40672 . 44252) (PUTHASH 44254 . 44485) (LISP::PUTHASH 44487 . 45199) (REMHASH 45201 . 45346) (
+\HASHRECLAIM 45348 . 47131) (\HASHACCESS 47133 . 52895) (REHASH 52897 . 53621) (\COPYHARRAYP 53623 . 
+54353) (\HASHTABLE.DEFPRINT 54355 . 55162)) (55165 55721 (STRINGHASHBITS 55175 . 55332) (
+STRING-EQUAL-HASHBITS 55334 . 55719)) (55722 57784 (\STRINGHASHBITS-UFN 55732 . 56838) (
+\STRING-EQUAL-HASHBITS-UFN 56840 . 57782)) (62071 67166 (\CODEARRAY 62081 . 62911) (\FIXCODENUM 62913
+ . 63578) (\FIXCODEPTR 63580 . 64640) (\FIXCODESYM 64642 . 67164)) (78407 113562 (\ALLOCBLOCK 78417 . 
+82416) (\MAIKO.ALLOCBLOCK 82418 . 86610) (\ALLOCBLOCK.OLD 86612 . 91483) (\ALLOCBLOCK.NEW 91485 . 
+94410) (\PREFIXALIGNMENT? 94412 . 97955) (\MAKEFREEARRAYBLOCK 97957 . 98552) (\DELETEBLOCK? 98554 . 
+99659) (\LINKBLOCK 99661 . 101787) (\MERGEBACKWARD 101789 . 103150) (\MERGEFORWARD 103152 . 104249) (
+\ARRAYBLOCKMERGER 104251 . 106436) (\#BLOCKDATACELLS 106438 . 107674) (\COPYARRAYBLOCK 107676 . 109244
+) (\RECLAIMARRAYBLOCK 109246 . 111375) (\ADVANCE.ARRAY.SEGMENTS 111377 . 113560)) (113624 116057 (
+\BYTELT 113634 . 114433) (\BYTESETA 114435 . 115376) (\WORDELT 115378 . 116055)) (116058 116392 (
+\ARRAYTYPENAME 116068 . 116390)) (116515 120209 (\SHOW.ARRAY.FREELISTS 116525 . 120207)) (120522 
+126272 (\CHECKARRAYBLOCK 120532 . 124907) (\PARSEARRAYSPACE 124909 . 125318) (\PARSEARRAYSPACE1 125320
+ . 126270)) (126406 132672 (\ALLOCHUNK 126416 . 132670)) (133850 139746 (PREINITARRAYS 133860 . 134401
+) (POSTINITARRAYS 134403 . 137121) (FILEARRAYBASE 137123 . 137535) (FILEBLOCKTRAILER 137537 . 137832) 
+(FILECODEBLOCK 137834 . 138850) (FILEPATCHBLOCK 138852 . 139744)) (139783 145207 (
+\SETUP.HUNK.TYPENUMBERS 139793 . 140829) (\COMPUTE.HUNK.TYPEDECLS 140831 . 142111) (\TURN.ON.HUNKING 
+142113 . 142785) (\SETUP.TYPENUM.TABLE 142787 . 145205)) (147470 154071 (\HUNKFIT? 147480 . 148095) (
+\AB.NEXT 148097 . 151292) (\AB.BACK 151294 . 154069)))))
+STOP
diff --git a/CLTL2/LLARRAYELT.LCOM b/CLTL2/LLARRAYELT.LCOM
new file mode 100644
index 00000000..5d587800
Binary files /dev/null and b/CLTL2/LLARRAYELT.LCOM differ
diff --git a/CLTL2/LLARRAYELT.~2~ b/CLTL2/LLARRAYELT.~2~
new file mode 100644
index 00000000..889fa5e4
--- /dev/null
+++ b/CLTL2/LLARRAYELT.~2~
@@ -0,0 +1,2948 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "19-Jan-93 10:43:28" {DSK}<python>lde>lispcore>sources>LLARRAYELT.;2 154426 
+
+      changes to%:  (RECORDS HARRAYP HASHSLOT SEQUENCEDESCRIPTOR ARRAYP ARRAYBLOCK SAFTABLE)
+
+      previous date%: " 4-Jan-93 23:51:47" {DSK}<python>lde>lispcore>sources>LLARRAYELT.;1)
+
+
+(* ; "
+Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT LLARRAYELTCOMS)
+
+(RPAQQ LLARRAYELTCOMS 
+       [(PROPS (LLARRAYELT FILETYPE))
+        (COMS                                                (* ; "ARRAY entries")
+              (FNS AIN AOUT ARRAY ARRAYSIZE ARRAYTYP ARRAYORIG COPYARRAY)
+              (DECLARE%: DONTCOPY (MACROS ARRAYSIZE))
+              (FNS ELT ELTD SETA SETD SUBARRAY))
+        [COMS                                                (* ; "HASHARRAY entries")
+              (FNS HARRAY HASHARRAY HARRAYP HARRAYPROP HARRAYSIZE CLRHASH MAPHASH GETHASH PUTHASH 
+                   LISP::PUTHASH REMHASH \HASHRECLAIM \HASHACCESS REHASH \COPYHARRAYP 
+                   \HASHTABLE.DEFPRINT)
+              (FNS STRINGHASHBITS STRING-EQUAL-HASHBITS)
+              (FNS \STRINGHASHBITS-UFN \STRING-EQUAL-HASHBITS-UFN)
+              (DECLARE%: DONTCOPY (EXPORT (RECORDS HARRAYP)
+                                         (MACROS \EQHASHINGBITS))
+                     (RECORDS HASHSLOT)
+                     (MACROS \FIRSTINDEX \HASHSLOT \REPROBE)
+                     (CONSTANTS (CELLSPERSLOT 2))
+                     (GLOBALVARS \HASH.NULL.VALUE SYSHASHARRAY))
+              [DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'HARRAYP '\HASHTABLE.DEFPRINT]
+              (INITRECORDS HARRAYP)
+              (SYSRECORDS HARRAYP)
+              (VARS (\HASH.NULL.VALUE '\Hash\Null\Value\]
+        (COMS                                                (* ; "System entries for CODE")
+              (FNS \CODEARRAY \FIXCODENUM \FIXCODEPTR \FIXCODESYM))
+        (COMS                                                (* ; "Internal")
+              (DECLARE%: DONTCOPY (MACROS EQPTR BUCKETINDEX FREEBLOCKCHAIN.N)
+                     (CONSTANTS \MAXBUCKETINDEX)
+                                                             (* ; 
+                                "\ADDBASE2 and \ADDBASE4 do \ADDBASE of 2*N and 4*N without boxing")
+                     (EXPORT (MACROS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER \BYTELT \BYTESETA 
+                                    \WORDELT)
+                            (CONSTANTS * BLOCKGCTYPECONSTANTS)
+                            (CONSTANTS * ARRAYCONSTANTS)
+                            (CONSTANTS * ARRAYTYPES)
+                            (CONSTANTS \MAX.CELLSPERHUNK)
+                            (CONSTANTS (\IN.MAKEINIT))
+                            (RECORDS SEQUENCEDESCRIPTOR ARRAYP ARRAYBLOCK)
+                            (GLOBALVARS \NxtArrayPage \FREEBLOCKBUCKETS \HUNKING?))
+                     (GLOBALVARS \ArrayFrLst \ArrayFrLst2 \RECLAIM.COUNTDOWN))
+              (FNS \ALLOCBLOCK \MAIKO.ALLOCBLOCK \ALLOCBLOCK.OLD \ALLOCBLOCK.NEW \PREFIXALIGNMENT? 
+                   \MAKEFREEARRAYBLOCK \DELETEBLOCK? \LINKBLOCK \MERGEBACKWARD \MERGEFORWARD 
+                   \ARRAYBLOCKMERGER \#BLOCKDATACELLS \COPYARRAYBLOCK \RECLAIMARRAYBLOCK 
+                   \ADVANCE.ARRAY.SEGMENTS)
+              (ADDVARS (\MAIKO.MOVDS (\MAIKO.ALLOCBLOCK \ALLOCBLOCK)))
+              (FNS \BYTELT \BYTESETA \WORDELT)
+              (FNS \ARRAYTYPENAME)
+              (VARS (\ARRAYMERGING T))
+              (GLOBALVARS \ARRAYMERGING)
+              (COMS                                          (* ; "for STORAGE")
+                    (FNS \SHOW.ARRAY.FREELISTS)
+                    (INITVARS (\ABSTORAGETABLE NIL))
+                    (GLOBALVARS \ABSTORAGETABLE)
+                    (DECLARE%: DONTCOPY (RECORDS SAFTABLE)))
+              (COMS                                          (* ; "Debugging and RDSYS")
+                    (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE \PARSEARRAYSPACE1)
+                    (INITVARS (ARRAYBLOCKCHECKING))
+                    (GLOBALVARS ARRAYBLOCKCHECKING)))
+        (COMS                                                (* ; "Basic hunking")
+              (FNS \ALLOCHUNK)
+              (VARS \HUNK.PTRSIZES)
+                                                             (* ; 
+                                  "Compiler needs \HUNK.PTRSIZES for creating closure environments")
+              (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS HUNKSIZEFROMNUMBER))
+                     (CONSTANTS \HUNK.UNBOXEDSIZES \HUNK.CODESIZES \HUNK.PTRSIZES)
+                     (GLOBALVARS \HUNKING? \UNBOXEDHUNK.TYPENUM.TABLE \CODEHUNK.TYPENUM.TABLE 
+                            \PTRHUNK.TYPENUM.TABLE))
+              (COMS 
+                    (* ;; "Keep a list of all the hunks rejected due to poor page-straddling alignment, or to code falling off the end of a doublepage")
+
+                    (VARS (\HUNKREJECTS))
+                    (GLOBALVARS \HUNKREJECTS)))
+        [COMS                                                (* ; "for MAKEINIT")
+              (FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK 
+                   FILEPATCHBLOCK)
+              (COMS                                          (* ; "Hunk Initialization")
+                    (FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING 
+                         \SETUP.TYPENUM.TABLE))
+              (DECLARE%: DONTCOPY (ADDVARS (INITVALUES (\NxtArrayPage)
+                                                  (\HUNKING?))
+                                         (INITPTRS (\FREEBLOCKBUCKETS)
+                                                (\ArrayFrLst)
+                                                (\ArrayFrLst2)
+                                                (\UNBOXEDHUNK.TYPENUM.TABLE)
+                                                (\CODEHUNK.TYPENUM.TABLE)
+                                                (\PTRHUNK.TYPENUM.TABLE))
+                                         (INEWCOMS (FNS \#BLOCKDATACELLS \PREFIXALIGNMENT? 
+                                                        \ALLOCBLOCK \MAIKO.ALLOCBLOCK \ALLOCBLOCK.NEW
+                                                        \MAKEFREEARRAYBLOCK \MERGEBACKWARD \LINKBLOCK
+                                                        \ALLOCHUNK)
+                                                (FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE 
+                                                     FILEBLOCKTRAILER FILECODEBLOCK FILEPATCHBLOCK)
+                                                (FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS
+                                                     \TURN.ON.HUNKING \SETUP.TYPENUM.TABLE))
+                                         (MKI.SUBFNS (\IN.MAKEINIT . T)
+                                                (\ALLOCBLOCK.OLD . NILL)
+                                                (\MERGEFORWARD . NILL)
+                                                (\FIXCODENUM . I.FIXUPNUM)
+                                                (\FIXCODESYM . I.FIXUPSYM)
+                                                (\FIXCODEPTR . I.FIXUPPTR)
+                                                (\CHECKARRAYBLOCK . NILL)
+                                                (\ARRAYMERGING PROGN NIL))
+                                         (EXPANDMACROFNS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER 
+                                                BUCKETINDEX FREEBLOCKCHAIN.N)
+                                         (RDCOMS (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE 
+                                                      \PARSEARRAYSPACE1))
+                                         (RD.SUBFNS (EQPTR . EQUAL)
+                                                (ARRAYBLOCKCHECKING . T))
+                                         (RDPTRS (\FREEBLOCKBUCKETS))
+                                         (RDVALS (\ArrayFrLst)
+                                                (\ArrayFrLst2)))
+                     EVAL@COMPILE
+                     (ADDVARS (DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE 
+                                     FILEBLOCKTRAILER FILECODEBLOCK FILEPATCHBLOCK)
+                            (DONTCOMPILEFNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS 
+                                   \TURN.ON.HUNKING \SETUP.TYPENUM.TABLE]
+        (COMS                                                (* ; "Debugging aids")
+              (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \ArrayFrLst)
+                     (CONSTANTS \ArrayBlockPassword)
+                     (ADDVARS (DONTCOMPILEFNS \HUNKFIT? \AB.NEXT \AB.BACK)))
+              (FNS \HUNKFIT? \AB.NEXT \AB.BACK))
+        (LOCALVARS . T)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML)
+                                                                             (LAMA LISP::PUTHASH 
+                                                                                   HARRAYPROP])
+
+(PUTPROPS LLARRAYELT FILETYPE :BCOMPL)
+
+
+
+(* ; "ARRAY entries")
+
+(DEFINEQ
+
+(AIN
+  [LAMBDA (APTR INDEX N FILE)                            (* ; "Edited 23-Nov-86 16:44 by jop:")
+
+    (* ;; "Reads N elements into APTR starting at INDEX.  INDEX and N are in terms of the array's indexing units")
+
+    (COND
+       ((NOT (OR (STRINGP APTR)
+                 (ARRAYP APTR)))
+        (LISPERROR "ILLEGAL ARG" APTR))
+       ((IGREATERP 0 INDEX)
+        (LISPERROR "ILLEGAL ARG" INDEX)))
+    (LET (BASE LENGTH OFFST TYP ORIG STBYTE)
+         (if (STRINGP APTR)
+             then (SETQ BASE (ffetch (STRINGP BASE) of APTR))
+                   (SETQ LENGTH (ffetch (STRINGP LENGTH) of APTR))
+                   (SETQ OFFST (ffetch (STRINGP OFFST) of APTR))
+                   (SETQ TYP (ffetch (STRINGP TYP) of APTR))
+                   (SETQ ORIG 1)
+           else (SETQ BASE (ffetch (ARRAYP BASE) of APTR))
+                 (SETQ LENGTH (ffetch (ARRAYP LENGTH) of APTR))
+                 (SETQ OFFST (ffetch (ARRAYP OFFST) of APTR))
+                 (SETQ TYP (ffetch (ARRAYP TYP) of APTR))
+                 (SETQ ORIG (ffetch (ARRAYP ORIG) of APTR)))
+         (SETQ STBYTE (IDIFFERENCE INDEX ORIG))
+         (COND
+            ((ILESSP (SELECTC TYP
+                         ((LIST \ST.BYTE \ST.CODE) 
+                              LENGTH)
+                         (\ST.POS16 (SETQ OFFST (UNFOLD OFFST BYTESPERWORD))
+                                    (SETQ N (UNFOLD N BYTESPERWORD))
+                                    (SETQ STBYTE (UNFOLD STBYTE BYTESPERWORD))
+                                    (UNFOLD LENGTH BYTESPERWORD))
+                         ((LIST \ST.INT32 \ST.FLOAT) 
+                              (SETQ OFFST (UNFOLD OFFST BYTESPERCELL))
+                              (SETQ N (UNFOLD N BYTESPERCELL))
+                              (SETQ STBYTE (UNFOLD STBYTE BYTESPERCELL))
+                              (UNFOLD LENGTH BYTESPERCELL))
+                         (\ST.BIT)
+                         (LISPERROR "ILLEGAL ARG" APTR))
+                    (IPLUS STBYTE N))
+             (LISPERROR "ILLEGAL ARG" APTR)))
+         (\BINS (\GETOFD FILE 'INPUT)
+                BASE
+                (IPLUS STBYTE OFFST)
+                N)
+         APTR])
+
+(AOUT
+  [LAMBDA (APTR INDEX N FILE)                            (* ; "Edited 23-Nov-86 16:49 by jop:")
+                                                             (* ; 
+                                            "INDEX and N are in terms of the array's indexing unit")
+    (COND
+       ((NOT (OR (STRINGP APTR)
+                 (ARRAYP APTR)))
+        (LISPERROR "ILLEGAL ARG" APTR))
+       ((IGREATERP 0 INDEX)
+        (LISPERROR "ILLEGAL ARG" INDEX)))
+
+    (* ;; "Used to be in terms of the block record SEQUENCEDESCRIPTOR, but changed to refer explicitly to arrayp's and stringp's since stringp's no longer look like arrayp's")
+
+    (LET (BASE LENGTH OFFST TYP ORIG STBYTE)
+         (if (STRINGP APTR)
+             then (SETQ BASE (ffetch (STRINGP BASE) of APTR))
+                   (SETQ LENGTH (ffetch (STRINGP LENGTH) of APTR))
+                   (SETQ OFFST (ffetch (STRINGP OFFST) of APTR))
+                   (SETQ TYP (ffetch (STRINGP TYP) of APTR))
+                   (SETQ ORIG 1)
+           else (SETQ BASE (ffetch (ARRAYP BASE) of APTR))
+                 (SETQ LENGTH (ffetch (ARRAYP LENGTH) of APTR))
+                 (SETQ OFFST (ffetch (ARRAYP OFFST) of APTR))
+                 (SETQ TYP (ffetch (ARRAYP TYP) of APTR))
+                 (SETQ ORIG (ffetch (ARRAYP ORIG) of APTR)))
+         (SETQ STBYTE (IDIFFERENCE INDEX ORIG))              (* ; 
+                                                           "Standardize units before comparing")
+         (COND
+            ((ILESSP (SELECTC TYP
+                         ((LIST \ST.BYTE \ST.CODE) 
+                              LENGTH)
+                         (\ST.POS16 (SETQ N (UNFOLD N BYTESPERWORD))
+                                    (SETQ STBYTE (UNFOLD STBYTE BYTESPERWORD))
+                                    (SETQ OFFST (UNFOLD OFFST BYTESPERWORD))
+                                    (UNFOLD LENGTH BYTESPERWORD))
+                         ((LIST \ST.INT32 \ST.FLOAT) 
+                              (SETQ N (UNFOLD N BYTESPERCELL))
+                              (SETQ STBYTE (UNFOLD STBYTE BYTESPERCELL))
+                              (SETQ OFFST (UNFOLD OFFST BYTESPERCELL))
+                              (UNFOLD LENGTH BYTESPERCELL))
+                         (LISPERROR "ILLEGAL ARG" APTR))
+                    (IPLUS STBYTE N))
+             (LISPERROR "ILLEGAL ARG" APTR)))
+         (\BOUTS (\GETOFD FILE 'OUTPUT)
+                BASE
+                (IPLUS STBYTE OFFST)
+                N)
+         APTR])
+
+(ARRAY
+  [LAMBDA (SIZE TYPE INITVAL ORIG ALIGN)                 (* JonL "20-Sep-84 19:46")
+
+    (* ;; "extension of the normal VM definition of an array to allow many different TYPEs, and also allows ORIG of 0")
+
+    (SETQ SIZE (FIX SIZE))
+    (COND
+       ((OR (IGREATERP 0 SIZE)
+            (IGREATERP SIZE \MaxArrayLen))
+        (LISPERROR "ILLEGAL ARG" SIZE)))                     (* ; 
+                                                 "Coerce floats at outset;  \ALLOCARRAY wants fixp")
+    (PROG (AP TYP GCTYPE (NCELLS SIZE))
+          [SETQ TYP (SELECTQ TYPE
+                        (BYTE (SETQ NCELLS (FOLDHI SIZE BYTESPERCELL))
+                              \ST.BYTE)
+                        ((SMALLP SMALLPOSP WORD) 
+                             (SETQ NCELLS (FOLDHI SIZE WORDSPERCELL))
+                             \ST.POS16)
+                        ((NIL POINTER FLAG) 
+                             (SETQ GCTYPE PTRBLOCK.GCT)
+                             \ST.PTR)
+                        ((0 DOUBLEPOINTER)                   (* ; 
+                                               "INTERLISP-10 style arrays--each element is 2 cells")
+                             (SETQ NCELLS (UNFOLD SIZE 2))
+                             (SETQ GCTYPE PTRBLOCK.GCT)
+                             \ST.PTR2)
+                        (FIXP \ST.INT32)
+                        (FLOATP [COND
+                                   (INITVAL (SETQ INITVAL (FLOAT INITVAL]
+                                \ST.FLOAT)
+                        (BIT (SETQ NCELLS (FOLDHI SIZE BITSPERCELL))
+                             \ST.BIT)
+                        (SIGNEDWORD \ST.INT32)
+                        (COND
+                           ((EQ SIZE TYPE)                   (* ; "= FIXP")
+                            \ST.INT32)
+                           ((AND (LISTP TYPE)
+                                 (EQ (CAR TYPE)
+                                     'BITS))
+                            (COND
+                               ((IGREATERP (CADR TYPE)
+                                       16)
+                                \ST.INT32)
+                               ((IGREATERP (CADR TYPE)
+                                       8)
+                                (SETQ NCELLS (FOLDHI SIZE WORDSPERCELL))
+                                \ST.POS16)
+                               ((IGREATERP (CADR TYPE)
+                                       1)
+                                (SETQ NCELLS (FOLDHI SIZE BYTESPERCELL))
+                                \ST.BYTE)
+                               (T (SETQ NCELLS (FOLDHI SIZE BITSPERCELL))
+                                  \ST.BIT)))
+                           (T (\ILLEGAL.ARG TYPE]
+          (SETQ AP (create ARRAYP
+                          TYP _ TYP
+                          LENGTH _ SIZE
+                          ORIG _ (SELECTQ ORIG
+                                     ((0 1) 
+                                          ORIG)
+                                     (NIL 1)
+                                     (LISPERROR "ILLEGAL ARG" ORIG))
+                          OFFST _ 0
+                          BASE _ (\ALLOCBLOCK NCELLS GCTYPE NIL ALIGN)))
+          [AND INITVAL
+               (PROG ((BASE (fetch (ARRAYP BASE) of AP))
+                      (NWORDS (SUB1 (UNFOLD NCELLS WORDSPERCELL)))
+                      LASTWORD2BASE)
+                     (SETQ LASTWORD2BASE (\ADDBASE BASE (SUB1 NWORDS)))
+                     (SELECTC TYP
+                         (\ST.BYTE (OR (EQ 0 INITVAL)
+                                       (PROGN (\PUTBASE LASTWORD2BASE 1
+                                                     (create WORD
+                                                            HIBYTE _ INITVAL
+                                                            LOBYTE _ INITVAL))
+                                              (\BLT BASE (\ADDBASE BASE 1)
+                                                    NWORDS))))
+                         (\ST.POS16 (OR (EQ 0 INITVAL)
+                                        (PROGN (\PUTBASE LASTWORD2BASE 1 INITVAL)
+                                               (\BLT BASE (\ADDBASE BASE 1)
+                                                     NWORDS))))
+                         (\ST.INT32 [OR (EQ 0 INITVAL)
+                                        (PROGN (\PUTBASEFIXP LASTWORD2BASE 0 INITVAL)
+                                               (\BLT BASE (\ADDBASE BASE WORDSPERCELL)
+                                                     (SUB1 NWORDS])
+                         ((LIST \ST.PTR \ST.PTR2)            (* ; 
+                                    "Remove \ST.FLOAT when FLOATP is no longer stored in PTR mode.")
+                              [PROG ((P BASE))
+                                    (FRPTQ NCELLS (\RPLPTR P 0 INITVAL)
+                                           (SETQ P (\ADDBASE P WORDSPERCELL])
+                         (\ST.FLOAT [OR (FEQP 0.0 INITVAL)
+                                        (PROGN (\PUTBASEFLOATP LASTWORD2BASE 0 INITVAL)
+                                               (\BLT BASE (\ADDBASE BASE WORDSPERCELL)
+                                                     (SUB1 NWORDS])
+                         (\ST.BIT (OR (EQ 0 INITVAL)
+                                      (PROGN (\PUTBASE LASTWORD2BASE 1 MASKWORD1'S)
+                                             (\BLT BASE (\ADDBASE BASE 1)
+                                                   NWORDS))))
+                         (SHOULDNT]
+          (RETURN AP])
+
+(ARRAYSIZE
+  [LAMBDA (X)                                            (* JonL " 4-NOV-83 12:44")
+    (\MACRO.MX (ARRAYSIZE X])
+
+(ARRAYTYP
+  [LAMBDA (ARRAY)                                    (* rmk%: "30-Dec-83 13:12")
+
+    (* ;; "This is a VM function which returns valid 2nd argument to ARRAY")
+
+    (SELECTC (fetch (ARRAYP TYP) of (\DTEST ARRAY 'ARRAYP))
+        (\ST.BYTE 'BYTE)
+        (\ST.PTR2 'DOUBLEPOINTER)
+        (\ST.PTR 'POINTER)
+        (\ST.POS16 'SMALLPOSP)
+        (\ST.CODE                                            (* ; "not valid 2nd arg to ARRAY")
+                  'CODE)
+        (\ST.INT32 'FIXP)
+        (\ST.FLOAT 'FLOATP)
+        (\ST.BIT 'BIT)
+        (SHOULDNT])
+
+(ARRAYORIG
+  [LAMBDA (ARRAY)                                    (* rmk%: "30-Dec-83 13:12")
+    (fetch (ARRAYP ORIG) of (\DTEST ARRAY 'ARRAYP])
+
+(COPYARRAY
+  [LAMBDA (ARRAY)                                    (* JonL "16-Oct-84 20:38")
+    (COND
+       [(HARRAYP ARRAY)
+        (PROG [(NHARRAY (HASHARRAY (HARRAYSIZE ARRAY]
+              (\COPYHARRAYP ARRAY NHARRAY)
+              (RETURN (REHASH ARRAY NHARRAY]
+       (T (PROG (NEWARRAY INDEX (ORIG (ARRAYORIG ARRAY))
+                       (TYPE (ARRAYTYP ARRAY))
+                       (SIZE (ARRAYSIZE ARRAY)))
+                (SETQ NEWARRAY (ARRAY SIZE TYPE NIL ORIG))
+                (SETQ INDEX ORIG)
+                (FRPTQ SIZE (SETA NEWARRAY INDEX (ELT ARRAY INDEX))
+                       (add INDEX 1))
+                (SELECTQ TYPE
+                    ((DOUBLEPOINTER) 
+                         (SETQ INDEX ORIG)
+                         (FRPTQ SIZE (SETD NEWARRAY INDEX (ELTD ARRAY INDEX))
+                                (add INDEX 1)))
+                    NIL)
+                (RETURN NEWARRAY])
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+[PUTPROPS ARRAYSIZE DMACRO ((A)
+                            (ffetch (ARRAYP LENGTH) of (\DTEST A 'ARRAYP]
+)
+)
+(DEFINEQ
+
+(ELT
+  [LAMBDA (A N)                                          (* lmm " 7-Jun-84 17:53")
+    (\DTEST A 'ARRAYP)
+    (PROG [(BASE (fetch (ARRAYP BASE) of A))
+           (N0 (IDIFFERENCE N (fetch (ARRAYP ORIG) of A]
+          (COND
+             ((OR (IGREATERP 0 N0)
+                  (IGEQ N0 (fetch (ARRAYP LENGTH) of A)))
+              (LISPERROR "ILLEGAL ARG" N)))
+          (SETQ N0 (IPLUS N0 (fetch (ARRAYP OFFST) of A)))
+          (RETURN (SELECTC (fetch (ARRAYP TYP) of A)
+                      ((LIST \ST.PTR \ST.PTR2) 
+                           (\GETBASEPTR (\ADDBASE2 BASE N0)
+                                  0))
+                      (\ST.INT32 (SETQ BASE (\ADDBASE2 BASE N0))
+                                 (\MAKENUMBER (\GETBASE BASE 0)
+                                        (\GETBASE BASE 1)))
+                      ((LIST \ST.BYTE \ST.CODE) 
+                           (\GETBASEBYTE BASE N0))
+                      (\ST.POS16 (\GETBASE BASE N0))
+                      (\ST.BIT (LOGAND (LRSH (\GETBASE BASE (FOLDLO N0 BITSPERWORD))
+                                             (IDIFFERENCE (SUB1 BITSPERWORD)
+                                                    (IMOD N0 BITSPERWORD)))
+                                      1))
+                      (\ST.FLOAT (\GETBASEFLOATP BASE (UNFOLD N0 WORDSPERCELL)))
+                      (LISPERROR "ILLEGAL ARG" A])
+
+(ELTD
+  [LAMBDA (A N)                                          (* rmk%: "30-Dec-83 13:13")
+    (\DTEST A 'ARRAYP)
+    (SELECTC (fetch (ARRAYP TYP) of A)
+        (\ST.PTR2 (PROG [(BASE (fetch (ARRAYP BASE) of A))
+                         (N0 (IDIFFERENCE N (fetch (ARRAYP ORIG) of A]
+                        (COND
+                           ((OR (IGREATERP 0 N0)
+                                (IGEQ N0 (fetch (ARRAYP LENGTH) of A)))
+                            (LISPERROR "ILLEGAL ARG" N)))
+                        (SETQ N0 (IPLUS N0 (fetch (ARRAYP OFFST) of A)))
+                        (RETURN (\GETBASEPTR (\ADDBASE2 (\ADDBASE2 BASE (fetch (ARRAYP LENGTH)
+                                                                           of A))
+                                                    N0)
+                                       0))))
+        (ELT A N])
+
+(SETA
+  [LAMBDA (A N V)                                        (* bvm%: " 6-Feb-85 15:54")
+    (COND
+       ([fetch (ARRAYP READONLY) of (SETQ A (\DTEST A 'ARRAYP]
+        (LISPERROR "ILLEGAL ARG" A)))
+    (PROG [(BASE (fetch (ARRAYP BASE) of A))
+           (N0 (IDIFFERENCE N (fetch (ARRAYP ORIG) of A]
+          (COND
+             ((OR (ILESSP N0 0)
+                  (IGEQ N0 (fetch (ARRAYP LENGTH) of A)))
+              (LISPERROR "ILLEGAL ARG" N)))
+          (SETQ N0 (IPLUS N0 (fetch (ARRAYP OFFST) of A)))
+          (RETURN (SELECTC (fetch (ARRAYP TYP) of A)
+                      ((LIST \ST.PTR \ST.PTR2) 
+                           (\RPLPTR (\ADDBASE2 BASE N0)
+                                  0 V))
+                      (\ST.INT32                             (* ; "32-bit 2's complement integers")
+                                 (\PUTBASEFIXP (\ADDBASE2 BASE N0)
+                                        0 V))
+                      ((LIST \ST.BYTE \ST.CODE) 
+                           (\PUTBASEBYTE BASE N0 V))
+                      (\ST.POS16                             (* ; "Unsigned 16-bit numbers")
+                                 (\PUTBASE BASE N0 V))
+                      (\ST.BIT [\PUTBASE BASE (FOLDLO N0 BITSPERWORD)
+                                      (COND
+                                         [(EQ 0 V)
+                                          (LOGAND (\GETBASE BASE (FOLDLO N0 BITSPERWORD))
+                                                 (LOGXOR (LLSH 1 (IDIFFERENCE (SUB1 BITSPERWORD)
+                                                                        (IMOD N0 BITSPERWORD)))
+                                                        (SUB1 (LLSH 1 BITSPERWORD]
+                                         (T (LOGOR (\GETBASE BASE (FOLDLO N0 BITSPERWORD))
+                                                   (LLSH 1 (IDIFFERENCE (SUB1 BITSPERWORD)
+                                                                  (IMOD N0 BITSPERWORD]
+                               V)
+                      (\ST.FLOAT (\PUTBASEFLOATP BASE (UNFOLD N0 WORDSPERCELL)
+                                        (FLOAT V)))
+                      (LISPERROR "ILLEGAL ARG" A])
+
+(SETD
+  [LAMBDA (A N V)                                        (* rmk%: "30-Dec-83 13:14")
+    (\DTEST A 'ARRAYP)
+    (SELECTC (fetch (ARRAYP TYP) of A)
+        (\ST.PTR2 (COND
+                     ((fetch (ARRAYP READONLY) of A)
+                      (LISPERROR "ILLEGAL ARG" A)))
+                  (PROG [(BASE (fetch (ARRAYP BASE) of A))
+                         (N0 (IDIFFERENCE N (fetch (ARRAYP ORIG) of A]
+                        (COND
+                           ((OR (IGREATERP 0 N0)
+                                (IGEQ N0 (fetch (ARRAYP LENGTH) of A)))
+                            (LISPERROR "ILLEGAL ARG" N)))
+                        (SETQ N0 (IPLUS N0 (fetch (ARRAYP OFFST) of A)))
+                        (\RPLPTR (\ADDBASE2 (\ADDBASE2 BASE (fetch (ARRAYP LENGTH) of A))
+                                        N0)
+                               0 V)
+                        (RETURN V)))
+        (SETA A N V])
+
+(SUBARRAY
+  [LAMBDA (X N M OLD NEWORIG)                            (* rmk%: "30-Dec-83 13:15")
+    (\DTEST X 'ARRAYP)
+    (PROG ((LEN (fetch (ARRAYP LENGTH) of X))
+           (ORIG (fetch (ARRAYP ORIG) of X))
+           (N1 N)
+           (M1 M))                                           (* ; 
+                                                           "N1 and M1 so don't reset user arg")
+          [COND
+             ((IGREATERP 0 N1)                               (* ; "Coerce the first index")
+              (SETQ N1 (IPLUS N1 LEN 1]
+          [COND
+             ((NULL M1)                                      (* ; "Now coerce the second index")
+              (SETQ M1 LEN))
+             ((IGREATERP 0 M1)
+              (SETQ M1 (IPLUS M1 LEN 1]                      (* ; 
+                                                 "Go uninterruptable to protect the OLD~=NIL case.")
+          (RETURN (AND (IGEQ N1 ORIG)
+                       (ILEQ N1 M1)
+                       (ILEQ M1 LEN)
+                       (UNINTERRUPTABLY
+                           (create ARRAYP smashing (OR (ARRAYP OLD)
+                                                               (create ARRAYP))
+                                                    BASE _ (fetch (ARRAYP BASE) of X)
+                                                    LENGTH _ (ADD1 (IDIFFERENCE M1 N1))
+                                                    TYP _ (fetch (ARRAYP TYP) of X)
+                                                    OFFST _ (IDIFFERENCE (IPLUS (fetch
+                                                                                 (ARRAYP OFFST)
+                                                                                   of X)
+                                                                                N1)
+                                                                   ORIG)
+                                                    ORIG _ ORIG))])
+)
+
+
+
+(* ; "HASHARRAY entries")
+
+(DEFINEQ
+
+(HARRAY
+  [LAMBDA (MINKEYS)                                      (* rmk%: " 3-Jan-84 13:09")
+
+    (* ;; "For backward compatibility--produces a non-growing hasharray")
+
+    (HASHARRAY MINKEYS 'ERROR])
+
+(HASHARRAY
+  [LAMBDA (MINKEYS OVERFLOW HASHBITSFN EQUIVFN RECLAIMABLE REHASH-THRESHOLD)
+                                                             (* ; "Edited  3-Oct-91 13:35 by jds")
+
+    (* ;; "MINKEYS is the number of required slots;  actual number of slots is greater by the vacancy factor REHASH-THRESHOLD default 0.75 --- MINKEYS is first adjusted by the vacancy factor, then bumped up to the next highest power of 2, so that hashkey can be computed with LOGAND instead of IREMAINDER.")
+
+    [COND
+       ((FIXP REHASH-THRESHOLD)                              (* ; "Scale it")
+        (SETQ REHASH-THRESHOLD (AND (FIXP OVERFLOW)
+                                    (ILESSP REHASH-THRESHOLD OVERFLOW)
+                                    (FQUOTIENT REHASH-THRESHOLD OVERFLOW]
+    (LET ((PHYSLOTS (OR (bind [IDEALSIZE _ (IMAX MINKEYS
+                                                     (IMIN (- (FOLDLO \MaxArrayNCells CELLSPERSLOT)
+                                                              2)
+                                                           (COND
+                                                              (REHASH-THRESHOLD
+                                                               (FIXR (FQUOTIENT (SUB1 MINKEYS)
+                                                                            REHASH-THRESHOLD)))
+                                                              (T (LLSH (IQUOTIENT (SUB1 MINKEYS)
+                                                                              3)
+                                                                       2] find I from 8
+                           to 16384 by I suchthat (IGREATERP I IDEALSIZE))
+                        [for I from [IMAX MINKEYS (IMIN 32749 (- (FOLDLO \MaxArrayNCells 
+                                                                                CELLSPERSLOT)
+                                                                         2)
+                                                                (COND
+                                                                   (REHASH-THRESHOLD
+                                                                    (FIXR (FQUOTIENT (SUB1 MINKEYS)
+                                                                                 REHASH-THRESHOLD)))
+                                                                   (T (LLSH (IQUOTIENT (SUB1 MINKEYS)
+                                                                                   3)
+                                                                            2] to 32749
+                           suchthat 
+
+                                 (* ;; "Find a prime table-size between our ideal and the maximum, which is 32749 (largest prime < array limit)")
+
+                                 (for J from 2 to (FIXR (SQRT I))
+                                    never (ZEROP (IREMAINDER I J]
+                        32768))
+          LOGSLOTS NCELLS)
+         (SETQ NCELLS (UNFOLD PHYSLOTS CELLSPERSLOT))
+         (COND
+            ((IGREATERP NCELLS \MaxArrayNCells)
+             (ERROR "HARRAY TOO LARGE" MINKEYS))
+            (T [SETQ LOGSLOTS (COND
+                                 (REHASH-THRESHOLD (FIXR (FTIMES REHASH-THRESHOLD PHYSLOTS)))
+                                 (T (IPLUS (LRSH PHYSLOTS 1)
+                                           (LRSH PHYSLOTS 2] (* ; 
+                           "Number of logical slots is REHASH-THRESHOLD * number of physical slots")
+               (create HARRAYP
+                      HARRAYPBASE _ (\ALLOCBLOCK NCELLS PTRBLOCK.GCT)
+                      LASTINDEX _ (SUB1 PHYSLOTS)
+                      RECLAIMABLE _ RECLAIMABLE
+                      OVERFLOWACTION _ OVERFLOW
+                      NUMSLOTS _ LOGSLOTS
+                      NULLSLOTS _ LOGSLOTS
+                      NUMKEYS _ 0
+                      HASHBITSFN _ HASHBITSFN
+                      EQUIVFN _ EQUIVFN])
+
+(HARRAYP
+  [LAMBDA (X)                                            (* rmk%: "21-Dec-83 22:20")
+    (AND (type? HARRAYP X)
+         X])
+
+(HARRAYPROP
+  [LAMBDA NARGS                                          (* bvm%: "21-Jan-86 11:02")
+                                                             (* ; 
+                                        "Nospread so we can tell whether a new value was specified")
+    (PROG ((HARRAY (AND (IGREATERP NARGS 0)
+                            (ARG NARGS 1)))
+           (PROP (AND (IGREATERP NARGS 1)
+                      (ARG NARGS 2)))
+           (NEWVALP (IGREATERP NARGS 2))
+           HA NEWVALUE)
+          (SETQ HA (\DTEST HARRAY 'HARRAYP))                 (* ; 
+                                                    "Keep HARRAY explicitly so can tell LISTP case")
+          (AND NEWVALP (SETQ NEWVALUE (ARG NARGS 3)))
+          [RETURN (SELECTQ PROP
+                      (SIZE (AND NEWVALP (GO CANTUPDATE))
+                            (HARRAYSIZE HA))
+                      (OVERFLOW [COND
+                                   [(LISTP HARRAY)           (* ; 
+                                  "For compatibility with old code that would enlist the hasharray")
+                                    (PROG1 (CDR HARRAY)
+                                        (AND NEWVALP (RPLACD HARRAY NEWVALUE)))]
+                                   (T (PROG1 (fetch (HARRAYP OVERFLOWACTION) of HA)
+                                          (AND NEWVALP (replace (HARRAYP OVERFLOWACTION)
+                                                          of HA with NEWVALUE)))])
+                      (NUMKEYS (AND NEWVALP (GO CANTUPDATE))
+                               (fetch (HARRAYP NUMKEYS) of HA))
+                      (EQUIVFN (PROG1 (fetch (HARRAYP EQUIVFN) of HA)
+                                   [AND NEWVALP (COND
+                                                   ((NEQ (fetch (HARRAYP NUMKEYS)
+                                                            of HA)
+                                                         0)  (* ; 
+                                               "Absurd to change equivalence relation in midstream")
+                                                    (GO CANTUPDATE))
+                                                   (T (replace (HARRAYP EQUIVFN) of
+                                                                                         HA
+                                                         with NEWVALUE]))
+                      (RECLAIMABLE (PROG1 (fetch (HARRAYP RECLAIMABLE) of HA)
+                                       (AND NEWVALP (replace (HARRAYP RECLAIMABLE)
+                                                       of HA with NEWVALUE))))
+                      (HASHBITSFN (PROG1 (fetch (HARRAYP HASHBITSFN) of HA)
+                                      [AND NEWVALP (COND
+                                                      ((NEQ (fetch (HARRAYP NUMKEYS)
+                                                               of HA)
+                                                            0)
+                                                       (GO CANTUPDATE))
+                                                      (T (replace (HARRAYP HASHBITSFN)
+                                                            of HA with NEWVALUE]))
+                      (PROG1 (LISTGET (SETQ HARRAY (fetch (HARRAYP HASHUSERDATA) of
+                                                                                         HA))
+                                    PROP)
+                          [AND NEWVALP (COND
+                                          ((NULL HARRAY)
+                                           (replace (HARRAYP HASHUSERDATA) of HA
+                                              with (LIST PROP NEWVALUE)))
+                                          (T (LISTPUT HARRAY PROP NEWVALUE])]
+      CANTUPDATE
+          (ERROR "Can't update this hash array property" PROP])
+
+(HARRAYSIZE
+  [LAMBDA (HARRAY)                                   (* rmk%: "21-Dec-83 23:33")
+    (fetch NUMSLOTS of (\DTEST HARRAY 'HARRAYP])
+
+(CLRHASH
+  [LAMBDA (HARRAY)                                   (* bvm%: "21-Jan-86 11:32")
+    (PROG ((HA (\DTEST HARRAY 'HARRAYP))
+           SLOT)
+          (SETQ SLOT (fetch HARRAYPBASE of HA))
+          (UNINTERRUPTABLY
+              (bind [LASTSLOT _ (fetch (HASHSLOT NEXTSLOT) of (\HASHSLOT
+                                                                           SLOT
+                                                                           (fetch (HARRAYP
+                                                                                       LASTINDEX)
+                                                                              of HA]
+                 do (replace (HASHSLOT KEY) of SLOT with NIL)
+                       (replace (HASHSLOT VALUE) of SLOT with NIL)
+                 repeatuntil (EQ (SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT))
+                                     LASTSLOT))
+              (replace (HARRAYP NULLSLOTS) of HA with (fetch (HARRAYP 
+                                                                                        NUMSLOTS)
+                                                                         of HA))
+              (replace (HARRAYP NUMKEYS) of HA with 0))
+          (RETURN HARRAY])
+
+(MAPHASH
+  [LAMBDA (HARRAY MAPHFN)                            (* bvm%: "21-Jan-86 11:28")
+    (DECLARE (LOCALVARS . T))
+    (LET ((HA (\DTEST HARRAY 'HARRAYP))
+          SLOT)
+         (SETQ SLOT (fetch HARRAYPBASE of HA))
+         (bind V [LASTSLOT _ (fetch (HASHSLOT NEXTSLOT) of (\HASHSLOT SLOT
+                                                                              (fetch (HARRAYP
+                                                                                          LASTINDEX)
+                                                                                 of HA]
+                (NULLVALUE _ \HASH.NULL.VALUE) when (SETQ V (fetch (HASHSLOT VALUE)
+                                                                   of SLOT))
+            do (APPLY* MAPHFN (AND (NEQ V NULLVALUE)
+                                       V)
+                          (fetch (HASHSLOT KEY) of SLOT))
+            repeatuntil (EQ (SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT))
+                                LASTSLOT) finally (RETURN HARRAY])
+
+(GETHASH
+  [LAMBDA (ITEM HARRAY DEFAULT RETURNMVS)                (* ; "Edited 26-Feb-91 13:07 by jds")
+
+(* ;;; "RETURNMVS, if true return multiple values, else don't.")
+
+    (PROG ((HA (\DTEST HARRAY 'HARRAYP))
+           INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT BITS EQFN ABASE VALUE)
+          [SETQ BITS (COND
+                        ((SETQ BITS (fetch (HARRAYP HASHBITSFN) of HA))
+                         (APPLY* BITS ITEM))
+                        (T (\EQHASHINGBITS ITEM]
+          (SETQ INDEX (\FIRSTINDEX BITS HA))                 (* ; 
+                           "Do first index outside of loop, so don't have to do setup on fast case")
+          (SETQ ABASE (fetch HARRAYPBASE of HA))
+          (SETQ SLOT (\HASHSLOT ABASE INDEX))
+          [COND
+             ((SETQ VALUE (fetch (HASHSLOT VALUE) of SLOT))
+                                                             (* ; "Slot is occupied")
+              (COND
+                 ((OR (EQ ITEM (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT)))
+                      (AND (SETQ EQFN (fetch (HARRAYP EQUIVFN) of HA))
+                           (APPLY* EQFN ITEM SKEY)))
+                  (GO FOUND)))                               (* ; "else try again")
+              )
+             [(NULL (fetch (HASHSLOT KEY) of SLOT))  (* ; "Null slot")
+              (RETURN (COND
+                         (RETURNMVS (LISP:VALUES DEFAULT NIL))
+                         (T DEFAULT]
+             (T                                              (* ; 
+                                                           "Deleted slot: null value, non-nil key")
+                (SETQ EQFN (fetch (HARRAYP EQUIVFN) of HA]
+                                                             (* ; "Perhaps we hit right on")
+          (SETQ FIRSTINDEX INDEX)
+          (SETQ REPROBE (\REPROBE BITS HA))                  (* ; "Compute reprobe interval")
+          (SETQ LIMIT (ADD1 (fetch (HARRAYP LASTINDEX) of HA)))
+      LP  (SETQ INDEX (IREMAINDER (IPLUS INDEX REPROBE)
+                             LIMIT))
+
+     (* ;; "Since table size is a power of two, any wraparound in the IPLUS16 will be consistent with the LOGAND")
+
+          (COND
+             ((EQ INDEX FIRSTINDEX)                          (* ; 
+                                         "Should never happen, since we don't allow full occupancy")
+              (SHOULDNT "Hashing in full hash table")))
+          (SETQ SLOT (\HASHSLOT ABASE INDEX))
+          (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT))
+          [COND
+             [(SETQ VALUE (fetch (HASHSLOT VALUE) of SLOT))
+                                                             (* ; "Slot is occupied")
+              (COND
+                 ((OR (EQ (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT))
+                          ITEM)
+                      (AND EQFN (APPLY* EQFN ITEM SKEY)))    (* ; "Found it")
+                  (GO FOUND]
+             ((NULL (fetch (HASHSLOT KEY) of SLOT))  (* ; "Empty slot")
+              (RETURN (COND
+                         (RETURNMVS (LISP:VALUES DEFAULT NIL))
+                         (T DEFAULT]
+          (GO LP)
+      FOUND
+          (RETURN (COND
+                     (RETURNMVS (LISP:VALUES (AND (NEQ VALUE \HASH.NULL.VALUE)
+                                                VALUE)
+                                       T))
+                     (T (AND (NEQ VALUE \HASH.NULL.VALUE)
+                             VALUE])
+
+(PUTHASH
+  [LAMBDA (KEY VAL HARRAY)                               (* raf "22-Aug-86 16:55")
+
+(* ;;; "Store new value VAL, or remove old value if VAL = NIL")
+
+    (\HASHACCESS KEY VAL HARRAY (NULL VAL))
+    VAL])
+
+(LISP::PUTHASH
+  (LISP:LAMBDA (KEY LISP:HASH-TABLE VALUE &OPTIONAL (EXTRA NIL EXTRA-P))
+                                                             (* ; "Edited 23-Mar-87 12:00 by bvm:")
+
+         (* ;; "SETF inverse for LISP:GETHASH.  Subtlety is that LISP:GETHASH has an optional arg DEFAULT, so if you passed one of those 3-argument forms to SETF, you'd get 4 arguments in this call.  In this case, the fourth argument is the new value and you should ignore the third.")
+
+         (LISP:CHECK-TYPE LISP:HASH-TABLE LISP:HASH-TABLE)
+         (\HASHACCESS KEY (LISP:IF EXTRA-P
+                                  EXTRA
+                                  VALUE)
+                LISP:HASH-TABLE NIL)
+         VALUE))
+
+(REMHASH
+  [LAMBDA (KEY HARRAY)                                   (* bvm%: "20-Jan-86 18:54")
+    (\HASHACCESS KEY NIL HARRAY T])
+
+(\HASHRECLAIM
+  [LAMBDA (HARRAY)                                   (* bvm%: "21-Jan-86 11:36")
+
+(* ;;; "Remove from HARRAY any keys whose ref cnt is 1")
+
+    (PROG ((HA (\DTEST HARRAY 'HARRAYP))
+           SLOT)
+          (SETQ SLOT (fetch (HARRAYP HARRAYPBASE) of HA))
+          (UNINTERRUPTABLY
+              (bind KEY [LASTSLOT _ (fetch (HASHSLOT NEXTSLOT)
+                                           of (\HASHSLOT SLOT (fetch (HARRAYP LASTINDEX)
+                                                                     of HA]
+                     (NUMDELETED _ 0) when (AND (SETQ KEY (fetch (HASHSLOT KEY) of SLOT))
+                                                    (NEQ KEY T)
+                                                    (\EQREFCNT1 KEY))
+                 do                                      (* ; 
+                                           "Slot is occupied with key with ref cnt 1, so delete it")
+                       (replace (HASHSLOT KEY) of SLOT with T)
+                       (replace (HASHSLOT VALUE) of SLOT with NIL)
+                       (add NUMDELETED 1) repeatuntil (EQ LASTSLOT (SETQ SLOT
+                                                                            (fetch (HASHSLOT
+                                                                                        NEXTSLOT)
+                                                                               of SLOT)))
+                 finally (replace (HARRAYP NUMKEYS) of HA
+                                with (IDIFFERENCE (fetch (HARRAYP NUMKEYS) of HA)
+                                                NUMDELETED))))
+          (RETURN HARRAY])
+
+(\HASHACCESS
+  [LAMBDA (ITEM VAL HARRAY REMOVE)                       (* ; "Edited 26-Feb-91 13:16 by jds")
+
+(* ;;; "Add or remove something from hash array HARRAY -- REMOVE = T means remove the item, which is necessarily distinct from adding a VAL = NIL")
+
+    (PROG ((HA (\DTEST HARRAY 'HARRAYP))
+           DELSLOT INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT BITS HASHBITSFN EQFN ABASE)
+          [SETQ BITS (COND
+                        ((SETQ HASHBITSFN (fetch (HARRAYP HASHBITSFN) of HA))
+                         (APPLY* HASHBITSFN ITEM))
+                        (T (\EQHASHINGBITS ITEM]
+      PHTOP
+          (SETQ INDEX (\FIRSTINDEX BITS HA))                 (* ; 
+                                                  "Handle first probe outside loop in case it wins")
+          (SETQ ABASE (fetch HARRAYPBASE of HA))
+          (SETQ SLOT (\HASHSLOT ABASE INDEX))
+          [COND
+             ((fetch (HASHSLOT VALUE) of SLOT)       (* ; "Slot is occupied")
+              (COND
+                 ((OR (EQ ITEM (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT)))
+                      (AND (SETQ EQFN (fetch (HARRAYP EQUIVFN) of HA))
+                           (APPLY* EQFN ITEM SKEY)))
+                  (GO FOUND)))                               (* ; "else try again")
+              )
+             ((NULL (fetch (HASHSLOT KEY) of SLOT))  (* ; "Null slot")
+              (GO ADDNEWENTRY))
+             (T                                              (* ; 
+                                                           "Deleted slot: null value, non-nil key")
+                (SETQ DELSLOT SLOT)
+                (SETQ EQFN (fetch (HARRAYP EQUIVFN) of HA]
+          (SETQ FIRSTINDEX INDEX)
+          (SETQ REPROBE (\REPROBE BITS HA))
+          (SETQ LIMIT (ADD1 (fetch (HARRAYP LASTINDEX) of HA)))
+      LP  (SETQ INDEX (IREMAINDER (IPLUS INDEX REPROBE)
+                             LIMIT))
+          (COND
+             ((EQ INDEX FIRSTINDEX)
+
+              (* ;; "We don't allow full occupancy, so if we get to the beginning without finding an empty slot, we must have found a deleted one")
+
+              (SETQ SLOT (OR DELSLOT (ERROR "No vacant slot in hasharray")))
+              (GO ADDNEWENTRY)))
+          (SETQ SLOT (\HASHSLOT ABASE INDEX))
+          [COND
+             [(fetch (HASHSLOT VALUE) of SLOT)       (* ; "Slot is occupied")
+              (COND
+                 ((OR (EQ (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT))
+                          ITEM)
+                      (AND EQFN (APPLY* EQFN ITEM SKEY)))    (* ; "Found it")
+                  (GO FOUND]
+             (T (COND
+                   ((NULL (fetch (HASHSLOT KEY) of SLOT))
+
+                    (* ;; "NIL as both key and value means empty slot.  New entry goes here, unless there was an earlier deleted slot")
+
+                    (AND DELSLOT (SETQ SLOT DELSLOT))
+                    (GO ADDNEWENTRY))
+                   ((NULL DELSLOT)                           (* ; 
+                                                         "Key non-NIL but value NIL means deleted.")
+                    (SETQ DELSLOT SLOT]
+          (GO LP)
+      FOUND
+          (UNINTERRUPTABLY
+              [COND
+                 (REMOVE                                     (* ; 
+                                           "Deleted slots are noted by value = NIL and key non-NIL")
+                        (replace (HASHSLOT KEY) of SLOT with T)
+                        (replace (HASHSLOT VALUE) of SLOT with NIL)
+                        (add (fetch (HARRAYP NUMKEYS) of HA)
+                               -1))
+                 (T 
+                    (* ;; "If writing value NIL must write distinguished non-NIL value.  Ultimately, this should be a non-interned symbol, so that nobody could mistakenly type it (!) but it still wouldn't be ref counted (in present world)")
+
+                    (replace (HASHSLOT VALUE) of SLOT with (OR VAL \HASH.NULL.VALUE])
+          (RETURN T)
+      ADDNEWENTRY
+                                                             (* ; 
+                                  "Didn't find this item in table.  If REMOVE is T, nothing to do.")
+          (COND
+             (REMOVE (RETURN NIL)))
+          (COND
+             ((EQ 0 (fetch (HARRAYP NULLSLOTS) of HA))
+              (COND
+                 ((fetch (HARRAYP RECLAIMABLE) of HA)
+                                                             (* ; 
+                                                 "Before rehashing, remove anything with ref cnt 1")
+                  (\HASHRECLAIM HA)))
+              (SETQ HARRAY (HASHOVERFLOW (OR HARRAY SYSHASHARRAY)))
+              (SETQ HA (\DTEST HARRAY 'HARRAYP))
+
+              (* ;; "ERRORX2 doesn't handle SYSHASHARRAY specially;  on 10, SYSHASHARRAY is rehashed directly in PUTHASH, without going through ERRORX2 and independent of the normal LISTP conventions.")
+
+              (SETQ DELSLOT NIL)                             (* ; 
+                                                  "Non-NIL DELSLOT is a pointer into the old array")
+              (GO PHTOP)))
+          (UNINTERRUPTABLY
+              (OR (EQ SLOT DELSLOT)
+                  (add (fetch (HARRAYP NULLSLOTS) of HA)
+                         -1))
+              (add (fetch (HARRAYP NUMKEYS) of HA)
+                     1)
+              (replace (HASHSLOT KEY) of SLOT with ITEM)
+              (replace (HASHSLOT VALUE) of SLOT with (OR VAL \HASH.NULL.VALUE)))
+          (RETURN VAL])
+
+(REHASH
+  [LAMBDA (OLDAR NEWAR)                                  (* rmk%: "26-Dec-83 11:50")
+    (CLRHASH NEWAR)
+    (PROG [SLOT LASTSLOT V (APTR1 (\DTEST OLDAR 'HARRAYP]    (* ; "This is maphash expanded out")
+          (SETQ SLOT (fetch HARRAYPBASE of APTR1))
+          (SETQ LASTSLOT (\ADDBASE4 SLOT (fetch (HARRAYP LASTINDEX) of APTR1)))
+      LP  (COND
+             ((SETQ V (fetch (HASHSLOT VALUE) of SLOT))
+              (PUTHASH (fetch (HASHSLOT KEY) of SLOT)
+                     V NEWAR)))
+          (COND
+             ((EQ SLOT LASTSLOT)
+              (RETURN NEWAR)))
+          (SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT))
+          (GO LP])
+
+(\COPYHARRAYP
+  [LAMBDA (SOURCE TARGET)                                (* rmk%: "31-Dec-83 13:58")
+
+    (* ;; "Copies all properties of SOURCE into TARGET;  called from HASHOVERFLOW")
+
+    (replace NULLSLOTS of TARGET with (fetch NULLSLOTS of SOURCE))
+    (replace LASTINDEX of TARGET with (fetch LASTINDEX of SOURCE))
+    (replace HARRAYPBASE of TARGET with (fetch HARRAYPBASE of SOURCE))
+    (replace OVERFLOWACTION of TARGET with (fetch OVERFLOWACTION of SOURCE))
+    (replace NUMSLOTS of TARGET with (fetch NUMSLOTS of SOURCE))
+    (replace NUMKEYS of TARGET with (fetch NUMKEYS of SOURCE])
+
+(\HASHTABLE.DEFPRINT
+  [LAMBDA (LISP:HASH-TABLE STREAM)                         (* ; "Edited 23-Mar-87 11:38 by bvm:")
+
+    (* ;; "For benefit of common lisp, print harrayp by name %"hash table%", for example, #<Hash-Table @ 76,5432>")
+
+    [.SPACECHECK. STREAM (CONSTANT (+ (NCHARS "<Hash-Table @ >")
+                                      (PROGN                 (* ; "Longest address is `177,177777'")
+                                             10]
+    (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))
+    (\SOUT "<Hash-Table @ " STREAM)
+    (\PRINTADDR LISP:HASH-TABLE STREAM)
+    (\OUTCHAR STREAM (CHARCODE >))                           (* ; 
+                                                          "Return T to say we printed it ourselves")
+    T])
+)
+(DEFINEQ
+
+(STRINGHASHBITS
+  [LAMBDA (STRING)                                       (* ; "Edited  2-Mar-89 14:11 by jds")
+    (MISCN STRINGHASHBITS STRING])
+
+(STRING-EQUAL-HASHBITS
+  [LAMBDA (STRING)                                       (* ; "Edited  2-Mar-89 14:14 by jds")
+
+(* ;;; "A hashbits function for the hash equivalence STRING-EQUAL.")
+
+(* ;;; "This is similar to the atom hash algorithm, but we OR in 40Q to cause uppercase and lowercase chars to have the same codes.")
+
+    (MISCN STRING-EQUAL-HASHBITS STRING])
+)
+(DEFINEQ
+
+(\STRINGHASHBITS-UFN
+  [LAMBDA (INDEX ARGCOUNT ARG-PTR)                       (* ; "Edited  2-Mar-89 14:06 by jds")
+
+    (* ;; "UFN for the STRINGHASHBITS MISCN opcode.  Computes a hash index for strings and symbols, so identical string CONTENTS hash to the same place.")
+
+    (LET ((STRING (\GETBASEPTR ARG-PTR 0)))
+         (for C inpname STRING bind (HASHBITS _ 0)
+            do                                           (* ; 
+                                                       "This is similar to the atom hash algorithm")
+                  [SETQ HASHBITS (IPLUS16 C (IPLUS16 (SETQ HASHBITS (IPLUS16 HASHBITS
+                                                                           (LLSH (LOGAND HASHBITS 
+                                                                                        4095)
+                                                                                 2)))
+                                                   (LLSH (LOGAND HASHBITS 255)
+                                                         8] finally (RETURN HASHBITS])
+
+(\STRING-EQUAL-HASHBITS-UFN
+  [LAMBDA (INDEX ARGCOUNT ARG-PTR)                       (* ; "Edited  2-Mar-89 14:09 by jds")
+
+(* ;;; "A hashbits function for the hash equivalence STRING-EQUAL.")
+
+(* ;;; "This is similar to the atom hash algorithm, but we OR in 40Q to cause uppercase and lowercase chars to have the same codes.")
+
+    (LET ((STRING (\GETBASEPTR ARG-PTR 0)))
+         (for C inpname STRING bind (HASHBITS _ 0)
+            do [SETQ HASHBITS (IPLUS16 (LOGOR C 32)
+                                         (IPLUS16 (SETQ HASHBITS (IPLUS16 HASHBITS
+                                                                        (LLSH (LOGAND HASHBITS 4095)
+                                                                              2)))
+                                                (LLSH (LOGAND HASHBITS 255)
+                                                      8] finally (RETURN HASHBITS])
+)
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
+
+(DATATYPE HARRAYP ((NULLSLOTS WORD)                      (* ; 
+                                                      "Number of NIL-NIL slots, which break chains")
+                       (LASTINDEX WORD)                      (* ; "Slot offset of last slot.  Used in probe computations computations.  Microcode support for \ADDBASE4 would help")
+                       (HARRAYPBASE POINTER)
+                       (RECLAIMABLE FLAG)                    (* ; 
+                                                      "True if keys can go away when no other refs")
+                       (OVERFLOWACTION POINTER)
+                       (NUMSLOTS WORD)                       (* ; 
+                                      "The maximum number of logical slots--returned by HARRAYSIZE")
+                       (NUMKEYS WORD)                        (* ; 
+                                                         "The number of distinct keys in the array")
+                       (HASHBITSFN POINTER)
+                       (EQUIVFN POINTER)
+                       (HASHUSERDATA POINTER)))
+)
+
+(/DECLAREDATATYPE 'HARRAYP '(WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER)
+       '((HARRAYP 0 (BITS . 15))
+         (HARRAYP 1 (BITS . 15))
+         (HARRAYP 2 POINTER)
+         (HARRAYP 2 (FLAGBITS . 0))
+         (HARRAYP 4 POINTER)
+         (HARRAYP 6 (BITS . 15))
+         (HARRAYP 7 (BITS . 15))
+         (HARRAYP 8 POINTER)
+         (HARRAYP 10 POINTER)
+         (HARRAYP 12 POINTER))
+       '14)
+(DECLARE%: EVAL@COMPILE 
+
+[PUTPROPS \EQHASHINGBITS MACRO (OPENLAMBDA (X)               (* ; 
+                 "Spread out objects whose low bits are in small arithmetic progression, esp atoms")
+                                      (LOGXOR (\HILOC X)
+                                             (LOGXOR (LLSH (LOGAND (\LOLOC X)
+                                                                  8191)
+                                                           3)
+                                                    (LRSH (\LOLOC X)
+                                                          9]
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DECLARE%: EVAL@COMPILE
+
+(BLOCKRECORD HASHSLOT ((KEY POINTER)
+                           (VALUE POINTER))
+                          [ACCESSFNS ((NEXTSLOT (\ADDBASE DATUM (UNFOLD WORDSPERCELL CELLSPERSLOT])
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+[PUTPROPS \FIRSTINDEX MACRO ((BITS APTR1)
+                             (IREMAINDER BITS (ADD1 (fetch (HARRAYP LASTINDEX) of APTR1]
+
+(PUTPROPS \HASHSLOT MACRO (= . \ADDBASE4))
+
+(PUTPROPS \REPROBE MACRO ((BITS HA)
+                          (LOGOR [IREMAINDER (LOGXOR BITS (LRSH BITS 8))
+                                        (IMIN 64 (ADD1 (fetch (HARRAYP LASTINDEX)
+                                                          of HA]
+                                 1)))
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ CELLSPERSLOT 2)
+
+
+(CONSTANTS (CELLSPERSLOT 2))
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \HASH.NULL.VALUE SYSHASHARRAY)
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(DEFPRINT 'HARRAYP '\HASHTABLE.DEFPRINT)
+)
+
+(/DECLAREDATATYPE 'HARRAYP '(WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER)
+       '((HARRAYP 0 (BITS . 15))
+         (HARRAYP 1 (BITS . 15))
+         (HARRAYP 2 POINTER)
+         (HARRAYP 2 (FLAGBITS . 0))
+         (HARRAYP 4 POINTER)
+         (HARRAYP 6 (BITS . 15))
+         (HARRAYP 7 (BITS . 15))
+         (HARRAYP 8 POINTER)
+         (HARRAYP 10 POINTER)
+         (HARRAYP 12 POINTER))
+       '14)
+(ADDTOVAR SYSTEMRECLST
+
+(DATATYPE HARRAYP ((NULLSLOTS WORD)
+                       (LASTINDEX WORD)
+                       (HARRAYPBASE POINTER)
+                       (RECLAIMABLE FLAG)
+                       (OVERFLOWACTION POINTER)
+                       (NUMSLOTS WORD)
+                       (NUMKEYS WORD)
+                       (HASHBITSFN POINTER)
+                       (EQUIVFN POINTER)
+                       (HASHUSERDATA POINTER)))
+)
+
+(RPAQQ \HASH.NULL.VALUE \Hash\Null\Value\)
+
+
+
+(* ; "System entries for CODE")
+
+(DEFINEQ
+
+(\CODEARRAY
+  [LAMBDA (NBYTES INITONPAGE)                            (* lmm "15-Aug-84 11:51")
+    (PROG NIL
+
+     (* ;; "NBYTES is the number of bytes required, INITONPAGE is the number of CELLS which must reside on same page")
+
+          (COND
+             ((OR (IGREATERP 0 NBYTES)
+                  (IGREATERP NBYTES 65535))
+              (LISPERROR "ILLEGAL ARG" NBYTES)))             (* ; 
+                                                    "dolphin requires code blocks aligned quadword")
+          (RETURN (create ARRAYP
+                         TYP _ \ST.CODE
+                         BASE _ (\ALLOCBLOCK (FOLDHI NBYTES BYTESPERCELL)
+                                       CODEBLOCK.GCT INITONPAGE CELLSPERQUAD)
+                         LENGTH _ NBYTES
+                         ORIG _ 0])
+
+(\FIXCODENUM
+  [LAMBDA (CA BN NUM MASK)                               (* ; "Edited  7-Jan-91 13:29 by jds")
+    (DECLARE (IGNORE MASK))                              (* ; 
+                                            "MASK is used by the renamed version of this function.")
+
+    (* ;; "Do fixup for a 2-byte number in the code stream.  Used for type numbers only, for now.")
+
+    (PROG ((BASE (fetch (ARRAYP BASE) of CA)))
+          (\PUTBASEBYTE BASE BN (LOGAND 255 NUM))
+          (\PUTBASEBYTE BASE (SETQ BN (SUB1 BN))
+                 (LOGOR (\GETBASEBYTE BASE BN)
+                        (LRSH NUM 8)))
+          (RETURN NUM])
+
+(\FIXCODEPTR
+  [LAMBDA (CA BN PTR MASK)                    (* ; 
+                                                "Edited 12-Nov-92 17:03 by sybalsky:mv:envos")
+    (DECLARE (IGNORE MASK))                              (* ; 
+                                            "MASK is used by the renamed version of this function.")
+    (PROG ((BASE (fetch (ARRAYP BASE) of CA))
+           (LO (\LOLOC PTR)))
+          (UNINTERRUPTABLY
+              (\ADDREF PTR)
+              (\PUTBASEBYTE BASE BN (LOGAND LO 255))
+              (\PUTBASEBYTE BASE (SUB1 BN)
+                     (LRSH LO 8))
+              (\PUTBASEBYTE BASE (IDIFFERENCE BN 2)
+                     (LOGOR (\GETBASEBYTE BASE (IDIFFERENCE BN 2))
+                            (LOGAND (\HILOC PTR)
+                                   255)))
+              (\PUTBASEBYTE BASE (IDIFFERENCE BN 3)
+                     (LOGOR (\GETBASEBYTE BASE (IDIFFERENCE BN 3))
+                            (LRSH (\HILOC PTR)
+                                  8))))
+          (RETURN PTR])
+
+(\FIXCODESYM
+  [LAMBDA (CA BN SYM MASK)                    (* ; 
+                                                "Edited 13-Nov-92 04:56 by sybalsky:mv:envos")
+    (DECLARE (IGNORE MASK))                              (* ; 
+                                            "MASK is used by the renamed version of this function.")
+
+    (* ;; "Perform fix-up for a symbol in an IL-Compiled function -- either 2 or 4 bytes, depending on the architecture.")
+
+    (* ;; "CA -- the code array")
+
+    (* ;; "BN -- byte number of the low-order byte to be fixed up")
+
+    (* ;; "SYM -- the symbol, expressed as a FIXP or a NEW-ATOM.")
+
+    (NEW-SYMBOL-CODE (PROG (HIBYTE NUM (BASE (fetch (ARRAYP BASE) of CA)))
+
+                      (* ;; "For 3-byte-symbol machines, handle 3 bytes worth of atom number.")
+
+                           [COND
+                              ((SMALLP SYM)
+                               (SETQ NUM SYM)
+                               (SETQ HIBYTE 0))
+                              ((FIXP SYM)
+                               (SETQ NUM (LOGAND SYM 65535))
+                               (SETQ HIBYTE (LRSH SYM 16)))
+                              (T (SETQ NUM (\LOLOC SYM))
+                                 (SETQ HIBYTE (\HILOC SYM]
+                           (UNINTERRUPTABLY
+                               (\PUTBASEBYTE BASE BN (LOGAND NUM 255))
+                               (\PUTBASEBYTE BASE (SUB1 BN)
+                                      (LOGAND (LRSH NUM 8)
+                                             255))
+                               (\PUTBASEBYTE BASE (IDIFFERENCE BN 2)
+                                      (LOGOR (\GETBASEBYTE BASE (IDIFFERENCE BN 2))
+                                             (LOGAND HIBYTE 255)))
+                               (\PUTBASEBYTE BASE (IDIFFERENCE BN 3)
+                                      (LOGOR (\GETBASEBYTE BASE (IDIFFERENCE BN 3))
+                                             (LRSH HIBYTE 8))))
+                           (RETURN (+ (LLSH HIBYTE 16)
+                                      NUM)))
+           (PROG ((NUM (\LOLOC SYM))
+                  (BASE (fetch (ARRAYP BASE) of CA)))
+
+            (* ;; "2-BYTE case:  Just fill it in.")
+
+                 (\PUTBASEBYTE BASE BN (LOGAND 255 NUM))
+                 (\PUTBASEBYTE BASE (SETQ BN (SUB1 BN))
+                        (LOGOR (\GETBASEBYTE BASE BN)
+                               (LRSH NUM 8)))
+                 (RETURN NUM])
+)
+
+
+
+(* ; "Internal")
+
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS EQPTR DMACRO (= . EQ))
+
+(PUTPROPS BUCKETINDEX MACRO ((N)
+                             (IMIN (INTEGERLENGTH N)
+                                   \MAXBUCKETINDEX)))
+
+[PUTPROPS FREEBLOCKCHAIN.N MACRO ((N)
+                                  (\ADDBASE2 \FREEBLOCKBUCKETS (BUCKETINDEX N]
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \MAXBUCKETINDEX 30)
+
+
+(CONSTANTS \MAXBUCKETINDEX)
+)
+
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \ADDBASE2 MACRO (OPENLAMBDA (BASE N)
+                                 (\ADDBASE (\ADDBASE BASE N)
+                                        N)))
+
+(PUTPROPS \ADDBASE4 MACRO (OPENLAMBDA (BASE N)
+                                 (\ADDBASE2 (\ADDBASE2 BASE N)
+                                        N)))
+
+(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX)
+                                    (FOLDLO (fetch DTDSIZE of (\GETDTD NTYPX))
+                                           WORDSPERCELL)))
+
+[PUTPROPS \BYTELT DMACRO (OPENLAMBDA (A J)
+                                (\GETBASEBYTE (fetch (ARRAYP BASE) of A)
+                                       (IPLUS (fetch (ARRAYP OFFST) of A)
+                                              J]
+
+(PUTPROPS \BYTESETA DMACRO (OPENLAMBDA (A J V)
+                                  (\PUTBASEBYTE (fetch (ARRAYP BASE) of A)
+                                         (IPLUS (fetch (ARRAYP OFFST) of A)
+                                                J)
+                                         V)))
+
+[PUTPROPS \WORDELT DMACRO (OPENLAMBDA (A J)
+                                 [CHECK (AND (ARRAYP A)
+                                             (EQ 0 (fetch (ARRAYP ORIG) of A))
+                                             (EQ \ST.POS16 (fetch (ARRAYP TYP) of A]
+                                 (CHECK (IGREATERP (fetch (ARRAYP LENGTH) of A)
+                                               J))
+                                 (\GETBASE (fetch (ARRAYP BASE) of A)
+                                        (IPLUS (fetch (ARRAYP OFFST) of A)
+                                               J]
+)
+
+(RPAQQ BLOCKGCTYPECONSTANTS ((CODEBLOCK.GCT 2)
+                                 (PTRBLOCK.GCT 1)
+                                 (UNBOXEDBLOCK.GCT 0)))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ CODEBLOCK.GCT 2)
+
+(RPAQQ PTRBLOCK.GCT 1)
+
+(RPAQQ UNBOXEDBLOCK.GCT 0)
+
+
+(CONSTANTS (CODEBLOCK.GCT 2)
+       (PTRBLOCK.GCT 1)
+       (UNBOXEDBLOCK.GCT 0))
+)
+
+(RPAQQ ARRAYCONSTANTS (\ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells 
+                                 \ArrayBlockTrailerWords (\ArrayBlockOverheadCells (IPLUS 
+                                                                               \ArrayBlockHeaderCells
+                                                                                          
+                                                                              \ArrayBlockTrailerCells
+                                                                                          ))
+                                 (\ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords 
+                                                                  \ArrayBlockTrailerWords))
+                                 \ArrayBlockLinkingCells
+                                 (\MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells 
+                                                            \ArrayBlockLinkingCells))
+                                 (\MaxArrayBlockSize 65535)
+                                 (\MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize 
+                                                         \ArrayBlockOverheadCells))
+                                 \MaxArrayLen
+                                 (\ABPASSWORDSHIFT 3)
+                                 (\ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT))
+                                 (\FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword 
+                                                                  \ABPASSWORDSHIFT)
+                                                            (LLSH UNBOXEDBLOCK.GCT 1)))
+                                 (\UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword 
+                                                                  \ABPASSWORDSHIFT)
+                                                            1))
+                                 (\CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword 
+                                                                  \ABPASSWORDSHIFT)
+                                                            (LLSH CODEBLOCK.GCT 1)
+                                                            1))))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \ArrayBlockHeaderCells 1)
+
+(RPAQQ \ArrayBlockHeaderWords 2)
+
+(RPAQQ \ArrayBlockTrailerCells 1)
+
+(RPAQQ \ArrayBlockTrailerWords 2)
+
+(RPAQ \ArrayBlockOverheadCells (IPLUS \ArrayBlockHeaderCells \ArrayBlockTrailerCells))
+
+(RPAQ \ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords \ArrayBlockTrailerWords))
+
+(RPAQQ \ArrayBlockLinkingCells 2)
+
+(RPAQ \MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells \ArrayBlockLinkingCells))
+
+(RPAQQ \MaxArrayBlockSize 65535)
+
+(RPAQ \MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize \ArrayBlockOverheadCells))
+
+(RPAQQ \MaxArrayLen 65535)
+
+(RPAQQ \ABPASSWORDSHIFT 3)
+
+(RPAQ \ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT))
+
+(RPAQ \FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
+                                    (LLSH UNBOXEDBLOCK.GCT 1)))
+
+(RPAQ \UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
+                                    1))
+
+(RPAQ \CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
+                                    (LLSH CODEBLOCK.GCT 1)
+                                    1))
+
+
+(CONSTANTS \ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells 
+       \ArrayBlockTrailerWords (\ArrayBlockOverheadCells (IPLUS \ArrayBlockHeaderCells 
+                                                                \ArrayBlockTrailerCells))
+       (\ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords \ArrayBlockTrailerWords))
+       \ArrayBlockLinkingCells
+       (\MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells \ArrayBlockLinkingCells))
+       (\MaxArrayBlockSize 65535)
+       (\MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize \ArrayBlockOverheadCells))
+       \MaxArrayLen
+       (\ABPASSWORDSHIFT 3)
+       (\ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT))
+       (\FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
+                                  (LLSH UNBOXEDBLOCK.GCT 1)))
+       (\UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
+                                  1))
+       (\CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
+                                  (LLSH CODEBLOCK.GCT 1)
+                                  1)))
+)
+
+(RPAQQ ARRAYTYPES ((\ST.BYTE 0)
+                       (\ST.POS16 1)
+                       (\ST.INT32 2)
+                       (\ST.CODE 4)
+                       (\ST.PTR 6)
+                       (\ST.FLOAT 7)
+                       (\ST.BIT 8)
+                       (\ST.PTR2 11)))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \ST.BYTE 0)
+
+(RPAQQ \ST.POS16 1)
+
+(RPAQQ \ST.INT32 2)
+
+(RPAQQ \ST.CODE 4)
+
+(RPAQQ \ST.PTR 6)
+
+(RPAQQ \ST.FLOAT 7)
+
+(RPAQQ \ST.BIT 8)
+
+(RPAQQ \ST.PTR2 11)
+
+
+(CONSTANTS (\ST.BYTE 0)
+       (\ST.POS16 1)
+       (\ST.INT32 2)
+       (\ST.CODE 4)
+       (\ST.PTR 6)
+       (\ST.FLOAT 7)
+       (\ST.BIT 8)
+       (\ST.PTR2 11))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \MAX.CELLSPERHUNK 64)
+
+
+(CONSTANTS \MAX.CELLSPERHUNK)
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \IN.MAKEINIT NIL)
+
+
+(CONSTANTS (\IN.MAKEINIT))
+)
+(DECLARE%: EVAL@COMPILE
+
+(BLOCKRECORD SEQUENCEDESCRIPTOR ((ORIG BITS 1)
+                                     (NIL BITS 1)
+                                     (READONLY FLAG)
+                                     (NIL BITS 1)
+                                     (BASE POINTER)
+                                     (TYP BITS 4)
+                                     (NIL BITS 4)
+                                     (LENGTH BITS 24)
+                                     (OFFST FIXP)))
+
+(DATATYPE ARRAYP ((ORIG BITS 1)
+                      (NIL BITS 1)
+                      (READONLY FLAG)                        (* ; "probably no READONLY arrays now")
+                      (NIL BITS 1)
+                      (BASE POINTER)
+                      (TYP BITS 4)
+                      (NIL BITS 4)
+                      (LENGTH BITS 24)
+                      (OFFST FIXP))
+
+                     (* ;; "note that while ARRAYP is a DATATYPE, the allocation of it actually happens at MAKEINIT time under INITDATATYPE{NAMES}")
+
+                     )
+
+(BLOCKRECORD ARRAYBLOCK ((PASSWORD BITS 13)
+                             (GCTYPE BITS 2)                 (* ; "Unboxed, Pointers, or Code")
+                             (INUSE FLAG)
+                             (ARLEN WORD)
+                             (FWD FULLXPOINTER)              (* ; "Only when on free list")
+                             (BKWD FULLXPOINTER))
+                            (BLOCKRECORD ARRAYBLOCK ((ABFLAGS WORD)
+                                                             (* ; "Used for header and trailer")
+                                                     ))
+                            [ACCESSFNS ARRAYBLOCK ((DAT (\ADDBASE DATUM \ArrayBlockHeaderWords))
+                                                   (TRAILER (\ADDBASE2 DATUM
+                                                                   (IDIFFERENCE (fetch
+                                                                                 (ARRAYBLOCK ARLEN)
+                                                                                   of DATUM)
+                                                                          \ArrayBlockTrailerCells]
+                            (TYPE? (AND (EQ 0 (NTYPX DATUM))
+                                            (IGEQ (\HILOC DATUM)
+                                                  \FirstArraySegment))))
+)
+
+(/DECLAREDATATYPE 'ARRAYP '((BITS 1)
+                            (BITS 1)
+                            FLAG
+                            (BITS 1)
+                            POINTER
+                            (BITS 4)
+                            (BITS 4)
+                            (BITS 24)
+                            FIXP)
+       '((ARRAYP 0 (BITS . 0))
+         (ARRAYP 0 (BITS . 16))
+         (ARRAYP 0 (FLAGBITS . 32))
+         (ARRAYP 0 (BITS . 48))
+         (ARRAYP 0 POINTER)
+         (ARRAYP 2 (BITS . 3))
+         (ARRAYP 2 (BITS . 67))
+         (ARRAYP 2 (LONGBITS . 135))
+         (ARRAYP 4 FIXP))
+       '6)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \NxtArrayPage \FREEBLOCKBUCKETS \HUNKING?)
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \ArrayFrLst \ArrayFrLst2 \RECLAIM.COUNTDOWN)
+)
+)
+(DEFINEQ
+
+(\ALLOCBLOCK
+  [LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN)               (* bvm%: " 7-Feb-85 15:30")
+
+    (* ;; "NCELLS is number of cells wanted not counting overhead cell.  For code arrays, INITONPAGE is number of cells to be kept on a single page.  It might be necessary to flag a block with an aligned indicator, to help a compacting garbage collector preserve the align proprty.  --- Does not assume that caller is uninterruptable --- Returns NIL if NCELLS = 0 --- GCTYPE is one of the constants PTRBLOCK.GCT, CODEBLOCK.GCT, UNBOXEDBLOCK.GCT, indicating any special behavior to be performed when the block is reclaimed.  NIL defaults to UNBOXEDBLOCK.GCT")
+
+    (DECLARE (GLOBALVARS \ArrayFrLst))
+    (COND
+       ((ILESSP NCELLS \ArrayBlockLinkingCells)
+        (COND
+           ((ILESSP NCELLS 0)
+            (\ILLEGAL.ARG NCELLS)))
+        (SETQ NCELLS \ArrayBlockLinkingCells))
+       ((IGREATERP NCELLS \MaxArrayNCells)
+        (\LISPERROR NCELLS "ARRAY STORAGE BLOCK TOO LARGE")))(* ; 
+                           "NCELLS is number of data cells;  remember for allocation counter below")
+    (SELECTQ GCTYPE
+        (NIL (SETQ GCTYPE UNBOXEDBLOCK.GCT))
+        (T (SETQ GCTYPE PTRBLOCK.GCT))
+        NIL)                                                 (* ; 
+                           "This SELECTQ can be removed when all callers are upgraded to constants")
+    (COND
+       ((AND INITONPAGE (OR (ILESSP INITONPAGE 0)
+                            (IGREATERP INITONPAGE CELLSPERPAGE)))
+        (\ILLEGAL.ARG INITONPAGE)))
+    (COND
+       ((NULL ALIGN))
+       ((OR (ILESSP ALIGN 0)
+            (IGREATERP ALIGN CELLSPERPAGE))
+        (\ILLEGAL.ARG ALIGN))
+       ((ILEQ ALIGN 1)
+        (SETQ ALIGN))
+       ((AND INITONPAGE (PROGN                               (* ; 
+                           "Some check for consistency between ALIGN and INITONPAGE is needed here")
+                               NIL))
+        (ERROR "INITONPAGE and ALIGN too high")))
+    (OR (AND \HUNKING? (ILEQ NCELLS \MAX.CELLSPERHUNK)
+             (\ALLOCHUNK NCELLS GCTYPE INITONPAGE ALIGN))
+        (PROG ((ARLEN (IPLUS NCELLS \ArrayBlockOverheadCells))
+               ABLOCK)
+          RETRY
+              (UNINTERRUPTABLY
+                                                             (* ; "Comment PPLossage")
+                  (SETQ ABLOCK (OR (\ALLOCBLOCK.OLD ARLEN GCTYPE INITONPAGE ALIGN)
+                                   (\ALLOCBLOCK.NEW ARLEN GCTYPE INITONPAGE ALIGN)
+                                   (PROGN (FRPTQ 10 (RECLAIM))
+
+                                          (* ;; "We're probably out of array space;  our last chance is to collect and hope something shows up on the free list.")
+
+                                          (\ALLOCBLOCK.OLD ARLEN GCTYPE INITONPAGE ALIGN))
+                                   (GO FULL)))               (* ; 
+                     "ABLOCK now points to the beginning of the actual block of storage to be used")
+                  (replace (ARRAYBLOCK INUSE) of ABLOCK with T)
+                  (replace (ARRAYBLOCK INUSE) of (fetch (ARRAYBLOCK TRAILER) of
+                                                                                         ABLOCK)
+                     with T)
+                  (replace (ARRAYBLOCK GCTYPE) of ABLOCK with GCTYPE)
+                  (\CHECKARRAYBLOCK ABLOCK NIL)
+                  (.INCREMENT.ALLOCATION.COUNT. NCELLS)      (* ; 
+                                              "NCELLS because CREATEREF accounts for overhead cell")
+                  (SETQ ABLOCK (\ADDBASE ABLOCK \ArrayBlockHeaderWords))
+                  (\CREATEREF ABLOCK)
+                  (RETURN ABLOCK))
+          FULL
+              (LISPERROR "ARRAYS FULL" NIL T)                (* ; 
+                                                          "User might release something, so retry.")
+              (GO RETRY])
+
+(\MAIKO.ALLOCBLOCK
+  [LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN)               (* ; "Edited 29-Jun-90 12:17 by ON")
+
+    (* ;; "Maiko specific \ALLOCBLOCK. Does not decrement \RECLAIM.COUNTDOWN.")
+
+    (* ;; "NCELLS is number of cells wanted not counting overhead cell.  For code arrays, INITONPAGE is number of cells to be kept on a single page.  It might be necessary to flag a block with an aligned indicator, to help a compacting garbage collector preserve the align proprty.  --- Does not assume that caller is uninterruptable --- Returns NIL if NCELLS = 0 --- GCTYPE is one of the constants PTRBLOCK.GCT, CODEBLOCK.GCT, UNBOXEDBLOCK.GCT, indicating any special behavior to be performed when the block is reclaimed.  NIL defaults to UNBOXEDBLOCK.GCT")
+
+    (DECLARE (GLOBALVARS \ArrayFrLst))
+    (COND
+       ((ILESSP NCELLS \ArrayBlockLinkingCells)
+        (COND
+           ((ILESSP NCELLS 0)
+            (\ILLEGAL.ARG NCELLS)))
+        (SETQ NCELLS \ArrayBlockLinkingCells))
+       ((IGREATERP NCELLS \MaxArrayNCells)
+        (\LISPERROR NCELLS "ARRAY STORAGE BLOCK TOO LARGE")))(* ; 
+                           "NCELLS is number of data cells;  remember for allocation counter below")
+    (SELECTQ GCTYPE
+        (NIL (SETQ GCTYPE UNBOXEDBLOCK.GCT))
+        (T (SETQ GCTYPE PTRBLOCK.GCT))
+        NIL)                                                 (* ; 
+                           "This SELECTQ can be removed when all callers are upgraded to constants")
+
+    (* ;; "Maiko doesn't have to worry about INITONPAGE.   ----- '90/06/29 on.")
+
+    (* ;; "(COND ((AND INITONPAGE (OR (ILESSP INITONPAGE 0) (IGREATERP INITONPAGE CELLSPERPAGE))) (\ILLEGAL.ARG INITONPAGE)))")
+
+    (COND
+       ((NULL ALIGN))
+       ((OR (ILESSP ALIGN 0)
+            (IGREATERP ALIGN CELLSPERPAGE))
+        (\ILLEGAL.ARG ALIGN))
+       ((ILEQ ALIGN 1)
+        (SETQ ALIGN))
+       ((AND INITONPAGE (PROGN                               (* ; 
+                           "Some check for consistency between ALIGN and INITONPAGE is needed here")
+                               NIL))
+        (ERROR "INITONPAGE and ALIGN too high")))
+    (OR (AND \HUNKING? (ILEQ NCELLS \MAX.CELLSPERHUNK)       (* ; 
+      "Maiko doesn't have to worry about INITONPAGE so call \ALLOCHUNK with arg INITONPAGE as NIL.")
+             (\ALLOCHUNK NCELLS GCTYPE NIL ALIGN))
+        (PROG ((ARLEN (IPLUS NCELLS \ArrayBlockOverheadCells))
+               ABLOCK)
+          RETRY
+              (UNINTERRUPTABLY
+                                                             (* ; "Comment PPLossage")
+                  (SETQ ABLOCK (OR (\ALLOCBLOCK.OLD ARLEN GCTYPE NIL ALIGN)
+                                   (\ALLOCBLOCK.NEW ARLEN GCTYPE NIL ALIGN)
+                                   (PROGN (FRPTQ 10 (RECLAIM))
+
+                                          (* ;; "We're probably out of array space;  our last chance is to collect and hope something shows up on the free list.")
+
+                                          (\ALLOCBLOCK.OLD ARLEN GCTYPE INITONPAGE ALIGN))
+                                   (GO FULL)))               (* ; 
+                     "ABLOCK now points to the beginning of the actual block of storage to be used")
+                  (replace (ARRAYBLOCK INUSE) of ABLOCK with T)
+                  (replace (ARRAYBLOCK INUSE) of (fetch (ARRAYBLOCK TRAILER) of
+                                                                                         ABLOCK)
+                     with T)
+                  (replace (ARRAYBLOCK GCTYPE) of ABLOCK with GCTYPE)
+                  (\CHECKARRAYBLOCK ABLOCK NIL)
+                  (.CHECK.ALLOCATION.COUNT. NCELLS)
+                  (SETQ ABLOCK (\ADDBASE ABLOCK \ArrayBlockHeaderWords))
+                  (PROG1 (\DELREF ABLOCK)
+                         (.CHECK.ALLOCATION.COUNT. 1))
+                  (RETURN ABLOCK))
+          FULL
+              (LISPERROR "ARRAYS FULL" NIL T)                (* ; 
+                                                          "User might release something, so retry.")
+              (GO RETRY])
+
+(\ALLOCBLOCK.OLD
+  [LAMBDA (ARLEN GCTYPE INITONPAGE ALIGN)                (* bvm%: "15-Feb-85 11:01")
+
+    (* ;; "Returns a block of the right size and alignment, or NIL if one couldn't be found.")
+
+    (for BKTI from (BUCKETINDEX ARLEN) to \MAXBUCKETINDEX bind ABLOCK
+       when (AND (SETQ ABLOCK (\GETBASEPTR (\ADDBASE2 \FREEBLOCKBUCKETS BKTI)
+                                         0))
+                     (bind (1STBLOCK.IN.FREECHAIN _ ABLOCK)
+                            USABLELEN REMAINDERLEN PREFIXLEN
+                        repeatuntil (EQ (SETQ ABLOCK (fetch (ARRAYBLOCK FWD) of ABLOCK))
+                                            1STBLOCK.IN.FREECHAIN)
+                        when (PROGN [COND
+                                           ((OR (NEQ (fetch (ARRAYBLOCK PASSWORD) of ABLOCK)
+                                                     \ArrayBlockPassword)
+                                                (NEQ (fetch (ARRAYBLOCK PASSWORD)
+                                                        of (fetch (ARRAYBLOCK TRAILER)
+                                                                  of ABLOCK))
+                                                     \ArrayBlockPassword))
+                                            (RETURN (\MP.ERROR \MP.BADARRAYBLOCK "Bad Array Block" 
+                                                           ABLOCK]
+                                        (SETQ PREFIXLEN (COND
+                                                           ((OR ALIGN INITONPAGE)
+                                                            (\PREFIXALIGNMENT? ARLEN INITONPAGE 
+                                                                   ALIGN GCTYPE ABLOCK))
+                                                           (T 0)))
+                                        (IGEQ (SETQ USABLELEN (IDIFFERENCE (fetch (ARRAYBLOCK
+                                                                                       ARLEN)
+                                                                              of ABLOCK)
+                                                                     PREFIXLEN))
+                                              ARLEN))
+                        do (\CHECKARRAYBLOCK ABLOCK T T)
+                              (\DELETEBLOCK? ABLOCK)     (* ; "take it off the free list")
+                              [COND
+                                 ((NEQ PREFIXLEN 0)          (* ; 
+                   "We must split off a bit initially, in order to preserve the INITONPAGE request")
+                                  (\MERGEBACKWARD (\MAKEFREEARRAYBLOCK ABLOCK PREFIXLEN))
+                                  (SETQ ABLOCK (\ADDBASE2 ABLOCK PREFIXLEN]
+                              (SETQ REMAINDERLEN (IDIFFERENCE USABLELEN ARLEN))
+                              (COND
+                                 [(IGREATERP REMAINDERLEN (COND
+                                                             (\HUNKING? (IPLUS \MAX.CELLSPERHUNK 
+                                                                             \ArrayBlockOverheadCells
+                                                                               ))
+                                                             (T 0)))
+                                                             (* ; 
+                                             "Split off any extra space from the end of the block.")
+                                  (\MERGEFORWARD (\LINKBLOCK (\MAKEFREEARRAYBLOCK
+                                                                      (\ADDBASE2 ABLOCK ARLEN)
+                                                                      REMAINDERLEN]
+                                 (\HUNKING?                  (* ; 
+                                         "Coerce the length upwards so as not to have a runt block")
+                                        (SETQ ARLEN USABLELEN)))
+                              (COND
+                                 ((OR (NEQ PREFIXLEN 0)
+                                      (NEQ USABLELEN ARLEN)) (* ; 
+                                  "If we changed the length of the block, store the new length now")
+                                  (\MAKEFREEARRAYBLOCK ABLOCK ARLEN)))
+                              (\CHECKARRAYBLOCK ABLOCK T)
+                              (\CLEARCELLS (\ADDBASE ABLOCK \ArrayBlockHeaderWords)
+                                     (IDIFFERENCE ARLEN \ArrayBlockOverheadCells)) 
+                                                             (* ; "clear out old garbage")
+                                                             (* ; "signal that we found one")
+                              (RETURN T))) do (RETURN ABLOCK])
+
+(\ALLOCBLOCK.NEW
+  [LAMBDA (ARLEN GCTYPE INITONPAGE ALIGN)                (* ; "Edited  4-Jan-93 02:06 by jds")
+    (DECLARE (GLOBALVARS \ArrayFrLst \NxtArrayPage))
+
+    (* ;; "Patch up a new section of memory beginning at the end of current arrayspace, and make it a freeblock for subsequent usage.  Also used to increment to the next page/segment boundary when allocating code arrays")
+
+    (PROG (FINALWORD FINALPAGE NEXTFREEBLOCK PREFIXLEN)
+      RETRY
+          [COND
+             ([AND (OR INITONPAGE ALIGN)
+                   (NEQ 0 (SETQ PREFIXLEN (\PREFIXALIGNMENT? ARLEN INITONPAGE ALIGN GCTYPE 
+                                                 \ArrayFrLst](* ; 
+                         "Gobble up a modest amount of space in order to insure correct alignment.")
+              (COND
+                 ((SETQ PREFIXLEN (\ALLOCBLOCK.NEW PREFIXLEN))
+                  (\MERGEBACKWARD PREFIXLEN)             (* ; 
+               "Problem: what happens if array space switch happened inside this \ALLOCBLOCK.NEW ?")
+                  )
+                 (T (RETURN]
+          (SETQ FINALWORD (\ADDBASE (\ADDBASE \ArrayFrLst ARLEN)
+                                 (SUB1 ARLEN)))
+
+     (* ;; "FINALWORD is pointer to the last word of the new block.  The new \ArrayFrLst will be one past that, i.e., at (\ADDBASE2 \ArrayFrLst ARLEN) -- The double \ADDBASE avoids large integer arithmetic and computing FINALWORD first avoids negative arguments to \ADDBASE")
+
+          (SETQ NEXTFREEBLOCK (\ADDBASE FINALWORD 1))
+          [COND
+             ((IGREATERP (SETQ FINALPAGE (fetch (POINTER PAGE#) of FINALWORD))
+                     (IDIFFERENCE \NxtMDSPage \GUARDSTORAGEFULL))
+                                                             (* ; 
+ "Make sure that there are enough pages to satisfy this request before we make any global changes.")
+              (SELECTQ (\CHECKFORSTORAGEFULL (ADD1 (IDIFFERENCE FINALPAGE \NxtArrayPage)))
+                  (T                                         (* ; "Is ok, go ahead"))
+                  (0                                         (* ; "Is ok, but \NxtArrayPage moved.")
+                     (GO RETRY))
+                  (RETURN NIL]
+
+     (* ;; "\NxtArrayPage is the page after the page of FINALWORD, the next one that needs to be \NEWPAGEd.  \ArrayFrLst's page will be (SUB1 \NxtArrayPage) except when it is allowed to be EQ to the first word on \NxtArrayPage")
+
+          (until (IGREATERP \NxtArrayPage FINALPAGE)
+             do (\MAKEMDSENTRY \NxtArrayPage 0)
+                   (\NEW2PAGE (create POINTER
+                                     PAGE# _ \NxtArrayPage))
+                   (\PUTBASEFIXP \NxtArrayPage 0 (IPLUS \NxtArrayPage 2)))
+          (RETURN (PROG1 (\MAKEFREEARRAYBLOCK \ArrayFrLst ARLEN)
+                         (SETQ.NOREF \ArrayFrLst NEXTFREEBLOCK])
+
+(\PREFIXALIGNMENT?
+  [LAMBDA (ARLEN INITONPAGE ALIGN GCTYPE BASE)           (* Pavel "16-Oct-86 14:15")
+
+    (* ;; "how many cells must be added to to the base address of BASE to get a block whose first data word is aligned according to ALIGN and which has its first INITONPAGE cells all on one page")
+
+    (PROG ((DAT (fetch (POINTER CELLINSEGMENT) of (\ADDBASE BASE \ArrayBlockHeaderWords)))
+           (ADJUSTMENT 0)
+           FUDGE)
+
+     (* ;; "DAT will hold the cell-in-segment offset of the first dataword of the arrayblock;  it is this first dataword which must be aligned etc rather than the true beginning of the block.")
+
+      LP  (COND
+             ((AND ALIGN (NEQ (SETQ FUDGE (IREMAINDER DAT ALIGN))
+                              0))                            (* ; 
+                                                           "Not aligned, so adjust first for that.")
+              (add ADJUSTMENT (SETQ FUDGE (IDIFFERENCE ALIGN FUDGE)))
+              (add DAT FUDGE)))
+          (COND
+             ((AND INITONPAGE (NEQ (FLOOR DAT CELLSPERPAGE)
+                                   (FLOOR (IPLUS DAT INITONPAGE -1)
+                                          CELLSPERPAGE)))    (* ; 
+                           "There aren't INITONPAGE cells on the page, so go to next page boundary")
+              [add ADJUSTMENT (SETQ FUDGE (IDIFFERENCE CELLSPERPAGE (IMOD DAT CELLSPERPAGE]
+              (add DAT FUDGE)
+
+              (* ;; "No need to realign at this point.  ALIGN must be a power of two, so it's either an alignment less than CELLSPERPAGE, in which case this page boundary satisfies it, or it's a multiple of CELLSPERPAGE, in which case the first COND satisfied it and we didn't have to touch it in this COND")
+
+              ))
+          (COND
+             ([AND (EQ GCTYPE CODEBLOCK.GCT)
+                   (IGREATERP (IDIFFERENCE ARLEN \ArrayBlockOverheadCells)
+                          (SETQ FUDGE (IDIFFERENCE CELLSPERSEGMENT (SETQ DAT (IMOD DAT 
+                                                                                   CELLSPERSEGMENT]
+
+              (* ;; "Code arrays cannot cross segment boundaries.  Note that ARLEN includes the overhead cells, hence the extra subtraction.")
+
+              (add ADJUSTMENT FUDGE)
+              (add DAT FUDGE)
+
+              (* ;; "No need to re-check the alignment since ALIGN and INITONPAGE are both guaranteed satisified by a block starting on a segment boundary")
+
+              ))
+
+     (* ;; "The following code claims to prevent splitting off too small a block, but it's not clear this is intrinsically bad, and the code does not appear to do anything rational.  -- bvm --- (COND ((AND (NEQ ADJUSTMENT 0) \HUNKING?  (IGREATERP (SETQ FUDGE (IDIFFERENCE (IPLUS \MAX.CELLSPERHUNK \ArrayBlockOverheadCells) ADJUSTMENT)) 0) (PROGN (* * Account for potential merging backwards when this initial piece is split off.) (AND (EQ (fetch (ARRAYBLOCK PASSWORD) of (SETQ PREVTRAILER (\ADDBASE BASE (IMINUS \ArrayBlockTrailerCells)))) \ArrayBlockPassword) (NOT (fetch (ARRAYBLOCK INUSE) of PREVTRAILER)) (ILESSP (fetch (ARRAYBLOCK ARLEN) of PREVTRAILER) FUDGE)))) (* Just to ensure that we don't break up a large arrayblocks into two pieces one of which is too small to be usable.) (add ADJUSTMENT FUDGE) (SETQ DAT (IPLUS DAT FUDGE)) (* Go around again, since this function wouldn't have been called unless one of INITONPAGE or ALIGN were non-null.) (GO LP)))")
+
+          (RETURN ADJUSTMENT])
+
+(\MAKEFREEARRAYBLOCK
+  [LAMBDA (BLOCK LENGTH)                                 (* lmm "25-Jul-84 13:07")
+    (replace (ARRAYBLOCK ABFLAGS) of BLOCK with \FreeArrayFlagWord)
+    (replace (ARRAYBLOCK ARLEN) of BLOCK with LENGTH)
+    (replace (ARRAYBLOCK ABFLAGS) of (fetch (ARRAYBLOCK TRAILER) of BLOCK)
+       with \FreeArrayFlagWord)
+    (replace (ARRAYBLOCK ARLEN) of (fetch (ARRAYBLOCK TRAILER) of BLOCK) with
+                                                                                         LENGTH)
+    BLOCK])
+
+(\DELETEBLOCK?
+  [LAMBDA (BASE)                                         (* bvm%: "15-Feb-85 11:04")
+    (COND
+       ((AND (IGEQ (fetch (ARRAYBLOCK ARLEN) of BASE)
+                   \MinArrayBlockSize)
+             (fetch (ARRAYBLOCK FWD) of BASE))       (* ; 
+                                           "Allegedly, BASE has been 'checked' before coming here.")
+        (PROG [(F (fetch (ARRAYBLOCK FWD) of BASE))
+               (B (fetch (ARRAYBLOCK BKWD) of BASE))
+               (FBL (FREEBLOCKCHAIN.N (fetch ARLEN of BASE]
+              (COND
+                 ((EQ BASE F)
+                  (COND
+                     ((EQ BASE (\GETBASEPTR FBL 0))
+                      (\PUTBASEPTR FBL 0 NIL))
+                     (T (\MP.ERROR \MP.BADDELETEBLOCK "deleting last block # FREEBLOCKLIST")))
+                  (RETURN))
+                 ((EQ BASE (\GETBASEPTR FBL 0))
+                  (\PUTBASEPTR FBL 0 F)))
+              (replace (ARRAYBLOCK BKWD) of F with B)
+              (replace (ARRAYBLOCK FWD) of B with F])
+
+(\LINKBLOCK
+  [LAMBDA (BASE)                                         (* JonL "16-Jan-85 02:46")
+
+    (* ;; "Add BASE to the free list.  Assumes that BASE is a well-formed free block.")
+
+    [COND
+       (\FREEBLOCKBUCKETS (COND
+                             ((ILESSP (fetch (ARRAYBLOCK ARLEN) of BASE)
+                                     \MinArrayBlockSize)
+                              (\CHECKARRAYBLOCK BASE T))
+                             (T (PROG ((FBL (FREEBLOCKCHAIN.N (fetch ARLEN of BASE)))
+                                       FREEBLOCK)
+                                      (SETQ FREEBLOCK (\GETBASEPTR FBL 0))
+                                      (COND
+                                         ((NULL FREEBLOCK)
+                                          (replace (ARRAYBLOCK FWD) of BASE with BASE)
+                                          (replace (ARRAYBLOCK BKWD) of BASE with BASE))
+                                         (T (replace (ARRAYBLOCK FWD) of BASE with 
+                                                                                            FREEBLOCK
+                                                   )
+                                            (replace (ARRAYBLOCK BKWD) of BASE
+                                               with (fetch (ARRAYBLOCK BKWD) of FREEBLOCK
+                                                               ))
+                                            (replace (ARRAYBLOCK FWD) of (fetch
+                                                                                  (ARRAYBLOCK BKWD)
+                                                                                    of FREEBLOCK)
+                                               with BASE)
+                                            (replace (ARRAYBLOCK BKWD) of FREEBLOCK
+                                               with BASE)))
+                                      (\PUTBASEPTR FBL 0 BASE)
+                                      (\CHECKARRAYBLOCK BASE T T]
+    BASE])
+
+(\MERGEBACKWARD
+  [LAMBDA (BASE)                                         (* bvm%: " 6-Feb-85 16:53")
+
+    (* ;; "Caller is uninterruptable and asserts that a non-NIL BASE is a free but unlinked arrayblock.  We return a linked (if possible) block, either BASE itself or an enlarged previous free block that is linked (if possible) and includes the BASE storage.")
+
+    (PROG (ARLEN PARLEN PBASE PTRAILER SPLIT)
+          [COND
+             ((NULL BASE)
+              (RETURN NIL))
+             ([OR (NOT \ARRAYMERGING)
+                  (EQ BASE \ARRAYSPACE)
+                  (EQ BASE \ARRAYSPACE2)
+                  (fetch (ARRAYBLOCK INUSE) of (SETQ PTRAILER (\ADDBASE BASE (IMINUS 
+                                                                              \ArrayBlockTrailerWords
+                                                                                            ]
+
+              (* ;; "If this is the absolute 'first' block of array space, then there is nothing behind it to merge;  similarly, if the block behind it is in use, then don't merge.")
+
+              (RETURN (\LINKBLOCK BASE]
+          [SETQ PBASE (\ADDBASE2 BASE (IMINUS (fetch (ARRAYBLOCK ARLEN) of PTRAILER]
+          (\CHECKARRAYBLOCK PBASE T)
+          (\DELETEBLOCK? PBASE)
+          (RETURN (\ARRAYBLOCKMERGER PBASE BASE])
+
+(\MERGEFORWARD
+  [LAMBDA (BASE)                                         (* bvm%: "15-Feb-85 11:18")
+
+    (* ;; "BASE is a free and linked (if possible) block.  Merge with the next block if it is free and not too big.  Caller must be uninterruptable.")
+
+    (PROG (NBASE NBINUSE)
+          (COND
+             ((OR (NOT \ARRAYMERGING)
+                  (NULL BASE)
+                  (\CHECKARRAYBLOCK BASE T T)
+                  (EQ (SETQ NBASE (\ADDBASE2 BASE (fetch (ARRAYBLOCK ARLEN) of BASE)))
+                      \ArrayFrLst)
+                  (EQ NBASE \ArrayFrLst2)
+                  [\CHECKARRAYBLOCK NBASE (NOT (SETQ NBINUSE (fetch (ARRAYBLOCK INUSE)
+                                                                    of NBASE]
+                  NBINUSE)
+              (RETURN NIL)))                                 (* ; 
+                                "Note that if we ever get to here, both blocks have been 'checked'")
+          (\DELETEBLOCK? NBASE)
+          (\DELETEBLOCK? BASE)
+          (\ARRAYBLOCKMERGER BASE NBASE])
+
+(\ARRAYBLOCKMERGER
+  [LAMBDA (BASE NBASE)                                   (* bvm%: "13-Feb-85 14:57")
+
+(* ;;; "BASE and NBASE are two consecutive unlinked freeblocks.  (Called only after the two blocks have been 'checked')")
+
+    (PROG ((ARLEN (fetch (ARRAYBLOCK ARLEN) of BASE))
+           (NARLEN (fetch (ARRAYBLOCK ARLEN) of NBASE))
+           SECONDBITE MINBLOCKSIZE SHAVEBACK)
+          (SETQ SECONDBITE (IDIFFERENCE \MaxArrayBlockSize ARLEN))
+          (COND
+             ((IGREATERP NARLEN SECONDBITE)
+
+              (* ;; "check if sum of NARLEN+ARLEN is leq maximum.  (Written this way to stay within small number range.) If not, then break up into two freeblocks since one can't hold all the cells.")
+
+              (SETQ ARLEN \MaxArrayBlockSize)
+              (SETQ NARLEN (IDIFFERENCE NARLEN SECONDBITE))
+
+              (* ;; "Normal overflow case is just to make the first block as big as possible, then leave the rest in the second block.  So the code above adds to ARLEN and subtracts from NARLEN an equal amount to achieve the desired split.  However, check that the remaining NBASE block is not too small")
+
+              (COND
+                 ([ILESSP NARLEN (SETQ MINBLOCKSIZE (COND
+                                                       (\HUNKING? (IPLUS \ArrayBlockOverheadCells 
+                                                                         \MAX.CELLSPERHUNK))
+                                                       (T \MinArrayBlockSize]
+
+                  (* ;; "Decrease ARLEN and SECONDBITE by the amount it will take to get NARLEN up to MINBLOCKSIZE -- SHAVEBACK is negative")
+
+                  (SETQ SHAVEBACK (IDIFFERENCE NARLEN (SETQ NARLEN MINBLOCKSIZE)))
+                  (add ARLEN SHAVEBACK)
+                  (add SECONDBITE SHAVEBACK)))
+
+              (* ;; "Okay, make a tail of the second block into a free block of its own")
+
+              (\LINKBLOCK (\MAKEFREEARRAYBLOCK (\ADDBASE2 NBASE SECONDBITE)
+                                     NARLEN))
+              (SETQ NARLEN 0)))
+          (RETURN (\LINKBLOCK (\MAKEFREEARRAYBLOCK BASE (IPLUS ARLEN NARLEN])
+
+(\#BLOCKDATACELLS
+  [LAMBDA (DATAWORD)                                     (* JonL "20-Sep-84 19:07")
+
+    (* ;; "DATAWORD is a pointer as would be returned by \ALLOCBLOCK Returns the number of cells available to the caller.  Compiled closed so that we can change internal representations without clients needing to be recompiled.")
+
+    (PROG ((TYPENO (NTYPX DATAWORD)))
+          (RETURN (COND
+                     [(EQ 0 TYPENO)
+                      (COND
+                         ((type? ARRAYBLOCK DATAWORD)
+                          (IDIFFERENCE (fetch (ARRAYBLOCK ARLEN) of (\ADDBASE DATAWORD
+                                                                                   (IMINUS 
+                                                                               \ArrayBlockHeaderWords
+                                                                                          )))
+                                 \ArrayBlockOverheadCells))
+                         (T (\ILLEGAL.ARG DATAWORD]
+                     (T (OR (AND (OR \HUNKING? (fetch DTDHUNKP of (\GETDTD TYPENO)))
+                                 (HUNKSIZEFROMNUMBER TYPENO))
+                            (\ILLEGAL.ARG DATAWORD])
+
+(\COPYARRAYBLOCK
+  [LAMBDA (OLD)                                      (* ; "Edited  3-Mar-87 22:28 by bvm:")
+    (LET [(HEADER (\ADDBASE OLD (IMINUS \ArrayBlockHeaderWords]
+         (COND
+            [(AND (IEQ \ArrayBlockPassword (fetch PASSWORD of HEADER))
+                  (fetch (ARRAYBLOCK INUSE) of HEADER))
+             (LET* ((LEN (- (fetch (ARRAYBLOCK ARLEN) of HEADER)
+                            \ArrayBlockOverheadCells))
+                    (TYP (fetch (ARRAYBLOCK GCTYPE) of HEADER))
+                    (NEW (\ALLOCBLOCK LEN TYP)))
+                   (PROG1 NEW
+                       (SELECTC TYP
+                           (PTRBLOCK.GCT                     (* ; 
+                                                  "Have to reference count the pointers as we copy")
+                                         (FRPTQ LEN (\RPLPTR NEW 0 (COPYALL (\GETBASEPTR OLD 0)))
+                                                (SETQ NEW (\ADDBASE NEW WORDSPERCELL))
+                                                (SETQ OLD (\ADDBASE OLD WORDSPERCELL))))
+                           (CODEBLOCK.GCT                    (* ; 
+                                                           "should increment references from code")
+                                          (\COPYCODEBLOCK NEW OLD (UNFOLD LEN WORDSPERCELL)))
+                           (\BLT NEW OLD (UNFOLD LEN WORDSPERCELL))))]
+            (T                                               (* ; "Not an array block")
+               OLD])
+
+(\RECLAIMARRAYBLOCK
+  [LAMBDA (P)                                            (* ; "Edited  8-Jan-88 18:31 by jop")
+
+    (* ;; "Called to reclaim objects of type 0.  This is called with interrupts turned off.  Returns T to tell GC that we reclaimed it.")
+
+    (PROG ((B (\ADDBASE P (IMINUS \ArrayBlockHeaderWords)))
+           (RECLAIM-P T))
+
+     (* ;; "B points to arrayblock header, P to first and subsequent data words")
+
+          (IF (OR (< (\HILOC P)
+                         \FirstArraySegment)
+                      (NOT (IEQ \ArrayBlockPassword (fetch PASSWORD of B)))
+                      (NOT (fetch (ARRAYBLOCK INUSE) of B)))
+              THEN 
+
+                    (* ;; "RAID instead of \GCERROR because this error is continuable with ^N.")
+
+                    (\MP.ERROR \MP.BADARRAYRECLAIM 
+                           "Bad array block reclaimed--continue with ^N but save state ASAP")
+                    (RETURN T))
+          (SELECTC (fetch (ARRAYBLOCK GCTYPE) of B)
+              (PTRBLOCK.GCT                                  (* ; "Release all pointers")
+                            (for old P (TRAILER _ (fetch (ARRAYBLOCK TRAILER)
+                                                             of B)) by (\ADDBASE P 
+                                                                                      WORDSPERCELL)
+                               until (EQ P TRAILER) do (\RPLPTR P 0 NIL)))
+              (CODEBLOCK.GCT                                 (* ; "Release literals")
+
+                             (* ;; "Since \reclaimcodeblock is a finalization function -- returns nil if do reclaim and t if don't reclaim")
+
+                             (SETQ RECLAIM-P (NOT (\RECLAIMCODEBLOCK P))))
+              NIL)
+          [IF RECLAIM-P
+              THEN (\MERGEFORWARD (\MERGEBACKWARD (\MAKEFREEARRAYBLOCK B
+                                                                     (fetch ARLEN of B]
+
+     (* ;; "Always tell GC that we have reclaimed it")
+
+          (RETURN T])
+
+(\ADVANCE.ARRAY.SEGMENTS
+  [LAMBDA (NXTPAGE)                                      (* ; "Edited  4-Jan-93 02:08 by jds")
+
+(* ;;; "Called when the first 8mb are exhausted, and we want to switch array space into the next area, starting with page NXTPAGE -- have to first clean up what's left in the old area")
+
+    (PROG (NCELLSLEFT)
+          (SETQ.NOREF \ArrayFrLst2 (COND
+                                      ((IGEQ [SETQ NCELLSLEFT
+                                              (IPLUS (UNFOLD (SUB1 (IDIFFERENCE \NxtArrayPage
+                                                                          (fetch (POINTER PAGE#)
+                                                                             of \ArrayFrLst)))
+                                                            CELLSPERPAGE)
+                                                     (IDIFFERENCE CELLSPERPAGE (fetch
+                                                                                (POINTER CELLINPAGE)
+                                                                                  of \ArrayFrLst]
+                                             \MinArrayBlockSize)
+                                                             (* ; 
+                            "Make the rest of the already allocated array space into a small block")
+                                       (\MERGEBACKWARD (\MAKEFREEARRAYBLOCK \ArrayFrLst 
+                                                                  NCELLSLEFT))
+                                       (create POINTER
+                                              PAGE# _ \LeastMDSPage))
+                                      (T \ArrayFrLst)))
+          [SETQ.NOREF \ARRAYSPACE2 (SETQ.NOREF \ArrayFrLst (create POINTER
+                                                                  PAGE# _ (\PUTBASEFIXP \NxtArrayPage
+                                                                                 0 NXTPAGE]
+                                                             (* ; 
+                                "Return code to tell \ALLOCBLOCK.NEW to notice the new arrangement")
+          (RETURN 0])
+)
+
+(ADDTOVAR \MAIKO.MOVDS (\MAIKO.ALLOCBLOCK \ALLOCBLOCK))
+(DEFINEQ
+
+(\BYTELT
+  [LAMBDA (A J)                                          (* JonL "20-Sep-84 20:01")
+
+    (* ;; "A special function for system accesses to 0-origin byte arrays, of which syntax-tables are the primary example.  This compiles open into a GETBASEBYTE, with no checking for argument validity!")
+
+    (OR [AND [EQ 0 (fetch (ARRAYP ORIG) of (SETQ A (\DTEST A 'ARRAYP]
+             (OR (EQ \ST.BYTE (fetch (ARRAYP TYP) of A))
+                 (EQ \ST.CODE (fetch (ARRAYP TYP) of A]
+        (LISPERROR "ILLEGAL ARG" A))
+    (OR (IGREATERP (fetch (ARRAYP LENGTH) of A)
+               J)
+        (LISPERROR "ILLEGAL ARG" J))
+    (\GETBASEBYTE (fetch (ARRAYP BASE) of A)
+           (IPLUS (fetch (ARRAYP OFFST) of A)
+                  J])
+
+(\BYTESETA
+  [LAMBDA (A J V)                                        (* JonL "20-Sep-84 20:01")
+
+    (* ;; "A special function for system setting of 0-origin byte arrays, of which syntax-tables are the primary example.  This compiles open into a GETBASEBYTE, with no checking for argument validity! --- NOTE: The value is undefined, not V!")
+
+    (OR [AND [EQ 0 (fetch (ARRAYP ORIG) of (SETQ A (\DTEST A 'ARRAYP]
+             (OR (EQ \ST.BYTE (fetch (ARRAYP TYP) of A))
+                 (EQ \ST.CODE (fetch (ARRAYP TYP) of A]
+        (LISPERROR "ILLEGAL ARG" A))
+    (OR (IGREATERP (fetch (ARRAYP LENGTH) of A)
+               J)
+        (LISPERROR "ILLEGAL ARG" J))
+    (AND (fetch (ARRAYP READONLY) of A)
+         (LISPERROR "ILLEGAL ARG" A))
+    (\PUTBASEBYTE (fetch (ARRAYP BASE) of A)
+           (IPLUS (fetch (ARRAYP OFFST) of A)
+                  J)
+           V])
+
+(\WORDELT
+  [LAMBDA (A J)                                          (* JonL "20-Sep-84 20:02")
+
+    (* ;; "A special function for system accesses to 0-origin word arrays, This compiles open into a GETBASE, with no checking for argument validity!")
+
+    (OR (AND [EQ 0 (fetch (ARRAYP ORIG) of (SETQ A (\DTEST A 'ARRAYP]
+             (EQ \ST.POS16 (fetch (ARRAYP TYP) of A)))
+        (LISPERROR "ILLEGAL ARG" A))
+    (OR (IGREATERP (fetch (ARRAYP LENGTH) of A)
+               J)
+        (LISPERROR "ILLEGAL ARG" J))
+    (\GETBASE (fetch (ARRAYP BASE) of A)
+           (IPLUS (fetch (ARRAYP OFFST) of A)
+                  J])
+)
+(DEFINEQ
+
+(\ARRAYTYPENAME
+  [LAMBDA (X)                                            (* rmk%: "21-Dec-83 14:55")
+
+    (* ;; 
+  "This is called from the VM function TYPENAME to determine the 'logical' type of the array X")
+
+    (SELECTC (fetch (ARRAYP TYP) of X)
+        (\ST.CODE 'CCODEP)
+        'ARRAYP])
+)
+
+(RPAQQ \ARRAYMERGING T)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \ARRAYMERGING)
+)
+
+
+
+(* ; "for STORAGE")
+
+(DEFINEQ
+
+(\SHOW.ARRAY.FREELISTS
+  [LAMBDA (SIZESLST)                                     (* bvm%: "12-Feb-85 15:25")
+    (COND
+       ((OR SIZESLST (SETQ SIZESLST STORAGE.ARRAYSIZES))
+        (RESETFORM (RECLAIMMIN MAX.SMALLP)
+               (PROG ((TABLE \ABSTORAGETABLE)
+                      (N (LENGTH SIZESLST))
+                      (TOTAL 0)
+                      FBL ABLOCK ARLEN)
+                     [COND
+                        ((OR (NOT (\BLOCKDATAP TABLE))
+                             (IGEQ N (FOLDLO (\#BLOCKDATACELLS TABLE)
+                                            2)))
+
+                         (* ;; "Need bigger table if someone has enlarged SIZESLST since last time.  There are 2 cells per table entry")
+
+                         (SETQ \ABSTORAGETABLE (SETQ TABLE (\ALLOCBLOCK (UNFOLD (IPLUS N 4)
+                                                                                   2)
+                                                                  UNBOXEDBLOCK.GCT]
+                     (\CLEARCELLS TABLE (\#BLOCKDATACELLS TABLE))
+                     [for BKTI from 0 to \MAXBUCKETINDEX
+                        do (COND
+                                  ((SETQ FBL (\GETBASEPTR (\ADDBASE2 \FREEBLOCKBUCKETS BKTI)
+                                                    0))
+                                   (SETQ ABLOCK FBL)
+                                   (repeatuntil (EQ FBL (SETQ ABLOCK (fetch (ARRAYBLOCK
+                                                                                     FWD)
+                                                                            of ABLOCK)))
+                                      do (add TOTAL (SETQ ARLEN (fetch (ARRAYBLOCK ARLEN)
+                                                                           of ABLOCK)))
+                                            (for (SAFENTRY _ TABLE)
+                                               by (\ADDBASE SAFENTRY (TIMES 2 WORDSPERCELL))
+                                               as X in SIZESLST
+                                               when (OR (NULL X)
+                                                            (ILEQ ARLEN X))
+                                               do (add (fetch SAFITEMS of SAFENTRY)
+                                                             1)
+                                                     (add (fetch SAFCELLS of SAFENTRY)
+                                                            ARLEN)
+                                                     (RETURN]
+                     (printout NIL T " variable-datum free list: " T)
+                     (for (SAFENTRY _ TABLE) by (\ADDBASE SAFENTRY (TIMES 2 WORDSPERCELL))
+                        as X in SIZESLST do (COND
+                                                           (X (printout NIL "le " X))
+                                                           (T (printout NIL "others ")))
+                                                       (printout NIL 10 .I8 (fetch SAFITEMS
+                                                                               of SAFENTRY)
+                                                              " items; " .I8 (fetch SAFCELLS
+                                                                                of SAFENTRY)
+                                                              " cells." T))
+                     (printout NIL T "Total cells free: " .I8 TOTAL "  total pages: " .I4
+                            (FOLDHI TOTAL CELLSPERPAGE)
+                            T T])
+)
+
+(RPAQ? \ABSTORAGETABLE NIL)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \ABSTORAGETABLE)
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE
+
+(BLOCKRECORD SAFTABLE ((SAFITEMS WORD)
+                           (NIL WORD)
+                           (SAFCELLS FIXP)))
+)
+)
+
+
+
+(* ; "Debugging and RDSYS")
+
+(DEFINEQ
+
+(\CHECKARRAYBLOCK
+  [LAMBDA (BASE FREE ONFREELIST)                         (* bvm%: "13-Feb-85 14:50")
+    (COND
+       (ARRAYBLOCKCHECKING (PROG (ERROR TRAILER)
+                                 (COND
+                                    ((NEQ (fetch (ARRAYBLOCK PASSWORD) of BASE)
+                                          \ArrayBlockPassword)
+                                     (SETQ ERROR "ARRAYBLOCK Password wrong"))
+                                    ((NEQ (fetch (ARRAYBLOCK INUSE) of BASE)
+                                          (NOT FREE))
+                                     (SETQ ERROR "ARRAYBLOCK INUSE bit set wrong"))
+                                    ((UNLESSRDSYS (AND FREE (NEQ (\REFCNT BASE)
+                                                                 1))
+                                            NIL)
+                                     (SETQ ERROR "Free ARRAYBLOCK with RefCnt not 1"))
+                                    ((NEQ (fetch (ARRAYBLOCK PASSWORD)
+                                             of (SETQ TRAILER (fetch (ARRAYBLOCK TRAILER)
+                                                                     of BASE)))
+                                          \ArrayBlockPassword)
+                                     (SETQ ERROR "ARRAYBLOCK Trailer password wrong"))
+                                    ((NEQ (fetch (ARRAYBLOCK ARLEN) of BASE)
+                                          (fetch (ARRAYBLOCK ARLEN) of TRAILER))
+                                     (SETQ ERROR "ARRAYBLOCK Header and Trailer length don't match"))
+                                    ((NEQ (fetch (ARRAYBLOCK INUSE) of BASE)
+                                          (NOT FREE))
+                                     (SETQ ERROR "ARRAYBLOCK Trailer INUSE bit set wrong"))
+                                    ((OR (NOT ONFREELIST)
+                                         (ILESSP (fetch (ARRAYBLOCK ARLEN) of BASE)
+                                                \MinArrayBlockSize))
+                                                             (* ; 
+                                                     "Remaining tests only for blocks on free list")
+                                     (RETURN))
+                                    ((OR (NOT (EQPTR (fetch (ARRAYBLOCK FWD)
+                                                        of (fetch (ARRAYBLOCK BKWD)
+                                                                  of BASE))
+                                                     BASE))
+                                         (NOT (EQPTR (fetch (ARRAYBLOCK BKWD)
+                                                        of (fetch (ARRAYBLOCK FWD)
+                                                                  of BASE))
+                                                     BASE)))
+                                     (SETQ ERROR "ARRAYBLOCK links fouled"))
+                                    [(bind (FBL _ (FREEBLOCKCHAIN.N (fetch (ARRAYBLOCK ARLEN)
+                                                                           of BASE)))
+                                            ROVER first (OR (SETQ ROVER (\GETBASEPTR FBL 0))
+                                                                (RETURN (SETQ ERROR 
+                                                                         "Free block's bucket empty")
+                                                                       ))
+                                        do (AND (EQPTR ROVER BASE)
+                                                    (RETURN))
+                                              (\CHECKARRAYBLOCK ROVER T)
+                                        repeatuntil (EQ (SETQ ROVER (fetch (ARRAYBLOCK FWD)
+                                                                           of ROVER))
+                                                            (\GETBASEPTR FBL 0]
+                                    (T                       (* ; "Everything ok")
+                                       (RETURN)))
+                                 (UNLESSRDSYS (\MP.ERROR \MP.BADARRAYBLOCK ERROR BASE T)
+                                        (ERROR BASE ERROR))
+                                 (RETURN ERROR])
+
+(\PARSEARRAYSPACE
+  [LAMBDA (FN)                                           (* bvm%: "16-Apr-86 17:05")
+    (COND
+       ((NEQ \ArrayFrLst2 \ARRAYSPACE2)                      (* ; "Array space is in two chunks")
+        (\PARSEARRAYSPACE1 FN \ARRAYSPACE \ArrayFrLst2)
+        (\PARSEARRAYSPACE1 FN \ARRAYSPACE2 \ArrayFrLst))
+       (T (\PARSEARRAYSPACE1 FN \ARRAYSPACE \ArrayFrLst])
+
+(\PARSEARRAYSPACE1
+  [LAMBDA (FN START END)                                 (* bvm%: " 9-Jan-85 17:10")
+    (for (ROVER _ START) repeatuntil [EQPTR END (SETQ ROVER (\ADDBASE2 ROVER
+                                                                           (fetch (ARRAYBLOCK
+                                                                                       ARLEN)
+                                                                              of ROVER]
+       do (\CHECKARRAYBLOCK ROVER (NOT (fetch (ARRAYBLOCK INUSE) of ROVER))
+                     (AND (NOT (fetch (ARRAYBLOCK INUSE) of ROVER))
+                          (fetch (ARRAYBLOCK FWD) of ROVER)))
+             (AND FN (APPLY* FN ROVER (fetch (ARRAYBLOCK ARLEN) of ROVER)
+                            (fetch (ARRAYBLOCK INUSE) of ROVER)
+                            (fetch (ARRAYBLOCK GCTYPE) of ROVER])
+)
+
+(RPAQ? ARRAYBLOCKCHECKING )
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS ARRAYBLOCKCHECKING)
+)
+
+
+
+(* ; "Basic hunking")
+
+(DEFINEQ
+
+(\ALLOCHUNK
+  [LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN)               (* bvm%: "13-Jun-86 15:21")
+    (COND
+       ([AND ALIGN (OR (IGREATERP ALIGN \MAX.CELLSPERHUNK)
+                       (NOT (FMEMB ALIGN (SELECTC GCTYPE
+                                             (UNBOXEDBLOCK.GCT 
+                                                  (CONSTANT (for X in \HUNK.UNBOXEDSIZES
+                                                               when (AND (IGREATERP X 1)
+                                                                             (ILEQ X 
+                                                                                   \MAX.CELLSPERHUNK)
+                                                                             (POWEROFTWOP X))
+                                                               collect X)))
+                                             (PTRBLOCK.GCT (CONSTANT (for X in \HUNK.PTRSIZES
+                                                                        when (AND (IGREATERP
+                                                                                       X 1)
+                                                                                      (ILEQ X 
+                                                                                    \MAX.CELLSPERHUNK
+                                                                                            )
+                                                                                      (POWEROFTWOP
+                                                                                       X))
+                                                                        collect X)))
+                                             (CODEBLOCK.GCT (CONSTANT (LIST CELLSPERQUAD)))
+                                             NIL]            (* ; 
+                                                "Certify that the alignment request is legitimate.")
+        (ERROR "Oddball alignment request" ALIGN)))
+    (PROG ((TYPENUM.TABLE (SELECTC GCTYPE
+                              (UNBOXEDBLOCK.GCT 
+                                   \UNBOXEDHUNK.TYPENUM.TABLE)
+                              (CODEBLOCK.GCT \CODEHUNK.TYPENUM.TABLE)
+                              (PTRBLOCK.GCT \PTRHUNK.TYPENUM.TABLE)
+                              (SHOULDNT)))
+           (FAILCNT 0)
+           DTNUMBER HUNK HUNKSIZE ONPAGE STRADDLERS)
+      BEG [do (SETQ DTNUMBER (\GETBASEBYTE TYPENUM.TABLE NCELLS))
+                 (SETQ HUNKSIZE (HUNKSIZEFROMNUMBER DTNUMBER))
+             repeatuntil (OR (NOT ALIGN)
+                                 (EQ 0 (IREMAINDER (FOLDLO (fetch DTDSIZE of (\GETDTD 
+                                                                                            DTNUMBER)
+                                                                  )
+                                                          WORDSPERCELL)
+                                              ALIGN))
+                                 (COND
+                                    ((IGREATERP (SETQ NCELLS (ADD1 HUNKSIZE))
+                                            \MAX.CELLSPERHUNK)
+                                     (GO LOSE))
+                                    (T 
+
+                                 (* ;; "We're allowed to chunk up the size of the request in order to meet the alignment;  ultimately we should top off at \MAX.CELLSPERHUNK")
+
+                                       NIL]
+      LP  (SETQ HUNK (CREATECELL DTNUMBER))
+          (COND
+             ([OR (NULL INITONPAGE)
+                  (ILESSP INITONPAGE (SETQ ONPAGE (IDIFFERENCE CELLSPERPAGE (fetch (POINTER
+                                                                                        CELLINPAGE)
+                                                                               of HUNK]
+                                                             (* ; 
+                                                      "Ah, happy case -- all constraints satisfied")
+              (RETURN HUNK)))
+
+     (* ;; "Sigh, gotta try to get one with more of the initial `run' of cells on the same page.")
+
+          (COND
+             (\IN.MAKEINIT                                   (* ; "Lose!  Only code has an INITONPAGE requirement, and makeinit does not allocate code via \ALLOCBLOCK")
+                    (HELP "Call to \ALLOCBLOCK with non-NIL INITONPAGE demand" INITONPAGE))
+             (T (COND
+                   ([AND (EQ GCTYPE CODEBLOCK.GCT)
+                         (ILEQ (IQUOTIENT (ITIMES 10 ONPAGE)
+                                      HUNKSIZE)
+                               (COND
+                                  ((ILEQ HUNKSIZE 24)
+                                   60)
+                                  ((ILEQ HUNKSIZE 50)
+                                   50)
+                                  (T 30]
+
+                    (* ;; "If the percentage of the page-straddling codehunk that is on the first page is too small, then just toss this loser into the `black hole' This heuristic is based on empirical data taken about Sep 1984 which observed the ratio of `on-page' requirements to code length.")
+
+                    (\ADDREF HUNK))
+                   (T                                        (* ; 
+                          "So that a GC doesn't sneak in and put it back on the freelist too soon.")
+                      (push STRADDLERS HUNK)))
+                (COND
+                   ((IGREATERP (add FAILCNT 1)
+                           16)                               (* ; 
+                       "Put a limit to this nonsense of trying to find a non-page-straddling hunk!")
+                    (GO LOSE))
+                   ((EQ FAILCNT 8)                           (* ; 
+                  "After too many failures with this size of hunk, try the next container size up.")
+                    (SETQ NCELLS (ADD1 HUNKSIZE))
+                    (AND STRADDLERS (SETQ \HUNKREJECTS (NCONC STRADDLERS \HUNKREJECTS)))
+                    (GO BEG)))
+                (GO LP)))
+      LOSE
+          (AND STRADDLERS (SETQ \HUNKREJECTS (NCONC STRADDLERS \HUNKREJECTS)))
+          (RETURN])
+)
+
+(RPAQQ \HUNK.PTRSIZES (2 4 5 6 7 8 10 12 16 24 32 42 64))
+
+
+
+(* ; "Compiler needs \HUNK.PTRSIZES for creating closure environments")
+
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX)
+                                    (FOLDLO (fetch DTDSIZE of (\GETDTD NTYPX))
+                                           WORDSPERCELL)))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \HUNK.UNBOXEDSIZES 
+       (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64))
+
+(RPAQQ \HUNK.CODESIZES (12 16 20 24 28 32 36 42 50 64))
+
+(RPAQQ \HUNK.PTRSIZES (2 4 5 6 7 8 10 12 16 24 32 42 64))
+
+
+(CONSTANTS \HUNK.UNBOXEDSIZES \HUNK.CODESIZES \HUNK.PTRSIZES)
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \HUNKING? \UNBOXEDHUNK.TYPENUM.TABLE \CODEHUNK.TYPENUM.TABLE \PTRHUNK.TYPENUM.TABLE)
+)
+)
+
+
+
+(* ;; 
+"Keep a list of all the hunks rejected due to poor page-straddling alignment, or to code falling off the end of a doublepage"
+)
+
+
+(RPAQQ \HUNKREJECTS NIL)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \HUNKREJECTS)
+)
+
+
+
+(* ; "for MAKEINIT")
+
+(DEFINEQ
+
+(PREINITARRAYS
+  [LAMBDA NIL                                            (* bvm%: " 9-Jan-85 16:50")
+
+    (* ;; "This is called only at the very beginning of MAKEINIT.  \ARRAYspace and \ARRAYbase are INITCONSTANTS.  This sets up the array allocator so that MAKEINIT can do, e.g., string allocations.")
+
+    (DECLARE (GLOBALVARS \ArrayFrLst \ArrayFrLst2 \NxtArrayPage))
+    (SETQ.NOREF \ArrayFrLst (\VAG2 \FirstArraySegment 0))
+    (SETQ.NOREF \ArrayFrLst2 \ARRAYSPACE2)
+    (SETQ.NOREF \NxtArrayPage (PAGELOC \ArrayFrLst])
+
+(POSTINITARRAYS
+  [LAMBDA (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE)      (* bvm%: " 7-Feb-85 15:30")
+
+    (* ;; "Called only from MAKEINIT after all code and data has been copied to the new image.  AFTERCODEPTR is a pointer to the first word after the last code byte.  CODESTARTPAGE is the page at which MAKEINIT code arrays being.  This function makes sure that any unused space between the strings and the beginning of the code gets linked in as free arrayblocks.")
+
+    (SETQ \FREEBLOCKBUCKETS (\ALLOCBLOCK (ADD1 \MAXBUCKETINDEX)))
+    (PROG [(EXTRACELLS (IDIFFERENCE (UNFOLD CODESTARTPAGE CELLSPERPAGE)
+                              (IPLUS (UNFOLD (fetch SEGMENT# of \ArrayFrLst)
+                                            CELLSPERSEGMENT)
+                                     (fetch CELLINSEGMENT of \ArrayFrLst]
+
+     (* ;; "First, tell the makeiniter how many pages were left over in the string space.  He may want to adjust the constants to keep this down to just a couple of pages.")
+
+          (COND
+             ((IGREATERP EXTRACELLS \MaxArrayBlockSize)
+              (printout T T T "POSTINITARRAYS:  You pre-allocated too much string space." T 19 
+                     "MKI.CODESTARTOFFSET on MAKEINIT should be reduced by about "
+                     (IDIFFERENCE (FOLDLO EXTRACELLS CELLSPERPAGE)
+                            10)
+                     "." T)
+              (HELP))
+             ((IGEQ EXTRACELLS \MinArrayBlockSize)           (* ; 
+                                                  "We don't allow more than one array-block extra.")
+              (printout T T T "POSTINITARRAYS:  There were " (FOLDLO EXTRACELLS CELLSPERPAGE)
+                     " allocated but unused array pages." T T))
+             (T (printout T T "POSTINITARRAYS:  String space overflowed into code-arrays" T 19 
+                       "You should add at least " (ADD1 (FOLDLO (IMINUS EXTRACELLS)
+                                                               CELLSPERPAGE))
+                       " to MKI.CODESTARTOFFSET on MAKEINIT." T)
+                (HELP)))                                     (* ; 
+                                                           "Cause those pages to get allocated")
+          (\LINKBLOCK (\ALLOCBLOCK.NEW EXTRACELLS))
+          (SETQ.NOREF \ArrayFrLst AFTERCODEPTR)              (* ; 
+                                         "\NxtArrayPage is the next page that needs to be NEWPAGEd")
+          (SETQ.NOREF \NxtArrayPage CODENEXTPAGE)
+          (for VP from (PAGELOC \ARRAYSPACE) to (PAGELOC \NxtArrayPage)
+             by (FOLDLO \MDSIncrement WORDSPERPAGE) do (\MAKEMDSENTRY VP 0])
+
+(FILEARRAYBASE
+  [LAMBDA NIL                                            (* rmk%: "15-MAR-82 21:55")
+    (\ADDBASE \ARRAYSPACE (LOCAL (IPLUS (UNFOLD MKI.CODESTARTOFFSET WORDSPERPAGE)
+                                        (FOLDLO (IDIFFERENCE (GETFILEPTR (OUTPUT))
+                                                       MKI.FirstDataByte)
+                                               BYTESPERWORD])
+
+(FILEBLOCKTRAILER
+  [LAMBDA (BLOCKINFO)                                    (* rmk%: "18-NOV-82 09:49")
+
+    (* ;; 
+  "Sets up block trailer, assuming file is currently positioned just past the last dataword")
+
+    (BOUT16 OUTX \UsedArrayFlagWord)
+    (BOUT16 OUTX BLOCKINFO])
+
+(FILECODEBLOCK
+  [LAMBDA (NCELLS INITONPAGE)                            (* JonL "20-Sep-84 13:29")
+
+    (* ;; "sort of like CODEARRAY at MAKEINIT time for allocating space on the file;  this code borrowed from CODEARRAY and \ALLOCBLOCK.  Returns ARLEN, which is then passed to FILEBLOCKTRAILER to set trailer length.")
+
+    (PROG (PREFIXLEN (ARLEN (IPLUS NCELLS \ArrayBlockOverheadCells)))
+
+     (* ;; "ARLEN is the number of cells in the array .  INITONPAGE is number of cells which must reside on same page")
+
+          (COND
+             ([NEQ 0 (SETQ PREFIXLEN (\PREFIXALIGNMENT? ARLEN INITONPAGE CELLSPERQUAD 
+                                            CODEBLOCK.GCT (FILEARRAYBASE]
+
+              (* ;; "Check page first, cause if we did segment first and succeeded but then failed on page, we would have to check segment again.")
+
+              (FILEPATCHBLOCK PREFIXLEN)))
+          (BOUT16 OUTX \CodeArrayFlagWord)
+          (BOUT16 OUTX ARLEN)
+          (RETURN ARLEN])
+
+(FILEPATCHBLOCK
+  [LAMBDA (ARLEN)                                        (* rmk%: "18-NOV-82 09:50")
+
+    (* ;; "like \PATCHBLOCK for array allocation on files at MAKEINIT time")
+
+    (LOCAL (BOUT16 OUTX \FreeArrayFlagWord))                 (* ; "in-use bit off, password set")
+    (LOCAL (BOUT16 OUTX ARLEN))                              (* ; "number of cells in this block")
+    [COND
+       ((IGREATERP ARLEN \ArrayBlockHeaderCells)             (* ; 
+  "Assumes that header and trailer look alike, so that we only need one instance for a tiny block.")
+        (LOCAL (BOUTZEROS (UNFOLD (IDIFFERENCE ARLEN \ArrayBlockOverheadCells)
+                                 BYTESPERCELL)))             (* ; "zeros for data words")
+        (LOCAL (BOUT16 OUTX \FreeArrayFlagWord))             (* ; "Set up trailer")
+        (LOCAL (BOUT16 OUTX ARLEN]
+    NIL])
+)
+
+
+
+(* ; "Hunk Initialization")
+
+(DEFINEQ
+
+(\SETUP.HUNK.TYPENUMBERS
+  [LAMBDA NIL                                            (* ; "Edited  4-Mar-87 11:04 by bvm:")
+
+(* ;;; "Called before datatype table is initialized.  We add to the list of initial datatypes (\built-in-system-types) entries for all the hunk types we will want.")
+
+(* ;;; "Note: the compiler knows about the pointer hunk names, so it is important to coordinate any future changes to \HUNK.PTRSIZES with the compiler.")
+
+    (SETQ INITIALDTDCONTENTS (APPEND \BUILT-IN-SYSTEM-TYPES (\COMPUTE.HUNK.TYPEDECLS 
+                                                                   \HUNK.PTRSIZES PTRBLOCK.GCT
+                                                                   '\PTRHUNK)
+                                    (\COMPUTE.HUNK.TYPEDECLS \HUNK.UNBOXEDSIZES UNBOXEDBLOCK.GCT
+                                           '\UNBOXEDHUNK)
+                                    (\COMPUTE.HUNK.TYPEDECLS \HUNK.CODESIZES CODEBLOCK.GCT
+                                           '\CODEHUNK])
+
+(\COMPUTE.HUNK.TYPEDECLS
+  [LAMBDA (SIZELST GCTYPE PREFIX)                        (* ; "Edited  4-Mar-87 11:03 by bvm:")
+
+    (* ;; "Add type entries to INITIALDTDCONTENTS for the hunks in SIZELST of type GCTYPE.  PREFIX is the start of the name, e.g., \PTRHUNK.  Entries are of the form (name size ptrs finalization)")
+
+    (ALLOCAL (for HUNKSIZE in SIZELST BIND (FINAL _ (AND (EQ GCTYPE CODEBLOCK.GCT)
+                                                                     '\RECLAIMCODEBLOCK))
+                until (> HUNKSIZE \MAX.CELLSPERHUNK)
+                collect (LIST (PACK* PREFIX HUNKSIZE)
+                                  (UNFOLD HUNKSIZE WORDSPERCELL)
+                                  (COND
+                                     ((EQ GCTYPE PTRBLOCK.GCT)
+                                                             (* ; 
+                              "Compute DTDPTRS list, i.e., which fields are pointers (all of them)")
+                                      (for I from 0 by 2
+                                         to (SUB1 (UNFOLD HUNKSIZE WORDSPERCELL)) collect
+                                                                                      I)))
+                                  FINAL])
+
+(\TURN.ON.HUNKING
+  [LAMBDA NIL                                            (* bvm%: "13-Jun-86 17:27")
+
+(* ;;; "create all the datatypes, and the tables used to calculate a hunk datatype number from the allocation size request.")
+
+    (SETQ \UNBOXEDHUNK.TYPENUM.TABLE (\SETUP.TYPENUM.TABLE \HUNK.UNBOXEDSIZES UNBOXEDBLOCK.GCT
+                                            '\UNBOXEDHUNK))
+    (SETQ \CODEHUNK.TYPENUM.TABLE (\SETUP.TYPENUM.TABLE \HUNK.CODESIZES CODEBLOCK.GCT
+                                         '\CODEHUNK))
+    (SETQ \PTRHUNK.TYPENUM.TABLE (\SETUP.TYPENUM.TABLE \HUNK.PTRSIZES PTRBLOCK.GCT '\PTRHUNK))
+    (SETQ \HUNKING? T])
+
+(\SETUP.TYPENUM.TABLE
+  [LAMBDA (SIZELST GCTYPE PREFIX)                        (* ; "Edited  5-Mar-87 10:12 by bvm:")
+
+(* ;;; "Create a table that maps from number of cells desired to the closest hunk size that fits for a given GCTYPE.  SIZELST is  list of sizes in cells.  PREFIX is the datatype name prefix for this kind of hunk.")
+
+    (for I from 0 to \MAX.CELLSPERHUNK bind (HUNKSIZE _ -1)
+                                                         (SIZEL _ SIZELST)
+                                                         (TABLE _ (\ALLOCBLOCK
+                                                                   (FOLDHI (IPLUS 4 \MAX.CELLSPERHUNK
+                                                                                  )
+                                                                          BYTESPERCELL)
+                                                                   UNBOXEDBLOCK.GCT))
+                                                         TNAME DTD DTNUMBER
+       do [COND
+                 ((IGREATERP I HUNKSIZE)                     (* ; 
+                                                     "Advance to next quantum range in the SIZELST")
+                  (SETQ HUNKSIZE (OR (FIXP (pop SIZEL))
+                                     \MAX.CELLSPERHUNK))
+                  (SETQ TNAME (PACK* PREFIX HUNKSIZE))
+                  (COND
+                     ((for old DTNUMBER from 1 as TYPE in (LOCAL 
+                                                                                   INITIALDTDCONTENTS
+                                                                                     )
+                         when (EQ (LOCAL (CAR TYPE))
+                                      TNAME) do 
+
+                                 (* ;; "Find the type number that has been assigned to this hunk type.  Ordinarily would use \TYPENUMBERFROMNAME, but atoms haven't been initialized yet, so we can only talk locally")
+
+                                                   (RETURN DTNUMBER))
+                      (SETQ DTD (\GETDTD DTNUMBER))
+                      (replace DTDGCTYPE of DTD with GCTYPE)
+                      (replace DTDHUNKP of DTD with T))
+                     (T (HELP "No type declaration for" TNAME]
+             (\PUTBASEBYTE TABLE I DTNUMBER) finally (RETURN TABLE])
+)
+(DECLARE%: DONTCOPY 
+
+(ADDTOVAR INITVALUES (\NxtArrayPage)
+                         (\HUNKING?))
+
+(ADDTOVAR INITPTRS (\FREEBLOCKBUCKETS)
+                       (\ArrayFrLst)
+                       (\ArrayFrLst2)
+                       (\UNBOXEDHUNK.TYPENUM.TABLE)
+                       (\CODEHUNK.TYPENUM.TABLE)
+                       (\PTRHUNK.TYPENUM.TABLE))
+
+(ADDTOVAR INEWCOMS (FNS \#BLOCKDATACELLS \PREFIXALIGNMENT? \ALLOCBLOCK \MAIKO.ALLOCBLOCK 
+                            \ALLOCBLOCK.NEW \MAKEFREEARRAYBLOCK \MERGEBACKWARD \LINKBLOCK \ALLOCHUNK)
+                       (FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK
+                            FILEPATCHBLOCK)
+                       (FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING 
+                            \SETUP.TYPENUM.TABLE))
+
+(ADDTOVAR MKI.SUBFNS (\IN.MAKEINIT . T)
+                         (\ALLOCBLOCK.OLD . NILL)
+                         (\MERGEFORWARD . NILL)
+                         (\FIXCODENUM . I.FIXUPNUM)
+                         (\FIXCODESYM . I.FIXUPSYM)
+                         (\FIXCODEPTR . I.FIXUPPTR)
+                         (\CHECKARRAYBLOCK . NILL)
+                         (\ARRAYMERGING PROGN NIL))
+
+(ADDTOVAR EXPANDMACROFNS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER BUCKETINDEX FREEBLOCKCHAIN.N)
+
+(ADDTOVAR RDCOMS (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE \PARSEARRAYSPACE1))
+
+(ADDTOVAR RD.SUBFNS (EQPTR . EQUAL)
+                        (ARRAYBLOCKCHECKING . T))
+
+(ADDTOVAR RDPTRS (\FREEBLOCKBUCKETS))
+
+(ADDTOVAR RDVALS (\ArrayFrLst)
+                     (\ArrayFrLst2))
+EVAL@COMPILE 
+
+(ADDTOVAR DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER 
+                                   FILECODEBLOCK FILEPATCHBLOCK)
+
+(ADDTOVAR DONTCOMPILEFNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING 
+                                   \SETUP.TYPENUM.TABLE)
+)
+
+
+
+(* ; "Debugging aids")
+
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \ArrayFrLst)
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \ArrayBlockPassword 5461)
+
+
+(CONSTANTS \ArrayBlockPassword)
+)
+
+
+(ADDTOVAR DONTCOMPILEFNS \HUNKFIT? \AB.NEXT \AB.BACK)
+)
+(DEFINEQ
+
+(\HUNKFIT?
+  [LAMBDA (N)                                            (* JonL "15-Jan-85 00:48")
+
+    (* ;; "Show how an MDS unit of 2 pages would accomodate chunks of size N cells.")
+
+    (printout NIL T "Hunk size = " N " cells,  " (IQUOTIENT (FOLDLO \MDSIncrement WORDSPERCELL)
+                                                        N)
+           " fit in a MDS unit with "
+           (IREMAINDER (FOLDLO \MDSIncrement WORDSPERCELL)
+                  N)
+           " cells left over." T .TAB 8 "('unit' is split with " (IREMAINDER CELLSPERPAGE N)
+           " cells kept on first page)" T)
+    T])
+
+(\AB.NEXT
+  [LAMBDA (ABHI ABLO)                                    (* JonL "10-Sep-84 05:04")
+
+    (* ;; "ABHI and ABLO form the \HILOC and \LOLOC of some arrayblock which we want to 'go' to the predecessor of;  alternatively, ABHI can be a list of these two address parts, or just a random arrayblock address.")
+
+    (* ;; "Returns a 4-list;  size of the next block, whether or not it is free, and the \HILOC and the \LOLOC of that block")
+
+    [COND
+       [(AND (LISTP ABHI)
+             (NULL ABLO))
+        [COND
+           ((AND (EQ 4 (LENGTH ABHI))
+                 (FIXP (CAR ABHI))
+                 (SELECTQ (CADR ABHI)
+                     ((INUSE FREE) 
+                          T)
+                     NIL))                                   (* ; 
+                                                           "Result is output of \AB.NEXT itself")
+            (SETQ ABHI (CDDR ABHI]
+        (COND
+           ((EQ 2 (LENGTH ABHI))                             (* ; "A 2-list of \HILOC and \LOLOC")
+            (SETQ ABLO (CADR ABHI))
+            (SETQ ABHI (CAR ABHI]
+       ((OR (EQ ABHI \ArrayFrLst)
+            (type? ARRAYBLOCK ABHI))
+        (SETQ ABLO (\LOLOC ABHI))
+        (SETQ ABHI (\HILOC ABHI]
+    (OR (IGEQ ABHI 0)
+        (ERROR "Negative segment number?" ABHI))
+    (AND (IGREATERP ABHI (\HILOC \ArrayFrLst))
+         (ERROR "Segment number too high?" ABHI))
+    (OR (IGEQ ABLO 0)
+        (ERROR "Negative offset number?" ABLO))
+    (PROG (PW SIZE SIZE.WORDS (ABADDR (\VAG2 ABHI ABLO)))
+          [PROGN                                             (* ; "Checking on current block")
+                 (SETQ PW (\GETBASE ABADDR 0))
+                 [COND
+                    ((NEQ \ArrayBlockPassword (LOADBYTE PW 3 13))
+                     (SETQ ABADDR)
+                     (ERROR "Array Password not found at this loc" (LIST ABHI ABLO]
+                 (SETQ SIZE.WORDS (UNFOLD (SETQ SIZE (\GETBASE ABADDR 1))
+                                         WORDSPERCELL))
+                 (COND
+                    [(NEQ \ArrayBlockPassword (LOADBYTE (\GETBASE ABADDR (IDIFFERENCE SIZE.WORDS 2))
+                                                     3 13))
+                     (ERROR "Array Password not found just below this" (PROG1 (LIST ABHI ABLO)
+                                                                              (SETQ ABADDR]
+                    ((NEQ SIZE (\GETBASE ABADDR (IDIFFERENCE SIZE.WORDS 1)))
+                     (ERROR "Header and Trailer lengths disagree" (PROG1 (LIST ABHI ABLO)
+                                                                         (SETQ ABADDR]
+          (SETQ ABADDR (\ADDBASE ABADDR SIZE.WORDS))
+          (SETQ PW (\GETBASE ABADDR 0))
+          [COND
+             ((NEQ \ArrayBlockPassword (LOADBYTE PW 3 13))
+              (SETQ ABADDR)
+              (ERROR "Array Password not found at this loc" (LIST ABHI ABLO]
+          (RETURN (LIST (\GETBASE ABADDR 1)
+                        (COND
+                           ((ODDP PW)
+                            'INUSE)
+                           (T 'FREE))
+                        (\HILOC ABADDR)
+                        (\LOLOC ABADDR])
+
+(\AB.BACK
+  [LAMBDA (ABHI ABLO)                                    (* JonL " 9-Sep-84 16:28")
+
+    (* ;; "ABHI and ABLO form the \HILOC and \LOLOC of some arrayblock which we want to 'go' to the predecessor of;  alternatively, ABHI can be a list of these two address parts, or just a random arrayblock address.")
+
+    (* ;; "Returns a 4-list;  size of the block we are starting from, whether or not it is free, and the \HILOC and the \LOLOC of the predecessor block")
+
+    [COND
+       [(AND (LISTP ABHI)
+             (NULL ABLO))
+        [COND
+           ((AND (EQ 4 (LENGTH ABHI))
+                 (FIXP (CAR ABHI))
+                 (SELECTQ (CADR ABHI)
+                     ((INUSE FREE) 
+                          T)
+                     NIL))                                   (* ; 
+                                                           "Result is output of \AB.BACK itself")
+            (SETQ ABHI (CDDR ABHI]
+        (COND
+           ((EQ 2 (LENGTH ABHI))                             (* ; "A 2-list of \HILOC and \LOLOC")
+            (SETQ ABLO (CADR ABHI))
+            (SETQ ABHI (CAR ABHI]
+       ((OR (EQ ABHI \ArrayFrLst)
+            (type? ARRAYBLOCK ABHI))
+        (SETQ ABLO (\LOLOC ABHI))
+        (SETQ ABHI (\HILOC ABHI]
+    (OR (IGEQ ABHI 0)
+        (ERROR "Negative segment number?" ABHI))
+    (AND (IGREATERP ABHI (\HILOC \ArrayFrLst))
+         (ERROR "Segment number too high?" ABHI))
+    (OR (IGEQ ABLO 0)
+        (ERROR "Negative offset number?" ABLO))
+    (PROG (PW SIZE (ABADDR (\ADDBASE (\VAG2 ABHI ABLO)
+                                  -2)))
+          (SETQ PW (\GETBASE ABADDR 0))
+          [COND
+             ((NEQ \ArrayBlockPassword (LOADBYTE PW 3 13))
+              (SETQ ABADDR)
+              (ERROR "Array Password not found just below this" (LIST ABHI ABLO]
+          (SETQ SIZE (\GETBASE ABADDR 1))
+          [SETQ ABADDR (\ADDBASE ABADDR (IMINUS (UNFOLD (SUB1 SIZE)
+                                                       WORDSPERCELL]
+          [COND
+             [(NEQ \ArrayBlockPassword (LOADBYTE (\GETBASE ABADDR 0)
+                                              3 13))
+              (ERROR "Array Password not found just below this" (PROG1 (LIST ABHI ABLO)
+                                                                       (SETQ ABADDR]
+             ((NEQ SIZE (\GETBASE ABADDR 1))
+              (ERROR "Header and Trailer lengths disagree" (PROG1 (LIST ABHI ABLO)
+                                                                  (SETQ ABADDR]
+          (RETURN (LIST SIZE (COND
+                                ((ODDP PW)
+                                 'INUSE)
+                                (T 'FREE))
+                        (\HILOC ABADDR)
+                        (\LOLOC ABADDR])
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA LISP::PUTHASH HARRAYPROP)
+)
+(PUTPROPS LLARRAYELT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1989 
+1990 1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (9331 21709 (AIN 9341 . 11614) (AOUT 11616 . 14218) (ARRAY 14220 . 19805) (ARRAYSIZE 
+19807 . 19947) (ARRAYTYP 19949 . 20545) (ARRAYORIG 20547 . 20714) (COPYARRAY 20716 . 21707)) (21875 
+29520 (ELT 21885 . 23314) (ELTD 23316 . 24241) (SETA 24243 . 26500) (SETD 26502 . 27496) (SUBARRAY 
+27498 . 29518)) (29555 55164 (HARRAY 29565 . 29785) (HASHARRAY 29787 . 33810) (HARRAYP 33812 . 33961) 
+(HARRAYPROP 33963 . 37998) (HARRAYSIZE 38000 . 38165) (CLRHASH 38167 . 39539) (MAPHASH 39541 . 40670) 
+(GETHASH 40672 . 44252) (PUTHASH 44254 . 44485) (LISP::PUTHASH 44487 . 45199) (REMHASH 45201 . 45346) (
+\HASHRECLAIM 45348 . 47131) (\HASHACCESS 47133 . 52895) (REHASH 52897 . 53621) (\COPYHARRAYP 53623 . 
+54353) (\HASHTABLE.DEFPRINT 54355 . 55162)) (55165 55721 (STRINGHASHBITS 55175 . 55332) (
+STRING-EQUAL-HASHBITS 55334 . 55719)) (55722 57784 (\STRINGHASHBITS-UFN 55732 . 56838) (
+\STRING-EQUAL-HASHBITS-UFN 56840 . 57782)) (62071 67166 (\CODEARRAY 62081 . 62911) (\FIXCODENUM 62913
+ . 63578) (\FIXCODEPTR 63580 . 64640) (\FIXCODESYM 64642 . 67164)) (78407 113562 (\ALLOCBLOCK 78417 . 
+82416) (\MAIKO.ALLOCBLOCK 82418 . 86610) (\ALLOCBLOCK.OLD 86612 . 91483) (\ALLOCBLOCK.NEW 91485 . 
+94410) (\PREFIXALIGNMENT? 94412 . 97955) (\MAKEFREEARRAYBLOCK 97957 . 98552) (\DELETEBLOCK? 98554 . 
+99659) (\LINKBLOCK 99661 . 101787) (\MERGEBACKWARD 101789 . 103150) (\MERGEFORWARD 103152 . 104249) (
+\ARRAYBLOCKMERGER 104251 . 106436) (\#BLOCKDATACELLS 106438 . 107674) (\COPYARRAYBLOCK 107676 . 109244
+) (\RECLAIMARRAYBLOCK 109246 . 111375) (\ADVANCE.ARRAY.SEGMENTS 111377 . 113560)) (113624 116057 (
+\BYTELT 113634 . 114433) (\BYTESETA 114435 . 115376) (\WORDELT 115378 . 116055)) (116058 116392 (
+\ARRAYTYPENAME 116068 . 116390)) (116515 120209 (\SHOW.ARRAY.FREELISTS 116525 . 120207)) (120522 
+126272 (\CHECKARRAYBLOCK 120532 . 124907) (\PARSEARRAYSPACE 124909 . 125318) (\PARSEARRAYSPACE1 125320
+ . 126270)) (126406 132672 (\ALLOCHUNK 126416 . 132670)) (133850 139746 (PREINITARRAYS 133860 . 134401
+) (POSTINITARRAYS 134403 . 137121) (FILEARRAYBASE 137123 . 137535) (FILEBLOCKTRAILER 137537 . 137832) 
+(FILECODEBLOCK 137834 . 138850) (FILEPATCHBLOCK 138852 . 139744)) (139783 145207 (
+\SETUP.HUNK.TYPENUMBERS 139793 . 140829) (\COMPUTE.HUNK.TYPEDECLS 140831 . 142111) (\TURN.ON.HUNKING 
+142113 . 142785) (\SETUP.TYPENUM.TABLE 142787 . 145205)) (147470 154071 (\HUNKFIT? 147480 . 148095) (
+\AB.NEXT 148097 . 151292) (\AB.BACK 151294 . 154069)))))
+STOP
diff --git a/CLTL2/LLBASIC b/CLTL2/LLBASIC
new file mode 100644
index 00000000..66ad0806
--- /dev/null
+++ b/CLTL2/LLBASIC
@@ -0,0 +1,2320 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "12-Oct-93 14:29:06" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLBASIC.;2" 128788 
+
+      changes to%:  (OPTIMIZERS \ATOMCELL GETPROPLIST SETPROPLIST)
+                    (VARS LLBASICCOMS)
+                    (FUNCTIONS ATOM)
+                    (FNS COPYATOM)
+
+      previous date%: " 5-Aug-93 10:20:24" "{Pele:mv:envos}<LispCore>Sources>LLBASIC.;35")
+
+
+(* ; "
+Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT LLBASICCOMS)
+
+(RPAQQ LLBASICCOMS
+       ((FNS LISTP LITATOM FIXP SMALLP NLISTP ARRAYP FLOATP NUMBERP STACKP)
+        (FUNCTIONS ATOM)
+        (DECLARE%: DONTCOPY (EXPORT (MACROS CHECK \StatsZero \StatsAdd1 IPLUS16 SMALLPOSP SETXVAR 
+                                           SETQ.NOREF IEQ)
+                                   (CONSTANTS WordsPerPage))
+               (TEMPLATES SPREADAPPLY* SPREADAPPLY SETQ.NOREF))
+        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS FREELISTENTRY HASHENTRY))
+        [COMS                                                (* ; "atoms")
+              (FNS GETTOPVAL SETTOPVAL FSETVAL \SETGLOBALVAL.UFN \SETFVAR.UFN GETPROPLIST \ATOMCELL 
+                   SETPROPLIST)
+              (COMS (MACROS \PROPCELL)
+                    (OPTIMIZERS \ATOMCELL GETPROPLIST SETPROPLIST))
+              (FNS \MKATOM \CREATE.SYMBOL \MKATOM.FULL \INITATOMPAGE)
+              (FNS MAPATOMS ATOMHASH#PROBES)
+              (COMS                                          (* ; "For MAKEINIT & TeleRaid")
+                    
+                    (* ;; "This code has one major shortcoming which will not normally turn up.  If the local and remote sysouts conflict in their package setups it is possible for this code to return symbols interned in what for the teleraid'ing machine would be the correct package, but for the remote machine is in fact incorrect.  This warrents a warning in the documentation.  The problem lies in the fact that you *cannot* uncopy a symbol correctly between two machines with incompatible package setups.  An example of such a situation would be where on one machine the package FOO inherits BAR, and on the other BAR is present directly in FOO.  BAR's package cell will be different in both cases.  Two solutions come to mind; both would break the VSAVEWORK feature.  The first would be to UNCOPY symbols into special %"remote symbol%" objects.  The second is to create uninterned symbols with the correct name and smash their package cell to be that of a correctly named package.  Both of these schemes would require special reading and printing code.")
+
+                    (MACROS READSYS.HAS.PACKAGES)
+                    (VARS READSYS.PACKAGE.FROM.NAME READSYS.PACKAGE.FROM.INDEX)
+                    (FNS INITATOMS COPYATOM UNCOPYATOM MAKE.LOCAL.ATOM SYMBOL.VALUE SYMBOL.PNAME 
+                         SYMBOL.PACKAGE OLD.FIND.SYMBOL LOOKUP-SYMBOL FIND.PACKAGE FIND.SYMBOL 
+                         PACKAGE.NAME))
+              (COMS                                          (* ; "See \PNAMELIMIT comment below")
+                    (VARS (\PNAMELIMIT 255))
+                    (INITVARS (\PNAMES.IN.BLOCKS?)))
+              (COMS 
+                    (* ;; "Flag for the closure cache")
+
+                    (INITVARS (SI::*CLOSURE-CACHE-ENABLED*))
+                    (GLOBALVARS SI::*CLOSURE-CACHE-ENABLED*))
+              (FNS \DEFINEDP PUTD \PUTD GETD PUTDEFN GETDEFN)
+              (FNS \STKMIN)
+              (INITVARS (\OPSTACKEFFECT)
+                     (\OPLENGTH))
+              (GLOBALVARS \OPSTACKEFFECT \OPLENGTH)
+              (VARS (COMPILEATPUTDFLG))
+              (DECLARE%: DONTCOPY (EXPORT (RECORDS LITATOM CL:SYMBOL VALINDEX VCELL DEFINITIONCELL 
+                                                 FNHEADER PNAMECELL PACKAGEINDEX PNAMEBASE PNAMEINDEX
+                                                 )
+                                         (RECORDS NEW-ATOM)
+                                         (MACROS \DEFCELL \VALCELL \PNAMECELL)
+                                         (MACROS \ATOMVALINDEX \ATOMDEFINDEX \ATOMPNAMEINDEX 
+                                                \ATOMPROPINDEX \INDEXATOMPNAME \INDEXATOMVAL 
+                                                \INDEXATOMDEF \ATOMNUMBER)
+                                         (GLOBALVARS \NxtPnByte \CurPnPage \NxtAtomPage \AtomFrLst 
+                                                \OneCharAtomBase \PNAMES.IN.BLOCKS? \SCRATCHSTRING 
+                                                COMPILEATPUTDFLG)
+                                         (CONSTANTS (\PNAMELIMIT 255)
+                                                (\CharsPerPnPage 512))
+                                         (CONSTANTS (\NEWATOM-PNAMEOFFSET 0)
+                                                (\NEWATOM-VALOFFSET 2)
+                                                (\NEWATOM-DEFOFFSET 4)
+                                                (\NEWATOM-PLISTOFFSET 6)
+                                                (\NEWATOM-TYPE# 21))
+                                         
+
+                                 (* ;; "\PNAMELIMIT is exported but needs to also be a VARS on this file to get it copied.  Note that both commands must be edited together.  ")
+
+                                         
+                                         (* ;; 
+                                 "\NEWATOM-xxxxOFFSET is word offset in NEWATOM .  -- '90/07/19 ON")
+))
+              (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS COMPUTE.ATOM.HASH ATOM.HASH.REPROBE)
+                     (ADDVARS (DONTCOMPILEFNS INITATOMS COPYATOM UNCOPYATOM READATOM MAKE.LOCAL.ATOM
+                                     SYMBOL.VALUE SYMBOL.PNAME SYMBOL.PACKAGE OLD.FIND.SYMBOL 
+                                     LOOKUP-SYMBOL FIND.PACKAGE FIND.SYMBOL PACKAGE.NAME GETDEFN 
+                                     PUTDEFN FSETVAL]
+        (COMS                                                (* ; 
+                                                    "for executing boot expressions when first run")
+              (FNS \RESETSYSTEMSTATE INITIALEVALQT SIMPLEPRINT)
+              (GLOBALVARS RESETFORMS BOOTFILES))
+        (COMS                                                (* ; "stats")
+              (FNS PAGEFAULTS \SETTOTALTIME \SERIALNUMBER))
+        (COMS                                                (* ; 
+                                                   "Fast functions for moving and clearing storage")
+              (FNS \BLT \MOVEBYTES \CLEARWORDS \CLEARBYTES \CLEARCELLS)
+              (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS .CLEARNWORDS.))
+              (COMS                                          (* ; "Obsolete")
+                    (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS \MOVEWORDS)))
+                    (FNS \MOVEWORDS \ZEROBYTES \ZEROWORDS)))
+        (LOCALVARS . T)
+        [DECLARE%: DONTCOPY                                  (* ; "For MAKEINIT & TeleRaid")
+               (ADDVARS (INITVALUES (\AtomFrLst 0))
+                      (INITPTRS (\OneCharAtomBase NIL)
+                             (\SCRATCHSTRING))
+                      (INEWCOMS (FNS FSETVAL SETPROPLIST PUTDEFN \BLT)
+                             (FNS \MKATOM \CREATE.SYMBOL \INITATOMPAGE \MOVEBYTES \STKMIN)
+                             (FNS COPYATOM INITATOMS))
+                      (EXPANDMACROFNS SMALLPOSP COMPUTE.ATOM.HASH ATOM.HASH.REPROBE \DEFCELL \VALCELL
+                             \PNAMECELL \PROPCELL \INDEXATOMPNAME)
+                      (MKI.SUBFNS (\PARSE.NUMBER . NILL)
+                             (\MKATOM.FULL . NILL)
+                             (\ATOMDEFINDEX . I.ATOMNUMBER)
+                             (\ATOMVALINDEX . I.ATOMNUMBER)
+                             (\ATOMPROPINDEX . I.ATOMNUMBER)
+                             (\ATOMPNAMEINDEX . I.ATOMNUMBER)
+                             (\ATOMCELL . I.\ATOMCELL)
+                             (\GETBASEFIXP . I.GETBASEFIXP)
+                             (\PUTBASEFIXP . I.PUTBASEFIXP)
+                             (SETQ.NOREF . SETQ)
+                             (SETTOPVAL . I.FSETVAL))
+                      (RD.SUBFNS (\PARSE.NUMBER . NILL)
+                             (\ATOMDEFINDEX . VATOMNUMBER)
+                             (\ATOMPROPINDEX . VATOMNUMBER)
+                             (\ATOMVALINDEX . VATOMNUMBER)
+                             (SETQ.NOREF . SETQ)
+                             (\INDEXATOMPNAME . VATOM)
+                             (\INDEXATOMVAL . VATOM)
+                             (\INDEXATOMDEF . VATOM)
+                             (\ATOMNUMBER . VATOMNUMBER)
+                             (\CREATE.SYMBOL . VNOSUCHATOM))
+                      (RDCOMS (FNS UNCOPYATOM MAKE.LOCAL.ATOM SYMBOL.VALUE SYMBOL.PNAME 
+                                   SYMBOL.PACKAGE OLD.FIND.SYMBOL LOOKUP-SYMBOL FIND.PACKAGE 
+                                   FIND.SYMBOL PACKAGE.NAME \MKATOM GETTOPVAL GETPROPLIST SETTOPVAL 
+                                   GETDEFN \ATOMCELL)
+                             (FNS LISTP)
+                             (VARS (COPYATOMSTR)))
+                      (RD.SUBFNS (\RPLPTR . VPUTBASEPTR))
+                      (RDVALS (\AtomFrLst]
+        (PROP FILETYPE LLBASIC)))
+(DEFINEQ
+
+(LISTP
+  [LAMBDA (X)                                            (* bvm%: "30-Jan-85 10:56")
+                                                             (* ; "usually done in microcode")
+    (AND (EQ (NTYPX X)
+             \LISTP)
+         (COND
+            ((EQ CDRCODING 0)
+             T)
+            (T                                               (* ; 
+                 "Check that it is not a list page header.  This is mostly for benefit of teleraid")
+               (NEQ (fetch (POINTER WORDINPAGE) of X)
+                    0)))
+         X])
+
+(LITATOM
+  [LAMBDA (X)                                            (* ; "Edited 12-Feb-91 16:14 by jds")
+                                                             (* ; "compiles open to NTYPX check")
+    ((OPCODES COPY TYPEMASK.N 64 EQ)
+     X])
+
+(FIXP
+  [LAMBDA (X)                                            (* lmm "10-MAR-81 15:08")
+                                                             (* ; "compiles open to TYPEPs")
+    (\TYPEMASK.UFN X (LRSH \TT.FIXP 8])
+
+(SMALLP
+  [LAMBDA (X)                                            (* lmm "10-MAR-81 15:10")
+                                                             (* ; "compiles open to TYPEP")
+    (SELECTC (NTYPX X)
+        (\SMALLP X)
+        NIL])
+
+(NLISTP
+  [LAMBDA (X)                                            (* lmm "10-MAR-81 15:07")
+                                                             (* ; "compiles open")
+    (NOT (LISTP X])
+
+(ARRAYP
+  [LAMBDA (X)                                            (* lmm "10-MAR-81 15:11")
+                                                             (* ; "compiles open to TYPEP")
+    (SELECTC (NTYPX X)
+        (\ARRAYP X)
+        NIL])
+
+(FLOATP
+  [LAMBDA (X)                                            (* lmm "10-MAR-81 15:11")
+                                                             (* ; "compiles open to TYPEP")
+    (SELECTC (NTYPX X)
+        (\FLOATP X)
+        NIL])
+
+(NUMBERP
+  [LAMBDA (X)                                            (* lmm "10-MAR-81 15:12")
+    (\TYPEMASK.UFN X (LRSH \TT.NUMBERP 8])
+
+(STACKP
+  [LAMBDA (X)                                            (* lmm "10-MAR-81 15:13")
+    (SELECTC (NTYPX X)
+        (\STACKP X)
+        NIL])
+)
+
+(DEFINLINE ATOM (X)
+   (OR (NULL X)
+       (AND (\TYPEMASK.UFN X 8)
+            T)))
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS CHECK MACRO [ARGS (COND
+                                       [(AND (BOUNDP 'CHECK)
+                                             CHECK)
+                                        (CONS 'PROGN
+                                              (for I in ARGS
+                                                 collect (LIST 'OR I
+                                                                   (LIST 'RAID
+                                                                         (KWOTE (LIST 
+                                                                                      '
+                                                                                      Check-failure%:
+                                                                                      I]
+                                       (T (CONS COMMENTFLG ARGS])
+
+(PUTPROPS \StatsZero BYTEMACRO (OPENLAMBDA (N)
+                                              (\PUTBASE N 0 0)
+                                              (\PUTBASE N 1 0)))
+
+(PUTPROPS \StatsAdd1 DMACRO [OPENLAMBDA (A)
+                                           (PROG ((LO (IPLUS16 (\GETBASE A 1)
+                                                             1)))
+                                                 (DECLARE (LOCALVARS LO))
+                                                             (* ; "Increment double word at A by 1")
+                                                 (\PUTBASE A 1 LO)
+                                                 (COND
+                                                    ((EQ LO 0)
+                                                     (\PUTBASE A 0 (ADD1 (\GETBASE A 0])
+
+(PUTPROPS IPLUS16 MACRO ((X Y)                       (* ; "Kludge to do 16-bit plus")
+                                 (\LOLOC (\ADDBASE X Y))))
+
+(PUTPROPS SMALLPOSP MACRO (OPENLAMBDA (X)
+                                         (AND (SMALLP X)
+                                              (IGEQ X 0))))
+
+[PROGN (PUTPROPS SETXVAR MACRO [X `(SETQ.NOREF %, (CADAR X)
+                                                  %,
+                                                  (CADR X])
+       (PUTPROPS SETXVAR DMACRO (X (OR (AND (EQ (CAAR X)
+                                                        'QUOTE)
+                                                    (LITATOM (CADAR X)))
+                                               (SHOULDNT))
+                                           (GLOBALVARS \VALSPACE)
+                                           (LIST 'SETQ.NOREF (CADAR X)
+                                                 (CADR X))))]
+
+(PUTPROPS SETQ.NOREF DMACRO ((VAR VAL)
+                                     (\PUTBASEPTR (LOCF (fetch (LITATOM VALUE)
+                                                           of 'VAR))
+                                            0 VAL)))
+
+(PROGN (PUTPROPS IEQ MACRO ((X Y)
+                                    (IEQP X Y)))
+       (PUTPROPS IEQ DMACRO (= . EQ)))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ WordsPerPage 256)
+
+
+(CONSTANTS WordsPerPage)
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+
+(SETTEMPLATE 'SPREADAPPLY* '(FUNCTIONAL |..| EVAL))
+
+(SETTEMPLATE 'SPREADAPPLY '(FUNCTIONAL EVAL . PPE))
+
+(SETTEMPLATE 'SETQ.NOREF '(SET EVAL . PPE))
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: EVAL@COMPILE
+
+(BLOCKRECORD FREELISTENTRY ((FREELINK FULLXPOINTER)))
+
+(BLOCKRECORD HASHENTRY ((HASHPAGE# WORD)
+                            (HASHFIRSTOFFSET WORD)
+                            (HASHLASTFREE FULLXPOINTER))
+                           [ACCESSFNS HASHENTRY (HASHMASK (fetch HASHFIRSTOFFSET of DATUM)
+                                                       (PROGN (replace HASHPAGE# of DATUM
+                                                                 with MAX.SMALLP)
+                                                              (replace HASHFIRSTOFFSET
+                                                                 of DATUM with NEWVALUE])
+)
+)
+
+
+
+(* ; "atoms")
+
+(DEFINEQ
+
+(GETTOPVAL
+  [LAMBDA (X)                                            (* edited%: " 3-Apr-85 16:38")
+    (fetch (LITATOM VALUE) of X])
+
+(SETTOPVAL
+  [LAMBDA (ATM VAL)                                      (* edited%: " 3-Apr-85 19:37")
+    (SELECTQ ATM
+        (NIL (AND VAL (LISPERROR "ATTEMPT TO SET NIL OR T" VAL)))
+        (T (OR (EQ VAL T)
+               (LISPERROR "ATTEMPT TO SET NIL OR T" VAL)))
+        (replace (LITATOM VALUE) of ATM with (UNLESSRDSYS VAL (\COPY VAL])
+
+(FSETVAL
+  [LAMBDA (ATM VAL)                                      (* edited%: " 3-Apr-85 19:36")
+                                                             (* ; 
+                                                 "SETTOPVAL without error checks for MAKEINIT only")
+    (replace (LITATOM VALUE) of ATM with VAL])
+
+(\SETGLOBALVAL.UFN
+  [LAMBDA (V A)                                          (* bvm%: " 6-Jun-85 11:54")
+    (replace (VALINDEX VALUE) of A with V])
+
+(\SETFVAR.UFN
+  [LAMBDA (V VCELL)                                      (* edited%: " 3-Apr-85 16:40")
+    (replace (VCELL VALUE) of VCELL with V])
+
+(GETPROPLIST
+  [LAMBDA (ATM)                                          (* edited%: " 3-Apr-85 16:40")
+    (\GETBASEPTR (\PROPCELL ATM)
+           0])
+
+(\ATOMCELL
+  [LAMBDA (X N)                               (* ; 
+                                                "Edited  9-Nov-92 14:18 by sybalsky:mv:envos")
+    (LET ((ATOMNO (\ATOMDEFINDEX X)))
+         (COND
+            (NIL                                             (* ; "OLD VERSION")
+                 (EQ (\HILOC ATOMNO)
+                     0)                                      (* ; "Xerox Lisp traditional symbol")
+                 (LET [(LOC (SELECTC N
+                                (\DEF.HI (\ATOMDEFINDEX ATOMNO))
+                                (\VAL.HI (\ATOMVALINDEX ATOMNO))
+                                (\PLIST.HI (\ATOMPROPINDEX ATOMNO))
+                                (\PNAME.HI (\ATOMPNAMEINDEX ATOMNO))
+                                (SHOULDNT]
+                      (\ADDBASE (\VAG2 N LOC)
+                             LOC)))
+            [(FIXP ATOMNO)                               (* ; "Xerox Lisp traditional symbol")
+             (LET [(LOC (SELECTC N
+                            (\DEF.HI \NEWATOM-DEFOFFSET)
+                            (\VAL.HI \NEWATOM-VALOFFSET)
+                            (\PLIST.HI \NEWATOM-PLISTOFFSET)
+                            (\PNAME.HI \NEWATOM-PNAMEOFFSET)
+                            (SHOULDNT]
+                  (\ADDBASE \PNPSPACE (IPLUS LOC (ITIMES 10 ATOMNO]
+            (T                                               (* ; 
+                                       "New symbol that appears after traditional symbol runs out.")
+               (LET [(OFFSET (SELECTC N
+                                 (\DEF.HI \NEWATOM-DEFOFFSET)
+                                 (\VAL.HI \NEWATOM-VALOFFSET)
+                                 (\PLIST.HI \NEWATOM-PLISTOFFSET)
+                                 (\PNAME.HI \NEWATOM-PNAMEOFFSET)
+                                 (SHOULDNT]
+                    (\ADDBASE ATOMNO OFFSET])
+
+(SETPROPLIST
+  [LAMBDA (ATM LST)                                      (* edited%: " 3-Apr-85 16:41")
+    (replace (LITATOM PROPLIST) of ATM with LST])
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \PROPCELL MACRO ((ATOM)
+                                   (\ATOMCELL ATOM (CONSTANT \PLIST.HI))))
+)
+
+(DEFOPTIMIZER \ATOMCELL (&REST X)
+                            [LET [(CE (CONSTANTEXPRESSIONP (CADR X]
+                                 (COND
+                                    [CE `((OPCODES ATOMCELL.N %, (CAR CE))
+                                          %,
+                                          (CAR X]
+                                    (T 'IGNOREMACRO])
+
+(DEFOPTIMIZER GETPROPLIST (X)
+                              `(\GETBASEPTR (\PROPCELL ,X)
+                                      0))
+
+(DEFOPTIMIZER SETPROPLIST (ATM LST)
+                              `(\RPLPTR (\PROPCELL ,ATM)
+                                      0
+                                      ,LST))
+(DEFINEQ
+
+(\MKATOM
+  [LAMBDA (BASE OFFST LEN FATP NONNUMERICP)              (* bvm%: " 3-Aug-86 15:24")
+    (PROG ([FATCHARSEENP (AND FATP (NOT (NULL (for I from OFFST
+                                                 to (SUB1 (IPLUS OFFST LEN))
+                                                 suchthat (IGREATERP (\GETBASEFAT BASE I)
+                                                                     \MAXTHINCHAR]
+           HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE)
+
+     (* ;; "Because FATCHARSEENP is used in an EQ check later, it must be NIL or T only, hence the (NOT (NULL ...))")
+
+          (COND
+             ((EQ LEN 0)                                     (* ; 
+                                                          "The Zero-length atom has hash code zero")
+              (SETQ HASH 0)
+              (SETQ FIRSTBYTE 255)
+              (GO LP)))
+          (SETQ FIRSTCHAR (UNLESSRDSYS (\GETBASECHAR FATP BASE OFFST)
+                                 (NTHCHARCODE BASE OFFST)))  (* ; 
+                                                           "Grab the first character of the atom")
+          [UNLESSRDSYS (COND
+                          [(AND (EQ LEN 1)
+                                (ILEQ FIRSTCHAR \MAXTHINCHAR)
+                                \OneCharAtomBase)            (* ; 
+                               "The one-character atoms live in well known places, no need to hash")
+                           (RETURN (COND
+                                      ((IGREATERP FIRSTCHAR (CHARCODE "9"))
+                                       (\ADDBASE \OneCharAtomBase (IDIFFERENCE FIRSTCHAR 10)))
+                                      ((IGEQ FIRSTCHAR (CHARCODE "0"))
+                                                             (* ; 
+                                                    "These one-character atoms are integers.  Sigh")
+                                       (IDIFFERENCE FIRSTCHAR (CHARCODE "0")))
+                                      (T (\ADDBASE \OneCharAtomBase FIRSTCHAR]
+                          ((AND (NOT NONNUMERICP)
+                                (ILEQ FIRSTCHAR (CHARCODE "9"))
+                                (SETQ HASHENT (\PARSE.NUMBER BASE OFFST LEN FATP 10 \ORIGREADTABLE)))
+                                                             (* ; 
+                                                           "\PARSE.NUMBER returns a number or NIL")
+                           (RETURN HASHENT]                  (* ; "Calculate first probe")
+          (SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255))
+
+     (* ;; "First byte is used to compute hash and reprobe.  Use lower order byte of first character, since chances are that has the most information")
+
+          (COMPUTE.ATOM.HASH BASE OFFST LEN FIRSTBYTE FATP)  (* ; 
+                                                  "Build a hash value for this atom from the PNAME")
+      LP                                                     (* ; 
+                                                        "Top of the probe-and-compare-PNAMEs loop.")
+          [COND
+             ((NEQ 0 (SETQ HASHENT (\GETBASE \AtomHashTable HASH)))
+
+              (* ;; "HASHENT is one greater than the atom number, so that atom zero can be stored.  Go from atom number to pname, compare strings")
+
+              (COND
+                 ((UNLESSRDSYS [AND (EQ [ffetch (PNAMEBASE PNAMELENGTH)
+                                           of (SETQ PNBASE (ffetch (PNAMEINDEX PNAMEBASE)
+                                                                  of (SETQ ATM# (SUB1 HASHENT]
+                                        LEN)
+                                    [EQ FATCHARSEENP (AND (PROG1 (EQ 0 (ffetch (PNAMEBASE 
+                                                                                  PNAMEFATPADDINGBYTE
+                                                                                          )
+                                                                          of PNBASE))
+
+                                 (* ;; "Extra memory references to get the FATPNAMEP bit, so do a quick and dirty heuristic, based on the fact that the second byte of a fatpname is always 0--wouldn't be worth it if the fatbit were more easily accessible")
+
+                                                                 )
+                                                          (ffetch (LITATOM FATPNAMEP)
+                                                             of (\ADDBASE \ATOMSPACE ATM#]
+                                    (COND
+                                       [FATCHARSEENP         (* ; 
+                                "FATCHARSEENP=T now implies that both the probe and target are fat")
+                                              (for B1 from 1 to LEN as B2
+                                                 from OFFST always 
+                                                             (* ; 
+ "Loop thru the characters in the putative atom and the existing PNAME, to see if they're the same")
+                                                                      (EQ (\GETBASEFAT PNBASE B1)
+                                                                          (\GETBASEFAT BASE B2]
+                                       [FATP                 (* ; 
+                        "The incoming string is fat, but there are no fat characters in the PNAME.")
+                                             (for B1 from 1 to LEN as B2 from
+                                                                                         OFFST
+                                                always (EQ (\GETBASETHIN PNBASE B1)
+                                                               (\GETBASEFAT BASE B2]
+                                       (T                    (* ; 
+                                        "Both the incoming string of chars and the PNAME are thin.")
+                                          (for B1 from 1 to LEN as B2 from OFFST
+                                             always (EQ (\GETBASETHIN PNBASE B1)
+                                                            (\GETBASETHIN BASE B2]
+                         (EQ (\INDEXATOMPNAME (SETQ ATM# (SUB1 HASHENT)))
+                             BASE))
+                  (RETURN (\ADDBASE \ATOMSPACE ATM#)))
+                 (T                                          (* ; 
+"Doesn't match, so reprobe.  Want reprobe to be variable, preferably independent of primary probe.")
+                    [SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (ATOM.HASH.REPROBE HASH 
+                                                                              FIRSTBYTE]
+                    (GO LP]                                  (* ; "Not found, must make new atom")
+          (RETURN (UNINTERRUPTABLY
+                      (LET ((NEWATOM (\CREATE.SYMBOL BASE OFFST LEN FATP FATCHARSEENP)))
+                           [UNLESSRDSYS (\PUTBASE \AtomHashTable HASH (ADD1 (\ATOMPNAMEINDEX NEWATOM]
+                           NEWATOM))])
+
+(\CREATE.SYMBOL
+  [LAMBDA (BASE OFFSET LEN FATP FATCHARSEENP)            (* ; "Edited  8-Feb-93 16:48 by jds")
+
+(* ;;; "Creates a new symbol whose pname is as indicated.  FATP means the presented string is fat, while FATCHARSEENP means that there actually is a fat char in there (otherwise we will store a thin pname) --- Must be called UNINTERRUPTABLY and the caller is responsible for interning the symbol wherever it belongs")
+
+    (* ;; "WARNING:  Changes here (e.g., to where we seitch over to bigatoms) need to be reflected in MAPATOMS, too.")
+
+    (LET ([PNBASE (\ALLOCBLOCK (COND
+                                  (FATCHARSEENP              (* ; 
+                                           "Allocate us a bunch of word-sized chars in pname space")
+                                         (FOLDHI (ADD1 LEN)
+                                                WORDSPERCELL))
+                                  (T                         (* ; "Allocation is in CELLS")
+                                     (FOLDHI (ADD1 LEN)
+                                            BYTESPERCELL]
+          PB CPP ATM)
+         [COND
+            ((IGEQ (SETQ ATM \AtomFrLst)
+                   12287)
+
+             (* ;; "used to be:")
+
+             (IGEQ (SETQ ATM \AtomFrLst)
+                   \MaxAtomFrLst)                            (* ; 
+                             "This test WAS fast (it used to be EQ), with the old, painful result:")
+                                                             (* ; 
+                                                 "(\MP.ERROR \MP.ATOMSFULL %"No more atoms left%")")
+
+             (* ;; "Now, just create us a NEW-ATOM, and keep going:")
+
+             (SETQ ATM (CREATECELL \NEW-ATOM))
+             (REPLACE (VALINDEX VALUE) OF ATM WITH 'NOBIND))
+            ((EVENP ATM 256)                                 (* ; 
+                                                           "Can fit 256 new atoms into 10 pages.")
+
+             (* ;; "Old Condition:")
+
+             (EVENP ATM \MDSIncrement)                       (* ; 
+                                                   "MDS pages are allocated in two-page chunks now")
+
+             (* ;; "THE ITIEMS 10 IS NEW FOR BIGVM:")
+
+             (LET [(PN (ITIMES 10 (FOLDLO ATM WORDSPERPAGE]
+                  (COND
+                     ((NEW-SYMBOL-CODE NIL (IGEQ PN (IDIFFERENCE \LastAtomPage 1)))
+
+                      (* ;; "This used to cause the %"You're running out of atoms%" error.")
+
+                      (\MKATOM.FULL)))
+                  (\MAKEMDSENTRY (FOLDLO ATM WORDSPERPAGE)
+                         (LOGOR \TT.NOREF \TT.SYMBOLP \TT.ATOM \LITATOM))
+                                                             (* ; "Make entry in MDS type table")
+                  (\INITATOMPAGE PN)                     (* ; 
+                                        "Make Def'n, TopVal, and Plist pages exist, and initialize")
+                  ]
+         (replace (PNAMEINDEX PNAMEBASE) of ATM with PNBASE)
+                                                             (* ; 
+                                           "PNAME starts on byte 1 always --- byte 0 is the length")
+         (COND
+            (FATCHARSEENP (\BLT (\ADDBASE PNBASE 1)
+                                 (\ADDBASE BASE OFFSET)
+                                 LEN))
+            [FATP (for I from OFFSET as J from 1 to LEN
+                     do (\PUTBASETHIN PNBASE J (\GETBASEFAT BASE I]
+            (T (\MOVEBYTES BASE OFFSET PNBASE 1 LEN)))
+         (replace (PNAMEBASE PNAMELENGTH) of PNBASE with LEN)
+         (COND
+            ((NOT \IN.MAKEINIT)                              (* ; 
+                        "Make the pname block permanent, since the replace above did not addref it")
+             (\ADDREF PNBASE)))
+         (SETQ \AtomFrLst (ADD1 \AtomFrLst))
+
+         (* ;; "If it's an old atom (so ATM is an atom#), change it to a LITATOM:")
+
+         (AND (FIXP ATM)
+              (SETQ ATM (\ADDBASE \ATOMSPACE ATM)))
+         (COND
+            (FATCHARSEENP (freplace (LITATOM FATPNAMEP) of ATM with T)))
+         ATM])
+
+(\MKATOM.FULL
+  [LAMBDA NIL                                            (* bvm%: " 7-May-86 12:25")
+
+(* ;;; "Cause a STORAGEFULL interrupt on the first atom of the penultimate page -- that should give 'early' warning.")
+
+    (DECLARE (GLOBALVARS \STORAGEFULL \INTERRUPTSTATE))
+    (COND
+       ((NOT \STORAGEFULL)
+        (SETQ \STORAGEFULL T)
+        (replace STORAGEFULL of \INTERRUPTSTATE with T)
+        (SETQ \PENDINGINTERRUPT T)))
+    NIL])
+
+(\INITATOMPAGE
+  [LAMBDA (PN)                                (* ; 
+                                                "Edited 28-Oct-92 15:47 by sybalsky:mv:envos")
+    (COND
+       [NIL (PROG ((OFFSET (UNFOLD PN WORDSPERPAGE))
+                   VALBASE)
+
+             (* ;; "PN is the page number of the first atom.  OFFSET is the first atom.  Have to double that to get offsets in \DEFSPACE etc.  Atoms, like everything, are allocated in double pages, so the 4 spaces have to be allocated in quad pages")
+
+             (* ;; "assumes CCODEP bit in definition cell is default 'OFF' , so it's ok to have all def pages zero to start")
+
+                  (\NEW4PAGE (\ADDBASE2 \PNPSPACE OFFSET))
+                  (\NEW4PAGE (\ADDBASE2 \DEFSPACE OFFSET))
+                  (\NEW4PAGE (\ADDBASE2 \PLISTSPACE OFFSET))
+                  (\NEW4PAGE (SETQ VALBASE (\ADDBASE2 \VALSPACE OFFSET)))
+                  (FRPTQ (ITIMES CELLSPERPAGE 4)             (* ; 
+                                                           "Initialize value pages to value NOBIND")
+                         (\PUTBASEPTR VALBASE 0 (EVQ 'NOBIND))
+                         (SETQ VALBASE (\ADDBASE VALBASE WORDSPERCELL]
+       (T 
+          (* ;; "New, big-VM code:  Allocate 10 pages in PNPspace at a crack, to hold 256 atoms.")
+
+          (LET ((OFFSET (UNFOLD PN WORDSPERPAGE))
+                (ATM (UNFOLD (IQUOTIENT PN 10)
+                            WORDSPERPAGE))
+                VALBASE)
+
+               (* ;; "Create the new pages in what used to be PNAME space:")
+
+               (FOR I FROM 0 TO 9 AS OFF FROM OFFSET BY WORDSPERPAGE
+                  DO (\NEWPAGE (\ADDBASE \PNPSPACE OFF)))
+
+               (* ;; "Make all the atoms' values be NOBIND:")
+
+               (FOR I FROM 0 TO 255 AS OFF FROM OFFSET BY 10
+                  DO (\PUTBASEPTR \PNPSPACE (IPLUS OFF \NEWATOM-VALOFFSET)
+                                'NOBIND])
+)
+(DEFINEQ
+
+(MAPATOMS
+  [LAMBDA (FN)
+    (DECLARE (LOCALVARS . T))                        (* ; "Edited  8-Feb-93 16:47 by jds")
+
+    (* ;; "8-FEB-92 JDS:  We now switch over into big-atom mode at 12288  (changes in \CREATE.SYMBOL should be lected here)")
+
+    (PROG ((A 0))
+          (for A from 0 to (IMIN \AtomFrLst 12286) do (APPLY* FN (\INDEXATOMPNAME
+                                                                                  A)))
+          (COND
+             ((IGREATERP \AtomFrLst 12286)
+              (CL:FLET
+               [(\SFLHASHLOOKUP (PAGE# HASHTABLE INSERT)
+                       (bind (MASK _ (fetch HASHMASK of HASHTABLE))
+                              PROBE HASHENT first (SETQ PROBE (LOGAND (LLSH PAGE# 2)
+                                                                         MASK))
+                          do [COND
+                                    ((EQ (fetch HASHPAGE# of (SETQ HASHENT (\ADDBASE 
+                                                                                          HASHTABLE 
+                                                                                          PROBE)))
+                                         PAGE#)
+                                     (RETURN HASHENT))
+                                    ((EQ 0 (fetch HASHPAGE# of HASHENT))
+                                     (RETURN (COND
+                                                (INSERT (replace HASHPAGE# of HASHENT
+                                                           with PAGE#)
+                                                       HASHENT]
+                                (SETQ PROBE (LOGAND (IPLUS PROBE 4)
+                                                   MASK]
+               (PROG ((HASHTABLE
+                       (PROG ((DTD (\GETDTD \NEW-ATOM))
+                              NPAGES HASHTABLE HASHENT HSIZE NEXTFREE NEXTPAGE LASTPAGE FIRSTFREE 
+                              LASTFREE OTHERLASTFREE PREVPAGELASTFREE PROBE MASK)
+                             (SETQ NPAGES (ITIMES (for I from 0 to \MAXVMPAGE
+                                                     by 2 count (EQ (MDSTYPE# I)
+                                                                            \NEW-ATOM))
+                                                 2))
+                             (SETQ HSIZE (FIX (TIMES NPAGES 1.4)))
+                                                             (* ; 
+                                       "Good size of hashtable for hashing pages of this type into")
+                             (SETQ HSIZE (find I from 8 by I
+                                            suchthat (IGREATERP I HSIZE)))
+                                                             (* ; "Get a power of 2")
+                             (SETQ HASHTABLE (\ALLOCBLOCK (ITIMES HSIZE 2)))
+                             (replace HASHMASK of HASHTABLE with (SUB1 (ITIMES HSIZE 4)))
+                             (SETQ NEXTFREE (fetch DTDFREE of DTD))
+                             [do
+                              (COND
+                                 ((NEQ (SETQ NEXTPAGE (fetch (POINTER PAGE#) of NEXTFREE))
+                                       LASTPAGE)             (* ; "Cell on a new page")
+                                  [COND
+                                     ((AND NEXTFREE (NEQ (NTYPX NEXTFREE)
+                                                         \NEW-ATOM))
+                                      (RETURN (RAID "Bad free list" NEXTFREE]
+                                  (COND
+                                     (LASTPAGE               (* ; 
+                            "Hash LASTPAGE and see if we have already seen cells free on this page")
+                                      (SETQ HASHENT (\SFLHASHLOOKUP LASTPAGE HASHTABLE T))
+                                      (COND
+                                         [(SETQ OTHERLASTFREE (fetch HASHLASTFREE of HASHENT)
+                                           )                 (* ; 
+                            "Yes, we have seen others.  Link this section of the free list into it")
+                                          (COND
+                                             ((EQ (fetch FREELINK of OTHERLASTFREE)
+                                                  FIRSTFREE)
+
+                                 (* ;; "Aha, already in order.  This happens when we have a sequence LASTPAGE -> x ...  -> LASTPAGE where everything in between the two LASTPAGE's got moved to earlier in the freelist")
+
+                                              (SETQ PREVPAGELASTFREE LASTFREE))
+                                             (T
+                                              (UNINTERRUPTABLY
+                                                  [replace FREELINK of OTHERLASTFREE
+                                                     with
+                                                     (PROG1 FIRSTFREE
+                                                         (replace FREELINK
+                                                            of (OR PREVPAGELASTFREE
+                                                                       (RETURN (RAID 
+                                                                                "No PREVPAGELASTFREE"
+                                                                                     ))) with
+                                                                                         NEXTFREE)
+                                                         (replace FREELINK of LASTFREE
+                                                            with (fetch FREELINK of
+                                                                                         
+                                                                                        OTHERLASTFREE
+                                                                            )))])]
+                                         (T (replace HASHFIRSTOFFSET of HASHENT
+                                               with (\LOLOC FIRSTFREE))
+                                            (SETQ PREVPAGELASTFREE LASTFREE)))
+                                      (replace HASHLASTFREE of HASHENT with LASTFREE)))
+                                  (OR (SETQ FIRSTFREE NEXTFREE)
+                                      (RETURN))
+                                  (SETQ LASTPAGE NEXTPAGE)))
+                              (SETQ NEXTFREE (fetch FREELINK of (SETQ LASTFREE NEXTFREE]
+                             (SETQ LASTPAGE (SETQ PREVPAGELASTFREE))
+                             (SETQ NEXTFREE (fetch DTDFREE of DTD))
+
+                        (* ;; "Now take a quick second pass to link all odd pages immediately after the corresponding even pages.  Might possibly have done this in the previous loop, but the logic gets pretty messy")
+
+                             [do
+                              (COND
+                                 ((NEQ (SETQ NEXTPAGE (fetch (POINTER PAGE#) of NEXTFREE))
+                                       LASTPAGE)             (* ; "Cell on a new page")
+                                  [COND
+                                     (LASTPAGE
+                                      (COND
+                                         [(AND (ODDP LASTPAGE)
+                                               (SETQ HASHENT (\SFLHASHLOOKUP (LOGXOR LASTPAGE 1)
+                                                                    HASHTABLE))
+                                               (NEQ (fetch FREELINK
+                                                       of (SETQ OTHERLASTFREE
+                                                               (fetch HASHLASTFREE of HASHENT
+                                                                      )))
+                                                    FIRSTFREE))
+                                                             (* ; 
+"There is an entry for our partner even page, and it is not immediately followed by its odd partner")
+                                          (OR
+                                           NIL
+                                           (UNINTERRUPTABLY
+                                               [replace FREELINK of OTHERLASTFREE
+                                                  with (PROG1 FIRSTFREE
+                                                               (COND
+                                                                  (PREVPAGELASTFREE (replace
+                                                                                     FREELINK
+                                                                                       of 
+                                                                                     PREVPAGELASTFREE
+                                                                                       with
+                                                                                       NEXTFREE))
+                                                                  (T (OR (EQ FIRSTFREE
+                                                                             (fetch DTDFREE
+                                                                                of DTD))
+                                                                         (RAID "No PREVPAGELASTFREE")
+                                                                         )
+                                                                     (replace DTDFREE
+                                                                        of DTD with NEXTFREE)
+                                                                     ))
+                                                               (replace FREELINK of LASTFREE
+                                                                  with (fetch FREELINK
+                                                                              of OTHERLASTFREE)))
+                                                      ])]
+                                         (T (SETQ PREVPAGELASTFREE LASTFREE]
+                                  (OR (SETQ FIRSTFREE NEXTFREE)
+                                      (RETURN))
+                                  (SETQ LASTPAGE NEXTPAGE)))
+                              (SETQ NEXTFREE (fetch FREELINK of (SETQ LASTFREE NEXTFREE]
+                             (RETURN HASHTABLE)))
+                      (SIZE (fetch DTDSIZE of (\GETDTD \NEW-ATOM)))
+                      (ATOM# 65536)
+                      RESULT FIRSTFREE LASTFREE HASHENT LASTPAGE LIMIT)
+                     (OR HASHTABLE (RETURN))
+                     (OR (EVENP SIZE)
+                         (SHOULDNT "Odd size?"))
+                     (COND
+                        ((.ALLOCATED.PER.PAGE. SIZE)
+                         (SETQ LASTPAGE (SUB1 \PagesPerMDSUnit))
+                         (SETQ LIMIT WORDSPERPAGE))
+                        (T (SETQ LASTPAGE 0)
+                           (SETQ LIMIT \MDSIncrement)))
+                     [for MDSPAGE# from 0 by \PagesPerMDSUnit
+                        while (<= MDSPAGE# \MAXVMPAGE) when (EQ (MDSTYPE# MDSPAGE#)
+                                                                        \NEW-ATOM)
+                        do [COND
+                                  ([SETQ FIRSTFREE (COND
+                                                      ((SETQ HASHENT (OR (\SFLHASHLOOKUP MDSPAGE# 
+                                                                                HASHTABLE)
+                                                                         (\SFLHASHLOOKUP (LOGOR
+                                                                                          MDSPAGE# 1)
+                                                                                HASHTABLE)))
+                                                       (\VAG2 (FOLDLO MDSPAGE# PAGESPERSEGMENT)
+                                                              (fetch HASHFIRSTOFFSET of
+                                                                                         HASHENT]
+                                   (SETQ LASTFREE (fetch HASHLASTFREE
+                                                     of (OR (AND (EVENP (fetch HASHPAGE#
+                                                                               of HASHENT))
+                                                                     (\SFLHASHLOOKUP (LOGOR MDSPAGE#
+                                                                                            1)
+                                                                            HASHTABLE))
+                                                                HASHENT] 
+
+                              (* ;; 
+                     "Now collect all pointers not on free list.  This code parallels \INITMDSPAGE")
+
+                              (for N from 0 to LASTPAGE
+                                 do (for (DISP _ 0) while (<= (add DISP SIZE)
+                                                                          LIMIT)
+                                           as (DATUMBASE _ (create POINTER
+                                                                      PAGE# _ (IPLUS N MDSPAGE#)))
+                                           by (\ADDBASE DATUMBASE SIZE)
+                                           when [AND (OR (NOT FIRSTFREE)
+                                                             (for (X _ FIRSTFREE)
+                                                                by (fetch FREELINK
+                                                                          of X)
+                                                                never (EQ X DATUMBASE)
+                                                                repeatuntil (EQ X LASTFREE]
+                                           do (APPLY* FN DATUMBASE)
+                                                 (ADD ATOM# 1]
+                     (RETURN])
+
+(ATOMHASH#PROBES
+  [LAMBDA (STRING)                                       (* bvm%: " 8-Jul-86 21:50")
+
+(* ;;; "Looks up STRING (a string or litatom) in atom hash table.  If found, returns number of probes needed to find it, a minimum of one.  If not found, returns NIL")
+
+    (PROG (DESIREDATOM# BASE OFFST LEN FIRSTBYTE FIRSTCHAR HASH HASHENT PNBASE REPROBE FATCHARSEENP 
+                 FATP)
+          [COND
+             ((LITATOM STRING)
+              (SETQ BASE (ffetch (LITATOM PNAMEBASE) of STRING))
+              (SETQ OFFST 1)
+              (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of STRING))
+              (SETQ FATP (SETQ FATCHARSEENP (ffetch (LITATOM FATPNAMEP) of STRING)))
+              (SETQ DESIREDATOM# (\LOLOC STRING)))
+             (T [SETQ BASE (ffetch (STRINGP BASE) of (SETQ STRING (MKSTRING STRING]
+                (SETQ OFFST (ffetch (STRINGP OFFST) of STRING))
+                (SETQ LEN (ffetch (STRINGP LENGTH) of STRING))
+                [COND
+                   ((SETQ FATP (ffetch (STRINGP FATSTRINGP) of STRING))
+                    (SETQ FATCHARSEENP (for C infatstring STRING
+                                          when (IGREATERP C \MAXTHINCHAR)
+                                          do (RETURN T]
+                (OR (ILEQ LEN \PNAMELIMIT)
+                    (RETURN]
+          (SETQ FIRSTCHAR (\GETBASECHAR FATP BASE OFFST))
+          (SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255))
+          (COMPUTE.ATOM.HASH BASE OFFST LEN FIRSTBYTE FATP)
+          (RETURN (for PROBES from 1 until (EQ 0 (SETQ HASHENT (\GETBASE \AtomHashTable 
+                                                                                  HASH)))
+                     do (COND
+                               ([COND
+                                   (DESIREDATOM# (EQ DESIREDATOM# (SUB1 HASHENT)))
+                                   (T (AND (EQ [fetch (PNAMEBASE PNAMELENGTH)
+                                                  of (SETQ PNBASE (fetch (PNAMEINDEX 
+                                                                                        PNAMEBASE)
+                                                                         of (SUB1 HASHENT]
+                                               LEN)
+                                           [EQ FATCHARSEENP (ffetch (LITATOM FATPNAMEP)
+                                                               of (\ADDBASE \ATOMSPACE
+                                                                             (SUB1 HASHENT]
+                                           (COND
+                                              [FATCHARSEENP  (* ; 
+                                "FATCHARSEENP=T now implies that both the probe and target are fat")
+                                                     (for B1 from 1 to LEN as B2
+                                                        from OFFST
+                                                        always 
+                                                             (* ; 
+ "Loop thru the characters in the putative atom and the existing PNAME, to see if they're the same")
+                                                              (EQ (\GETBASEFAT PNBASE B1)
+                                                                  (\GETBASEFAT BASE B2]
+                                              [FATP          (* ; 
+                        "The incoming string is fat, but there are no fat characters in the PNAME.")
+                                                    (for B1 from 1 to LEN as B2
+                                                       from OFFST
+                                                       always (EQ (\GETBASETHIN PNBASE B1)
+                                                                      (\GETBASEFAT BASE B2]
+                                              (T             (* ; 
+                                        "Both the incoming string of chars and the PNAME are thin.")
+                                                 (for B1 from 1 to LEN as B2
+                                                    from OFFST
+                                                    always (EQ (\GETBASETHIN PNBASE B1)
+                                                                   (\GETBASETHIN BASE B2]
+                                (RETURN PROBES)))            (* ; 
+"Doesn't match, so reprobe.  Want reprobe to be variable, preferably independent of primary probe.")
+                           (SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (ATOM.HASH.REPROBE
+                                                                               HASH FIRSTBYTE])
+)
+
+
+
+(* ; "For MAKEINIT & TeleRaid")
+
+
+
+
+(* ;; 
+"This code has one major shortcoming which will not normally turn up.  If the local and remote sysouts conflict in their package setups it is possible for this code to return symbols interned in what for the teleraid'ing machine would be the correct package, but for the remote machine is in fact incorrect.  This warrents a warning in the documentation.  The problem lies in the fact that you *cannot* uncopy a symbol correctly between two machines with incompatible package setups.  An example of such a situation would be where on one machine the package FOO inherits BAR, and on the other BAR is present directly in FOO.  BAR's package cell will be different in both cases.  Two solutions come to mind; both would break the VSAVEWORK feature.  The first would be to UNCOPY symbols into special %"remote symbol%" objects.  The second is to create uninterned symbols with the correct name and smash their package cell to be that of a correctly named package.  Both of these schemes would require special reading and printing code."
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS READSYS.HAS.PACKAGES MACRO (NIL (NEQ 1 READSYS.PACKAGE.FROM.NAME)))
+)
+
+(RPAQQ READSYS.PACKAGE.FROM.NAME 1)
+
+(RPAQQ READSYS.PACKAGE.FROM.INDEX 1)
+(DEFINEQ
+
+(INITATOMS
+  [LAMBDA NIL                                            (* ; "Edited 11-Dec-86 14:41 by Pavel")
+
+    (* ;; "called only under MAKEINIT to initialize the making of atoms")
+
+    (CREATEPAGES \AtomHashTable \AtomHTpages)
+    (SETQ \SCRATCHSTRING (ALLOCSTRING \PNAMELIMIT))          (* ; "\SCRATCHSTRING created in remote space simply to make renaming simple.  Could smash it to NIL inside init.sysout")
+                                                             (* (CREATEPAGES \PNCHARSSPACE 1))
+    (COPYATOM NIL)                                       (* ; "NIL is atom 0")
+    (COPYATOM 'NOBIND)                                   (* ; "atom 1")
+
+    (* ;; "Now make the single character atoms -- all thin chars except the digits")
+
+    (for C from 0 to 255 when (OR (ILESSP C (CHARCODE 0))
+                                                  (IGREATERP C (CHARCODE 9)))
+       do (COPYATOM (CHARACTER C)))
+    (SETQ \OneCharAtomBase (\ADDBASE \ATOMSPACE 2))          (* ; 
+                                                           "= (CHARACTER 0) -- for FCHARACTER")
+    (COPYATOM (FUNCTION \EVALFORM))                      (* ; "atom 256-10+2 = 248")
+    (COPYATOM (FUNCTION \GC.HANDLEOVERFLOW))             (* ; "atom 249")
+    (COPYATOM (FUNCTION \DTEST.UFN))                     (* ; "atom 250")
+    (COPYATOM (FUNCTION \OVERFLOWMAKENUMBER))            (* ; "atom 251")
+    (COPYATOM (FUNCTION \MAKENUMBER))                    (* ; "atom 252")
+    (COPYATOM (FUNCTION \SETGLOBAL.UFN))                 (* ; "atom 253")
+    (COPYATOM (FUNCTION \SETFVAR.UFN))                   (* ; "atom 254")
+    (COPYATOM (FUNCTION \GCMAPTABLE))                    (* ; "atom 255")
+    (COPYATOM (FUNCTION \INTERPRETER))                   (* ; "atom 256")
+    (OR (EQ (\ATOMDEFINDEX (FUNCTION \INTERPRETER))
+            256)
+        (HELP (FUNCTION \INTERPRETER)
+              " not atom 400Q"])
+
+(COPYATOM
+  [LAMBDA (X)                                                (* ; "Edited 29-Apr-91 16:01 by jrb:")
+
+    (* ;; "this function is only for the use of MAKEINIT, which passes it a local atom to be translated into an atom in the remote sysout.")
+
+    [ALLOCAL (LET ((PKG (CL:SYMBOL-PACKAGE X)))              (* ; 
+                             "SYMBOL-PACKAGE and *INTERLISP-PACKAGE* both NIL in non-package world")
+                  (COND
+                     ((EQ PKG *INTERLISP-PACKAGE*))
+                     ((NULL PKG)                             (* ; 
+                                                  "This is an uninterned symbol, so add  prefix.")
+                      (SETQ X (CONCAT "" X)))
+                     ((EQ PKG *KEYWORD-PACKAGE*)             (* ; 
+                                                       "keywords eval to self, so also set top val")
+                      (MKI.DSET X X)
+                      (SETQ X (CONCAT ":" X)))
+                     (T 
+                        (* ;; "Kludge time.  We don't yet have the machinery to create packages in the init.sysout, so anything that isn't an Interlisp symbol has to be turned into a flat-space symbol with appropriate prefix")
+
+                        (CL:MULTIPLE-VALUE-BIND (SYM WHERE)
+                               (CL:FIND-SYMBOL (CL:SYMBOL-NAME X)
+                                      PKG)
+                               (SETQ WHERE (SELECTQ WHERE
+                                               (:INTERNAL "::")
+                                               (:EXTERNAL ":")
+                                               (ERROR "Where is this symbol?" X)))
+                               (COND
+                                  ((EQ PKG *LISP-PACKAGE*)
+                                   (SETQ SYM "LISP"))
+                                  ((EQ PKG *COMMON-LISP-PACKAGE*)
+                                   (SETQ SYM "CL"))
+                                  ((CL:STRING= (CL:PACKAGE-NAME PKG)
+                                          "SYSTEM")
+                                   (SETQ SYM "SI"))
+                                  ((CL:STRING= (CL:PACKAGE-NAME PKG)
+                                          "CONDITIONS")
+                                   (SETQ SYM "CONDITIONS"))
+                                  ((CL:STRING= (CL:PACKAGE-NAME PKG)
+                                          "XEROX-COMMON-LISP")
+                                   (SETQ SYM "XCL"))
+                                  ((CL:STRING= (CL:PACKAGE-NAME PKG)
+                                          "COMPILER")
+                                   (SETQ SYM "COMPILER"))
+                                  ((CL:STRING= (CL:PACKAGE-NAME PKG)
+                                          "FASL")
+                                   (SETQ SYM "FASL"))
+                                  (T (HELP 
+             "Can only translate symbols in IL, CL, XCL, CONDITIONS, SI, COMPILER, FASL and keywords"
+                                           X)))
+                               (SETQ X (CONCAT SYM WHERE (CL:SYMBOL-NAME X]
+    (LET ((N (LOCAL (NCHARS X)))
+          (BASE (ffetch (STRINGP BASE) of \SCRATCHSTRING))
+          (OFFST (ffetch (STRINGP OFFST) of \SCRATCHSTRING)))
+                                                             (* ; 
+                                                       "\SCRATCHSTRING is initialized in INITATOMS")
+         [for I from 1 to N do (\PUTBASEBYTE BASE (LOCAL (IPLUS OFFST I -1))
+                                                      (LOCAL (NTHCHARCODE X I]
+         (\ATOMDEFINDEX (\MKATOM BASE OFFST N])
+
+(UNCOPYATOM
+  [LAMBDA (N)                                            (* ; "Edited  6-Mar-87 11:55 by raf")
+
+(* ;;; "This is used only by VATOM (in READSYS) to turn atom numbers into similar local atoms.  Note that it would be very difficult to create correctly exported symbols due to conflicts between the local and remote package setups.")
+
+    (PROG (ATOM.NAME PACKAGE.NAME)
+
+     (* ;; "Uncopy the atom name")
+
+          (SETQ ATOM.NAME (SYMBOL.PNAME N))
+
+     (* ;; "Find and uncopy the package name")
+
+          (SETQ PACKAGE.NAME (IF (READSYS.HAS.PACKAGES)
+                                 THEN (PACKAGE.NAME (SYMBOL.PACKAGE N))
+                               ELSE "INTERLISP"))
+          (RETURN (MAKE.LOCAL.ATOM PACKAGE.NAME ATOM.NAME])
+
+(MAKE.LOCAL.ATOM
+  [LAMBDA (PKG.NAME ATM.NAME)                            (* ; "Edited 17-Feb-87 16:20 by raf")
+
+(* ;;; "There are potential cases in which package setup differences between the local and remote machines will intern names in different packages.  For example, if in the local package the name is an inherited symbol, but remotely the name is directly present in the paackage (shadowed symbol have the same problem).  This is mildly troublesome, however any solution would break VSAVEWORK.  In future it would be best to create a remote-symbol structure and pass that around.")
+
+    (ALLOCAL (CL:INTERN ATM.NAME (OR (CL:FIND-PACKAGE PKG.NAME)
+                                     (CL:MAKE-PACKAGE PKG.NAME :USES NIL])
+
+(SYMBOL.VALUE
+  [LAMBDA (SYMBOL)                                       (* ; "Edited 22-Dec-92 17:05 by jds")
+
+    (* ;; "Get a symbol's value.  This is for RDSYS only.")
+
+    (LET [(LOC (OLD.FIND.SYMBOL SYMBOL 1 (LOCAL (NCHARS SYMBOL]
+         (COND
+            (NIL 
+                 (* ;; "OLD VERSION")
+
+                 (\GETBASEPTR (VADDBASE (VVAG2 12 LOC)
+                                     LOC)
+                        0))
+            (T 
+               (* ;; "NEW VERSION")
+
+               (\GETBASEPTR (VADDBASE (VVAG2 8 0)
+                                   (IPLUS (ITIMES (LOGAND LOC 65535)
+                                                 10)
+                                          \NEWATOM-VALOFFSET))
+                      0])
+
+(SYMBOL.PNAME
+  [LAMBDA (N BUFFER)                                     (* ; "Edited 22-Dec-92 16:32 by jds")
+
+(* ;;; "Uncopy the pname of symbol number N into a string and return it.")
+
+    [ALLOCAL (SETQ BUFFER (OR BUFFER (ALLOCSTRING \PNAMELIMIT]
+    (PROG (ADDR LEN)
+
+     (* ;; "Uncopy the atom name")
+
+          [COND
+             (NIL (SETQ ADDR (\GETBASEPTR (\ADDBASE2 \PNPSPACE N)
+                                    0)))
+             (T (SETQ ADDR (\GETBASEPTR (\ADDBASE (\VAG2 8 0)
+                                               (IPLUS (ITIMES (LOGAND N 65535)
+                                                             10)
+                                                      \NEWATOM-PNAMEOFFSET))
+                                  0]
+          (SETQ LEN (\GETBASEBYTE ADDR 0))
+          [for I from 1 to LEN do (LOCAL (RPLSTRING BUFFER I (FCHARACTER (
+                                                                                         \GETBASEBYTE
+                                                                                          ADDR I]
+          (RETURN (LOCAL (SUBSTRING BUFFER 1 LEN])
+
+(SYMBOL.PACKAGE
+  [LAMBDA (N)                                 (* ; 
+                                                "Edited  8-Nov-92 02:16 by sybalsky:mv:envos")
+
+(* ;;; "Given a symbol number, return a pointer to its remote package.")
+
+    (PROG [(INDEX (COND
+                     (NIL                                    (* ; "OLD WAY")
+                          (LRSH (\GETBASE (\ADDBASE2 \PNPSPACE N)
+                                       0)
+                                8))
+                     (NIL (T (LRSH (\GETBASE (\ADDBASE \PNPSPACE (IPLUS (ITIMES 10 N)
+                                                                        \NEWATOM-PNAMEOFFSET 8))
+                                          0)
+                                   8)))
+                     (T (fetch (LITATOM PACKAGEINDEX) OF N]
+          (RETURN (COND
+                     ((EQ INDEX *UNINTERNED-PACKAGE-INDEX*)
+                      NIL)
+                     (T (\GETBASEPTR (FFETCH (ONED-ARRAY BASE) OF READSYS.PACKAGE.FROM.INDEX)
+                               (LLSH INDEX 1])
+
+(OLD.FIND.SYMBOL
+  [LAMBDA (BASE OFFST LEN FATP NONNUMERICP)              (* ; "Edited 17-Feb-87 16:43 by raf")
+    (PROG ([FATCHARSEENP (AND FATP (NOT (NULL (for I from OFFST
+                                                 to (SUB1 (IPLUS OFFST LEN))
+                                                 suchthat (IGREATERP (\GETBASEFAT BASE I)
+                                                                     \MAXTHINCHAR]
+           HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE)
+
+     (* ;; "Because FATCHARSEENP is used in an EQ check later, it must be NIL or T only, hence the (NOT (NULL ...))")
+
+          (COND
+             ((EQ LEN 0)                                     (* ; 
+                                                          "The Zero-length atom has hash code zero")
+              (SETQ HASH 0)
+              (SETQ FIRSTBYTE 255)
+              (GO LP)))
+          (SETQ FIRSTCHAR (UNLESSRDSYS (\GETBASECHAR FATP BASE OFFST)
+                                 (NTHCHARCODE BASE OFFST)))  (* ; 
+                                                           "Grab the first character of the atom")
+          [UNLESSRDSYS (COND
+                          [(AND (EQ LEN 1)
+                                (ILEQ FIRSTCHAR \MAXTHINCHAR)
+                                \OneCharAtomBase)            (* ; 
+                               "The one-character atoms live in well known places, no need to hash")
+                           (RETURN (COND
+                                      ((IGREATERP FIRSTCHAR (CHARCODE "9"))
+                                       (\ADDBASE \OneCharAtomBase (IDIFFERENCE FIRSTCHAR 10)))
+                                      ((IGEQ FIRSTCHAR (CHARCODE "0"))
+                                                             (* ; 
+                                                    "These one-character atoms are integers.  Sigh")
+                                       (IDIFFERENCE FIRSTCHAR (CHARCODE "0")))
+                                      (T (\ADDBASE \OneCharAtomBase FIRSTCHAR]
+                          ((AND (NOT NONNUMERICP)
+                                (ILEQ FIRSTCHAR (CHARCODE "9"))
+                                (SETQ HASHENT (\PARSE.NUMBER BASE OFFST LEN FATP 10 \ORIGREADTABLE)))
+                                                             (* ; 
+                                                           "\PARSE.NUMBER returns a number or NIL")
+                           (RETURN HASHENT]                  (* ; "Calculate first probe")
+          (SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255))
+
+     (* ;; "First byte is used to compute hash and reprobe.  Use lower order byte of first character, since chances are that has the most information")
+
+          (COMPUTE.ATOM.HASH BASE OFFST LEN FIRSTBYTE FATP)  (* ; 
+                                                  "Build a hash value for this atom from the PNAME")
+      LP                                                     (* ; 
+                                                        "Top of the probe-and-compare-PNAMEs loop.")
+          [COND
+             ((NEQ 0 (SETQ HASHENT (\GETBASE \AtomHashTable HASH)))
+
+              (* ;; "HASHENT is one greater than the atom number, so that atom zero can be stored.  Go from atom number to pname, compare strings")
+
+              (COND
+                 ([UNLESSRDSYS [AND (EQ [ffetch (PNAMEBASE PNAMELENGTH)
+                                           of (SETQ PNBASE (ffetch (PNAMEINDEX PNAMEBASE)
+                                                                  of (SETQ ATM# (SUB1 HASHENT]
+                                        LEN)
+                                    [EQ FATCHARSEENP (AND (PROG1 (EQ 0 (ffetch (PNAMEBASE 
+                                                                                  PNAMEFATPADDINGBYTE
+                                                                                          )
+                                                                          of PNBASE))
+
+                                 (* ;; "Extra memory references to get the FATPNAMEP bit, so do a quick and dirty heuristic, based on the fact that the second byte of a fatpname is always 0--wouldn't be worth it if the fatbit were more easily accessible")
+
+                                                                 )
+                                                          (ffetch (LITATOM FATPNAMEP)
+                                                             of (\ADDBASE \ATOMSPACE ATM#]
+                                    (COND
+                                       [FATCHARSEENP         (* ; 
+                                "FATCHARSEENP=T now implies that both the probe and target are fat")
+                                              (for B1 from 1 to LEN as B2
+                                                 from OFFST always 
+                                                             (* ; 
+ "Loop thru the characters in the putative atom and the existing PNAME, to see if they're the same")
+                                                                      (EQ (\GETBASEFAT PNBASE B1)
+                                                                          (\GETBASEFAT BASE B2]
+                                       [FATP                 (* ; 
+                        "The incoming string is fat, but there are no fat characters in the PNAME.")
+                                             (for B1 from 1 to LEN as B2 from
+                                                                                         OFFST
+                                                always (EQ (\GETBASETHIN PNBASE B1)
+                                                               (\GETBASEFAT BASE B2]
+                                       (T                    (* ; 
+                                        "Both the incoming string of chars and the PNAME are thin.")
+                                          (for B1 from 1 to LEN as B2 from OFFST
+                                             always (EQ (\GETBASETHIN PNBASE B1)
+                                                            (\GETBASETHIN BASE B2]
+                         (LOCAL (STREQUAL (LOCAL (CL:SYMBOL-NAME BASE))
+                                       (SYMBOL.PNAME (SETQ ATM# (SUB1 HASHENT]
+                  (UNLESSRDSYS (RETURN (\ADDBASE \ATOMSPACE (SUB1 ATM#)))
+                         (RETURN ATM#)))
+                 (T                                          (* ; 
+"Doesn't match, so reprobe.  Want reprobe to be variable, preferably independent of primary probe.")
+                    [SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (ATOM.HASH.REPROBE HASH 
+                                                                              FIRSTBYTE]
+                    (GO LP]                                  (* ; "Not found, must make new atom")
+          (RETURN (UNINTERRUPTABLY
+                      (LET ((NEWATOM (\CREATE.SYMBOL BASE OFFST LEN FATP FATCHARSEENP)))
+                           [UNLESSRDSYS (\PUTBASE \AtomHashTable HASH (ADD1 (\ATOMPNAMEINDEX NEWATOM]
+                           NEWATOM))])
+
+(LOOKUP-SYMBOL
+  [LAMBDA (TABLE STRING SXHASH ENTRY-HASH)               (* ; "Edited 17-Feb-87 10:43 by raf")
+
+(* ;;; "Find where the symbol named String is stored in Table.  Index is returned, or NIL if it is not present.   Length and Hash are the length and sxhash of String.  Entry-Hash is the entry-hash of the string and length.%"")
+
+    (LET* ((VEC (\GETBASEPTR TABLE 0))                       (* ; "CL::PACKAGE-HASHTABLE-TABLE")
+           (HASH (\GETBASEPTR TABLE 2))                      (* ; "CL::PACKAGE-HASHTABLE-HASH")
+           (LEN (FFETCH (ONED-ARRAY TOTAL-SIZE) OF VEC))
+                                                             (* ; "CL:ARRAY-TOTAL-SIZE")
+           [H2 (ADD1 (IREMAINDER SXHASH (IDIFFERENCE LEN 2]  (* ; "REHASH-FACTOR")
+           )
+          (DECLARE (TYPE (CL:SIMPLE-ARRAY (CL:UNSIGNED-BYTE 8))
+                             HASH)
+                 (TYPE (CL:SIMPLE-ARRAY (CL:UNSIGNED-BYTE 16))
+                       VEC))
+          (PROG ((INDEX-VAR (IREMAINDER SXHASH LEN))
+                 SYMBOL-NUMBER EHASH)
+                (IF NIL
+                    THEN (CL:FORMAT T "Probe @ ~s~%%" INDEX-VAR))
+            LOOP
+                (SETQ EHASH (\GETBASEBYTE (FFETCH (ONED-ARRAY BASE) OF HASH)
+                                   INDEX-VAR))               (* ; "CL:AREF")
+                [COND
+                   [(EQL EHASH ENTRY-HASH)
+                    (IF NIL
+                        THEN (CL:FORMAT T "Entry hash MATCHES~%%"))
+                    (LET [(SYMBOL-NAME (SYMBOL.PNAME (SETQ SYMBOL-NUMBER
+                                                          (\GETBASE (FFETCH (ONED-ARRAY BASE)
+                                                                       OF VEC)
+                                                                 INDEX-VAR]
+                                                             (* ; "CL:AREF")
+                         (IF NIL
+                             THEN (CL:FORMAT T "Got symbol index~%%"))
+
+                         (* ;; "pname length is first byte of pname")
+
+                         (COND
+                            ((LOCAL (STREQUAL SYMBOL-NAME STRING))
+                             (IF NIL
+                                 THEN (CL:FORMAT T " found~%%"))
+                             (GO DOIT))
+                            (T (IF NIL
+                                   THEN (CL:FORMAT T "Didn't match~%%"]
+                   ((EQL 0 EHASH)
+                    (IF NIL
+                        THEN (CL:FORMAT T "Hit deleted entry (no match)~%%"))
+                    (SETQ INDEX-VAR NIL)
+                    (GO DOIT))
+                   (T (IF NIL
+                          THEN (CL:FORMAT T "Entry hash does not match~%%"]
+                (SETQ INDEX-VAR (IREMAINDER (IPLUS INDEX-VAR H2)
+                                       LEN))                 (* ; "SYMBOL-HASH-REPROBE")
+                (IF NIL
+                    THEN (CL:FORMAT T "Reprobe @ ~s~%%" INDEX-VAR))
+                (GO LOOP)
+            DOIT
+                (RETURN SYMBOL-NUMBER])
+
+(FIND.PACKAGE
+  [LAMBDA (NAME)                                         (* ; "Edited  6-Mar-87 11:50 by raf")
+
+(* ;;; "Given a name, find the package with that name or nickname.  This is a specialized, macroexpanded and de-optimized version of IL:GETHASH")
+
+    (PROG ((ITEM (LOCAL (MKSTRING NAME)))
+           (HA READSYS.PACKAGE.FROM.NAME)
+           BITS INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT ABASE VALUE)
+          (SETQ BITS (STRINGHASHBITS ITEM))
+          (SETQ INDEX (LOGAND BITS (ffetch (HARRAYP LASTINDEX) of HA)))
+                                                             (* ; "\FIRSTINDEX")
+          (SETQ ABASE (ffetch HARRAYPBASE of HA))
+          (SETQ FIRSTINDEX INDEX)
+          (SETQ REPROBE (LOGOR (LOGAND (LOGXOR BITS (LRSH BITS 8))
+                                      (IMIN 63 (FFETCH (HARRAYP LASTINDEX) OF HA)))
+                               1))                           (* ; "\REPROBE")
+          (SETQ LIMIT (ffetch (HARRAYP LASTINDEX) of HA))
+      LP  (SETQ SLOT (\ADDBASE4 ABASE INDEX))                (* ; "\HASHSLOT")
+          (COND
+             [(SETQ VALUE (ffetch (HASHSLOT VALUE) of SLOT))
+                                                             (* ; "Slot is occupied")
+              (SETQ SKEY (V\UNCOPY (ffetch (HASHSLOT KEY) of SLOT)))
+              (COND
+                 ((STREQUAL ITEM SKEY)                       (* ; "Found it")
+                  (GO FOUND]
+             ((NULL (ffetch (HASHSLOT KEY) of SLOT)) (* ; "Empty slot")
+              (RETURN NIL)))
+          (SETQ INDEX (LOGAND (IPLUS16 INDEX REPROBE)
+                             LIMIT))                         (* ; "Since table size is a power of two, any wraparound in the IPLUS16 will be consistent with the LOGAND")
+          (COND
+             ((EQ INDEX FIRSTINDEX)                          (* ; 
+                                         "Should never happen, since we don't allow full occupancy")
+              (SHOULDNT "Hashing in full hash table")))
+          (GO LP)
+      FOUND
+          (RETURN (AND (NEQ VALUE \HASH.NULL.VALUE)
+                       VALUE])
+
+(FIND.SYMBOL
+  [LAMBDA (STRING PACKAGE)                               (* ; "Edited 16-Feb-87 15:59 by raf")
+
+(* ;;; 
+"Given a string, find a symbol by that name.  This is macroexpanded and altered code from LLPACKAGE")
+
+    (LET* ((LENGTH (LOCAL (FFETCH (STRINGP LENGTH) OF STRING)))
+           [HASH (COND
+                    ((EQL 0 LENGTH)
+                     0)
+                    (T (PROG* ((TERMINUS LENGTH)
+                               (HASH (LLSH (LOCAL (NTHCHARCODE STRING 1))
+                                           8))
+                               (CHAR# 2))
+                          A0355
+                              [COND
+                                 ((IGREATERP CHAR# TERMINUS)
+                                  (RETURN (PROGN HASH]
+                              (PROGN)
+                              [SETQ HASH (IPLUS16 (IPLUS16 (SETQ HASH (IPLUS16 HASH
+                                                                             (LLSH (LOGAND HASH 4095)
+                                                                                   2)))
+                                                         (LLSH (LOGAND HASH 255)
+                                                               8))
+                                                (LOCAL (NTHCHARCODE STRING CHAR#]
+                              (SETQ CHAR# (ADD1 CHAR#))
+                              (GO A0355]                     (* ; "SYMBOL-HASH")
+           (EHASH (IPLUS (IREMAINDER (LOGXOR LENGTH HASH (RSH HASH 8)
+                                            (RSH HASH 16)
+                                            (RSH HASH 19))
+                                254)
+                         2))                                 (* ; "ENTRY-HASH")
+           (SYM)
+           (WHERE)
+           (DONE))
+          [COND
+             ((NOT (\GETBASEPTR PACKAGE 14))                 (* ; "CL::%%PACKAGE-EXTERNAL-ONLY")
+              (IF NIL
+                  THEN (PRINT "Checking INTERNAL symbols"))
+              (LET ((INDEX (LOOKUP-SYMBOL (\GETBASEPTR PACKAGE 16)
+                                  STRING HASH EHASH)))       (* ; "CL::%%PACKAGE-INTERNAL-SYMBOLS")
+                   (COND
+                      (INDEX (SETQ SYM INDEX)
+                             (SETQ WHERE :INTERNAL)
+                             (SETQ DONE T]
+          [COND
+             ((NOT DONE)
+              (IF NIL
+                  THEN (PRINT "Checking EXTERNAL symbols"))
+              (LET ((INDEX (LOOKUP-SYMBOL (\GETBASEPTR PACKAGE 18)
+                                  STRING HASH EHASH)))       (* ; "CL::%%PACKAGE-INTERNAL-SYMBOLS")
+                   (COND
+                      (INDEX (SETQ SYM INDEX)
+                             (SETQ WHERE :EXTERNAL)
+                             (SETQ DONE T]
+          [COND
+             ((NOT DONE)
+              (IF NIL
+                  THEN (CL:FORMAT T "Checking USE'd packages~%%"))
+              (LET ((HEAD (\GETBASEPTR PACKAGE 2))           (* ; "CL::%%PACKAGE-TABLES")
+                    )
+                   (PROG ((PREV HEAD)
+                          (TABLE (CDR HEAD)))
+                     USED-PACKAGE-LOOP
+                         [COND
+                            ((OR DONE (NULL TABLE))
+                             (RETURN (PROGN (CL:VALUES NIL NIL]
+                         [PROGN (LET ((INDEX (LOOKUP-SYMBOL (CAR TABLE)
+                                                    STRING HASH EHASH)))
+                                                             (* ; "CL::%%PACKAGE-INTERNAL-SYMBOLS")
+                                     (COND
+                                        (INDEX (COND
+                                                  ((NEQ PREV HEAD)
+                                                   (LET* ((A0347 PREV)
+                                                          (A0346 (CDR A0347))
+                                                          (A0349 TABLE)
+                                                          (A0348 (CDR A0349))
+                                                          (A0351 HEAD)
+                                                          (A0350 (CDR A0351)))
+                                                         (CDR (RPLACD A0347 A0348))
+                                                         (CDR (RPLACD A0349 A0350))
+                                                         (CDR (RPLACD A0351 TABLE))
+                                                         A0346)))
+                                               (SETQ SYM INDEX)
+                                               (SETQ WHERE :INHERITED)
+                                               (SETQ DONE T))
+                                        (T]
+                         (PROGN (SETQ PREV (PROG1 TABLE
+                                               (PROGN (SETQ TABLE (CDR TABLE))
+                                                      NIL)))
+                                NIL)
+                         (GO USED-PACKAGE-LOOP]
+          (LOCAL (CL:VALUES SYM WHERE])
+
+(PACKAGE.NAME
+  [LAMBDA (RMPKG)                                        (* ; "Edited 12-Feb-87 17:29 by raf")
+    (AND RMPKG (\UNCOPY (\GETBASEPTR RMPKG 4])
+)
+
+
+
+(* ; "See \PNAMELIMIT comment below")
+
+
+(RPAQQ \PNAMELIMIT 255)
+
+(RPAQ? \PNAMES.IN.BLOCKS? )
+
+
+
+(* ;; "Flag for the closure cache")
+
+
+(RPAQ? SI::*CLOSURE-CACHE-ENABLED* )
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS SI::*CLOSURE-CACHE-ENABLED*)
+)
+(DEFINEQ
+
+(\DEFINEDP
+  [LAMBDA (A)                                            (* edited%: " 3-Apr-85 19:45")
+    (AND (LITATOM A)
+         (fetch (LITATOM DEFPOINTER) of A)
+         T])
+
+(PUTD
+  [LAMBDA (FN DEF FLG)                        (* ; 
+                                                "Edited  5-Aug-93 10:19 by sybalskY:MV:ENVOS")
+    (PROG1 DEF
+        [COND
+           ((NOT (LITATOM FN))
+            (\ILLEGAL.ARG FN))
+           ([NOT (OR (LISTP DEF)
+                     (NULL DEF)
+                     (TYPEP DEF 'COMPILED-CLOSURE]
+            (\ILLEGAL.ARG DEF))
+           ((AND (NULL FLG)
+                 (TYPEP DEF 'COMPILED-CLOSURE)
+                 (NEQ (fetch (COMPILED-CLOSURE FRAMENAME) of DEF)
+                      FN))                                   (* ; 
+                                    "Definition being stored has a different frame name, so fix it")
+            (SETQ DEF (\RENAMEDFN DEF FN]
+        (\PUTD FN DEF))])
+
+(\PUTD
+  [LAMBDA (FN DEF)                                       (* lmm " 7-Nov-86 03:54")
+    (LET ((DCELL (fetch (LITATOM DEFINITIONCELL) of FN)))
+         (UNINTERRUPTABLY
+             (PROG ((DVAL DEF)
+                    CODEBASE)
+                   (COND
+                      [(TYPEP DVAL 'COMPILED-CLOSURE)
+                       (SETQ CODEBASE (fetch (COMPILED-CLOSURE FNHEADER) of DVAL))
+                       (replace (DEFINITIONCELL PSEUDOCODEP) of DCELL with NIL)
+                       (COND
+                          ((fetch (COMPILED-CLOSURE ENVIRONMENT) of DVAL)
+                                                             (* ; 
+                                                     "Full closure, have to store it as non-ccodep")
+                           (replace CCODEP of DCELL with NIL)
+                           (GO CLOSURE))
+                          (T                                 (* ; "Strip out code base")
+                             (SETQ DVAL CODEBASE]
+                      ((AND (ARRAYP DVAL)
+                            (EQ (fetch (ARRAYP TYP) of DVAL)
+                                \ST.CODE))                   (* ; 
+                                              "Code array -- only from the code reader or compiler")
+                       (SETQ CODEBASE (SETQ DVAL (fetch (ARRAYP BASE) of DVAL)))
+                       (replace (DEFINITIONCELL PSEUDOCODEP) of DCELL with NIL))
+                      (T (GO EXPR)))
+               CODE
+                   (replace (DEFINITIONCELL CCODEP) of DCELL with T)
+               CLOSURE
+                   (replace (DEFINITIONCELL ARGTYPE) of DCELL with (fetch
+                                                                                (FNHEADER ARGTYPE)
+                                                                                  of CODEBASE))
+                   (replace (DEFINITIONCELL FASTP) of DCELL with
+                                                                    (EQ 0 (fetch (FNHEADER NTSIZE
+                                                                                            )
+                                                                             of CODEBASE)))
+                   (replace (DEFINITIONCELL DEFPOINTER) of DCELL with DVAL)
+                   (RETURN DEF)
+               EXPR
+                   (replace (DEFINITIONCELL DEFCELLFLAGS) of DCELL with 0)
+                   (replace (DEFINITIONCELL DEFPOINTER) of DCELL with DVAL)
+                   (RETURN DEF)))])
+
+(GETD
+  [LAMBDA (A)                                            (* ; "Edited  7-Jan-88 15:47 by jop")
+    (IF (LITATOM A)
+        THEN (LET* ((A (fetch (LITATOM DEFINITIONCELL) of A))
+                        (DEF (fetch (DEFINITIONCELL DEFPOINTER) of A)))
+                       (COND
+                          ((NOT (fetch (DEFINITIONCELL CCODEP) of A))
+                           DEF)
+                          (SI::*CLOSURE-CACHE-ENABLED* (SI::GET-CACHE-CLOSURE DEF))
+                          (T (create COMPILED-CLOSURE
+                                    FNHEADER _ DEF])
+
+(PUTDEFN
+  [LAMBDA (FN CA SIZE)                                   (* edited%: " 3-Apr-85 19:55")
+                                                             (* ; 
+                                          "special version of PUTD that runs only at MAKEINIT time")
+    (PROG ((DCELL (fetch (LITATOM DEFINITIONCELL) of FN))
+           [BLOCKINFO (PROGN 
+                             (* ;; "Reserve enough space.  FILECODEBLOCK leaves file pointing at first data word, so BASE is set to that below.  BLOCKINFO is used for setting block trailer.")
+
+                             (FILECODEBLOCK (FOLDHI SIZE BYTESPERCELL)
+                                    (fetch (CODEARRAY ALIGNED) of CA]
+           (BASE (FILEARRAYBASE)))
+          (replace (DEFINITIONCELL DEFPOINTER) of DCELL with BASE)
+          (replace (DEFINITIONCELL ARGTYPE) of DCELL with (fetch (CODEARRAY ARGTYPE)
+                                                                         of CA))
+          (replace (DEFINITIONCELL FASTP) of DCELL with (EQ (fetch (CODEARRAY NTSIZE)
+                                                                           of CA)
+                                                                        0))
+          (replace (DEFINITIONCELL CCODEP) of DCELL with T)
+          (replace (DEFINITIONCELL PSEUDOCODEP) of DCELL with NIL)
+          [COND
+             ((FMEMB FN LOCKEDFNS)
+              (\LOCKCELL DCELL 1)
+              (\LOCKCELL BASE (FOLDHI (IPLUS (fetch (POINTER WORDINPAGE) of BASE)
+                                             (FOLDHI SIZE BYTESPERWORD))
+                                     WORDSPERPAGE]
+          [COND
+             ((EQ FN (LOCAL (FUNCTION \RESETSTACK)))         (* ; 
+                                  "special kludge to remember where \RESETSTACK is in the MAKEINIT")
+              (SETQ RESETPTR (FILEARRAYBASE))
+              (SETQ RESETPC (fetch (CODEARRAY STARTPC) of CA]
+          (AOUT CA 0 SIZE OUTX 'CODE)
+          (BOUTZEROS (MODUP SIZE BYTESPERCELL))
+          (FILEBLOCKTRAILER BLOCKINFO])
+
+(GETDEFN
+  [LAMBDA (A)                                            (* lmm "20-AUG-81 12:17")
+    (fetch (LITATOM DEFPOINTER) of A])
+)
+(DEFINEQ
+
+(\STKMIN
+  [LAMBDA (CODE CODEISBLOCK PRINT)
+    (DECLARE (LOCALVARS . T))                        (* ; "Edited 10-Nov-88 17:01 by jds")
+
+    (* ;; "compute minimum stack space to run in this function, for either D-machine (which checks at every opcode) or Maiko (which only checks at a selected number of opcodes.")
+
+    (* ;; "this function is tightly coded because it is executed every function loaded")
+
+    (ALLOCAL
+     (PROGN
+
+      (* ;; "can be run renamed but will work on local space.")
+
+      [if (NOT \OPSTACKEFFECT)
+          then
+          (SETQ \OPSTACKEFFECT (\ALLOCBLOCK (FOLDHI 256 BYTESPERCELL)))
+          (SETQ \OPLENGTH (\ALLOCBLOCK (FOLDHI 256 BYTESPERCELL)))
+          [for I from 0 to 255
+             do
+             (\PUTBASEBYTE
+              \OPSTACKEFFECT I
+              (- 2 (LET ((OP (\FINDOP I))
+                         LEVADJ)
+                        (SELECTQ (fetch (OPCODE OPCODENAME)
+                                        OP)
+                            ((FN0 FN1 FN2 FN3 FN4 FNX SWAP NOP APPLYFN RETURN) 
+                                 2)
+                            ((UNBIND DUNBIND UNWIND POP.N) 
+                                 -1)
+                            ((BIND SUBRCALL MISCN) 
+                                 1)
+                            (OR (NUMBERP (if (LISTP (SETQ LEVADJ (fetch (OPCODE
+                                                                                         LEVADJ)
+                                                                                    OP)))
+                                                 then (SETQ LEVADJ (CAR LEVADJ))
+                                               else LEVADJ))
+                                (SELECTQ LEVADJ
+                                    ((CJUMP NCJUMP)          (* ; "these only check if they jump")
+                                         -1)
+                                    ((JUMP) 
+                                         2)
+                                    (PROGN 2]
+          (for I from 0 to 255 do (\PUTBASEBYTE \OPLENGTH I
+                                                         (ADD1 (OR (CADDR (\FINDOP I))
+                                                                   -1]
+      [IF (NOT CODEISBLOCK)
+          THEN (SETQ CODE (OR (\GET-COMPILED-CODE-BASE CODE)
+                                  (fetch (ARRAYP BASE)
+                                         CODE]
+      (LLSH (PROG (MAX OP STKE (PC (fetch (FNHEADER STARTPC)
+                                          CODE))
+                       (DEPTH (IPLUS (IMAX (fetch (FNHEADER NA) of CODE)
+                                           0)
+                                     8
+                                     (UNFOLD (ADD1 (fetch (FNHEADER PV) of CODE))
+                                            CELLSPERQUAD)
+                                     4)))
+                  (SETQ MAX (PLUS DEPTH 8))
+
+             (* ;; 
+           "this PROG computes the depth in cells. The llsh around converts it to D-machine words.")
+
+             (* ;; "the initial maximum is the actual size of the frame, plus 4 extra cells for space to store info in case of an overflow. The default maximum is 8 more than that. By walking the code, it finds if there are any other runs that would increase it beyond that. At jumps or %"Maiko check%" opcodes, the depth is reset to 0.  ")
+
+              LP  (if (EQ 0 (SETQ OP (\GETBASEBYTE CODE PC)))
+                      then 
+
+                            (* ;; "end of the function")
+
+                            (RETURN MAX))
+
+             (* ;; "the following is for debugging")
+
+                  (AND PRINT (CL:FORMAT T "~%%~3o: ~3o d<~3d> mx<~3d>" PC OP DEPTH MAX))
+                  (SELECTQ (SETQ STKE (- 2 (\GETBASEBYTE \OPSTACKEFFECT OP)))
+                      (2 
+                         (* ;; "special code indicating that this opcode checks the stack level")
+
+                         (AND PRINT (PRIN1 "*"))
+                         (SETQ DEPTH 0))
+                      (add DEPTH STKE))
+                  (if (GREATERP DEPTH MAX)
+                      then (SETQ MAX DEPTH))
+                  (CL:INCF PC (\GETBASEBYTE \OPLENGTH OP))
+                  (GO LP))
+            1])
+)
+
+(RPAQ? \OPSTACKEFFECT )
+
+(RPAQ? \OPLENGTH )
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \OPSTACKEFFECT \OPLENGTH)
+)
+
+(RPAQQ COMPILEATPUTDFLG NIL)
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
+
+(ACCESSFNS LITATOM ((DEFINITIONCELL (\DEFCELL DATUM))
+                        (PROPCELL (\PROPCELL DATUM))
+                        (VCELL (\VALCELL DATUM))
+                        (PNAMECELL (\PNAMECELL DATUM)))
+
+                       (* ;; "VCELL can also be accessed directly from a value index via the record VALINDEX (as in \SETGLOBALVAL.UFN) --- Similarly, PNAMEINDEX accesses PNAMECELL for use by \MKATOM and UNCOPYATOM")
+
+                       (TYPE? (LITATOM DATUM))
+                       (BLOCKRECORD PROPCELL ((NIL BITS 4) (* ; "former flags locations")
+                                              (PROPLIST POINTER)
+                                              (NIL BITS 8) (* ; "Package byte")
+                                              (NIL BITS 8) (* ; "Flags from defcell")
+
+                                              (* ;; "PROPCell flags:")
+
+                                              (NIL BITS 1)
+                                              (GENSYMP FLAG)
+                                              (FATPNAMEP FLAG)
+                                              (NIL BITS 5)
+
+                                              (* ;; "Filler for final cell:")
+
+                                              (NIL BITS 8))))
+
+(SYNONYM CL:SYMBOL (LITATOM))
+
+(ACCESSFNS VALINDEX [(VCELL (COND
+                                   [(AND (FIXP DATUM)
+                                         (ILESSP DATUM 65535))
+                                                             (* ; "Xerox Lisp traditional symbol")
+                                    (\ADDBASE2 \PNPSPACE (IPLUS \NEWATOM-VALOFFSET (ITIMES 10 DATUM]
+                                   (T                        (* ; "New symbol")
+                                                             (* ; "'90/07/19 ON")
+                                      (\ADDBASE DATUM \NEWATOM-VALOFFSET])
+
+(BLOCKRECORD VCELL ((VALUE FULLPOINTER)))
+
+(BLOCKRECORD DEFINITIONCELL ((CCODEP FLAG)
+                                 (FASTP FLAG)
+                                 (ARGTYPE BITS 2)            (* ; "Former flag location")
+                                 (DEFPOINTER POINTER)
+                                 (NIL POINTER)             (* ; "Proplist cell")
+                                 (NIL BITS 8)              (* ; "package")
+
+                                 (* ;; "DEFCELL flags overflow from top 4 bits of the real cell:")
+
+                                 (NIL BITS 4)
+                                 (PSEUDOCODEP FLAG)
+                                 (NIL BITS 3)
+
+                                 (* ;; "proplist falgs and filler:")
+
+                                 (NIL BITS 16))
+                                (BLOCKRECORD DEFINITIONCELL ((DEFCELLFLAGS BITS 4)
+                                                             (NIL POINTER)
+                                                             (* ; "defn ptr")
+                                                             (NIL BITS 4)
+                                                             (NIL POINTER)
+                                                             (* ; "filler for proplist ptr")
+                                                             (NIL BITS 8)
+                                                             (AUXDEFCELLFLAGS BYTE)
+                                                             (NIL BITS 16))))
+
+(BLOCKRECORD FNHEADER ((STKMIN WORD)
+                           (NA SIGNEDWORD)
+                           (PV SIGNEDWORD)
+                           (STARTPC WORD)
+                           (CLOSUREP FLAG)                   (* ; 
+                                                           "T if this is a %"compiled closure%"")
+                           (BYTESWAPPED FLAG)                (* ; 
+                  "T if, on 386, we reswapped the code section of this function for faster access.")
+                           (ARGTYPE BITS 2)                  (* ; "0 = LAMBDA")
+                                                             (* ; "2 = LAMBDA nospread")
+                                                             (* ; "1 = NLAMBDA")
+                                                             (* ; "3 = NLAMBDA nospread")
+
+                           (* ;; "4 NIL BITS USED TO BE HERE.")
+
+                           (%#FRAMENAME XPOINTER)
+                           (NTSIZE WORD)                     (* ; "Size of the Name Table, IN WORDS.  This value is always rounded up to the next Quad-word in size, and there' guaranteed to be one entry of zeros in the length.")
+                           (NLOCALS BYTE)
+                           (FVAROFFSET BYTE))
+                          [ACCESSFNS FNHEADER ((LSTARP (ILESSP (fetch (FNHEADER NA) of DATUM)
+                                                              0))
+                                               (OVERHEADWORDS (PROGN 8))
+                                               (NATIVE (PROGN NIL))
+                                                             (* ; 
+                                                "T if this is a NATIVE-code function (never true!)")
+                                               (ALIGNED (IPLUS (fetch (FNHEADER NTSIZE)
+                                                                  of DATUM)
+                                                               (fetch (FNHEADER OVERHEADWORDS)
+                                                                  of T)))
+                                               (FIXED NIL (replace (FNHEADER STKMIN)
+                                                               of DATUM with (\STKMIN DATUM T
+                                                                                            )))
+                                               (NPVARWORDS (UNFOLD (ADD1 (fetch (FNHEADER PV)
+                                                                            of DATUM))
+                                                                  WORDSPERQUAD))
+                                               (FRAMENAME (fetch (FNHEADER %#FRAMENAME)
+                                                             of DATUM)
+                                                      (UNINTERRUPTABLY
+                                                          (CHECK (NEQ (\HILOC DATUM)
+                                                                      \STACKHI))
+                                                          (\DELREF (fetch (FNHEADER %#FRAMENAME)
+                                                                      of DATUM))
+                                                          (\ADDREF NEWVALUE)
+                                                          (replace (FNHEADER %#FRAMENAME)
+                                                             of DATUM with NEWVALUE))])
+
+(BLOCKRECORD PNAMECELL ((NIL BITS 4)
+                            (PNAMEBASE XPOINTER)
+                            (NIL POINTER)                  (* ; "val, def, prop cells")
+                            (NIL POINTER)
+                            (NIL POINTER)
+                            (PACKAGEINDEX BYTE)
+                            (NIL BITS 24)                  (* ; "filler for other flags")
+                            )
+                           (BLOCKRECORD PNAMECELL ((FULLPNAMEBASE FULLXPOINTER)
+                                                             (* ; 
+                                                         "Replacing this smashes PACKAGEINDEX to 0")
+                                                   ))
+                           [ACCESSFNS PNAMECELL ((PACKAGE [LET ((I (FETCH (PNAMECELL PACKAGEINDEX
+                                                                                     ) OF DATUM))
+                                                                )
+                                                             (* ; "This ugly construct allows cl:symbol-package to run in the init, where *PACKAGE-FROM-INDEX* is not yet bound.")
+                                                               (COND
+                                                                  ((EQ 0 I)
+                                                                   NIL)
+                                                                  (T (CL:AREF *PACKAGE-FROM-INDEX* I]
+                                                        (REPLACE (PNAMECELL PACKAGEINDEX)
+                                                           OF DATUM
+                                                           WITH (IF (NULL NEWVALUE)
+                                                                        THEN 
+                                                                           *UNINTERNED-PACKAGE-INDEX*
+                                                                      ELSE (CL::%%PACKAGE-INDEX
+                                                                                NEWVALUE])
+
+(ACCESSFNS PACKAGEINDEX [(PACKAGE (IF (EQ 0 DATUM)   (* ; "This ugly construct allows cl:symbol-package to run in the init, where *PACKAGE-FROM-INDEX* is not yet bound.")
+                                          THEN NIL
+                                        ELSE (CL:AREF *PACKAGE-FROM-INDEX* DATUM])
+
+(BLOCKRECORD PNAMEBASE ((PNAMELENGTH BYTE)               (* ; 
+                                                  "Length is always here, be the pname thin or fat")
+                            (PNAMEFATPADDINGBYTE BYTE)       (* ; 
+                        "This byte is zero for fat pnames so that the pname chars are word-aligned")
+                            ))
+
+(ACCESSFNS PNAMEINDEX [(PNAMECELL (COND
+                                         [(AND (FIXP DATUM)
+                                               (ILESSP DATUM 65535))
+                                                             (* ; "Xerox Lisp traditional symbol")
+                                          (\ADDBASE \PNPSPACE (IPLUS \NEWATOM-PNAMEOFFSET
+                                                                     (ITIMES 10 DATUM]
+                                         (T                  (* ; "New symbol")
+                                                             (* ; "'90/07/19 ON")
+                                            (\ADDBASE DATUM \NEWATOM-PNAMEOFFSET])
+)
+(DECLARE%: EVAL@COMPILE
+
+(BLOCKRECORD NEW-ATOM (
+                           (* ;; 
+                         "An extended symbol, for expanding atom space.  Kept in its own datatype.")
+
+                           (PNAME XPOINTER)                  (* ; "PNAME, same as litatom.")
+                           (VALUE POINTER)
+                           (DEF POINTER)
+                           (PROPLIST POINTER)
+
+                           (* ;; 
+                         "Flags that used to be above the pointers, e.g. package, ccodep, gensymp:")
+
+                           (NIL BITS 32)))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \DEFCELL MACRO ((ATOM)
+                                  (\ATOMCELL ATOM \DEF.HI)))
+
+(PUTPROPS \VALCELL MACRO ((ATOM)
+                                  (\ATOMCELL ATOM \VAL.HI)))
+
+(PUTPROPS \PNAMECELL MACRO ((ATOM)
+                                    (\ATOMCELL ATOM \PNAME.HI)))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \ATOMVALINDEX DMACRO [OPENLAMBDA (X)
+                                              (COND
+                                                 ((EQ (NTYPX X)
+                                                      \LITATOM)
+                                                             (* ; "Original litatoms")
+                                                  (\LOLOC X))
+                                                 ((EQ (NTYPX X)
+                                                      \NEW-ATOM)
+                                                             (* ; "new 3-byte symbols")
+                                                  X)
+                                                 (T (SHOULDNT])
+
+(PUTPROPS \ATOMDEFINDEX DMACRO [OPENLAMBDA (X)
+                                              (COND
+                                                 ((EQ (NTYPX X)
+                                                      \LITATOM)
+                                                             (* ; "Original litatoms")
+                                                  (\LOLOC X))
+                                                 ((EQ (NTYPX X)
+                                                      \NEW-ATOM)
+                                                             (* ; "new 3-byte symbols")
+                                                  X)
+                                                 (T (SHOULDNT])
+
+(PUTPROPS \ATOMPNAMEINDEX DMACRO [OPENLAMBDA (X)
+                                                (COND
+                                                   ((EQ (NTYPX X)
+                                                        \LITATOM)
+                                                             (* ; "Original litatoms")
+                                                    (\LOLOC X))
+                                                   ((EQ (NTYPX X)
+                                                        \NEW-ATOM)
+                                                             (* ; "new 3-byte symbols")
+                                                    X)
+                                                   (T (SHOULDNT])
+
+(PUTPROPS \ATOMPROPINDEX DMACRO [(X)
+                                         (COND
+                                            ((EQ (NTYPX X)
+                                                 \LITATOM)   (* ; "Original litatoms")
+                                             (\LOLOC X))
+                                            ((EQ (NTYPX X)
+                                                 \NEW-ATOM)  (* ; "new 3-byte symbols")
+                                             X)
+                                            (T (SHOULDNT])
+
+(PUTPROPS \INDEXATOMPNAME DMACRO (OPENLAMBDA (X)
+                                                (COND
+                                                   [(FIXP X)
+                                                             (* ; "Xerox Lisp traditional symbol")
+                                                    (COND
+                                                       ((SMALLP X)
+                                                        (\VAG2 \AtomHI X))
+                                                       (T (\VAG2 (LRSH X 16)
+                                                                 (LOGAND X 65535]
+                                                   (T        (* ; "New symbol")
+                                                      X))))
+
+(PUTPROPS \INDEXATOMVAL DMACRO (OPENLAMBDA (X)
+                                              (COND
+                                                 [(FIXP X)
+                                                             (* ; "Xerox Lisp traditional symbol")
+                                                  (COND
+                                                     ((SMALLP X)
+                                                      (\VAG2 \AtomHI X))
+                                                     (T (\VAG2 (LRSH X 16)
+                                                               (LOGAND X 65535]
+                                                 (T          (* ; "New symbol")
+                                                    X))))
+
+(PUTPROPS \INDEXATOMDEF DMACRO (OPENLAMBDA (X)
+                                              (COND
+                                                 [(FIXP X)
+                                                             (* ; "Xerox Lisp traditional symbol")
+                                                  (COND
+                                                     ((SMALLP X)
+                                                      (\VAG2 \AtomHI X))
+                                                     (T (\VAG2 (LRSH X 16)
+                                                               (LOGAND X 65535]
+                                                 (T          (* ; "New symbol")
+                                                    X))))
+
+(PUTPROPS \ATOMNUMBER DMACRO (= . \LOLOC))
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \NxtPnByte \CurPnPage \NxtAtomPage \AtomFrLst \OneCharAtomBase \PNAMES.IN.BLOCKS? 
+       \SCRATCHSTRING COMPILEATPUTDFLG)
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \PNAMELIMIT 255)
+
+(RPAQQ \CharsPerPnPage 512)
+
+
+(CONSTANTS (\PNAMELIMIT 255)
+       (\CharsPerPnPage 512))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \NEWATOM-PNAMEOFFSET 0)
+
+(RPAQQ \NEWATOM-VALOFFSET 2)
+
+(RPAQQ \NEWATOM-DEFOFFSET 4)
+
+(RPAQQ \NEWATOM-PLISTOFFSET 6)
+
+(RPAQQ \NEWATOM-TYPE# 21)
+
+
+(CONSTANTS (\NEWATOM-PNAMEOFFSET 0)
+       (\NEWATOM-VALOFFSET 2)
+       (\NEWATOM-DEFOFFSET 4)
+       (\NEWATOM-PLISTOFFSET 6)
+       (\NEWATOM-TYPE# 21))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS COMPUTE.ATOM.HASH MACRO [(BASE OFFST LEN FIRSTBYTE FATP)
+                                                             (* ; 
+                                              "Sets variable HASH to atom hash of indicated string")
+                                           (SETQ HASH (LLSH FIRSTBYTE 8))
+                                           (for CHAR# from (ADD1 OFFST)
+                                              to (SUB1 (IPLUS OFFST LEN))
+                                              do (SETQ HASH
+                                                      (IPLUS16 (IPLUS16 (SETQ HASH
+                                                                         (IPLUS16 HASH
+                                                                                (LLSH (LOGAND HASH 
+                                                                                             4095)
+                                                                                      2)))
+                                                                      (LLSH (LOGAND HASH 255)
+                                                                            8))
+                                                             (UNLESSRDSYS
+                                                              (COND
+                                                                 (FATP (LOGAND (\GETBASEFAT BASE 
+                                                                                      CHAR#)
+                                                                              255))
+                                                                 (T (\GETBASETHIN BASE CHAR#)))
+                                                              (NTHCHARCODE BASE CHAR#])
+
+(PUTPROPS ATOM.HASH.REPROBE MACRO [(HASH FIRSTBYTE)
+                                           (LOGAND 63 (LOGOR 1 (LOGXOR FIRSTBYTE HASH])
+)
+
+
+(ADDTOVAR DONTCOMPILEFNS INITATOMS COPYATOM UNCOPYATOM READATOM MAKE.LOCAL.ATOM SYMBOL.VALUE 
+                                   SYMBOL.PNAME SYMBOL.PACKAGE OLD.FIND.SYMBOL LOOKUP-SYMBOL 
+                                   FIND.PACKAGE FIND.SYMBOL PACKAGE.NAME GETDEFN PUTDEFN FSETVAL)
+)
+
+
+
+(* ; "for executing boot expressions when first run")
+
+(DEFINEQ
+
+(\RESETSYSTEMSTATE
+  [LAMBDA NIL                                            (* rmk%: " 5-JUN-81 17:32")
+    (\KEYBOARDON T)
+    (\RESETTERMINAL])
+
+(INITIALEVALQT
+  [LAMBDA NIL                                            (* bvm%: "21-APR-83 12:02")
+    (DECLARE (GLOBALVARS BOOTFILES))
+    (\SETIOPOINTERS)
+    (PROG ((RL BOOTFILES)
+           FL L)
+          (OR RL (RETURN))
+          (SIMPLEPRINT "evaluating initial expressions:
+")                                                           (* ; 
+                                             "BOOTFILES is the list of boot files in reverse order")
+      R   (SETQ FL (CONS (CAR RL)
+                         FL))
+          (COND
+             ((SETQ RL (CDR RL))
+              (GO R)))
+      L1  [COND
+             ([LISTP (SETQ L (GETTOPVAL (CAR FL]
+              (SIMPLEPRINT (CAR FL))                     (* Print the name of the bootfile)
+              (DSPBOUT (CHARCODE CR))
+              (PROG NIL
+                L2  [EVAL (PROG1 (CAR L)
+                              (SETTOPVAL (CAR FL)
+                                     (SETQ L (CDR L))))]
+                    (AND (LISTP L)
+                         (GO L2)))
+              (SETTOPVAL (CAR FL)
+                     'NOBIND]
+          (COND
+             ((SETQ FL (CDR FL))
+              (GO L1)))
+          (SETQ BOOTFILES NIL)
+          (INTERPRET.REM.CM)                                 (* See if command line has anything 
+                                                           to say)
+      )                                                      (* ; 
+            "Value is T so that correct value is returned when this is called from within COPYSYS0")
+    T])
+
+(SIMPLEPRINT
+  [LAMBDA (X N)                                          (* bvm%: "13-Feb-85 22:25")
+    (COND
+       [(OR (LITATOM X)
+            (STRINGP X))
+        (for I from 1 to (NCHARS X) do (DSPBOUT (NTHCHARCODE X I]
+       ((LISTP X)
+        (COND
+           ((EQ N 0)
+            (SIMPLEPRINT "&"))
+           (T (DSPBOUT (CHARCODE %())
+              (PROG NIL
+                LP  [SIMPLEPRINT (CAR X)
+                           (SETQ N (COND
+                                      ((SMALLPOSP N)
+                                       (SUB1 N))
+                                      (T 3]
+                    (COND
+                       ((EQ N 0)
+                        (SIMPLEPRINT " --)"))
+                       ((NULL (SETQ X (CDR X)))
+                        (SIMPLEPRINT ")"))
+                       ((NLISTP X)
+                        (SIMPLEPRINT " . ")
+                        (SIMPLEPRINT X)
+                        (SIMPLEPRINT ")"))
+                       (T (SIMPLEPRINT " ")
+                          (GO LP])
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS RESETFORMS BOOTFILES)
+)
+
+
+
+(* ; "stats")
+
+(DEFINEQ
+
+(PAGEFAULTS
+  [LAMBDA NIL                                            (* rrb "13-NOV-80 15:36")
+    (DECLARE (GLOBALVARS \MISCSTATS))
+    (fetch PAGEFAULTS of \MISCSTATS])
+
+(\SETTOTALTIME
+  [LAMBDA NIL                                            (* JonL "17-Dec-83 00:23")
+                                                             (* ; 
+                                             "updates the total time field of the misc stats page.")
+    (\BOXIPLUS (LOCF (fetch TOTALTIME of \MISCSTATS))
+           (CLOCKDIFFERENCE (fetch STARTTIME of \MISCSTATS])
+
+(\SERIALNUMBER
+  [LAMBDA NIL                                            (* rmk%: " 9-JUN-81 14:49")
+    (fetch (IFPAGE SerialNumber) of \InterfacePage])
+)
+
+
+
+(* ; "Fast functions for moving and clearing storage")
+
+(DEFINEQ
+
+(\BLT
+  [LAMBDA (DBASE SBASE NWORDS)                           (* lmm "30-Mar-85 05:43")
+                                                             (* ; 
+              "Generally in ucode -- must guarantee transferral by moving high-order address first")
+    (PROG [(NN (CONSTANT (EXPT 2 14]
+          (RETURN (COND
+                     ((GREATERP NWORDS NN)                   (* ; 
+                                                         "dorado has microcode only for up to 2^15")
+                      (\BLT (\ADDBASE DBASE NN)
+                             (\ADDBASE SBASE NN)
+                             (DIFFERENCE NWORDS NN))
+                      (\BLT DBASE SBASE NN))
+                     (T (for I from (SUB1 NWORDS) by -1 to 0
+                           do (\PUTBASE DBASE I (\GETBASE SBASE I)))
+                        DBASE])
+
+(\MOVEBYTES
+  [LAMBDA (SBASE SBYTE DBASE DBYTE NBYTES)               (* rmk%: "23-OCT-82 14:24")
+                                                             (* ; 
+                                                           "Simple version for bootstrapping")
+    (COND
+       ((IGREATERP NBYTES 0)
+        (PROG ((SB (\ADDBASE SBASE (FOLDLO SBYTE BYTESPERWORD)))
+               (DB (\ADDBASE DBASE (FOLDLO DBYTE BYTESPERWORD)))
+               SBN DBN NWORDS)
+              (COND
+                 [(EQ (SETQ SBN (IMOD SBYTE BYTESPERWORD))
+                      (SETQ DBN (IMOD DBYTE BYTESPERWORD)))  (* ; "Can move words")
+                  (COND
+                     ((EQ SBN 1)
+                      (\PUTBASEBYTE DB 1 (\GETBASEBYTE SB 1))
+                      (SETQ DB (\ADDBASE DB 1))
+                      (SETQ SB (\ADDBASE SB 1))
+                      (add NBYTES -1)))
+                  (\BLT DB SB (SETQ NWORDS (FOLDLO NBYTES BYTESPERWORD)))
+                  (COND
+                     ((EQ (IMOD NBYTES BYTESPERWORD)
+                          1)
+                      (\PUTBASEBYTE (\ADDBASE DB NWORDS)
+                             0
+                             (\GETBASEBYTE (\ADDBASE SB NWORDS)
+                                    0]
+                 (T (FRPTQ NBYTES (\PUTBASEBYTE DB (PROG1 DBN (add DBN 1))
+                                         (\GETBASEBYTE SB (PROG1 SBN (add SBN 1])
+
+(\CLEARWORDS
+  [LAMBDA (BASE NWORDS)                                  (* bvm%: "20-Feb-85 12:30")
+    (PROG1 BASE
+        (while (IGREATERP NWORDS 32767) do 
+
+                                          (* ;; "BLT wants NWORDS to be small.  We play it safe by keeping the count smaller than 2^15, avoiding a Dorado uCode bug")
+
+                                                  (.CLEARNWORDS. BASE 32768)
+                                                  (SETQ BASE (\ADDBASE BASE 32768))
+                                                  (SETQ NWORDS (IDIFFERENCE NWORDS 32768)))
+        (COND
+           ((IGREATERP NWORDS 0)
+            (.CLEARNWORDS. BASE NWORDS))))])
+
+(\CLEARBYTES
+  [LAMBDA (BASE OFFST NBYTES)                            (* bvm%: "29-Jan-85 18:56")
+    (COND
+       ((IGREATERP NBYTES 0)
+        (COND
+           ((ODDP OFFST)
+            (\PUTBASEBYTE BASE OFFST 0)
+            (add OFFST 1)
+            (add NBYTES -1)))                            (* ; "OFFST is now even")
+        (SETQ BASE (\ADDBASE BASE (FOLDLO OFFST BYTESPERWORD)))
+        (COND
+           ((ODDP NBYTES)                                    (* ; "Final byte to be zeroed")
+            (\PUTBASEBYTE BASE (SUB1 NBYTES)
+                   0)))                                      (* ; 
+                                "Now all we have to do is zero the word-aligned part in the middle")
+        (\CLEARWORDS BASE (FOLDLO NBYTES BYTESPERWORD])
+
+(\CLEARCELLS
+  [LAMBDA (BASE NCELLS)                                  (* bvm%: "20-Feb-85 12:51")
+    [while (IGEQ NCELLS (FOLDLO 32767 WORDSPERCELL)) do 
+                                                             (* ; 
+                                                           "Keep the BLTs small.  See \CLEARWORDS")
+                                                               (.CLEARNWORDS. BASE 32768)
+                                                               (SETQ BASE (\ADDBASE BASE 32768))
+                                                               (SETQ NCELLS (IDIFFERENCE NCELLS
+                                                                                   (FOLDLO 32768 
+                                                                                         WORDSPERCELL
+                                                                                          ]
+    (COND
+       ((IGREATERP NCELLS 0)
+        (SETQ NCELLS (UNFOLD NCELLS WORDSPERCELL))
+        (.CLEARNWORDS. BASE NCELLS])
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS .CLEARNWORDS. MACRO (OPENLAMBDA (BASE NWORDS)
+
+                                 (* ;; "Clear NWORDS words starting at base.  Assumes NWORDS is smallp and greater than zero.  Compiler refuses to optimize out an IGREATERP test here, so push back to caller")
+
+                                             (\PUTBASE BASE (SUB1 NWORDS)
+                                                    0)
+                                             [COND
+                                                ((NEQ NWORDS 1)
+                                                 (\BLT BASE (\ADDBASE BASE 1)
+                                                        (SUB1 NWORDS]
+                                             NIL))
+)
+)
+
+
+
+(* ; "Obsolete")
+
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \MOVEWORDS MACRO (OPENLAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS)
+                                          (\BLT (\ADDBASE DBASE DOFFSET)
+                                                 (\ADDBASE SBASE SOFFSET)
+                                                 NWORDS)))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+(DEFINEQ
+
+(\MOVEWORDS
+  [LAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS)           (* bvm%: "15-JUN-82 13:56")
+    (\BLT (\ADDBASE DBASE DOFFSET)
+           (\ADDBASE SBASE SOFFSET)
+           NWORDS])
+
+(\ZEROBYTES
+  [LAMBDA (BASE FIRST LAST)                              (* bvm%: "29-Jan-85 19:12")
+    (\CLEARBYTES BASE FIRST (ADD1 (IDIFFERENCE LAST FIRST])
+
+(\ZEROWORDS
+  [LAMBDA (BASE ENDBASE)                                 (* bvm%: "29-Jan-85 12:54")
+    (while (IGREATERP (\HILOC ENDBASE)
+                      (\HILOC BASE)) do (\CLEARWORDS BASE (IDIFFERENCE (SUB1 WORDSPERSEGMENT)
+                                                                         (\LOLOC BASE)))
+                                           (\PUTBASE (\VAG2 (\HILOC BASE)
+                                                            (SUB1 WORDSPERSEGMENT))
+                                                  0 0)       (* ; 
+                              "Done this way to avoid non-SMALLP arithmetic when (\LOLOC BASE) = 0")
+                                           (SETQ BASE (\VAG2 (ADD1 (\HILOC BASE))
+                                                             0)))
+    (PROG [(DIF (IDIFFERENCE (\LOLOC ENDBASE)
+                       (\LOLOC BASE]
+          (COND
+             ((IGEQ DIF 0)
+              (\PUTBASE BASE 0 0)
+              (\CLEARWORDS (\ADDBASE BASE 1)
+                     DIF])
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+(DECLARE%: DONTCOPY 
+
+(ADDTOVAR INITVALUES (\AtomFrLst 0))
+
+(ADDTOVAR INITPTRS (\OneCharAtomBase NIL)
+                       (\SCRATCHSTRING))
+
+(ADDTOVAR INEWCOMS (FNS FSETVAL SETPROPLIST PUTDEFN \BLT)
+                       (FNS \MKATOM \CREATE.SYMBOL \INITATOMPAGE \MOVEBYTES \STKMIN)
+                       (FNS COPYATOM INITATOMS))
+
+(ADDTOVAR EXPANDMACROFNS SMALLPOSP COMPUTE.ATOM.HASH ATOM.HASH.REPROBE \DEFCELL \VALCELL 
+                                   \PNAMECELL \PROPCELL \INDEXATOMPNAME)
+
+(ADDTOVAR MKI.SUBFNS (\PARSE.NUMBER . NILL)
+                         (\MKATOM.FULL . NILL)
+                         (\ATOMDEFINDEX . I.ATOMNUMBER)
+                         (\ATOMVALINDEX . I.ATOMNUMBER)
+                         (\ATOMPROPINDEX . I.ATOMNUMBER)
+                         (\ATOMPNAMEINDEX . I.ATOMNUMBER)
+                         (\ATOMCELL . I.\ATOMCELL)
+                         (\GETBASEFIXP . I.GETBASEFIXP)
+                         (\PUTBASEFIXP . I.PUTBASEFIXP)
+                         (SETQ.NOREF . SETQ)
+                         (SETTOPVAL . I.FSETVAL))
+
+(ADDTOVAR RD.SUBFNS (\PARSE.NUMBER . NILL)
+                        (\ATOMDEFINDEX . VATOMNUMBER)
+                        (\ATOMPROPINDEX . VATOMNUMBER)
+                        (\ATOMVALINDEX . VATOMNUMBER)
+                        (SETQ.NOREF . SETQ)
+                        (\INDEXATOMPNAME . VATOM)
+                        (\INDEXATOMVAL . VATOM)
+                        (\INDEXATOMDEF . VATOM)
+                        (\ATOMNUMBER . VATOMNUMBER)
+                        (\CREATE.SYMBOL . VNOSUCHATOM))
+
+(ADDTOVAR RDCOMS (FNS UNCOPYATOM MAKE.LOCAL.ATOM SYMBOL.VALUE SYMBOL.PNAME SYMBOL.PACKAGE 
+                          OLD.FIND.SYMBOL LOOKUP-SYMBOL FIND.PACKAGE FIND.SYMBOL PACKAGE.NAME \MKATOM
+                          GETTOPVAL GETPROPLIST SETTOPVAL GETDEFN \ATOMCELL)
+                     (FNS LISTP)
+                     (VARS (COPYATOMSTR)))
+
+(ADDTOVAR RD.SUBFNS (\RPLPTR . VPUTBASEPTR))
+
+(ADDTOVAR RDVALS (\AtomFrLst))
+)
+
+(PUTPROPS LLBASIC FILETYPE CL:COMPILE-FILE)
+(PUTPROPS LLBASIC COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 
+1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (9433 11831 (LISTP 9443 . 10026) (LITATOM 10028 . 10295) (FIXP 10297 . 10534) (SMALLP 
+10536 . 10791) (NLISTP 10793 . 11006) (ARRAYP 11008 . 11263) (FLOATP 11265 . 11520) (NUMBERP 11522 . 
+11668) (STACKP 11670 . 11829)) (16122 19624 (GETTOPVAL 16132 . 16288) (SETTOPVAL 16290 . 16659) (
+FSETVAL 16661 . 17008) (\SETGLOBALVAL.UFN 17010 . 17181) (\SETFVAR.UFN 17183 . 17353) (GETPROPLIST 
+17355 . 17515) (\ATOMCELL 17517 . 19442) (SETPROPLIST 19444 . 19622)) (20467 34502 (\MKATOM 20477 . 
+27709) (\CREATE.SYMBOL 27711 . 32008) (\MKATOM.FULL 32010 . 32487) (\INITATOMPAGE 32489 . 34500)) (
+34503 53824 (MAPATOMS 34513 . 48960) (ATOMHASH#PROBES 48962 . 53822)) (55115 83516 (INITATOMS 55125 . 
+57169) (COPYATOM 57171 . 60870) (UNCOPYATOM 60872 . 61669) (MAKE.LOCAL.ATOM 61671 . 62418) (
+SYMBOL.VALUE 62420 . 63193) (SYMBOL.PNAME 63195 . 64349) (SYMBOL.PACKAGE 64351 . 65457) (
+OLD.FIND.SYMBOL 65459 . 72814) (LOOKUP-SYMBOL 72816 . 76010) (FIND.PACKAGE 76012 . 78214) (FIND.SYMBOL
+ 78216 . 83345) (PACKAGE.NAME 83347 . 83514)) (83790 90507 (\DEFINEDP 83800 . 84003) (PUTD 84005 . 
+84817) (\PUTD 84819 . 87535) (GETD 87537 . 88169) (PUTDEFN 88171 . 90349) (GETDEFN 90351 . 90505)) (
+90508 94928 (\STKMIN 90518 . 94926)) (115043 117926 (\RESETSYSTEMSTATE 115053 . 115210) (INITIALEVALQT
+ 115212 . 116817) (SIMPLEPRINT 116819 . 117924)) (118021 118820 (PAGEFAULTS 118031 . 118225) (
+\SETTOTALTIME 118227 . 118644) (\SERIALNUMBER 118646 . 118818)) (118884 123795 (\BLT 118894 . 119792) 
+(\MOVEBYTES 119794 . 121238) (\CLEARWORDS 121240 . 121934) (\CLEARBYTES 121936 . 122740) (\CLEARCELLS 
+122742 . 123793)) (125040 126491 (\MOVEWORDS 125050 . 125253) (\ZEROBYTES 125255 . 125427) (\ZEROWORDS
+ 125429 . 126489)))))
+STOP
diff --git a/CLTL2/LLBASIC.LCOM b/CLTL2/LLBASIC.LCOM
new file mode 100644
index 00000000..7d81a539
Binary files /dev/null and b/CLTL2/LLBASIC.LCOM differ
diff --git a/CLTL2/LLCHAR b/CLTL2/LLCHAR
new file mode 100644
index 00000000..56ca0f96
--- /dev/null
+++ b/CLTL2/LLCHAR
@@ -0,0 +1,1978 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 16:04:12" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLCHAR.;2" 112937 
+
+      previous date%: "30-Jul-91 15:22:33" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLCHAR.;1")
+
+
+(* ; "
+Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT LLCHARCOMS)
+
+(RPAQQ LLCHARCOMS
+       ((FNS ALLOCSTRING MKATOM SUBATOM CHARACTER \PARSE.NUMBER \INVALID.DOTTED.SYMBOL 
+             \INVALID.INTEGER \MKINTEGER MKSTRING \PRINDATUM.TO.STRING BKSYSBUF NCHARS NTHCHARCODE 
+             RPLCHARCODE \RPLCHARCODE NTHCHAR RPLSTRING SUBSTRING GNC GNCCODE GLC GLCCODE STREQUAL 
+             STRING.EQUAL STRINGP CHCON1 U-CASE L-CASE FLIP-CASE U-CASEP L-CASEP U-CASE-STRINGS 
+             \SMASHABLESTRING \MAKEWRITABLESTRING \SMASHSTRING \FATTENSTRING)
+        (COMS                                                (* ; 
+                           "Temporary until low level system is changed to call STRING.EQUAL again")
+              (P (MOVD? 'STRING.EQUAL 'STRING-EQUAL NIL T)
+                 (MOVD? 'STRING.EQUAL 'LISP::SIMPLE-STRING-EQUAL NIL T)))
+        (FNS \GETBASESTRING \PUTBASESTRING \PUTBASESTRINGFAT GetBcplString SetBcplString)
+        (DECLARE%: DONTCOPY (EXPORT (RECORDS STRINGP)
+                                   (GLOBALVARS \OneCharAtomBase)
+                                   (RESOURCES \NUMSTR \NUMSTR1 \PNAMESTRING)
+                                   (CONSTANTS (\FATPNAMESTRINGP T))
+                                   (MACROS \PNAMESTRINGPUTCHAR)
+                                   (OPTIMIZERS FCHARACTER)
+                                   (I.S.OPRS inpname inatom instring)
+                                                             (* ; 
+                       "For use when the inner-loop test in the generic operators is too expensive")
+                                   (I.S.OPRS infatatom inthinatom infatstring inthinstring)
+                                   (MACROS \CHARCODEP \FATCHARCODEP \THINCHARCODEP)
+                                                             (* ; "For benefit of Masterscope")
+                                   (MACROS \GETBASEFAT \GETBASETHIN \PUTBASEFAT \PUTBASETHIN)
+                                   (MACROS \PUTBASECHAR \GETBASECHAR)
+                                   (MACROS \CHARSET \CHAR8CODE)
+                                   (CONSTANTS (\CHARMASK 255)
+                                          (\MAXCHAR 255)
+                                          (\MAXTHINCHAR 255)
+                                          (\MAXFATCHAR 65535)
+                                          (\MAXCHARSET 255)
+                                          (NSCHARSETSHIFT 255)
+                                          (%#STRINGPWORDS 4))
+                                   (MACROS \NATOMCHARS \NSTRINGCHARS)))
+        (INITRESOURCES \NUMSTR \NUMSTR1 \PNAMESTRING)
+        (P (MOVD? 'CHARACTER 'FCHARACTER NIL T))
+        [COMS (FNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY)
+                                                             (* ; "For MAKEINIT")
+              (DECLARE%: DONTCOPY (ADDVARS (INEWCOMS (FNS ALLOCSTRING %%COPY-ONED-ARRAY 
+                                                          %%COPY-STRING-TO-ARRAY))
+                                         (* "So %%COPY-ONED-ARRAY will compile properly")
+                                         (INEWCOMS (FILES (SYSLOAD FROM VALUEOF DIRECTORIES)
+                                                          CMLARRAY-SUPPORT))
+                                         (EXPANDMACROFNS \PUTBASETHIN \PUTBASEFAT \CHARCODEP 
+                                                \GETBASECHAR \GETBASETHIN \GETBASEFAT \PUTBASECHAR)
+                                         (DONTCOMPILEFNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY]
+        (DECLARE%: DONTCOPY EVAL@COMPILE (LOCALVARS . T))
+        
+        (* ;; "Arrange for the proper compiler")
+
+        (PROP FILETYPE LLCHAR)))
+(DEFINEQ
+
+(ALLOCSTRING
+  [LAMBDA (N INITCHAR OLD FATFLG)                            (* jop%: "23-Sep-86 17:44")
+    (SETQ N (FIX N))                                         (* ; "Coerce floats at the outset")
+    (COND
+       ((OR (ILESSP N 0)
+            (IGREATERP N \MaxArrayLen))
+        (LISPERROR "ILLEGAL ARG" N)))
+    [COND
+       ((NULL INITCHAR)
+        (SETQ INITCHAR 0))
+       ((\CHARCODEP INITCHAR))
+       (T (SETQ INITCHAR (CHCON1 INITCHAR]
+    [LET ((FATP (OR FATFLG (IGREATERP INITCHAR \MAXTHINCHAR)))
+          STRINGBASE)                                        (* ; 
+                            "Allocate the block before going uninterruptable in the smashing case.")
+         [SETQ STRINGBASE (\ALLOCBLOCK (COND
+                                          (FATP (FOLDHI N WORDSPERCELL))
+                                          (T (FOLDHI N BYTESPERCELL]
+         [COND
+            [(STRINGP OLD)
+             (UNINTERRUPTABLY
+                 (create STRINGP smashing OLD LENGTH _ N BASE _ STRINGBASE TYP _
+                                           (COND
+                                              (FATP \ST.POS16)
+                                              (T \ST.BYTE))))]
+            (T (SETQ OLD (create STRINGP
+                                LENGTH _ N
+                                BASE _ STRINGBASE
+                                TYP _ (COND
+                                         (FATP \ST.POS16)
+                                         (T \ST.BYTE]
+         (COND
+            ((NEQ 0 INITCHAR)                                (* ; 
+                             "\ALLOCBLOCK always zeros the block, so don't need to initialize then")
+             (COND
+                (FATP (for I from 0 to (SUB1 N) do (\PUTBASEFAT STRINGBASE I INITCHAR
+                                                                          )))
+                (T (for I from 0 to (SUB1 N) do (\PUTBASETHIN STRINGBASE I INITCHAR]
+    OLD])
+
+(MKATOM
+  [LAMBDA (X)                                                (* jop%: "23-Sep-86 16:30")
+    (COND
+       ((STRINGP X)
+        (\MKATOM (ffetch (STRINGP BASE) of X)
+               (ffetch (STRINGP OFFST) of X)
+               (LET ((LEN (ffetch (STRINGP LENGTH) of X)))
+                    (COND
+                       ((IGREATERP LEN \PNAMELIMIT)
+                        (LISPERROR "ATOM TOO LONG" X))
+                       (T LEN)))
+               (ffetch (STRINGP FATSTRINGP) of X)))
+       ((OR (LITATOM X)
+            (NUMBERP X))
+        X)
+       (T (PACK* X])
+
+(SUBATOM
+  [LAMBDA (X N M)                                            (* jop%: "23-Sep-86 17:47")
+    (PROG (BASE OFFST LEN FATP (N1 N)
+                (M1 M))                                      (* ; 
+                                                           "N1 and M1 so don't reset user arg.")
+          [COND
+             ((LITATOM X)
+              (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X))
+              (SETQ OFFST 1)
+              (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X))
+              (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X)))
+             (T (SETQ LEN (OR (STRINGP X)
+                              (MKSTRING X)))             (* ; "Don't reset user arg")
+                (SETQ BASE (ffetch (STRINGP BASE) of LEN))
+                (SETQ FATP (ffetch (STRINGP FATSTRINGP) of LEN))
+                (SETQ OFFST (ffetch (STRINGP OFFST) of LEN))
+                (SETQ LEN (ffetch (STRINGP LENGTH) of LEN]
+          [COND
+             ((IGREATERP 0 N1)                               (* ; "Coerce the first index")
+              (SETQ N1 (IPLUS N1 LEN 1]
+          [COND
+             ((NULL M1)                                      (* ; "Coerce the second")
+              (SETQ M1 LEN))
+             ((IGREATERP 0 M1)
+              (SETQ M1 (IPLUS M1 LEN 1]
+          (RETURN (AND (IGREATERP N1 0)
+                       (ILEQ N1 M1)
+                       (ILEQ M1 LEN)
+                       (\MKATOM BASE (IPLUS OFFST N1 -1)
+                              (COND
+                                 ((IGREATERP (SETQ LEN (ADD1 (IDIFFERENCE M1 N1)))
+                                         \PNAMELIMIT)
+                                  (LISPERROR "ATOM TOO LONG" X))
+                                 (T LEN))
+                              FATP])
+
+(CHARACTER
+  [LAMBDA (N)                                                (* jop%: "23-Sep-86 17:45")
+    (OR (\CHARCODEP N)
+        (SETQ N (\ILLEGAL.ARG N)))
+    (COND
+       ((IGREATERP N \MAXTHINCHAR)                           (* ; 
+                        "The character we're getting is NOT a thin character -- do it the hard way")
+        (WITH-RESOURCE (\PNAMESTRING)
+               (\PNAMESTRINGPUTCHAR (ffetch (STRINGP XBASE) of \PNAMESTRING)
+                      0 N)
+               (\MKATOM (ffetch (STRINGP XBASE) of \PNAMESTRING)
+                      0 1 \FATPNAMESTRINGP)))
+       ((IGREATERP N (CHARCODE 9))
+        (\ADDBASE \OneCharAtomBase (IDIFFERENCE N 10)))
+       ((IGEQ N (CHARCODE 0))
+        (IDIFFERENCE N (CHARCODE 0)))
+       (T                                                    (* ; 
+                                                "The common case -- just add on the one-atom base.")
+          (\ADDBASE \OneCharAtomBase N])
+
+(\PARSE.NUMBER
+  [LAMBDA (BASE BN LEN FATP RADIX RDTBL)                     (* ; "Edited 12-Feb-87 19:21 by bvm:")
+
+(* ;;; "Attempt to create a numeric atom out of the chars in BASE from BN for LEN characters (fat or thin, depending on FATP).   Return NIL if the chars do not form a legal number when read in this read table.")
+
+    (DECLARE (GLOBALVARS \ORIGREADTABLE))
+    (if (NULL RDTBL)
+        then (SETQ RDTBL *READTABLE*))
+    (PROG ((I BN)
+           (END (IPLUS BN LEN))
+           (STATE 'INIT)
+           (COMMONLISP (AND (NEQ RDTBL \ORIGREADTABLE)
+                            (fetch (READTABLEP COMMONLISP) of RDTBL)))
+           COMMONLISPY MAXDIGIT MAXALPHADIGIT C SIGN START ENDFRAC DECPT EXPSTART NEGFRAC SIGDIGITS 
+           EXP10 SEENALPHADIGITS SEENBOGUSDIGITS)            (* ; "The test for \origreadtable is a kludge so that \MKATOM can work before read tables are set up.  \MKATOM calls us with RDTBL = \origreadtable, which is initially NOBIND. ")
+          (if (NULL RADIX)
+              then (SETQ RADIX (if COMMONLISP
+                                       then *READ-BASE*
+                                     else 10)))
+          [if (GREATERP RADIX 10)
+              then                                       (* ; 
+                                                       "can have alphabetic digits for large bases")
+                    (SETQ MAXALPHADIGIT (IPLUS (CHARCODE A)
+                                               (IDIFFERENCE RADIX 11)))
+                    (SETQ MAXDIGIT (CHARCODE 9))
+            else (SETQ MAXDIGIT (IPLUS (CHARCODE 0)
+                                           (SUB1 RADIX]
+          [SETQ COMMONLISPY (OR COMMONLISP (AND (NEQ RDTBL \ORIGREADTABLE)
+                                                (fetch (READTABLEP COMMONNUMSYNTAX) of RDTBL]
+      LP  
+
+     (* ;; "Scan string to see what we have: a decimal integer, octal integer, or floating-point number.  Once we know which we have, we can pack up the value quickly")
+
+          (if (EQ I END)
+              then (RETURN (SELECTQ STATE
+                                   ((INITDIGIT AFTERQ AFTERMIDDLEDOT) 
+                                        (if (NOT START)
+                                            then         (* ; "saw no non-zero digits")
+                                                  0
+                                          elseif SEENBOGUSDIGITS
+                                            then         (* ; "Some digits were not valid in this radix, so object is not a number.  Note that there is no suffix in this case, so i is correct.")
+                                                  (\INVALID.INTEGER BASE START I SIGN RADIX FATP)
+                                          else (\MKINTEGER BASE START
+                                                          (if (NEQ STATE 'INITDIGIT)
+                                                              then 
+                                                             (* ; "string ended in Q or dot")
+                                                                    (SUB1 I)
+                                                            else I)
+                                                          (EQ SIGN '-)
+                                                          RADIX FATP)))
+                                   ((INFRACTION INEXPONENT) 
+                                        (if SIGDIGITS
+                                            then [if (NOT ENDFRAC)
+                                                         then (SETQ ENDFRAC I)
+                                                               (SETQ NEGFRAC (EQ SIGN '-]
+                                                  (if (IGREATERP SIGDIGITS MAX.DIGITS.ACCURACY)
+                                                      then 
+
+                                 (* ;; "Too many digits--we will overflow.  Only take as many as we can handle.  Don't worry about looking at the n+1'st digit for rounding, since it won't make any difference (there are many fewer sig bits in a floatp than in a fixp)")
+
+                                                            (SETQ ENDFRAC (IPLUS START 
+                                                                                 MAX.DIGITS.ACCURACY)
+                                                             )
+                                                            (if (AND (IGREATERP DECPT START)
+                                                                         (ILESSP DECPT ENDFRAC))
+                                                                then (add ENDFRAC 1)))
+                                                  (SETQ EXP10 (if EXPSTART
+                                                                  then (\MKINTEGER
+                                                                            BASE EXPSTART I
+                                                                            (EQ SIGN '-)
+                                                                            10 FATP)
+                                                                else 0)) 
+                                                             (* ; "the explicit exponent")
+                                                  (\FLOATINGSCALE (\MKINTEGER BASE START ENDFRAC
+                                                                         NEGFRAC 10 FATP)
+                                                         (IPLUS EXP10 (IDIFFERENCE DECPT ENDFRAC)
+                                                                (if (ILESSP DECPT ENDFRAC)
+                                                                    then 
+                                                             (* ; 
+                                                     "don't count the position the dec pt occupies")
+                                                                          1
+                                                                  else 0)))
+                                          else           (* ; "we saw only zeros")
+                                                (FLOAT 0)))
+                                   NIL)))
+          (SETQ STATE
+           (OR
+            [SELCHARQ (SETQ C (\GETBASECHAR FATP BASE I))
+                 (- (AND (NOT SIGN)
+                         (SELECTQ STATE
+                             ((INIT AFTERE) 
+                                  (SETQ SIGN '-)
+                                  STATE)
+                             NIL)))
+                 (+ (AND (NOT SIGN)
+                         (SELECTQ STATE
+                             ((INIT AFTERE) 
+                                  (SETQ SIGN '+)
+                                  STATE)
+                             NIL)))
+                 (%. (SETQ DECPT I)
+                     (SELECTQ STATE
+                         (INIT 'AFTERINITIALDOT)
+                         (INITDIGIT (if SEENALPHADIGITS
+                                        then             (* ; 
+                                                        "Can't have decimal point in other radices")
+                                              NIL
+                                      elseif COMMONLISP
+                                        then             (* ; "Could be decimal integer")
+                                              (SETQ RADIX 10)
+                                              (SETQ SEENBOGUSDIGITS NIL) 
+                                                             (* ; 
+                                                   "digits bigger than radix not an error any more")
+                                              'AFTERMIDDLEDOT
+                                      else 'INFRACTION))
+                         (AFTERINITIALDOT                    (* ; 
+                      "Two dots in a row.  If symbol is ALL dots, then we have to signal an error.")
+                              (if [AND COMMONLISP (NOT SIGN)
+                                           (for J from (ADD1 I) to (SUB1 END)
+                                              always (EQ (\GETBASECHAR FATP BASE J)
+                                                             (CHARCODE %.]
+                                  then (\INVALID.DOTTED.SYMBOL BASE BN LEN FATP)
+                                else                     (* ; 
+  "not all dots, started with sign, or in Interlisp read table, where it's ok -- just not a number")
+                                      NIL))
+                         NIL))
+                 (COND
+                    ((AND (IGEQ C (CHARCODE 0))
+                          (ILEQ C (CHARCODE 9)))             (* ; "digit")
+                     (SELECTQ STATE
+                         ((INIT INITDIGIT) 
+                              (IF (> C MAXDIGIT)
+                                  THEN                   (* ; "not a digit in this radix.  However, number could turn out to be decimal (integer or float), so keep going.")
+                                        (SETQ SEENBOGUSDIGITS T))
+                              (if SIGDIGITS
+                                  then (add SIGDIGITS 1)
+                                elseif (NEQ C (CHARCODE 0))
+                                  then                   (* ; 
+                                                     "record where first significant digit happens")
+                                        (SETQ START I)
+                                        (SETQ SIGDIGITS 1))
+                              'INITDIGIT)
+                         ((INFRACTION AFTERINITIALDOT AFTERMIDDLEDOT) 
+                                                             (* ; "Scanning fractional part")
+                              (if SIGDIGITS
+                                  then (add SIGDIGITS 1)
+                                elseif (NEQ C (CHARCODE 0))
+                                  then (SETQ SIGDIGITS 1)
+                                        (SETQ START I))
+                              'INFRACTION)
+                         (AFTERE (SETQ EXPSTART I)
+                                 'INEXPONENT)
+                         (INEXPONENT 'INEXPONENT)
+                         NIL))
+                    ((IGREATERP C (CHARCODE z))              (* ; "Out in the wilderness")
+                     NIL)
+                    (T                                       (* ; "Some other non-digit")
+                     [if (AND COMMONLISPY (IGEQ C (CHARCODE a)))
+                         then (SETQ C (IDIFFERENCE C (IDIFFERENCE (CHARCODE a)
+                                                                (CHARCODE A]
+                     (if (AND MAXALPHADIGIT (IGEQ C (CHARCODE A))
+                                  (ILEQ C MAXALPHADIGIT)
+                                  (NOT DECPT))
+                         then                            (* ; "Letter is a digit in this base")
+                               (SELECTQ STATE
+                                   ((INIT INITDIGIT) 
+                                        (SETQ SEENALPHADIGITS T)
+                                        (if SIGDIGITS
+                                            then (add SIGDIGITS 1)
+                                          else (SETQ START I)
+                                                (SETQ SIGDIGITS 1))
+                                        'INITDIGIT)
+                                   NIL)
+                       elseif (EQ C (CHARCODE Q))
+                         then                            (* ; 
+                      "Interlisp octal specifier -- perhaps should only do this if not common lisp")
+                               (SELECTQ STATE
+                                   (INITDIGIT (SETQ RADIX 8)
+                                              (SETQ SEENBOGUSDIGITS NIL)
+                                                             (* ; "It is possible that we should check to see if all the digits are really octal digits, but that's a pain, and we never did it before in Interlisp.")
+                                              'AFTERQ)
+                                   NIL)
+                       elseif (AND [OR (EQ C (CHARCODE E))
+                                           (AND COMMONLISPY (FMEMB C (CHARCODE (D F L S]
+                                       (NOT SEENALPHADIGITS))
+                         then                            (* ; 
+                          "Exponent marker.  Someday there will be differences among some of these")
+                               (SELECTQ STATE
+                                   ((INITDIGIT INFRACTION AFTERMIDDLEDOT) 
+                                                             (* ; 
+                                                           "We've seen digits and/or a fraction")
+                                        (OR DECPT (SETQ DECPT I))
+                                        (SETQ ENDFRAC I)
+                                        (SETQ NEGFRAC (EQ SIGN '-))
+                                        (SETQ SIGN NIL)
+                                        'AFTERE)
+                                   NIL)
+                       elseif (AND (EQ C (CHARCODE /))
+                                       COMMONLISPY)
+                         then                            (* ; 
+                               "Ratio marker.  Must only have seen digits and possibly sign so far")
+                         (if
+                          [AND
+                           (EQ STATE 'INITDIGIT)
+                           (NEQ (ADD1 I)
+                                END)
+                           (for J from (ADD1 I) to (SUB1 END)
+                              always                     (* ; 
+                                                       "test remaining digits valid for this radix")
+                              (AND (IGEQ (SETQ C (\GETBASECHAR FATP BASE J))
+                                         (CHARCODE 0))
+                                   (OR (ILEQ C MAXDIGIT)
+                                       (AND MAXALPHADIGIT (IGEQ C (CHARCODE A))
+                                            (ILEQ (if (IGEQ C (CHARCODE a))
+                                                      then (IDIFFERENCE C (IDIFFERENCE
+                                                                               (CHARCODE a)
+                                                                               (CHARCODE A)))
+                                                    else C)
+                                                  MAXALPHADIGIT]
+                             then (RETURN (if START
+                                                  then (/ (\MKINTEGER BASE START I
+                                                                     (EQ SIGN '-)
+                                                                     RADIX FATP)
+                                                              (\MKINTEGER BASE (ADD1 I)
+                                                                     END NIL RADIX FATP))
+                                                else     (* ; "saw no non-zero digits")
+                                                      0]
+            (RETURN NIL)))
+          (SETQ I (ADD1 I))
+          (GO LP])
+
+(\INVALID.DOTTED.SYMBOL
+  [LAMBDA (BASE START LEN FATP)                              (* ; "Edited 12-Feb-87 18:56 by bvm:")
+
+(* ;;; "Called from number parser when scanning a token that is all dots.  Value returned from here is NIL to treat it as a quoted symbol or any other non-null value you'd like to return.")
+
+    (LISP:CERROR "Treat the dots as if they were escaped" 
+           "Invalid symbol consisting entirely of dots ~S" (\GETBASESTRING BASE START LEN FATP))
+    NIL])
+
+(\INVALID.INTEGER
+  [LAMBDA (BASE START END SIGN RADIX FATP)                   (* ; "Edited 12-Feb-87 19:39 by bvm:")
+
+(* ;;; "Called when scanning a token that is all digits, but some digits are not valid in this read base.  Value returned from here is NIL to treat it as a symbol or a number (the default proceed case says to interpret in decimal).")
+
+    (LISP:CERROR "Treat the number as if in decimal radix" 
+           "Invalid integer %"~@[~A~]~A%" in read base ~D" SIGN (\GETBASESTRING
+                                                                 BASE
+                                                                 (if FATP
+                                                                     then 
+
+                                 (* ;; "yecch.  start arg to \getbasestring is always byte offset, whether it's fat or not.  start arg to \parse.number is character number (and usually zero, apparently).")
+
+                                                                           (UNFOLD START BYTESPERWORD
+                                                                                  )
+                                                                   else START)
+                                                                 (- END START)
+                                                                 FATP)
+           RADIX)
+    (\MKINTEGER BASE START END (EQ SIGN '-)
+           10 FATP])
+
+(\MKINTEGER
+  [LAMBDA (BASE START END NEG RADIX FATP)                    (* ; "Edited 13-Oct-87 11:10 by jrb:")
+
+(* ;;; "Return integer whose Ascii characters run from START to END off BASE.  If NEG is true, negate it.  RADIX is the base.  String is assumed to contain only digits valid in RADIX -- no error checking.  For benefit of floating routines, dec pt is ignored.")
+
+(* ;;; "JRB - Modified per BvM suggestion to accumulate three digits at a time (three digits insures largest legal radix (36) won't overflow a smallp).  The bottom of the loop goes to great lengths to avoid computing RADIX^2 and RADIX^3 unless it absolutely has to.")
+
+    (PROG ((VAL 0)
+           LOOPVAL CH I RADIX2 RADIX3)
+      LP  (if (EQ START END)
+              then (RETURN VAL))
+          (SETQ LOOPVAL 0)
+          (SETQ I 3)
+          (while (AND (NOT (EQ START END))
+                          (NOT (EQ I 0)))
+             do (SETQ CH (\GETBASECHAR FATP BASE START))
+                   (if (NEQ CH (CHARCODE "."))
+                       then                              (* ; "ignore dec pt")
+                             [SETQ CH (if (IGEQ CH (CHARCODE A))
+                                          then           (* ; 
+                                       "Large radix digit.  Could be lowercase, so zap the 40q bit")
+                                                (IPLUS 10 (IDIFFERENCE (LOGAND CH 95)
+                                                                 (CHARCODE A)))
+                                        else (IDIFFERENCE CH (CHARCODE 0]
+                             (SETQ LOOPVAL (if NEG
+                                               then (IDIFFERENCE (ITIMES LOOPVAL RADIX)
+                                                               CH)
+                                             else (IPLUS (ITIMES LOOPVAL RADIX)
+                                                             CH)))
+                             (SETQ I (SUB1 I)))
+                   (SETQ START (ADD1 START)))
+          (SETQ VAL (if (EQ VAL 0)
+                        then LOOPVAL
+                      else [OR RADIX3 (SETQ RADIX3 (ITIMES RADIX (SETQ RADIX2 (ITIMES RADIX RADIX
+                                                                                         ]
+                            (IPLUS (ITIMES VAL (SELECTQ I
+                                                   (0 RADIX3)
+                                                   (1 RADIX2)
+                                                   (2 RADIX)
+                                                   1))
+                                   LOOPVAL)))
+          (GO LP])
+
+(MKSTRING
+  [LAMBDA (X FLG RDTBL)                                      (* ; "Edited 10-Feb-87 19:09 by bvm:")
+                                                             (* ; 
+                                         "Coerce X to be a string.  The string will be FAT if X is")
+    (DECLARE (GLOBALVARS PRXFLG))
+    (OR [COND
+           ((NOT FLG)                                        (* ; 
+                                     "The simple case -- just gather up the characters in the item")
+            (COND
+               ((STRINGP X)                              (* ; "Strings coerce to themselves")
+                X)
+               [(LITATOM X)                                  (* ; 
+                         "LITATOMs have a new descriptor created, pointing to the same characters.")
+                (create STRINGP
+                       XBASE _ (ffetch (LITATOM PNAMEBASE) of X)
+                       LENGTH _ (ffetch (LITATOM PNAMELENGTH) of X)
+                       OFFST _ 1
+                       XREADONLY _ T
+                       TYP _ (COND
+                                ((ffetch (LITATOM FATPNAMEP) of X)
+                                 \ST.POS16)
+                                (T \ST.BYTE]
+               ((LISP:CHARACTERP X)                          (* ; 
+                                                          "CL characters are one-character strings")
+                (ALLOCSTRING 1 (LISP:CHAR-CODE X]
+        (LET [(BASE (COND
+                       (PRXFLG (\CHECKRADIX *PRINT-BASE*))
+                       (T 10]
+             (LET ((*PRINT-ESCAPE* FLG)
+                   (*READTABLE* (COND
+                                   (FLG (\GTREADTABLE RDTBL))
+                                   (T *READTABLE*)))
+                   (*PRINT-RADIX* (AND FLG (NEQ BASE 10)))
+                   (*PRINT-BASE* BASE)
+                   (*PRINT-LENGTH*)
+                   (*PRINT-LEVEL*))
+
+                  (* ;; "General case: internally print the name, gather up the characters")
+
+                  (\PRINDATUM.TO.STRING X])
+
+(\PRINDATUM.TO.STRING
+  [LAMBDA (X)                                                (* ; "Edited  9-Dec-86 11:04 by jrb:")
+
+(* ;;; "Produces a string that is the result of printing X according the current settings of *PRINT-ESCAPE* etc.")
+
+    (SELECTC (NTYPX X)
+        ((LIST \FIXP \SMALLP \FLOATP)                        (* ; 
+                                                 "We know how to print numbers without extra steps")
+             (GLOBALRESOURCE (\NUMSTR \NUMSTR1)
+                    (LET [(STR (COND
+                                  ((FLOATP X)
+                                   (\CONVERT.FLOATING.NUMBER X \NUMSTR \NUMSTR1))
+                                  (T (\CONVERTNUMBER X *PRINT-BASE* NIL (AND *PRINT-RADIX* 
+                                                                               *READTABLE*)
+                                            \NUMSTR \NUMSTR1]
+                         (RPLSTRING (ALLOCSTRING (NCHARS STR))
+                                1 STR))))
+        (LET ((FATSTRINGP)
+              (STRINGLEN 0)
+              (STRINDEX 0)
+              STRINGPTR *PRINT-CIRCLE-HASHTABLE* (*PRINT-CIRCLE-NUMBER* 1)
+              THERE-ARE-CIRCLES)
+             (DECLARE (LISP:SPECIAL *PRINT-CIRCLE-HASHTABLE* *PRINT-CIRCLE-NUMBER* 
+                                 THERE-ARE-CIRCLES))         (* ; 
+                                              "If *print-circle* is on, need to scan the structure")
+             (IF *PRINT-CIRCLE*
+                 THEN (SETQ *PRINT-CIRCLE-HASHTABLE* (LISP:MAKE-HASH-TABLE))
+                       (PRINT-CIRCLE-SCAN X)
+                       (IF (NOT THERE-ARE-CIRCLES)
+                           THEN (SETQ *PRINT-CIRCLE-HASHTABLE* NIL)))
+
+             (* ;; "First count up the characters and their fatness")
+
+             (\MAPPNAME.INTERNAL [FUNCTION (LAMBDA (DUMMY CODE)
+                                             (COND
+                                                ((GREATERP CODE \MAXTHINCHAR)
+                                                 (SETQ FATSTRINGP T)))
+                                             (add STRINGLEN 1]
+                    X)
+
+             (* ;; "We print structures TWICE here, so we need to reset *PRINT-CIRCLE-HASHTABLE* and *PRINT-CIRCLE-NUMBER* if circles are being printed")
+
+             (if *PRINT-CIRCLE-HASHTABLE*
+                 then (SETQ *PRINT-CIRCLE-NUMBER* 1)
+                       (LISP:MAPHASH #'[LAMBDA (KEY VAL)
+                                         (if (NUMBERP VAL)
+                                             then (LISP:SETF (LISP:GETHASH KEY 
+                                                                        *PRINT-CIRCLE-HASHTABLE*)
+                                                             'T2]
+                              *PRINT-CIRCLE-HASHTABLE*))
+
+             (* ;; "Then print X again actually storing the characters into the string")
+
+             (SETQ STRINGPTR (ALLOCSTRING STRINGLEN NIL NIL FATSTRINGP))
+             (\MAPPNAME.INTERNAL [FUNCTION (LAMBDA (DUMMY CODE)
+                                             [COND
+                                                ((EQ STRINDEX (ffetch (STRINGP LENGTH)
+                                                                 of STRINGPTR))
+                                                             (* ; 
+                                                           "Help! NCHARS and \MAPPNAME disagree.")
+                                                 (SETQ STRINGPTR (CONCAT STRINGPTR " "]
+                                             (add STRINDEX 1)
+                                             (COND
+                                                ((ffetch (STRINGP FATSTRINGP) of 
+                                                                                            STRINGPTR
+                                                        )    (* ; 
+                                                        "Fat string;  just smash the character in.")
+                                                 (\PUTBASEFAT (fetch (STRINGP BASE)
+                                                                 of STRINGPTR)
+                                                        (IPLUS (fetch (STRINGP OFFST)
+                                                                  of STRINGPTR)
+                                                               STRINDEX -1)
+                                                        CODE))
+                                                ((ILEQ CODE \MAXTHINCHAR)
+                                                             (* ; 
+                                                    "Thin char and String;  just smash the char in")
+                                                 (\PUTBASETHIN (fetch (STRINGP BASE)
+                                                                  of STRINGPTR)
+                                                        (IPLUS (fetch (STRINGP OFFST)
+                                                                  of STRINGPTR)
+                                                               STRINDEX -1)
+                                                        CODE))
+                                                (T 
+
+                                       (* ;; "Need to fatten the string, then smash in the char.  This shouldn't happen unless X gets printed different the two times!")
+
+                                                   (\FATTENSTRING STRINGPTR)
+                                                   (\PUTBASEFAT (fetch (STRINGP BASE)
+                                                                   of STRINGPTR)
+                                                          (IPLUS (fetch (STRINGP OFFST)
+                                                                    of STRINGPTR)
+                                                                 STRINDEX -1)
+                                                          CODE]
+                    X)
+             STRINGPTR])
+
+(BKSYSBUF
+  [LAMBDA (X FLG RDTBL)                                      (* jop%: "23-Sep-86 17:31")
+    (PROG NIL
+          (if (NOT FLG)
+              then (COND
+                          [(LITATOM X)
+                           (RETURN (for C inatom X do (BKSYSCHARCODE C]
+                          [(STRINGP X)
+                           (RETURN (for C instring X do (BKSYSCHARCODE C]
+                          (T NIL)))
+          (LET ((*READTABLE* *READTABLE*)
+                (*PACKAGE* *PACKAGE*)
+                TTY)
+               [if FLG
+                   then (if RDTBL
+                                then                     (* ; 
+                                                        "Use the explicit read table we were given")
+                                      (SETQ *READTABLE* (\GTREADTABLE RDTBL))
+                              elseif (NEQ (SETQ TTY (TTY.PROCESS))
+                                              (THIS.PROCESS))
+                                then                     (* ; 
+                                       "Print it using the read environment of the destination tty")
+                                      (SETQ *READTABLE* (PROCESS.EVALV TTY '*READTABLE*))
+                                      (SETQ *PACKAGE* (PROCESS.EVALV TTY '*PACKAGE*]
+               (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CODE)
+                                      (BKSYSCHARCODE CODE]
+                      X FLG RDTBL)))
+    X])
+
+(NCHARS
+  [LAMBDA (X FLG RDTBL)                                      (* jop%: "24-Sep-86 23:06")
+
+(* ;;; "Return the number of characters in (the print name of) X.  If FLG, then return the number of characters in the PRIN2 version, according to RDTBL.")
+
+    (PROG ((NCHARCNT 0))
+          [COND
+             [(LITATOM X)
+              (if (NOT FLG)
+                  then                                   (* ; 
+                                                           "Too hairy to figure out package count")
+                        (RETURN (ffetch (LITATOM PNAMELENGTH) of X]
+             ((STRINGP X)
+              (RETURN (IPLUS (ffetch (STRINGP LENGTH) of X)
+                             (COND
+                                [FLG 
+                                     (* ;; "2 for the enclosing quotes and an escape to quote every double quote char or escape in the string body")
+
+                                     (IPLUS 2 (for C instring X
+                                                 bind (ESC _ (ffetch (READTABLEP ESCAPECHAR)
+                                                                    of (\GTREADTABLE RDTBL)))
+                                                 count (OR (EQ C (CHARCODE %"))
+                                                               (EQ C (CHARCODE LF))
+                                                               (EQ C ESC]
+                                (T 0]                        (* ; "Slow case...")
+          (\MAPPNAME [FUNCTION (LAMBDA NIL
+                                 (add NCHARCNT 1]
+                 X FLG RDTBL)
+          (RETURN NCHARCNT])
+
+(NTHCHARCODE
+  [LAMBDA (X N FLG RDTBL)                                    (* jop%: "23-Sep-86 16:34")
+    (PROG (BASE OFFST FATP LEN (M N))
+          [COND
+             (FLG (GO SLOWCASE))
+             (T (COND
+                   ((STRINGP X)
+                    (SETQ BASE (ffetch (STRINGP BASE) of X))
+                    (SETQ LEN (ffetch (STRINGP LENGTH) of X))
+                    (SETQ OFFST (ffetch (STRINGP OFFST) of X))
+                    (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)))
+                   ((LITATOM X)
+                    (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X))
+                    (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))
+                    (SETQ OFFST 1)
+                    (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)))
+                   (T (GO SLOWCASE]
+          [COND
+             ((ILESSP M 0)                                   (* ; "Negative index counts from end")
+              (SETQ M (IPLUS M LEN 1]
+          [RETURN (COND
+                     ((OR (ILESSP M 1)
+                          (IGREATERP M LEN))                 (* ; "out of range")
+                      NIL)
+                     (T                                      (* ; 
+                                                           "The -1 is cause strings have ORIG=1")
+                        (\GETBASECHAR FATP BASE (SUB1 (IPLUS OFFST M]
+      SLOWCASE
+          [COND
+             ((EQ M 0)
+              (RETURN))
+             ((ILESSP M 0)
+              (AND (ILESSP (SETQ M (IPLUS M (NCHARS X FLG RDTBL)
+                                          1))
+                          1)
+                   (RETURN]
+          (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CODE)
+                                 (COND
+                                    ((EQ (SETQ M (SUB1 M))
+                                         0)
+                                     (RETFROM 'NTHCHARCODE CODE]
+                 X FLG RDTBL)
+          (RETURN])
+
+(RPLCHARCODE
+  [LAMBDA (X N CHAR)                                         (* jop%: "23-Sep-86 16:36")
+    (COND
+       ((STRINGP X)
+        (PROG ((LEN (ffetch (STRINGP LENGTH) of X)))
+              (\SMASHABLESTRING X (\FATCHARCODEP CHAR))
+              [COND
+                 ((ILESSP N 0)                               (* ; "address from end")
+                  (SETQ N (IPLUS N LEN 1]
+              (COND
+                 ((OR (ILESSP N 1)
+                      (IGREATERP N LEN))
+                  (LISPERROR "ILLEGAL ARG" N)))              (* ; 
+                                                   "We assume that ORIG is 1 because X is a string")
+              (\PUTBASECHAR (ffetch (STRINGP FATSTRINGP) of X)
+                     (ffetch (STRINGP BASE) of X)
+                     (IPLUS (ffetch (STRINGP OFFST) of X)
+                            (SUB1 N))
+                     CHAR)
+              (RETURN X)))
+       (T (RPLCHARCODE (MKSTRING X)
+                 N CHAR])
+
+(\RPLCHARCODE
+  [LAMBDA (X N CHAR)                                         (* jop%: "23-Sep-86 16:50")
+
+(* ;;; "System version: does error checking interpreted.  Compiles open as \PUTBASEFAT or \PUTBASETHIN.  N must be positive, X must be a real not READONLY string")
+
+    (COND
+       ((OR (NOT (STRINGP X))
+            (ffetch (STRINGP READONLY) of X))    (* ; 
+                            "X has to be a string, and can't be READONLY (e.g.  a litatom's pname)")
+        (LISPERROR "ILLEGAL ARG" X))
+       ((OR (ILEQ N 0)
+            (IGREATERP N (ffetch (STRINGP LENGTH) of X)))
+                                                             (* ; 
+                                            "The position arg has to be inside the string's length")
+        (LISPERROR "ILLEGAL ARG" N))
+       ((NOT (\CHARCODEP CHAR))                              (* ; "CHAR has to be a charcode")
+        (LISPERROR "ILLEGAL ARG" CHAR))
+       ((AND (IGREATERP CHAR \MAXTHINCHAR)
+             (NOT (ffetch (STRINGP FATSTRINGP) of X)))
+                                                             (* ; 
+                                   "If the char's fat, and the string isn't, coerce it to fatness.")
+        (\SMASHABLESTRING X T)))
+    (\PUTBASECHAR (ffetch (STRINGP FATSTRINGP) of X)
+           (ffetch (STRINGP BASE) of X)
+           (IPLUS (ffetch (STRINGP OFFST) of X)
+                  (SUB1 N))
+           CHAR)
+    X])
+
+(NTHCHAR
+  [LAMBDA (X N FLG RDTBL)                                    (* jop%: "23-Sep-86 17:17")
+    (LET ((CODE (NTHCHARCODE X N FLG RDTBL)))
+         (AND CODE (FCHARACTER CODE])
+
+(RPLSTRING
+  [LAMBDA (X N Y)                                            (* ; "Edited 24-Sep-87 11:49 by bvm:")
+    (PROG ((OLDSTRING (OR (STRINGP X)
+                          (MKSTRING X)))
+           (REP Y)
+           OBASE OLEN RBASE RLEN ROFFST POS FIRSTNEW RFAT)
+          (SETQ OLEN (ffetch (STRINGP LENGTH) of OLDSTRING))
+          [COND
+             ((LITATOM REP)
+              (SETQ RBASE (ffetch (LITATOM PNAMEBASE) of REP))
+              (SETQ ROFFST 1)
+              (SETQ RLEN (ffetch (LITATOM PNAMELENGTH) of REP))
+              (SETQ RFAT (ffetch (LITATOM FATPNAMEP) of REP)))
+             (T (OR (STRINGP REP)
+                    (SETQ REP (MKSTRING REP)))
+                (SETQ RBASE (ffetch (STRINGP BASE) of REP))
+                (SETQ ROFFST (ffetch (STRINGP OFFST) of REP))
+                (SETQ RLEN (ffetch (STRINGP LENGTH) of REP))
+                (SETQ RFAT (ffetch (STRINGP FATSTRINGP) of REP]
+          [COND
+             ((> [+ RLEN (SETQ POS (COND
+                                      ((> N 0)
+                                       (SUB1 N))
+                                      (T (+ OLEN N]
+                 OLEN)
+              (LISPERROR "ILLEGAL ARG" (if (> POS OLEN)
+                                           then          (* ; 
+                           "actually, the index is wrong, without even considering the replacement")
+                                                 N
+                                         else Y]
+          (\SMASHABLESTRING OLDSTRING RFAT)              (* ; 
+                                   "Make sure the string is writeable and of the appropriate width")
+          (SETQ OBASE (ffetch (STRINGP BASE) of OLDSTRING))
+                                                             (* ; 
+                                         "Note: OBASE might have changed, so not fetched until now")
+          (SETQ FIRSTNEW (+ POS (ffetch (STRINGP OFFST) of OLDSTRING)))
+                                                             (* ; 
+                          "Now can smash chars from RBASE into OBASE starting at position FIRSTNEW")
+          (COND
+             (RFAT                                           (* ; 
+                         "Fat into fat.  \SMASHABLESTRING* above ensured that OLDSTRING is now fat")
+                   (\BLT (\ADDBASE OBASE FIRSTNEW)
+                         (\ADDBASE RBASE ROFFST)
+                         RLEN))
+             [(ffetch (STRINGP FATSTRINGP) of OLDSTRING)
+                                                             (* ; 
+                                                           "Smashing thin string into a fat one")
+              (for I from ROFFST to (SUB1 (+ ROFFST RLEN)) as J from FIRSTNEW
+                 do (\PUTBASEFAT OBASE J (\GETBASETHIN RBASE I]
+             (T                                              (* ; "Thin into thin is just byte blt")
+                (\MOVEBYTES RBASE ROFFST OBASE FIRSTNEW RLEN)))
+          (RETURN OLDSTRING])
+
+(SUBSTRING
+  [LAMBDA (X N M OLDPTR)                                     (* jop%: "23-Sep-86 17:48")
+    (PROG ((OLDSTRING X)
+           (START N)
+           (END M)
+           FATP BASE OFFST LEN)                              (* ; 
+                                                 "OLDSTRING START and END so don't reset user args")
+          [COND
+             ((LITATOM OLDSTRING)
+              (SETQ BASE (ffetch (LITATOM PNAMEBASE) of OLDSTRING))
+              (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of OLDSTRING))
+              (SETQ FATP (ffetch (LITATOM FATPNAMEP) of OLDSTRING))
+              (SETQ OFFST 1))
+             (T (OR (STRINGP OLDSTRING)
+                    (SETQ OLDSTRING (MKSTRING OLDSTRING)))
+                (SETQ BASE (ffetch (STRINGP BASE) of OLDSTRING))
+                (SETQ LEN (ffetch (STRINGP LENGTH) of OLDSTRING))
+                (SETQ FATP (ffetch (STRINGP FATSTRINGP) of OLDSTRING))
+                (SETQ OFFST (ffetch (STRINGP OFFST) of OLDSTRING]
+          [COND
+             ((ILESSP START 0)                               (* ; "Coerce the first index")
+              (SETQ START (IPLUS START LEN 1]
+          [COND
+             ((NULL END)                                     (* ; "Now coerce the second index")
+              (SETQ END LEN))
+             ((ILESSP END 0)
+              (SETQ END (IPLUS END LEN 1]
+          (RETURN (COND
+                     ((AND (IGREATERP START 0)
+                           (ILEQ START END)
+                           (ILEQ END LEN))
+                      (UNINTERRUPTABLY
+                          [COND
+                             ((STRINGP OLDPTR)
+                              (create STRINGP smashing OLDPTR READONLY _ (LITATOM OLDSTRING)
+                                                        BASE _ BASE TYP _ (COND
+                                                                             (FATP \ST.POS16)
+                                                                             (T \ST.BYTE))
+                                                        LENGTH _ (ADD1 (IDIFFERENCE END START))
+                                                        OFFST _ (IPLUS START OFFST -1)))
+                             (T (SETQ OLDPTR (create STRINGP
+                                                    READONLY _ (LITATOM OLDSTRING)
+                                                    BASE _ BASE
+                                                    TYP _ (COND
+                                                             (FATP \ST.POS16)
+                                                             (T \ST.BYTE))
+                                                    LENGTH _ (ADD1 (IDIFFERENCE END START))
+                                                    OFFST _ (IPLUS START OFFST -1])
+                      OLDPTR])
+
+(GNC
+  [LAMBDA (X)                                                (* jop%: "23-Sep-86 16:26")
+    (LET ((CODE (GNCCODE X)))
+         (AND CODE (FCHARACTER CODE])
+
+(GNCCODE
+  [LAMBDA (X)                                                (* jop%: "23-Sep-86 16:27")
+    (COND
+       [(STRINGP X)
+        (LET ((LEN (fetch (STRINGP LENGTH) of X))
+              (OFFST (fetch (STRINGP OFFST) of X)))
+             (COND
+                ((NOT (EQ 0 LEN))
+                 (PROG1 (\GETBASECHAR (ffetch (STRINGP FATSTRINGP) of X)
+                               (ffetch (STRINGP BASE) of X)
+                               OFFST)
+                     (UNINTERRUPTABLY
+                         (freplace (STRINGP OFFST) of X with (ADD1 OFFST))
+                         (freplace (STRINGP LENGTH) of X with (SUB1 LEN))))]
+       (T (NTHCHARCODE X 1])
+
+(GLC
+  [LAMBDA (X)                                                (* jop%: "23-Sep-86 16:25")
+    (LET ((CODE (GLCCODE X)))
+         (AND CODE (FCHARACTER CODE])
+
+(GLCCODE
+  [LAMBDA (X)                                                (* jop%: "23-Sep-86 16:26")
+    (COND
+       [(STRINGP X)
+        (LET [(LEN (SUB1 (fetch (ARRAY-HEADER FILL-POINTER) of X]
+             (COND
+                ((NOT (EQ -1 LEN))
+                 (PROG1 (\GETBASECHAR (ffetch (STRINGP FATSTRINGP) of X)
+                               (ffetch (STRINGP BASE) of X)
+                               (IPLUS LEN (ffetch (STRINGP OFFST) of X)))
+                     (UNINTERRUPTABLY
+                         (freplace (ARRAY-HEADER FILL-POINTER-P) of X with T)
+                         (freplace (ARRAY-HEADER FILL-POINTER) of X with LEN)))]
+       (T (NTHCHARCODE X -1])
+
+(STREQUAL
+  [LAMBDA (X Y)                                              (* ; "Edited 10-Jun-88 16:16 by TAL")
+    (DECLARE (LOCALVARS . T))
+    (AND (STRINGP X)
+         (STRINGP Y)
+         (PROG ((LEN (ffetch (STRINGP LENGTH) of X)))
+               (COND
+                  ((NEQ LEN (ffetch (STRINGP LENGTH) of Y))
+                   (RETURN)))
+               (RETURN (PROG ((BASEX (ffetch (STRINGP BASE) of X))
+                              (BNX (ffetch (STRINGP OFFST) of X))
+                              (FATPX (ffetch (STRINGP FATSTRINGP) of X))
+                              (BASEY (ffetch (STRINGP BASE) of Y))
+                              (BNY (ffetch (STRINGP OFFST) of Y))
+                              (FATPY (ffetch (STRINGP FATSTRINGP) of Y)))
+                             (COND
+                                ((OR (NEQ 0 BNX)
+                                     (NEQ 0 BNY)
+                                     FATPX FATPY)
+                                 (GO SLOWLP)))
+                         LP  (COND
+                                ((EQ 0 LEN)
+                                 (RETURN T)))
+                             (add LEN -1)
+                             (COND
+                                ((NEQ (\GETBASEBYTE BASEX LEN)
+                                      (\GETBASEBYTE BASEY LEN))
+                                 (RETURN)))
+                             (GO LP)
+                         SLOWLP
+                             (COND
+                                ((EQ 0 LEN)
+                                 (RETURN T))
+                                ((NEQ (\GETBASECHAR FATPX BASEX BNX)
+                                      (\GETBASECHAR FATPY BASEY BNY))
+                                 (RETURN))
+                                (T (add BNX 1)
+                                   (add BNY 1)
+                                   (add LEN -1)
+                                   (GO SLOWLP])
+
+(STRING.EQUAL
+  [LAMBDA (X Y)                                              (* jop%: "23-Sep-86 16:38")
+
+(* ;;; "True if X and Y are equal atoms or strings without respect to alphabetic case")
+
+    (PROG (CABASE LEN BASEX OFFSETX FATPX BASEY OFFSETY FATPY C1 C2)
+          (COND
+             ((LITATOM X)
+              (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))
+              (SETQ BASEX (ffetch (LITATOM PNAMEBASE) of X))
+              (SETQ OFFSETX 1)
+              (SETQ FATPX (ffetch (LITATOM FATPNAMEP) of X)))
+             ((STRINGP X)
+              (SETQ LEN (ffetch (STRINGP LENGTH) of X))
+              (SETQ BASEX (ffetch (STRINGP BASE) of X))
+              (SETQ OFFSETX (ffetch (STRINGP OFFST) of X))
+              (SETQ FATPX (ffetch (STRINGP FATSTRINGP) of X)))
+             (T (RETURN NIL)))
+          (COND
+             ((LITATOM Y)
+              (COND
+                 ((NEQ LEN (ffetch (LITATOM PNAMELENGTH) of Y))
+                  (RETURN)))
+              (SETQ BASEY (ffetch (LITATOM PNAMEBASE) of Y))
+              (SETQ OFFSETY 1)
+              (SETQ FATPY (ffetch (LITATOM FATPNAMEP) of Y)))
+             ((STRINGP Y)
+              (COND
+                 ((NEQ LEN (ffetch (STRINGP LENGTH) of Y))
+                  (RETURN)))
+              (SETQ BASEY (ffetch (STRINGP BASE) of Y))
+              (SETQ OFFSETY (ffetch (STRINGP OFFST) of Y))
+              (SETQ FATPY (ffetch (STRINGP FATSTRINGP) of Y)))
+             (T (RETURN NIL)))
+          [COND
+             ((NEQ (ffetch (ARRAYP TYP) of (\DTEST UPPERCASEARRAY 'ARRAYP))
+                   \ST.BYTE)                                 (* ; 
+                                                           "Someone smashed UPPERCASEARRAY ?")
+              (SETQ UPPERCASEARRAY (UPPERCASEARRAY]
+          (SETQ CABASE (ffetch (ARRAYP BASE) of UPPERCASEARRAY))
+          (RETURN (COND
+                     [(OR FATPX FATPY)                       (* ; "Slow case")
+                      (for BNX from OFFSETX as BNY from OFFSETY as I to
+                                                                                         LEN
+                         always (PROGN (SETQ C1 (\GETBASECHAR FATPX BASEX BNX))
+                                           (SETQ C2 (\GETBASECHAR FATPY BASEY BNY))
+                                           (COND
+                                              ((OR (IGREATERP C1 \MAXTHINCHAR)
+                                                   (IGREATERP C2 \MAXTHINCHAR))
+                                                             (* ; "Fat chars not alphabetic")
+                                               (EQ C1 C2))
+                                              (T (EQ (\GETBASEBYTE CABASE C1)
+                                                     (\GETBASEBYTE CABASE C2]
+                     (T (for BNX from OFFSETX as BNY from OFFSETY as I
+                           to LEN always (EQ (\GETBASEBYTE CABASE (\GETBASETHIN BASEX BNX))
+                                                     (\GETBASEBYTE CABASE (\GETBASETHIN BASEY BNY])
+
+(STRINGP
+  [LAMBDA (OBJECT)                                           (* jop%: "24-Sep-86 22:58")
+    (AND (%%STRINGP OBJECT)
+         OBJECT])
+
+(CHCON1
+  [LAMBDA (X)                                                (* jop%: "23-Sep-86 17:45")
+
+(* ;;; "This is opencoded NTHCHARCODE* for the case where N=1 and FLG=NIL")
+
+    (COND
+       [(STRINGP X)
+        (AND (NEQ (fetch (STRINGP LENGTH) of X)
+                  0)
+             (\GETBASECHAR (fetch (STRINGP FATSTRINGP) of X)
+                    (fetch (STRINGP BASE) of X)
+                    (fetch (STRINGP OFFST) of X]
+       ((LITATOM X)
+        (AND (NEQ (ffetch (LITATOM PNAMELENGTH) of X)
+                  0)
+             (\GETBASECHAR (ffetch (LITATOM FATPNAMEP) of X)
+                    (ffetch (LITATOM PNAMEBASE) of X)
+                    1)))
+       (T (NTHCHARCODE X 1])
+
+(U-CASE
+  [LAMBDA (X)                                                (* ; "Edited 10-Feb-87 19:12 by bvm:")
+    (COND
+       [(LITATOM X)
+        (WITH-RESOURCE (\PNAMESTRING)
+               (for C CHANGEFLG (BASE _ (ffetch (STRINGP BASE) of \PNAMESTRING))
+                  inatom X as I from 0
+                  do (\PNAMESTRINGPUTCHAR BASE I (COND
+                                                        [(AND (IGEQ C (CHARCODE a))
+                                                              (ILEQ C (CHARCODE z)))
+                                                         (SETQ CHANGEFLG (IPLUS C (IDIFFERENCE
+                                                                                   (CHARCODE A)
+                                                                                   (CHARCODE a]
+                                                        (T C)))
+                  finally (RETURN (COND
+                                         ((OR CHANGEFLG (NEQ (LISP:SYMBOL-PACKAGE X)
+                                                             *INTERLISP-PACKAGE*))
+                                          (\MKATOM BASE 0 I \FATPNAMESTRINGP))
+                                         (T                  (* ; 
+                           "Don't bother calling \MKATOM if X already uppercase and interned in IL")
+                                            X]
+       ((STRINGP X)
+        (for C BASE NEWSTRING (FATP _ (ffetch (STRINGP FATSTRINGP) of X))
+           instring X as I from 0 first (SETQ NEWSTRING (ALLOCSTRING (
+                                                                                        \NSTRINGCHARS
+                                                                                          X)
+                                                                               NIL NIL FATP))
+                                                    (SETQ BASE (ffetch (STRINGP XBASE)
+                                                                  of NEWSTRING))
+           do (\PUTBASECHAR FATP BASE I (COND
+                                               [(AND (IGEQ C (CHARCODE a))
+                                                     (ILEQ C (CHARCODE z)))
+                                                (IPLUS C (IDIFFERENCE (CHARCODE A)
+                                                                (CHARCODE a]
+                                               (T C))) finally (RETURN NEWSTRING)))
+       [(LISTP X)
+        (CONS (U-CASE (CAR X))
+              (AND (CDR X)
+                   (U-CASE (CDR X]
+       (T X])
+
+(L-CASE
+  [LAMBDA (X FLG)                                            (* ; "Edited 10-Feb-87 19:12 by bvm:")
+    (COND
+       [(LITATOM X)
+        (WITH-RESOURCE (\PNAMESTRING)
+               (for C CHANGEFLG (BASE _ (ffetch (STRINGP XBASE) of \PNAMESTRING))
+                  inatom X as I from 0
+                  do [COND
+                            [(AND (IGEQ C (CHARCODE A))
+                                  (ILEQ C (CHARCODE Z)))
+                             (COND
+                                (FLG (SETQ FLG NIL))
+                                (T (SETQ CHANGEFLG (SETQ C (IPLUS C (IDIFFERENCE (CHARCODE a)
+                                                                           (CHARCODE A]
+                            ([AND FLG (AND (IGEQ C (CHARCODE a))
+                                           (ILEQ C (CHARCODE z]
+                             (SETQ FLG NIL)
+                             (SETQ CHANGEFLG (SETQ C (IPLUS C (IDIFFERENCE (CHARCODE A)
+                                                                     (CHARCODE a]
+                        (\PNAMESTRINGPUTCHAR BASE I C)
+                  finally (RETURN (COND
+                                         ((OR CHANGEFLG (NEQ (LISP:SYMBOL-PACKAGE X)
+                                                             *INTERLISP-PACKAGE*))
+                                          (\MKATOM BASE 0 I \FATPNAMESTRINGP))
+                                         (T                  (* ; 
+                           "Don't bother calling \MKATOM if X already lowercase and interned in IL")
+                                            X]
+       ((STRINGP X)
+        (for C BASE NEWSTRING (FATP _ (ffetch (STRINGP FATSTRINGP) of X))
+           instring X as I from 0 first (SETQ NEWSTRING (ALLOCSTRING (
+                                                                                        \NSTRINGCHARS
+                                                                                          X)
+                                                                               NIL NIL FATP))
+                                                    (SETQ BASE (ffetch (STRINGP BASE)
+                                                                  of NEWSTRING))
+           do [COND
+                     [(AND (IGEQ C (CHARCODE A))
+                           (ILEQ C (CHARCODE Z)))
+                      (COND
+                         (FLG (SETQ FLG NIL))
+                         (T (SETQ C (IPLUS C (IDIFFERENCE (CHARCODE a)
+                                                    (CHARCODE A]
+                     ([AND FLG (AND (IGEQ C (CHARCODE a))
+                                    (ILEQ C (CHARCODE z]
+                      (SETQ FLG NIL)
+                      (SETQ C (IPLUS C (IDIFFERENCE (CHARCODE A)
+                                              (CHARCODE a]
+                 (\PUTBASECHAR FATP BASE I C) finally (RETURN NEWSTRING)))
+       [(LISTP X)
+        (CONS (L-CASE (CAR X)
+                     FLG)
+              (AND (CDR X)
+                   (L-CASE (CDR X)
+                          FLG]
+       (T X])
+
+(FLIP-CASE
+  [LAMBDA (X)                                                (* ; "Edited 30-May-91 16:47 by jrb:")
+    (COND
+       [(LITATOM X)
+        (WITH-RESOURCE (\PNAMESTRING)
+               (for C CHANGEFLG (BASE _ (ffetch (STRINGP BASE) of \PNAMESTRING))
+                  inatom X as I from 0
+                  do (\PNAMESTRINGPUTCHAR BASE I (COND
+                                                        [(AND (IGEQ C (CHARCODE a))
+                                                              (ILEQ C (CHARCODE z)))
+                                                         (SETQ CHANGEFLG (IPLUS C (IDIFFERENCE
+                                                                                   (CHARCODE A)
+                                                                                   (CHARCODE a]
+                                                        [(AND (IGEQ C (CHARCODE A))
+                                                              (ILEQ C (CHARCODE Z)))
+                                                         (SETQ CHANGEFLG (IDIFFERENCE
+                                                                          C
+                                                                          (IDIFFERENCE (CHARCODE
+                                                                                        A)
+                                                                                 (CHARCODE a]
+                                                        (T C)))
+                  finally (RETURN (COND
+                                         ((OR CHANGEFLG (NEQ (LISP:SYMBOL-PACKAGE X)
+                                                             *INTERLISP-PACKAGE*))
+                                          (\MKATOM BASE 0 I \FATPNAMESTRINGP))
+                                         (T                  (* ; 
+                           "Don't bother calling \MKATOM if X already uppercase and interned in IL")
+                                            X]
+       ((STRINGP X)
+        (for C BASE NEWSTRING (FATP _ (ffetch (STRINGP FATSTRINGP) of X))
+           instring X as I from 0 first (SETQ NEWSTRING (ALLOCSTRING (
+                                                                                        \NSTRINGCHARS
+                                                                                          X)
+                                                                               NIL NIL FATP))
+                                                    (SETQ BASE (ffetch (STRINGP XBASE)
+                                                                  of NEWSTRING))
+           do (\PUTBASECHAR FATP BASE I (COND
+                                               [(AND (IGEQ C (CHARCODE a))
+                                                     (ILEQ C (CHARCODE z)))
+                                                (IPLUS C (IDIFFERENCE (CHARCODE A)
+                                                                (CHARCODE a]
+                                               [(AND (IGEQ C (CHARCODE A))
+                                                     (ILEQ C (CHARCODE Z)))
+                                                (IDIFFERENCE C (IDIFFERENCE (CHARCODE A)
+                                                                      (CHARCODE a]
+                                               (T C))) finally (RETURN NEWSTRING)))
+       [(LISTP X)
+        (CONS (FLIP-CASE (CAR X))
+              (AND (CDR X)
+                   (FLIP-CASE (CDR X]
+       (T X])
+
+(U-CASEP
+  [LAMBDA (X)                                                (* jop%: "23-Sep-86 16:43")
+    (COND
+       [(LITATOM X)
+        (for C inatom X never (AND (IGEQ C (CHARCODE a))
+                                               (ILEQ C (CHARCODE z]
+       [(STRINGP X)
+        (for C instring X never (AND (IGEQ C (CHARCODE a))
+                                                 (ILEQ C (CHARCODE z]
+       [(LISTP X)
+        (AND (U-CASEP (CAR X))
+             (OR (NULL (CDR X))
+                 (U-CASEP (CDR X]
+       (T T])
+
+(L-CASEP
+  [LAMBDA (X)                                                (* ; "Edited 30-May-91 16:39 by jrb:")
+    (COND
+       [(LITATOM X)
+        (for C inatom X never (AND (IGEQ C (CHARCODE A))
+                                               (ILEQ C (CHARCODE Z]
+       [(STRINGP X)
+        (for C instring X never (AND (IGEQ C (CHARCODE A))
+                                                 (ILEQ C (CHARCODE Z]
+       [(LISTP X)
+        (AND (L-CASEP (CAR X))
+             (OR (NULL (CDR X))
+                 (L-CASEP (CDR X]
+       (T T])
+
+(U-CASE-STRINGS
+  [LAMBDA (X)                                                (* ; "Edited 11-Jul-91 14:33 by jrb:")
+    (COND
+       [(LISTP X)
+        (CONS (U-CASE-STRINGS (CAR X))
+              (U-CASE-STRINGS (CDR X]
+       ((STRINGP X)
+        (for C BASE NEWSTRING (FATP _ (ffetch (STRINGP FATSTRINGP) of X))
+           instring X as I from 0 first (SETQ NEWSTRING (ALLOCSTRING (
+                                                                                        \NSTRINGCHARS
+                                                                                          X)
+                                                                               NIL NIL FATP))
+                                                    (SETQ BASE (ffetch (STRINGP XBASE)
+                                                                  of NEWSTRING))
+           do (\PUTBASECHAR FATP BASE I (COND
+                                               [(AND (IGEQ C (CHARCODE a))
+                                                     (ILEQ C (CHARCODE z)))
+                                                (IPLUS C (IDIFFERENCE (CHARCODE A)
+                                                                (CHARCODE a]
+                                               (T C))) finally (RETURN NEWSTRING)))
+       (T X])
+
+(\SMASHABLESTRING
+  [LAMBDA (STR FATP)                                         (* gbn "18-Apr-85 00:39")
+
+    (* ;; "Ensures that FATP characters can be smashed into STR")
+
+    (COND
+       [(ffetch (STRINGP READONLY) of STR)
+        (\MAKEWRITABLESTRING STR (OR FATP (ffetch (STRINGP FATSTRINGP) of STR]
+       ((AND FATP (NOT (ffetch (STRINGP FATSTRINGP) of STR)))
+        (\FATTENSTRING STR)))
+    STR])
+
+(\MAKEWRITABLESTRING
+  [LAMBDA (STR NEWFATP)                                      (* jop%: "23-Sep-86 16:44")
+
+(* ;;; "takes a string pointing at a readonly pname and changes the string to point to a block of writable memory of the appropriate width")
+
+    (%%MAKE-ARRAY-WRITEABLE STR)
+    (if (AND NEWFATP (NOT (ffetch (STRINGP FATSTRINGP) of STR)))
+        then (%%MAKE-STRING-ARRAY-FAT STR))
+    STR])
+
+(\SMASHSTRING
+  [LAMBDA (DEST POS SOURCE NC)                               (* jop%: "23-Sep-86 16:51")
+
+(* ;;; "copy NC characters from the string SOURCE to the string DEST starting at character POS (counting from 0) of DEST.  If NC=NIL, length of SOURCE is used.  DEST is presumed to be not READONLY, long enough for the smash, and to be fat if SOURCE contains any fat characters--the caller must guarantee this.")
+                                                             (* ; 
+                                                    "Only caller so far is \RSTRING2 in the reader")
+    (OR NC (SETQ NC (ffetch (STRINGP LENGTH) of SOURCE)))
+    (add POS (ffetch (STRINGP OFFST) of DEST))
+    (COND
+       [(ffetch (STRINGP FATSTRINGP) of DEST)    (* ; "The destination is fat.")
+        (COND
+           ((ffetch (STRINGP FATSTRINGP) of SOURCE)
+                                                             (* ; 
+                                    "The source is also;  just copy the characters straight across")
+            (\BLT (\ADDBASE (ffetch (STRINGP BASE) of DEST)
+                         POS)
+                  (\ADDBASE (ffetch (STRINGP BASE) of SOURCE)
+                         (ffetch (STRINGP OFFST) of SOURCE))
+                  NC))
+           (T                                                (* ; 
+                                                           "Have to do thin-to-fat conversion")
+              (bind (DBASE _ (ffetch (STRINGP BASE) of DEST)) for C 
+                                                                                      inthinstring
+                                                                                        SOURCE
+                 as DESTCH# from POS as SRCH# from 1 to NC
+                 do                                      (* ; 
+                    "Run thru chars 1..NC (or len) of the source, moving them into the destination")
+                       (\PUTBASEFAT DBASE DESTCH# C]
+       ((ffetch (STRINGP FATSTRINGP) of SOURCE)  (* ; 
+       "Assume that SOURCE is FATP with no fat characters.  This is a guarantee made by \RSTRING2.")
+        (bind (DBASE _ (ffetch (STRINGP BASE) of DEST)) for C infatstring
+                                                                                  SOURCE as
+                                                                                         DESTCH#
+           from POS as SRCH# from 1 to NC do 
+                                                             (* ; 
+                    "Run thru chars 1..NC (or len) of the source, moving them into the destination")
+                                                                (AND (IGREATERP C \MAXTHINCHAR)
+                                                                     (SHOULDNT)) 
+                                                             (* ; 
+                                                "If we find an unexpected fat character, complain!")
+                                                                (\PUTBASETHIN DBASE DESTCH# C)))
+       (T                                                    (* ; 
+                                 "The source and destination are both thin.  Just copy characters.")
+          (\MOVEBYTES (ffetch (STRINGP BASE) of SOURCE)
+                 (ffetch (STRINGP OFFST) of SOURCE)
+                 (ffetch (STRINGP BASE) of DEST)
+                 POS NC)))
+    DEST])
+
+(\FATTENSTRING
+  [LAMBDA (STR)                                              (* jop%: "11-Sep-86 18:00")
+    (%%MAKE-STRING-ARRAY-FAT STR])
+)
+
+
+
+(* ; "Temporary until low level system is changed to call STRING.EQUAL again")
+
+
+(MOVD? 'STRING.EQUAL 'STRING-EQUAL NIL T)
+
+(MOVD? 'STRING.EQUAL 'LISP::SIMPLE-STRING-EQUAL NIL T)
+(DEFINEQ
+
+(\GETBASESTRING
+  [LAMBDA (BASE BYTEOFFSET NCHARS FATP)                      (* jop%: "23-Sep-86 17:50")
+
+(* ;;; "Makes a string consisting of NCHARS characters starting at BYTEOFFSET from BASE -- note that caller must know whether the string is fat (see \PUTBASESTRING);  BYTEOFFSET is always a byte offset in either case")
+
+    (LET ((STR (ALLOCSTRING NCHARS NIL NIL FATP)))
+         (\MOVEBYTES BASE BYTEOFFSET (fetch (STRINGP BASE) of STR)
+                (fetch (STRINGP OFFST) of STR)
+                (COND
+                   (FATP (UNFOLD NCHARS BYTESPERWORD))
+                   (T NCHARS)))
+         STR])
+
+(\PUTBASESTRING
+  [LAMBDA (BASE BYTEOFFSET SOURCE FATP)                      (* jop%: "23-Sep-86 16:48")
+
+    (* ;; "In addition to putting the bytes into memory, this guy returns the number of characters `written' , since the source may not be a STRINGP, but will be coerced to one.")
+
+    (* ;; "Not clear what this fn should do with fat strings.  Caller is using this fn to store raw characters into some random location, so must make some assumption about the format they are stored in.  Hence if there's a fat string, but FATP is false, we don't know what to do")
+
+    (COND
+       ((STRINGP SOURCE)
+        (COND
+           (FATP (\PUTBASESTRINGFAT BASE BYTEOFFSET (ffetch (STRINGP BASE) of SOURCE)
+                        (ffetch (STRINGP OFFST) of SOURCE)
+                        (ffetch (STRINGP LENGTH) of SOURCE)
+                        (ffetch (STRINGP FATSTRINGP) of SOURCE)))
+           ((ffetch (STRINGP FATSTRINGP) of SOURCE)
+            [for CH infatstring SOURCE as OFFSET from BYTEOFFSET
+               do (COND
+                         ((ILEQ CH \MAXTHINCHAR)
+                          (\PUTBASEBYTE BASE OFFSET CH))
+                         (T (ERROR "Fat string in \PUTBASESTRING" SOURCE]
+            (ffetch (STRINGP LENGTH) of SOURCE))
+           (T (\MOVEBYTES (ffetch (STRINGP BASE) of SOURCE)
+                     (ffetch (STRINGP OFFST) of SOURCE)
+                     BASE BYTEOFFSET (SETQ SOURCE (ffetch (STRINGP LENGTH) of SOURCE)))
+              SOURCE)))
+       ((LITATOM SOURCE)
+        (COND
+           (FATP (\PUTBASESTRINGFAT BASE BYTEOFFSET (ffetch (LITATOM PNAMEBASE) of SOURCE
+                                                               )
+                        1
+                        (ffetch (LITATOM PNAMELENGTH) of SOURCE)
+                        (ffetch (LITATOM FATPNAMEP) of SOURCE)))
+           ((ffetch (LITATOM FATPNAMEP) of SOURCE)
+            [for CH infatatom SOURCE as OFFSET from BYTEOFFSET
+               do (COND
+                         ((ILEQ CH \MAXTHINCHAR)
+                          (\PUTBASEBYTE BASE OFFSET CH))
+                         (T (ERROR "Fat string in \PUTBASESTRING" SOURCE]
+            (ffetch (LITATOM PNAMELENGTH) of SOURCE))
+           (T (\MOVEBYTES (ffetch (LITATOM PNAMEBASE) of SOURCE)
+                     1 BASE BYTEOFFSET (SETQ SOURCE (ffetch (LITATOM PNAMELENGTH) of SOURCE))
+                     )
+              SOURCE)))
+       (T (\PUTBASESTRING BASE BYTEOFFSET (MKSTRING SOURCE)
+                 FATP])
+
+(\PUTBASESTRINGFAT
+  [LAMBDA (DBASE DBYTEOFFSET SBASE SOFFSET LEN FATP)         (* jop%: " 8-Sep-86 21:02")
+
+(* ;;; "Store a fat string at byte offset from DBASE.  SBASE and SOFFSET are in the source's units (bytes or words)")
+
+    [COND
+       (FATP (\MOVEBYTES SBASE (UNFOLD SOFFSET BYTESPERWORD)
+                    DBASE DBYTEOFFSET (UNFOLD LEN BYTESPERWORD)))
+       (T                                                    (* ; "Store thin string in fat format")
+          (for I from 0 to (SUB1 LEN) as DOFF from DBYTEOFFSET by 2
+             do (\PUTBASETHIN DBASE DOFF 0)
+                   (\PUTBASETHIN DBASE (ADD1 DOFF)
+                          (\GETBASETHIN SBASE (IPLUS SOFFSET I]
+    LEN])
+
+(GetBcplString
+  [LAMBDA (BASE ATOMFLG)                                     (* jop%: "23-Sep-86 17:46")
+
+    (* ;; "Returns as a Lisp string the Bcpl string stored at BS.  Format is one byte length, follwed by chars.  If ATOMFLG is true, returns result as an atom")
+
+    (LET ((L (\GETBASEBYTE BASE 0))
+          S)
+         (COND
+            ((AND ATOMFLG (ILEQ L \PNAMELIMIT))
+             (\MKATOM BASE 1 L))
+            (T (SETQ S (\GETBASESTRING BASE 1 L))
+               (COND
+                  (ATOMFLG                                   (* ; "Let MKATOM handle the error")
+                         (MKATOM S))
+                  (T S])
+
+(SetBcplString
+  [LAMBDA (BASE STR)                                         (* bvm%: " 5-Jul-85 21:50")
+    (LET ((L (NCHARS STR)))
+         (COND
+            ((IGREATERP L 255)
+             (LISPERROR "ILLEGAL ARG" BASE))
+            (T (\PUTBASEBYTE BASE 0 L)
+               (\PUTBASESTRING BASE 1 STR)))
+         BASE])
+)
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
+
+(ACCESSFNS STRINGP ((XREADONLY (fetch (ARRAY-HEADER READ-ONLY-P) of DATUM)
+                               (replace (ARRAY-HEADER READ-ONLY-P) of DATUM with NEWVALUE
+                                      ))
+                        (XBASE ([OPENLAMBDA (STRING)
+                                       (COND
+                                          ((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
+                                           (%%ARRAY-BASE STRING))
+                                          (T (fetch (ARRAY-HEADER BASE) of STRING]
+                                DATUM)
+                               ((OPENLAMBDA (STRING NV)
+                                       (replace (ARRAY-HEADER INDIRECT-P) of STRING
+                                          with NIL)
+                                       (replace (ARRAY-HEADER BASE) of STRING with NV)
+                                       NV)
+                                DATUM NEWVALUE))
+                        (TYP ((OPENLAMBDA (STRING)
+                                     (SELECTC (COND
+                                                 ((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
+                                                  (%%ARRAY-TYPE-NUMBER STRING))
+                                                 (T (fetch (ARRAY-HEADER TYPE-NUMBER)
+                                                       of STRING)))
+                                         (%%THIN-CHAR-TYPENUMBER 
+                                              \ST.BYTE)
+                                         (%%FAT-CHAR-TYPENUMBER 
+                                              \ST.POS16)
+                                         (SHOULDNT "Unknown type-number")))
+                              DATUM)
+                             ([OPENLAMBDA (STRING NV)
+                                     (LET [(%%NEW-TYPE-NUMBER (SELECTC NV
+                                                                  (\ST.BYTE %%THIN-CHAR-TYPENUMBER)
+                                                                  (\ST.POS16 %%FAT-CHAR-TYPENUMBER)
+                                                                  (SHOULDNT "Unknown typ value"]
+                                          (COND
+                                             ((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
+                                              (%%SET-ARRAY-TYPE-NUMBER STRING %%NEW-TYPE-NUMBER))
+                                             (T (replace (ARRAY-HEADER TYPE-NUMBER) of STRING
+                                                   with %%NEW-TYPE-NUMBER]
+                              DATUM NEWVALUE))
+                        (LENGTH (fetch (ARRAY-HEADER FILL-POINTER) of DATUM)
+                               ((OPENLAMBDA (STRING NV)
+                                       (replace (ARRAY-HEADER FILL-POINTER) of STRING
+                                          with NV)
+                                       (replace (ARRAY-HEADER TOTAL-SIZE) of STRING
+                                          with NV)
+                                       [COND
+                                          ((%%GENERAL-ARRAY-P STRING)
+                                           (freplace (GENERAL-ARRAY DIMS) of STRING
+                                              with (LIST NV]
+                                       NV)
+                                DATUM NEWVALUE))
+                        (OFFST ([OPENLAMBDA (STRING)
+                                       (COND
+                                          ((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
+                                           (%%ARRAY-OFFSET STRING))
+                                          (T (fetch (ARRAY-HEADER OFFSET) of STRING]
+                                DATUM)
+                               ([OPENLAMBDA (STRING NV)
+                                       (COND
+                                          ((NOT (EQ 0 NV))
+                                           (replace (ARRAY-HEADER DISPLACED-P) of STRING
+                                              with T)))
+                                       (COND
+                                          ((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
+                                           (%%SET-ARRAY-OFFSET STRING NV))
+                                          (T (replace (ARRAY-HEADER OFFSET) of STRING
+                                                with NV]
+                                DATUM NEWVALUE))
+
+                        (* ;; "The rest of these fields only appear when smashing")
+
+                        (XFLAGS (LOGAND (fetch (ARRAY-HEADER FLAGS) of DATUM)
+                                       15)
+                               ((OPENLAMBDA (STRING)
+                                       (replace (ARRAY-HEADER ADJUSTABLE-P) of STRING
+                                          with NIL)
+                                       (replace (ARRAY-HEADER DISPLACED-P) of STRING
+                                          with NIL)
+                                       (replace (ARRAY-HEADER FILL-POINTER-P) of STRING
+                                          with NIL)
+                                       (replace (ARRAY-HEADER EXTENDABLE-P) of STRING
+                                          with NIL))
+                                DATUM)))
+                       [ACCESSFNS STRINGP
+                              ((ORIG ((OPENLAMBDA (STRING)
+                                             1)
+                                      DATUM)
+                                     ((OPENLAMBDA (STRING NV)
+                                             (COND
+                                                ((NOT (EQ NV 1))
+                                                 (ERROR "Il:stringp's are always origin 1")))
+                                             NV)
+                                      DATUM NEWVALUE))       (* ; "An inoperative field")
+                               (SUBSTRINGED ((OPENLAMBDA (STRING)
+                                                    NIL)
+                                             DATUM)
+                                      ((OPENLAMBDA (STRING NV)
+                                              (OR (NULL NV)
+                                                  (ERROR "Substringed field not supported")))
+                                       DATUM NEWVALUE))
+                               (READONLY (ffetch (STRINGP XREADONLY) of DATUM)
+                                      (freplace (STRINGP XREADONLY) of DATUM with 
+                                                                                           NEWVALUE))
+                               (FATSTRINGP ((OPENLAMBDA (STRING)
+                                                   (EQ (COND
+                                                          ((fetch (ARRAY-HEADER INDIRECT-P)
+                                                              of STRING)
+                                                           (%%ARRAY-TYPE-NUMBER STRING))
+                                                          (T (fetch (ARRAY-HEADER TYPE-NUMBER)
+                                                                of STRING)))
+                                                       %%FAT-CHAR-TYPENUMBER))
+                                            DATUM)
+                                      ([OPENLAMBDA (STRING NV)
+                                              (LET [(%%NEW-TYPE-NUMBER (COND
+                                                                          (NV %%FAT-CHAR-TYPENUMBER)
+                                                                          (T %%THIN-CHAR-TYPENUMBER]
+                                                   (COND
+                                                      ((fetch (ARRAY-HEADER INDIRECT-P)
+                                                          of STRING)
+                                                       (%%SET-ARRAY-TYPE-NUMBER STRING 
+                                                              %%NEW-TYPE-NUMBER))
+                                                      (T (replace (ARRAY-HEADER TYPE-NUMBER)
+                                                            of STRING with %%NEW-TYPE-NUMBER]
+                                       DATUM NEWVALUE))
+                               (BASE (ffetch (STRINGP XBASE) of DATUM)
+                                     (freplace (STRINGP XBASE) of DATUM with NEWVALUE]
+                       (CREATE (create ONED-ARRAY
+                                          BASE _ XBASE
+                                          READ-ONLY-P _ XREADONLY
+                                          STRING-P _ T
+                                          DISPLACED-P _ (NOT (EQ OFFST 0))
+                                          TYPE-NUMBER _ (COND
+                                                           ((EQ TYP \ST.POS16)
+                                                            %%FAT-CHAR-TYPENUMBER)
+                                                           (T %%THIN-CHAR-TYPENUMBER))
+                                          OFFSET _ OFFST
+                                          FILL-POINTER _ LENGTH
+                                          TOTAL-SIZE _ LENGTH))
+                       (TYPE? (LISP:STRINGP DATUM))
+                       OFFST _ 0 TYP _ \ST.BYTE LENGTH _ 0)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \OneCharAtomBase)
+)
+(DECLARE%: EVAL@COMPILE 
+
+[PUTDEF '\NUMSTR 'RESOURCES '(NEW (ALLOCSTRING 128]
+
+[PUTDEF '\NUMSTR1 'RESOURCES '(NEW (CONCAT]
+
+[PUTDEF '\PNAMESTRING 'RESOURCES '(NEW (ALLOCSTRING \PNAMELIMIT NIL NIL \FATPNAMESTRINGP]
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \FATPNAMESTRINGP T)
+
+
+(CONSTANTS (\FATPNAMESTRINGP T))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \PNAMESTRINGPUTCHAR MACRO ((BASE OFFSET CODE)
+                                                             (* ; 
+                                                    "For stuffing chars into resource \PNAMESTRING")
+                                             (\PUTBASECHAR \FATPNAMESTRINGP BASE OFFSET CODE)))
+)
+
+(DEFOPTIMIZER FCHARACTER (NUM)
+                             `([OPENLAMBDA (N)
+                                      (COND
+                                         ((IGREATERP N \MAXTHINCHAR)
+                                                             (* ; 
+                        "The character we're getting is NOT a thin character -- do it the hard way")
+                                          (CHARACTER N))
+                                         ((IGREATERP N (CHARCODE 9))
+                                          (\ADDBASE \OneCharAtomBase (IDIFFERENCE N 10)))
+                                         ((IGEQ N (CHARCODE 0))
+                                          (IDIFFERENCE N (CHARCODE 0)))
+                                         (T                  (* ; 
+                                                "The common case -- just add on the one-atom base.")
+                                            (\ADDBASE \OneCharAtomBase N]
+                               ,NUM))
+(DECLARE%: EVAL@COMPILE 
+
+(I.S.OPR 'inpname NIL '[SUBPAIR '($$END $$BODY $$FATP $$BASE $$OFFSET)
+                                (LIST (GETDUMMYVAR)
+                                      (GETDUMMYVAR)
+                                      (GETDUMMYVAR)
+                                      (GETDUMMYVAR)
+                                      (GETDUMMYVAR))
+                                `(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP
+                                    declare (LOCALVARS $$END $$BODY $$FATP $$BASE $$OFFSET)
+                                    first [PROG NIL
+                                                $$RETRY
+                                                    (COND
+                                                       ((STRINGP $$BODY)
+                                                        (SETQ $$BASE (ffetch (STRINGP BASE)
+                                                                        of $$BODY))
+                                                        (SETQ $$OFFSET (SUB1 (ffetch (STRINGP
+                                                                                          OFFST)
+                                                                                of $$BODY)))
+                                                        (SETQ $$END (IPLUS $$OFFSET
+                                                                           (ffetch (STRINGP
+                                                                                        LENGTH)
+                                                                              of $$BODY)))
+                                                        (SETQ $$FATP (ffetch (STRINGP 
+                                                                                        FATSTRINGP)
+                                                                        of $$BODY)))
+                                                       ((LITATOM $$BODY)
+                                                        (SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
+                                                                        of $$BODY))
+                                                        (SETQ $$END (ffetch (PNAMEBASE 
+                                                                                       PNAMELENGTH)
+                                                                       of $$BASE))
+                                                        (SETQ $$FATP (ffetch (LITATOM FATPNAMEP)
+                                                                        of $$BODY)))
+                                                       (T (SETQ $$BODY (MKSTRING $$BODY))
+                                                          (GO $$RETRY]
+                                    eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
+                                          (AND (IGREATERP $$OFFSET $$END)
+                                               (GO $$OUT))
+                                          (SETQ I.V. (COND
+                                                        ($$FATP (\GETBASEFAT $$BASE $$OFFSET))
+                                                        (T (\GETBASETHIN $$BASE $$OFFSET]
+       T)
+
+(I.S.OPR 'inatom NIL '[SUBPAIR '($$OFFSET $$BODY $$BASE $$END $$FATP)
+                               (LIST (GETDUMMYVAR)
+                                     (GETDUMMYVAR)
+                                     (GETDUMMYVAR)
+                                     (GETDUMMYVAR)
+                                     (GETDUMMYVAR))
+                               '(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP
+                                   declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END $$FATP)
+                                   first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
+                                                             of $$BODY))
+                                         (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of
+                                                                                         $$BASE))
+                                         (SETQ $$FATP (ffetch (LITATOM FATPNAMEP) of $$BODY))
+                                   eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
+                                         (AND (IGREATERP $$OFFSET $$END)
+                                              (GO $$OUT))
+                                         (SETQ I.V. (COND
+                                                       ($$FATP (\GETBASEFAT $$BASE $$OFFSET))
+                                                       (T (\GETBASETHIN $$BASE $$OFFSET]
+       T)
+
+(I.S.OPR 'instring NIL '[SUBPAIR '($$BODY $$END $$OFFSET $$BASE $$FATP)
+                                 (LIST (GETDUMMYVAR)
+                                       (GETDUMMYVAR)
+                                       (GETDUMMYVAR)
+                                       (GETDUMMYVAR)
+                                       (GETDUMMYVAR))
+                                 '(bind $$BODY _ BODY $$END $$OFFSET $$BASE $$FATP
+                                     declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE $$FATP)
+                                     first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
+                                                                       of $$BODY)))
+                                           (SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY)
+                                            )
+                                           (SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP
+                                                                                    LENGTH)
+                                                                          of $$BODY)))
+                                           (SETQ $$FATP (ffetch (STRINGP FATSTRINGP)
+                                                           of $$BODY))
+                                     eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
+                                           (AND (IGREATERP $$OFFSET $$END)
+                                                (GO $$OUT))
+                                           (SETQ I.V. (COND
+                                                         ($$FATP (\GETBASEFAT $$BASE $$OFFSET))
+                                                         (T (\GETBASETHIN $$BASE $$OFFSET]
+       T)
+)
+(DECLARE%: EVAL@COMPILE 
+
+(I.S.OPR 'infatatom NIL '[SUBPAIR '($$OFFSET $$BODY $$BASE $$END)
+                                  (LIST (GETDUMMYVAR)
+                                        (GETDUMMYVAR)
+                                        (GETDUMMYVAR)
+                                        (GETDUMMYVAR))
+                                  '(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END
+                                      declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END)
+                                      first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
+                                                                of $$BODY))
+                                            (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
+                                                           of $$BASE))
+                                      eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
+                                            (AND (IGREATERP $$OFFSET $$END)
+                                                 (GO $$OUT))
+                                            (SETQ I.V. (\GETBASEFAT $$BASE $$OFFSET]
+       T)
+
+(I.S.OPR 'inthinatom NIL '[SUBPAIR '($$OFFSET $$BODY $$BASE $$END)
+                                   (LIST (GETDUMMYVAR)
+                                         (GETDUMMYVAR)
+                                         (GETDUMMYVAR)
+                                         (GETDUMMYVAR))
+                                   '(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END
+                                       declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END)
+                                       first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
+                                                                 of $$BODY))
+                                             (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
+                                                            of $$BASE))
+                                       eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
+                                             (AND (IGREATERP $$OFFSET $$END)
+                                                  (GO $$OUT))
+                                             (SETQ I.V. (\GETBASETHIN $$BASE $$OFFSET]
+       T)
+
+(I.S.OPR 'infatstring NIL '[SUBPAIR '($$BODY $$END $$OFFSET $$BASE)
+                                    (LIST (GETDUMMYVAR)
+                                          (GETDUMMYVAR)
+                                          (GETDUMMYVAR)
+                                          (GETDUMMYVAR))
+                                    '(bind $$BODY _ BODY $$END $$OFFSET $$BASE
+                                        declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE)
+                                        first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP
+                                                                                    OFFST)
+                                                                          of $$BODY)))
+                                              (SETQ $$BASE (ffetch (STRINGP BASE)
+                                                              of $$BODY))
+                                              (SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP
+                                                                                       LENGTH)
+                                                                             of $$BODY)))
+                                        eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
+                                              (AND (IGREATERP $$OFFSET $$END)
+                                                   (GO $$OUT))
+                                              (SETQ I.V. (\GETBASEFAT $$BASE $$OFFSET]
+       T)
+
+(I.S.OPR 'inthinstring NIL '[SUBPAIR '($$BODY $$END $$OFFSET $$BASE)
+                                     (LIST (GETDUMMYVAR)
+                                           (GETDUMMYVAR)
+                                           (GETDUMMYVAR)
+                                           (GETDUMMYVAR))
+                                     '(bind $$BODY _ BODY $$END $$OFFSET $$BASE
+                                         declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE)
+                                         first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP
+                                                                                     OFFST)
+                                                                           of $$BODY)))
+                                               (SETQ $$BASE (ffetch (STRINGP BASE)
+                                                               of $$BODY))
+                                               (SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP
+                                                                                        LENGTH)
+                                                                              of $$BODY)))
+                                         eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
+                                               (AND (IGREATERP $$OFFSET $$END)
+                                                    (GO $$OUT))
+                                               (SETQ I.V. (\GETBASETHIN $$BASE $$OFFSET]
+       T)
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \CHARCODEP DMACRO (OPENLAMBDA (X)          (* ; 
+               "used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses")
+                                           (AND (SMALLP X)
+                                                (IGEQ X 0))))
+
+(PUTPROPS \FATCHARCODEP DMACRO (OPENLAMBDA (X)       (* ; 
+               "Used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses")
+                                              (AND (SMALLP X)
+                                                   (IGREATERP X \MAXTHINCHAR))))
+
+(PUTPROPS \THINCHARCODEP DMACRO (OPENLAMBDA (X)
+                                               (AND (SMALLP X)
+                                                    (IGEQ X 0)
+                                                    (ILEQ X \MAXTHINCHAR))))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \GETBASEFAT MACRO (= . \GETBASE))
+
+(PUTPROPS \GETBASETHIN MACRO (= . \GETBASEBYTE))
+
+(PUTPROPS \PUTBASEFAT MACRO (= . \PUTBASE))
+
+(PUTPROPS \PUTBASETHIN MACRO (= . \PUTBASEBYTE))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \PUTBASECHAR MACRO [OPENLAMBDA (FATP BASE OFFSET CODE)
+                                            (COND
+                                               (FATP (\PUTBASEFAT BASE OFFSET CODE))
+                                               (T (\PUTBASETHIN BASE OFFSET CODE])
+
+(PUTPROPS \GETBASECHAR MACRO [(FATP BASE N)
+                                      (COND
+                                         (FATP (\GETBASEFAT BASE N))
+                                         (T (\GETBASETHIN BASE N])
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \CHARSET MACRO ((CHARCODE)
+                                  (LRSH CHARCODE 8)))
+
+(PUTPROPS \CHAR8CODE MACRO ((CHARCODE)
+                                    (LOGAND CHARCODE 255)))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \CHARMASK 255)
+
+(RPAQQ \MAXCHAR 255)
+
+(RPAQQ \MAXTHINCHAR 255)
+
+(RPAQQ \MAXFATCHAR 65535)
+
+(RPAQQ \MAXCHARSET 255)
+
+(RPAQQ NSCHARSETSHIFT 255)
+
+(RPAQQ %#STRINGPWORDS 4)
+
+
+(CONSTANTS (\CHARMASK 255)
+       (\MAXCHAR 255)
+       (\MAXTHINCHAR 255)
+       (\MAXFATCHAR 65535)
+       (\MAXCHARSET 255)
+       (NSCHARSETSHIFT 255)
+       (%#STRINGPWORDS 4))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \NATOMCHARS DMACRO ((AT)
+                                      (fetch (LITATOM PNAMELENGTH) of AT)))
+
+(PUTPROPS \NSTRINGCHARS DMACRO ((S)
+                                        (fetch (STRINGP LENGTH) of S)))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+
+(/SETTOPVAL '\\NUMSTR.GLOBALRESOURCE NIL)
+
+(/SETTOPVAL '\\NUMSTR1.GLOBALRESOURCE NIL)
+
+(/SETTOPVAL '\\PNAMESTRING.GLOBALRESOURCE NIL)
+
+(MOVD? 'CHARACTER 'FCHARACTER NIL T)
+(DEFINEQ
+
+(%%COPY-ONED-ARRAY
+  [LAMBDA (LOCAL-ARRAY)                                      (* jop%: "24-Sep-86 17:51")
+    (PROG ((SIZE (LOCAL (ffetch (ONED-ARRAY TOTAL-SIZE) of LOCAL-ARRAY)))
+           (BASE (LOCAL (ffetch (ONED-ARRAY BASE) of LOCAL-ARRAY)))
+           (OFFSET (LOCAL (ffetch (ONED-ARRAY OFFSET) of LOCAL-ARRAY)))
+           (TYPENUMBER (LOCAL (ffetch (ONED-ARRAY TYPE-NUMBER) of LOCAL-ARRAY)))
+           NCELLS REMOTE-ARRAY REMOTE-BASE)
+          (if (NEQ OFFSET 0)
+              then (ERROR "Can't copy an array with non-zero offset"))
+          (if (EQ (%%TYPENUMBER-TO-GC-TYPE TYPENUMBER)
+                      PTRBLOCK.GCT)
+              then (ERROR "Can't copy pointer arrays"))
+          (SETQ NCELLS (FOLDHI (ITIMES (IPLUS SIZE OFFSET)
+                                      (%%TYPENUMBER-TO-BITS-PER-ELEMENT TYPENUMBER))
+                              BITSPERCELL))
+          (SETQ REMOTE-ARRAY (create ONED-ARRAY
+                                    BASE _ (\ALLOCBLOCK NCELLS)
+                                    STRING-P _ (%%CHAR-TYPE-P TYPENUMBER)
+                                    FILL-POINTER-P _ (LOCAL (ffetch (ONED-ARRAY FILL-POINTER-P)
+                                                               of LOCAL-ARRAY))
+                                    TYPE-NUMBER _ TYPENUMBER
+                                    FILL-POINTER _ (LOCAL (ffetch (ONED-ARRAY FILL-POINTER)
+                                                             of LOCAL-ARRAY))
+                                    TOTAL-SIZE _ SIZE))
+          (SETQ REMOTE-BASE (ffetch (ONED-ARRAY BASE) of REMOTE-ARRAY))
+          [for I from 0 to (SUB1 (LLSH NCELLS 1))
+             do (\PUTBASE REMOTE-BASE I (LOCAL (\GETBASE BASE I]
+          (RETURN REMOTE-ARRAY])
+
+(%%COPY-STRING-TO-ARRAY
+  [LAMBDA (LOCAL-STRING)                                     (* jop%: "24-Sep-86 17:51")
+
+(* ;;; "Only handles thin strings")
+
+    (PROG ((SIZE (LOCAL (NCHARS LOCAL-STRING)))
+           REMOTE-BASE REMOTE-ARRAY)
+          (SETQ REMOTE-BASE (\ALLOCBLOCK (FOLDHI (ITIMES SIZE 8)
+                                                BITSPERCELL)))
+          (SETQ REMOTE-ARRAY
+           (create ONED-ARRAY
+                  BASE _ REMOTE-BASE
+                  STRING-P _ T
+                  TYPE-NUMBER _ %%THIN-CHAR-TYPENUMBER
+                  FILL-POINTER _ SIZE
+                  TOTAL-SIZE _ SIZE))
+          [for I from 0 to (SUB1 SIZE) do (\PUTBASEBYTE REMOTE-BASE I
+                                                                 (LOCAL (NTHCHARCODE LOCAL-STRING
+                                                                               (ADD1 I]
+          (RETURN REMOTE-ARRAY])
+)
+
+
+
+(* ; "For MAKEINIT")
+
+(DECLARE%: DONTCOPY 
+
+(ADDTOVAR INEWCOMS (FNS ALLOCSTRING %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY))
+
+(ADDTOVAR INEWCOMS (FILES (SYSLOAD FROM VALUEOF DIRECTORIES)
+                              CMLARRAY-SUPPORT))
+
+(ADDTOVAR EXPANDMACROFNS \PUTBASETHIN \PUTBASEFAT \CHARCODEP \GETBASECHAR \GETBASETHIN 
+                                   \GETBASEFAT \PUTBASECHAR)
+
+(ADDTOVAR DONTCOMPILEFNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY)
+)
+(DECLARE%: DONTCOPY EVAL@COMPILE 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+
+
+
+(* ;; "Arrange for the proper compiler")
+
+
+(PUTPROPS LLCHAR FILETYPE :FAKE-COMPILE-FILE)
+(PUTPROPS LLCHAR COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 
+1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (4089 77673 (ALLOCSTRING 4099 . 6122) (MKATOM 6124 . 6759) (SUBATOM 6761 . 8631) (
+CHARACTER 8633 . 9637) (\PARSE.NUMBER 9639 . 25391) (\INVALID.DOTTED.SYMBOL 25393 . 25892) (
+\INVALID.INTEGER 25894 . 27348) (\MKINTEGER 27350 . 30057) (MKSTRING 30059 . 32204) (
+\PRINDATUM.TO.STRING 32206 . 38414) (BKSYSBUF 38416 . 39954) (NCHARS 39956 . 41658) (NTHCHARCODE 41660
+ . 43708) (RPLCHARCODE 43710 . 44771) (\RPLCHARCODE 44773 . 46308) (NTHCHAR 46310 . 46503) (RPLSTRING 
+46505 . 49716) (SUBSTRING 49718 . 52641) (GNC 52643 . 52816) (GNCCODE 52818 . 53586) (GLC 53588 . 
+53761) (GLCCODE 53763 . 54528) (STREQUAL 54530 . 56588) (STRING.EQUAL 56590 . 59890) (STRINGP 59892 . 
+60043) (CHCON1 60045 . 60832) (U-CASE 60834 . 63518) (L-CASE 63520 . 66740) (FLIP-CASE 66742 . 70371) 
+(U-CASEP 70373 . 70947) (L-CASEP 70949 . 71534) (U-CASE-STRINGS 71536 . 72913) (\SMASHABLESTRING 72915
+ . 73377) (\MAKEWRITABLESTRING 73379 . 73815) (\SMASHSTRING 73817 . 77523) (\FATTENSTRING 77525 . 
+77671)) (77864 83030 (\GETBASESTRING 77874 . 78532) (\PUTBASESTRING 78534 . 81273) (\PUTBASESTRINGFAT 
+81275 . 82021) (GetBcplString 82023 . 82688) (SetBcplString 82690 . 83028)) (109320 112134 (
+%%COPY-ONED-ARRAY 109330 . 111180) (%%COPY-STRING-TO-ARRAY 111182 . 112132)))))
+STOP
diff --git a/CLTL2/LLCHAR.LCOM b/CLTL2/LLCHAR.LCOM
new file mode 100644
index 00000000..a9d616e2
Binary files /dev/null and b/CLTL2/LLCHAR.LCOM differ
diff --git a/CLTL2/LLCODE b/CLTL2/LLCODE
new file mode 100644
index 00000000..499cc17c
--- /dev/null
+++ b/CLTL2/LLCODE
@@ -0,0 +1,1272 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 16:12:45" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLCODE.;1" 60289  
+
+      previous date%: "19-Jan-93 10:45:33" "{Pele:mv:envos}<LispCore>Sources>LLCODE.;18")
+
+
+(* ; "
+Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT LLCODECOMS)
+
+(RPAQQ LLCODECOMS
+       [
+        (* ;; "THIS FILE IS DUPLICATED on <Lispcore>Sources> and <Lispcore>Sources>2-byte>, with the latter being the old 2-byte-atom version.  IF YOU CHANGE THIS ONE, CHANGE THE OTHER ONE!")
+
+        [COMS                                                (* ; "reading in compiled code")
+              (FNS DCODERD DCODESKIP \ALLOC.CODE.BLOCK \REALNAMEP \RENAMEDFN)
+              (DECLARE%: DONTEVAL@LOAD DOCOPY [VARS (CODERDTBL (COPYREADTABLE 'ORIG]
+                     (P (SETSYNTAX 25 '[MACRO (LAMBDA (FILE RDTBL)
+                                                     (EVAL (READ FILE RDTBL]
+                               CODERDTBL)
+                        (SETSYNTAX 124 '(MACRO ALWAYS READVBAR)
+                               CODERDTBL)
+                        (READTABLEPROP CODERDTBL 'USESILPACKAGE NIL)))
+              (GLOBALVARS CODERDTBL FILERDTBL)
+              (COMS 
+                    (* ;; "CODEINDICATOR is the token the compiler puts out in front of compiled definitions.  To switch to an incompatible compiled code version, choose a new value for CODEINDICATOR.  If old compiled code is still loadable in the new system, retain the CODEREADER prop for an indicators that are still loadable.")
+
+                    
+                    (* ;; "CODEINDICATOR changed to :D6 4/6/90 by JDS for Medley 1.15, because of additional opcodes emitted by compiler.")
+
+                    
+                    (* ;; "CODEINDICATOR changed to :D7 by JDS 3/4/91 for Medley 1.3, because of 3-byte atoms.  Old CODEREADER properties removed at the same time.")
+
+                    
+                    (* ;; "Changed to :D8 by JDS 11/12/92 for Medley 2.1/3.0 because of 4-byte pointers/4-byte atoms.  Old CODEREADER property removed as well, since old code is not readable.")
+
+                    (VARS (CODEINDICATOR ':D8))
+                    (GLOBALVARS CODEINDICATOR)
+                    (PROP CODEREADER * (LIST CODEINDICATOR]
+        [COMS                                                (* ; "Compiled CLOSURE type")
+              (FNS MAKE-COMPILED-CLOSURE \CCLOSURE.DEFPRINT \GET-COMPILED-DEFINITION 
+                   \GET-COMPILED-CODE-BASE EQDEFP)
+              (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS COMPILED-CLOSURE)
+                                                      (CONSTANTS \COMPILED-CLOSURE)
+                                                      (MACROS \EXTENDED.EQP)))
+              (INITRECORDS COMPILED-CLOSURE)
+              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'COMPILED-CLOSURE '\CCLOSURE.DEFPRINT]
+        [COMS                                                (* ; "utilities")
+              (FNS \FINDOP OP#)
+              
+              (* ;; 
+       "List of opcodes known to the system.  Used to drive the compilers and build the UFN table.")
+
+              
+              (* ;; "Format of an entry: (op# name #-extra-bytes ?? stack-effect ")
+
+              (VARS \OPCODES)
+              (ADDVARS (\OPCODEARRAY))
+              (GLOBALVARS \OPCODEARRAY \OPCODES)
+              (DECLARE%: EVAL@COMPILE DONTCOPY (FNS WORDSPERNAMEENTRY)
+                     (EXPORT (MACROS DPUTCODE MCODEP)
+                            (MACROS CODELT CODELT2 CODESETA2 CODESETA)
+                            (MACROS BYTESPERNAMEENTRY BYTESPERNTOFFSETENTRY GETNAMEENTRY GETNTFLAGS 
+                                   GETNTOFFSET GETNTOFFSETENTRY GETNTTAG SETNAMEENTRY 
+                                   WORDSPERNTOFFSETENTRY NTSLOT-OFFSET)
+                            (FUNCTIONS NEW-SYMBOL-CODE)
+                            (OPTIMIZERS BIG-VMEM-CODE SETSTKNAMEENTRY SETSTKNTOFFSETENTRY 
+                                   GETSTKNAMEENTRY GETSTKNTOFFSETENTRY WORDSPERNAMEENTRY 
+                                   SETSTKNTOFFSET SETSTKNAME-RAW SETSTKNTOFFSET-RAW NEW-SYMBOL-CODE 
+                                   MAKE-NTENTRY NULL-NTENTRY)
+                            (OPTIMIZERS NTSLOT-VARTYPE)
+                            (RECORDS CODEARRAY)
+                            (RECORDS OPCODE)
+                            (GLOBALVARS \OPCODES)
+                            (CONSTANTS PVARCODE FVARCODE IVARCODE VARCODEMASK)
+                            (CONSTANTS \NT.IVARCODE \NT.PVARCODE \NT.FVARCODE]
+        [COMS                                                (* ; "ufns")
+              (FNS INITUFNTABLE \SETUFNENTRY \GETUFNENTRY)
+              (FNS \UNKNOWN.UFN)
+              [DECLARE%: DONTEVAL@LOAD DOCOPY                (* ; "To go into the INIT")
+                     
+                     (* ;; "INITIALIZE THE TARGET ARCHITECTURE.")
+
+                     (INITVARS (COMPILER::*TARGET-ARCHITECTURE* '(:4-BYTE :3-BYTE))
+                            (COMPILER::*HOST-ARCHITECTURE* '(:4-BYTE :3-BYTE]
+              (DECLARE%: DONTCOPY (RECORDS UFNENTRY)
+                     (ADDVARS (INEWCOMS (FNS INITUFNTABLE \SETUFNENTRY)))
+                     EVAL@COMPILE
+                     (ADDVARS (DONTCOMPILEFNS INITUFNTABLE]
+        [COMS                                                (* ; "for MAKEINIT and READSYS")
+              (DECLARE%: DONTCOPY (ADDVARS (INEWCOMS
+                                            (FNS DCODERD)
+                                            [VARS \OPCODES (CODERDTBL (COPYREADTABLE 'ORIG]
+                                            (P (SETSYNTAX (CHARCODE ^Y)
+                                                      '[MACRO (LAMBDA (FILE RDTBL)
+                                                                     (EVALFORMAKEINIT (READ FILE 
+                                                                                            RDTBL]
+                                                      CODERDTBL)
+                                               (SETSYNTAX (CHARCODE %|)
+                                                      '(MACRO ALWAYS READVBAR)
+                                                      CODERDTBL)
+                                               (READTABLEPROP CODERDTBL 'USESILPACKAGE NIL)))
+                                         (MKI.SUBFNS (\CODEARRAY . SCRATCHARRAY)
+                                                (DPUTCODE . I.PUTDEFN)
+                                                (CODERDTBL . I.CODERDTBL)
+                                                (SETSTKNTOFFSET . I.SETSTKNTOFFSET)
+                                                (WORDSPERNAMEENTRY . I.WORDSPERNAMEENTRY))
+                                         (EXPANDMACROFNS CODELT CODELT2 CODESETA CODESETA2 DPUTCODE 
+                                                MCODEP BYTESPERNAMEENTRY BYTESPERNTOFFSETENTRY 
+                                                WORDSPERNAMEENTRY)
+                                         (RD.SUBFNS (CODELT . VGETBASEBYTE)
+                                                (CODESETA . VPUTBASEBYTE))
+                                         (RDCOMS (FNS \GET-COMPILED-CODE-BASE]
+        (PROP FILETYPE LLCODE)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA OP#)
+                                                                             (NLAML)
+                                                                             (LAMA])
+
+
+
+(* ;; 
+"THIS FILE IS DUPLICATED on <Lispcore>Sources> and <Lispcore>Sources>2-byte>, with the latter being the old 2-byte-atom version.  IF YOU CHANGE THIS ONE, CHANGE THE OTHER ONE!"
+)
+
+
+
+
+(* ; "reading in compiled code")
+
+(DEFINEQ
+
+(DCODERD
+  [LAMBDA (FN)                                               (* ; "Edited 28-Jan-91 15:45 by jds")
+
+    (* ;; "Read a function definition from an LCOM file.")
+
+    (* ;; "Much of this code is duplicated in DASSEM.DSTOREFNDEF (in file DLAP).  Any changes to the codeblock format or this function's behavior should be mirrored there.")
+
+    (READC)
+    (LET ((INSTREAM (GETSTREAM NIL 'INPUT))
+          (*READTABLE* (if (EQ *READTABLE* FILERDTBL)
+                           then                          (* ; 
+                                             "old style file, read code with different read table!")
+                                 CODERDTBL
+                         else                            (* ; "read code in same readtable")
+                               *READTABLE*)))
+         (PROG ((NAMETABLE (PROG1 (READ)
+                                  (READC)))
+                (CODELEN (IPLUS (LLSH (\BIN INSTREAM)
+                                      8)
+                                (\BIN INSTREAM)))
+                (NLOCALS (\BIN INSTREAM))
+                (NFREEVARS (\BIN INSTREAM))
+                (ARGTYPE (\BIN INSTREAM))
+                (NARGS (\BIN INSTREAM))
+                (NTSIZE 0)
+                (FRAMENAME FN)
+                REALSIZE STARTPC NTWORDS CA FVAROFFSET LOCALARGS STARTLOCALS LOCALSIZE)
+               [COND
+                  ((EQ (CAR NAMETABLE)
+                       'NAME)
+                   (SETQ FRAMENAME (CADR NAMETABLE))
+                   (SETQ NAMETABLE (CDDR NAMETABLE]
+               [COND
+                  ((EQ (CAR NAMETABLE)
+                       'L)
+                   (SETQ LOCALARGS (CADR NAMETABLE))
+                   (SETQ NAMETABLE (CDDR NAMETABLE]
+               [COND
+                  (NAMETABLE                                 (* ; 
+              "NAMETABLE now is a sequence of flat triples, one per name to be stored in nametable")
+                         (on NAMETABLE by CDDDR do (add NTSIZE 1))
+                         (SETQ NTSIZE (CEIL [ADD1 (UNFOLD NTSIZE (CONSTANT (WORDSPERNAMEENTRY]
+                                            WORDSPERQUAD]
+               [SETQ NTWORDS (COND
+                                (NAMETABLE (IPLUS NTSIZE NTSIZE))
+                                (T (CONSTANT WORDSPERQUAD]
+
+          (* ;; "NameTable must end in quadword which ends in 0;  thus, round down and add a quad.  NTWORDS is the number of words allocated for nametable")
+
+               (SETQ STARTPC (UNFOLD (IPLUS (fetch (CODEARRAY OVERHEADWORDS) of T)
+                                            NTWORDS)
+                                    BYTESPERWORD))           (* ; 
+                             "initial pc for the function: after fixed header and double nametable")
+               [COND
+                  (LOCALARGS (SETQ STARTLOCALS STARTPC)      (* ; 
+     "Insert an extra nametable between the real one and the start pc where we store localvar args")
+                         (SETQ LOCALSIZE (CEIL [ADD1 (UNFOLD (FOLDLO (FLENGTH LOCALARGS)
+                                                                    2)
+                                                            (CONSTANT (WORDSPERNAMEENTRY]
+                                               (IQUOTIENT WORDSPERQUAD 2)))
+                                                             (* ; 
+           "Number of words in half this nametable: must end in zero, when doubled is quad-aligned")
+                         (SETQ LOCALSIZE (UNFOLD LOCALSIZE BYTESPERWORD))
+                                                             (* ; "size in bytes now")
+                         (add STARTPC (UNFOLD LOCALSIZE 2]
+               (SETQ REALSIZE (CEIL (IPLUS STARTPC CODELEN)
+                                    BYTESPERQUAD))
+               (SETQ CA (\CODEARRAY REALSIZE (CEIL (ADD1 (FOLDHI STARTPC BYTESPERCELL))
+                                                   CELLSPERQUAD)))
+               (AIN CA STARTPC CODELEN INSTREAM)
+
+          (* ;; "Now build the name table, which has two parallel parts: the names, and where to find them on the stack")
+
+               (for X on NAMETABLE by (CDDDR X) as NT1
+                  from (IPLUS (SUB1 (BYTESPERNAMEENTRY))
+                                  (UNFOLD (fetch (CODEARRAY OVERHEADWORDS) of T)
+                                         BYTESPERWORD)) by (BYTESPERNAMEENTRY)
+                  bind (NTBYTESIZE _ (UNFOLD NTSIZE BYTESPERWORD))
+                  do (\FIXCODESYM CA NT1 (CADDR X)
+                                -1)                          (* ; 
+                                                         "Insert the name into first half of table")
+                        (SETSTKNTOFFSET CA (IPLUS NT1 NTBYTESIZE)
+                               (SELECTQ (CAR X)
+                                   (P (CONSTANT (LLSH \NT.PVARCODE 14)))
+                                   (F [OR FVAROFFSET (SETQ FVAROFFSET (UNFOLD (FOLDLO NT1
+                                                                                     (CONSTANT (
+                                                                                    BYTESPERNAMEENTRY
+                                                                                                )))
+                                                                             (CONSTANT (
+                                                                                  WORDSPERNAMEENTRY
+                                                                                        ]
+                                                             (* ; 
+                   "Save word offset of first FVAR in nametable, so ucode can easily access FVAR n")
+                                      (CONSTANT (LLSH \NT.FVARCODE 14)))
+                                   (I (CONSTANT (LLSH \NT.IVARCODE 14)))
+                                   (SHOULDNT))
+                               (CADR X))                     (* ; 
+                                                           "Code type and index into second half")
+                      )
+               [COND
+                  (LOCALARGS                                 (* ; 
+                                                           "Build invisible name table for locals")
+                         (for X on LOCALARGS by (CDDR X) as NT
+                            from (IPLUS (SUB1 (BYTESPERNAMEENTRY))
+                                            STARTLOCALS) by (CONSTANT (BYTESPERNAMEENTRY))
+                            do (\FIXCODESYM CA NT (CADR X)
+                                          -1)                (* ; "Name in first half")
+                                  (SETSTKNTOFFSET CA (IPLUS NT LOCALSIZE)
+                                         (CONSTANT (LLSH \NT.IVARCODE 14))
+                                         (CAR X))            (* ; "index in second half")]
+               (PROGN                                        (* ; "Fill in function header")
+                      (replace (CODEARRAY NA) of CA with (COND
+                                                                        ((EQ ARGTYPE 2)
+                                                                         -1)
+                                                                        (T NARGS)))
+                      (replace (CODEARRAY PV) of CA with (SUB1 (FOLDHI (IPLUS NLOCALS 
+                                                                                          NFREEVARS)
+                                                                                  CELLSPERQUAD)))
+                      (replace (CODEARRAY STARTPC) of CA with STARTPC)
+                      (replace (CODEARRAY ARGTYPE) of CA with ARGTYPE)
+                      (replace (CODEARRAY FRAMENAME) of CA with FRAMENAME)
+                      (replace (CODEARRAY NTSIZE) of CA with NTSIZE)
+                      (replace (CODEARRAY NLOCALS) of CA with NLOCALS)
+                      (replace (CODEARRAY FVAROFFSET) of CA with (OR FVAROFFSET 0))
+                      (replace (CODEARRAY FIXED) of CA with T))
+
+          (* ;; "Now read fixups: 3 lists in plist format of function fixups, symbol fixups and random pointer fixups.")
+
+               (for X on (READ) by (CDDR X) do (\FIXCODESYM CA (IPLUS (CAR X)
+                                                                                      STARTPC)
+                                                                      (CADR X)
+                                                                      -1))
+               (for X on (READ) by (CDDR X) do (\FIXCODESYM CA (IPLUS (CAR X)
+                                                                                      STARTPC)
+                                                                      (CADR X)
+                                                                      -1))
+               [for X on (READ) by (CDDR X) do (\FIXCODEPTR CA (IPLUS (CAR X)
+                                                                                      STARTPC)
+                                                                      (EVQ (CADR X]
+               (DPUTCODE FN CA (IPLUS STARTPC CODELEN])
+
+(DCODESKIP
+  [LAMBDA (FN FLG)                                           (* bvm%: " 2-Oct-86 21:39")
+
+(* ;;; "If FLG is true then copy code from input to output, else just skip code on input.  For copy case, source and destination read tables must be the same!")
+
+    (PROG ((INSTREAM (GETSTREAM NIL 'INPUT))
+           (RDTBL (if (EQ *READTABLE* FILERDTBL)
+                      then                               (* ; 
+                                             "old style file, read code with different read table!")
+                            CODERDTBL
+                    else                                 (* ; "read code in same readtable")
+                          *READTABLE*))
+           CODELEN START)
+          (READC INSTREAM)                                   (* ; "Skip EOL after code indicator")
+          [COND
+             (FLG                                            (* ; 
+                     "In both cases, scan over the code.  When FLG is true, we will copy when done")
+                  (SETQ START (GETFILEPTR INSTREAM]
+          (SKREAD INSTREAM)                                  (* ; "Skip localvar args")
+          (READC INSTREAM)
+          (SETQ CODELEN (IPLUS (LLSH (\BIN INSTREAM)
+                                     8)
+                               (\BIN INSTREAM)))
+          (\BIN INSTREAM)
+          (\BIN INSTREAM)
+          (\BIN INSTREAM)
+          (\BIN INSTREAM)
+          (SETFILEPTR INSTREAM (IPLUS (GETFILEPTR INSTREAM)
+                                      CODELEN))              (* ; "Skip the code itself")
+          (SKREAD INSTREAM NIL RDTBL)                      (* ; "Skip 3 lists of fixups")
+          (SKREAD INSTREAM NIL RDTBL)
+          (SKREAD INSTREAM NIL RDTBL)
+          (READC INSTREAM RDTBL)
+          (COND
+             (FLG                                            (* ; 
+                          "copy it all to destination.  We assume reader environments are the same")
+                  (PRIN4 FN)
+                  (PRIN3 " ")
+                  (PRIN4 CODEINDICATOR)
+                  (TERPRI)
+                  (COPYBYTES INSTREAM NIL START (GETFILEPTR])
+
+(\ALLOC.CODE.BLOCK
+  [LAMBDA (NBYTES INITONPAGE)                                (* bvm%: " 8-Jul-86 17:09")
+    (\ALLOCBLOCK (FOLDHI NBYTES BYTESPERCELL)
+           CODEBLOCK.GCT INITONPAGE CELLSPERQUAD])
+
+(\REALNAMEP
+  [LAMBDA (X)                                                (* lmm "15-OCT-81 00:16")
+    (AND (NEQ X 'ERRORSET)
+         (NEQ (NTHCHAR X 1)
+              '\])
+
+(\RENAMEDFN
+  [LAMBDA (DEF FN)                                           (* ; "Edited  3-Mar-87 22:32 by bvm:")
+
+    (* ;; "Used by PUTD when doing movds from one function to another")
+
+    (LET* [[CODEBASE (fetch (COMPILED-CLOSURE FNHEADER) of (\DTEST DEF 'COMPILED-CLOSURE]
+           (WORDSIZE (UNFOLD (\#BLOCKDATACELLS CODEBASE)
+                            WORDSPERCELL))
+           (NEWCA (\ALLOC.CODE.BLOCK (UNFOLD WORDSIZE BYTESPERWORD)
+                         (CEIL (ADD1 (FOLDHI (fetch (FNHEADER STARTPC) of CODEBASE)
+                                            BYTESPERCELL))
+                               CELLSPERQUAD]
+          (\COPYCODEBLOCK NEWCA CODEBASE WORDSIZE FN)
+          (create COMPILED-CLOSURE using DEF FNHEADER _ NEWCA])
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(RPAQ CODERDTBL (COPYREADTABLE 'ORIG))
+
+
+(SETSYNTAX 25 '[MACRO (LAMBDA (FILE RDTBL)
+                        (EVAL (READ FILE RDTBL]
+       CODERDTBL)
+
+(SETSYNTAX 124 '(MACRO ALWAYS READVBAR)
+       CODERDTBL)
+
+(READTABLEPROP CODERDTBL 'USESILPACKAGE NIL)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS CODERDTBL FILERDTBL)
+)
+
+
+
+(* ;; 
+"CODEINDICATOR is the token the compiler puts out in front of compiled definitions.  To switch to an incompatible compiled code version, choose a new value for CODEINDICATOR.  If old compiled code is still loadable in the new system, retain the CODEREADER prop for an indicators that are still loadable."
+)
+
+
+
+
+(* ;; 
+"CODEINDICATOR changed to :D6 4/6/90 by JDS for Medley 1.15, because of additional opcodes emitted by compiler."
+)
+
+
+
+
+(* ;; 
+"CODEINDICATOR changed to :D7 by JDS 3/4/91 for Medley 1.3, because of 3-byte atoms.  Old CODEREADER properties removed at the same time."
+)
+
+
+
+
+(* ;; 
+"Changed to :D8 by JDS 11/12/92 for Medley 2.1/3.0 because of 4-byte pointers/4-byte atoms.  Old CODEREADER property removed as well, since old code is not readable."
+)
+
+
+(RPAQQ CODEINDICATOR :D8)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS CODEINDICATOR)
+)
+
+(PUTPROPS :D8 CODEREADER (DCODERD . DCODESKIP))
+
+
+
+(* ; "Compiled CLOSURE type")
+
+(DEFINEQ
+
+(MAKE-COMPILED-CLOSURE
+  [LAMBDA (CODEBASE ENVIRONMENT)                             (* bvm%: " 7-Jul-86 11:32")
+    (create COMPILED-CLOSURE
+           FNHEADER _ CODEBASE
+           ENVIRONMENT _ ENVIRONMENT])
+
+(\CCLOSURE.DEFPRINT
+  [LAMBDA (CLOSURE STREAM)                                   (* bvm%: " 7-Jul-86 15:50")
+
+(* ;;; "Print closure object as, for example, #<Compiled Closure FOOBAR/76,5432>")
+
+    (LET [(NAME (fetch (COMPILED-CLOSURE FRAMENAME) of CLOSURE))
+          (TYPE (COND
+                   ((fetch (COMPILED-CLOSURE ENVIRONMENT) of CLOSURE)
+                    "Closure")
+                   (T "Function"]
+         (.SPACECHECK. STREAM (IPLUS (CONSTANT (NCHARS "<Compiled Function />"))
+                                     (PROGN                  (* ; 
+                                                           "Longest stack address is 177,177777")
+                                            10)
+                                     (COND
+                                        ((OR (LITATOM NAME)
+                                             (STRINGP NAME))
+                                         (NCHARS NAME (LITATOM NAME)))
+                                        (T (SETQ NAME)
+                                           0))
+                                     1))
+         (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))
+         (\SOUT "<Compiled " STREAM)
+         (\SOUT TYPE STREAM)
+         [COND
+            (NAME (\OUTCHAR STREAM (CHARCODE SPACE))
+                  (COND
+                     ((STRINGP NAME)
+                      (\SOUT NAME STREAM))
+                     (T (\PRINDATUM NAME STREAM]
+         (\OUTCHAR STREAM (CHARCODE /))
+         (\PRINTADDR CLOSURE STREAM)
+         (\OUTCHAR STREAM (CHARCODE >))
+         T])
+
+(\GET-COMPILED-DEFINITION
+  [LAMBDA (X)                                                (* bvm%: "11-Jul-86 16:28")
+
+(* ;;; "X is an object denoting a function somehow.  If it represents a compiled function, return a CLOSURE object for it")
+
+    (PROG NIL
+          [COND
+             ((LITATOM X)
+              (COND
+                 ((PROG1 (fetch (LITATOM CCODEP) of X)
+                      (SETQ X (fetch (LITATOM DEFPOINTER) of X)))
+                  (RETURN (MAKE-COMPILED-CLOSURE X]
+          (RETURN (AND (type? COMPILED-CLOSURE X)
+                       X])
+
+(\GET-COMPILED-CODE-BASE
+  [LAMBDA (X)                                                (* bvm%: "11-Jul-86 16:26")
+
+(* ;;; "X is an object denoting a function somehow.  If it represents a compiled function, return its code base")
+
+    (PROG NIL
+          [COND
+             ((LITATOM X)
+              (COND
+                 ((PROG1 (fetch (LITATOM CCODEP) of X)
+                      (SETQ X (fetch (LITATOM DEFPOINTER) of X)))
+                  (RETURN X]
+          (RETURN (AND (EQ (NTYPX X)
+                           \COMPILED-CLOSURE)
+                       (fetch (COMPILED-CLOSURE FNHEADER) of X])
+
+(EQDEFP
+  [LAMBDA (CA1 CA2)                                          (* bvm%: " 7-Jul-86 22:36")
+
+    (* ;; 
+  "determines whether two code arrays CA1 and CA2 are equivalent (same except for framename)")
+
+    (COND
+       ((AND (TYPEP CA1 'COMPILED-CLOSURE)
+             (TYPEP CA2 'COMPILED-CLOSURE)
+             (EQ (fetch (COMPILED-CLOSURE ENVIRONMENT) of CA1)
+                 (fetch (COMPILED-CLOSURE ENVIRONMENT) of CA2)))
+        (SETQ CA1 (fetch (COMPILED-CLOSURE FNHEADER) of CA1))
+        (SETQ CA2 (fetch (COMPILED-CLOSURE FNHEADER) of CA2))
+        (for I from 0 to (SUB1 (UNFOLD (IMIN (\#BLOCKDATACELLS CA1)
+                                                         (\#BLOCKDATACELLS CA2))
+                                                  WORDSPERCELL))
+           always (OR (EQ (\GETBASE CA1 I)
+                              (\GETBASE CA2 I))
+                          [EQ I (INDEXF (fetch (FNHEADER %#FRAMENAME]
+                          (EQ I (ADD1 (INDEXF (fetch (FNHEADER %#FRAMENAME])
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
+
+(DATATYPE COMPILED-CLOSURE (FNHEADER ENVIRONMENT))
+)
+
+(/DECLAREDATATYPE 'COMPILED-CLOSURE '(POINTER POINTER)
+       '((COMPILED-CLOSURE 0 POINTER)
+         (COMPILED-CLOSURE 2 POINTER))
+       '4)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \COMPILED-CLOSURE 13)
+
+
+(CONSTANTS \COMPILED-CLOSURE)
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \EXTENDED.EQP MACRO [OPENLAMBDA (X Y)
+                                             (COND
+                                                ((EQ (NTYPX X)
+                                                     (NTYPX Y))
+                                                 (SELECTC (NTYPX X)
+                                                     (\STACKP (EQ (fetch (STACKP EDFXP)
+                                                                     of X)
+                                                                  (fetch (STACKP EDFXP)
+                                                                     of Y)))
+                                                     (\COMPILED-CLOSURE 
+                                                          (EQDEFP X Y))
+                                                     NIL])
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+
+(/DECLAREDATATYPE 'COMPILED-CLOSURE '(POINTER POINTER)
+       '((COMPILED-CLOSURE 0 POINTER)
+         (COMPILED-CLOSURE 2 POINTER))
+       '4)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(DEFPRINT 'COMPILED-CLOSURE '\CCLOSURE.DEFPRINT)
+)
+
+
+
+(* ; "utilities")
+
+(DEFINEQ
+
+(\FINDOP
+  [LAMBDA (OPNAME FLG)                                       (* lmm "22-Mar-85 10:20")
+    (ALLOCAL (PROGN [OR \OPCODEARRAY
+                        (PROGN (SETQ \OPCODEARRAY (ARRAY 256 'POINTER NIL 0))
+                               (for X in \OPCODES
+                                  do (PUTPROP (fetch OPCODENAME of X)
+                                                'DOPCODE X)
+                                        (if (LISTP (fetch OP# of X))
+                                            then (for I
+                                                        from (CAR (fetch OP# of X))
+                                                        to (CADR (fetch OP# of X))
+                                                        by 1 do (SETA \OPCODEARRAY I X))
+                                          else (SETA \OPCODEARRAY (fetch OP# of X)
+                                                         X]
+                    (OR (COND
+                           ((LITATOM OPNAME)
+                            (GETPROP OPNAME 'DOPCODE))
+                           ((FIXP OPNAME)
+                            (ELT \OPCODEARRAY OPNAME)))
+                        (AND FLG (ERROR OPNAME FLG])
+
+(OP#
+  [NLAMBDA X                                                 (* lmm "12-FEB-82 23:50")
+    (CAR (\FINDOP (CAR X])
+)
+
+
+
+(* ;; "List of opcodes known to the system.  Used to drive the compilers and build the UFN table.")
+
+
+
+
+(* ;; "Format of an entry: (op# name #-extra-bytes ?? stack-effect ")
+
+
+(RPAQQ \OPCODES
+       ((0 -X- 0)
+        (1 CAR 0 T 0 \CAR.UFN)
+        (2 CDR 0 T 0 \CDR.UFN)
+        (3 LISTP 0 T 0 LISTP)
+        (4 NTYPX 0 T 0 NTYPX)
+        (5 TYPEP 1 TYPEP 0 \TYPEP.UFN)
+        (6 DTEST 4 ATOM 0 \DTEST.UFN)
+        (7 UNWIND 2 T (UNWIND 1)
+           \UNWIND.UFN)
+        (8 FN0 4 FN 1)
+        (9 FN1 4 FN 0)
+        (10 FN2 4 FN -1)
+        (11 FN3 4 FN -2)
+        (12 FN4 4 FN -3)
+        (13 FNX 5 FNX FNX)
+        (14 APPLYFN 0 T -1)
+        (15 CHECKAPPLY* 0 T 0 \CHECKAPPLY* (4K 12K))
+        (16 RETURN 0 T (JUMP 1)
+            \HARDRETURN)
+        (17 BIND 2)
+        (18 UNBIND 0)
+        (19 DUNBIND 0)
+        (20 RPLPTR.N 1 T -1 \RPLPTR.UFN (4K))
+        (21 GCREF 1 T 0 \HTFIND)
+        (22 ASSOC 0 T -1 ASSOC (4K DORADO))
+        (23 GVAR_ 4 ATOM 0 \SETGLOBALVAL.UFN)
+        (24 RPLACA 0 T -1 \RPLACA.UFN 4K)
+        (25 RPLACD 0 T -1 \RPLACD.UFN 4K)
+        (26 CONS 0 T -1 \CONS.UFN)
+        (27 CMLASSOC 0 T -1 LISP::%%SIMPLE-ASSOC (4K DORADO))
+        (28 FMEMB 0 T -1 FMEMB (4K DORADO))
+        (29 CMLMEMBER 0 T -1 LISP::%%SIMPLE-MEMBER (4K DORADO))
+        (30 FINDKEY 1 T 0 \FINDKEY.UFN)
+        (31 CREATECELL 0 T 0 \CREATECELL 4K)
+        (32 BIN 0 T 0 \BIN 4K)
+        (33 BOUT 0 T -1 \BOUT (4K DORADO))
+        (34 POPDISP 0 T 0 \POPDISP.UFN (4K DORADO))
+        (35 RESTLIST 1 T -1 \RESTLIST.UFN)
+        (36 MISCN 2 T 1 \MISCN.UFN (DORADO DLION DBREAK))
+        (37 unused)
+        (38 RPLCONS 0 T -1 \RPLCONS (4K DORADO))
+        (39 LISTGET 0 T -1 LISTGET (4K DORADO))
+        (40 unused)
+        (41 unused)
+        (42 unused)
+        (43 unused)
+        (44 EVAL 0 T 0 \EVAL)
+        (45 ENVCALL 0 T (JUMP 0)
+            \ENVCALL.UFN)
+        (46 TYPECHECK 0 T 0 \TYPECHECK.UFN)
+        (47 STKSCAN 0 T 0 \STKSCAN)
+        (48 BUSBLT 1 (WORDSOUT BYTESOUT BYTESOUTSWAPPED NYBBLESOUT WORDSIN BYTESIN BYTESINSWAPPED 
+                            NYBBLESINSWAPPED)
+            -3 \BUSBLT.UFN (4K DORADO))
+        (49 MISC8 1 (IBLT1 IBLT2)
+            -7 \MISC8.UFN (4K DORADO))
+        (50 UBFLOAT3 1 (POLY MATRIX.3X3 MATRIX.4X4 MATRIX.133 MATRIX.331 MATRIX.144 MATRIX.441 
+                             UBASET1)
+            (-2 1)
+            \UNBOXFLOAT3
+            (4K DORADO))
+        (51 TYPEMASK.N 1 T 0 \TYPEMASK.UFN)
+        (52 RDPROLOGPTR 0 T 0 RAID (4K DORADO))
+        (53 RDPROLOGTAG 0 T 0 RAID (4K DORADO))
+        (54 WRTPTR&TAG 0 T -2 RAID (4K DORADO))
+        (55 WRTPTR&0TAG 0 T -1 RAID (4K DORADO))
+        (56 MISC7 1 (PSEUDOCOLOR \FASTBITMAPBIT)
+            -6 \MISC7.UFN (4K DORADO))
+        (57 DOVEMISC 1 (READIW WRITEIO WRITEMP RDTIMER BYTESWAP LOCKMEM NOTIFYIOP SETWP)
+            (0 -1 0 0 0 -3 0 0))
+        (58 EQL 0 T -1 EQL)
+        (59 DRAWLINE 0 T -8 \DRAWLINE.UFN (4K DORADO))
+        (60 STORE.N 1 T 0 \STORE.N.UFN)
+        (61 COPY.N 1 T 1 \COPY.N.UFN)
+        (62 RAID 0 T 0 RAID T)
+        (63 \RETURN 0 T 0 \RETURN)
+        ((64 70)
+         IVAR 0 IVAR 1)
+        (71 IVARX 1 IVAR 1)
+        ((72 78)
+         PVAR 0 PVAR 1)
+        (79 PVARX 1 PVAR 1)
+        ((80 86)
+         FVAR 0 FVAR 1)
+        (87 FVARX 1 FVAR 1)
+        ((88 94)
+         PVAR_ 0 PVAR 0)
+        (95 PVARX_ 1 PVAR 0)
+        (96 GVAR 4 ATOM 1)
+        (97 ARG0 0 T 0 \ARG0 T)
+        (98 IVARX_ 1 IVAR 0)
+        (99 FVARX_ 1 FVAR 0)
+        (100 COPY 0 T 1)
+        (101 MYARGCOUNT 0 T 1 \MYARGCOUNT T)
+        (102 MYALINK 0 T 1)
+        (103 ACONST 4 ATOM 1)
+        (104 %'NIL 0 T 1)
+        (105 %'T 0 T 1)
+        (106 %'0 0 T 1)
+        (107 %'1 0 T 1)
+        (108 SIC 1 SIC 1)
+        (109 SNIC 1 SNIC 1)
+        (110 SICX 2 SICX 1)
+        (111 GCONST 4 GCONST 1)
+        (112 unused)
+        (113 READFLAGS 0 T 0 \READFLAGS)
+        (114 READRP 0 T 0 \READRP)
+        (115 WRITEMAP 0 T -2 \WRITEMAP DORADO)
+        (116 READPRINTERPORT 0 T 1 \READPRINTERPORT.UFN 4K)
+        (117 WRITEPRINTERPORT 0 T 0 \WRITEPRINTERPORT.UFN 4K)
+        (118 PILOTBITBLT 0 T -1 \PILOTBITBLT)
+        (119 RCLK 0 T 0 \RCLKSUBR)
+        (120 MISC1 1 (error INPUT OUTPUT error error error error error error RWMUFMAN)
+             0 \MISC1.UFN)
+        (121 MISC2 1 (?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?10)
+             -1 \MISC2.UFN)
+        (122 RECLAIMCELL 0 T 0 \GCRECLAIMCELL DORADO)
+        (123 GCSCAN1 0 T 0 \GCSCAN1)
+        (124 GCSCAN2 0 T 0 \GCSCAN2)
+        (125 SUBRCALL 2 SUBRCALL)
+        (126 CONTEXTSWITCH 0 T 0 \CONTEXTSWITCH)
+        (127 RETCALL 4 FNX (JUMP 1)
+             \RETCALL)
+        ((128 143)
+         JUMP 0 JUMP JUMP NIL)
+        ((144 159)
+         FJUMP 0 JUMP CJUMP NIL)
+        ((160 175)
+         TJUMP 0 JUMP CJUMP NIL)
+        (176 JUMPX 1 JUMPX JUMP)
+        (177 JUMPXX 2 JUMPXX JUMP)
+        (178 FJUMPX 1 JUMPX CJUMP)
+        (179 TJUMPX 1 JUMPX CJUMP)
+        (180 NFJUMPX 1 JUMPX NCJUMP)
+        (181 NTJUMPX 1 JUMPX NCJUMP)
+        (182 AREF1 0 T -1 %%AREF1 (4K DORADO))
+        (183 ASET1 0 T -2 %%ASET1 (4K DORADO))
+        ((184 190)
+         PVAR_^ 0 PVAR -1 NIL)
+        (191 POP 0 T -1)
+        (192 POP.N 1 T (POP.N 1)
+             \POP.N.UFN)
+        (193 ATOMCELL.N 1 T 0 \ATOMCELL)
+        (194 GETBASEBYTE 0 T -1 \GETBASEBYTE)
+        (195 INSTANCEP 4 ATOM 0 \INSTANCEP.UFN NIL)
+        (196 BLT 0 T -2 \BLT)
+        (197 MISC10 1 T -9 \MISC10.UFN (4K DORADO))
+        (198 P-MISC2 1 (GET-NEXT-RUN)
+             -1 \P-MISC2.UFN)
+        (199 PUTBASEBYTE 0 T -2 \PUTBASEBYTE)
+        (200 GETBASE.N 1 T 0)
+        (201 GETBASEPTR.N 1 T 0)
+        (202 GETBITS.N.FD 2 T 0)
+        (203 unused)
+        (204 CMLEQUAL 0 T -1 LISP:EQUAL (4K 12K DORADO))
+        (205 PUTBASE.N 1 T -1 \PUTBASE.UFN)
+        (206 PUTBASEPTR.N 1 T -1 \PUTBASEPTR.UFN)
+        (207 PUTBITS.N.FD 2 T -1 \PUTBITS.UFN)
+        (208 ADDBASE 0 T -1 \ADDBASE)
+        (209 VAG2 0 T -1 \VAG2)
+        (210 HILOC 0 T 0)
+        (211 LOLOC 0 T 0)
+        (212 PLUS2 0 T -1 \SLOWPLUS2 *)
+        (213 DIFFERENCE 0 T -1 \SLOWDIFFERENCE *)
+        (214 TIMES2 0 T -1 \SLOWTIMES2 *)
+        (215 QUOTIENT 0 T -1 \SLOWQUOTIENT *)
+        (216 IPLUS2 0 T -1 \SLOWIPLUS2)
+        (217 IDIFFERENCE 0 T -1 \SLOWIDIFFERENCE)
+        (218 ITIMES2 0 T -1 \SLOWITIMES2)
+        (219 IQUOTIENT 0 T -1 \SLOWIQUOTIENT)
+        (220 IREMAINDER 0 T -1 IREMAINDER)
+        (221 IPLUS.N 1 T 0 \SLOWIPLUS2 (4K 12K))
+        (222 IDIFFERENCE.N 1 T 0 \SLOWIDIFFERENCE (4K 12K))
+        (223 BASE-< 0 T -1 \BASE-<.UFN (4K 12K DORADO))
+        (224 LLSH1 0 T 0 \SLOWLLSH1)
+        (225 LLSH8 0 T 0 \SLOWLLSH8)
+        (226 LRSH1 0 T 0 \SLOWLRSH1)
+        (227 LRSH8 0 T 0 \SLOWLRSH8)
+        (228 LOGOR2 0 T -1 \SLOWLOGOR2)
+        (229 LOGAND2 0 T -1 \SLOWLOGAND2)
+        (230 LOGXOR2 0 T -1 \SLOWLOGXOR2)
+        (231 LSH 0 T -1 LSH T)
+        (232 FPLUS2 0 T -1 \SLOWFPLUS2 4K)
+        (233 FDIFFERENCE 0 T -1 \SLOWFDIFFERENCE 4K)
+        (234 FTIMES2 0 T -1 \SLOWFTIMES2 4K)
+        (235 FQUOTIENT 0 T -1 \SLOWFQUOTIENT 4K)
+        (236 UBFLOAT2 1 (UFADD UFSUB UFISUB UFMULT UFDIV UFGREAT UFMAX UFMIN UFREM UBAREF1)
+             (-1 1)
+             \UNBOXFLOAT2
+             (4K DORADO))
+        (237 UBFLOAT1 1 (BOX UNBOX UFABS UFNEGATE UFIX)
+             (0 1)
+             \UNBOXFLOAT1
+             (4K DORADO))
+        (238 AREF2 0 T -2 %%AREF2 (4K DORADO))
+        (239 ASET2 0 T -3 %%ASET2 (4K DORADO))
+        (240 EQ 0 T -1)
+        (241 IGREATERP 0 T -1 \SLOWIGREATERP)
+        (242 FGREATERP 0 T -1 \SLOWFGREATERP)
+        (243 GREATERP 0 T -1 GREATERP)
+        (244 EQUAL 0 T -1 EQUAL)
+        (245 MAKENUMBER 0 T -1 \MAKENUMBER 4K)
+        (246 BOXIPLUS 0 T -1 \BOXIPLUS 4K)
+        (247 BOXIDIFFERENCE 0 T -1 \BOXIDIFFERENCE 4K)
+        (248 FLOATBLT 1 (FLOATWRAP FLOATUNWRAP FLOAT FIX FPLUS FDIFFERENCE FDIFFERENCE FPLUSABS 
+                               ABSDIFFERENCE ABSFPLUS FTIMES)
+             -3 \FLOATBLT (4K DORADO))
+        (249 FFTSTEP 0 T -1 \FFTSTEP (4K DORADO))
+        (250 MISC3 1 (EXPONENT MAGNITUDE FLOAT COMP BLKFMAX BLKFMIN BLKFABSMAX BLKFABSMIN FLOATTOBYTE
+                            ARRAYREAD LINES-EQUAL-P)
+             -2 \MISC3.UFN (4K DORADO))
+        (251 MISC4 1 (ARRAY.TIMES ARRAY.PERM ARRAY.PLUS ARRAY.DIFFERENCE ARRAY.MAGIC 3MATCH BMBIT 
+                            ARRAYWRITE)
+             -3 \MISC4.UFN)
+        (252 UPCTRACE 0 T 0 NILL (4K 12K))
+        (253 SWAP 0 T 0)
+        (254 NOP 0 T 0)
+        (255 = 0 T -1 LISP::%%= (4K DORADO))))
+
+(ADDTOVAR \OPCODEARRAY )
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \OPCODEARRAY \OPCODES)
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DEFINEQ
+
+(WORDSPERNAMEENTRY
+  [LAMBDA NIL 2])
+)
+
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS DPUTCODE MACRO ((FN CA SIZE)
+                                  (SELECTQ (SYSTEMTYPE)
+                                      (D (DEFC FN CA))
+                                      (/PUTPROP FN 'DCODE CA))))
+
+(PUTPROPS MCODEP MACRO [(X)
+                                (OR (ARRAYP X)
+                                    (AND (LITATOM X)
+                                         (ARRAYP (SELECTQ (SYSTEMTYPE)
+                                                     (D (GETD X))
+                                                     (GETPROP X 'DCODE])
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS CODELT MACRO ((CA N)
+                                (\BYTELT CA N)))
+
+(PUTPROPS CODELT2 MACRO [OPENLAMBDA (DEF LC)
+                                       (LOGOR (LLSH (CODELT DEF LC)
+                                                    BITSPERBYTE)
+                                              (CODELT DEF (ADD1 LC])
+
+(PUTPROPS CODESETA2 MACRO [OPENLAMBDA (DEF LC VALUE)
+                                         (CODESETA DEF LC (LRSH VALUE BITSPERBYTE))
+                                         (CODESETA DEF (ADD1 LC)
+                                                (IMOD VALUE (CONSTANT (LLSH 1 BITSPERBYTE])
+
+(PUTPROPS CODESETA MACRO ((CA N NV)
+                                  (\BYTESETA CA N NV)))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS BYTESPERNAMEENTRY MACRO (NIL (UNFOLD (CONSTANT (WORDSPERNAMEENTRY))
+                                                        BYTESPERWORD)))
+
+(PUTPROPS BYTESPERNTOFFSETENTRY MACRO (NIL (UNFOLD (WORDSPERNAMEENTRY)
+                                                            BYTESPERWORD)))
+
+(PUTPROPS GETNAMEENTRY MACRO (OPENLAMBDA (DEF LC)
+                                            (LET ((NUMBER 0))
+
+                                 (* ;; "Must ALWAYS be called with DEF really being either a FNHEADER or a nametable pseudo-fnheader.  Never use addbase to offset from it.  This is because CODEBASEELT checks the BYTESWAPPED flag in the fnheader....")
+
+                                                 [FOR I FROM 0
+                                                    TO (CONSTANT (SUB1 (BYTESPERNAMEENTRY)))
+                                                    DO (SETQ NUMBER
+                                                            (LOGOR (LLSH NUMBER BITSPERBYTE)
+                                                                   (CODEBASELT DEF (IPLUS LC I]
+                                                 NUMBER)))
+
+(PUTPROPS GETNTFLAGS MACRO (OPENLAMBDA (DEF LC)
+                                          (CODEBASELT DEF LC)))
+
+(PUTPROPS GETNTOFFSET MACRO (OPENLAMBDA (DEF LC)
+                                           (NTSLOT-OFFSET (GETNTOFFSETENTRY DEF LC))))
+
+(PUTPROPS GETNTOFFSETENTRY MACRO (OPENLAMBDA (DEF LC)
+                                                (LET ((NUMBER 0))
+                                                     [for I from 0
+                                                        to (CONSTANT (SUB1 (BYTESPERNTOFFSETENTRY
+                                                                                )))
+                                                        do (SETQ NUMBER
+                                                                (LOGOR (LLSH NUMBER BITSPERBYTE)
+                                                                       (CODEBASELT DEF
+                                                                              (IPLUS LC I]
+                                                     NUMBER)))
+
+(PUTPROPS GETNTTAG MACRO (OPENLAMBDA (DEF LC)
+                                        (CODEBASELT DEF (ADD1 LC))))
+
+(PUTPROPS SETNAMEENTRY MACRO [OPENLAMBDA
+                                      (DEF LC VALUE)
+                                      (FOR I FROM (CONSTANT (SUB1 (BYTESPERNAMEENTRY)))
+                                         TO 0 BY -1
+                                         DO [CODEBASESETA DEF (IPLUS LC I)
+                                                       (LOGAND VALUE (CONSTANT (SUB1 (LLSH 1 
+                                                                                          BITSPERBYTE
+                                                                                           ]
+                                               (SETQ VALUE (LRSH VALUE BITSPERBYTE])
+
+(PUTPROPS WORDSPERNTOFFSETENTRY MACRO (NIL (WORDSPERNAMEENTRY)))
+
+(PUTPROPS NTSLOT-OFFSET MACRO ((X)
+                                       (LOGAND 255 X)))
+)
+
+(DEFMACRO NEW-SYMBOL-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM)
+
+   (* ;; "Use one form or another, depending on whether we're compiling for new 3-byte atoms or old 2-byte atom numbers.")
+
+   [COND
+      ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)       (* ; "NEW ATOMS")
+       `,NEW-SYMBOL-FORM)
+      (T `,OLD-SYMBOL-FORM])
+
+(DEFOPTIMIZER BIG-VMEM-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM &ENVIRONMENT ENV)
+
+                                (* ;; 
+                              "Allow for differences between 4-byte pointers and 3-byte pointers..")
+
+                                [COND
+                                   ((FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
+                                    `,NEW-SYMBOL-FORM)
+                                   (T `,OLD-SYMBOL-FORM])
+
+(DEFOPTIMIZER SETSTKNAMEENTRY (CODEARRAY OFFSET VAL &ENVIRONMENT ENV)
+
+                                  (* ;; "Set the name entry for a name-table entry.")
+
+                                  [COND
+                                     [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
+                                      `(LET ((BASE (fetch (ARRAYP BASE) of ,CODEARRAY))
+                                             (VALUE ,VAL))
+                                            (COND
+                                               ((FIXP VALUE) (* ; 
+                                                           "A 20-byte atom #.  Make it an atom.")
+                                                (\PUTBASEPTR BASE ,OFFSET (\VAG2 \AtomHI VALUE)))
+                                               (T            (* ; "A 3-byte atom.  Just use it.")
+                                                  (\PUTBASEPTR BASE ,OFFSET VALUE]
+                                     (T `(LET [(BASE (fetch (ARRAYP BASE) of ,CODEARRAY]
+                                              (\PUTBASE BASE ,OFFSET ,VAL])
+
+(DEFOPTIMIZER SETSTKNTOFFSETENTRY (BASE OFFSET VAL &ENVIRONMENT ENV)
+
+                                      (* ;; "Set the offset entry for a name-table entry.")
+
+                                      [COND
+                                         [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
+                                          `(\PUTBASEFIXP ,BASE ,OFFSET ,VAL]
+                                         (T `(\PUTBASE ,BASE ,OFFSET ,VAL])
+
+(DEFOPTIMIZER GETSTKNAMEENTRY (BASE OFFSET &ENVIRONMENT ENV)
+
+                                  (* ;; "Get a name entry out of a name table.  BASE is the start of the name table; OFFSET is in words, not bytes or name entries.")
+
+                                  [COND
+                                     [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
+                                      `(\GETBASEPTR ,BASE ,OFFSET]
+                                     (T `(\GETBASE ,BASE ,OFFSET])
+
+(DEFOPTIMIZER GETSTKNTOFFSETENTRY (BASE OFFSET &ENVIRONMENT ENV)
+                                      [COND
+                                         [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
+                                          `(\GETBASEFIXP ,BASE ,OFFSET]
+                                         (T `(\GETBASE ,BASE ,OFFSET])
+
+(DEFOPTIMIZER WORDSPERNAMEENTRY (&ENVIRONMENT ENV)
+
+                                    (* ;; "Number of words in a name-table %"Name%" entry--the space for the symbol.  1 for old symbol systems, 2 for 3-byte-atom systesm.")
+
+                                    [COND
+                                       ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
+                                        `(PROGN 2))
+                                       ((AND CROSSCOMPILING (FMEMB :3-BYTE-INIT (
+                                                                    COMPILER::ENV-TARGET-ARCHITECTURE
+                                                                                 ENV)))
+                                        `(PROGN 2))
+                                       (T `(PROGN 1])
+
+(DEFOPTIMIZER SETSTKNTOFFSET (BASE OFFSET TYPE VAL &ENVIRONMENT ENV)
+
+                                 (* ;; "Set the offset entry for a name-table entry, from the symbol to fill in plus the variable-type marker value SHIFTED LEFT 14 BITS ALREADY.")
+
+                                 [COND
+                                    [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
+                                     `(PROGN (\FIXCODENUM ,BASE (IDIFFERENCE ,OFFSET BYTESPERWORD)
+                                                    ,TYPE)
+                                             (\FIXCODENUM ,BASE ,OFFSET ,VAL]
+                                    (T `(\FIXCODENUM ,BASE ,OFFSET (IPLUS ,TYPE ,VAL])
+
+(DEFOPTIMIZER SETSTKNAME-RAW (BASE OFFSET VAL &ENVIRONMENT ENV)
+
+                                 (* ;; "Set the name entry for a name-table entry. This version works with raw storage, as opposed to SETSTKNAMEENTRY, which works on an ARRAYP.")
+
+                                 (* ;; "If this optimizer changes, change SETSTKNAMEENTRY as well.")
+
+                                 [COND
+                                    [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
+                                     `(LET ((VALUE ,VAL))
+                                           (COND
+                                              ((FIXP VALUE)  (* ; 
+                                                           "A 20-byte atom #.  Make it an atom.")
+                                               (\PUTBASEPTR ,BASE ,OFFSET (\VAG2 \AtomHI VALUE)))
+                                              (T             (* ; "A 3-byte atom.  Just use it.")
+                                                 (\PUTBASEPTR ,BASE ,OFFSET VALUE]
+                                    (T `(\PUTBASE ,BASE ,OFFSET ,VAL])
+
+(DEFOPTIMIZER SETSTKNTOFFSET-RAW (BASE OFFSET TYPE VAL &ENVIRONMENT ENV)
+
+                                 (* ;; "Set the offset entry for a name-table entry.  This version works on raw storage, vs SETSTKNAMEOFFSETENTRY, which is supposed to work on codearrays.  Any changes here should be made there, as well.  TYPE must already be shifted left by 14 bits.")
+
+                                     [COND
+                                        [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
+                                         `(PROGN (\PUTBASE ,BASE ,OFFSET ,TYPE)
+                                                 (\PUTBASE ,BASE (IPLUS ,OFFSET 1)
+                                                        ,VAL]
+                                        (T `(\PUTBASE ,BASE ,OFFSET (IPLUS ,TYPE ,VAL])
+
+(DEFOPTIMIZER NEW-SYMBOL-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM &ENVIRONMENT ENV)
+
+                                  (* ;; 
+                                "Allow for differences between 3-byte atoms and 2-byte atoms.")
+
+                                  [COND
+                                     ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
+                                      `,NEW-SYMBOL-FORM)
+                                     (T `,OLD-SYMBOL-FORM])
+
+(DEFOPTIMIZER MAKE-NTENTRY (TYPE OFFSET &ENVIRONMENT ENV)
+                               [COND
+                                  [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
+                                   `(IPLUS (CONSTANT (LLSH ,TYPE 16))
+                                           ,OFFSET]
+                                  (T `(IPLUS (CONSTANT ,TYPE)
+                                             ,OFFSET])
+
+(DEFOPTIMIZER NULL-NTENTRY (VALUE &ENVIRONMENT ENV)
+
+                               (* ;; "Predicate:  Is  VALUE a null entry in a name table?  I.e., does it result from fetching the entry at the end that`s all zeros?  For 2-byte atoms, that's the same as being zero.  For 3-byte atoms, it's the same as being NIL.")
+
+                               [COND
+                                  [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
+                                   `(NULL ,VALUE]
+                                  (T `(EQ ,VALUE 0])
+
+(DEFOPTIMIZER NTSLOT-VARTYPE (X &ENVIRONMENT ENV)
+
+                                 (* ;; "Given the contents of a name-table Offset entry, return the variable-type bits at the top of the entry.  THE RESULT IS RETURNED SHEFTED LEFT 14 BITS, THE USUAL REPRESENTATION.")
+
+                                 [COND
+                                    [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV))
+                                     `(LOGAND 49153 (LRSH ,X 16]
+                                    (T `(LOGAND ,X 49152])
+(DECLARE%: EVAL@COMPILE
+
+(ACCESSFNS CODEARRAY ((STKMIN (CODELT2 DATUM 0)
+                                 (CODESETA2 DATUM 0 NEWVALUE))
+                          (NA (SIGNED (CODELT2 DATUM 2)
+                                     BITSPERWORD)
+                              (CODESETA2 DATUM 2 (UNSIGNED NEWVALUE BITSPERWORD)))
+                          (PV (SIGNED (CODELT2 DATUM 4)
+                                     BITSPERWORD)
+                              (CODESETA2 DATUM 4 (UNSIGNED NEWVALUE BITSPERWORD)))
+                          (STARTPC (CODELT2 DATUM 6)
+                                 (CODESETA2 DATUM 6 NEWVALUE))
+                          [ARGTYPE (LOGAND (LRSH (CODELT DATUM 8)
+                                                 4)
+                                          3)
+                                 (CODESETA DATUM 8 (LOGOR (LOGAND (CODELT DATUM 8)
+                                                                 207)
+                                                          (LLSH (LOGAND NEWVALUE 3)
+                                                                4]
+                          (FRAMENAME (\VAG2 (LOGAND (CODELT2 DATUM 8)
+                                                   4095)
+                                            (CODELT2 DATUM 10))
+                                 (\FIXCODEPTR DATUM 11 (EVQ NEWVALUE)))
+                          (NTSIZE (CODELT2 DATUM 12)
+                                 (CODESETA2 DATUM 12 NEWVALUE))
+                          (NLOCALS (CODELT DATUM 14)
+                                 (CODESETA DATUM 14 NEWVALUE))
+                          (FVAROFFSET (CODELT DATUM 15)
+                                 (CODESETA DATUM 15 NEWVALUE)))
+                         [ACCESSFNS CODEARRAY ((LSTARP (ILESSP (fetch (CODEARRAY NA) of
+                                                                                         DATUM)
+                                                              0))
+                                               (OVERHEADWORDS (PROGN 8))
+                                               (ALIGNED (IPLUS (fetch (CODEARRAY NTSIZE)
+                                                                  of DATUM)
+                                                               (fetch (CODEARRAY OVERHEADWORDS)
+                                                                  of T)))
+                                               (FIXED NIL (replace (CODEARRAY STKMIN)
+                                                               of DATUM with (\STKMIN DATUM))
+                                                      )
+                                               (FRAMENAME# (PROGN 8])
+)
+(DECLARE%: EVAL@COMPILE
+
+(RECORD OPCODE (OP# OPCODENAME OPNARGS OPPRINT LEVADJ UFNFN UNIMPL))
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \OPCODES)
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ PVARCODE 32768)
+
+(RPAQQ FVARCODE 49152)
+
+(RPAQQ IVARCODE 0)
+
+(RPAQQ VARCODEMASK 49152)
+
+
+(CONSTANTS PVARCODE FVARCODE IVARCODE VARCODEMASK)
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \NT.IVARCODE 0)
+
+(RPAQQ \NT.PVARCODE 2)
+
+(RPAQQ \NT.FVARCODE 3)
+
+
+(CONSTANTS \NT.IVARCODE \NT.PVARCODE \NT.FVARCODE)
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+
+
+
+(* ; "ufns")
+
+(DEFINEQ
+
+(INITUFNTABLE
+  [LAMBDA NIL                                              (* ; 
+                                                      "Edited 19-Nov-92 15:28 by sybalsky:mv:envos")
+    (CREATEPAGES \UFNTable \UFNTableSize NIL T)
+    (for I from 0 to 255 do (\SETUFNENTRY I '\UNKNOWN.UFN 0 0))
+    (for X in \OPCODES when (fetch (OPCODE UFNFN) of X)
+       do (\SETUFNENTRY (PROG ((OP (fetch (OPCODE OP#) of X)))
+                                      (RETURN (if (LISTP OP)
+                                                  then (CAR OP)
+                                                else OP)))
+                     (fetch (OPCODE UFNFN) of X)
+                     [COND
+                        ((LISTP (fetch (OPCODE LEVADJ) of X))
+                         (CADR (fetch (OPCODE LEVADJ) of X)))
+                        (T (IDIFFERENCE (IPLUS 1 (COND
+                                                    ((EQ (fetch (OPCODE OPNARGS) of X)
+                                                         0)
+                                                     0)
+                                                    (T 1)))
+                                  (fetch (OPCODE LEVADJ) of X]
+                     (SELECTQ (fetch (OPCODE OPNARGS) of X)
+                         (0 0)
+                         (1 1)
+                         (2 2)
+                         (3 
+                            (* ;; "Changed by JDS from (3 1) 12/26/90 as part of 3-byte-atom change.  I dunno why this was (3 1), since there were no UFNing args with 3-byte args???")
+
+                            3)
+                         (4 4)
+                         (5 5)
+                         (SHOULDNT])
+
+(\SETUFNENTRY
+  [LAMBDA (INDEX FN NARGS NEXTRA)                            (* lmm " 7-Jun-85 14:08")
+    (SETQ INDEX (\ADDBASE (\ADDBASE \UFNTable INDEX)
+                       INDEX))
+    (change (fetch (UFNENTRY FNINDEX) of INDEX)
+           (\ATOMDEFINDEX FN))
+    (change (fetch (UFNENTRY NEXTRA) of INDEX)
+           NEXTRA)
+    (change (fetch (UFNENTRY NARGS) of INDEX)
+           NARGS])
+
+(\GETUFNENTRY
+  [LAMBDA (OP)                                               (* hdj "17-Jun-85 13:08")
+    (LET [(INDEX (\ADDBASE2 \UFNTable (if (LITATOM OP)
+                                          then (fetch (OPCODE OP#) of (\FINDOP OP))
+                                        else OP]
+         (\VAG2 0 (fetch (UFNENTRY FNINDEX) of INDEX])
+)
+(DEFINEQ
+
+(\UNKNOWN.UFN
+  [LAMBDA NIL                                              (* bvm%: "23-Mar-84 15:52")
+    (\MP.ERROR \MP.UNKNOWN.UFN "Compiler/microcode error: unknown UFN"])
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(RPAQ? COMPILER::*TARGET-ARCHITECTURE* '(:4-BYTE :3-BYTE))
+
+(RPAQ? COMPILER::*HOST-ARCHITECTURE* '(:4-BYTE :3-BYTE))
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE
+
+(BLOCKRECORD UFNENTRY (
+                           (* ;; "Describes a 32-bit entry in the %"UFN Table%", \UFNTable, which is used to find the function to call when an opcode isn't implemented in microcode.")
+
+                           (FNINDEX WORD)                    (* ; 
+                                                          " LO 16 bits of the symbol # for the UFN")
+                           (NEXTRA BYTE)                     (* ; 
+                                          "[Previously unused] HI 8 bits of the UFN symbol number.")
+                           (NARGS BYTE)                      (* ; "# of arguments to the UFN.")
+                           ))
+)
+
+
+(ADDTOVAR INEWCOMS (FNS INITUFNTABLE \SETUFNENTRY))
+EVAL@COMPILE 
+
+(ADDTOVAR DONTCOMPILEFNS INITUFNTABLE)
+)
+
+
+
+(* ; "for MAKEINIT and READSYS")
+
+(DECLARE%: DONTCOPY 
+
+(ADDTOVAR INEWCOMS
+          (FNS DCODERD)
+          [VARS \OPCODES (CODERDTBL (COPYREADTABLE 'ORIG]
+          (P (SETSYNTAX (CHARCODE ^Y)
+                    '[MACRO (LAMBDA (FILE RDTBL)
+                                   (EVALFORMAKEINIT (READ FILE RDTBL]
+                    CODERDTBL)
+             (SETSYNTAX (CHARCODE %|)
+                    '(MACRO ALWAYS READVBAR)
+                    CODERDTBL)
+             (READTABLEPROP CODERDTBL 'USESILPACKAGE NIL)))
+
+(ADDTOVAR MKI.SUBFNS (\CODEARRAY . SCRATCHARRAY)
+                         (DPUTCODE . I.PUTDEFN)
+                         (CODERDTBL . I.CODERDTBL)
+                         (SETSTKNTOFFSET . I.SETSTKNTOFFSET)
+                         (WORDSPERNAMEENTRY . I.WORDSPERNAMEENTRY))
+
+(ADDTOVAR EXPANDMACROFNS CODELT CODELT2 CODESETA CODESETA2 DPUTCODE MCODEP BYTESPERNAMEENTRY 
+                                   BYTESPERNTOFFSETENTRY WORDSPERNAMEENTRY)
+
+(ADDTOVAR RD.SUBFNS (CODELT . VGETBASEBYTE)
+                        (CODESETA . VPUTBASEBYTE))
+
+(ADDTOVAR RDCOMS (FNS \GET-COMPILED-CODE-BASE))
+)
+
+(PUTPROPS LLCODE FILETYPE LISP:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA OP#)
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA )
+)
+(PUTPROPS LLCODE COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 
+1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (7940 20905 (DCODERD 7950 . 17502) (DCODESKIP 17504 . 19716) (\ALLOC.CODE.BLOCK 19718
+ . 19930) (\REALNAMEP 19932 . 20112) (\RENAMEDFN 20114 . 20903)) (22257 26445 (MAKE-COMPILED-CLOSURE 
+22267 . 22489) (\CCLOSURE.DEFPRINT 22491 . 24116) (\GET-COMPILED-DEFINITION 24118 . 24722) (
+\GET-COMPILED-CODE-BASE 24724 . 25365) (EQDEFP 25367 . 26443)) (28009 29442 (\FINDOP 28019 . 29308) (
+OP# 29310 . 29440)) (38127 38181 (WORDSPERNAMEENTRY 38137 . 38179)) (54946 57591 (INITUFNTABLE 54956
+ . 56764) (\SETUFNENTRY 56766 . 57204) (\GETUFNENTRY 57206 . 57589)) (57592 57787 (\UNKNOWN.UFN 57602
+ . 57785)))))
+STOP
diff --git a/CLTL2/LLCODE.LCOM b/CLTL2/LLCODE.LCOM
new file mode 100644
index 00000000..857e96cf
Binary files /dev/null and b/CLTL2/LLCODE.LCOM differ
diff --git a/CLTL2/LLFLOAT b/CLTL2/LLFLOAT
new file mode 100644
index 00000000..51426abe
--- /dev/null
+++ b/CLTL2/LLFLOAT
@@ -0,0 +1,2109 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 16:17:34" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLFLOAT.;2" 101006 
+
+      previous date%: " 3-Sep-91 18:05:23" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLFLOAT.;1")
+
+
+(* ; "
+Copyright (c) 1982, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT LLFLOATCOMS)
+
+(RPAQQ LLFLOATCOMS
+       [(DECLARE%: DONTCOPY (MACROS \HAND.FLOATUNBOX)
+               (EXPORT (MACROS POLYEVAL)))
+        (COMS (FNS \PUTBASEFLOATP \GETBASEFLOATP)
+              (MACROS \PUTBASEFLOATP \GETBASEFLOATP          (* ; 
+                                                      " the following deal with raw 32 bit numbers")
+                     \.PUTBASE32 \.GETBASE32))
+        [COMS (FNS FTIMES FPLUS FQUOTIENT FDIFFERENCE FGREATERP FABS)
+                                                             (* ; "UFNs")
+              (FNS \SLOWFDIFFERENCE \SLOWFPLUS2 \SLOWFTIMES2 \SLOWFQUOTIENT \SLOWFGREATERP)
+              
+              (* ;; "Float and \float changed to coerce ratios.")
+
+              (FUNCTIONS FLOAT)
+              (FNS \FZEROP FEQP \FLOAT \FIXP.FROM.FLOATP FIXR \BOXFPLUSDIF \BOXFQUOTIENT \BOXFTIMES2
+                   \INFINITY \MAKEFLOAT MAKEFLOATNUMBER PutFloat)
+              (PROP DMACRO ZEROP)
+              (FNS SQRT)
+              (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS FLOATP)
+                                                      (CONSTANTS (MAX.DIGITS.ACCURACY 9)))
+                     (CONSTANTS (\8BITS 255)
+                            (\MAX.HI.FRAC 127)
+                            (\SIGNBIT 32768)
+                            (\EXPONENT.BIAS 127)
+                            (\HIDDENBIT 128)
+                            (\MAX.EXPONENT 255))
+                     (MACROS .FLOATUNBOX. .LLSH1. .LLSH8. .LRSH1. .LRSH8. .LRSHSTICKY. .ADDSMALL2. 
+                            .ADDSMALL3. .SUBSMALL. .POWEROF2.)
+                     (LOCALVARS . T))
+              (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (\UNDERFLOW)
+                                                    (MAX.FLOAT (\INFINITY 0))
+                                                    (MIN.FLOAT (\INFINITY 1)))
+                     (P (MOVD? 'FGREATERP 'FGTP]
+        [COMS 
+              (* ;; "unboxed ufns")
+
+              (FNS \UNBOXFLOAT1 \UNBOXFLOAT2 \UNBOXFLOAT3)
+              (FNS \MATMULT133 \MATMULT144 \MATMULT331 \MATMULT333 \MATMULT441 \MATMULT444)
+                                                             (* ; "unboxed arg handling")
+              (DECLARE%: DONTCOPY (EXPORT (MACROS \CALLER.ARGS]
+        (COMS (FNS FLOATP.TO.BCPL BCPL.TO.FLOATP)
+              (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS BCPLNUM EFPN)))
+        [COMS (VARIABLES INTPOWERS)
+              (FUNCTIONS ENUM-STRING FNUM-STRING FLTSTR FLTINTLOG DIGITSBDP INTTOEXT EXTTOINT SPLIT8
+                     TIMESPOW10 \EXTFTIMES \EXTFQUOTIENT \EXTNORMALIZE \CONVERT.FLOATING.NUMBER 
+                     \FLOATINGSCALE)
+              (FNS \INIT.POWERS.OF.TEN)
+              (DECLARE%: DONTCOPY (RESOURCES \CFNSTRING)
+                     (GLOBALVARS \POWERS.OF.TEN)
+                     (MACROS \POWER.OF.TEN))
+              (DECLARE%: DONTEVAL@LOAD DOCOPY (INITRESOURCES \CFNSTRING)
+                     (P (\INIT.POWERS.OF.TEN]
+        (PROP ARGNAMES \UNBOXFLOAT1 \UNBOXFLOAT2 \UNBOXFLOAT3)
+        (PROP FILETYPE LLFLOAT)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML)
+                                                                             (LAMA FPLUS FTIMES])
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \HAND.FLOATUNBOX MACRO [LAMBDA (X)
+
+                                 (* ;; "this doesn't call \FLOATUNBOX because it's used by the UFN case of \FLOATUNBOX.  Takes a FLOATP and returns the raw unboxed bits of the value.  Must be used with great caution as raw unboxed bits are not allowed in many places.")
+
+                                           (\VAG2 (fetch (FLOATP HIWORD) of (SETQ X
+                                                                                     (FLOAT
+                                                                                      X)))
+                                                  (fetch (FLOATP LOWORD) of X])
+)
+
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS POLYEVAL DMACRO ((X COEFFS DEGREE)         (* ; 
+                  "execute the POLYEVAL opcode on the value X, the array COEFFS with degree DEGREE")
+                                   (\FLOATBOX ((OPCODES UBFLOAT3 0)
+                                               (\FLOATUNBOX X)
+                                               (fetch (ARRAYP BASE) of COEFFS)
+                                               DEGREE))))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+(DEFINEQ
+
+(\PUTBASEFLOATP
+  [LAMBDA (BASE OFFST VAL)                                   (* Pavel " 6-Oct-86 21:52")
+
+    (* ;; "put the floatp VAL at offset OFFST from BASE.  Used by REPLACEFIELD of floatp fields")
+
+    (\FLOATBOX (\.PUTBASE32 BASE OFFST (\FLOATUNBOX VAL])
+
+(\GETBASEFLOATP
+  [LAMBDA (BASE OFFST)                                       (* Pavel " 6-Oct-86 21:52")
+
+    (* ;; "get the floatp at OFFST from BASE")
+
+    (\FLOATBOX (\.GETBASE32 BASE OFFST])
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \PUTBASEFLOATP DMACRO [(BASE OFFST VAL)    (* ; 
+             "put the floatp VAL at offset OFFST from BASE.  Used by REPLACEFIELD of floatp fields")
+                                         (\FLOATBOX (\.PUTBASE32 BASE OFFST (\FLOATUNBOX VAL])
+
+(PUTPROPS \GETBASEFLOATP DMACRO ((BASE OFFST)        (* ; 
+                                                           "get the floatp at OFFST from BASE")
+                                         (\FLOATBOX (\.GETBASE32 BASE OFFST))))
+
+(PUTPROPS \.PUTBASE32 DMACRO (= . \PUTBASEPTR))
+
+(PUTPROPS \.GETBASE32 DMACRO (APPLY* COMP.GETBASE NIL GETBASE.32))
+)
+(DEFINEQ
+
+(FTIMES
+  [LAMBDA N                                                  (* JonL "17-May-84 18:35")
+    (PROG (R (J 1))
+          [COND
+             ((EQ 0 N)
+              (RETURN 1.0))
+             ((EQ N 1)
+              (RETURN (FLOAT (ARG N 1]
+          (SETQ R (ARG N 1))
+      LP  (COND
+             ((NEQ J N)
+              (SETQ J (ADD1 J))                              (* ; 
+                             "assumes that FTIMES compiles into opcode that punts into \FTIMES.UFN")
+              (SETQ R (FTIMES R (ARG N J)))
+              (GO LP)))
+          (RETURN R])
+
+(FPLUS
+  [LAMBDA N                                                  (* JonL "17-May-84 18:35")
+    (PROG (R (J 1))
+          [COND
+             ((EQ 0 N)
+              (RETURN 0.0))
+             ((EQ N 1)
+              (RETURN (FLOAT (ARG N 1]
+          (SETQ R (ARG N 1))
+      LP  (COND
+             ((NEQ J N)
+              (SETQ J (ADD1 J))
+              (SETQ R (FPLUS R (ARG N J)))
+              (GO LP)))
+          (RETURN R])
+
+(FQUOTIENT
+  [LAMBDA (X Y)                                              (* lmm "11-FEB-82 14:02")
+    ((OPCODES FQUOTIENT)
+     X Y])
+
+(FDIFFERENCE
+  [LAMBDA (X Y)                                              (* lmm "14-MAR-84 22:20")
+    ((OPCODES FDIFFERENCE)
+     X Y])
+
+(FGREATERP
+  [LAMBDA (X Y)                                              (* lmm "17-Oct-84 15:45")
+
+    (* ;; "to compare two floats, compare signbits, and if they are equal compare the remaining 31 bits of each number as unsigned integers")
+
+    ((OPCODES FGREATERP)
+     X Y])
+
+(FABS
+  [LAMBDA (X)                                                (* Pavel " 6-Oct-86 21:53")
+    (\FLOATBOX ((OPCODES UBFLOAT1 2)
+                (\FLOATUNBOX X])
+)
+
+
+
+(* ; "UFNs")
+
+(DEFINEQ
+
+(\SLOWFDIFFERENCE
+  [LAMBDA (X Y)                                              (* lmm "17-Oct-84 15:42")
+    (\CALLME 'FDIFFERENCE)
+    (\BOXFPLUSDIF X Y T])
+
+(\SLOWFPLUS2
+  [LAMBDA (X Y)                                              (* lmm "17-Oct-84 15:42")
+                                                             (* ; "UFN for FPLUS")
+    (\CALLME 'FPLUS)
+    (\BOXFPLUSDIF X Y])
+
+(\SLOWFTIMES2
+  [LAMBDA (X Y)                                              (* lmm "17-Oct-84 15:43")
+    (\CALLME 'FTIMES)
+    (\BOXFTIMES2 X Y])
+
+(\SLOWFQUOTIENT
+  [LAMBDA (X Y)                                              (* lmm "17-Oct-84 15:43")
+    (\CALLME 'FQUOTIENT)                                     (* ; "UFN for FQUOTIENT")
+    (\BOXFQUOTIENT X Y NIL])
+
+(\SLOWFGREATERP
+  [LAMBDA (X Y)                                              (* JonL "17-May-84 18:34")
+
+    (* ;; "to compare two floats, compare signbits, and if they are equal compare the remaining 31 bits of each number as unsigned integers")
+
+    (COND
+       [(AND (FLOATP X)
+             (FLOATP Y))
+
+        (* ;; "Can speed this up by not unpacking--check signs, then compare remaining 31d bits as unsigned numbers")
+
+        (PROG ((HX (fetch (FLOATP HIWORD) of X))
+               (HY (fetch (FLOATP HIWORD) of Y))
+               SIGNX)
+              (RETURN (COND
+                         ((NEQ (SETQ SIGNX (LOGAND HX \SIGNBIT))
+                               (LOGAND HY \SIGNBIT))
+                          (EQ 0 SIGNX))
+                         [(EQ 0 SIGNX)                       (* ; "numbers are positive")
+                          (OR (IGREATERP HX HY)
+                              (AND (EQ HX HY)
+                                   (IGREATERP (fetch LOWORD of X)
+                                          (fetch LOWORD of Y]
+                         (T                                  (* ; 
+                                              "Numbers are negative, so compare in other direction")
+                            (OR (IGREATERP HY HX)
+                                (AND (EQ HX HY)
+                                     (IGREATERP (fetch LOWORD of Y)
+                                            (fetch LOWORD of X]
+       (T (PROG (HX LX SIGNX EXPX HY LY SIGNY EXPY)
+                (.FLOATUNBOX. X SIGNX EXPX HX LX)
+                (.FLOATUNBOX. Y SIGNY EXPY HY LY)
+                (RETURN (COND
+                           ((NEQ SIGNX SIGNY)
+                            (EQ 0 SIGNX))
+                           [(EQ 0 SIGNX)                     (* ; "numbers are positive")
+                            (OR (IGREATERP EXPX EXPY)
+                                (AND (EQ EXPX EXPY)
+                                     (OR (IGREATERP HX HY)
+                                         (AND (EQ HX HY)
+                                              (IGREATERP LX LY]
+                           (T                                (* ; 
+                                              "Numbers are negative, so compare in other direction")
+                              (OR (IGREATERP EXPY EXPX)
+                                  (AND (EQ EXPY EXPX)
+                                       (OR (IGREATERP HY HX)
+                                           (AND (EQ HY HX)
+                                                (IGREATERP LY LX])
+)
+
+
+
+(* ;; "Float and \float changed to coerce ratios.")
+
+
+(LISP:DEFUN FLOAT (LISP:NUMBER &OPTIONAL LISP::OTHER)
+   (\DTEST LISP:NUMBER 'FLOATP))
+(DEFINEQ
+
+(\FZEROP
+  [LAMBDA (X)                                                (* JonL "27-Sep-84 22:20")
+
+    (* ;; "Support for generic ZEROP macro")
+
+    (AND [EQ 0 (fetch LOWORD of (\DTEST X 'FLOATP]
+         (EQ 0 (fetch HIWORDNOSIGNBIT of X])
+
+(FEQP
+  [LAMBDA (X Y)                                              (* JonL "17-May-84 20:26")
+    (COND
+       [(AND (FLOATP X)
+             (FLOATP Y))
+
+        (* ;; "If they're both floatp already, can essentially compare contents, since floatps are generally normalized.")
+                                                             (* ; 
+                     "Last OR clause is to check for comparing a negative zero to a positive zero.")
+        (AND (EQ (fetch LOWORD of X)
+                 (fetch LOWORD of Y))
+             (OR (EQ (fetch HIWORD of X)
+                     (fetch HIWORD of Y))
+                 (AND (EQ 0 (fetch HIWORDNOSIGNBIT of X))
+                      (EQ 0 (fetch HIWORDNOSIGNBIT of Y]
+       (T (PROG (SIGNX EXPX HX LX SIGNY EXPY HY LY)
+                (.FLOATUNBOX. X SIGNX EXPX HX LX T)
+                (.FLOATUNBOX. Y SIGNY EXPY HY LY T)
+                (RETURN (AND (EQ HX HY)
+                             (EQ LX LY)
+                             (EQ EXPX EXPY)
+                             (OR (EQ SIGNX SIGNY)
+                                 (AND (EQ 0 EXPX)
+                                      (EQ 0 HX)
+                                      (EQ 0 LX])
+
+(\FLOAT
+  [LAMBDA (X)                                                (* ; "Edited 28-Feb-87 18:42 by jop")
+    (OR (FLOATP X)
+        (SELECTC (NTYPX X)
+            (\FIXP (LET ((HI (fetch (FIXP HINUM) of X))
+                         (LO (fetch (FIXP LONUM) of X))
+                         (SIGN 0))
+                        (COND
+                           ((IGREATERP HI MAX.POS.HINUM)
+                            (.NEGATE. HI LO)
+                            (SETQ SIGN 1)))
+                        (\MAKEFLOAT SIGN (IPLUS \EXPONENT.BIAS 31)
+                               HI LO T)))
+            (\SMALLP (LET* [(HI 0)
+                            (SIGN 0)
+                            (LO (COND
+                                   ((IGEQ X 0)
+                                    X)
+                                   (T (SETQ SIGN 1)          (* ; "X is negative--negate it")
+                                      (COND
+                                         ((EQ 0 (\LOLOC X))  (* ; "Min small integer")
+                                          (SETQ HI 1)
+                                          0)
+                                         (T (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER (\LOLOC X]
+                           (\MAKEFLOAT SIGN (IPLUS \EXPONENT.BIAS 31)
+                                  HI LO T)))
+            (COND
+               ((TYPENAMEP X 'BIGNUM)
+                (\BIGNUM.TO.FLOAT X))
+               ((TYPEP X 'RATIO)
+                (FQUOTIENT (LISP::RATIO-NUMERATOR X)
+                       (LISP::RATIO-DENOMINATOR X)))
+               (T (LISP:ERROR 'XCL:TYPE-MISMATCH :EXPECTED-TYPE '(AND NUMBER (NOT COMPLEX))
+                         :NAME X :VALUE X :MESSAGE "a non-complex number"])
+
+(\FIXP.FROM.FLOATP
+  [LAMBDA (X)                                                (* lmm "19-Sep-85 15:08")
+    (PROG (SIGN EXP HI LO)
+          (.FLOATUNBOX. X SIGN EXP HI LO (GO RETZERO))
+          (SETQ EXP (IDIFFERENCE EXP (SUB1 \EXPONENT.BIAS))) (* ; 
+                                                           "number of bits to left of binary point")
+          [COND
+             ((ILESSP EXP 0)
+              (RETURN 0))
+             ([OR (IGREATERP EXP 32)
+                  (AND (EQ EXP 32)
+                       (OR (EQ 0 SIGN)
+                           (NEQ HI \SIGNBIT)
+                           (NEQ LO 0]
+              (RETURN (LSH (LET ((VAL (PLUS (LSH HI 16)
+                                            LO)))
+                                (if (EQ SIGN 1)
+                                    then (MINUS VAL)
+                                  else VAL))
+                           (DIFFERENCE EXP 32]
+          [COND
+             ((IGEQ (SETQ EXP (IDIFFERENCE 32 EXP))
+                    16)
+              (SETQ LO (LRSH HI (IDIFFERENCE EXP 16)))
+              (SETQ HI 0))
+             (T                                              (* ; 
+                                                    "large integer, have to manipulate both halves")
+                (FRPTQ EXP (.LRSH1. HI LO]
+          (COND
+             ((EQ SIGN 1)
+              (.NEGATE. HI LO)))
+          (RETURN (\MAKENUMBER HI LO))
+      RETZERO
+          (RETURN 0])
+
+(FIXR
+  [LAMBDA (X)                                                (* lmm "22-JUL-84 20:48")
+    (OR (FIXP X)
+        (PROG (SIGN EXP HI LO ROUNDINGBITS)
+              (.FLOATUNBOX. X SIGN EXP HI LO (GO RETZERO))
+              (SETQ EXP (IDIFFERENCE EXP (SUB1 \EXPONENT.BIAS)))
+                                                             (* ; 
+                                                           "number of bits to left of binary point")
+              [COND
+                 ((ILESSP EXP 0)
+                  (RETURN 0))
+                 [(IGEQ EXP 32)                              (* ; "FIX handles this")
+                  (RETURN (FIX (FPLUS X 0.5]
+                 ([OR (IGREATERP EXP 32)
+                      (AND (EQ EXP 32)
+                           (OR (EQ 0 SIGN)
+                               (NEQ HI \SIGNBIT)
+                               (NEQ LO 0]                    (* ; 
+                                                         "Overflow: number is larger than MAX.FIXP")
+                  (RETURN (SELECTQ \OVERFLOW
+                              (T (LISPERROR "OVERFLOW" X T))
+                              (COND
+                                 ((EQ 0 SIGN)
+                                  MAX.FIXP)
+                                 (T MIN.FIXP]
+              [COND
+                 ((IGEQ EXP 24)                              (* ; 
+                          "No decimal places to worry about, so no rounding, just shift into place")
+                  (FRPTQ (IDIFFERENCE 32 EXP)
+                         (.LRSH1. HI LO)))
+                 (T 
+                    (* ;; "Shift right until binary point is in the middle of LO, as per \MAKEFLOAT;  then decide how to round, and shift right once more")
+
+                    [COND
+                       ((IGEQ (SETQ EXP (IDIFFERENCE 24 EXP))
+                              16)                            (* ; 
+                                                        "shifting all the way out of the high word")
+                        (SETQ LO (LRSH [LOGOR HI (COND
+                                                    ((EQ 0 LO)
+                                                     0)
+                                                    (T       (* ; "Sticky bits")
+                                                       (LRSH \8BITS 1]
+                                       (IDIFFERENCE EXP 16)))
+                        (SETQ HI 0))
+                       (T                                    (* ; 
+                                                     "Shift both halves, keeping sticky bits in LO")
+                          (FRPTQ EXP (.LRSHSTICKY. HI LO]
+                    (SETQ ROUNDINGBITS (LOGAND LO \8BITS))
+                    (.LRSH8. HI LO)                          (* ; "Shift the rest of the way")
+                    (COND
+                       ((OR (IGREATERP ROUNDINGBITS 128)
+                            (AND (EQ ROUNDINGBITS 128)
+                                 (ODDP LO)))                 (* ; 
+                "Round up if greater than .5, or exactly 0.5 and rounding up will make number even")
+                        (COND
+                           ((EQ LO MAX.SMALL.INTEGER)
+                            (SETQ LO 0)
+                            (add HI 1))
+                           (T (add LO 1]
+              (COND
+                 ((EQ SIGN 1)
+                  (.NEGATE. HI LO)))
+              (RETURN (\MAKENUMBER HI LO))
+          RETZERO
+              (RETURN 0])
+
+(\BOXFPLUSDIF
+  [LAMBDA (X Y SUBTRACT BOX)                                 (* JonL "17-May-84 18:56")
+                                                             (* ; "Does X-Y if SUBTRACT is true")
+    (PROG (SIGNX EXPX HX LX SIGNY EXPY HY LY EXPDIFF PLEASENORMALIZE CARRY)
+          (.FLOATUNBOX. Y SIGNY EXPY HY LY)
+          [COND
+             (SUBTRACT (SETQ SIGNY (IDIFFERENCE 1 SIGNY]
+          (.FLOATUNBOX. X SIGNX EXPX HX LX (GO RESULTISY))
+          [COND
+             ((AND (EQ 0 HY)
+                   (EQ 0 LY))
+              (GO DONE))
+             ((EQ EXPX \MAX.EXPONENT)
+
+              (* ;; "X = infinity, so result is infinity.  This is not quite right if Y is infinity of opposite sign, though")
+
+              (RETURN (\INFINITY SIGNX BOX)))
+             ((EQ EXPY \MAX.EXPONENT)
+              (RETURN (\INFINITY SIGNY BOX]
+          (SETQ EXPDIFF (IDIFFERENCE EXPX EXPY))             (* ; 
+                                  "first align the binary points by right-shifting the smaller guy")
+          [COND
+             [(IGREATERP EXPDIFF 0)
+              (COND
+                 ((IGREATERP EXPDIFF 31)                     (* ; 
+                                                           "Y would get shifted into oblivion")
+                  (GO DONE))
+                 (T (FRPTQ EXPDIFF (.LRSHSTICKY. HY LY]
+             ((NEQ EXPDIFF 0)
+              (COND
+                 ((ILESSP EXPDIFF -31)
+                  (GO RESULTISY))
+                 (T (FRPTQ (IMINUS EXPDIFF)
+                           (.LRSHSTICKY. HX LX))
+                    (SETQ EXPX EXPY]
+          [COND
+             [(EQ SIGNX SIGNY)                               (* ; "same sign, add magnitudes")
+              (SETQ CARRY (.ADDSMALL2. LX LY))
+              (COND
+                 ((EQ (.ADDSMALL3. HX HY CARRY)
+                      1)                                     (* ; 
+                        "there was a carry out of HX, so shift everyone right and stick it back in")
+                  (.LRSHSTICKY. HX LX)
+                  (add HX \SIGNBIT)
+                  (add EXPX 1]
+             (T                                              (* ; 
+                                                         "subtract magnitudes, smaller from larger")
+                (COND
+                   ((OR (ILESSP HX HY)
+                        (AND (EQ HX HY)
+                             (ILESSP LX LY)))                (* ; "Y is bigger, so swap")
+                    (swap HX HY)
+                    (swap LX LY)
+                    (SETQ SIGNX SIGNY)))
+                (SETQ PLEASENORMALIZE (NEQ (LOGAND HX \SIGNBIT)
+                                           0))               (* ; "thus if neither operand is normalized, we won't waste time normalizing and denormalizing the result")
+                (SETQ HX (IDIFFERENCE (IDIFFERENCE HX HY)
+                                (.SUBSMALL. LX LY]
+      DONE
+          (RETURN (\MAKEFLOAT SIGNX EXPX HX LX PLEASENORMALIZE BOX))
+      RESULTISY
+          (RETURN (\MAKEFLOAT SIGNY EXPY HY LY NIL BOX])
+
+(\BOXFQUOTIENT
+  [LAMBDA (X Y BOX)                                          (* lmm "18-DEC-80 13:40")
+    (PROG (SIGNX EXPX HX LX (SIGNY 0)
+                 (EXPY 0)
+                 HY LY BORROW (HZ 0)
+                 (LZ 0))
+          (.FLOATUNBOX. X SIGNX EXPX HX LX (GO DONE))
+          (.FLOATUNBOX. Y SIGNY EXPY HY LY (GO DIVZERO))
+          (COND
+             ((EQ EXPX \MAX.EXPONENT)                        (* ; "X is infinity")
+              (RETURN (\INFINITY SIGNX BOX)))
+             ((EQ EXPY \MAX.EXPONENT)                        (* ; "Y = infinity, result is zero")
+              (GO DONE)))
+
+     (* ;; "Divide X -- double length, implicitly extended with zeros -- by Y.  At each step, Y is subtracted from X if possible, putting a one bit in the quotient, and then X and the quotient are shifted left.  Result is a 32-bit quotient.")
+
+          (.LRSH1. HX LX)
+          (.LRSH1. HY LY)                                    (* ; 
+          "shift these right one so that we never have to worry about carrying out of the high bit")
+          (FRPTQ 31 (PROGN (.LLSH1. HZ LZ)                   (* ; 
+                                                      "shift quotient left one as we accumulate it")
+                           (COND
+                              ((OR (AND (EQ HX HY)
+                                        (IGEQ LX LY))
+                                   (IGREATERP HX HY))        (* ; "X GE Y, so subtract Y")
+                               (SETQ HX (IDIFFERENCE (IDIFFERENCE HX HY)
+                                               (.SUBSMALL. LX LY)))
+                               (SETQ LZ (ADD1 LZ))           (* ; 
+                           "note that this never overflows, because of the left shift we did above")
+                               ))
+
+                           (* ;; "now shift dividend left one.  After the subtraction the high-order bit must be off, so this works okay")
+
+                           (.LLSH1. HX LX)))
+          (.LLSH1. HZ LZ)                                    (* ; 
+                                   "left shift result 1 to compensate for the earlier right shifts")
+          [COND
+             ((OR (NEQ HX 0)
+                  (NEQ LX 0))                                (* ; "set sticky bit")
+              (SETQ LZ (LOGOR LZ 1]
+      DONE
+          (RETURN (\MAKEFLOAT (LOGXOR SIGNX SIGNY)
+                         (IPLUS (IDIFFERENCE EXPX EXPY)
+                                \EXPONENT.BIAS)
+                         HZ LZ T BOX))
+      DIVZERO
+          (RETURN (COND
+                     ((EQ \OVERFLOW T)
+                      (ERROR "FLOATING DIVIDE BY ZERO" Y))
+                     (T (\INFINITY SIGNX BOX])
+
+(\BOXFTIMES2
+  [LAMBDA (X Y BOX)                                          (* JonL "17-May-84 18:56")
+    (PROG (SIGNX EXPX HX LX (SIGNY 0)
+                 (EXPY 0)
+                 HY LY (HHY 0)
+                 (HHZ 0)
+                 (HZ 0)
+                 (LZ 0)
+                 SAVEHY SAVELY CARRY)
+          (.FLOATUNBOX. X SIGNX EXPX HX LX (GO DONE)
+                 T)
+          (.FLOATUNBOX. Y SIGNY EXPY HY LY (GO DONE)
+                 T)
+          [COND
+             ((EQ EXPX \MAX.EXPONENT)                        (* ; "X = infinity")
+              (RETURN (\INFINITY SIGNX BOX)))
+             ((EQ EXPY \MAX.EXPONENT)
+              (RETURN (\INFINITY SIGNY BOX]
+
+     (* ;; "Multiply the significands.  We have two 24-bit integers, so have a 48-bit, 3-word product, stored as {HHZ,HZ,LZ}.  Multiplication will be in two steps: multiply LX by {HY,LY}, storing in result, and then multiply HX by {HY,LY}, storing in the top two words.  The first multiplication can be omitted in the not uncommon case of a zero low fraction, and the second multiplication is a little bit simpler, since result fits in two words.")
+
+          (COND
+             ((EQ 0 LX)
+              (GO LP2))
+             ((EQ 0 LY)                                      (* ; 
+                                                           "swap operands to make life easier")
+              (swap HX HY)
+              (swap LX LY)
+              (GO LP2)))
+          (SETQ SAVEHY HY)                                   (* ; 
+                                                           "we'll need these for second step")
+          (SETQ SAVELY LY)
+      LP1                                                    (* ; "multiply LX times HY,LY")
+          [COND
+             ((NEQ (LOGAND LX 1)
+                   0)
+              (SETQ CARRY (.ADDSMALL2. LZ LY))
+              (SETQ CARRY (.ADDSMALL3. HZ HY CARRY))
+              (SETQ HHZ (IPLUS HHZ HHY CARRY]
+          (COND
+             ((EQ 0 (SETQ LX (LRSH LX 1)))                   (* ; "done with this step")
+              (SETQ HY SAVEHY)
+              (SETQ LY SAVELY)
+              (GO LP2)))
+          (SETQ HHY (LLSH HHY 1))                            (* ; "left shift Y by one")
+          (SETQ HY (LLSH (COND
+                            ((IGREATERP HY MAX.POS.HINUM)
+                             (add HHY 1)
+                             (LOGAND HY MAX.POS.HINUM))
+                            (T HY))
+                         1))
+          (SETQ LY (LLSH (COND
+                            ((IGREATERP LY MAX.POS.HINUM)
+                             (add HY 1)
+                             (LOGAND LY MAX.POS.HINUM))
+                            (T LY))
+                         1))
+          (GO LP1)
+      LP2 
+
+     (* ;; "multiply HX times HY,LY, adding into high two words of Z.  No overflow here, since HX has at most (and usually exactly) 8 bits")
+
+          [COND
+             ((NEQ (LOGAND HX 1)
+                   0)
+              (SETQ CARRY (.ADDSMALL2. HZ LY))
+              (SETQ HHZ (IPLUS HHZ HY CARRY]
+          (COND
+             ((NEQ (SETQ HX (LRSH HX 1))
+                   0)
+              (.LLSH1. HY LY)
+              (GO LP2)))
+      DONE
+          
+
+     (* ;; "We now have a 48-bit result in HHZ,HZ,LZ.  \MAKEFLOAT can handle it from here.  Note that the exponent we give is bumped by 1, because the 'binary point' , which was between the first and second bits, was moved one to the right by multiplying")
+
+          (RETURN (\MAKEFLOAT (LOGXOR SIGNX SIGNY)
+                         (IPLUS EXPX EXPY (IDIFFERENCE 1 \EXPONENT.BIAS))
+                         HHZ HZ T BOX])
+
+(\INFINITY
+  [LAMBDA (SIGN BOX)                                         (* lmm "17-DEC-80 20:32")
+
+    (* ;; "Returns 'infinity' of the appropriate SIGN (0 or 1), reusing floating BOX if given")
+
+    (* ;; "For now, don't return true infinity, but rather the largest representable finite number, so that miscellaneous floating-point routines don't die")
+
+    (OR (FLOATP BOX)
+        (SETQ BOX (create FLOATP)))
+    (replace (FLOATP SIGNBIT) of BOX with SIGN)
+    (replace (FLOATP EXPONENT) of BOX with (SUB1 \MAX.EXPONENT))
+    (replace (FLOATP HIFRACTION) of BOX with \MAX.HI.FRAC)
+    (replace (FLOATP LOFRACTION) of BOX with 65535)
+    BOX])
+
+(\MAKEFLOAT
+  [LAMBDA (SIGN EXP HI LO NORMALIZE BOX)                     (* JonL "17-May-84 18:56")
+
+(* ;;; "packs up the pieces of a floating point result into a single number box, n the process checking for underflow, rounding, checking overflow.  BOX is optional box to reuse.  NORMALIZE is true if we should normalize the result first (make sign bit of HI 1);  otherwise we assume result is already normalized")
+
+    (PROG (ROUNDINGBITS)
+          (OR (FLOATP BOX)
+              (SETQ BOX (create FLOATP)))
+      TOP (COND
+             ((AND (EQ 0 HI)
+                   (EQ 0 LO))
+              (replace HIWORD of BOX with (replace LOWORD of BOX with 0))
+              (RETURN BOX)))
+          [COND
+             (NORMALIZE [COND
+                           ((EQ 0 HI)
+                            (SETQ HI LO)
+                            (SETQ LO 0)
+                            (SETQ EXP (IDIFFERENCE EXP 16]
+                    (while (EQ 0 (LOGAND HI \SIGNBIT)) do (.LLSH1. HI LO)
+                                                                 (SETQ EXP (SUB1 EXP]
+          [COND
+             ((ILEQ EXP 0)                                   (* ; 
+      "underflow.  Scale by 2^Exponentbias in order to deliver a useful value to the error handler")
+              (SELECTQ \UNDERFLOW
+                  (T (RETURN (LISPERROR "FLOATING UNDERFLOW" (\MAKEFLOAT SIGN (IPLUS EXP 
+                                                                                       \EXPONENT.BIAS
+                                                                                         )
+                                                                    HI LO NIL BOX)
+                                    T)))
+                  NIL)
+
+              (* ;; "If we have to return a result, we must 'denormalize' this number.  This gives us a little more time before vanishing to zero")
+
+              (COND
+                 ((ILESSP EXP -24)                           (* ; 
+                                                           "too small even as denormalized number")
+                  (SETQ HI (SETQ LO 0))
+                  (GO TOP))
+                 (T 
+                    (* ;; "denormalize by shifting right until the exponent is logically 1;  final result will have exponent zero, hidden bit zero")
+
+                    (FRPTQ (IDIFFERENCE 1 EXP)
+                           (.LRSHSTICKY. HI LO))
+                    (SETQ EXP 0]
+          (SETQ ROUNDINGBITS (LOGAND LO \8BITS))             (* ; 
+                                            "round result.  low order 8 bits are used for rounding")
+          (.LRSH8. HI LO)
+          [COND
+             ([OR (IGREATERP ROUNDINGBITS 128)
+                  (AND (EQ ROUNDINGBITS 128)
+                       (NOT (EQ 0 (LOGAND LO 1]
+
+              (* ;; "round up if the left over fraction was greater than 1/2;  if it was equal to a half, round to the even result")
+
+              (COND
+                 [(EQ LO MAX.SMALL.INTEGER)                  (* ; "can't add 1 directly")
+                  (SETQ LO 0)
+                  (SETQ HI (ADD1 HI))
+                  (COND
+                     ((IGREATERP HI (LOGOR \HIDDENBIT \MAX.HI.FRAC))
+                                                             (* ; "'1.11111--' became '10.000--'")
+                      (SETQ HI (LRSH HI 1))
+                      (add EXP 1]
+                 (T (SETQ LO (ADD1 LO]
+          [COND
+             ((AND (EQ HI 0)
+                   (EQ LO 0))
+
+              (* ;; "result is zero.  This could have snuck in if we denormalized a number that didn't have enough digits to survive")
+
+              (GO TOP))
+             ((IGEQ EXP \MAX.EXPONENT)
+
+              (* ;; "overflow.  If trap enabled, wrap the exponent around to middle of range (divide by 2^exponentbias) to provide a number of possible use to error handler")
+
+              (SELECTQ \OVERFLOW
+                  (T (RETURN (LISPERROR "FLOATING OVERFLOW" (\MAKEFLOAT SIGN (IDIFFERENCE EXP 
+                                                                                       \EXPONENT.BIAS
+                                                                                        )
+                                                                   HI LO NIL BOX)
+                                    T)))
+                  NIL)
+              (RETURN (\INFINITY SIGN BOX]
+          (replace SIGNBIT of BOX with SIGN)
+          (replace EXPONENT of BOX with EXP)
+          (replace HIFRACTION of BOX with HI)
+          (replace LOFRACTION of BOX with LO)
+          (RETURN BOX])
+
+(MAKEFLOATNUMBER
+  [LAMBDA (N0 N1)                                            (* lmm "12-Apr-85 18:19")
+                                                             (* ; "CALLED FROM FETCHFIELD")
+    (LET [(VAL (NCREATE 'FLOATP]
+         (replace (FLOATP HIWORD) of VAL with N0)
+         (replace (FLOATP LOWORD) of VAL with N1)
+         VAL])
+
+(PutFloat
+  [LAMBDA (PTR N)                                            (* lmm "29-Dec-84 11:32")
+                                                             (* ; "used by REPLACEFIELD")
+    (\PUTBASEFLOATP PTR 0 N)
+    N])
+)
+
+(PUTPROPS ZEROP DMACRO [OPENLAMBDA (X)
+                                      (COND
+                                         ((EQ X 0))
+                                         ((FLOATP X)
+                                          (\FZEROP X])
+(DEFINEQ
+
+(SQRT
+  [LAMBDA (N)                                                (* lmm "24-Jan-85 19:13")
+    (PROG ((X (FLOAT N))
+           V)
+          (DECLARE (TYPE FLOATP X V))
+          (if (FLESSP X 0.0)
+              then (ERROR "SQRT OF NEGATIVE VALUE" N)
+            elseif (NOT (FGREATERP X 0.0))
+              then                                       (* ; "Trichotomy ==> X = 0.0")
+                    (RETURN 0.0))
+          (SETQ V (create FLOATP
+                         EXPONENT _ (LOGAND (IPLUS \EXPONENT.BIAS
+                                                   (LRSH (LOGAND (IDIFFERENCE (fetch (FLOATP
+                                                                                          EXP)
+                                                                                 of X)
+                                                                        \EXPONENT.BIAS)
+                                                                (MASK.1'S 0 BITSPERWORD))
+                                                         1))
+                                           \MAX.EXPONENT)
+                         HIFRACTION _ (fetch (FLOATP HIFRAC) of X)))
+
+     (* ;; "Exponent is stored as excess \EXPONENT.BIAS and although the LRSH doesn't really do division by 2 (e.g., when the arg is negative) at least the low-order 8 bits will be right.  It doesn't even matter that it may be off-by-one, due to the infamous 'Arithmetic Shifting Considered Harmful' since it is only an estimate.")
+
+          [FRPTQ 4 (SETQ V (FTIMES 0.5 (FPLUS V (FQUOTIENT X V]
+          (RETURN V])
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
+
+(BLOCKRECORD FLOATP ((SIGNBIT BITS 1)
+                         (EXPONENT BITS 8)
+                         (HIFRACTION BITS 7)
+                         (LOFRACTION BITS 16))
+                        (BLOCKRECORD FLOATP ((HIWORD WORD)
+                                             (LOWORD WORD)))
+                        (BLOCKRECORD FLOATP ((NIL BITS 9)
+                                             (LONGFRACTION BITS 23)))
+                        (BLOCKRECORD FLOATP ((FLOATCONTENTS BITS 32)))
+                        (BLOCKRECORD FLOATP ((NIL BITS 1)
+                                             (HIWORDNOSIGNBIT BITS 15)))
+                        (CREATE (\FLOATBOX (\VAG2 (LOGOR (LLSH SIGNBIT (PLUS 7 8))
+                                                             (LLSH EXPONENT 7)
+                                                             HIFRACTION)
+                                                      LOFRACTION)))
+                        LOFRACTION _ 0 HIFRACTION _ 0 EXPONENT _ 0 SIGNBIT _ 0
+                        [ACCESSFNS FLOATP ((EXP (LOGAND (LRSH (\HILOC (\FLOATUNBOX DATUM))
+                                                              7)
+                                                       255))
+                                           (HIFRAC (LOGAND (\HILOC (\FLOATUNBOX DATUM))
+                                                          127])
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ MAX.DIGITS.ACCURACY 9)
+
+
+(CONSTANTS (MAX.DIGITS.ACCURACY 9))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \8BITS 255)
+
+(RPAQQ \MAX.HI.FRAC 127)
+
+(RPAQQ \SIGNBIT 32768)
+
+(RPAQQ \EXPONENT.BIAS 127)
+
+(RPAQQ \HIDDENBIT 128)
+
+(RPAQQ \MAX.EXPONENT 255)
+
+
+(CONSTANTS (\8BITS 255)
+       (\MAX.HI.FRAC 127)
+       (\SIGNBIT 32768)
+       (\EXPONENT.BIAS 127)
+       (\HIDDENBIT 128)
+       (\MAX.EXPONENT 255))
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS .FLOATUNBOX. MACRO
+          [(FLONUM SIGN EXP HI LO ZEROFORM DONTSHIFT RESTARTIFINTEGER)
+
+           (* ;; "Unpacks a floating point number FLONUM into its components.  ZEROFORM is evaluated if the number is true zero.  The fraction is unpacked into HI and LO, with the binary point implicitly between bits 0 and 1 of HI.  If DONTSHIFT is true, the fraction is left in its original state, with 8 bits in HI and 16 in LO.  If FLONUM is not floating, it is coerced.")
+
+           (PROG NIL
+             RETRY
+                 [COND
+                    ((NOT (FLOATP FLONUM))                   (* ; 
+                                                           "Float and normalize the non-floatp")
+                     (COND
+                        ('RESTARTIFINTEGER (SETQ FLONUM (LISPERROR "NON-NUMERIC ARG" FLONUM T))
+                               (GO RESTARTIFINTEGER))
+                        (T (SELECTC (NTYPX FLONUM)
+                               (\FIXP (SETQ HI (fetch (FIXP HINUM) of FLONUM))
+                                      (SETQ LO (fetch (FIXP LONUM) of FLONUM))
+                                      (SETQ SIGN (COND
+                                                    ((IGREATERP HI MAX.POS.HINUM)
+                                                     (.NEGATE. HI LO)
+                                                     1)
+                                                    (T 0))))
+                               (\SMALLP (SETQ HI 0)
+                                        [SETQ LO (COND
+                                                    ((SMALLPOSP FLONUM)
+                                                     (SETQ SIGN 0)
+                                                     FLONUM)
+                                                    (T (SETQ SIGN 1)
+                                                             (* ; "FLONUM is negative--negate it")
+                                                       (COND
+                                                          ((EQ 0 (LOLOC FLONUM))
+                                                             (* ; "Min small integer")
+                                                           (SETQ HI 1)
+                                                           0)
+                                                          (T (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER
+                                                                          (LOLOC FLONUM])
+                               (PROGN (SETQ FLONUM (FLOAT FLONUM))
+                                      (GO RETRY)))
+                           [COND
+                              [(EQ 0 HI)
+                               (COND
+                                  ((EQ 0 LO)
+                                   (SETQ EXP 0)
+                                   (PROGN ZEROFORM (RETURN)))
+                                  (T (SETQ HI LO)
+                                     (SETQ LO 0)
+                                     (SETQ EXP (IPLUS \EXPONENT.BIAS 15]
+                              ((IGREATERP HI 255)            (* ; "Not exact, punt")
+                               (SETQ FLONUM (FLOAT FLONUM))
+                               (GO UNPACK))
+                              (T (SETQ EXP (IPLUS \EXPONENT.BIAS 31]
+                           [COND
+                              ((ILEQ HI 255)                 (* ; "Do a big shift first.")
+                               (.LLSH8. HI LO)
+                               (SETQ EXP (IDIFFERENCE EXP 8]
+                           (while (EQ 0 (LOGAND HI \SIGNBIT)) do (.LLSH1. HI LO)
+                                                                        (SETQ EXP (SUB1 EXP)))
+                           (COND
+                              (DONTSHIFT (.LRSH8. HI LO)))
+                           (RETURN]
+             UNPACK
+                 (SETQ SIGN (fetch (FLOATP SIGNBIT) of FLONUM))
+                 (SETQ LO (fetch (FLOATP LOFRACTION) of FLONUM))
+                 (SETQ HI (fetch (FLOATP HIFRACTION) of FLONUM))
+                 [COND
+                    [(EQ 0 (SETQ EXP (fetch (FLOATP EXPONENT) of FLONUM)))
+                                                             (* ; 
+                                                    "zero or a de-normalized number from underflow")
+                     (COND
+                        ((AND (EQ 0 HI)
+                              (EQ 0 LO))                     (* ; 
+                                                          "A zero, regardless of the sign bit zero")
+                         ZEROFORM)
+                        (T                                   (* ; 
+                                               "need bias adjust to account for lack of hidden bit")
+                           (SETQ EXP 1]
+                    ((NEQ EXP \MAX.EXPONENT)                 (* ; 
+                                        "might want to check for NaN's here if EXP = \MAX.EXPONENT")
+                                                             (* ; 
+                                                          "OR in the implicit high bit of fraction")
+                     (SETQ HI (IPLUS HI \HIDDENBIT]
+                 (COND
+                    ((NOT DONTSHIFT)
+                     (.LLSH8. HI LO])
+
+(PUTPROPS .LLSH1. MACRO ((HI LO)                     (* ; 
+                                                    "shift the pair left one, assuming no overflow")
+                                 (SETQ HI (LLSH HI 1))
+                                 (SETQ LO (LLSH (COND
+                                                   ((IGREATERP LO MAX.POS.HINUM)
+                                                    (add HI 1)
+                                                    (LOGAND LO MAX.POS.HINUM))
+                                                   (T LO))
+                                                1))))
+
+(PUTPROPS .LLSH8. MACRO ((HI LO)                     (* ; 
+                                                          "shift pair left 8, assuming no overflow")
+                                 (SETQ HI (IPLUS (LLSH HI 8)
+                                                 (LRSH LO 8)))
+                                 (SETQ LO (LLSH (LOGAND LO \8BITS)
+                                                8))))
+
+(PUTPROPS .LRSH1. MACRO ((HI LO)
+                                 (SETQ LO (LRSH LO 1))
+                                 [COND
+                                    ((NEQ (LOGAND HI 1)
+                                          0)
+                                     (SETQ LO (IPLUS LO \SIGNBIT]
+                                 (SETQ HI (LRSH HI 1))))
+
+(PUTPROPS .LRSH8. MACRO ((HI LO)
+                                 (SETQ LO (IPLUS (LRSH LO 8)
+                                                 (LLSH (LOGAND HI \8BITS)
+                                                       8)))
+                                 (SETQ HI (LRSH HI 8))))
+
+(PUTPROPS .LRSHSTICKY. MACRO ((HI LO)                (* ; 
+           "shifts pair right one, but low-order bit is sticky -- if it ever becomes 1, it stays 1")
+                                      (SETQ LO (LOGOR (LRSH LO 1)
+                                                      (LOGAND LO 1)))
+                                      [COND
+                                         ((NEQ (LOGAND HI 1)
+                                               0)
+                                          (SETQ LO (IPLUS LO \SIGNBIT]
+                                      (SETQ HI (LRSH HI 1))))
+
+(PUTPROPS .ADDSMALL2. MACRO [(X Y)
+                                     (PROGN                  (* ; 
+                                                           "does X _ X+Y, returning the carry bit")
+                                            (COND
+                                               ((IGREATERP X (IDIFFERENCE MAX.SMALL.INTEGER Y))
+                                                [SETQ X (IDIFFERENCE X (IDIFFERENCE MAX.SMALL.INTEGER
+                                                                              (SUB1 Y]
+                                                1)
+                                               (T (SETQ X (IPLUS X Y))
+                                                  0])
+
+(PUTPROPS .ADDSMALL3. MACRO [(X Y CARRY)
+                                     (PROGN                  (* ; 
+                                                       "X _ X+Y+CARRY, returning the new carry bit")
+                                            (COND
+                                               ((IGREATERP X (IDIFFERENCE (IDIFFERENCE 
+                                                                                 MAX.SMALL.INTEGER Y)
+                                                                    CARRY))
+                                                (SETQ X
+                                                 (IDIFFERENCE
+                                                  X
+                                                  (IDIFFERENCE [IDIFFERENCE
+                                                                MAX.SMALL.INTEGER
+                                                                (SUB1 (COND
+                                                                         ((EQ Y 0)
+                                                                          (PROG1 CARRY (SETQ CARRY 0)
+                                                                                 ))
+                                                                         (T Y]
+                                                         CARRY)))
+                                                1)
+                                               (T (SETQ X (IPLUS X Y CARRY))
+                                                  0])
+
+(PUTPROPS .SUBSMALL. MACRO ((X Y)                    (* ; 
+                                     "Subtract Y from X, returning the borrow out of the next word")
+                                    (COND
+                                       ((ILEQ Y X)
+                                        (SETQ X (IDIFFERENCE X Y))
+                                        0)
+                                       (T [SETQ X (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER
+                                                               (IDIFFERENCE Y X]
+                                          1))))
+
+(PUTPROPS .POWEROF2. MACRO [OPENLAMBDA (X)
+                                          (COND
+                                             ((ILESSP X 16)
+                                              (LSH 1 X))
+                                             (T (LSH (LSH 1 (IDIFFERENCE X 16))
+                                                     16])
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(RPAQQ \UNDERFLOW NIL)
+
+(RPAQ MAX.FLOAT (\INFINITY 0))
+
+(RPAQ MIN.FLOAT (\INFINITY 1))
+
+
+(MOVD? 'FGREATERP 'FGTP)
+)
+
+
+
+(* ;; "unboxed ufns")
+
+(DEFINEQ
+
+(\UNBOXFLOAT1
+  [LAMBDA (OP)                                               (* lmm " 5-Mar-86 11:35")
+
+    (* ;; "UFN for the unboxed floating 1-arg cases")
+
+    (\SLOWRETURN)
+    (SELECTQ OP
+        (0                                                   (* ; "BOX")
+           (\CALLER.ARGS (X)
+                  (LET [(VAL (NCREATE 'FLOATP]
+                       (replace (FLOATP HIWORD) of VAL with (\HILOC X))
+                       (replace (FLOATP LOWORD) of VAL with (\LOLOC X))
+                       VAL)))
+        (1                                                   (* ; "UNBOX")
+           (\CALLER.ARGS (X)
+                  (\HAND.FLOATUNBOX X)))
+        (2                                                   (* ; "UFABS")
+           (\CALLER.ARGS ((X FLOATP))
+                  (\FLOATUNBOX (ABS X))))
+        (3                                                   (* ; "UFNEGATE")
+           (\CALLER.ARGS ((X FLOATP))
+                  (\FLOATUNBOX (FMINUS X))))
+        (4                                                   (* ; "UFIX")
+           (\CALLER.ARGS ((X FLOATP))
+                  (FIX X)))
+        (HELP "\UNBOXFLOAT1 called with illegal op " OP])
+
+(\UNBOXFLOAT2
+  [LAMBDA (OP)                                               (* lmm " 7-Mar-85 16:48")
+
+    (* ;; "UFN for the 2-arg floating cases")
+
+    (\CALLER.ARGS ((X FLOATP)
+                   (Y FLOATP))
+           (SELECTQ OP
+               (0                                            (* ; "UFADD")
+                  (\HAND.FLOATUNBOX (FPLUS X Y)))
+               (1                                            (* ; "UFSUB")
+                  (\HAND.FLOATUNBOX (FDIFFERENCE X Y)))
+               (2                                            (* ; "UFISUB")
+                  (\HAND.FLOATUNBOX (FDIFFERENCE Y X)))
+               (3                                            (* ; "UFMULT")
+                  (\HAND.FLOATUNBOX (FTIMES X Y)))
+               (4                                            (* ; "UFDIV")
+                  (\HAND.FLOATUNBOX (FQUOTIENT X Y)))
+               (5                                            (* ; "UFGREAT")
+                  (FGREATERP X Y))
+               (6                                            (* ; "UFMAX")
+                  (\HAND.FLOATUNBOX (FMAX X Y)))
+               (7                                            (* ; "UFMIN")
+                  (\HAND.FLOATUNBOX (FMIN X Y)))
+               (8                                            (* ; "UFREM")
+                  (\HAND.FLOATUNBOX (FREMAINDER X Y)))
+               (HELP "\UNBOXFLOAT2 called with illegal op " OP])
+
+(\UNBOXFLOAT3
+  [LAMBDA (OP)                                               (* jop%: "29-Aug-86 14:30")
+    (if (EQ 0 OP)
+        then [\CALLER.ARGS ((X FLOATP)
+                                COEFFICIENTS DEGREE)         (* ; "Polynomial evaluation")
+                        (bind (RESULT _ (\GETBASEFLOATP COEFFICIENTS 0))
+                           declare (TYPE FLOATP RESULT) for I from 2
+                           to (LLSH DEGREE 1) by 2 do (SETQ RESULT
+                                                                   (FPLUS (FTIMES RESULT X)
+                                                                          (\GETBASEFLOATP 
+                                                                                 COEFFICIENTS I)))
+                           finally (RETURN (\FLOATUNBOX RESULT]
+      else (\CALLER.ARGS (MATRIX1 MATRIX2 RESULT)
+                      (SELECTQ OP
+                          (1                                 (* ; "3 x 3 matrix multiply")
+                             (\MATMULT333 MATRIX1 MATRIX2 RESULT))
+                          (2                                 (* ; "4 x 4 matrix multiply")
+                             (\MATMULT444 MATRIX1 MATRIX2 RESULT))
+                          (3                                 (* ; "(1,3) * (3,3) => (1,3)")
+                             (\MATMULT133 MATRIX1 MATRIX2 RESULT))
+                          (4                                 (* ; "(3,3) * (3,1) => (3,1)")
+                             (\MATMULT331 MATRIX1 MATRIX2 RESULT))
+                          (5                                 (* ; "(1,4) * (4,4) => (1,4)")
+                             (\MATMULT144 MATRIX1 MATRIX2 RESULT))
+                          (6                                 (* ; "(4,4) * (4,1) => (4,1)")
+                             (\MATMULT441 MATRIX1 MATRIX2 RESULT))
+                          (HELP "\UNBOXFLOAT3 called with illegal op " OP])
+)
+(DEFINEQ
+
+(\MATMULT133
+  [LAMBDA (ABASE BBASE CBASE)                                (* jop%: "29-Aug-86 12:20")
+
+(* ;;; "Multiply a 3 vector times a 3 by 3 array")
+
+    (for K from 0 to 4 by 2
+       do (bind (PRODUCT _ 0.0) declare (TYPE FLOATP PRODUCT) for I from 0
+                 to 4 by 2 as J from K by 6
+                 do [SETQ PRODUCT (FPLUS PRODUCT (FTIMES (\GETBASEFLOATP ABASE I)
+                                                                (\GETBASEFLOATP BBASE J]
+                 finally (\PUTBASEFLOATP CBASE K PRODUCT)))
+    CBASE])
+
+(\MATMULT144
+  [LAMBDA (ABASE BBASE CBASE)                                (* jop%: "29-Aug-86 12:20")
+
+(* ;;; "Multiply a 4 vector times a 4 by 4 array")
+
+    (for K from 0 to 6 by 2
+       do (bind (PRODUCT _ 0.0) declare (TYPE FLOATP PRODUCT) for I from 0
+                 to 6 by 2 as J from K by 8
+                 do [SETQ PRODUCT (FPLUS PRODUCT (FTIMES (\GETBASEFLOATP ABASE I)
+                                                                (\GETBASEFLOATP BBASE J]
+                 finally (\PUTBASEFLOATP CBASE K PRODUCT)))
+    CBASE])
+
+(\MATMULT331
+  [LAMBDA (ABASE BBASE CBASE)                                (* jop%: "29-Aug-86 12:20")
+
+(* ;;; "Multiply a 3 by 3 array by a 3 vector")
+
+    (for K from 0 to 4 by 2
+       do (bind (PRODUCT _ 0.0) declare (TYPE FLOATP PRODUCT) for I
+                 from (ITIMES K 3) by 2 as J from 0 to 4 by 2
+                 do [SETQ PRODUCT (FPLUS PRODUCT (FTIMES (\GETBASEFLOATP ABASE I)
+                                                                (\GETBASEFLOATP BBASE J]
+                 finally (\PUTBASEFLOATP CBASE K PRODUCT)))
+    CBASE])
+
+(\MATMULT333
+  [LAMBDA (ABASE BBASE CBASE)                                (* jop%: "29-Aug-86 12:31")
+
+(* ;;; "Multiply two 3 by 3 arrays")
+
+    [bind (K _ 0) for ASTART from 0 to 12 by 6
+       do (for BSTART from 0 to 4 by 2
+                 do (bind (PRODUCT _ 0.0) declare (TYPE FLOATP PRODUCT) for I
+                           from ASTART to (IPLUS ASTART 4) by 2 as J from BSTART
+                           by 6 do [SETQ PRODUCT (FPLUS PRODUCT (FTIMES (
+                                                                                     \GETBASEFLOATP
+                                                                                         ABASE I)
+                                                                                   (\GETBASEFLOATP
+                                                                                    BBASE J]
+                           finally (\PUTBASEFLOATP CBASE K PRODUCT))
+                       (SETQ K (IPLUS K 2]
+    CBASE])
+
+(\MATMULT441
+  [LAMBDA (ABASE BBASE CBASE)                                (* jop%: "29-Aug-86 12:20")
+
+(* ;;; "Multiply a 4 by 4 array by a 4 vector")
+
+    (for K from 0 to 6 by 2
+       do (bind (PRODUCT _ 0.0) declare (TYPE FLOATP PRODUCT) for I
+                 from (ITIMES K 4) by 2 as J from 0 to 6 by 2
+                 do [SETQ PRODUCT (FPLUS PRODUCT (FTIMES (\GETBASEFLOATP ABASE I)
+                                                                (\GETBASEFLOATP BBASE J]
+                 finally (\PUTBASEFLOATP CBASE K PRODUCT)))
+    CBASE])
+
+(\MATMULT444
+  [LAMBDA (ABASE BBASE CBASE)                                (* jop%: "29-Aug-86 12:31")
+
+(* ;;; "Multiply two 4 by 4 arrays")
+
+    [bind (K _ 0) for ASTART from 0 to 24 by 8
+       do (for BSTART from 0 to 6 by 2
+                 do (bind (PRODUCT _ 0.0) declare (TYPE FLOATP PRODUCT) for I
+                           from ASTART to (IPLUS ASTART 6) by 2 as J from BSTART
+                           by 8 do [SETQ PRODUCT (FPLUS PRODUCT (FTIMES (
+                                                                                     \GETBASEFLOATP
+                                                                                         ABASE I)
+                                                                                   (\GETBASEFLOATP
+                                                                                    BBASE J]
+                           finally (\PUTBASEFLOATP CBASE K PRODUCT))
+                       (SETQ K (IPLUS K 2]
+    CBASE])
+)
+
+
+
+(* ; "unboxed arg handling")
+
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \CALLER.ARGS MACRO
+          [X
+           (LET
+            ((ARGS (CAR X))
+             (FORMS (CDR X)))
+            `(PROGN
+              (\SLOWRETURN)
+              (LET [(AL (\MYALINK))
+                    NEXT
+                    ,@(for VAR in ARGS collect (COND
+                                                              ((LISTP VAR)
+                                                               (LIST (CAR VAR)
+                                                                     0))
+                                                              (T VAR]
+                   [DECLARE ,@(for VAR in ARGS when (LISTP VAR)
+                                     collect `(TYPE ,(SELECTQ (CADR VAR)
+                                                             ((FLOATING FLOATP) 
+                                                                  (CADR VAR))
+                                                             (HELP))
+                                                        ,(CAR VAR]
+                   (SETQ NEXT (fetch (FX NEXTBLOCK) of AL))
+                   ,@[for X in (REVERSE ARGS)
+                        collect (LET [(FORMS `(\.GETBASE32 \STACKSPACE (SETQ NEXT
+                                                                            (IDIFFERENCE NEXT 
+                                                                                   WORDSPERCELL]
+                                         (COND
+                                            [(LISTP X)
+                                             `(SETQ ,(CAR X)
+                                               (\FLOATBOX ,FORMS]
+                                            (T `(SETQ ,X ,FORMS]
+                   (\MAKEFREEBLOCK NEXT (TIMES ,(LENGTH ARGS)
+                                               WORDSPERCELL))
+                   (replace (FX NEXTBLOCK) of AL with NEXT)
+                   (PROGN ,@FORMS])
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+(DEFINEQ
+
+(FLOATP.TO.BCPL
+  [LAMBDA (FLONUM)                                           (* bvm%: "22-OCT-81 22:31")
+
+(* ;;; 
+"Converts a floating point number in IEEE format to an integer in BCPL floating-point format")
+
+    (OR (FLOATP FLONUM)
+        (SETQ FLONUM (FLOAT FLONUM)))
+    (PROG (RESULT FRAC (EXP (IPLUS (fetch EXPONENT of FLONUM)
+                                   2)))
+          (COND
+             ((FEQP FLONUM 0.0)
+              (RETURN 0)))
+          [COND
+             ((IGREATERP EXP 255)                            (* ; 
+                                                           "Overflow, so just return BCPL infinity")
+              (SETQ EXP 255)
+              (SETQ FRAC 4194303))
+             (T (SETQ FRAC (LRSH (fetch LONGFRACTION of FLONUM)
+                                 1]
+          (SETQ RESULT (create BCPLNUM
+                              BCPLEXPONENT _ EXP
+                              SIGNIFICANTBIT _ 1
+                              BCPLHIFRACTION _ (LRSH FRAC 16)
+                              BCPLLOFRACTION _ (LOGAND FRAC MAX.SMALL.INTEGER)))
+          (RETURN (COND
+                     ((EQ (fetch SIGNBIT of FLONUM)
+                          1)
+                      (IMINUS RESULT))
+                     (T RESULT])
+
+(BCPL.TO.FLOATP
+  [LAMBDA (BCPLNUM)                                          (* bvm%: "22-OCT-81 22:34")
+
+    (* ;; 
+  "Converts BCPLNUM, an integer in BCPL floating-point format, to a FLOATP, which is IEEE standard")
+
+    (PROG (SIGN EXP FRAC)
+          (COND
+             ((ILESSP BCPLNUM 0)
+              (SETQ BCPLNUM (IMINUS BCPLNUM))                (* ; 
+                                          "In a negative BCPL format, whole number is complemented")
+              (SETQ SIGN 1))
+             ((IEQP BCPLNUM 0)                               (* ; "Canonical form for 0.0")
+              (RETURN (FPLUS 0.0)))
+             (T (SETQ SIGN 0)))
+          (COND
+             ((OR (SMALLP BCPLNUM)
+                  (NEQ (fetch SIGNIFICANTBIT of BCPLNUM)
+                       1))
+              (ERROR "Not a valid BCPL flonum" BCPLNUM)))
+          [COND
+             ((ILESSP (SETQ EXP (IDIFFERENCE (fetch BCPLEXPONENT of BCPLNUM)
+                                       2))
+                     0)
+
+              (* ;; "Underflow.  IEEE exponent is off by 2 because the bias is one smaller in IEEE format and we shift the mantissa left one")
+
+              (RETURN (FPLUS 0.0]
+          (SETQ FRAC (LLSH (fetch RESTOFFRACTION of BCPLNUM)
+                           1))
+          (RETURN (create FLOATP
+                         SIGNBIT _ SIGN
+                         EXPONENT _ EXP
+                         HIFRACTION _ (LRSH FRAC 16)
+                         LOFRACTION _ (LOGAND FRAC MAX.SMALL.INTEGER])
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: EVAL@COMPILE
+
+(BLOCKRECORD BCPLNUM ((BCPLSIGNBIT BITS 1)
+                          (BCPLEXPONENT BITS 8)              (* ; "exponent, biased by 128")
+                          (SIGNIFICANTBIT BITS 1)            (* ; 
+                                                 "Always 1 in a bcpl num;  binary point is to left")
+                          (RESTOFFRACTION BITS 22))
+                         (BLOCKRECORD BCPLNUM ((NIL BITS 10)
+                                               (BCPLHIFRACTION BITS 6)
+                                               (BCPLLOFRACTION BITS 16)))
+                         (CREATE (CREATECELL \FIXP)))
+
+(RECORD EFPN (EXP HI LO))
+)
+)
+
+(LISP:DEFVAR INTPOWERS
+   (LET ((AR (LISP:MAKE-ARRAY 10)))
+
+        (* ;; "(MAKE-ARRAY 10 INITIAL-CONTENTS (QUOTE (1 10 100 1000 10000 100000 1000000 10000000 100000000 1000000000)))")
+
+        (* ;; "This HORRIBLE hack is here because not enough of MAKE-ARRAY is in the loadup to let the above form work right.  (The ASETs are written open to avoid the gensyms produced by the stupid SETF expansion.)  TBF by BOB BANE")
+
+        (ASET 1 AR 0)
+        (ASET 10 AR 1)
+        (ASET 100 AR 2)
+        (ASET 1000 AR 3)
+        (ASET 10000 AR 4)
+        (ASET 100000 AR 5)
+        (ASET 1000000 AR 6)
+        (ASET 10000000 AR 7)
+        (ASET 100000000 AR 8)
+        (ASET 1000000000 AR 9)
+        AR))
+
+(LISP:DEFUN ENUM-STRING (OUTSTR MANTSTR INTEXP DECPLACES EXPWIDTH)
+
+   (* ;; "Prints exponential notation observing rounding & exponent spacing")
+
+   (LISP:MACROLET [(STRPUT (C)
+                          `(LISP:VECTOR-PUSH-EXTEND ,C OUTSTR]
+          [LET ((DIGITS (LISP:LENGTH MANTSTR))
+                (POINTPLACE 1)
+                (INDEX -1)
+                EXPOFFSET)
+               (LISP:SETF (LISP:FILL-POINTER OUTSTR)
+                      0)
+               (IF DECPLACES
+                   THEN (SETQ POINTPLACE (- DIGITS DECPLACES)))
+               (SETQ EXPOFFSET (- DIGITS POINTPLACE))
+
+               (* ;; "Print the mantissa")
+
+               [IF (MINUSP POINTPLACE)                   (* ; ".0 before mantissa needed")
+                   THEN (STRPUT #\.)
+                         (LISP:DOTIMES (I (- POINTPLACE))
+                             (STRPUT #\0))
+                         (LISP:DOTIMES (I DIGITS)
+                             (STRPUT (LISP:CHAR MANTSTR I)))
+                 ELSE (LISP:DOTIMES (I POINTPLACE)
+                              (STRPUT (LISP:CHAR MANTSTR (LISP:INCF INDEX))))
+                       (STRPUT #\.)
+                       (LISP:DOTIMES (I EXPOFFSET)
+                           (STRPUT (LISP:CHAR MANTSTR (LISP:INCF INDEX))))
+                       (IF DECPLACES
+                           THEN (LISP:DOTIMES (I (- DECPLACES EXPOFFSET))
+                                        (STRPUT #\0))
+                         ELSE (IF (EQ 0 EXPOFFSET)
+                                      THEN (STRPUT #\0)  (* ; 
+                                               "Must print at least one decimal place in this case")
+                                         ]
+
+               (* ;; "mantissa done - now for the exponent")
+
+               (LISP:INCF INTEXP EXPOFFSET)
+               (SETQ MANTSTR (WITH-RESOURCES (\NUMSTR \NUMSTR1)
+                                    (\CONVERTNUMBER (ABS INTEXP)
+                                           10 T NIL \NUMSTR \NUMSTR1)))
+               (SETQ DIGITS (LISP:LENGTH MANTSTR))
+               (STRPUT #\E)
+               (IF (MINUSP INTEXP)
+                   THEN (STRPUT #\-)
+                 ELSE (STRPUT #\+))
+               (IF EXPWIDTH
+                   THEN (LISP:DOTIMES (I (- EXPWIDTH DIGITS 2))
+                                (STRPUT #\0)))
+               (LISP:DOTIMES (I DIGITS)
+                   (STRPUT (LISP:CHAR MANTSTR I)))]
+          OUTSTR))
+
+(LISP:DEFUN FNUM-STRING (OUTSTR MANTSTR INTEXP DECPLACES)
+
+   (* ;; "Prints floating decimal output observing # of places required")
+
+   (LISP:MACROLET [(STRPUT (C)
+                          `(LISP:VECTOR-PUSH ,C OUTSTR]
+          [LET* ((DIGITS (LISP:LENGTH MANTSTR))
+                 (POINTPLACE (+ DIGITS INTEXP))
+                 (INDEX -1)
+                 PLACESOUT)
+                (LISP:SETF (LISP:FILL-POINTER OUTSTR)
+                       0)
+                (COND
+                   ((NOT (LISP:PLUSP POINTPLACE))
+                    (STRPUT #\0)
+                    (STRPUT #\.)
+                    (LISP:DOTIMES (I (- POINTPLACE))
+                        (STRPUT #\0))
+                    (LISP:DOTIMES (I DIGITS)
+                        (STRPUT (LISP:CHAR MANTSTR I)))
+                    (SETQ PLACESOUT (- DIGITS POINTPLACE)))
+                   ((MINUSP INTEXP)
+                    (LISP:DOTIMES (I POINTPLACE)
+                        (STRPUT (LISP:CHAR MANTSTR (LISP:INCF INDEX))))
+                    (STRPUT #\.)
+                    (LISP:DOTIMES (I (- INTEXP))
+                        (STRPUT (LISP:CHAR MANTSTR (LISP:INCF INDEX))))
+                    (SETQ PLACESOUT (- INTEXP)))
+                   (T (LISP:DOTIMES (I DIGITS)
+                          (STRPUT (LISP:CHAR MANTSTR I)))
+                      (LISP:DOTIMES (I INTEXP)
+                          (STRPUT #\0))
+                      (STRPUT #\.)
+                      (STRPUT #\0)
+                      (SETQ PLACESOUT 1)))
+                (IF DECPLACES
+                    THEN (LISP:DOTIMES (I (- DECPLACES PLACESOUT))
+                                 (STRPUT #\0))]
+          OUTSTR))
+
+(LISP:DEFUN FLTSTR (F K)
+
+(* ;;; "Returns a string MANT and a fixp EXP such that F = MANT * 10 ** EXP, to K digits. Algorithm copped from %"An Implementation guide to a Proposed Standard for Floating-Point Arithmetic%" by J T Coonen (IEEE Computer Jan. 1980), and modified somewhat. The hack here when printing to unspecified precision is to always generate 7 digits, check to see if that's enough, and then clip trailing zeros from whatever results. This  tends to produce more digits than necessary for denormalized numbers, but it makes everything else print a LOT faster.")
+
+   [IF (= F 0.0)
+       THEN 
+
+             (* ;; "Foo!  You have to do it this way because the people who call FLTSTR assume they can smash whatever it returns... It would also be nice if it were documented somewhere that WITH-RESOURCES expands into a PROG1 and therefore can't return multiple-values...")
+
+             (LET (outstring)
+                  (WITH-RESOURCES (\NUMSTR \NUMSTR1)
+                         (RPLCHARCODE \NUMSTR 1 (CHARCODE 0))
+                         (SETQ outstring (SUBSTRING \NUMSTR 1 1 \NUMSTR1)))
+                  (LISP:VALUES outstring 0))
+     ELSE (PROG (SIGNF FEXP FHI FLO TEXP THI TLO MANT EXP ROUNDINGBITS
+                           (LOCALK (LISP:IF K
+                                       (MIN 9 K)
+                                       7))
+                           FLOG10 MANTSTRING)
+                    (DECLARE (LISP:SPECIAL TEXP THI TLO))(* ; 
+                                               "used by extended  floating multiplier and inttoext")
+                    (.FLOATUNBOX. F SIGNF FEXP FHI FLO)
+
+               (* ;; "Re-normalize ")
+
+                    (if (EQ 0 FHI)
+                        then (SETQ FHI FLO)
+                              (SETQ FLO 0)
+                              (LISP:DECF FEXP 16))
+                    (while (EQ 0 (LOGAND FHI \SIGNBIT)) do (.LLSH1. FHI FLO)
+                                                                  (LISP:DECF FEXP))
+
+               (* ;; "find # of digits before decimal point by looking up base 10 log in extpowers")
+
+                    (SETQ FLOG10 (FLTINTLOG FEXP FHI FLO))
+                MOREDIGITS
+                    (SETQ EXP (- FLOG10 LOCALK))
+                AGAIN
+                    (TIMESPOW10 (- EXP)
+                           FEXP FHI FLO)                     (* ; "results in texp thi tlo")
+                    (SETQ MANT (EXTTOINT TEXP THI TLO))
+
+               (* ;; "Now compare the result to 10**k to check if the exp guess was a good one")
+
+               (* ;; "This code is in the original algorithm, but I'm not sure it's needed here. What the heck, it's pretty fast...")
+
+               (* ;; "(cond ((>= mant (cl:1+ (cl:aref intpowers localk))) (cl:incf exp) (go again)) ((eql mant (cl:aref intpowers localk)) (cl:incf exp) (setq mant (cl:aref intpowers (cl:1- localk)))) ((<= mant (cl:1- (cl:aref intpowers (cl:1- localk)))) (cl:decf exp) (go again)))")
+
+               (* ;; "If K came in NIL, check to see if enough digits have been generated")
+
+                    [if (NOT K)
+                        then (INTTOEXT MANT)         (* ; " values in texp thi tlo")
+                              (TIMESPOW10 EXP TEXP THI TLO)
+                              (while (NOT (> TEXP 0)) do (.LRSH1. THI TLO)
+                                                                (LISP:INCF TEXP))
+                              (SETQ ROUNDINGBITS (LOGAND TLO 255))
+                              (SETQ TLO (LOGAND TLO 65280)) 
+
+                              (* ;; "Round the  32-bit result to 24 bits to try and match F")
+
+                              (if [OR (IGREATERP ROUNDINGBITS 128)
+                                          (AND (EQ ROUNDINGBITS 128)
+                                               (NOT (EQ 0 (LOGAND TLO 256]
+                                  then (if (EQ TLO 65280)
+                                               then (SETQ TLO 0)
+                                                     (if (EQ THI MAX.SMALL.INTEGER)
+                                                         then (SETQ THI \SIGNBIT)
+                                                               (LISP:INCF TEXP)
+                                                       else (LISP:INCF THI))
+                                             else (LISP:INCF TLO 256)))
+                              (if (OR (NOT (EQ FEXP TEXP))
+                                          (NOT (EQ FHI THI))
+                                          (NOT (EQ FLO TLO)))
+                                  then (LISP:INCF LOCALK)
+                                        (if (< LOCALK 10)
+                                            then (GO MOREDIGITS]
+
+               (* ;; "Done! Convert integer mantissa to a string")
+
+                    (WITH-RESOURCES (\NUMSTR \NUMSTR1)
+                           (\CONVERTNUMBER MANT 10 T NIL \NUMSTR \NUMSTR1)
+                           (SETQ MANTSTRING \NUMSTR1))
+
+               (* ;; "If K came in NIL, clip trailing %"0%"s from mantissa string; if it came in bigger than 8, pad the string with 0s.")
+
+                    (if (NOT K)
+                        then (LET [(ENDPOINTER (LISP:1- (NCHARS MANTSTRING]
+                                      (while (EQ #\0 (LISP:CHAR MANTSTRING ENDPOINTER))
+                                         do (GLC MANTSTRING)
+                                               (LISP:INCF EXP)
+                                               (LISP:DECF ENDPOINTER)))
+                      else (freplace (ARRAY-HEADER FILL-POINTER-P) of MANTSTRING
+                                  with T)
+                            (freplace (ARRAY-HEADER TOTAL-SIZE) of MANTSTRING with 128) 
+                                                             (* ; "So VECTOR-PUSH will work...")
+                            (while (IGREATERP K LOCALK) do (LISP:VECTOR-PUSH #\0 MANTSTRING)
+                                                                  (LISP:DECF EXP)
+                                                                  (LISP:INCF LOCALK)))
+                    (RETURN (LISP:VALUES MANTSTRING EXP])
+
+(LISP:DEFUN FLTINTLOG (FEXP FHI FLO)
+   (DECLARE (GLOBALVARS EXTPOWERS))
+   [LET ((RESULT (if (NOT (> FEXP 0))
+                     then (LET (TEXP THI TLO)
+                                   (DECLARE (LISP:SPECIAL TEXP THI TLO))
+                                   (TIMESPOW10 37 FEXP FHI FLO)
+                                   (LISP:SETQ FEXP TEXP FHI THI FLO TLO)
+                                   -74)
+                   else -37)))
+        (FOR I FROM 76 TO 0 BIND TABENTRY
+           DO (SETQ TABENTRY (LISP:AREF EXTPOWERS I))
+                 (IF [OR (> FEXP (FETCH (EFPN EXP) OF TABENTRY))
+                             (AND (EQ FEXP (FETCH (EFPN EXP) OF TABENTRY))
+                                  (OR (> FHI (FETCH (EFPN HI) OF TABENTRY))
+                                      (AND (EQ FHI (FETCH (EFPN HI) OF TABENTRY))
+                                           (>= FLO (FETCH (EFPN LO) OF TABENTRY]
+                     THEN (RETURN (IPLUS RESULT I])
+
+(LISP:DEFUN DIGITSBDP (F)
+   (LET (SIGNF FEXP FHI FLO)
+
+(* ;;; "Returns the number of decimal places before the decimal point F has.")
+
+        (.FLOATUNBOX. F SIGNF FEXP FHI FLO)
+
+        (* ;; "Re-normalize ")
+
+        (if (EQ 0 FHI)
+            then (SETQ FHI FLO)
+                  (SETQ FLO 0)
+                  (LISP:DECF FEXP 16))
+        (while (EQ 0 (LOGAND FHI \SIGNBIT)) do (.LLSH1. FHI FLO)
+                                                      (LISP:DECF FEXP))
+        (FLTINTLOG FEXP FHI FLO)))
+
+(LISP:DEFUN INTTOEXT (N)
+
+(* ;;; "Takes an integer N and returns a fixp exponent and a two-fixp mantissa (by setting non-locals (texp, thi, tlo)) . Ignores sign of N, range limitations of normal exponent (everything comes back %"normalized%").")
+
+   (LET ((EXP (IPLUS \EXPONENT.BIAS 31))
+         HI LO)
+        (if (EQ N 0)
+            then (SETQ TEXP 0)
+                  (SETQ THI 0)
+                  (SETQ TLO 0)
+          else (.UNBOX. N HI LO)
+                [if (EQ 0 HI)
+                    then (SETQ HI LO)
+                          (SETQ LO 0)
+                          (SETQ EXP (IDIFFERENCE EXP 16))
+                          (while (EQ 0 (LOGAND HI \SIGNBIT)) do (SETQ HI (LLSH1 HI 1))
+                                                                       (SETQ EXP (SUB1 EXP)))
+                  else (while (EQ 0 (LOGAND HI \SIGNBIT)) do (.LLSH1. HI LO)
+                                                                        (SETQ EXP (SUB1 EXP]
+                (SETQ TEXP EXP)
+                (SETQ THI HI)
+                (SETQ TLO LO))))
+
+(LISP:DEFUN EXTTOINT (EXP HI LO)
+
+(* ;;; "Takes a fixp exponent and a two-fixp mantissa and returns an integer which is the properly rounded integer. Ignores sign and out-of-range numbers.")
+
+   (SETQ EXP (IDIFFERENCE EXP \EXPONENT.BIAS))
+   [if (NOT (EQ EXP 31))
+       then (LET (ROUNDFLAG)
+                     [if (< EXP 15)
+                         then (SETQ LO HI)
+                               (SETQ HI 0)
+                               (LISP:INCF EXP 16)
+                               (SETQ LO (LRSH LO (- 30 EXP)))
+                       else (while (NOT (EQ EXP 30)) do (.LRSH1. HI LO)
+                                                                   (SETQ EXP (ADD1 EXP]
+                     (SETQ ROUNDFLAG (EQ 1 (LOGAND LO 1)))
+                     (.LRSH1. HI LO)
+                     (if ROUNDFLAG
+                         then (if (EQ LO 65535)
+                                      then (SETQ LO 0)
+                                            (LISP:INCF HI)
+                                    else (LISP:INCF LO]
+   (\MAKENUMBER HI LO))
+
+(DEFMACRO SPLIT8 (IN HI LO)
+   `(LISP:SETQ ,HI (LRSH ,IN 8)
+           ,LO
+           (LLSH (LOGAND ,IN 255)
+                 8)))
+
+(LISP:DEFUN TIMESPOW10 (POWER EXP HI LO)
+   (DECLARE (GLOBALVARS EXTPOWERS))
+   [LET (TABENTRY CURPOWER)
+        (LISP:SETQ TEXP EXP THI HI TLO LO)
+        (WHILE (NOT (EQ 0 POWER)) DO [COND
+                                                ((> POWER 38)
+                                                 (SETQ CURPOWER 76))
+                                                ((< POWER -38)
+                                                 (SETQ CURPOWER 0))
+                                                (T (SETQ CURPOWER (+ POWER 38]
+                                            (SETQ TABENTRY (LISP:AREF EXTPOWERS (IABS CURPOWER))) 
+
+                                            (* ;; 
+                                 "Results of this land in texp thi tlo (bound above, somewhere...)")
+
+                                            (\EXTFTIMES EXP HI LO (fetch (EFPN EXP)
+                                                                             TABENTRY)
+                                                   (fetch (EFPN HI)
+                                                          TABENTRY)
+                                                   (fetch (EFPN LO)
+                                                          TABENTRY))
+                                            (SETQ EXP TEXP)
+                                            (SETQ HI THI)
+                                            (SETQ LO TLO)
+                                            (LISP:DECF POWER (- CURPOWER 38])
+
+(LISP:DEFUN \EXTFTIMES (EXPX HX LX EXPY HY LY)
+   (PROG ((SIGNX 0)
+          (SIGNY 0)
+          (HHZ 0)
+          (HZ 0)
+          (LZ 0)
+          CARRY LOW8BITS FOO FOOHI FOOLO)
+         (if (AND (EQ 0 EXPX)
+                      (EQ 0 HX)
+                      (EQ 0 LX))
+             then (GO DONE))
+         (if (AND (EQ 0 EXPY)
+                      (EQ 0 HY)
+                      (EQ 0 LY))
+             then (GO DONE))
+         (COND)
+
+(* ;;; "Multiplying two 32-bit operands to get a 32-bit rounded product. Doing the multiplication 8 bits at a time and maintaining a 40-bit or so sum in (HHZ HZ LZ) that holds the lower order products as we go.")
+
+         (COND
+            ((OR (EQ 0 HY)
+                 (EQ 0 LY))                                  (* ; 
+                                                           "swap operands to make life easier")
+             (swap HX HY)
+             (swap LX LY)))
+         (LISP:DOTIMES (I 4)
+             (SETQ LOW8BITS (LOGAND LX 255))
+
+             (* ;; "Skip it if 8 bits are 0")
+
+             (if (NOT (EQ 0 LOW8BITS))
+                 then (SETQ FOO (ITIMES LOW8BITS (LOGAND LY 255)))
+                       (SETQ CARRY (.ADDSMALL2. LZ FOO))
+                       (SETQ FOO (ITIMES LOW8BITS (LOGAND HY 255)))
+                       (SETQ CARRY (.ADDSMALL3. HZ FOO CARRY))
+                       (SETQ HHZ (IPLUS HHZ CARRY))
+                       (SETQ FOO (ITIMES LOW8BITS (LRSH LY 8)))
+                       (SPLIT8 FOO FOOHI FOOLO)
+                       (SETQ CARRY (.ADDSMALL2. LZ FOOLO))
+                       (SETQ FOOHI (IPLUS FOOHI CARRY))
+                       (SETQ CARRY (.ADDSMALL2. HZ FOOHI))
+                       (SETQ FOO (ITIMES LOW8BITS (LRSH HY 8)))
+                       (SPLIT8 FOO FOOHI FOOLO)
+                       (SETQ CARRY (IPLUS CARRY (.ADDSMALL2. HZ FOOLO)))
+                       (SETQ HHZ (IPLUS HHZ FOOHI CARRY)))
+             (.LRSH8. HX LX)                                 (* ; "Shift over 8 bits")
+
+             (* ;; "Don't shift sum the last time")
+
+             (if (NOT (EQ I 3))
+                 then (.LRSH8. HZ LZ)
+                       (SETQ HZ (LOGOR HZ (LLSH HHZ 8)))
+                       (SETQ HHZ (LRSH HHZ 8))))
+
+    (* ;; "OK, shift (HHZ HZ LZ) over 8 so \EXTNORMALIZE can understand them")
+
+         (.LLSH8. HHZ HZ)
+         (SETQ HZ (LOGOR HZ (LRSH LZ 8)))
+         (SETQ LZ (LLSH (LOGAND LZ 255)
+                        8))
+
+    (* ;; "We now have a 40-bit result in HHZ,HZ,LZ.  \EXTNORMALIZE can handle it from here.  Note that the exponent we give is bumped by 1, because the 'binary point' , which was between the first and second bits, was moved one to the right by multiplying")
+
+     DONE
+         (RETURN (\EXTNORMALIZE (IPLUS EXPX EXPY (IDIFFERENCE 1 \EXPONENT.BIAS))
+                        HHZ HZ LZ))))
+
+(LISP:DEFUN \EXTFQUOTIENT (EXPX HX LX EXPY HY LY)
+   (PROG ((SIGNX 0)
+          (SIGNY 0)
+          BORROW
+          (HZ 0)
+          (LZ 0))
+         (if (AND (EQ EXPX 0)
+                      (EQ HX 0)
+                      (EQ LX 0))
+             then (GO DONE))
+         (if (AND (EQ EXPY 0)
+                      (EQ HY 0)
+                      (EQ LY 0))
+             then (GO DIVZERO))
+         (COND
+            ((EQ EXPX \MAX.EXPONENT)                         (* ; "X is infinity, result is too.")
+             (RETURN (LISP:VALUES \MAX.EXPONENT 65535 65535)))
+            ((EQ EXPY \MAX.EXPONENT)                         (* ; "Y = infinity, result is zero")
+             (GO DONE)))
+
+(* ;;; "Divide X -- double length, implicitly extended with zeros -- by Y.  At each step, Y is subtracted from X if possible, putting a one bit in the quotient, and then X and the quotient are shifted left.  Result is a 32-bit quotient.")
+
+         (.LRSH1. HX LX)
+         (.LRSH1. HY LY)                                     (* ; 
+          "shift these right one so that we never have to worry about carrying out of the high bit")
+         (FRPTQ 31 (PROGN (.LLSH1. HZ LZ)                    (* ; 
+                                                      "shift quotient left one as we accumulate it")
+                          (COND
+                             ((OR (AND (EQ HX HY)
+                                       (IGEQ LX LY))
+                                  (IGREATERP HX HY))         (* ; "X GE Y, so subtract Y")
+                              (SETQ HX (IDIFFERENCE (IDIFFERENCE HX HY)
+                                              (.SUBSMALL. LX LY)))
+                              (SETQ LZ (ADD1 LZ))            (* ; 
+                           "note that this never overflows, because of the left shift we did above")
+                              ))
+
+                          (* ;; "now shift dividend left one.  After the subtraction the high-order bit must be off, so this works okay")
+
+                          (.LLSH1. HX LX)))
+         (.LLSH1. HZ LZ)                                     (* ; 
+                                   "left shift result 1 to compensate for the earlier right shifts")
+         [COND
+            ((OR (NEQ HX 0)
+                 (NEQ LX 0))                                 (* ; "set sticky bit")
+             (SETQ LZ (LOGOR LZ 1]
+     DONE
+         (RETURN (\EXTNORMALIZE (IPLUS (IDIFFERENCE EXPX EXPY)
+                                           \EXPONENT.BIAS)
+                        HZ LZ))
+     DIVZERO
+         (SETQ TEXP \MAX.EXPONENT)
+         (SETQ THI 65535)
+         (SETQ TLO 65535)))
+
+(LISP:DEFUN \EXTNORMALIZE (EXP HI LO &OPTIONAL (ROUNDINGBITS 0))
+
+   (* ;; "Takes four fixps, one exponent and three mantissa, and returns a normalized, rounded exponent and two fixp mantissa. Does nothing about exponent range or %"denormalization%"; just shifts mantissa, bumps exponent, and rounds")
+
+   (PROG NIL
+         (COND
+            ((AND (EQ 0 HI)
+                  (EQ 0 LO))
+             (SETQ EXP 0)
+             (GO DONE)))
+         [COND
+            ((EQ 0 HI)
+             (SETQ HI LO)
+             (SETQ LO ROUNDINGBITS)
+             (SETQ ROUNDINGBITS 0)
+             (SETQ EXP (IDIFFERENCE EXP 16]
+         (while (EQ 0 (LOGAND HI \SIGNBIT))
+            do (.LLSH1. HI LO)
+                  (if (NOT (EQ 0 (LOGAND ROUNDINGBITS \SIGNBIT)))
+                      then (SETQ LO (ADD1 LO)))
+                  (SETQ ROUNDINGBITS (LLSH ROUNDINGBITS 1))
+                  (SETQ EXP (SUB1 EXP)))                     (* ; "round result.")
+         [COND
+            ([OR (IGREATERP ROUNDINGBITS \SIGNBIT)
+                 (AND (EQ ROUNDINGBITS \SIGNBIT)
+                      (NOT (EQ 0 (LOGAND LO 1]
+
+             (* ;; "round up if the left over fraction was greater than 1/2;  if it was equal to a half, round to the even result")
+
+             (COND
+                [(EQ LO MAX.SMALL.INTEGER)                   (* ; "can't add 1 directly")
+                 (SETQ LO 0)
+                 (COND
+                    ((EQ HI MAX.SMALL.INTEGER)
+                     (SETQ HI \SIGNBIT)
+                     (add EXP 1]
+                (T (SETQ LO (ADD1 LO]
+     DONE
+         
+
+    (* ;; "Stuff results in texp thi tlo (bound somewhere above... hopefully...)")
+
+         (SETQ TEXP EXP)
+         (SETQ THI HI)
+         (SETQ TLO LO)))
+
+(LISP:DEFUN \CONVERT.FLOATING.NUMBER (F OUTSTR OUTSTRPTR FORMAT)
+   (DECLARE (GLOBALVARS \FLOATFORMAT))
+   [WITH-RESOURCE
+    (\CFNSTRING)
+    (LISP:MACROLET
+     [(STRPUT (C)
+             `(LISP:SETF (LISP:CHAR OUTSTR (LISP:INCF OSINDEX))
+                     ,C]
+     (OR FORMAT (SETQ FORMAT \FLOATFORMAT))
+     (IF (NOT (LISP:CONSP FORMAT))
+         THEN (SETQ FORMAT NIL))
+     (LET
+      ((OSINDEX -1)
+       [MINUSFLAG (AND (MINUSP F)
+                       (SETQ F (- F]
+       (PADSIZE 0)
+       (PADCHAR #\Space)
+       NUMSTR INTEXP NSWIDTH)
+      [DESTRUCTURING-BIND
+       (WIDTH DECPART EXPPART PAD0 ROUND)
+       (CDR FORMAT)
+
+       (* ;; "Clip WIDTH to maximum size of buffer strings (128)")
+
+       (AND WIDTH (IGREATERP WIDTH 128)
+            (SETQ WIDTH 128))
+       (COND
+          ((NULL EXPPART)
+           (SETQ EXPPART 0)))
+       (COND
+          (PAD0 (SETQ PADCHAR #\0)))
+       (IF [OR (NOT (EQ EXPPART 0))
+                   (AND (NOT (ZEROP F))
+                        (OR (< F 0.001)
+                            (>= F 1.0E+7]
+           THEN 
+
+                 (* ;; "Exponential required - too big/small or explicitly requested")
+
+                 (IF (AND (NOT ROUND)
+                              DECPART)
+                     THEN (SETQ ROUND (LISP:1+ DECPART)))
+                 (LISP:MULTIPLE-VALUE-SETQ (NUMSTR INTEXP)
+                        (FLTSTR F ROUND))
+                 (IF (AND ROUND (NOT DECPART)            (* ; 
+                                              "we might be able to remove some trailing zeros here")
+                              (NOT (ZEROP F)))
+                     THEN (FOR STREND FROM (LISP:1- (LISP:LENGTH NUMSTR)) TO 0
+                                 BY -1 WHILE (EQ #\0 (LISP:CHAR NUMSTR STREND))
+                                 DO (GLC NUMSTR)
+                                       (LISP:INCF INTEXP)))
+                 (SETQ NUMSTR (ENUM-STRING \CFNSTRING NUMSTR INTEXP DECPART EXPPART))
+         ELSE 
+
+               (* ;; "Floating decimal printing")
+
+               [IF (AND (NOT ROUND)
+                            DECPART) 
+
+                      (* ;; 
+                    "Foo! Must compute round from decpart to round to a specific decimal place")
+
+                   THEN (SETQ ROUND
+                             (IF (ZEROP F)
+                                 THEN 1
+                               ELSE (MAX 0 (MIN 9 (+ (LISP:TRUNCATE (LISP:1+ (LISP:LOG F 10)))
+                                                         DECPART]
+               (LISP:MULTIPLE-VALUE-SETQ (NUMSTR INTEXP)
+                      (FLTSTR F ROUND))
+               (IF (AND ROUND (NOT DECPART)              (* ; 
+                                              "we might be able to remove some trailing zeros here")
+                            (NOT (ZEROP F)))
+                   THEN (FOR STREND FROM (LISP:1- (LISP:LENGTH NUMSTR)) TO 0
+                               BY -1 WHILE (EQ #\0 (LISP:CHAR NUMSTR STREND))
+                               DO (GLC NUMSTR)
+                                     (LISP:INCF INTEXP)))
+               (SETQ NUMSTR (FNUM-STRING \CFNSTRING NUMSTR INTEXP DECPART)))
+       (SETQ NSWIDTH (LISP:LENGTH \CFNSTRING))               (* ; "Handle padding")
+       [IF (AND WIDTH (> WIDTH NSWIDTH))
+           THEN (SETQ PADSIZE (- WIDTH NSWIDTH (LISP:IF MINUSFLAG
+                                                       1
+                                                       0)]
+       (AND PAD0 MINUSFLAG (STRPUT #\-))                     (* ; "Minus sign before 0 pad")
+       (LISP:DOTIMES (I PADSIZE)
+           (STRPUT PADCHAR))
+       (AND (NOT PAD0)
+            MINUSFLAG
+            (STRPUT #\-))                                    (* ; "But after blank pad")
+       (LISP:DOTIMES (I NSWIDTH)
+           (STRPUT (LISP:CHAR \CFNSTRING I)))]
+      (SUBSTRING OUTSTR 1 (LISP:1+ OSINDEX)
+             OUTSTRPTR])
+
+(LISP:DEFUN \FLOATINGSCALE (INTMANT INTEXP &OPTIONAL BOX)
+
+(* ;;; "Takes an integer mantissa and integer exponent and returns a floating-point number F such that  F = intmant * 10**intexp. Smashes it into box if one is supplied")
+
+   (LET (TEXP THI TLO (SIGN 0))
+        (DECLARE (LISP:SPECIAL TEXP THI TLO))
+        (IF (MINUSP INTMANT)
+            THEN (SETQ INTMANT (- INTMANT))
+                  (SETQ SIGN 1))
+        (INTTOEXT INTMANT)                               (* ; "leaves result in texp thi tlo")
+        (TIMESPOW10 INTEXP TEXP THI TLO)                 (* ; "ditto")
+        (\MAKEFLOAT SIGN TEXP THI TLO T BOX)))
+(DEFINEQ
+
+(\INIT.POWERS.OF.TEN
+  [LAMBDA NIL                                              (* ; "Edited 14-Jan-87 11:21 by jrb:")
+
+    (* ;; "Initialize array \POWERS.OF.TEN to values 10^-29 thru 10^+29.  I suppose I could have the array cover the entire range of floats, but the range is asymmetric and the numbers start losing significance at the ends, so it's not really worth it. Also initialize the array of 32-bit mantissa powers of 10 used by \convert.floating.number and friends.")
+
+    (SETQ \POWERS.OF.TEN (ARRAY 59 'POINTER))
+    (SETQ EXTPOWERS (LISP:MAKE-ARRAY 77))
+    (SETA \POWERS.OF.TEN 30 1.0)
+    (LISP:SETF (LISP:AREF EXTPOWERS 38)
+           (CREATE EFPN
+                  EXP _ \EXPONENT.BIAS
+                  HI _ 32768
+                  LO _ 0))
+    (for I from 1 to 29 bind (POWTEN _ 1.0) do (SETA \POWERS.OF.TEN
+                                                                         (IPLUS I 30)
+                                                                         (SETQ POWTEN
+                                                                          (FTIMES POWTEN 10.0)))
+                                                                  (SETA \POWERS.OF.TEN
+                                                                        (IDIFFERENCE 30 I)
+                                                                        (FQUOTIENT 1.0 POWTEN)))
+    [LET (ENOW EEXP EHI ELO TEXP THI TLO)
+         (DECLARE (LISP:SPECIAL TEXP THI TLO))
+
+         (* ;; "First generate the powers of ten exactly representable in 32 bits")
+
+         (for I from 1 to 9 bind (POW10 _ 1)
+            do (INTTOEXT (SETQ POW10 (LISP:* POW10 10))) 
+                                                             (* ; "Results in texp thi tlo")
+                  (LISP:SETF (LISP:AREF EXTPOWERS (+ 38 I))
+                         (CREATE EFPN
+                                EXP _ TEXP
+                                HI _ THI
+                                LO _ TLO)))
+         (SETQ ENOW (LISP:AREF EXTPOWERS (+ 38 9)))
+         (SETQ EEXP (FETCH (EFPN EXP)
+                           ENOW))
+         (SETQ EHI (FETCH (EFPN HI)
+                          ENOW))
+         (SETQ ELO (FETCH (EFPN LO)
+                          ENOW))
+         (for I from 1 to 4
+            do (TIMESPOW10 I EEXP EHI ELO)           (* ; "this does out to 10^13")
+                  (LISP:SETF (LISP:AREF EXTPOWERS (+ I 9 38))
+                         (CREATE EFPN
+                                EXP _ TEXP
+                                HI _ THI
+                                LO _ TLO)))
+
+         (* ;; "Then use them to generate the others")
+
+         (SETQ ENOW (LISP:AREF EXTPOWERS (+ 38 13)))
+         (SETQ EEXP (FETCH (EFPN EXP)
+                           ENOW))
+         (SETQ EHI (FETCH (EFPN HI)
+                          ENOW))
+         (SETQ ELO (FETCH (EFPN LO)
+                          ENOW))
+         (for I from 1 to 13
+            do (TIMESPOW10 I EEXP EHI ELO)           (* ; "this does out to 10^26")
+                  (LISP:SETF (LISP:AREF EXTPOWERS (+ I 13 38))
+                         (CREATE EFPN
+                                EXP _ TEXP
+                                HI _ THI
+                                LO _ TLO)))
+         (SETQ ENOW (LISP:AREF EXTPOWERS (+ 38 26)))
+         (SETQ EEXP (FETCH (EFPN EXP)
+                           ENOW))
+         (SETQ EHI (FETCH (EFPN HI)
+                          ENOW))
+         (SETQ ELO (FETCH (EFPN LO)
+                          ENOW))
+         (for I from 1 to 12
+            do (TIMESPOW10 I EEXP EHI ELO)           (* ; "this does out to 10^38")
+                  (LISP:SETF (LISP:AREF EXTPOWERS (+ I 26 38))
+                         (CREATE EFPN
+                                EXP _ TEXP
+                                HI _ THI
+                                LO _ TLO)))
+
+         (* ;; "Finally generate all the inverses: 10^-1 - 10^-38")
+
+         (for I from 1 to 38
+            do (SETQ ENOW (LISP:AREF EXTPOWERS (+ I 38)))
+                  (\EXTFQUOTIENT \EXPONENT.BIAS 32768 0 (FETCH (EFPN EXP)
+                                                                   ENOW)
+                         (FETCH (EFPN HI)
+                                ENOW)
+                         (FETCH (EFPN LO)
+                                ENOW))
+                  (LISP:SETF (LISP:AREF EXTPOWERS (- 38 I))
+                         (CREATE EFPN
+                                EXP _ TEXP
+                                HI _ THI
+                                LO _ TLO]
+    \POWERS.OF.TEN])
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+[PUTDEF '\CFNSTRING 'RESOURCES '(NEW (LISP:MAKE-ARRAY 128 :ELEMENT-TYPE 'LISP:STRING-CHAR 
+                                            :FILL-POINTER 0 :ADJUSTABLE T]
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \POWERS.OF.TEN)
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \POWER.OF.TEN MACRO ((N)
+                                       (ELT \POWERS.OF.TEN (IPLUS N 30))))
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(/SETTOPVAL '\\CFNSTRING.GLOBALRESOURCE NIL)
+
+
+(\INIT.POWERS.OF.TEN)
+)
+
+(PUTPROPS \UNBOXFLOAT1 ARGNAMES (X OP))
+
+(PUTPROPS \UNBOXFLOAT2 ARGNAMES (X Y OP))
+
+(PUTPROPS \UNBOXFLOAT3 ARGNAMES (X Y Z OP))
+
+(PUTPROPS LLFLOAT FILETYPE LISP:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA FPLUS FTIMES)
+)
+(PUTPROPS LLFLOAT COPYRIGHT ("Venue & Xerox Corporation" 1982 1984 1985 1986 1987 1988 1990 1991 1993)
+)
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (5053 5547 (\PUTBASEFLOATP 5063 . 5337) (\GETBASEFLOATP 5339 . 5545)) (6234 8047 (
+FTIMES 6244 . 6839) (FPLUS 6841 . 7290) (FQUOTIENT 7292 . 7433) (FDIFFERENCE 7435 . 7580) (FGREATERP 
+7582 . 7871) (FABS 7873 . 8045)) (8069 11535 (\SLOWFDIFFERENCE 8079 . 8248) (\SLOWFPLUS2 8250 . 8493) 
+(\SLOWFTIMES2 8495 . 8652) (\SLOWFQUOTIENT 8654 . 8890) (\SLOWFGREATERP 8892 . 11533)) (11688 35749 (
+\FZEROP 11698 . 11965) (FEQP 11967 . 13229) (\FLOAT 13231 . 14987) (\FIXP.FROM.FLOATP 14989 . 16479) (
+FIXR 16481 . 20043) (\BOXFPLUSDIF 20045 . 23187) (\BOXFQUOTIENT 23189 . 25958) (\BOXFTIMES2 25960 . 
+29672) (\INFINITY 29674 . 30387) (\MAKEFLOAT 30389 . 35125) (MAKEFLOATNUMBER 35127 . 35506) (PutFloat 
+35508 . 35747)) (36002 37667 (SQRT 36012 . 37665)) (50823 55607 (\UNBOXFLOAT1 50833 . 52061) (
+\UNBOXFLOAT2 52063 . 53566) (\UNBOXFLOAT3 53568 . 55605)) (55608 60400 (\MATMULT133 55618 . 56258) (
+\MATMULT144 56260 . 56900) (\MATMULT331 56902 . 57550) (\MATMULT333 57552 . 58649) (\MATMULT441 58651
+ . 59299) (\MATMULT444 59301 . 60398)) (62531 65437 (FLOATP.TO.BCPL 62541 . 63854) (BCPL.TO.FLOATP 
+63856 . 65435)) (95174 99983 (\INIT.POWERS.OF.TEN 95184 . 99981)))))
+STOP
diff --git a/CLTL2/LLFLOAT.LCOM b/CLTL2/LLFLOAT.LCOM
new file mode 100644
index 00000000..ec947945
Binary files /dev/null and b/CLTL2/LLFLOAT.LCOM differ
diff --git a/CLTL2/LLINTERP b/CLTL2/LLINTERP
new file mode 100644
index 00000000..e0038120
--- /dev/null
+++ b/CLTL2/LLINTERP
@@ -0,0 +1,2904 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 16:25:22" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLINTERP.;1" 155590 
+
+      previous date%: "31-Dec-92 01:36:17" "{Pele:mv:envos}<LispCore>Sources>LLINTERP.;6")
+
+
+(* ; "
+Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+The following program was created in 1981 but has not been published
+within the meaning of the copyright law, is furnished under license,
+and may not be used, copied and/or disclosed except in accordance
+with the terms of said license.
+")
+
+(PRETTYCOMPRINT LLINTERPCOMS)
+
+(RPAQQ LLINTERPCOMS
+       [[E                                                   (* ; 
+                                                           "Don't fontify these common functions")
+           (SETQ FNSLST
+                 (LDIFFERENCE FNSLST
+                        '(EVALV PROG SET SETQ RETURN GO QUOTE AND OR PROGN COND PROG1 FUNCTION EVAL 
+                                APPLY]
+        (COMS                                                (* ; 
+                                                           "For calling interpreted functions")
+              (FNS \INTERPRETER \INTERPRETER1 \SETUP-COMPILED-CLOSURE-CALL \STKNAME))
+        (COMS                                                (* ; "EVCALL ufn.")
+              (FNS \ENVCALL.UFN \SETUP-ENVIRONMENT-CALL))
+        (COMS                                                (* ; "recursive interpreter")
+              (FNS EVAL \EVAL \EVALFORM \EVALFORMASLAMBDA \EVALOTHER APPLY APPLY* \CHECKAPPLY* 
+                   \CKAPPLYARGS DEFEVAL)
+              (DECLARE%: DONTCOPY (MACROS .APPLY.))
+              (COMS                                          (* ; "Free variable manipulation")
+                    (FNS EVALV \EVALV1 \EVALVAR BOUNDP SET \SETVAR SETQ \STKSCAN \SETFVARSLOT))
+              (COMS                                          (* ; "PROG and friends")
+                    (FNS PROG \PROG0 \EVPROG1 RETURN GO EVALA \EVALA ERRORSET 
+                         SI::ERRORSET-PRINT-FUNCTION))
+              (COMS                                          (* ; 
+                                                        "LET and friends -- need these in the init")
+                    (FNS LET LET* \LET0 \LET*))
+              (FNS QUOTE AND OR PROGN COND \EVPROGN PROG1)
+              (COMS (VARS (\DEFEVALFNS NIL)
+                          (\EVALHOOK))
+                    (SPECVARS *EVALHOOK*)
+                    (ADDVARS (LAMBDASPLST LAMBDA NLAMBDA LISP:LAMBDA OPENLAMBDA))
+                    (GLOBALVARS \DEFEVALFNS \EVALHOOK LAMBDASPLST CLISPARRAY)
+                    (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (CLISPARRAY))
+                           (P (MOVD? 'SETQ 'SETN NIL T)))
+                    (GLOBALVARS CLISPARRAY))
+              [COMS                                          (* ; 
+                                                        "Evaluating in different stack environment")
+                    (FNS ENVEVAL ENVAPPLY FUNCTION \FUNCT1 \MAKEFUNARGFRAME STKEVAL STKAPPLY RETEVAL
+                         RETAPPLY)
+                    (DECLARE%: DONTEVAL@LOAD DOCOPY          (* ; 
+                                         "For bootstrapping, IL:FUNCTION is as good as CL:FUNCTION")
+                           (P (MOVD? 'FUNCTION 'LISP:FUNCTION NIL T]
+              (COMS                                          (* ; "Blip and other stack funniness")
+                    (FNS BLIPVAL SETBLIPVAL BLIPSCAN)
+                    (FNS \REALFRAMEP)
+                    [INITVARS (OPENFNS '(APPLY* SETQ AND OR COND SELECTQ PROG PROGN PROG1 ARG SETARG
+                                               ERSETQ NLSETQ RESETFORM RESETLST RESETVARS RPTQ 
+                                               SAVESETQ SETN UNDONLSETQ XNLSETQ]
+                    (VARS \BLIPNAMES)
+                    (GLOBALVARS BRKINFOLST)
+                    (GLOBALVARS \BLIPNAMES OPENFNS)))
+        (COMS (FNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA READVA 
+                   READATOM READOCT SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY NOSUCHATOM)
+              (FNS BACKTRACE \BACKTRACE \SCANFORNTENTRY \PRINTSTK \PRINTFRAME \PRINTBF)
+              (DECLARE%: EVAL@COMPILE DONTCOPY (COMS * RAIDCOMS)))
+        (COMS (FNS CCODEP EXPRP SUBRP FNTYP ARGTYPE NARGS ARGLIST \CCODEARGLIST \CCODEIVARSCAN)
+              (COMS                                          (* ; 
+                                                       "Translation machinery for new LAMBDA words")
+                    (PROP VARTYPE LAMBDATRANFNS)
+                    (ALISTS (LAMBDATRANFNS)))
+              (DECLARE%: DONTCOPY (MACROS \CCODENARGS \CCODEFNTYP \CCODEARGTYPE)))
+        (COMS                                                (* ; "CONSTANTS mechanism")
+              (FNS CONSTANTS CONSTANTEXPRESSIONP)
+              (INITVARS (COMPVARMACROHASH (HASHARRAY 100)))
+                                                             (* ; "We need this initialized for the INIT, so don't put it off. (It used to start out NIL and get set later)")
+              (ADDVARS (CONSTANTFOLDFNS PLUS IPLUS TIMES ITIMES DIFFERENCE IDIFFERENCE QUOTIENT 
+                              IQUOTIENT IMIN IMAX IABS LLSH LRSH LOGOR LOGXOR LOGAND OR AND))
+              (GLOBALVARS COMPVARMACROHASH CONSTANTFOLDFNS))
+        (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (LOCALVARS . T))
+        (SPECVARS *TAIL* *FN* *FORM* *ARGVAL*)
+        (DECLARE%: EVAL@COMPILE DONTCOPY (ADDVARS (LAMS FAULTEVAL FAULTAPPLY)))
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA CONSTANTS PROG1 COND PROGN OR AND QUOTE LET* LET GO PROG SETQ)
+                      (NLAML FUNCTION RETURN)
+                      (LAMA BOUNDP APPLY* \INTERPRETER])
+
+
+
+(* ; "For calling interpreted functions")
+
+(DEFINEQ
+
+(\INTERPRETER
+  [LAMBDA N                                                  (* ; "Edited 21-Jan-91 18:02 by jds")
+
+    (* ;; "the microcode calls this function instead if it is given an expr or an undefined function to call --- the name of the function/sexpression which is supposed to be called is given as an extra argument")
+
+    (PROG ((FN (ARG N N))
+           (NACTUAL (SUB1 N))
+           (NA 0)
+           DEF ARGLIST NEXTRA NTSIZE TYPE NNILS ENV)
+          (COND
+             ((LITATOM FN)
+              (CHECK (NOT (fetch (LITATOM CCODEP) of FN)))
+              (SETQ DEF (fetch (LITATOM DEFPOINTER) of FN)))
+             (T (SETQ DEF FN)))
+          [COND
+             ((TYPEP DEF 'COMPILED-CLOSURE)
+              (RETURN (\MISCAPPLY* (FUNCTION \SETUP-COMPILED-CLOSURE-CALL)
+                             DEF)))
+             ((TYPEP DEF 'CLOSURE)
+              (SETQ ENV (CLOSURE-ENVIRONMENT DEF))
+              (SETQ DEF (CLOSURE-FUNCTION DEF]
+          (COND
+             ((NLISTP DEF)
+              (GO ERR)))
+          (RETURN (.CALLAFTERPUSHINGNILS.
+                   (SELECTQ (CAR DEF)
+                       (LISP:LAMBDA (RETURN (\INTERPRETER-LAMBDA N DEF ENV FN)))
+                       ([LAMBDA NLAMBDA OPENLAMBDA] 
+                            [SETQ ARGLIST (CAR (OR (LISTP (CDR DEF))
+                                                   (GO ERR]
+                            (SETQ NNILS
+                             (IPLUS (SETQ NEXTRA
+                                     (COND
+                                        ((LISTP ARGLIST)     (* ; "spread function")
+                                         (for X in ARGLIST
+                                            do (COND
+                                                      ((OR (NULL (\DTEST X 'LITATOM))
+                                                           (EQ X T))
+                                                       (LISPERROR "ATTEMPT TO BIND NIL OR T" X))) 
+                                                             (* ; "Process one argument")
+                                                  (SETQ NA (ADD1 NA)))
+                                         (COND
+                                            ((IGREATERP NA NACTUAL)
+                                             (IDIFFERENCE NA NACTUAL))
+                                            (T 0)))
+                                        ((NULL ARGLIST)      (* ; "spread function")
+                                         0)
+                                        ((EQ ARGLIST T)
+                                         (LISPERROR "ATTEMPT TO BIND NIL OR T" ARGLIST))
+                                        (T 
+
+                                 (* ;; "Nospread--needs to bind exactly one variable, the arg name.  LAMBDA* also needs to set that arg to the number of actual args, but that can be done by diddling the slot currently occupied by the fn name.  Never any 'extra' args to worry about")
+
+                                           (\DTEST ARGLIST 'LITATOM)
+                                           (SETQ NA 1)
+                                           0)))
+                                    (PROG1 (SETQ NTSIZE (CEIL [ADD1 (UNFOLD NA (CONSTANT (
+                                                                                    WORDSPERNAMEENTRY
+                                                                                          ]
+                                                              WORDSPERQUAD))
+
+                                 (* ;; "round number of nametable entries up to next quadword, leaving room for a zero.  add in overhead.  NA is now in units of 'cells' since there two words in a cell.")
+
+                                           )
+                                    (FOLDHI (fetch (FNHEADER OVERHEADWORDS) of T)
+                                           WORDSPERCELL)
+                                    (SUB1 CELLSPERQUAD))))
+                       (FUNARG (GO FUN))
+                       (GO ERR))
+                   (\INTERPRETER1 ARGLIST NNILS NTSIZE NACTUAL NEXTRA FN DEF)))
+      FUN 
+
+     (* ;; "FUNARG -- Interlisp %"closure%" of form (FUNARG fn stackptr).  Subsumed by common lisp lexical closures.")
+
+          [RETURN (PROGN (\SMASHLINK NIL (\STACKARGPTR (CADDR DEF)))
+                         (SPREADAPPLY (CADR DEF)
+                                (for I from 1 to (SUB1 N) collect (ARG N I]
+      ERR (RETURN (FAULTAPPLY FN (for I from 1 to NACTUAL collect (ARG N I])
+
+(\INTERPRETER1
+  [LAMBDA (ARGLIST NNILS NTSIZE NACTUAL NPVARARGS FN DEF)(* ; "Edited 27-Jan-91 12:48 by jds")
+    (PROG ((*TAIL* (CDDR DEF))
+           (INTERPFRAME (\MYALINK))
+           HEADER NT NILSTART)
+          (SETQ HEADER (fetch (FX FNHEADER) of INTERPFRAME))
+                                                             (* ; 
+                                                     "The function header of code for \INTERPRETER")
+
+     (* ;; "Build a nametable for INTERPFRAME that identifies the vars in ARGLIST as the NACTUAL IVAR's that were passed to it as arguments plus the NPVARARGS extra NIL's that we implement as PVAR's.  We build the nametable out of space that was allocated on the stack by \INTERPRETER pushing many NIL's")
+
+          (SETQ NT (ADDSTACKBASE (CEIL (+ (SETQ NILSTART (- (fetch (FX NEXTBLOCK) of 
+                                                                                          INTERPFRAME
+                                                                   )
+                                                            (UNFOLD NNILS WORDSPERCELL)))
+                                          (UNFOLD NPVARARGS WORDSPERCELL))
+                                       WORDSPERQUAD)))
+
+     (* ;; "Address of our synthesized nametable: NNILS cells back from the end of INTERPFRAME, leaving space for additional 'PVARs' we are using as extra NIL args, rounded up to quadword")
+
+          (UNINTERRUPTABLY
+              [COND
+                 ((NOT ARGLIST)                              (* ; "No args, no nametable")
+                  )
+                 ((LISTP ARGLIST)
+                  (for ARG in ARGLIST as ARG# from 0 as NT1
+                     from (fetch (FNHEADER OVERHEADWORDS) of T)
+                     by (CONSTANT (WORDSPERNAMEENTRY)) as NT2
+                     from (+ (fetch (FNHEADER OVERHEADWORDS) of T)
+                                 NTSIZE) by (CONSTANT (WORDSPERNTOFFSETENTRY))
+                     do (SETSTKNAME-RAW NT NT1 (\ATOMVALINDEX ARG))
+                           [SETSTKNTOFFSET-RAW NT NT2 (COND
+                                                         ((< ARG# NACTUAL)
+                                                          IVARCODE)
+                                                         (T  (* ; 
+                             "Say it's the nth PVAR, where n is out of the range of the real PVARs")
+                                                            PVARCODE))
+                                  (COND
+                                     ((< ARG# NACTUAL)
+                                      ARG#)
+                                     (T                      (* ; 
+                             "Say it's the nth PVAR, where n is out of the range of the real PVARs")
+                                        (IPLUS (FOLDLO (- NILSTART (fetch (FX FIRSTPVAR)
+                                                                      of INTERPFRAME))
+                                                      WORDSPERCELL)
+                                               (- ARG# NACTUAL] 
+                                                             (* ; "(SETSTKNTOFFSET-RAW NT NT2 (COND ((< ARG# NACTUAL) (+ IVARCODE ARG#)) (T ; Say it's the nth PVAR, where n is out of the range of the real PVARs (+ PVARCODE (FOLDLO (- NILSTART (fetch (FX FIRSTPVAR) of INTERPFRAME)) WORDSPERCELL) (- ARG# NACTUAL)))))")
+                         )                                   (* ; 
+             "Note: area is initialize to NIL's (zero), so end of nametable already has its zeroes")
+                  )
+                 (T                                          (* ; 
+                                                           "Nospread.  Store lone arg in nametable")
+                    (SETSTKNAME-RAW NT (fetch (FNHEADER OVERHEADWORDS) of T)
+                           (\ATOMVALINDEX ARGLIST))
+                    (SETSTKNTOFFSET-RAW NT (+ (fetch (FNHEADER OVERHEADWORDS) of T)
+                                              NTSIZE)
+                           IVARCODE
+                           (COND
+                              ((EQ (CAR DEF)
+                                   'NLAMBDA)                 (* ; "It's the first (and only) arg")
+                               0)
+                              (T                             (* ; 
+                                        "Use the n+1'st arg, which currently is our framename (FN)")
+                                 (\PUTBASEPTR \STACKSPACE (+ (fetch (BF IVAR)
+                                                                of (fetch (FX BLINK)
+                                                                          of INTERPFRAME))
+                                                             (UNFOLD NACTUAL WORDSPERCELL))
+                                        NACTUAL)             (* ; 
+                                                        "set arg's value to be number of real args")
+                                 NACTUAL]
+
+              (* ;; "now fix up header of NT")
+
+              (replace (FNHEADER %#FRAMENAME) of NT with FN)
+                                                             (* ; 
+                                                   "use #FRAMENAME to denote no reference counting")
+              (replace (FNHEADER NTSIZE) of NT with NTSIZE)
+              (replace (FNHEADER NLOCALS) of NT with (fetch (FNHEADER NLOCALS)
+                                                                    of HEADER))
+                                                             (* ; 
+                                  "Probably doesn't matter, since there are no FVARS in that frame")
+                                                             (* ; 
+                         "Do I need to worry about STK, NA, PV, START, ARGTYPE ?  --- probably not")
+              (replace (FX NAMETABLE) of INTERPFRAME with NT))
+      EVLP
+          
+
+     (* ;; 
+   "Now that we have 'bound' the arguments, just evaluate the forms in the LAMBDA/NLAMBDA as progn")
+
+          (COND
+             ((CDR *TAIL*)
+              (\EVAL (CAR *TAIL*))
+              (SETQ *TAIL* (CDR *TAIL*))
+              (GO EVLP))
+             (T (RETURN (\EVAL (CAR *TAIL*])
+
+(\SETUP-COMPILED-CLOSURE-CALL
+  [LAMBDA (CLOSURE)                                          (* bvm%: "21-Jul-86 11:12")
+
+(* ;;; "Called in the misc context by \INTERPRETER when the function being called is a closure.  Replace the intepreter frame by the frame that would result if we had correctly called the closure in microcode.  This is a normal function call of the code body in the closure with the one additional wrinkle that the CLOSURE object is stored in PVAR1.")
+
+    (LET ((INTERPFRAME (fetch (IFPAGE MiscFXP) of \InterfacePage))
+              (CODE (fetch (COMPILED-CLOSURE FNHEADER) of CLOSURE))
+              NA NACTUALS INTERPBF INTERPIVAR INTERPALINK INTERPCLINK SP NEWFX NPVARS STKEND SLOWP 
+              OLDBF ENV)
+           (SETQ OLDBF (SETQ INTERPBF (fetch (FX BLINK) of INTERPFRAME)))
+           (SETQ INTERPIVAR (fetch (BF IVAR) of INTERPBF))
+           (SETQ INTERPALINK (fetch (FX %#ALINK) of INTERPFRAME))
+                                                             (* ; 
+               "Note that this is the 'raw' ALINK -- we never look at it, just update it in new FX")
+           [COND
+              ((SETQ SLOWP (fetch (FX SLOWP) of INTERPFRAME))
+
+               (* ;; "Usually false, because \INTERPRETER hasn't had any reason to make itself slow.  But it's not uninterruptable, so arbitrary things could happen to it")
+
+               (SETQ INTERPCLINK (fetch (FX %#CLINK) of INTERPFRAME]
+           (SETQ STKEND (fetch (FX NEXTBLOCK) of INTERPFRAME))
+           [COND
+              ((fetch (BF PADDING) of INTERPBF)      (* ; 
+              "Forget padding.  I don't think anyone pads anymore, except maybe Lisp stack mungers")
+               (SETQ INTERPBF (IDIFFERENCE INTERPBF WORDSPERCELL]
+           (SETQ NACTUALS (FOLDLO (IDIFFERENCE INTERPBF INTERPIVAR)
+                                 WORDSPERCELL))
+           (SETQ NA (fetch (FNHEADER NA) of CODE))
+           [COND
+              ((OR SLOWP (ILESSP (IDIFFERENCE STKEND INTERPBF)
+                                (fetch (FNHEADER STKMIN) of CODE)))
+
+               (* ;; "No space for frame, or interpreter frame is slow, do slow case.  This computation is quite conservative, since we aren't counting the args")
+
+               (LET ((NEWSTACK (\FREESTACKBLOCK (IPLUS (fetch (FNHEADER STKMIN) of CODE)
+                                                           (UNFOLD NACTUALS WORDSPERCELL))
+                                          INTERPFRAME)))
+                      (SETQ STKEND (IPLUS NEWSTACK (fetch (FSB SIZE) of NEWSTACK)))
+                      [while (type? FSB STKEND) do (SETQ STKEND
+                                                                (add STKEND (fetch
+                                                                                 (FSB SIZE)
+                                                                                   of STKEND]
+                      (\BLT (ADDSTACKBASE NEWSTACK)
+                            (ADDSTACKBASE INTERPIVAR)
+                            (UNFOLD NACTUALS WORDSPERCELL))
+                      (SETQ INTERPBF (IPLUS NEWSTACK (UNFOLD NACTUALS WORDSPERCELL)))
+                      [COND
+                         ((NEQ (fetch (FX USECNT) of INTERPFRAME)
+                               0)
+                          (add (fetch (FX USECNT) of INTERPFRAME)
+                                 -1))
+                         (T [COND
+                               ((NEQ (fetch (BF USECNT) of OLDBF)
+                                     0)
+                                (add (fetch (BF USECNT) of OLDBF)
+                                       -1))
+                               (T                            (* ; "Normal slow case, can flush BF")
+                                  (\MAKEFREEBLOCK INTERPIVAR (IPLUS (IDIFFERENCE OLDBF INTERPIVAR)
+                                                                    WORDSPERCELL]
+                                                             (* ; 
+   "Finally, flush FX.  Has to be separate free block because FX and BF not necessarily contiguous")
+                            (LET [(START (COND
+                                                ((EQ OLDBF (fetch (FX DUMMYBF) of INTERPFRAME
+                                                                  ))
+                                                             (* ; "Normal contiguous case")
+                                                 INTERPFRAME)
+                                                (T           (* ; 
+                                                "Have to blow away the dummy BF in front of the FX")
+                                                   (fetch (FX DUMMYBF) of INTERPFRAME]
+                                   (\MAKEFREEBLOCK START (IDIFFERENCE (fetch (FX NEXTBLOCK)
+                                                                         of INTERPFRAME)
+                                                                START]
+                      (SETQ INTERPIVAR NEWSTACK)
+                      (SETQ SLOWP T]
+           [PROGN                                            (* ; 
+"Do argument adjustment.  In general we should pop excess args, but there's really no need for that")
+                  (COND
+                     ((GREATERP NA NACTUALS)                 (* ; 
+                                                           "Push extra NILs for missing args")
+                      (FRPTQ (DIFFERENCE NA NACTUALS)
+                             (\PUTBASEPTR (STACKADDBASE INTERPBF)
+                                    0 NIL)
+                             (add INTERPBF WORDSPERCELL]
+           (PROGN                                            (* ; "Fix up BF trailer cell")
+                  (\PUTBASE \STACKSPACE INTERPBF 0)          (* ; "Clear BF flags")
+                  (replace (BF IVAR) of INTERPBF with INTERPIVAR)
+                  (replace (BF FLAGS) of INTERPBF with \STK.BF)
+                  (CHECK (fetch (BF CHECKED) of INTERPBF)))
+           (PROGN 
+                  (* ;; "Fix up FX header.  Some of this work is redundant in the case where NEWFX is the same as the old, but in general we did some arg adjusting or did the slow case")
+
+                  (SETQ NEWFX (IPLUS INTERPBF WORDSPERCELL))
+                  (\PUTBASE \STACKSPACE NEWFX 0)             (* ; "Clear FX flags")
+                  (replace (FX FLAGS) of NEWFX with \STK.FX)
+                  (replace (FX NOPUSH) of NEWFX with T)
+                                                             (* ; 
+                      "When we return to the user context, don't want any value to appear on stack")
+                  (COND
+                     (SLOWP (replace (FX %#BLINK) of NEWFX with INTERPBF)
+                            (replace (FX %#CLINK) of NEWFX with (OR INTERPCLINK 
+                                                                                INTERPALINK))
+
+                            (* ;; "If INTERPCLINK is NIL, the original frame was not SLOW, so ALINK = CLINK and INTERPALINK has its low bit off")
+
+                            (replace (FX %#ALINK) of NEWFX with (LOGOR INTERPALINK 1)))
+                     (T (replace (FX %#ALINK) of NEWFX with INTERPALINK)))
+                  (replace (FX FNHEADER) of NEWFX with CODE)
+                  (replace (FX PC) of NEWFX with (fetch (FNHEADER STARTPC)
+                                                                of CODE)))
+           [PROGN                                            (* ; "Initialize PVAR region")
+                  (SETQ SP (fetch (FX FIRSTPVAR) of NEWFX))
+                  (SETQ NPVARS (UNFOLD (ADD1 (fetch (FNHEADER PV) of CODE))
+                                      CELLSPERQUAD))
+                  (COND
+                     ((SETQ ENV (fetch (COMPILED-CLOSURE ENVIRONMENT) of CLOSURE))
+                                                             (* ; 
+                                                           "Set first pvar to closure environment")
+                      (\PUTBASEPTR \STACKSPACE SP ENV)
+                      (add SP WORDSPERCELL)
+                      (add NPVARS -1)))
+                  (RPTQ NPVARS (PROGN                        (* ; 
+                                                       "Fill in rest of Pvar region with 'unbound'")
+                                      (\PUTBASE \STACKSPACE SP 65535)
+                                      (add SP WORDSPERCELL]
+           (PROGN                                            (* ; 
+                                                           "Make free block after this frame")
+                  (replace (FX NEXTBLOCK) of NEWFX with (add SP (fetch
+                                                                                 (FX PADDING)
+                                                                                   of NEWFX)))
+                                                             (* ; 
+                                                       "Need extra junk quad after the pvar region")
+                  (\MAKEFREEBLOCK SP (IDIFFERENCE STKEND SP))
+                  (CHECK (fetch (FX CHECKED) of NEWFX)))
+           (replace (IFPAGE MiscFXP) of \InterfacePage with NEWFX])
+
+(\STKNAME
+  [LAMBDA (POS)                                              (* ; "Edited 27-Jan-91 14:20 by jds")
+
+    (* ;; "Get the frame name from the stack frame at POS.  If that's an interpreter frame, get it's caller's frame name.")
+
+    (LET ((NAME (fetch (FX FRAMENAME) of POS)))
+           (if (EQ NAME '\INTERPRETER)
+               then [\GETBASEPTR \STACKSPACE (LET ((BFLINK (fetch (FX BLINK) of
+                                                                                         POS)))
+                                                        (+ (fetch (BF IVAR) of BFLINK)
+                                                           (TIMES (LISP:1- (fetch (BF NARGS)
+                                                                              of BFLINK))
+                                                                  WORDSPERCELL]
+             else NAME])
+)
+
+
+
+(* ; "EVCALL ufn.")
+
+(DEFINEQ
+
+(\ENVCALL.UFN
+  [LAMBDA (\INTERRUPTABLE)                                   (* ; "Edited 18-Apr-88 18:25 by bvm")
+    (\MISCAPPLY* (FUNCTION \SETUP-ENVIRONMENT-CALL])
+
+(\SETUP-ENVIRONMENT-CALL
+  [LAMBDA NIL                                              (* ; "Edited  4-Aug-88 11:39 by bvm")
+
+(* ;;; "Called in the misc context by ufn for ENVCALL, a variant on APPLYFN that takes on the stack: ..args.. #args codeblock environment.  Replace the ufn frame by the frame that would result if we had correctly done the call in microcode.  This is a normal function call of the codeblock with the one additional wrinkle that the environment is stored in PVAR0.")
+
+    (LET* ((UFNFX (fetch (IFPAGE MiscFXP) of \InterfacePage))
+               (UFNNEXT (fetch (FX NEXTBLOCK) of UFNFX))
+               (UFNBF (fetch (FX BLINK) of UFNFX))
+               (UFNIVAR (fetch (BF IVAR) of UFNBF))
+               (CALLER (fetch (FX CLINK) of UFNFX))
+               (CALLNEXT (fetch (FX NEXTBLOCK) of CALLER))
+               CODE ENV NA NACTUALS STKEND SLOWP LOCNARGS FREESIZE NEEDEDSIZE ARGSTART NEWSTACK IVAR)
+           [SETQ LOCNARGS (STACKADDBASE (- CALLNEXT (UNFOLD 3 WORDSPERCELL]
+                                                             (* ; 
+                      "Location in caller's stack of number of args, followed by CODEBLOCK and ENV")
+           (SETQ NACTUALS (\GETBASEPTR LOCNARGS 0))          (* ; 
+                                       "Fetch nargs, codeblock and environment from caller's stack")
+           (SETQ ENV (\GETBASEPTR LOCNARGS 4))
+           (SETQ CODE (\GETBASEPTR LOCNARGS 2))
+           (SETQ NA (fetch (FNHEADER NA) of CODE))   (* ; "Number args expected")
+           (SETQ NEEDEDSIZE (fetch (FNHEADER STKMIN) of CODE))
+           (SETQ ARGSTART (- CALLNEXT (UNFOLD (+ NACTUALS 3)
+                                             WORDSPERCELL))) (* ; 
+                                                           "Address of first argument to function")
+           (if (AND (> NACTUALS NA)
+                        (>= NA 0))
+               then                                      (* ; "More args than expected.  No need to retain/copy them (and it's best not to, since STKMIN calculation assumes expected args, not lots more)")
+                     (SETQ NACTUALS NA))
+           (if (AND (if (EQ UFNBF (fetch (FX DUMMYBF) of UFNFX))
+                            then                         (* ; "BF and FX contiguous")
+                                  T
+                          else                           (* ; 
+                                  "Yecch.  Non-contiguous BF and FX.  Toss the BF and do slow case")
+                                (\MAKEFREEBLOCK UFNIVAR (+ WORDSPERCELL (- UFNBF UFNIVAR)))
+                                (SETQ UFNIVAR (fetch (FX DUMMYBF) of UFNFX)) 
+                                                             (* ; 
+                                        "For next \makefreeblock -- have to blow away this dummybf")
+                                NIL)
+                        (EQ UFNIVAR CALLNEXT)
+                        (PROGN                               (* ; 
+                                                           "Caller contiguous with ufn frame")
+                               (SETQ FREESIZE (- UFNNEXT UFNIVAR))
+                               (bind SZ while (type? FSB UFNNEXT)
+                                  do                     (* ; 
+                                             "Add up the lengths of all the contiguous free blocks")
+                                        (add FREESIZE (SETQ SZ (fetch (FSB SIZE) of
+                                                                                         UFNNEXT)))
+                                        (add UFNNEXT SZ))
+                               (> FREESIZE NEEDEDSIZE)))
+               then                                      (* ; "Normal case: there's enough space to build the frame on top of ufn frame.  Args are already there (we will lop them from caller's frame), so no copying to do.")
+                     (SETQ STKEND UFNNEXT)
+                     (SETQ NEWSTACK ARGSTART)
+             else                                        (* ; 
+                                                     "Have to make a discontinuous frame elsewhere")
+                   (\MAKEFREEBLOCK UFNIVAR (- UFNNEXT UFNIVAR)) 
+                                                             (* ; 
+                            "Discard ufn frame (and dummy bf before it in the non-contiguous case)")
+                   (SETQ NEWSTACK (\FREESTACKBLOCK (+ NEEDEDSIZE (UNFOLD NACTUALS WORDSPERCELL))
+                                         UFNIVAR))           (* ; 
+                              "Get a free block big enough for fn plus the args we'll have to copy")
+                   (SETQ STKEND (+ NEWSTACK (fetch (FSB SIZE) of NEWSTACK)))
+                   (\BLT (STACKADDBASE NEWSTACK)
+                         (STACKADDBASE ARGSTART)
+                         (UNFOLD NACTUALS WORDSPERCELL))     (* ; "Copy args to new frame")
+                   (\MAKEFREEBLOCK ARGSTART (- CALLNEXT ARGSTART)) 
+                                                             (* ; 
+                                                           "Free up space taken in caller by args")
+                   (SETQ SLOWP T))
+           (SETQ IVAR NEWSTACK)
+           (add NEWSTACK (UNFOLD NACTUALS WORDSPERCELL))
+           (replace (FX NEXTBLOCK) of CALLER with ARGSTART)
+                                                             (* ; 
+                                               "Shorten caller's frame to account for args removed")
+           (if (>= NA 0)
+               then                                      (* ; "Fill in NIL for defaulted args")
+                     (RPTQ (- NA NACTUALS)
+                           (\PUTBASEPTR (STACKADDBASE NEWSTACK)
+                                  0 NIL)
+                           (add NEWSTACK WORDSPERCELL)))
+           (PROGN                                            (* ; "Fix up BF trailer cell")
+                  (\PUTBASE (STACKADDBASE NEWSTACK)
+                         0 \STK.BF.WORD)                     (* ; "Clear BF flags")
+                  (replace (BF IVAR) of NEWSTACK with IVAR)
+                  (CHECK (fetch (BF CHECKED) of NEWSTACK)))
+           (PROGN 
+                  (* ;; "Now build the FX header")
+
+                  (add NEWSTACK WORDSPERCELL)
+                  (\PUTBASE (STACKADDBASE NEWSTACK)
+                         0
+                         (LLSH \STK.FX \STK.FLAGS.SHIFT))    (* ; "Clear FX flags")
+                  (replace (FX NOPUSH) of NEWSTACK with T)
+                                                             (* ; 
+                      "When we return to the user context, don't want any value to appear on stack")
+                  [LET ((ALINK (+ CALLER \#ALINK.OFFSET)))
+                                                             (* ; "ALINK field for fast case")
+                         (COND
+                            (SLOWP                           (* ; "Have to make non-contiguous frame slow.  Set each piece manually to avoid redundant computation from the computed record fields")
+                                   (replace (FX %#BLINK) of NEWSTACK
+                                      with (fetch (FX DUMMYBF) of NEWSTACK))
+                                   (replace (FX %#CLINK) of NEWSTACK with ALINK)
+                                   (replace (FX %#ALINK) of NEWSTACK with (LOGOR ALINK 1)
+                                          )                  (* ; "1 is the slow bit")
+                                   )
+                            (T (replace (FX %#ALINK) of NEWSTACK with ALINK]
+                  (replace (FX FNHEADER) of NEWSTACK with CODE)
+                  (replace (FX PC) of NEWSTACK with (fetch (FNHEADER STARTPC)
+                                                                   of CODE)))
+           [LET ((SP (fetch (FX FIRSTPVAR) of NEWSTACK))
+                     (NPVARS (UNFOLD (ADD1 (fetch (FNHEADER PV) of CODE))
+                                    CELLSPERQUAD)))
+
+                  (* ;; "Fill in rest of FX")
+
+                  [PROGN                                     (* ; "Initialize PVAR region")
+                         (if ENV
+                             then                        (* ; 
+                                                           "Set first pvar to closure environment")
+                                   (\PUTBASEPTR (STACKADDBASE SP)
+                                          0 ENV)
+                                   (add SP WORDSPERCELL)
+                                   (SETQ NPVARS (SUB1 NPVARS)))
+                         (RPTQ NPVARS (PROGN                 (* ; 
+                                                       "Fill in rest of Pvar region with 'unbound'")
+                                             (\PUTBASE (STACKADDBASE SP)
+                                                    0 65535)
+                                             (add SP WORDSPERCELL]
+                  (PROGN                                     (* ; 
+                                                           "Make free block after this frame")
+                         (replace (FX NEXTBLOCK) of NEWSTACK
+                            with (add SP (fetch (FX PADDING) of NEWSTACK)))
+                                                             (* ; 
+                                                       "Need extra junk quad after the pvar region")
+                         (CHECK (> STKEND SP))
+                         (\MAKEFREEBLOCK SP (- STKEND SP))
+                         (CHECK (fetch (FX CHECKED) of NEWSTACK]
+           (replace (IFPAGE MiscFXP) of \InterfacePage with NEWSTACK])
+)
+
+
+
+(* ; "recursive interpreter")
+
+(DEFINEQ
+
+(EVAL
+  [LAMBDA (U \INTERNAL)
+    (DECLARE (SPECVARS \INTERNAL))                       (* lmm "19-AUG-81 23:04")
+    (\EVAL U])
+
+(\EVAL
+  [LAMBDA (FORM)                                             (* lmm " 3-NOV-81 15:42")
+
+    (* ;; "ufn for Interlisp EVAL opcode.")
+
+    (COND
+       ((LISTP FORM)
+        (\EVALFORM FORM))
+       ((LITATOM FORM)
+        (\EVALVAR FORM))
+       ((NUMBERP FORM)
+        FORM)
+       (T (\EVALOTHER FORM])
+
+(\EVALFORM
+  [LAMBDA (*FORM* TEMP)
+    (DECLARE (SPECVARS *FORM*)
+           (ADDTOVAR LAMS FAULTEVAL))                    (* ; "Edited 29-Jun-87 16:42 by amd")
+
+(* ;;; "eval of LISTP")
+
+    (PROG NIL
+      RETRY
+          [COND
+             ((LITATOM (SETQ TEMP (CAR *FORM*)))
+              (COND
+                 ((fetch (LITATOM CCODEP) of TEMP)
+                  (SELECTQ (fetch (LITATOM ARGTYPE) of TEMP)
+                      (1 (GO NLSPREAD))
+                      (3 (GO NLNOSPREAD))
+                      (GO EVLAM)))
+                 (T                                          (* ; "EXPR OR UDF")
+                    (SETQ TEMP (fetch (LITATOM DEFPOINTER) of TEMP]
+                                                             (* ; "TEMP is now definition of EXPR")
+          (LISP:TYPECASE TEMP
+              ((OR COMPILED-CLOSURE CLOSURE)                 (* ; "falls out"))
+              (CONS (SELECTQ (CAR TEMP)
+                        (NLAMBDA (COND
+                                    ((OR (LISTP (SETQ TEMP (CADR TEMP)))
+                                         (NULL TEMP))
+                                     (GO NLSPREAD))
+                                    (T (GO NLNOSPREAD))))
+                        ((LISP:LAMBDA LAMBDA OPENLAMBDA))
+                        (GO FAULT)))
+              (T (GO FAULT)))
+      EVLAM
+          
+
+     (* ;; "THIS FUNCTION'S DEFINITION VERY DEPENDENT ON THE SPECIAL MACRO IN ALAP FOR COMPILING IT.  --- SEE CEVALFORM")
+
+          [RETURN (PROG ((*ARGVAL* 0)
+                         (*TAIL* *FORM*)
+                         (*FN* (CAR *FORM*)))
+                        (DECLARE (SPECVARS *ARGVAL* *FN* *TAIL*))
+                        (RETURN (.EVALFORM.]
+      NLSPREAD
+          (RETURN (SPREADAPPLY (CAR *FORM*)
+                         (CDR *FORM*)))
+      NLNOSPREAD
+          (RETURN (SPREADAPPLY* (CAR *FORM*)
+                         (CDR *FORM*)))
+      FAULT
+          (COND
+             ([AND CLISPARRAY (LISTP (SETQ TEMP (GETHASH *FORM* CLISPARRAY]
+              (SETQ *FORM* TEMP)
+              (GO RETRY)))
+          (RETURN (FAULTEVAL *FORM*])
+
+(\EVALFORMASLAMBDA
+  [LAMBDA (FAULTX)                                           (* lmm "29-Apr-86 13:06")
+    (PROG ((*ARGVAL* 0)
+           (*TAIL* FAULTX)
+           (*FN* (CAR FAULTX)))
+          (DECLARE (SPECVARS *ARGVAL* *FN* *TAIL*))
+          (RETURN (.EVALFORM.])
+
+(\EVALOTHER
+  [LAMBDA (X)                                                (* lmm "10-MAY-80 17:03")
+
+    (* ;; "evaluate some other data type (not atom or list)")
+
+    (PROG NIL
+          (RETURN (SPREADAPPLY* (CDR (OR (FASSOC (TYPENAME X)
+                                                \DEFEVALFNS)
+                                         (RETURN X)))
+                         X])
+
+(APPLY
+  [LAMBDA (U V \INTERNAL)
+    (DECLARE (SPECVARS \INTERNAL))                       (* lmm "15-Aug-84 17:53")
+    (.APPLY. U V])
+
+(APPLY*
+  [LAMBDA U                                                  (* lmm " 5-Jun-86 03:28")
+    (PROG [(DEF (AND (IGREATERP U 0)
+                     (ARG U 1]
+      LP  (COND
+             [(LITATOM DEF)
+              (COND
+                 [(fetch (LITATOM CCODEP) of DEF)
+                  (COND
+                     ((EQ (fetch (LITATOM ARGTYPE) of DEF)
+                          3)
+                      (GO NOSPR))
+                     (T (GO SPR]
+                 (T                                          (* ; "EXPR")
+                    (SETQ DEF (OR (LISTP (fetch (LITATOM DEFPOINTER) of DEF))
+                                  (GO FAULT]
+             ((CCODEP DEF)
+              (GO SPR))
+             ((NLISTP DEF)
+              (GO FAULT)))
+          (SELECTQ (CAR DEF)
+              ([LAMBDA LISP:LAMBDA] 
+                   NIL)
+              (FUNARG                                        (* ; 
+                                          "Ignore environment of funarg?  This is obsolete anyway.")
+                      (SETQ DEF (CADR DEF))
+                      (GO LP))
+              (NLAMBDA (COND
+                          ((AND (CAR (LISTP (CDR DEF)))
+                                (NLISTP (CADR DEF)))
+                           (GO NOSPR))))
+              (OPENLAMBDA)
+              (GO FAULT))
+      SPR [RETURN (SELECTQ U
+                      (1                                     (* ; "no args")
+                         (SPREADAPPLY* (ARG U 1)))
+                      (2                                     (* ; "1 arg")
+                         (SPREADAPPLY* (ARG U 1)
+                                (ARG U 2)))
+                      (3                                     (* ; "2 args")
+                         (SPREADAPPLY* (ARG U 1)
+                                (ARG U 2)
+                                (ARG U 3)))
+                      (4                                     (* ; "3 args")
+                         (SPREADAPPLY* (ARG U 1)
+                                (ARG U 2)
+                                (ARG U 3)
+                                (ARG U 4)))
+                      (SPREADAPPLY (ARG U 1)
+                             (for I from 2 to U collect (ARG U I]
+      FAULT
+          [RETURN (FAULTAPPLY DEF (for I from 2 to U collect (ARG U I]
+      NOSPR
+                                                             (* ; "NLAMBDA*")
+          (RETURN (SPREADAPPLY* (ARG U 1)
+                         (for I from 2 to U collect (ARG U I])
+
+(\CHECKAPPLY*
+  [LAMBDA (FN)                                               (* bvm%: " 7-Jul-86 17:13")
+
+(* ;;; "APPLY* compiles open as: [PUSH each arg, PUSH #args, PUSH FN, CHECKAPPLY*, APPLYFN] CHECKAPPLY* should merely return FN in the case where FN is a LAMBDA or a NLAMBDA spread.  The only case it needs to handle special is NLAMBDA nospread.")
+
+    (PROG ((DEF FN))
+          [COND
+             [(LITATOM DEF)
+              (COND
+                 ((NOT (fetch (LITATOM CCODEP) of DEF))
+                                                             (* ; "EXPR")
+                  (SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF)))
+                 ((EQ (fetch (LITATOM ARGTYPE) of DEF)
+                      3)
+                  (GO NOSPR))
+                 (T (RETURN FN]
+             ((AND NIL (TYPEP DEF 'COMPILED-CLOSURE))
+
+              (* ;; "Give a symbol this definition so APPLYFN can call it.  This is an utter kludge.  It can never work with preemptive scheduling, and even without it is vulnerable to an interrupt between CHECKAPPLY* and APPLYFN")
+
+              (\PUTD '*\CHECKAPPLY*\HACK DEF)
+              (RETURN '*\CHECKAPPLY*\HACK]
+          (COND
+             ((AND (LISTP DEF)
+                   (EQ (CAR DEF)
+                       'NLAMBDA)
+                   (LISTP (SETQ DEF (CDR DEF)))
+                   (CAR DEF)
+                   (NLISTP (CAR DEF)))
+              (GO NOSPR))
+             (T (RETURN FN)))
+      NOSPR
+          (RETURN (LIST 'LAMBDA NIL (LIST 'QUOTE (SPREADAPPLY* FN (\CKAPPLYARGS])
+
+(\CKAPPLYARGS
+  [LAMBDA NIL                                              (* lmm "10-NOV-81 22:26")
+    (PROG ((FRAME (fetch (FX ALINK) of (\MYALINK)))
+           ACNT PTR VAL)
+          [SETQ ACNT (STACKGETBASEPTR (SETQ PTR (IDIFFERENCE (fetch (FX NEXTBLOCK) of FRAME)
+                                                       WORDSPERCELL]
+          (CHECK (SMALLPOSP ACNT))
+          [FRPTQ ACNT (push VAL (STACKGETBASEPTR (SETQ PTR (IDIFFERENCE PTR WORDSPERCELL]
+          (RETURN VAL])
+
+(DEFEVAL
+  [LAMBDA (TYPE FN)                                          (* edited%: "13-DEC-78 23:18")
+    (PROG ((F (FASSOC TYPE \DEFEVALFNS)))
+          [COND
+             (F (SETQ \DEFEVALFNS (DREMOVE F \DEFEVALFNS]
+          [COND
+             (FN (SETQ \DEFEVALFNS (CONS (CONS TYPE FN)
+                                         \DEFEVALFNS]
+          (RETURN (CDR F])
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS .APPLY. MACRO [(U V)                       (* body for APPLY, used by RETAPPLY 
+                                                           too)
+                                 (PROG ((DEF U))
+                                   LP  [COND
+                                          ((LITATOM DEF)
+                                           (COND
+                                              ((NOT (fetch (LITATOM CCODEP) of DEF))
+                                                             (* EXPR)
+                                               (SETQ DEF (fetch (LITATOM DEFPOINTER) of
+                                                                                         DEF)))
+                                              ((EQ (fetch (LITATOM ARGTYPE) of DEF)
+                                                   3)
+                                               (GO NLSTAR))
+                                              (T (GO NORMAL]
+                                       [COND
+                                          ((LISTP DEF)
+                                           (SELECTQ (CAR DEF)
+                                               (NLAMBDA (AND (NLISTP (CADR DEF))
+                                                             (CADR DEF)
+                                                             (GO NLSTAR)))
+                                               (FUNARG (SETQ DEF (CADR DEF))
+                                                       (GO LP))
+                                               NIL))
+                                          ((NULL DEF)
+                                           (RETURN (FAULTAPPLY U V]
+                                   NORMAL
+                                       (RETURN (SPREADAPPLY U V))
+                                   NLSTAR
+                                                             (* NLAMBDA*)
+                                       (RETURN (SPREADAPPLY* U V])
+)
+)
+
+
+
+(* ; "Free variable manipulation")
+
+(DEFINEQ
+
+(EVALV
+  [LAMBDA (VAR POS RELFLG)                                   (* lmm " 6-Apr-84 16:37")
+
+    (* ;; "EVAL of a LITATOM without uba error")
+
+    [COND
+       (POS (\SMASHLINK NIL (\STACKARGPTR POS]
+    (PROG1 (\EVALV1 VAR)
+        (COND
+           (RELFLG (RELSTK POS))))])
+
+(\EVALV1
+  [LAMBDA (VAR)                                              (* lmm "24-DEC-81 00:08")
+    (COND
+       ((OR (NULL (\DTEST VAR 'LITATOM))
+            (EQ VAR T))
+        VAR)
+       (T (\GETBASEPTR (\STKSCAN VAR)
+                 0])
+
+(\EVALVAR
+  [LAMBDA (VAR)                                              (* ; "Edited 30-Jan-87 13:28 by Pavel")
+
+    (* ;; "EVAL of a LITATOM")
+
+    (COND
+       ((OR (NULL VAR)
+            (EQ VAR T))
+        VAR)
+       (T (LET ((VP (\STKSCAN VAR))
+                    VAL)
+                 (COND
+                    ((EQ (SETQ VAL (\GETBASEPTR VP 0))
+                         'NOBIND)                            (* ; 
+"Value is NOBIND, even if it was not found as the top-level value.  This is consistent with BOUNDP.")
+                     (FAULTEVAL VAR))
+                    (T VAL])
+
+(BOUNDP
+  [LISP:LAMBDA (LISP::VAR)                                   (* ; "Edited 30-Jan-87 16:59 by Pavel")
+
+         (* ;; "True if VAR is bound or has top level value")
+
+         (AND (LISP:SYMBOLP LISP::VAR)
+              (NOT (EQ (\GETBASEPTR (\STKSCAN LISP::VAR)
+                              0)
+                       'NOBIND])
+
+(SET
+  [LAMBDA (VAR VALUE)                                        (* lmm "24-FEB-82 16:11")
+    (COND
+       ((NULL VAR)
+        (AND VALUE (LISPERROR "ATTEMPT TO SET NIL OR T" VALUE)))
+       (T (PROG [(VP (\STKSCAN (\DTEST VAR 'LITATOM]
+                (COND
+                   ((EQ (\HILOC VP)
+                        \STACKHI)
+                    (\PUTBASEPTR VP 0 VALUE))
+                   ((EQ VAR T)
+                    (OR (EQ VALUE T)
+                        (LISPERROR "ATTEMPT TO SET NIL OR T" VALUE)))
+                   (T (\RPLPTR VP 0 VALUE)))
+                (RETURN VALUE])
+
+(\SETVAR
+  [LAMBDA (VAR VALUE)                                        (* lmm "24-FEB-82 16:11")
+    (COND
+       ((NULL VAR)
+        (AND VALUE (LISPERROR "ATTEMPT TO SET NIL OR T" VALUE)))
+       (T (PROG [(VP (\STKSCAN (\DTEST VAR 'LITATOM]
+                (COND
+                   ((EQ (\HILOC VP)
+                        \STACKHI)
+                    (\PUTBASEPTR VP 0 VALUE))
+                   ((EQ VAR T)
+                    (OR (EQ VALUE T)
+                        (LISPERROR "ATTEMPT TO SET NIL OR T" VALUE)))
+                   (T (\RPLPTR VP 0 VALUE)))
+                (RETURN VALUE])
+
+(SETQ
+  [NLAMBDA U                                                 (* lmm "24-DEC-81 00:19")
+    (\SETVAR (CAR U)
+           (PROG ((*TAIL* (CDR U)))
+                 (DECLARE (SPECVARS *TAIL*))
+                 (RETURN (PROG1 (\EVAL (CAR *TAIL*))
+                             [PROG NIL                     (* ; 
+                                 "(SETQ X Y + 3) must try to eval + in order to get dwim involved.")
+                               LP  (COND
+                                      ((LISTP (SETQ *TAIL* (CDR *TAIL*)))
+                                       (\EVAL (CAR *TAIL*))
+                                       (GO LP])])
+
+(\STKSCAN
+  [LAMBDA (VAR)                                              (* ; "Edited 27-Jan-91 14:48 by jds")
+
+    (* ;; "Returns pointer to place where VAR is bound")
+
+    (PROG ((FX (fetch (FX ALINK) of (\MYALINK)))
+           (ATOM# (\ATOMVALINDEX VAR))
+           NTSIZE A VARINFO PVAROFFSET NT FVAR)
+      FRAMELP
+          [COND
+             ((fetch (FX INVALIDP) of FX)            (* ; 
+                                                   "Reached top of stack without finding a binding")
+              (RETURN (fetch (VALINDEX VCELL) of ATOM#]
+          (SETQ NT (fetch (FX NAMETABLE) of FX))
+          (SETQ NTSIZE (fetch (FNHEADER NTSIZE) of NT))
+          (SETQ NT (\ADDBASE NT (fetch (FNHEADER OVERHEADWORDS) of T)))
+      TABLELP
+          [COND
+             ((EQP (SETQ A (GETNAMEENTRY NT 0))
+                   0)                                        (* ; "End of name table")
+              (GO ENDTABLE))
+             ((EQP A ATOM#)                                  (* ; 
+                                                     "Found ATOM#.  See if it is really bound here")
+              (SELECTC (NTSLOT-VARTYPE (SETQ VARINFO (GETNTOFFSETENTRY NT NTSIZE)))
+                  (IVARCODE                                  (* ; "Is bound in BF")
+                                                             (* ; "IVAR")
+                            [RETURN (STACKADDBASE (IPLUS (UNFOLD (\LOLOC (NTSLOT-OFFSET VARINFO))
+                                                                WORDSPERCELL)
+                                                         (fetch (BF IVAR)
+                                                            of (fetch (FX BLINK) of
+                                                                                         FX])
+                  (PVARCODE                                  (* ; 
+                                                           "Local may or may not be bound yet")
+                            (SETQ PVAROFFSET (IPLUS (UNFOLD (\LOLOC (NTSLOT-OFFSET VARINFO))
+                                                           WORDSPERCELL)
+                                                    (fetch (FX FIRSTPVAR) of FX)))
+                            [COND
+                               ((fetch (PVARSLOT BOUND) of (STACKADDBASE PVAROFFSET))
+                                                             (* ; "PVAR")
+                                (RETURN (STACKADDBASE PVAROFFSET])
+                  (FVARCODE                                  (* ; 
+                                                           "If FVAR is looked up, we can use it.")
+                            [SETQ FVAR (ADDSTACKBASE (IPLUS (UNFOLD (\LOLOC (NTSLOT-OFFSET VARINFO))
+                                                                   WORDSPERCELL)
+                                                            (fetch (FX FIRSTPVAR) of FX]
+                            (COND
+                               ((fetch (FVARSLOT LOOKEDUP) of FVAR)
+                                (SETQ FVAR (fetch (FVARSLOT BINDINGPTR) of FVAR))
+                                (RETURN FVAR))
+                               (T (GO ENDTABLE))))
+                  (SHOULDNT]
+          [SETQ NT (\ADDBASE NT (CONSTANT (WORDSPERNAMEENTRY]
+          (GO TABLELP)
+      ENDTABLE
+          (SETQ FX (fetch (FX ALINK) of FX))
+          (GO FRAMELP])
+
+(\SETFVARSLOT
+  [LAMBDA (VAR NEWBINDING)                                   (* ; "Edited 20-Feb-91 01:07 by jds")
+
+    (* ;; "Sets the freevar binding slot of VAR in caller's frame to point at NEWBINDING")
+
+    (PROG ((FX (\MYALINK))
+           (ATOM# (NEW-SYMBOL-CODE VAR (\ATOMVALINDEX VAR)))
+           NTSIZE A VARINFO NT)
+          (SETQ NT (fetch (FX NAMETABLE) of FX))
+          (SETQ NTSIZE (fetch (FNHEADER NTSIZE) of NT))
+          (SETQ NT (\ADDBASE NT (fetch (FNHEADER OVERHEADWORDS) of T)))
+      TABLELP
+          (COND
+             ((NULL-NTENTRY (SETQ A (GETSTKNAMEENTRY NT 0))) (* ; "End of name table")
+              (ERROR "Binding slot not found in caller's frame" VAR))
+             ((AND (EQP A ATOM#)
+                   (EQP (NTSLOT-VARTYPE (SETQ VARINFO (GETSTKNTOFFSETENTRY NT NTSIZE)))
+                        FVARCODE))
+              (replace (FVARSLOT BINDINGPTR) of (ADDSTACKBASE
+                                                         (IPLUS (UNFOLD (\LOLOC (NTSLOT-OFFSET 
+                                                                                       VARINFO))
+                                                                       WORDSPERCELL)
+                                                                (fetch (FX FIRSTPVAR)
+                                                                   of FX))) with NEWBINDING)
+              (RETURN NEWBINDING)))
+          [SETQ NT (\ADDBASE NT (CONSTANT (WORDSPERNAMEENTRY]
+          (GO TABLELP])
+)
+
+
+
+(* ; "PROG and friends")
+
+(DEFINEQ
+
+(PROG
+  [NLAMBDA U                                                 (* ; "Edited 21-Jan-91 18:33 by jds")
+
+    (* ;; "PROG unpacks the argument list and changes any EVAL type forms by evaluating the form and then smashing the name and value")
+
+    (* ;; "NOTE --- this mechanism might confuse DWIM someday because the arguments inside the PROG are evaluated at a time when the PROG frame is in a very funny state: the 'values' are the variables, and the variables are NIL")
+
+    (PROG ((NVARS 0)
+           (VARLST (CAR U))
+           NTSIZE NNILS)
+          (for VAR in VARLST do                  (* ; 
+                                                     "Count number of vars to bind, check validity")
+                                           (COND
+                                              ((OR (NULL (\DTEST (COND
+                                                                    ((LISTP VAR)
+                                                                     (SETQ VAR (CAR VAR)))
+                                                                    (T VAR))
+                                                                'LITATOM))
+                                                   (EQ VAR T))
+                                               (LISPERROR "ATTEMPT TO BIND NIL OR T" VAR)))
+                                           (add NVARS 1))
+          (RETURN (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS
+                                                             (SETQ NTSIZE
+                                                              (CEIL [ADD1 (UNFOLD NVARS (CONSTANT
+                                                                                         (
+                                                                                    WORDSPERNAMEENTRY
+                                                                                          ]
+                                                                    WORDSPERQUAD))
+                                                             (FOLDHI (fetch (FNHEADER 
+                                                                                       OVERHEADWORDS)
+                                                                        of T)
+                                                                    WORDSPERCELL)
+                                                             (SUB1 CELLSPERQUAD)))
+                         (\PROG0 U U NNILS NVARS NTSIZE VARLST])
+
+(\PROG0
+  [LAMBDA (*FIRSTTAIL* *TAIL* NNILS NVARS NTSIZE VARLST)     (* ; "Edited 27-Jan-91 14:32 by jds")
+    (DECLARE (SPECVARS *TAIL* *FIRSTTAIL*))
+    (PROG NIL
+          [COND
+             (VARLST 
+
+                    (* ;; "Create a nametable inside progframe where PROG pushed all those nils")
+
+                    (PROG ((PROGFRAME (\MYALINK))
+                           HEADER NT NILSTART)
+                          (SETQ HEADER (fetch (FX FNHEADER) of PROGFRAME))
+                          (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART
+                                                               (IDIFFERENCE (fetch (FX NEXTBLOCK)
+                                                                               of PROGFRAME)
+                                                                      (UNFOLD NNILS WORDSPERCELL)))
+                                                              (UNFOLD NVARS WORDSPERCELL))
+                                                       WORDSPERQUAD)))
+
+                     (* ;; "NT is address of our synthesized nametable: beginning of NIL's, not counting additional PVARs we are about to bind, rounded up to quadword")
+
+                          [for VAR in VARLST as VALUEOFF from NILSTART by 
+                                                                                         WORDSPERCELL
+                             do                          (* ; "evaluate initial values first")
+                                   (COND
+                                      ((LISTP VAR)
+                                       (PUTBASEPTR \STACKSPACE VALUEOFF (\EVPROG1 (CDR VAR]
+                                                             (* ; "then build NT")
+                          (UNINTERRUPTABLY
+                              (for VAR in VARLST as VAR#
+                                 from (FOLDLO (IDIFFERENCE NILSTART (fetch (FX FIRSTPVAR)
+                                                                           of PROGFRAME))
+                                                 WORDSPERCELL) as NT1
+                                 from (fetch (FNHEADER OVERHEADWORDS) of T)
+                                 by (WORDSPERNAMEENTRY) as NT2
+                                 from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
+                                                 NTSIZE) by (CONSTANT (WORDSPERNTOFFSETENTRY))
+                                 do [SETSTKNAME-RAW NT NT1 (\ATOMVALINDEX (COND
+                                                                                 ((LISTP VAR)
+                                                                                  (CAR VAR))
+                                                                                 (T VAR]
+                                       (SETSTKNTOFFSET-RAW NT NT2 PVARCODE VAR#))
+                              (replace (FNHEADER %#FRAMENAME) of NT with 'PROG)
+                              (replace (FNHEADER NTSIZE) of NT with NTSIZE)
+                                                             (* ; 
+                           "Do I need to worry about STK, NA, PV, START, ARGTYPE NLOCALS ?  --- no")
+                              (replace (FX NAMETABLE) of PROGFRAME with NT))]
+      EVLP
+          (COND
+             ((NULL (SETQ *TAIL* (CDR *TAIL*)))
+              (RETURN NIL))
+             (T (\EVAL (OR (LISTP (CAR *TAIL*))
+                               (GO EVLP)))
+                (GO EVLP])
+
+(\EVPROG1
+  [LAMBDA (*TAIL*)                                           (* lmm "14-MAY-80 13:00")
+    (DECLARE (SPECVARS *TAIL*))
+    (PROG1 (\EVAL (CAR *TAIL*))
+        [PROG NIL
+          LP  (COND
+                 ((LISTP (SETQ *TAIL* (CDR *TAIL*)))
+                  (\EVAL (CAR *TAIL*))
+                  (GO LP])])
+
+(RETURN
+  [NLAMBDA (FORM)
+    (DECLARE (LOCALVARS . T))                            (* bvm%: "10-Nov-86 18:22")
+    (PROG ((MV (LISP:MULTIPLE-VALUE-LIST (\EVAL FORM)))
+           (FRAME (\MYALINK)))
+      LP  (COND
+             ((EQ (fetch (FNHEADER FRAMENAME) of (fetch (FX NAMETABLE) of FRAME))
+                  (FUNCTION \PROG0))
+              (SETQ FRAME (fetch (FX CLINK) of FRAME))
+                                                             (* ; "Its caller, i.e. PROG")
+              (\SMASHRETURN NIL FRAME)                     (* ; 
+                                                           "Make us return to PROG with this value")
+              (RETURN (LISP:VALUES-LIST MV)))
+             ([NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK) of FRAME]
+              (GO LP))
+             (T (LISPERROR "ILLEGAL RETURN"])
+
+(GO
+  [NLAMBDA U                                                 (* bvm%: "10-Nov-86 18:17")
+    (PROG ((FRAME (\MYALINK))
+           (LABEL (CAR U))
+           GOTAIL FIRSTARG)
+      LP  [COND
+             ((EQ (fetch (FNHEADER FRAMENAME) of (fetch (FX NAMETABLE) of FRAME))
+                  (FUNCTION \PROG0))
+              (COND
+                 ([SETQ GOTAIL (FMEMB LABEL (CDR (STACKGETBASEPTR (SETQ FIRSTARG
+                                                                   (fetch (BF IVAR)
+                                                                      of (fetch (FX BLINK)
+                                                                                of FRAME]
+
+                  (* ;; "first argument of \PROG0 is the actual tail of the prog, which can contain the labels.  Second argument is the 'current' *TAIL*")
+
+                  (STACKPUTBASEPTR (IPLUS FIRSTARG WORDSPERCELL)
+                         GOTAIL)                             (* ; 
+                                                           "Reset *TAIL* in the \PROG0 frame")
+                  (\SMASHRETURN NIL FRAME)                 (* ; 
+                                 "Fix it so we return to \PROG0 to continue evaluating after label")
+                  (RETURN NIL]
+          (COND
+             ([NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK) of FRAME]
+              (GO LP))
+             (T (LISPERROR "UNDEFINED OR ILLEGAL GO" LABEL])
+
+(EVALA
+  [LAMBDA (X A)                                              (* ; "Edited 21-Jan-91 18:13 by jds")
+
+(* ;;; "Evaluate X after spreading alist A on stack")
+
+    (PROG ((NVARS 0)
+           NTSIZE NNILS TMP)
+          (for VAR in A do                       (* ; 
+                                                     "Count number of vars to bind, check validity")
+                                      (COND
+                                         ((OR [NULL (SETQ TMP (\DTEST (CAR (\DTEST VAR 'LISTP))
+                                                                     'LITATOM]
+                                              (EQ TMP T))
+                                          (LISPERROR "ATTEMPT TO BIND NIL OR T" TMP)))
+                                      (add NVARS 1))
+          (RETURN (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS
+                                                             (SETQ NTSIZE
+                                                              (CEIL [ADD1 (UNFOLD NVARS (CONSTANT
+                                                                                         (
+                                                                                    WORDSPERNAMEENTRY
+                                                                                          ]
+                                                                    WORDSPERQUAD))
+                                                             (FOLDHI (fetch (FNHEADER 
+                                                                                       OVERHEADWORDS)
+                                                                        of T)
+                                                                    WORDSPERCELL)
+                                                             (SUB1 CELLSPERQUAD)))
+                         (\EVALA NNILS NVARS NTSIZE X A])
+
+(\EVALA
+  [LAMBDA (NNILS NVARS NTSIZE FORM ALIST)                    (* ; "Edited 27-Jan-91 16:39 by jds")
+    (PROG ((CALLER (\MYALINK))
+           NILSTART NT HEADER)
+
+     (* ;; "Create a nametable inside CALLER where EVALA pushed all those nils")
+
+          (SETQ HEADER (fetch (FX FNHEADER) of CALLER))
+                                                             (* ; 
+                                                           "The function header of code for EVALA")
+          (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch (FX NEXTBLOCK)
+                                                                             of CALLER)
+                                                                    (UNFOLD NNILS WORDSPERCELL)))
+                                              (UNFOLD NVARS WORDSPERCELL))
+                                       WORDSPERQUAD)))
+
+     (* ;; "Address of our synthesized nametable: beginning of NIL's, not counting additional PVARs we are about to bind, rounded up to quadword")
+
+          (UNINTERRUPTABLY
+              (for PAIR in ALIST as VAR# from (FOLDLO (IDIFFERENCE
+                                                                       NILSTART
+                                                                       (fetch (FX FIRSTPVAR)
+                                                                          of CALLER))
+                                                                     WORDSPERCELL) as NT1
+                 from (fetch (FNHEADER OVERHEADWORDS) of T) by (WORDSPERNAMEENTRY)
+                 as NT2 from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
+                                            NTSIZE) by (CONSTANT (WORDSPERNTOFFSETENTRY))
+                 as VALUEOFF from NILSTART by WORDSPERCELL
+                 do (PUTBASEPTR \STACKSPACE VALUEOFF (CDR PAIR))
+                       (SETSTKNAME-RAW NT NT1 (\ATOMVALINDEX (CAR PAIR)))
+                       (SETSTKNTOFFSET-RAW NT NT2 PVARCODE VAR#))
+
+              (* ;; "now fix up header of NT")
+
+              (replace (FNHEADER %#FRAMENAME) of NT with 'EVALA)
+              (replace (FNHEADER NTSIZE) of NT with NTSIZE)
+                                                             (* ; 
+                         "Do I need to worry about STK, NA, PV, START, ARGTYPE ?  --- probably not")
+              (replace (FX NAMETABLE) of CALLER with NT))
+          (RETURN (\EVAL FORM])
+
+(ERRORSET
+  [LAMBDA (FORM FLAG)                                        (* ; "Edited  6-Mar-87 14:39 by amd")
+
+    (* ;; "(proceed-case (handler-bind ...)), but open-coded to aviod a proceed-case literal")
+
+    (LET (SI::NLSETQ-VALUE)
+           (LISP:IF (EQ (LET [(*PROCEED-CASES* (CONS SI::NLSETQ-PROCEED-CASE *PROCEED-CASES*))
+                                  (SI::*NLSETQFLAG* (NEQ FLAG T))
+                                  (*CONDITION-HANDLER-BINDINGS* (LISP:IF FLAG
+                                                                    *CONDITION-HANDLER-BINDINGS*
+                                                                    (CONS '(LISP:ERROR
+                                                                                 . SI::NLSETQHANDLER)
+                                                                          
+                                                                         *CONDITION-HANDLER-BINDINGS*
+                                                                          ))]
+                               (DECLARE (SPECVARS SI::*NLSETQFLAG*))
+                               (LISP:CATCH *PROCEED-CASES*
+                                   (LISP:SETQ SI::NLSETQ-VALUE (LIST (\EVAL FORM)))
+                                   :NORMAL))
+                        :NORMAL)
+               SI::NLSETQ-VALUE
+               NIL)])
+
+(SI::ERRORSET-PRINT-FUNCTION
+  [LAMBDA (DATUM STREAM)
+    (DECLARE (IGNORE DATUM))                             (* bvm%: "11-Nov-86 21:40")
+    (PRIN1 "Unwind to ERRORSET" STREAM])
+)
+
+
+
+(* ; "LET and friends -- need these in the init")
+
+(DEFINEQ
+
+(LET
+  [NLAMBDA U
+    (DECLARE (LOCALVARS . T))                            (* ; "Edited 21-Jan-91 18:14 by jds")
+
+    (* ;; "LET unpacks the argument list and changes any EVAL type forms by evaluating the form and then smashing the name and value")
+
+    (LET ((NVARS 0)
+              (VARLST (CAR U))
+              NTSIZE NNILS)
+           (for VAR in VARLST do                 (* ; 
+                                                     "Count number of vars to bind, check validity")
+                                            (COND
+                                               ((OR (NULL (\DTEST (COND
+                                                                     ((LISTP VAR)
+                                                                      (SETQ VAR (CAR VAR)))
+                                                                     (T VAR))
+                                                                 'LITATOM))
+                                                    (EQ VAR T))
+                                                (LISPERROR "ATTEMPT TO BIND NIL OR T" VAR)))
+                                            (add NVARS 1))
+           (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE
+                                                             (CEIL [ADD1 (UNFOLD NVARS (CONSTANT
+                                                                                        (
+                                                                                    WORDSPERNAMEENTRY
+                                                                                         ]
+                                                                   WORDSPERQUAD))
+                                                      (FOLDHI (fetch (FNHEADER OVERHEADWORDS)
+                                                                 of T)
+                                                             WORDSPERCELL)
+                                                      (SUB1 CELLSPERQUAD)))
+                  (\LET0 (CDR U)
+                         NNILS NVARS NTSIZE VARLST])
+
+(LET*
+  [NLAMBDA U
+    (DECLARE (LOCALVARS . T))                            (* ; "Edited 21-Jan-91 23:02 by jds")
+
+    (* ;; "LET* unpacks the argument list and changes any EVAL type forms by evaluating the form and then smashing the name and value")
+
+    (LET* ((NVARS 0)
+               (VARLST (CAR U))
+               NTSIZE NNILS)
+           (for VAR in VARLST do                 (* ; 
+                                                     "Count number of vars to bind, check validity")
+                                            (COND
+                                               ((OR (NULL (\DTEST (COND
+                                                                     ((LISTP VAR)
+                                                                      (SETQ VAR (CAR VAR)))
+                                                                     (T VAR))
+                                                                 'LITATOM))
+                                                    (EQ VAR T))
+                                                (LISPERROR "ATTEMPT TO BIND NIL OR T" VAR)))
+                                            (add NVARS 1))
+           (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE
+                                                             (CEIL [ADD1 (UNFOLD NVARS (CONSTANT
+                                                                                        (
+                                                                                    WORDSPERNAMEENTRY
+                                                                                         ]
+                                                                   WORDSPERQUAD))
+                                                      (FOLDHI (fetch (FNHEADER OVERHEADWORDS)
+                                                                 of T)
+                                                             WORDSPERCELL)
+                                                      (SUB1 CELLSPERQUAD)))
+                  (\LET* (CDR U)
+                         NNILS NVARS NTSIZE VARLST])
+
+(\LET0
+  [LAMBDA (*TAIL* NNILS NVARS NTSIZE VARLST)
+    (DECLARE (LOCALVARS . T)
+           (SPECVARS *TAIL*))                                (* ; "Edited 27-Jan-91 14:35 by jds")
+    (PROG NIL
+          [COND
+             (VARLST (PROG ((PROGFRAME (\MYALINK))
+                            HEADER NT NILSTART)
+                           (SETQ HEADER (fetch (FX FNHEADER) of PROGFRAME))
+                           (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART
+                                                                (IDIFFERENCE (fetch (FX NEXTBLOCK
+                                                                                            )
+                                                                                of PROGFRAME)
+                                                                       (UNFOLD NNILS WORDSPERCELL)))
+                                                               (UNFOLD NVARS WORDSPERCELL))
+                                                        WORDSPERQUAD)))
+
+                      (* ;; "NT is address of our synthesized nametable: beginning of NIL's, not counting additional PVARs we are about to bind, rounded up to quadword")
+
+                           [for VAR in VARLST as VALUEOFF from NILSTART by 
+                                                                                         WORDSPERCELL
+                              do                         (* ; "evaluate initial values first")
+                                    (COND
+                                       ((LISTP VAR)
+                                        (PUTBASEPTR \STACKSPACE VALUEOFF (\EVPROG1 (CDR VAR]
+                                                             (* ; "then build NT")
+                           (UNINTERRUPTABLY
+                               (for VAR in VARLST as VAR#
+                                  from (FOLDLO (IDIFFERENCE NILSTART (fetch (FX FIRSTPVAR)
+                                                                            of PROGFRAME))
+                                                  WORDSPERCELL) as NT1
+                                  from (fetch (FNHEADER OVERHEADWORDS) of T)
+                                  by (CONSTANT (WORDSPERNAMEENTRY)) as NT2
+                                  from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
+                                                  NTSIZE) by (CONSTANT (WORDSPERNTOFFSETENTRY))
+                                  do [SETSTKNAME-RAW NT NT1 (\ATOMVALINDEX (COND
+                                                                                  ((LISTP VAR)
+                                                                                   (CAR VAR))
+                                                                                  (T VAR]
+                                        (SETSTKNTOFFSET-RAW NT NT2 PVARCODE VAR#))
+                               (replace (FNHEADER %#FRAMENAME) of NT with 'LET)
+                               (replace (FNHEADER NTSIZE) of NT with NTSIZE)
+                                                             (* ; 
+                           "Do I need to worry about STK, NA, PV, START, ARGTYPE NLOCALS ?  --- no")
+                               (replace (FX NAMETABLE) of PROGFRAME with NT))]
+      EVLP
+          (COND
+             [(NULL (CDR *TAIL*))
+              (RETURN (\EVAL (CAR *TAIL*]
+             (T (\EVAL (CAR *TAIL*))
+                (SETQ *TAIL* (CDR *TAIL*))
+                (GO EVLP])
+
+(\LET*
+  [LAMBDA (*TAIL* NNILS NVARS NTSIZE VARLST)
+    (DECLARE (LOCALVARS . T)
+           (SPECVARS *TAIL*))                                (* ; "Edited 27-Jan-91 14:37 by jds")
+    (PROG NIL
+          [COND
+             (VARLST (PROG ((PROGFRAME (\MYALINK))
+                            HEADER NT NILSTART)
+                           (SETQ HEADER (fetch (FX FNHEADER) of PROGFRAME))
+                           (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART
+                                                                (IDIFFERENCE (fetch (FX NEXTBLOCK
+                                                                                            )
+                                                                                of PROGFRAME)
+                                                                       (UNFOLD NNILS WORDSPERCELL)))
+                                                               (UNFOLD NVARS WORDSPERCELL))
+                                                        WORDSPERQUAD)))
+
+                      (* ;; "NT is address of our synthesized nametable: beginning of NIL's, not counting additional PVARs we are about to bind, rounded up to quadword")
+
+                      (* ;; "First build the nametable.  This differs from LET in that the nametable is built in reverse order and the PVARs are marked unbound before we start evaluating the forms.  This way, we get the right semantics of nested LET's.")
+
+                           (UNINTERRUPTABLY
+                               (FOR VAR IN VARLST AS VAR#
+                                  FROM (FOLDLO (IDIFFERENCE NILSTART (FETCH (FX FIRSTPVAR)
+                                                                            OF PROGFRAME))
+                                                  WORDSPERCELL) AS VALUEOFF FROM NILSTART
+                                  BY WORDSPERCELL AS NT1
+                                  FROM (IPLUS (UNFOLD (SUB1 NVARS)
+                                                         (CONSTANT (WORDSPERNAMEENTRY)))
+                                                  (FETCH (FNHEADER OVERHEADWORDS) OF T))
+                                  BY (IMINUS (CONSTANT (WORDSPERNAMEENTRY))) AS NT2
+                                  FROM (IPLUS (UNFOLD (SUB1 NVARS)
+                                                         (CONSTANT (WORDSPERNAMEENTRY)))
+                                                  (FETCH (FNHEADER OVERHEADWORDS) OF T)
+                                                  NTSIZE) BY (IMINUS (CONSTANT (
+                                                                                WORDSPERNTOFFSETENTRY
+                                                                                    )))
+                                  DO [SETSTKNAME-RAW NT NT1 (\ATOMVALINDEX (COND
+                                                                                  ((LISTP VAR)
+                                                                                   (CAR VAR))
+                                                                                  (T VAR]
+                                        (SETSTKNTOFFSET-RAW NT NT2 PVARCODE VAR#)
+                                        (PUTBASE \STACKSPACE VALUEOFF 65535))
+                               (replace (FNHEADER %#FRAMENAME) of NT with 'LET*)
+                               (REPLACE (FNHEADER NTSIZE) OF NT WITH NTSIZE)
+                                                             (* ; 
+                           "Do I need to worry about STK, NA, PV, START, ARGTYPE NLOCALS ?  --- no")
+                               (REPLACE (FX NAMETABLE) OF PROGFRAME WITH NT))
+                           (FOR VAR IN VARLST AS VALUEOFF FROM NILSTART BY 
+                                                                                         WORDSPERCELL
+                              DO                         (* ; "evaluate initial values first")
+                                    (PUTBASEPTR \STACKSPACE VALUEOFF (IF (LISTP VAR)
+                                                                         THEN (\EVPROG1
+                                                                                   (CDR VAR))
+                                                                       ELSE NIL]
+      EVLP
+          (COND
+             [(NULL (CDR *TAIL*))
+              (RETURN (\EVAL (CAR *TAIL*]
+             (T (\EVAL (CAR *TAIL*))
+                (SETQ *TAIL* (CDR *TAIL*))
+                (GO EVLP])
+)
+(DEFINEQ
+
+(QUOTE
+  [NLAMBDA U
+    (CAR U])
+
+(AND
+  [NLAMBDA U
+    (DECLARE (SPECVARS *TAIL*))
+    (OR (NLISTP U)
+        (PROG ((*TAIL* U))
+          LP  (RETURN (COND
+                         ((NLISTP (CDR *TAIL*))
+                          (\EVAL (CAR *TAIL*)))
+                         ((\EVAL (CAR *TAIL*))
+                          (SETQ *TAIL* (CDR *TAIL*))
+                          (GO LP])
+
+(OR
+  [NLAMBDA U
+    (DECLARE (SPECVARS *TAIL*))                          (* lmm " 9-May-86 13:45")
+    (AND (LISTP U)
+         (PROG ((*TAIL* U))
+           LP  (RETURN (COND
+                          ((NLISTP (CDR *TAIL*))
+                           (\EVAL (CAR *TAIL*)))
+                          (T (OR (\EVAL (CAR *TAIL*))
+                                 (PROGN (SETQ *TAIL* (CDR *TAIL*))
+                                        (GO LP])
+
+(PROGN
+  [NLAMBDA U                                                 (* ; 
+                                       "MUST be a NLAMBDA* with internal call to EVAL for dwimsake")
+    (DECLARE (SPECVARS *TAIL*))
+    (AND (LISTP U)
+         (PROG ((*TAIL* U))
+           LP  (COND
+                  [(NLISTP (CDR *TAIL*))
+                   (RETURN (\EVAL (CAR *TAIL*]
+                  (T (\EVAL (CAR *TAIL*))
+                     (SETQ *TAIL* (CDR *TAIL*))
+                     (GO LP])
+
+(COND
+  [NLAMBDA U
+    (DECLARE (SPECVARS *TAIL*))                          (* lmm "25-APR-80 18:03")
+    (PROG ((*TAIL* U)
+           VAL)
+      LP  (RETURN (COND
+                     ((NLISTP *TAIL*)
+                      (COND
+                         (*TAIL* (LISPERROR "UNUSUAL CDR ARG LIST" *TAIL*))
+                         (T NIL)))
+                     ((SETQ VAL (\EVAL (CAAR *TAIL*)))
+                      (COND
+                         ((CDAR *TAIL*)
+                          (\EVPROGN (CDAR *TAIL*)))
+                         (T VAL)))
+                     (T (SETQ *TAIL* (CDR *TAIL*))
+                        (GO LP])
+
+(\EVPROGN
+  [LAMBDA (*TAIL*)                                           (* lmm "18-Feb-86 01:44")
+    (DECLARE (SPECVARS *TAIL*))
+    (PROG NIL
+      LP  (COND
+             ((CDR *TAIL*)
+              (\EVAL (CAR *TAIL*))
+              (SETQ *TAIL* (CDR *TAIL*))
+              (GO LP))
+             (T (RETURN (\EVAL (CAR *TAIL*])
+
+(PROG1
+  [NLAMBDA U
+    (DECLARE (SPECVARS *TAIL*))                          (* lmm "14-MAY-80 12:59")
+    (AND (LISTP U)
+         (PROG ((*TAIL* U))
+               (RETURN (PROG1 (\EVAL (CAR *TAIL*))
+                           [PROG NIL
+                             LP  (COND
+                                    ((LISTP (SETQ *TAIL* (CDR *TAIL*)))
+                                     (\EVAL (CAR *TAIL*))
+                                     (GO LP])])
+)
+
+(RPAQQ \DEFEVALFNS NIL)
+
+(RPAQQ \EVALHOOK NIL)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(SPECVARS *EVALHOOK*)
+)
+
+(ADDTOVAR LAMBDASPLST LAMBDA NLAMBDA LISP:LAMBDA OPENLAMBDA)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \DEFEVALFNS \EVALHOOK LAMBDASPLST CLISPARRAY)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(RPAQQ CLISPARRAY NIL)
+
+
+(MOVD? 'SETQ 'SETN NIL T)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS CLISPARRAY)
+)
+
+
+
+(* ; "Evaluating in different stack environment")
+
+(DEFINEQ
+
+(ENVEVAL
+  [LAMBDA (FORM APOS CPOS AFLG CFLG)                         (* bvm%: "18-AUG-81 23:29")
+    (\CALLME '*ENV*)
+    (\SMASHLINK NIL (AND APOS (\STACKARGPTR APOS))
+           (AND CPOS (\STACKARGPTR CPOS)))
+    (COND
+       (AFLG (RELSTK APOS)))
+    (COND
+       (CFLG (RELSTK CPOS)))
+    (\EVAL FORM])
+
+(ENVAPPLY
+  [LAMBDA (FN ARGS APOS CPOS AFLG CFLG)                      (* lmm "15-Aug-84 17:53")
+    (\CALLME '*ENV*)
+    (\SMASHLINK NIL (AND APOS (\STACKARGPTR APOS))
+           (AND CPOS (\STACKARGPTR CPOS)))
+    (COND
+       (AFLG (RELSTK APOS)))
+    (COND
+       (CFLG (RELSTK CPOS)))
+    (.APPLY. FN ARGS])
+
+(FUNCTION
+  [NLAMBDA (FN ENV)                                          (* bvm%: "11-Nov-86 21:23")
+    (COND
+       (ENV (if NIL
+                then (LIST 'FUNARG FN (STKNTH -1 'FUNCTION))
+              else (ERROR "FUNARGs no longer supported--use Common Lisp lexical closures" FN)))
+       (T FN])
+
+(\FUNCT1
+  [LAMBDA (NNILS NVARS NTSIZE VARLST)                        (* ; "Edited 27-Jan-91 14:39 by jds")
+    (PROG ((FUNCTFRAME (\MYALINK))
+           HEADER NT NILSTART)
+          (SETQ HEADER (fetch (FX FNHEADER) of FUNCTFRAME))
+          (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch (FX NEXTBLOCK)
+                                                                             of FUNCTFRAME)
+                                                                    (UNFOLD NNILS WORDSPERCELL)))
+                                              (UNFOLD NVARS WORDSPERCELL))
+                                       WORDSPERQUAD)))
+
+     (* ;; "NT is address of our synthesized nametable: beginning of NIL's, not counting additional PVARs we are about to bind, rounded up to quadword")
+
+          (for VAR in VARLST as VALUEOFF from NILSTART by WORDSPERCELL
+             do (\PUTBASEPTR (ADDSTACKBASE VALUEOFF)
+                           0
+                           (\EVAL VAR)))                 (* ; "then build NT")
+          (UNINTERRUPTABLY
+              (for VAR in VARLST as VAR# from (FOLDLO (IDIFFERENCE
+                                                                       NILSTART
+                                                                       (fetch (FX FIRSTPVAR)
+                                                                          of FUNCTFRAME))
+                                                                     WORDSPERCELL) as NT1
+                 from (fetch (FNHEADER OVERHEADWORDS) of T) by (CONSTANT (
+                                                                                    WORDSPERNAMEENTRY
+                                                                                          ))
+                 as NT2 from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
+                                            NTSIZE) by (CONSTANT (WORDSPERNTOFFSETENTRY))
+                 do (SETSTKNAME-RAW NT NT1 (\ATOMVALINDEX VAR))
+                       (SETSTKNTOFFSET-RAW NT NT2 PVARCODE VAR#))
+              (replace (FNHEADER %#FRAMENAME) of NT with '*FUNARG*)
+              (replace (FNHEADER NTSIZE) of NT with NTSIZE)
+              (replace (FX NAMETABLE) of FUNCTFRAME with NT))
+          (RETURN (\MAKESTACKP NIL FUNCTFRAME])
+
+(\MAKEFUNARGFRAME
+  [LAMBDA (ENV)                                              (* ; "Edited 21-Jan-91 18:19 by jds")
+    (\CALLME 'FUNARG)
+    (PROG ((NVARS 0)
+           NTSIZE NNILS)
+          (for VAR in ENV do                     (* ; 
+                                                     "Count number of vars to bind, check validity")
+                                        (COND
+                                           ((OR (NULL (\DTEST VAR 'LITATOM))
+                                                (EQ VAR T))
+                                            (LISPERROR "ATTEMPT TO BIND NIL OR T" VAR)))
+                                        (add NVARS 1))
+          (SETQ ENV (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS
+                                                               (SETQ NTSIZE
+                                                                (CEIL [ADD1 (UNFOLD NVARS
+                                                                                   (CONSTANT (
+                                                                                    WORDSPERNAMEENTRY
+                                                                                              ]
+                                                                      WORDSPERQUAD))
+                                                               (FOLDHI (fetch (FNHEADER 
+                                                                                        OVERHEADWORDS
+                                                                                         )
+                                                                          of T)
+                                                                      WORDSPERCELL)
+                                                               (SUB1 CELLSPERQUAD)))
+                           (\FUNCT1 NNILS NVARS NTSIZE ENV)))
+                                                             (* ; 
+                                                           "ENV POINTS TO COPY OF FUNCTION FRAME")
+          (\SMASHLINK (fetch (STACKP EDFXP) of ENV)
+                 0 0)
+          (RETURN ENV])
+
+(STKEVAL
+  [LAMBDA (POS FORM FLG INTERNALFLG)                         (* lmm "25-APR-80 00:08")
+    (\SMASHLINK NIL (\STACKARGPTR POS))
+    (AND FLG (RELSTK POS))
+    (\EVAL FORM])
+
+(STKAPPLY
+  [LAMBDA (POS FN ARGS FLG)                                  (* lmm "15-Aug-84 17:55")
+    (\CALLME '*ENV*)
+    (\SMASHLINK NIL (\STACKARGPTR POS))
+    (AND FLG (RELSTK POS))
+    (.APPLY. FN ARGS])
+
+(RETEVAL
+  [LAMBDA (POS FORM FLG INTERNALFLG)                         (* bvm%: "11-Nov-86 20:53")
+
+    (* ;; "Return from POS with the value of evaluating FORM in the dynamic context of POS")
+
+    (* ;; "Anyone know what INTERNALFLG is for?")
+
+    (\CALLME '*ENV*)
+    (LET ((FX (\STACKARGPTR POS))
+              RETURNEE)
+           (if (fetch (FX INVALIDP) of (SETQ RETURNEE (fetch (FX CLINK) of FX)))
+               then (LISPERROR "ILLEGAL STACK ARG" POS))
+           (\SMASHRETURN NIL FX)                           (* ; 
+                               "unwind stack back to POS--we need to keep that dynamic environment")
+           (AND FLG (RELSTK POS))
+           (LISP:MULTIPLE-VALUE-PROG1 (\EVAL FORM)       (* ; "finally, return from POS")
+                  (SI::UNWIND RETURNEE])
+
+(RETAPPLY
+  [LAMBDA (POS FN ARGS FLG)                                  (* bvm%: "11-Nov-86 12:04")
+
+    (* ;; "Return from POS with the value of applying FN to ARGS in the dynamic context of POS")
+
+    (\CALLME '*ENV*)
+    (LET ((FX (\STACKARGPTR POS))
+              RETURNEE)
+           (if (fetch (FX INVALIDP) of (SETQ RETURNEE (fetch (FX CLINK) of FX)))
+               then (LISPERROR "ILLEGAL STACK ARG" POS))
+           (\SMASHRETURN NIL FX)                           (* ; 
+                               "unwind stack back to POS--we need to keep that dynamic environment")
+           (AND FLG (RELSTK POS))
+           (LISP:MULTIPLE-VALUE-PROG1 (.APPLY. FN ARGS)      (* ; "finally, return from POS")
+                  (SI::UNWIND RETURNEE])
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(MOVD? 'FUNCTION 'LISP:FUNCTION NIL T)
+)
+
+
+
+(* ; "Blip and other stack funniness")
+
+(DEFINEQ
+
+(BLIPVAL
+  [LAMBDA (BLIPTYP IPOS FLG)                                 (* ; "Edited 18-Feb-91 16:48 by jds")
+    (PROG ([FRAME (COND
+                     ((NULL IPOS)
+                      (\MYALINK))
+                     (T (\STACKARGPTR IPOS]
+           (A (NEW-SYMBOL-CODE BLIPTYP (\ATOMVALINDEX BLIPTYP)))
+           I)
+          (SELECTQ BLIPTYP
+              ((*TAIL* *FORM* *FN* *ARGVAL*))
+              (RETURN (AND (EQ FLG T)
+                           0)))
+          (RETURN
+           (COND
+              ((EQ FLG T)                                    (* ; 
+                                                   "Count number of blips of type BLIPTYP at FRAME")
+               (COND
+                  ((NOT (SETQ I (\VAROFFSET FRAME A)))
+                   0)
+                  ((EQ BLIPTYP '*ARGVAL*)                    (* ; 
+                              "the value of *ARGVAL* is the number of *ARGVAL* blips in this frame")
+                   (OR (\GETBASEPTR \STACKSPACE I)
+                       0))
+                  (T 1)))
+              (T
+               (PROG NIL
+                     (OR FLG (SETQ FLG 1))
+                 FRAMELP
+                     [COND
+                        ((SETQ I (\VAROFFSET FRAME A))
+                         (SELECTQ BLIPTYP
+                             (*ARGVAL* [COND
+                                          ((IGREATERP FLG (SETQ I (OR (\GETBASEPTR \STACKSPACE I)
+                                                                      0)))
+                                                             (* ; "Fewer blips here than FLG")
+                                           (SETQ FLG (IDIFFERENCE FLG I)))
+                                          (T                 (* ; 
+                              "Scan the temporary region for the value of the FLG'th *ARGVAL* blip")
+                                             (RETURN (PROG ((NXT (fetch (FX NEXTBLOCK)
+                                                                    of FRAME))
+                                                            (P (fetch (FX FIRSTTEMP) of
+                                                                                         FRAME)))
+                                                       LP  (CHECK (ILESSP P NXT))
+                                                           [COND
+                                                              ((EQ (\GETBASEPTR \STACKSPACE P)
+                                                                   '*ARGVAL*)
+
+                                           (* ;; "\EVALFORM pushes the atom *ARGVAL*, then each argument.  We want the FLG'th arg, counting from the end backwards")
+
+                                                               (add P
+                                                                      (UNFOLD (ADD1 (IDIFFERENCE
+                                                                                     I FLG))
+                                                                             WORDSPERCELL))
+                                                               (CHECK (ILESSP P NXT))
+                                                               (RETURN (\GETBASEPTR \STACKSPACE P]
+                                                           (add P WORDSPERCELL)
+                                                           (GO LP])
+                             (COND
+                                ((ILESSP (SETQ FLG (SUB1 FLG))
+                                        1)
+                                 (RETURN (\GETBASEPTR \STACKSPACE I]
+                 NEXT
+                     (COND
+                        ([NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK)
+                                                                             of FRAME]
+                         (GO FRAMELP])
+
+(SETBLIPVAL
+  [LAMBDA (BLIPTYP IPOS N VAL)                               (* ; "Edited 18-Feb-91 16:49 by jds")
+    (PROG ([FRAME (COND
+                     ((NULL IPOS)
+                      (\MYALINK))
+                     (T (\STACKARGPTR IPOS]
+           (A (NEW-SYMBOL-CODE BLIPTYP (\ATOMVALINDEX BLIPTYP)))
+           I)
+          (SELECTQ BLIPTYP
+              ((*TAIL* *FORM* *FN* *ARGVAL*))
+              (RETURN))
+          (COND
+             ((NOT N)
+              (SETQ N 1))
+             ((ILESSP N 1)
+              (\ILLEGAL.ARG N)))
+      FRAMELP
+          [COND
+             ((SETQ I (\VAROFFSET FRAME A))
+              (SELECTQ BLIPTYP
+                  (*ARGVAL* [COND
+                               ((NOT (SETQ I (\GETBASEPTR \STACKSPACE I)))
+                                                             (* ; "No argvals")
+                                )
+                               ((IGREATERP N I)
+                                (SETQ N (IDIFFERENCE N I)))
+                               (T                            (* ; 
+                                 "Scan the temporary region for the value of the Nth *ARGVAL* blip")
+                                  (RETURN (PROG ((NXT (fetch (FX NEXTBLOCK) of FRAME))
+                                                 (P (fetch (FX FIRSTTEMP) of FRAME)))
+                                            LP  (CHECK (ILESSP P NXT))
+                                                [COND
+                                                   ((EQ (\GETBASEPTR \STACKSPACE P)
+                                                        '*ARGVAL*)
+                                                             (* ; 
+       "\EVALFORM pushes the atom *ARGVAL*, then each argument.  We want the N'th arg from the end")
+                                                    (add P (UNFOLD (ADD1 (IDIFFERENCE I N))
+                                                                      WORDSPERCELL))
+                                                    (CHECK (ILESSP P NXT))
+                                                    (RETURN (\PUTBASEPTR \STACKSPACE P VAL]
+                                                (add P WORDSPERCELL)
+                                                (GO LP])
+                  (COND
+                     ((ILESSP (SETQ N (SUB1 N))
+                             1)                              (* ; 
+                                      "All other blip types are just the value of the blip binding")
+                      (RETURN (\PUTBASEPTR \STACKSPACE I VAL]
+          (COND
+             ([NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK) of FRAME]
+              (GO FRAMELP])
+
+(BLIPSCAN
+  [LAMBDA (BLIPTYP IPOS)                                     (* ; "Edited 18-Feb-91 16:50 by jds")
+    (PROG ([FRAME (COND
+                     ((NULL IPOS)
+                      (\MYALINK))
+                     (T (\STACKARGPTR IPOS]
+           OFF A)
+          (SETQ A (SELECTQ BLIPTYP
+                      ((*FORM* *TAIL* *FN* *ARGVAL*) 
+                           (NEW-SYMBOL-CODE BLIPTYP (\ATOMVALINDEX BLIPTYP)))
+                      (RETURN)))
+      LP  (COND
+             ([AND (SETQ OFF (\VAROFFSET FRAME A))
+                   (NOT (AND (EQ BLIPTYP '*ARGVAL*)
+                             (NULL (GETBASEPTR \STACKSPACE OFF]
+              (RETURN (\MAKESTACKP NIL FRAME)))
+             ([NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK) of FRAME]
+              (GO LP))
+             (T (RETURN])
+)
+(DEFINEQ
+
+(\REALFRAMEP
+  [LAMBDA (FRAME INTERPFLG)                                  (* lmm " 7-Nov-86 01:53")
+    (LET ((NAME (fetch (FNHEADER FRAMENAME) of (fetch (FX FNHEADER) of FRAME)))
+              BFLINK)
+
+           (* ;; "note that the selection is on the fnheader's name rather than the nametable name. \REALFRAMEP is thus not affected by SETSTKNAME")
+
+           (AND (LISP:SYMBOLP NAME)
+                (SELECTQ NAME
+                    (*ENV*                                   (* ; "*ENV* is used by ENVEVAL etc.")
+                           NIL)
+                    (\INTERPRETER T)
+                    (ERRORSET (NEQ (\STKARG 2 FRAME)
+                                   'INTERNAL))
+                    ((EVAL APPLY) 
+                         (\SMASHLINK NIL FRAME)
+                         (SELECTQ \INTERNAL
+                             ((INTERNAL SELECTQ) 
+                                  NIL)
+                             T))
+                    (OR (NOT (LITATOM NAME))
+                        (COND
+                           ((FMEMB NAME OPENFNS)
+                            INTERPFLG)
+                           (T (OR (NEQ (CHCON1 NAME)
+                                       (CHARCODE \))
+                                  (EXPRP NAME)
+                                  (FASSOC NAME BRKINFOLST])
+)
+
+(RPAQ? OPENFNS '(APPLY* SETQ AND OR COND SELECTQ PROG PROGN PROG1 ARG SETARG ERSETQ NLSETQ 
+                           RESETFORM RESETLST RESETVARS RPTQ SAVESETQ SETN UNDONLSETQ XNLSETQ))
+
+(RPAQQ \BLIPNAMES (*TAIL* *FORM* *FN* *ARGVALS*))
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS BRKINFOLST)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \BLIPNAMES OPENFNS)
+)
+(DEFINEQ
+
+(RAIDCOMMAND
+  [LAMBDA NIL                                              (* lmm "18-Mar-86 09:52")
+    (DECLARE (USEDFREE ROOTFRAME ALINKS? RAIDIX FRAME# VPRINTLEVEL))
+    (FRESHLINE T)
+    (PROG (CMD)
+          (SELECTQ (ALLOCAL (SETQ CMD (ASKUSER NIL NIL "@"
+                                             '((Q "uit [confirm]" CONFIRMFLG T)
+                                               (% "^N - remote return [confirm]" NOECHOFLG T 
+                                                   CONFIRMFLG T RETURN '^N)
+                                               (L "isp stack ")
+                                               (% "Lisp stack " NOECHOFLG T EXPLAINSTRING 
+                                                   "^L -- Lisp stack from arbitrary frame or context"
+                                                   RETURN '^L)
+                                               (F "rame ")
+                                               (%
+ "Next frame " EXPLAINSTRING "LF - next frame" RETURN 'LF)
+                                               (^ " Previous frame ")
+                                               (A "tom top-level value of atom: ")
+                                               (D "efinition for atom: ")
+                                               (P "roperty list for atom: ")
+                                               (V " -- show object at Virtual address: ")
+                                               (B "lock of storage starting at address: ")
+                                               (S "how raw stack from address: ")
+                                               (C "ode for function:")
+                                               (% "Basic frame at: " EXPLAINSTRING 
+                                                   "^F - print basic frame at octal address" RETURN
+                                                   '^F)
+                                               (% "frame extension at: " EXPLAINSTRING 
+                                                   "^X - print frame extension at octal address" 
+                                                   RETURN '^X)
+                                               (W "alk stack blocks starting at: ")
+                                               (K "" EXPLAINSTRING "K -- Set linKtype for stack ops")
+                                               (_ " Set word at address: ")
+                                               (% " Set value of atom " EXPLAINSTRING 
+                                                   "^V -- Set value of atom" RETURN '^V)
+                                               (% "atom number for atom: " EXPLAINSTRING 
+                                                   "^O - look up atom" RETURN '^O)
+                                               (Z "Zap Print level to: ")
+                                               (I "nspect InterfacePage [confirm]" CONFIRMFLG T)
+                                               (U " -- Show remote screen [confirm]" CONFIRMFLG T)
+                                               ("
+" "" RETURN NIL)
+                                               (% " Enter Lisp " EXPLAINSTRING "^Y -- Enter Lisp" 
+                                                   RETURN '^Y))
+                                             T)))
+              (^N (RETURN 'RETURN))
+              (Q (TERPRI T)
+                 (RETURN 'QUIT))
+              (NIL)
+              (A (PRINCOPY (GETTOPVAL (READATOM))))
+              (P (PRINCOPY (GETPROPLIST (READATOM))))
+              (C (PRINTCODE (READATOM)
+                        T RAIDIX))
+              (V (PRINCOPY (READVA)))
+              (B (PRINTADDRS (READVA)
+                        (READOCT " for (number of words): ")))
+              (S (PRINTADDRS (ADDSTACKBASE (READOCT))
+                        (READOCT " for (number of words): ")))
+              (D (PRINTADDRS (fetch (LITATOM DEFINITIONCELL) of (READATOM))
+                        2))
+              (^O (PRINTNUM .I2 (\ATOMVALINDEX (READATOM))
+                         T))
+              (^V (PROG ((ATM (READATOM)))
+                        (printout T " to be ")
+                        (SETTOPVAL ATM (READ T T))))
+              ((L ^L) 
+                   (RAIDSTACKCMD CMD))
+              (F [RAIDSHOWFRAME (SETQ FRAME# (PROG1 (READ T T)
+                                                        (READC T])
+              (LF (OR FRAME# (SETQ FRAME# 0))
+                  (printout T "(" .I1 (add FRAME# 1)
+                         ")" T)
+                  (RAIDSHOWFRAME FRAME#))
+              (^ (COND
+                    ((OR (NULL FRAME#)
+                         (ILEQ FRAME# 1))
+                     (printout T "No previous frame" T))
+                    (T (printout T "(" .I1 (add FRAME# -1)
+                              ")" T)
+                       (RAIDSHOWFRAME FRAME#))))
+              (^F (\PRINTBF (READOCT)
+                         NIL
+                         (FUNCTION PRINCOPY)))
+              (Z [ALLOCAL (LET [(A (PROG1 (READ T T)
+                                              (READC T)))
+                                    (D (PROG1 (READ T T)
+                                              (READC T]
+                                 (COND
+                                    ((AND (FIXP A)
+                                          (FIXP D))
+                                     (SETQ VPRINTLEVEL (CONS A D)))
+                                    (T (PRINTOUT T "Must be two integers, car level then cdr level" T
+                                              )
+                                       (ERROR!])
+              (W [SHOWSTACKBLOCKS (COND
+                                         ((EQ (PEEKC T)
+                                              '%
+)
+                                          (READC T)
+                                          (fetch (IFPAGE StackBase) of \InterfacePage))
+                                         (T (READOCT])
+              (^X (\PRINTFRAME (READOCT)
+                         'PRINCOPY))
+              (^Y (TERPRI T)
+                  (USEREXEC ':%:))
+              (K (SETQ ALINKS? (EQ (ASKUSER NIL NIL " Set link type for stack operations to "
+                                          '((A "links
+")
+                                            (C "links
+"))
+                                          T)
+                                   'A)))
+              (_ (PROG ((VA (READVA)))
+                       (printout T " Currently ")
+                       (PRINTNUM .I7 (GETBASE VA 0)
+                              T)
+                       (printout T " to be ")
+                       (PUTBASE VA 0 (READOCT))))
+              (I [ALLOCAL (COND
+                             [(NULL (GETD 'INSPECT]
+                             ((RECLOOK 'IFPAGE)
+                              (INSPECT [COND
+                                          ((LISTP VMEMFILE)
+                                           (VMAPPAGE (fetch (POINTER PAGE#) of \InterfacePage
+                                                            )))
+                                          (T (PROG [(PAGE (NCREATE 'VMEMPAGEP]
+                                                   (SETVMPTR (VGETTOPVAL '\InterfacePage))
+                                                   (\BINS (GETSTREAM VMEMFILE)
+                                                          PAGE 0 BYTESPERPAGE)
+                                                   (RETURN PAGE]
+                                     'IFPAGE))
+                             (T (PRIN1 " Can't -- no record for IFPAGE"]
+                 (TERPRI T))
+              (U (SHOWREMOTESCREEN))
+              (HELP))
+          (RETURN NIL])
+
+(RAIDSHOWFRAME
+  [LAMBDA (N)                                                (* bvm%: "27-Jan-85 15:27")
+    (PROG [(FRAME (OR ROOTFRAME (RAIDROOTFRAME]
+          [FRPTQ (SUB1 N)
+                 (COND
+                    ([fetch (FX INVALIDP) of (SETQ FRAME (COND
+                                                                    (ALINKS? (fetch (FX ALINK)
+                                                                                of FRAME))
+                                                                    (T (fetch (FX CLINK)
+                                                                          of FRAME]
+                     (RETURN (printout T N " is beyond the bottom of the stack" T]
+          (\BACKTRACE FRAME FRAME T NIL T T NIL (FUNCTION PRINCOPY)
+                 NIL RAIDIX])
+
+(RAIDSTACKCMD
+  [LAMBDA (CMD)                                              (* bvm%: "28-Jan-85 12:16")
+    (DECLARE (USEDFREE FRAME# ROOTFRAME))
+    (PROG (FRAME)
+          (SETQ FRAME# 0)
+          [COND
+             ((EQ CMD 'L)
+              (RAIDROOTFRAME))
+             (T (SETQ ROOTFRAME (SELECTQ (SETQ FRAME (ASKUSER NIL NIL "in context (? for help): "
+                                                            '((P "age fault")
+                                                              (G "arbage collection")
+                                                              (K "eyboard handler")
+                                                              (H "ard Return")
+                                                              (S "tack manipulator")
+                                                              (R "eset")
+                                                              (M "iscellaneous")
+                                                              (F "rame at location: "))
+                                                            T))
+                                    (P (fetch (IFPAGE FAULTFXP) of \InterfacePage))
+                                    (G (fetch (IFPAGE GCFXP) of \InterfacePage))
+                                    (K (fetch (IFPAGE KbdFXP) of \InterfacePage))
+                                    (H (fetch (IFPAGE HardReturnFXP) of \InterfacePage))
+                                    (S (fetch (IFPAGE SubovFXP) of \InterfacePage))
+                                    (R (fetch (IFPAGE ResetFXP) of \InterfacePage))
+                                    (M (fetch (IFPAGE MiscFXP) of \InterfacePage))
+                                    (COND
+                                       ((AND (ILESSP (SETQ FRAME (READOCT))
+                                                    WORDSPERPAGE)
+                                             (ILESSP (\GETBASE \InterfacePage FRAME)
+                                                    (fetch (IFPAGE EndOfStack) of 
+                                                                                       \InterfacePage
+                                                           ))
+                                             (type? FX (\GETBASE \InterfacePage FRAME)))
+                                        (\GETBASE \InterfacePage FRAME))
+                                       ((type? FX FRAME)
+                                        FRAME)
+                                       (T (PRINTNUM .I7 FRAME)
+                                          (printout T " not a valid frame." T)
+                                          (RETURN]
+          (FRESHLINE T)
+          (\BACKTRACE ROOTFRAME NIL T NIL NIL NIL ALINKS? (FUNCTION PRINCOPY)
+                 1 RAIDIX])
+
+(RAIDROOTFRAME
+  [LAMBDA NIL                                              (* bvm%: "27-Jan-85 15:26")
+    (SETQ ROOTFRAME (PROG1 (COND
+                              ((ALLOCAL (LISTP VMEMFILE))
+                               (PRIN1 "in TeleRaid Context" T)
+                               (fetch (IFPAGE TELERAIDFXP) of \InterfacePage))
+                              (T (fetch (IFPAGE CurrentFXP) of \InterfacePage)))
+                           (TERPRI T])
+
+(PRINTADDRS
+  [LAMBDA (BASE CNT)                                         (* bvm%: "13-Feb-85 22:42")
+    (PRIN1 "words from ")
+    (PRINTVA BASE)
+    (PRIN1 " to ")
+    (PRINTVA (\ADDBASE BASE (SUB1 CNT)))
+    (TERPRI)
+    (SPACES 7)
+    (for I from 0 to 7 do (PRINTNUM .I7 I))
+    (PROG ((NB (\VAG2 (\HILOC BASE)
+                      (FLOOR (\LOLOC BASE)
+                             8)))
+           (LB (\ADDBASE BASE CNT)))
+          (do (COND
+                     ((EVENP (\LOLOC NB)
+                             8)
+                      (TAB 0 0)
+                      (PRINTNUM .I5 (\LOLOC NB))
+                      (PRIN1 ": ")))
+                 [COND
+                    ((PTRGTP BASE NB)
+                     (SPACES 7))
+                    (T (PRINTNUM .I7 (\GETBASE NB 0]
+                 (SETQ NB (\ADDBASE NB 1)) repeatwhile (PTRGTP LB NB))
+          (TAB 0 0])
+
+(PRINTVA
+  [LAMBDA (X)                                                (* bvm%: "12-Feb-85 10:41")
+    (PRIN1 "{")
+    (PRINTNUM .I2 (HILOC X))
+    (PRIN1 ",")
+    (PRINTNUM .I2 (LOLOC X))
+    (PRIN1 "}"])
+
+(READVA
+  [LAMBDA NIL                                              (* lmm "21-AUG-81 12:55")
+    (VAG2 (READOCT)
+          (READOCT])
+
+(READATOM
+  [LAMBDA NIL                                              (* ; "Edited 16-Feb-87 15:44 by raf")
+    (ALLOCAL (PROG1 (HANDLER-BIND [[XCL:MISSING-EXTERNAL-SYMBOL #'(LAMBDA (CONDITION)
+
+                                                                    (* ;; 
+                                                                  "MAKE AN INTERNAL SYMBOL INSTEAD")
+
+                                                                    (LISP:INTERN (
+                                                                     XCL:MISSING-EXTERNAL-SYMBOL-NAME
+                                                                                  CONDITION)
+                                                                           (
+                                                                  XCL:MISSING-EXTERNAL-SYMBOL-PACKAGE
+                                                                            CONDITION]
+                                   (XCL:MISSING-PACKAGE #'(LAMBDA (CONDITION)
+
+                                                            (* ;; 
+                                            "FAKE A PACKAGE BY THIS NAME AND MAKE THE SYMBOL IN IT")
+
+                                                            (LISP:INTERN (
+                                                                      XCL:MISSING-PACKAGE-SYMBOL-NAME
+                                                                          CONDITION)
+                                                                   (LISP:MAKE-PACKAGE (
+                                                                     XCL:MISSING-PACKAGE-PACKAGE-NAME
+                                                                                       CONDITION)
+                                                                          :USE NIL]
+                           (LISP:READ T))
+                    (READC T])
+
+(READOCT
+  [LAMBDA (PROMPT)                                           (* bvm%: "28-Jan-85 11:51")
+    (DECLARE (USEDFREE RAIDIX))
+    (COND
+       ((AND PROMPT (NOT (READP T)))
+        (printout T PROMPT)))
+    (bind STR while (EQUAL (SETQ STR (RSTRING T T))
+                                   "") do (READC T)
+       finally
+       (RETURN
+        (PROG1 (OR (FIXP (SELECTQ RAIDIX
+                             (8 (MKATOM (CONCAT STR "Q")))
+                             (16 (bind (N _ 0)
+                                        CHAR while (SETQ CHAR (GNC STR))
+                                    do [SETQ N (IPLUS (ITIMES N 16)
+                                                          (COND
+                                                             ((FIXP CHAR)
+                                                              CHAR)
+                                                             ((AND (IGEQ (SETQ CHAR (CHCON1 CHAR))
+                                                                         (CHARCODE A))
+                                                                   (ILEQ CHAR (CHARCODE F)))
+                                                              (IPLUS (IDIFFERENCE CHAR (CHARCODE
+                                                                                        A))
+                                                                     10))
+                                                             (T (ERROR CHAR '? T]
+                                    finally (RETURN N)))
+                             (SHOULDNT)))
+                   (PROGN (PRIN1 "?" T)
+                          (ERROR!)))
+               (READC T])
+
+(SHOWSTACKBLOCKS
+  [LAMBDA (SCANPTR WAITFLG)                                  (* bvm%: "18-AUG-83 12:05")
+                                                             (* ; "show stack")
+    (PROG ((EASP (fetch EndOfStack of \InterfacePage)))
+      SCAN
+          [SELECTC (fetch (STK FLAGS) of SCANPTR)
+              (\STK.FSB (SHOWSTACKBLOCK1 SCANPTR "free block" (fetch (FSB CHECKED)
+                                                                     of SCANPTR))
+                        (add SCANPTR (fetch (FSB SIZE) of SCANPTR)))
+              (\STK.GUARD (SHOWSTACKBLOCK1 SCANPTR "guard block" T)
+                          (add SCANPTR (fetch (FSB SIZE) of SCANPTR)))
+              (\STK.FX                                       (* ; "frame extension")
+                       (SHOWSTACKBLOCK1 SCANPTR "Frame extn = " (fetch (FX CHECKED)
+                                                                       of SCANPTR))
+                       (PRIN2 (\UNCOPY (fetch (FX FRAMENAME) of SCANPTR)))
+                       (SETQ SCANPTR (fetch (FX NEXTBLOCK) of SCANPTR)))
+              (PROG ((ORIG SCANPTR)
+                     IVAR)                                   (* ; "must be a basic frame")
+                    (while (EQ (fetch (STK FLAGS) of SCANPTR)
+                                   \STK.NOTFLAG) do (add SCANPTR WORDSPERCELL))
+                    (COND
+                       ((NOT (type? BF SCANPTR))
+                        (SHOWSTACKBLOCK1 ORIG "Garbage" T))
+                       (T (SETQ IVAR (fetch (BF IVAR) of SCANPTR))
+                          [COND
+                             ((fetch (BF RESIDUAL) of SCANPTR)
+                              (SHOWSTACKBLOCK1 SCANPTR "Residual BF" (EQ SCANPTR ORIG))
+                              (PRIN1 " with IVar = ")
+                              (PRINTNUM .I7 IVAR))
+                             (T (SHOWSTACKBLOCK1 SCANPTR "Basic frame" (AND (EQ ORIG IVAR)
+                                                                                (fetch
+                                                                                 (BF CHECKED)
+                                                                                   of SCANPTR]
+                          (add SCANPTR WORDSPERCELL]
+          (TERPRI)
+          (COND
+             ((IGREATERP SCANPTR EASP)
+              (RETURN)))
+          (AND WAITFLG (READC T))
+          (GO SCAN])
+
+(SHOWSTACKBLOCK1
+  [LAMBDA (PTR STR GOODFLG)                                  (* bvm%: " 6-AUG-83 23:59")
+    (PRINTNUM .I7 PTR)
+    (SPACES 1)
+    (OR GOODFLG (PRIN1 "[bad] "))
+    (PRIN1 STR])
+
+(PRINCOPY
+  [LAMBDA (X)                                                (* bvm%: "24-Jan-86 12:33")
+    (PRINT (\UNCOPY X (LOCAL (CAR VPRINTLEVEL))
+                  (LOCAL (CDR VPRINTLEVEL)))
+           T T])
+
+(NOSUCHATOM
+  [LAMBDA (ATM)                                              (* ; 
+                                                      "Edited  9-Nov-92 15:24 by sybalsky:mv:envos")
+
+    (* ;; "Called only under TeleRaid when V\MKATOM fails to find atom ATM.  JDS:  And in MAKEINIT, ditto.  For Makeinit (since Teleraid is essentially dead), changed ERROR! to ERROR.")
+
+    (printout T "No such atom: " ATM T)
+    (ERROR "No such atom: "])
+)
+(DEFINEQ
+
+(BACKTRACE
+  [LAMBDA (IPOS EPOS FLAGS FILE PRINTFN)                     (* bvm%: "13-Feb-85 22:42")
+    (RESETFORM (OUTPUT FILE)
+           (\BACKTRACE (\STACKARGPTR (OR IPOS -1))
+                  (\STACKARGPTR (OR EPOS T))
+                  [EQ 0 (LOGAND 8 (OR FLAGS (SETQ FLAGS 0]
+                  (NEQ 0 (LOGAND FLAGS 1))
+                  (NEQ 0 (LOGAND FLAGS 4))
+                  (NEQ 0 (LOGAND FLAGS 32))
+                  (EQ 0 (LOGAND FLAGS 16))
+                  (OR PRINTFN (FUNCTION PRINT))
+                  NIL])
+
+(\BACKTRACE
+  [LAMBDA (IPOS EPOS NAMES VARS LOCALS JUNK ALINKS PRINTFN CNT RADIX)
+                                                             (* lmm " 2-Jul-86 13:00")
+    (OR RADIX (SETQ RADIX 8))
+    (PROG [NARGS NPVARS NAME ARGNAME BLINK (.I7 (NUMFORMATCODE (LIST 'FIX 7 RADIX]
+          (DECLARE (SPECVARS .I7))
+      POSLP
+          (COND
+             (CNT (printout NIL .I3 CNT ": ")
+                  (add CNT 1)))
+          (SETQ NAME (\STKNAME IPOS))
+          (COND
+             (JUNK (TERPRI)
+                   (TERPRI)
+                   (PRIN1 "Basic frame at ")
+                   (PRINTNUM .I7 (SETQ BLINK (fetch (FX BLINK) of IPOS)))
+                   (TERPRI)
+                   (\PRINTBF BLINK (fetch (FX NAMETABLE) of IPOS)
+                          PRINTFN)
+                   (PROGN (TERPRI)
+                          (PRIN1 "Frame xtn at ")
+                          (PRINTNUM .I7 IPOS)
+                          (PRIN1 ", frame name= "))
+                   (APPLY* PRINTFN NAME)
+                   (\PRINTFRAME IPOS PRINTFN))
+             [(OR VARS LOCALS)
+              (\PRINTBF (fetch (FX BLINK) of IPOS)
+                     (fetch (FX NAMETABLE) of IPOS)
+                     PRINTFN
+                     (COND
+                        (LOCALS 'LOCALS)
+                        (T T)))
+              (COND
+                 (NAMES (APPLY* PRINTFN NAME)
+                        (TERPRI)))
+              (\PRINTFRAME IPOS PRINTFN (COND
+                                               (LOCALS 'LOCALS)
+                                               (T T]
+             (NAMES (APPLY* PRINTFN NAME)))
+          (COND
+             ([AND (NEQ EPOS IPOS)
+                   (NOT (fetch (FX INVALIDP) of (SETQ IPOS (COND
+                                                                      (ALINKS (fetch (FX ALINK)
+                                                                                 of IPOS))
+                                                                      (T (fetch (FX CLINK)
+                                                                            of IPOS]
+              (GO POSLP)))
+          (RETURN T])
+
+(\SCANFORNTENTRY
+  [LAMBDA (NMT NTENTRY)                                      (* ; "Edited 18-Feb-91 15:18 by jds")
+
+    (* ;; "Scan thru the name table pointedto by NMT, looking for the name of the variable with offset entry NTENTRY, which must be in the form appropriate to the architecture (2- or 3-byte).")
+
+    (bind NM for NT1 from (fetch (FNHEADER OVERHEADWORDS) of T)
+       by (CONSTANT (WORDSPERNAMEENTRY)) as NT2 from (IPLUS (fetch (FNHEADER 
+                                                                                        OVERHEADWORDS
+                                                                                          )
+                                                                           of T)
+                                                                        (fetch (FNHEADER NTSIZE)
+                                                                           of NMT))
+       by (CONSTANT (WORDSPERNTOFFSETENTRY)) do (COND
+                                                           ((NULL-NTENTRY (SETQ NM (GETSTKNAMEENTRY
+                                                                                    NMT NT1)))
+                                                            (RETURN)))
+                                                       (COND
+                                                          ((IEQP NTENTRY (GETSTKNTOFFSETENTRY NMT NT2
+                                                                                ))
+                                                           (RETURN (\INDEXATOMVAL NM])
+
+(\PRINTSTK
+  [LAMBDA (I)                                                (* lmm "23-MAY-82 22:09")
+    (PRINTNUM .I7 I)
+    (PRIN1 ": ")
+    (PRINTNUM .I7 (GETBASE \STACKSPACE I))
+    (PRINTNUM .I7 (GETBASE \STACKSPACE (ADD1 I)))
+    (SPACES 1])
+
+(\PRINTFRAME
+  [LAMBDA (FRAME PRINTFN VARSONLY)                           (* ; "Edited 30-Jan-91 01:48 by jds")
+    (PROG ((NMT (fetch (FX NAMETABLE) of FRAME))
+           (I 0)
+           (FT (fetch (FX FIRSTTEMP) of FRAME))
+           TMP NLOCALS)
+          [COND
+             ((NOT VARSONLY)
+              (\PRINTSTK FRAME)
+              (PRIN1 "[")
+              (PROGN (PSTKFLD FAST "F, " FAST)
+                     (PSTKFLD INCALL "C, " INCALL)
+                     (PSTKFLD VALIDNAMETABLE "V, " VALIDNAMETABLE)
+                     (PSTKFLD NOPUSH "N, " NOPUSH)
+                     (PSTKFLD USECNT "USE=" (NEQ USECNT 0)
+                            NIL ", ")
+                     (PSTKFLD SLOWP "X, " SLOWP)
+                     (PSTKFLD ALINK " alink]" T))
+              (TERPRI)
+              (PSTK 2 (FNHEADER "[fn header]" T))
+              (PSTK 4 (NEXTBLOCK "[next, pc]" T))
+              (PSTK 6 (NAMETABLE "[nametable]" T))
+              (PSTK 8 (BLINK "[blink, clink]" T]
+          (SETQ NLOCALS (fetch (FNHEADER NLOCALS) of NMT))
+          [for old I from (fetch (FX FIRSTPVAR) of FRAME) by WORDSPERCELL
+             while (ILESSP I FT) as J from 0
+             do (OR VARSONLY (\PRINTSTK I))
+                   (COND
+                      [(ILESSP J NLOCALS)
+                       (COND
+                          ((OR (SETQ TMP (\SCANFORNTENTRY NMT (MAKE-NTENTRY PVARCODE J)))
+                               (AND (NEQ VARSONLY T)
+                                    (SETQ TMP "local")))
+                           (COND
+                              ((fetch (PVARSLOT BOUND) of (ADDSTACKBASE I))
+                               (AND VARSONLY (SPACES 3))
+                               (PRIN2 TMP)
+                               (SPACES 1)
+                               (APPLY* PRINTFN (\GETBASEPTR (ADDSTACKBASE I)
+                                                          0)))
+                              ((NOT VARSONLY)
+                               (printout NIL TMP " [unbound]" T]
+                      ((NOT VARSONLY)
+                       (COND
+                          ((SETQ TMP (\SCANFORNTENTRY NMT (MAKE-NTENTRY FVARCODE J)))
+                           (printout NIL "[fvar " .P2 TMP " "
+                                  (COND
+                                     ((fetch (FVARSLOT LOOKEDUP) of (ADDSTACKBASE I))
+                                      (COND
+                                         ((EQ [SETQ TMP (\HILOC (fetch (FVARSLOT BINDINGPTR)
+                                                                   of (ADDSTACKBASE I]
+                                              \STACKHI)
+                                          " on stack]")
+                                         ((NEQ (FLOOR TMP 2)
+                                               (\HILOC \VALSPACE))
+                                                             (* ; "See comment in BOUNDP")
+                                          " non-stack binding]")
+                                         (T " top value]")))
+                                     (T " not looked up]"))
+                                  T))
+                          (T (printout NIL "[padding]" T]
+          (COND
+             ((NOT VARSONLY)
+              (SETQ FT (fetch (FX NEXTBLOCK) of FRAME))
+              (for old I by 2 while (ILESSP I FT)
+                 do                                      (* ; 
+                           "2 = WORDSPERCELL but for doesn't translate correctly with WORDSPERCELL")
+                       (\PRINTSTK I)
+                       (COND
+                          ((fetch (PVARSLOT BOUND) of (ADDSTACKBASE I))
+                           (APPLY* PRINTFN (\GETBASEPTR (ADDSTACKBASE I)
+                                                      0)))
+                          (T (TERPRI])
+
+(\PRINTBF
+  [LAMBDA (BL NMT PRINTFN VARSONLY)                          (* ; "Edited 30-Jan-91 01:49 by jds")
+    [bind NM for I from (fetch (BF IVAR) of BL) by 2 as J from 0
+       to (SUB1 (fetch (BF NARGS) of BL))
+       do (OR VARSONLY (\PRINTSTK I))
+             [COND
+                ([OR (SETQ NM (\SCANFORNTENTRY [OR NMT (RETURN (OR VARSONLY (TERPRI]
+                                     (MAKE-NTENTRY IVARCODE J)))
+                     (AND (NEQ VARSONLY T)
+                          (SETQ NM '*local*]
+                 (AND VARSONLY (SPACES 3))
+                 (PRIN2 NM)
+                 (SPACES 1)
+                 (APPLY* PRINTFN (GETBASEPTR \STACKSPACE I]
+       finally (OR VARSONLY (while (ILESSP I BL) do (\PRINTSTK I)
+                                                               (printout NIL "[padding]" T)
+                                                               (add I 2]
+    (COND
+       ((NOT VARSONLY)
+        (\PRINTSTK BL)
+        (COND
+           ((fetch (BF RESIDUAL) of BL)
+            (PRIN1 "residual ")))
+        (COND
+           ((NEQ (fetch (BF USECNT) of BL)
+                 0)
+            (printout NIL "usecnt= " (fetch (BF USECNT) of BL)
+                   %,)))
+        (TERPRI])
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+
+(RPAQQ RAIDCOMS
+       ((MACROS PSTKFLD PRINTSTKFIELDS PSTK PRINTVA)
+        (ADDVARS (RDCOMS (FNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA
+                              READVA READOCT READATOM SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY 
+                              NOSUCHATOM)
+                        (FNS \BACKTRACE \STKNAME \PRINTBF \PRINTFRAME \SCANFORNTENTRY \PRINTSTK))
+               (EXPANDMACROFNS PSTKFLD PRINTSTKFIELDS PSTK PRINTVA))
+        (ADDVARS (DONTCOMPILEFNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS 
+                        PRINTVA READVA READATOM READOCT SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY 
+                        NOSUCHATOM))))
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS PSTKFLD MACRO [(FLD STR TEST FMT STR2)
+                                 (PROG ((FLD (fetch (FX FLD) of FRAME)))
+                                       (DECLARE (LOCALVARS FLD))
+                                       (COND
+                                          (TEST (PRIN1 'STR)
+                                                (SELECTQ (CONSTANT (NTHCHAR 'STR -1))
+                                                    (= (printout NIL %, FLD STR2))
+                                                    NIL)
+                                                T])
+
+(PUTPROPS PRINTSTKFIELDS MACRO [FIELDS (CONS 'PROGN (MAPCAR FIELDS (FUNCTION (LAMBDA (X)
+                                                                                       (CONS
+                                                                                        'PSTKFLD X])
+
+(PUTPROPS PSTK MACRO ((N . FIELDS)
+                              (\PRINTSTK (IPLUS FRAME N))
+                              (PRINTSTKFIELDS . FIELDS)
+                              (TERPRI)))
+
+(PUTPROPS PRINTVA MACRO [LAMBDA (X)
+                                  (printout NIL "{" (HILOC X)
+                                         ","
+                                         (LOLOC X)
+                                         "}"])
+)
+
+(ADDTOVAR RDCOMS (FNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA 
+                          READVA READOCT READATOM SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY NOSUCHATOM
+                          )
+                     (FNS \BACKTRACE \STKNAME \PRINTBF \PRINTFRAME \SCANFORNTENTRY \PRINTSTK))
+
+(ADDTOVAR EXPANDMACROFNS PSTKFLD PRINTSTKFIELDS PSTK PRINTVA)
+
+(ADDTOVAR DONTCOMPILEFNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA
+                                   READVA READATOM READOCT SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY 
+                                   NOSUCHATOM)
+)
+(DEFINEQ
+
+(CCODEP
+  [LAMBDA (FN)                                               (* ; "Edited 30-Jan-87 13:36 by Pavel")
+    (COND
+       [(LITATOM FN)
+        (COND
+           ((fetch (LITATOM CCODEP) of FN)
+            (NOT (fetch (LITATOM PSEUDOCODEP) of FN)))
+           (T (TYPEP (fetch (LITATOM DEFPOINTER) of FN)
+                     'COMPILED-CLOSURE]
+       (T (LISP:COMPILED-FUNCTION-P FN])
+
+(EXPRP
+  [LAMBDA (FN)                                               (* lmm "17-FEB-82 23:50")
+    (PROG ((DEF FN))
+          [COND
+             ((LITATOM DEF)
+              [COND
+                 ((fetch (LITATOM CCODEP) of DEF)
+                  (RETURN (fetch (LITATOM PSEUDOCODEP) of DEF]
+              (SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF]
+          (RETURN (COND
+                     ((LISTP DEF)
+                      T])
+
+(SUBRP
+  [LAMBDA (FN)                                               (* lmm "17-AUG-81 21:57")
+    NIL])
+
+(FNTYP
+  [LAMBDA (FN)                                               (* bvm%: " 7-Jul-86 16:43")
+    (PROG ((DEF FN))
+          [COND
+             ((LITATOM DEF)
+              (SETQ DEF (fetch (LITATOM DEFINITIONCELL) of DEF))
+              (COND
+                 ((fetch (DEFINITIONCELL PSEUDOCODEP) of DEF)
+                  (SETQ DEF (\PSEUDOCODE.REALDEF DEF)))
+                 ((PROG1 (fetch (DEFINITIONCELL CCODEP) of DEF)
+                      (SETQ DEF (fetch (DEFINITIONCELL DEFPOINTER) of DEF)))
+                  (RETURN (\CCODEFNTYP DEF]
+          (RETURN (COND
+                     ((LISTP DEF)
+                      (SELECTQ (CAR DEF)
+                          (LISP:LAMBDA 'EXPR*)
+                          ([LAMBDA OPENLAMBDA] 
+                               (COND
+                                  ((AND (NLISTP (SETQ DEF (CADR DEF)))
+                                        DEF)
+                                   'EXPR*)
+                                  (T 'EXPR)))
+                          (NLAMBDA (COND
+                                      ((AND (NLISTP (SETQ DEF (CADR DEF)))
+                                            DEF)
+                                       'FEXPR*)
+                                      (T 'FEXPR)))
+                          (FUNARG 'EXPR)
+                          NIL))
+                     ((TYPEP DEF 'COMPILED-CLOSURE)
+                      (\CCODEFNTYP (fetch (COMPILED-CLOSURE FNHEADER) of DEF])
+
+(ARGTYPE
+  [LAMBDA (FN)                                               (* bvm%: "16-Jul-86 22:47")
+    (LET ((DEF FN))
+           (LISP:TYPECASE DEF
+               (LISP:SYMBOL (COND
+                               ((PROG1 (fetch (LITATOM CCODEP) of DEF)
+                                    (SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF)))
+                                (\CCODEARGTYPE DEF))
+                               (DEF (ARGTYPE DEF))))
+               (CONS (SELECTQ (CAR DEF)
+                         (LISP:LAMBDA 2)
+                         ([LAMBDA OPENLAMBDA] 
+                              (COND
+                                 ((AND (NLISTP (SETQ DEF (CADR DEF)))
+                                       DEF)
+                                  2)
+                                 (T 0)))
+                         (NLAMBDA (COND
+                                     ((AND (NLISTP (SETQ DEF (CADR DEF)))
+                                           DEF)
+                                      3)
+                                     (T 1)))
+                         (FUNARG (ARGTYPE (CADR DEF)))
+                         (SELECTQ (FNTYP DEF)
+                             (EXPR 0)
+                             (FEXPR 1)
+                             (EXPR* 2)
+                             (FEXPR* 3)
+                             NIL)))
+               (CLOSURE 2)
+               (COMPILED-CLOSURE (\CCODEARGTYPE (fetch (COMPILED-CLOSURE FNHEADER) of DEF))))
+           ])
+
+(NARGS
+  [LAMBDA (FN)                                               (* bvm%: " 7-Jul-86 17:07")
+    (LET ((DEF FN))
+           (COND
+              ([AND (LITATOM DEF)
+                    (PROG1 (fetch (LITATOM CCODEP) of DEF)
+                        (SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF)))]
+               (\CCODENARGS DEF))
+              ((LISTP DEF)
+               (SELECTQ (CAR DEF)
+                   (LISP:LAMBDA 1)
+                   ([LAMBDA NLAMBDA OPENLAMBDA] 
+                        (COND
+                           ((NULL (SETQ DEF (CADR DEF)))
+                            0)
+                           ((NLISTP DEF)
+                            1)
+                           (T (in DEF sum 1))))
+                   (FUNARG (NARGS (CADR DEF)))
+                   NIL))
+              ((TYPEP DEF 'COMPILED-CLOSURE)
+               (\CCODENARGS (fetch (COMPILED-CLOSURE FNHEADER) of DEF])
+
+(ARGLIST
+  [LAMBDA (FN SMARTP)                                        (* ; "Edited 15-Jan-88 15:10 by bvm:")
+    (PROG ((DEF FN)
+           TEMP)
+          [COND
+             ((LITATOM DEF)
+              (COND
+                 ((PROG1 (fetch (LITATOM CCODEP) of DEF)
+                      (SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF)))
+                  (RETURN (\CCODEARGLIST DEF SMARTP)))
+                 ((NULL DEF)
+                  (SETQ DEF (GETPROP FN 'EXPR]
+          [RETURN (COND
+                     ((LISTP DEF)
+                      (SELECTQ (CAR DEF)
+                          (LISP:LAMBDA 'U)
+                          ([LAMBDA NLAMBDA OPENLAMBDA] 
+                               (CADR DEF))
+                          (FUNARG (ARGLIST (CADR DEF)))
+                          (GO UNDEF)))
+                     ((TYPEP DEF 'COMPILED-CLOSURE)
+                      (\CCODEARGLIST (fetch (COMPILED-CLOSURE FNHEADER) of DEF)
+                             SMARTP))
+                     (T (GO UNDEF]
+      UNDEF
+          (COND
+             ((AND (SETQ DEF (FNCHECK FN T))
+                   (NEQ DEF FN))
+              (RETURN (ARGLIST DEF)))
+             (T (ERROR '"Args not available:" FN])
+
+(\CCODEARGLIST
+  [LAMBDA (FNHD SMARTP)                                      (* ; 
+                                                           "Edited 10-May-88 12:18 by MASINTER")
+
+    (* ;; "Computes the arglist for raw code object FNHD.  If SMARTP is true, we're allowed to return a Common Lisp arg list if we find one; otherwise, we have to comply with Interlisp arglist semantics.")
+
+    (PROG ((N (fetch (FNHEADER NA) of FNHD))
+           IVARS SIZE LOCALSIZE ENDT)
+          [COND
+             ((EQ N 0)                                       (* ; "No args")
+              (RETURN NIL))
+             ((AND (< N 0)
+                   (NOT SMARTP))                             (* ; "LAMBDA*")
+              (RETURN 'U]
+          (SETQ SIZE (fetch (FNHEADER NTSIZE) of FNHD))
+          [COND
+             ((EQ [SETQ LOCALSIZE (- (FOLDLO (if (fetch (FNHEADER NATIVE) of FNHD)
+                                                 then (- (fetch (FNHEADER STARTPC)
+                                                                of FNHD)
+                                                             4)
+                                               else (fetch (FNHEADER STARTPC) of FNHD))
+                                            BYTESPERWORD)
+                                     (SETQ ENDT (+ (fetch (FNHEADER OVERHEADWORDS) of T)
+                                                   (COND
+                                                      ((EQ SIZE 0)
+                                                             (* ; 
+                                           "No nametable, but there's a quad of zeros there anyway")
+                                                       WORDSPERQUAD)
+                                                      (T (UNFOLD SIZE 2]
+                  0)                                         (* ; "Nothing extra here")
+              )
+             [(> LOCALSIZE WORDSPERCELL)                     (* ; 
+                                      "There is a second nametable between the first and the code.")
+              (SETQ IVARS (\CCODEIVARSCAN FNHD ENDT (FOLDLO LOCALSIZE 2]
+             ((AND (LISTP (SETQ ENDT (\GETBASEPTR FNHD ENDT)))
+                   (LISTP (CAR ENDT)))                       (* ; 
+                     "It's exactly a pointer to debugging info, car of which is a stylized arglist")
+              (SETQ ENDT (if (AND (EQ (CAAR ENDT)
+                                          '&OPTIONAL)
+                                      (LISTGET (CDR ENDT)
+                                             :INTERLISP))
+                             then                        (* ; "The &OPTIONAL, while strictly correct, is misleading, since it's technically true for ALL Interlisp functions.")
+                                   (CDAR ENDT)
+                           else (CAR ENDT)))
+              (RETURN (COND
+                         (SMARTP ENDT)
+                         (T                                  (* ; "Note that if we got this far, function can't be a nospread (we caught this in the very first COND up above), which means there can't be any &key or &rest")
+                            (for X in ENDT unless (EQ X '&OPTIONAL)
+                               collect (COND
+                                              ((STRINGP X)   (* ; 
+            "Callers of ARGLIST are expecting to get something that would actually function as one")
+                                               (MKATOM X))
+                                              (T X]
+          [COND
+             ((< N 0)                                        (* ; 
+           "Waited until now to see if there was a stored arglist, but we didn't find one--give up")
+              (RETURN 'U]
+          [COND
+             ((NEQ SIZE 0)                                   (* ; "Scan specials name table")
+              (SETQ IVARS (\CCODEIVARSCAN FNHD (fetch (FNHEADER OVERHEADWORDS) of T)
+                                 SIZE IVARS]
+          [SETQ IVARS (for I from 0 to (SUB1 N)
+                         collect (OR (CDR (ASSOC I IVARS))
+                                         (PACK* '*ARG* I]
+          (RETURN (SELECTQ (fetch (FNHEADER ARGTYPE) of FNHD)
+                      (3 (CAR IVARS))
+                      IVARS])
+
+(\CCODEIVARSCAN
+  [LAMBDA (FNHD START SIZE IVARS)                            (* ; "Edited 30-Jan-91 02:00 by jds")
+
+    (* ;; "Search nametable starting at offset START in FNHD for all ivars.  Return list of dotted pairs (index . name) consed onto front of IVARS.  NTSIZE is size of nt in words")
+
+    (bind NM CODE for NTOFFSET FROM (UNFOLD START BYTESPERWORD)
+       by (CONSTANT (BYTESPERNAMEENTRY)) while (SETQ NM (\INDEXATOMVAL (GETNAMEENTRY FNHD 
+                                                                                      NTOFFSET)))
+       do                                                (* ; 
+                                              "Note that entry = 0 => NM = NIL terminates the loop")
+             [COND
+                ((EQP [NTSLOT-VARTYPE (SETQ CODE (GETNTOFFSETENTRY FNHD (IPLUS NTOFFSET
+                                                                               (UNFOLD SIZE 
+                                                                                      BYTESPERWORD]
+                      IVARCODE)
+                 (push IVARS (CONS (NTSLOT-OFFSET CODE)
+                                       NM] finally (RETURN IVARS])
+)
+
+
+
+(* ; "Translation machinery for new LAMBDA words")
+
+
+(PUTPROPS LAMBDATRANFNS VARTYPE ALIST)
+
+(ADDTOVAR LAMBDATRANFNS )
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \CCODENARGS MACRO ((FNH)
+                                     ([LAMBDA (N)
+                                        (COND
+                                           ((ILESSP N 0)
+                                            1)
+                                           (T N]
+                                      (fetch (FNHEADER NA) of FNH))))
+
+(PUTPROPS \CCODEFNTYP MACRO ((FNH)
+                                     (SELECTQ (\CCODEARGTYPE FNH)
+                                         (0 'CEXPR)
+                                         (1 'CFEXPR)
+                                         (2 'CEXPR*)
+                                         'CFEXPR*)))
+
+(PUTPROPS \CCODEARGTYPE MACRO ((FNH)
+                                       (fetch (FNHEADER ARGTYPE) of FNH)))
+)
+)
+
+
+
+(* ; "CONSTANTS mechanism")
+
+(DEFINEQ
+
+(CONSTANTS
+  [NLAMBDA VARS                                              (* rmk%: " 3-Jan-84 13:20")
+    (OR COMPVARMACROHASH (SETQ COMPVARMACROHASH (HASHARRAY 100)))
+    [for X in VARS do (COND
+                                     ((LISTP X)
+                                      (PUTHASH (CAR X)
+                                             (LIST 'CONSTANT (CADR X))
+                                             COMPVARMACROHASH))
+                                     (T (PUTHASH X (LIST 'CONSTANT X)
+                                               COMPVARMACROHASH]
+    VARS])
+
+(CONSTANTEXPRESSIONP
+  [LAMBDA (FORM)                                             (* ; "Edited 21-Jan-91 23:45 by jds")
+    (COND
+       [(LITATOM FORM)
+        (COND
+           ((OR (NULL FORM)
+                (EQ FORM T))
+            (LIST FORM))
+           ((AND COMPVARMACROHASH (SETQ FORM (GETHASH FORM COMPVARMACROHASH)))
+            (CONSTANTEXPRESSIONP FORM]
+       [(LISTP FORM)
+        (SELECTQ (CAR FORM)
+            (QUOTE (CDR FORM))
+            (FUNCTION (AND (LITATOM (CADR FORM))
+                           (NULL (CDDR FORM))
+                           (CDR FORM)))
+            (CONSTANT [LET (VALUE)
+                             [SETQ VALUE (NLSETQ (EVAL (CADR FORM]
+                             (COND
+                                (VALUE (LIST (CAR VALUE)))
+                                (T (SETQ FORM (COMPILER:OPTIMIZE-AND-MACROEXPAND (CADR FORM)
+                                                     *BC-MACRO-ENVIRONMENT*
+                                                     (COMPILER:MAKE-CONTEXT :VALUES-USED 1 
+                                                            :PREDICATE-P NIL)))
+                                   (LIST (EVAL FORM])
+            (COND
+               [(FMEMB (CAR FORM)
+                       CONSTANTFOLDFNS)
+                (for X in (CDR FORM) collect (CAR (OR (CONSTANTEXPRESSIONP X)
+                                                                  (RETURN)))
+                   finally (RETURN (LIST (APPLY (CAR FORM)
+                                                    $$VAL]
+               ((NOT (GETD (CAR FORM)))
+                (PROG ((MAC (GETMACROPROP (CAR FORM)
+                                   COMPILERMACROPROPS)))
+                      (RETURN (AND MAC [NOT (EQUAL FORM (SETQ FORM (MACROEXPANSION FORM MAC]
+                                   (CONSTANTEXPRESSIONP FORM]
+       ((NUMBERP FORM)
+        (LIST FORM])
+)
+
+(RPAQ? COMPVARMACROHASH (HASHARRAY 100))
+
+
+
+(* ; 
+"We need this initialized for the INIT, so don't put it off. (It used to start out NIL and get set later)"
+)
+
+
+(ADDTOVAR CONSTANTFOLDFNS PLUS IPLUS TIMES ITIMES DIFFERENCE IDIFFERENCE QUOTIENT IQUOTIENT IMIN
+                                   IMAX IABS LLSH LRSH LOGOR LOGXOR LOGAND OR AND)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS COMPVARMACROHASH CONSTANTFOLDFNS)
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(SPECVARS *TAIL* *FN* *FORM* *ARGVAL*)
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+
+(ADDTOVAR LAMS FAULTEVAL FAULTAPPLY)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA CONSTANTS PROG1 COND PROGN OR AND QUOTE LET* LET GO PROG SETQ)
+
+(ADDTOVAR NLAML FUNCTION RETURN)
+
+(ADDTOVAR LAMA BOUNDP APPLY* \INTERPRETER)
+)
+(PUTPROPS LLINTERP COPYRIGHT ("Venue & Xerox Corporation" T 1981 1982 1983 1984 1985 1986 1987 1988 
+1990 1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (6043 27809 (\INTERPRETER 6053 . 10653) (\INTERPRETER1 10655 . 17157) (
+\SETUP-COMPILED-CLOSURE-CALL 17159 . 26869) (\STKNAME 26871 . 27807)) (27838 38244 (\ENVCALL.UFN 27848
+ . 28021) (\SETUP-ENVIRONMENT-CALL 28023 . 38242)) (38283 46887 (EVAL 38293 . 38436) (\EVAL 38438 . 
+38772) (\EVALFORM 38774 . 40952) (\EVALFORMASLAMBDA 40954 . 41238) (\EVALOTHER 41240 . 41636) (APPLY 
+41638 . 41784) (APPLY* 41786 . 44404) (\CHECKAPPLY* 44406 . 45988) (\CKAPPLYARGS 45990 . 46506) (
+DEFEVAL 46508 . 46885)) (48981 57472 (EVALV 48991 . 49286) (\EVALV1 49288 . 49542) (\EVALVAR 49544 . 
+50160) (BOUNDP 50162 . 50512) (SET 50514 . 51117) (\SETVAR 51119 . 51726) (SETQ 51728 . 52400) (
+\STKSCAN 52402 . 55922) (\SETFVARSLOT 55924 . 57470)) (57506 72559 (PROG 57516 . 60032) (\PROG0 60034
+ . 63668) (\EVPROG1 63670 . 64011) (RETURN 64013 . 64925) (GO 64927 . 66449) (EVALA 66451 . 68380) (
+\EVALA 68382 . 70975) (ERRORSET 70977 . 72364) (SI::ERRORSET-PRINT-FUNCTION 72366 . 72557)) (72618 
+85276 (LET 72628 . 74771) (LET* 74773 . 76921) (\LET0 76923 . 80585) (\LET* 80587 . 85274)) (85277 
+88159 (QUOTE 85287 . 85323) (AND 85325 . 85695) (OR 85697 . 86160) (PROGN 86162 . 86668) (COND 86670
+ . 87326) (\EVPROGN 87328 . 87679) (PROG1 87681 . 88157)) (88657 96366 (ENVEVAL 88667 . 88989) (
+ENVAPPLY 88991 . 89313) (FUNCTION 89315 . 89637) (\FUNCT1 89639 . 92090) (\MAKEFUNARGFRAME 92092 . 
+94289) (STKEVAL 94291 . 94485) (STKAPPLY 94487 . 94704) (RETEVAL 94706 . 95559) (RETAPPLY 95561 . 
+96364)) (96491 104003 (BLIPVAL 96501 . 100404) (SETBLIPVAL 100406 . 103148) (BLIPSCAN 103150 . 104001)
+) (104004 105373 (\REALFRAMEP 104014 . 105371)) (105754 126174 (RAIDCOMMAND 105764 . 113613) (
+RAIDSHOWFRAME 113615 . 114464) (RAIDSTACKCMD 114466 . 117343) (RAIDROOTFRAME 117345 . 117825) (
+PRINTADDRS 117827 . 118744) (PRINTVA 118746 . 118958) (READVA 118960 . 119111) (READATOM 119113 . 
+121010) (READOCT 121012 . 122716) (SHOWSTACKBLOCKS 122718 . 125295) (SHOWSTACKBLOCK1 125297 . 125499) 
+(PRINCOPY 125501 . 125717) (NOSUCHATOM 125719 . 126172)) (126175 136217 (BACKTRACE 126185 . 126727) (
+\BACKTRACE 126729 . 128989) (\SCANFORNTENTRY 128991 . 130621) (\PRINTSTK 130623 . 130875) (\PRINTFRAME
+ 130877 . 134866) (\PRINTBF 134868 . 136215)) (138982 150927 (CCODEP 138992 . 139412) (EXPRP 139414 . 
+139881) (SUBRP 139883 . 139996) (FNTYP 139998 . 141500) (ARGTYPE 141502 . 143026) (NARGS 143028 . 
+143982) (ARGLIST 143984 . 145235) (\CCODEARGLIST 145237 . 149702) (\CCODEIVARSCAN 149704 . 150925)) (
+151973 154512 (CONSTANTS 151983 . 152580) (CONSTANTEXPRESSIONP 152582 . 154510)))))
+STOP
diff --git a/CLTL2/LLINTERP.LCOM b/CLTL2/LLINTERP.LCOM
new file mode 100644
index 00000000..d3ca21cf
Binary files /dev/null and b/CLTL2/LLINTERP.LCOM differ
diff --git a/CLTL2/LLMVS b/CLTL2/LLMVS
new file mode 100644
index 00000000..31495179
--- /dev/null
+++ b/CLTL2/LLMVS
@@ -0,0 +1,338 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 16:35:37" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLMVS.;2" 20546  
+
+      previous date%: " 3-Sep-91 18:10:25" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLMVS.;1")
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1989, 1990, 1991, 1993 by Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT LLMVSCOMS)
+
+(RPAQQ LLMVSCOMS
+       [
+
+(* ;;; "Runtime support for multiple value passing.  This file must be present for compiled multiple values to work.")
+
+        (FNS LISP:VALUES LISP:VALUES-LIST \MVLIST \SIMULATE.UNBIND)
+        (DECLARE%: DONTCOPY (MACROS \VALUES \VALUES-UFN)
+               (LOCALVARS . T))
+        (VARIABLES LISP:MULTIPLE-VALUES-LIMIT)
+        
+        (* ;; "UFNs for the CL:VALUES and CL:VALUES-LIST sub-opcodes of MISCN:")
+
+        (FNS LISP::VALUES-UFN LISP::VALUES-LIST-UFN)
+        (PROP FILETYPE LLMVS)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML)
+                                                                             (LAMA LISP:VALUES])
+
+
+
+(* ;;; 
+"Runtime support for multiple value passing.  This file must be present for compiled multiple values to work."
+)
+
+(DEFINEQ
+
+(LISP:VALUES
+  [LAMBDA ARGS                                               (* ; "Edited 30-May-90 16:01 by jds")
+
+    (* ;; "Return multiple values to a caller.")
+
+    (\VALUES (for I from 1 to ARGS collect (ARG ARGS I))
+           (AND (IGEQ ARGS 1)
+                (ARG ARGS 1])
+
+(LISP:VALUES-LIST
+  [LAMBDA (LISP:VALUES)                                  (* ; "Edited 30-May-90 16:02 by jds")
+
+    (* ;; "Given a list of values, return them as multiple values to a caller.")
+
+    (\VALUES LISP:VALUES (CAR LISP:VALUES])
+
+(\MVLIST
+  [LAMBDA (X)
+    (LIST X])
+
+(\SIMULATE.UNBIND
+  [LAMBDA (FRAME N RETURNER)                                 (* ; "Edited 25-Nov-87 12:54 by bvm:")
+
+    (* ;; "Simulate the action of N applications of UNBIND occurring in specified FRAME.  RETURNER is the frame that will return to FRAME, and hence must be made slow (NIL if my caller).  Must be called uninterruptably.")
+
+    (LET* [(NEXT (fetch (FX NEXTBLOCK) of FRAME))
+           (SP NEXT)
+           (PVAR0BASE (STACKADDBASE (fetch (FX FIRSTPVAR) of FRAME]
+          [TO N DO (do                           (* ; 
+                                                       "Pop stack until a bind mark is encountered")
+                                  (SETQ SP (- SP WORDSPERCELL)) REPEATUNTIL (fetch BINDMARKP
+                                                                                   of
+                                                                                   (STACKADDBASE
+                                                                                    SP))
+                              FINALLY                    (* ; 
+"Unbind stuff.  Bind mark says how many pvars were bound, and gives the offset of the last of them")
+                                    (LET [(LASTPVAR (fetch BINDLASTPVAR of (STACKADDBASE
+                                                                                    SP]
+                                         (to (fetch BINDNVALUES of (STACKADDBASE SP))
+                                            do (\PUTBASE PVAR0BASE LASTPVAR 65535)
+                                                  (SETQ LASTPVAR (- LASTPVAR WORDSPERCELL]
+          (replace (FX NEXTBLOCK) of FRAME with SP)
+          (\MAKEFREEBLOCK SP (- NEXT SP))
+
+          (* ;; "Now explicitly slow return to FRAME, since we have violated the fast return assumptions by blowing away stack between here and there")
+
+          (replace (FX FASTP) of (OR RETURNER (\MYALINK)) with NIL])
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \VALUES MACRO
+          [(MANY ONE CALLER-FRAME)
+           (PROG* ((IMMEDIATE-CALLER (OR CALLER-FRAME (\MYALINK)))
+                   (CALLER IMMEDIATE-CALLER)
+                   PREVFRAME)
+
+            (* ;; "NB:  THIS MACRO MUST TRACK \VALUES-UFN, EXCEPT FOR THE PC-SETTING CODE.  THIS ONE IS USED IN THE FUNCTIONS CL:VALUES AND CL:VALUES-LIST.")
+
+            (* ;; "This macro is used by VALUES and VALUES-LIST to possibly return multiple values.  It works by examining the caller to see if the next instruction is MVLIST (currently in the form of a FN1 \MVLIST), which is present in all multiple-value receivers.  If so, it bumps the pc past there and returns the MANY expression, whose value is a list of all the values.  If it encounters RETURN instead, the call was tail-recursive, so procedure repeats with caller's caller, etc.  Otherwise, multiple values are not expected, and the macro returns just ONE value (the first) to the caller.")
+
+              NEWFRAME
+                  (RETURN (PROG ((PC (fetch (FX PC) of CALLER))
+                                 (CODE (fetch (FX FNHEADER) of CALLER))
+                                 (NUNBINDS 0)
+                                 BYTE)
+                            NEWPC
+                                [SELECTC (SETQ BYTE (\GETBASEBYTE CODE PC))
+                                    ((LIST (OP# RETURN)
+                                           (OP# \RETURN))    (* ; 
+                                  "Call is tail-recursive, so iterate.  \RETURN is for LLBREAKing.")
+                                         (SETQ PREVFRAME CALLER)
+                                         (SETQ CALLER (fetch (FX CLINK) of CALLER))
+                                         (GO NEWFRAME))
+                                    ((OP# FN1)               (* ; "Could be MVLIST")
+                                         (SELECTQ [\INDEXATOMDEF
+                                                   (NEW-SYMBOL-CODE [\VAG2 (\GETBASEBYTE CODE
+                                                                                  (+ PC 1))
+                                                                           (create
+                                                                            WORD
+                                                                            HIBYTE _
+                                                                            (\GETBASEBYTE
+                                                                             CODE
+                                                                             (+ PC 2))
+                                                                            LOBYTE _
+                                                                            (\GETBASEBYTE
+                                                                             CODE
+                                                                             (+ PC 3]
+                                                          (create WORD
+                                                                 HIBYTE _ (\GETBASEBYTE CODE
+                                                                                 (+ PC 1))
+                                                                 LOBYTE _ (\GETBASEBYTE CODE
+                                                                                 (+ PC 2]
+                                             (\MVLIST        (* ; 
+                                                "Bump PC past the call, and return the values list")
+                                                      (UNINTERRUPTABLY
+                                                          (COND
+                                                             ((NEQ NUNBINDS 0)
+                                                             (* ; 
+                  "Sigh.  We have to simulate the unbinding, since we need to get past the MVLIST.")
+                                                              (\SIMULATE.UNBIND CALLER NUNBINDS 
+                                                                     PREVFRAME)))
+
+                                                       (* ;; 
+         "Update the PC to skip over the FN1 opcode 1+(# of bytes in a symbol in the code stream):")
+
+                                                          (replace (FX PC) of CALLER
+                                                             with (NEW-SYMBOL-CODE (+ PC 4)
+                                                                             (+ PC 3))))
+                                                      (RETURN MANY))
+                                             NIL))
+                                    ((OP# UNBIND)            (* ; 
+    "UNBIND appears.  This preserves the top of stack, so it should also preserve multiple values.")
+                                         (add PC 1)
+                                         (add NUNBINDS 1)
+                                         (GO NEWPC))
+                                    ((OP# JUMPX)             (* ; "Follow the jump (yecch)")
+                                         (add PC (COND
+                                                        ((>= (SETQ BYTE (\GETBASEBYTE CODE
+                                                                               (+ PC 1)))
+                                                             128)
+                                                         (- BYTE 256))
+                                                        (T BYTE)))
+                                         (GO NEWPC))
+                                    ((OP# JUMPXX) 
+                                         (add PC (SIGNED (create WORD
+                                                                    HIBYTE _ (\GETBASEBYTE
+                                                                              CODE
+                                                                              (+ PC 1))
+                                                                    LOBYTE _ (\GETBASEBYTE
+                                                                              CODE
+                                                                              (+ PC 2)))
+                                                            BITSPERWORD))
+                                         (GO NEWPC))
+                                    (LET [(JUMPBASE (CONSTANT (CAAR (\FINDOP 'JUMP]
+                                         (COND
+                                            ([<= JUMPBASE BYTE (CONSTANT (CADAR (\FINDOP 'JUMP]
+                                             (add PC (+ (- BYTE JUMPBASE)
+                                                            2))
+                                             (GO NEWPC]
+                                (RETURN ONE])
+
+(PUTPROPS \VALUES-UFN MACRO
+          [(MANY ONE CALLER-FRAME RESULT-IVAR)
+           (PROG* ((IMMEDIATE-CALLER (OR CALLER-FRAME (\MYALINK)))
+                   (CALLER IMMEDIATE-CALLER)
+                   PREVFRAME)
+
+            (* ;; "NB:  THIS MACRO MUST TRACK \VALUES, EXCEPT FOR THE PC SETTING CODE.  THIS ONE IS USED IN THE UFNs FOR VALUES AND VALUES-LIST.")
+
+            (* ;; "This macro is used by VALUES and VALUES-LIST to possibly return multiple values.  It works by examining the caller to see if the next instruction is MVLIST (currently in the form of a FN1 \MVLIST), which is present in all multiple-value receivers.  If so, it bumps the pc past there and returns the MANY expression, whose value is a list of all the values.  If it encounters RETURN instead, the call was tail-recursive, so procedure repeats with caller's caller, etc.  Otherwise, multiple values are not expected, and the macro returns just ONE value (the first) to the caller.")
+
+              NEWFRAME
+                  (RETURN (PROG ((PC (fetch (FX PC) of CALLER))
+                                 (CODE (fetch (FX FNHEADER) of CALLER))
+                                 (NUNBINDS 0)
+                                 BYTE)
+                            NEWPC
+                                [SELECTC (SETQ BYTE (\GETBASEBYTE CODE PC))
+                                    ((LIST (OP# RETURN)
+                                           (OP# \RETURN))    (* ; 
+                                  "Call is tail-recursive, so iterate.  \RETURN is for LLBREAKing.")
+                                         (SETQ PREVFRAME CALLER)
+                                         (SETQ CALLER (fetch (FX CLINK) of CALLER))
+                                         (GO NEWFRAME))
+                                    ((OP# FN1)               (* ; "Could be MVLIST")
+                                         (SELECTQ [\INDEXATOMDEF (create WORD
+                                                                        HIBYTE _
+                                                                        (\GETBASEBYTE CODE
+                                                                               (+ PC 1))
+                                                                        LOBYTE _
+                                                                        (\GETBASEBYTE CODE
+                                                                               (+ PC 2]
+                                             (\MVLIST        (* ; 
+                                                "Bump PC past the call, and return the values list")
+                                                      (LET (VALS)
+                                                           (SETQ VALS MANY)
+
+                                        (* ;; "This LET & SETQ forces MANY to be computed before we dink with the stack (which seems to destroy some of the values!)")
+
+                                                           (REPLACE (FX NEXTBLOCK) OF 
+                                                                                     IMMEDIATE-CALLER
+                                                              WITH (LOLOC RESULT-IVAR))
+                                                           (UNINTERRUPTABLY
+                                                               (COND
+                                                                  ((NEQ NUNBINDS 0)
+                                                             (* ; 
+                  "Sigh.  We have to simulate the unbinding, since we need to get past the MVLIST.")
+                                                                   (\SIMULATE.UNBIND CALLER 
+                                                                          NUNBINDS PREVFRAME)))
+                                                               [COND
+                                                                  ((EQ CALLER IMMEDIATE-CALLER)
+
+                                               (* ;; "If the immediate caller has the MVLIST, then the PC has already been bumped, courtesy of the microcode.")
+
+                                                                   (replace (FX PC) of CALLER
+                                                                      with (+ PC 3)))
+                                                                  (T 
+                                                                     (* ;; 
+                                                  "Otherwise, we should skip over the FN1 \MVLIST.")
+
+                                                                     (replace (FX PC)
+                                                                        of CALLER
+                                                                        with (+ PC 3])
+                                                           (SI::UNWIND IMMEDIATE-CALLER)
+                                                           (RETURN VALS)))
+                                             NIL))
+                                    ((OP# UNBIND)            (* ; 
+    "UNBIND appears.  This preserves the top of stack, so it should also preserve multiple values.")
+                                         (add PC 1)
+                                         (add NUNBINDS 1)
+                                         (GO NEWPC))
+                                    ((OP# JUMPX)             (* ; "Follow the jump (yecch)")
+                                         (add PC (COND
+                                                        ((>= (SETQ BYTE (\GETBASEBYTE CODE
+                                                                               (+ PC 1)))
+                                                             128)
+                                                         (- BYTE 256))
+                                                        (T BYTE)))
+                                         (GO NEWPC))
+                                    ((OP# JUMPXX) 
+                                         (add PC (SIGNED (create WORD
+                                                                    HIBYTE _ (\GETBASEBYTE
+                                                                              CODE
+                                                                              (+ PC 1))
+                                                                    LOBYTE _ (\GETBASEBYTE
+                                                                              CODE
+                                                                              (+ PC 2)))
+                                                            BITSPERWORD))
+                                         (GO NEWPC))
+                                    (LET [(JUMPBASE (CONSTANT (CAAR (\FINDOP 'JUMP]
+                                         (COND
+                                            ([<= JUMPBASE BYTE (CONSTANT (CADAR (\FINDOP 'JUMP]
+                                             (add PC (+ (- BYTE JUMPBASE)
+                                                            2))
+                                             (GO NEWPC]
+                                (RETURN ONE])
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+
+(LISP:DEFCONSTANT LISP:MULTIPLE-VALUES-LIMIT 512)
+
+
+
+(* ;; "UFNs for the CL:VALUES and CL:VALUES-LIST sub-opcodes of MISCN:")
+
+(DEFINEQ
+
+(LISP::VALUES-UFN
+  [LAMBDA (LISP::INDEX LISP::ARGCOUNT LISP::ARG-PTR)         (* ; "Edited  5-Jun-90 15:21 by jds")
+
+    (* ;; "This is the UFN for the VALUES MISCN opcode.  Its definition must be analogous to that for CL:VALUES, in case anything changes.")
+
+    (* ;; "* * * * * * *")
+
+    (* ;; "Architectural note:  This function assumes that it is called by an unwind-protect from \miscn.ufn.  Therefore, it skips two frames before deciding whether to pass back one valur or many.")
+
+    (\VALUES-UFN (for I from 0 to (LLSH (SUB1 LISP::ARGCOUNT)
+                                                    1) by 2 collect (\GETBASEPTR 
+                                                                                   LISP::ARG-PTR I))
+           (AND (IGEQ LISP::ARGCOUNT 1)
+                (\GETBASEPTR LISP::ARG-PTR 0))
+           (fetch (FX CLINK) of (fetch (FX CLINK) of (\MYALINK)))
+           LISP::ARG-PTR])
+
+(LISP::VALUES-LIST-UFN
+  [LAMBDA (LISP::INDEX LISP::ARGCOUNT LISP::ARG-PTR)         (* ; "Edited  5-Jun-90 15:21 by jds")
+
+    (* ;; "This is the UFN for the VALUES-LIST MISCN opcode.  Its definition must be analogous to that for CL:VALUES-LIST, in case anything changes.")
+
+    (* ;; "* * * * * * *")
+
+    (* ;; "Architectural note:  This function assumes that it is called by an unwind-protect from \miscn.ufn.  Therefore, it skips two frames before deciding whether to pass back one value or many.")
+
+    (LET ((LISP:VALUES (\GETBASEPTR LISP::ARG-PTR 0)))
+         (\VALUES-UFN LISP:VALUES (CAR LISP:VALUES)
+                (fetch (FX CLINK) of (fetch (FX CLINK) of (\MYALINK)))
+                LISP::ARG-PTR])
+)
+
+(PUTPROPS LLMVS FILETYPE :FAKE-COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA LISP:VALUES)
+)
+(PUTPROPS LLMVS COPYRIGHT ("Xerox Corporation" 1986 1987 1989 1990 1991 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (1334 3999 (LISP:VALUES 1344 . 1651) (LISP:VALUES-LIST 1653 . 1908) (\MVLIST 1910 . 
+1950) (\SIMULATE.UNBIND 1952 . 3997)) (18510 20246 (LISP::VALUES-UFN 18520 . 19489) (LISP::VALUES-LIST-UFN
+ 19491 . 20244)))))
+STOP
diff --git a/CLTL2/LLMVS.LCOM b/CLTL2/LLMVS.LCOM
new file mode 100644
index 00000000..c81504da
Binary files /dev/null and b/CLTL2/LLMVS.LCOM differ
diff --git a/CLTL2/LLNEW b/CLTL2/LLNEW
new file mode 100644
index 00000000..9a145f88
--- /dev/null
+++ b/CLTL2/LLNEW
@@ -0,0 +1,1418 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "28-Jan-93 17:42:57" {DSK}<python>lde>lispcore>sources>LLNEW.;2 68199  
+
+      changes to%:  (FNS \COPY)
+
+      previous date%: " 5-Jan-93 00:46:10" {DSK}<python>lde>lispcore>sources>LLNEW.;1)
+
+
+(* ; "
+Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT LLNEWCOMS)
+
+(RPAQQ LLNEWCOMS
+       ((PROPS (LLNEW FILETYPE))
+        [COMS                                                (* ; "low level memory access")
+              (FNS \ADDBASE \GETBASE \PUTBASE \PUTBASE.UFN \PUTBASEPTR.UFN \PUTBITS.UFN \GETBASEBYTE
+                   \PUTBASEBYTE \GETBASEPTR \PUTBASEPTR \HILOC \LOLOC \VAG2 \RPLPTR \RPLPTR.UFN)
+              (FNS EQ EQL)
+              (PROP BYTEMACRO EQL)
+              (FNS LOC VAG)
+              (FNS CREATEPAGES \NEW4PAGE)
+              (DECLARE%: DONTCOPY (EXPORT (RECORDS POINTER WORD)
+                                         (MACROS PTRGTP .COERCE.TO.SMALLPOSP. .COERCE.TO.BYTE.))
+                     (ADDVARS (INEWCOMS (FNS \GETBASEBYTE \PUTBASEBYTE CREATEPAGES \NEW4PAGE))
+                            (RDCOMS (FNS \CAR.UFN \CDR.UFN)
+                                   (FNS \COPY \UNCOPY)
+                                   (FNS \GETBASEBYTE \PUTBASEBYTE))
+                            (INITPTRS (\LISTPDTD))
+                            (MKI.SUBFNS (\ADDBASE . I.ADDBASE)
+                                   (\GETBASE . I.GETBASE)
+                                   (\PUTBASE . I.PUTBASE)
+                                   (\GETBASEPTR . I.GETBASEPTR)
+                                   (\PUTBASEPTR . I.PUTBASEPTR)
+                                   (\HILOC . I.HILOC)
+                                   (\LOLOC . I.LOLOC)
+                                   (\VAG2 . I.VAG2)
+                                   (.COERCE.TO.SMALLPOSP. . PROG1)
+                                   (.COERCE.TO.BYTE. . PROG1)
+                                   (LOCKEDPAGEP . MKI.LOCKEDPAGEP)
+                                   (\RPLPTR . I.PUTBASEPTR)
+                                   (CONS . I.\CONS.UFN))
+                            (RD.SUBFNS (\ADDBASE . VADDBASE)
+                                   (\GETBASE . VGETBASE)
+                                   (\PUTBASE . VPUTBASE)
+                                   (\GETBASEPTR . VGETBASEPTR)
+                                   (\PUTBASEPTR . VPUTBASEPTR)
+                                   (\HILOC . VHILOC)
+                                   (\LOLOC . VLOLOC)
+                                   (\VAG2 . VVAG2)
+                                   (.COERCE.TO.SMALLPOSP. . PROG1)
+                                   (.COERCE.TO.BYTE. . PROG1)
+                                   (PTRGTP . IGREATERP)
+                                   (\RPLPTR . VPUTBASEPTR)
+                                   (CAR . V\CAR.UFN)
+                                   (CDR . V\CDR.UFN)
+                                   (CAR/CDRERR . T)))
+                     EVAL@COMPILE
+                     (ADDVARS (DONTCOMPILEFNS CREATEPAGES]
+        [COMS                                                (* ; "cons cells")
+              (FNS CONS \CONS.UFN \MAIKO.CONS.UFN CAR \CAR.UFN CDR \CDR.UFN RPLACA \RPLACA.UFN RPLACD
+                   \RPLACD.UFN DOCOLLECT \RPLCONS ENDCOLLECT \INITCONSPAGE \NEXTCONSPAGE)
+              (ADDVARS (\MAIKO.MOVDS (\MAIKO.CONS.UFN \CONS.UFN)))
+              (FNS \RESTLIST.UFN \FINDKEY.UFN)
+              (INITVARS (CAR/CDRERR 'CDR))
+              (DECLARE%: DONTCOPY (GLOBALVARS CAR/CDRERR)
+                     (EXPORT (RECORDS LISTP CONSPAGE)
+                            (CONSTANTS * CONSCONSTANTS))
+                     (MACROS .MAKECONSCELL. .FINDCLOSEPRIOR. .FINDCDRABLEPAIR. .FINDPAIR.)
+                                                             (* ; "for MAKEINIT")
+                     (ADDVARS (INEWCOMS (FNS \CONS.UFN \MAIKO.CONS.UFN \INITCONSPAGE \NEXTCONSPAGE))
+                            (EXPANDMACROFNS .MAKECONSCELL. .FINDCLOSEPRIOR. .FINDCDRABLEPAIR. 
+                                   .FINDPAIR.)))
+              (COMS                                          (* ; "testing out CONSes")
+                    (FNS CHECKCONSPAGES \CHECKCONSPAGE)
+                    (DECLARE%: DONTCOPY (MACROS !CHECK]
+        [COMS                                                (* ; "other random stuff for makeinit")
+              (FNS MAKEINITFIRST MAKEINITLAST \COPY \UNCOPY)
+              (DECLARE%: DONTCOPY (EXPORT (MACROS LOCAL ALLOCAL))
+                     (ADDVARS (MKI.SUBFNS (CHECK . *)
+                                     (RAID . HELP)
+                                     (UNINTERRUPTABLY
+                                          . PROGN)
+                                     (\StatsAdd1 . *)
+                                     (EVQ . I.\COPY)
+                                     (COPY . I.\COPY))
+                            (RD.SUBFNS (CHECK . *)
+                                   (RAID . HELP)
+                                   (UNINTERRUPTABLY
+                                        . PROGN)
+                                   (\StatsAdd1 . *)
+                                   (EVQ . V\COPY)
+                                   (COPY . V\COPY)
+                                   (1ST . V\UNCOPY)))
+                     (ADDVARS (INEWCOMS (FNS MAKEINITFIRST \COPY MAKEINITLAST)))
+                     EVAL@COMPILE
+                     (ADDVARS (DONTCOMPILEFNS MAKEINITFIRST \COPY MAKEINITLAST \UNCOPY]
+        (LOCALVARS . T)))
+
+(PUTPROPS LLNEW FILETYPE :BCOMPL)
+
+
+
+(* ; "low level memory access")
+
+(DEFINEQ
+
+(\ADDBASE
+  [LAMBDA (X D)                                          (* lmm " 2-NOV-81 18:33")
+
+    (* ;; "usually done in microcode;  this version uses only arithmetic and \VAG2")
+
+    (PROG (NH NL (XH (\HILOC X))
+              (XL (\LOLOC X)))
+          (.UNBOX. D NH NL)
+          (COND
+             [(IGREATERP XL (IDIFFERENCE MAX.SMALL.INTEGER NL))
+                                                             (* ; "carry")
+              (add XH 1)
+              (SETQ XL (SUB1 (IDIFFERENCE XL (IDIFFERENCE MAX.SMALL.INTEGER NL]
+             (T (add XL NL)))
+          (COND
+             [(IGREATERP NH MAX.POS.HINUM)
+              (SETQ XH (SUB1 (IDIFFERENCE XH (IDIFFERENCE MAX.SMALL.INTEGER NH]
+             (T (add XH NH)))
+          (RETURN (\VAG2 XH XL])
+
+(\GETBASE
+  [LAMBDA (X D)                                          (* lmm " 2-NOV-81 18:33")
+
+    (* ;; "usually done in microcode;  case where D=0 MUST be done in microcode")
+
+    (\GETBASE (\ADDBASE X D)
+           0])
+
+(\PUTBASE
+  [LAMBDA (X D V)                                        (* lmm "11-FEB-83 07:35")
+
+    (* ;; "usually done in microcode;  case where D=0 MUST be handled there")
+
+    (\PUTBASE (\ADDBASE X D)
+           0
+           (.COERCE.TO.SMALLPOSP. V])
+
+(\PUTBASE.UFN
+  [LAMBDA (X V D)                                        (* lmm "11-FEB-83 07:35")
+
+    (* ;; "usually done in microcode;  case where D=0 MUST be handled there")
+
+    (\PUTBASE (\ADDBASE X D)
+           0
+           (.COERCE.TO.SMALLPOSP. V])
+
+(\PUTBASEPTR.UFN
+  [LAMBDA (X V D)                                        (* lmm "10-NOV-81 15:12")
+
+    (* ;; "usually done in microcode;  this def uses only PUTBASE, ADDBASE, etc")
+
+    (\PUTBASE X D (\HILOC V))
+    (\PUTBASE (\ADDBASE X D)
+           1
+           (\LOLOC V))
+    V])
+
+(\PUTBITS.UFN
+  [LAMBDA (X V N.FD)                                     (* lmm "11-FEB-83 07:35")
+    (PROG ((NV (.COERCE.TO.SMALLPOSP. V))
+           (WIDTH (ADD1 (LOGAND N.FD 15)))
+           (FIRST (LRSH (LOGAND N.FD 255)
+                            4))
+           MASK SHIFT)
+          (SETQ SHIFT (IDIFFERENCE 16 (IPLUS FIRST WIDTH)))
+          (SETQ MASK (SUB1 (LLSH 1 WIDTH)))
+          (\PUTBASE (SETQ X (\ADDBASE X (LRSH N.FD 8)))
+                 0
+                 (LOGOR (LOGAND (\GETBASE X 0)
+                               (LOGXOR 65535 (LLSH MASK SHIFT)))
+                        (LLSH (LOGAND NV MASK)
+                              SHIFT)))
+          (RETURN NV])
+
+(\GETBASEBYTE
+  [LAMBDA (PTR N)                                        (* bvm%: " 5-Feb-85 12:05")
+
+    (* ;; 
+"usually done in microcode;  this def.  uses only \GETBASE and arithmetic --- used by MAKEINIT too")
+
+    (COND
+       [(EVENP N)
+        (fetch (WORD HIBYTE) of (\GETBASE PTR (FOLDLO N BYTESPERWORD]
+       (T (fetch (WORD LOBYTE) of (\GETBASE PTR (FOLDLO N BYTESPERWORD])
+
+(\PUTBASEBYTE
+  [LAMBDA (PTR DISP BYTE)                                (* JonL "31-Dec-83 23:48")
+
+    (* ;; "usually done in microcode --- this def used by MAKEINIT too")
+
+    (SETQ BYTE (.COERCE.TO.BYTE. BYTE))
+    [\PUTBASE PTR (FOLDLO (SETQ DISP (\DTEST DISP 'SMALLP))
+                             BYTESPERWORD)
+           (COND
+              ((EVENP DISP BYTESPERWORD)
+               (create WORD using (\GETBASE PTR (FOLDLO DISP BYTESPERWORD))
+                                      HIBYTE _ BYTE))
+              (T (create WORD using (\GETBASE PTR (FOLDLO DISP BYTESPERWORD))
+                                        LOBYTE _ BYTE]
+    BYTE])
+
+(\GETBASEPTR
+  [LAMBDA (X D)                                          (* lmm " 2-NOV-81 18:34")
+
+    (* ;; 
+  "usually done in microcode;  this def.  uses GETBASE, VAG2, etc.  and handles overflows too")
+
+    (\VAG2 (fetch LOBYTE of (\GETBASE X D))
+           (\GETBASE (\ADDBASE X 1)
+                  D])
+
+(\PUTBASEPTR
+  [LAMBDA (X D V)                                        (* lmm " 2-NOV-81 18:35")
+
+    (* ;; "usually done in microcode;  this def uses only PUTBASE, ADDBASE, etc")
+
+    (\PUTBASE X D (\HILOC V))
+    (\PUTBASE (\ADDBASE X D)
+           1
+           (\LOLOC V))
+    V])
+
+(\HILOC
+  [LAMBDA (X)                                            (* lmm "10-MAR-81 15:02")
+                                                             (* ; "MUST be handled in microcode")
+    (\HILOC X])
+
+(\LOLOC
+  [LAMBDA (X)                                            (* lmm "10-MAR-81 15:03")
+                                                             (* ; "MUST be handled in microcode")
+    (\LOLOC X])
+
+(\VAG2
+  [LAMBDA (H L)                                          (* JonL "31-Dec-83 23:39")
+
+    (* ;; "case where H is byte and L is smallposp MUST be handled in microcode.  Other cases may run error here.")
+
+    (\VAG2 (.COERCE.TO.BYTE. H)
+           (.COERCE.TO.SMALLPOSP. L])
+
+(\RPLPTR
+  [LAMBDA (OBJ OFFSET VAL)                               (* lmm " 3-NOV-81 12:10")
+    (UNINTERRUPTABLY
+        (\ADDREF VAL)
+        (\DELREF (\GETBASEPTR (SETQ OBJ (\ADDBASE OBJ OFFSET))
+                        0))
+        (\PUTBASEBYTE OBJ 1 (\HILOC VAL))            (* ; 
+                                                           "\PUTBASEPTR smashes the high byte")
+        (\PUTBASE OBJ 1 (\LOLOC VAL))
+        VAL)])
+
+(\RPLPTR.UFN
+  [LAMBDA (OBJ VAL OFFSET)                               (* ; "Edited 14-Jan-87 16:34 by Pavel")
+
+(* ;;; "The UFN is different from the function since the offset (inline) gets pushed last.")
+
+    (LET ((SLOT (\ADDBASE OBJ OFFSET)))
+         (UNINTERRUPTABLY
+             
+             (* ;; "Fix up the reference counts.")
+
+             (\ADDREF VAL)
+             (\DELREF (\GETBASEPTR SLOT 0))
+
+             (* ;; "\PUTBASEPTR smashes the high byte, so we use two calls instead.")
+
+             (\PUTBASEBYTE SLOT 1 (\HILOC VAL))
+             (\PUTBASE SLOT 1 (\LOLOC VAL))
+
+             (* ;; "Be sure to return the OBJ; code generated by the new compiler counts on it.")
+
+             OBJ)])
+)
+(DEFINEQ
+
+(EQ
+  [LAMBDA (X Y)                                          (* lmm "10-MAR-81 15:04")
+                                                             (* ; "MUST be handled in microcode")
+    (EQ X Y])
+
+(EQL
+  [LAMBDA (X Y)                                          (* ; "Edited  6-Jul-87 09:40 by jop")
+
+(* ;;; "Like EQ except for numbers")
+
+    (COND
+       ((OR (NOT (LISP:NUMBERP X))
+            (TYPEP X 'LISP:FIXNUM))
+        (EQ X Y))
+       [(LISP:FLOATP X)
+
+        (* ;; 
+      "32 bit compare --- differs from feqp in that the predicate is not true for -0.0 and 0.0")
+
+        (AND (LISP:FLOATP Y)
+             (EQ (fetch LOWORD of X)
+                    (fetch LOWORD of Y))
+             (EQ (fetch HIWORD of X)
+                    (fetch HIWORD of Y]
+       ((LISP:INTEGERP X)
+        (AND (LISP:INTEGERP Y)
+             (IEQP X Y)))
+       [(TYPEP X 'RATIO)
+        (AND (TYPEP Y 'RATIO)
+             (EQL (LISP::RATIO-NUMERATOR X)
+                    (LISP::RATIO-NUMERATOR Y))
+             (EQL (LISP::RATIO-DENOMINATOR X)
+                    (LISP::RATIO-DENOMINATOR Y]
+       ((TYPEP X 'COMPLEX)
+        (AND (TYPEP Y 'COMPLEX)
+             (EQL (LISP::COMPLEX-REALPART X)
+                    (LISP::COMPLEX-REALPART Y))
+             (EQL (LISP::COMPLEX-IMAGPART X)
+                    (LISP::COMPLEX-IMAGPART Y])
+)
+
+(PUTPROPS EQL BYTEMACRO COMP.EQ)
+(DEFINEQ
+
+(LOC
+  [LAMBDA (X)                                            (* lmm " 2-NOV-81 18:29")
+                                                             (* ; 
+     "Return HILOC-LOLOC pair, for easier traffic with RAID.  VAG interprets such pairs correctly.")
+    (CONS (\HILOC X)
+           (\LOLOC X])
+
+(VAG
+  [LAMBDA (LOC)                                      (* lmm " 2-NOV-81 18:28")
+                                                             (* ; "LOC can be a HILOC-LOLOC pair")
+    (COND
+       [(LISTP LOC)
+        (\VAG2 (CAR LOC)
+               (OR (FIXP (CDR LOC))
+                   (FIX (CADR LOC]
+       (T (\VAG2 (\HINUM LOC)
+                 (\LONUM LOC])
+)
+(DEFINEQ
+
+(CREATEPAGES
+  [LAMBDA (VA N BLANKFLG LOCKFLG)                        (* bvm%: "29-MAR-83 16:35")
+
+    (* ;; "called only under MAKEINIT --- BLANKFLG means that MAKEINIT won't write on this page, so fake it --- to prevent storage overflow when running on Maxc and init'ing GC table")
+
+    (for I from 0 to (SUB1 N) do (\NEWPAGE (\ADDBASE VA (UNFOLD I WORDSPERPAGE))
+                                                        NIL LOCKFLG BLANKFLG))
+    VA])
+
+(\NEW4PAGE
+  [LAMBDA (PTR)                               (* ; 
+                                                "Edited 24-Oct-92 12:45 by sybalsky:mv:envos")
+
+    (* ;; "Instantiates a block of 4 new virtual pages, starting with the one at PTR.")
+
+    (\NEWPAGE (\ADDBASE (\NEWPAGE (\ADDBASE (\NEWPAGE (\ADDBASE (\NEWPAGE PTR)
+                                                                     WORDSPERPAGE))
+                                             WORDSPERPAGE))
+                     WORDSPERPAGE])
+)
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
+
+(ACCESSFNS POINTER [(PAGE# (IPLUS (LLSH (\HILOC DATUM)
+                                            8)
+                                      (LRSH (\LOLOC DATUM)
+                                            8)))
+                        (WORDINPAGE (LOGAND (\LOLOC DATUM)
+                                           255))
+                        (CELLINPAGE (LRSH (fetch WORDINPAGE of DATUM)
+                                          1))
+                        (BYTEINPAGE (LLSH (fetch WORDINPAGE of DATUM)
+                                          1))
+                        (SEGMENT# (\HILOC DATUM))
+                        (WORDINSEGMENT (\LOLOC DATUM))
+                        (CELLINSEGMENT (LRSH (fetch WORDINSEGMENT of DATUM)
+                                             1))
+                        (WORD# (fetch WORDINPAGE of DATUM))
+                        (DBLWORD# (fetch CELLINPAGE of DATUM))
+                        (PAGEBASE (\VAG2 (\HILOC DATUM)
+                                         (LOGAND (\LOLOC DATUM)
+                                                65280]
+                       (CREATE (\VAG2 (LRSH PAGE# 8)
+                                          (LLSH (LOGAND PAGE# 255)
+                                                8))))
+
+(ACCESSFNS WORD ((HIBYTE (LRSH DATUM 8))
+                     (LOBYTE (LOGAND DATUM 255)))
+                    (CREATE (IPLUS (LLSH HIBYTE 8)
+                                       LOBYTE)))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS PTRGTP MACRO [OPENLAMBDA (X Y)
+                                      (OR (IGREATERP (\HILOC X)
+                                                 (\HILOC Y))
+                                          (AND (EQ (\HILOC X)
+                                                      (\HILOC Y))
+                                               (IGREATERP (\LOLOC X)
+                                                      (\LOLOC Y])
+
+(PUTPROPS .COERCE.TO.SMALLPOSP. DMACRO [OPENLAMBDA (X)
+                                                      (COND
+                                                         ((SMALLPOSP X)
+                                                          X)
+                                                         (T (\ILLEGAL.ARG X])
+
+(PUTPROPS .COERCE.TO.BYTE. DMACRO [OPENLAMBDA (X)
+                                                 (COND
+                                                    ([AND (SMALLPOSP X)
+                                                          (ILESSP X (CONSTANT (LLSH 1 BITSPERBYTE]
+                                                     X)
+                                                    (T (\ILLEGAL.ARG X])
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+
+(ADDTOVAR INEWCOMS (FNS \GETBASEBYTE \PUTBASEBYTE CREATEPAGES \NEW4PAGE))
+
+(ADDTOVAR RDCOMS (FNS \CAR.UFN \CDR.UFN)
+                     (FNS \COPY \UNCOPY)
+                     (FNS \GETBASEBYTE \PUTBASEBYTE))
+
+(ADDTOVAR INITPTRS (\LISTPDTD))
+
+(ADDTOVAR MKI.SUBFNS (\ADDBASE . I.ADDBASE)
+                         (\GETBASE . I.GETBASE)
+                         (\PUTBASE . I.PUTBASE)
+                         (\GETBASEPTR . I.GETBASEPTR)
+                         (\PUTBASEPTR . I.PUTBASEPTR)
+                         (\HILOC . I.HILOC)
+                         (\LOLOC . I.LOLOC)
+                         (\VAG2 . I.VAG2)
+                         (.COERCE.TO.SMALLPOSP. . PROG1)
+                         (.COERCE.TO.BYTE. . PROG1)
+                         (LOCKEDPAGEP . MKI.LOCKEDPAGEP)
+                         (\RPLPTR . I.PUTBASEPTR)
+                         (CONS . I.\CONS.UFN))
+
+(ADDTOVAR RD.SUBFNS (\ADDBASE . VADDBASE)
+                        (\GETBASE . VGETBASE)
+                        (\PUTBASE . VPUTBASE)
+                        (\GETBASEPTR . VGETBASEPTR)
+                        (\PUTBASEPTR . VPUTBASEPTR)
+                        (\HILOC . VHILOC)
+                        (\LOLOC . VLOLOC)
+                        (\VAG2 . VVAG2)
+                        (.COERCE.TO.SMALLPOSP. . PROG1)
+                        (.COERCE.TO.BYTE. . PROG1)
+                        (PTRGTP . IGREATERP)
+                        (\RPLPTR . VPUTBASEPTR)
+                        (CAR . V\CAR.UFN)
+                        (CDR . V\CDR.UFN)
+                        (CAR/CDRERR . T))
+EVAL@COMPILE 
+
+(ADDTOVAR DONTCOMPILEFNS CREATEPAGES)
+)
+
+
+
+(* ; "cons cells")
+
+(DEFINEQ
+
+(CONS
+  [LAMBDA (X Y)                                          (* lmm "11-FEB-82 13:55")
+                                                             (* ; 
+                                                           "use microcode UFN to get to \CONS.UFN")
+    ((OPCODES CONS)
+     X Y])
+
+(\CONS.UFN
+  [LAMBDA (X Y)                                          (* ; "Edited  8-Dec-92 16:46 by jds")
+    [COND
+       ((ZEROP CDRCODING)
+        (RAID)
+        (PROG ((CELL (CREATECELL \LISTP)))
+              (replace (LISTP CAR) of CELL with X)
+              (replace (LISTP CDR) of CELL with Y)
+              (RETURN CELL]
+    (UNINTERRUPTABLY
+        (\ADDREF X)
+        (\ADDREF Y)
+        (\StatsAdd1 (fetch DTDCNTLOC of \LISTPDTD))
+        (.INCREMENT.ALLOCATION.COUNT. 1)
+        (PROG (CNS.PAGE CELL)
+              [SETQ CNS.PAGE (COND
+                                ((NOT Y)
+                                 [COND
+                                    ((AND (SETQ CNS.PAGE (CREATE POINTER
+                                                                PAGE# _ (FETCH DTDNEXTPAGE
+                                                                           OF \LISTPDTD)))
+                                          (IGREATERP (FETCH (CONSPAGE CNT) OF CNS.PAGE)
+                                                 0)))
+                                    (T (SETQ CNS.PAGE (\NEXTCONSPAGE]
+                                 (.MAKECONSCELL. CNS.PAGE X \CDR.NIL))
+                                ((AND (EQ (NTYPX Y)
+                                             \LISTP)
+                                      (IGREATERP (fetch (CONSPAGE CNT)
+                                                    of (SETQ CNS.PAGE (fetch (POINTER 
+                                                                                            PAGEBASE)
+                                                                             of Y)))
+                                             0)
+                                      (SETQ CELL (.FINDCLOSEPRIOR. CNS.PAGE X Y)))
+
+                                 (* ;; 
+         "Test for any cells left on page --- NTYPX rather than LISTP test for benefit of MAKEINIT")
+                                                             (* .MAKECONSCELL. CNS.PAGE X
+                                                           (IPLUS \CDR.ONPAGE
+                                                           (fetch (POINTER DBLWORD#) of Y)))
+                                 CELL)
+                                (T (.FINDPAIR. X Y]
+              (\DELREF CNS.PAGE)
+              (RETURN CNS.PAGE)))])
+
+(\MAIKO.CONS.UFN
+  [LAMBDA (X Y)                                          (* ; "Edited  3-Jun-90 21:03 by nm")
+
+    (* ;; "Maiko specific \CONS.UFN. Does not decrement \RECLAIM.COUNTDOWN.")
+
+    [COND
+       ((ZEROP CDRCODING)
+        (RAID)
+        (PROG ((CELL (CREATECELL \LISTP)))
+              (replace (LISTP CAR) of CELL with X)
+              (replace (LISTP CDR) of CELL with Y)
+              (RETURN CELL]
+    (UNINTERRUPTABLY
+        (\ADDREF X)
+        (\ADDREF Y)
+        (\StatsAdd1 (fetch DTDCNTLOC of \LISTPDTD))
+        (.CHECK.ALLOCATION.COUNT. 1)
+        (PROG (CNS.PAGE)
+              [SETQ CNS.PAGE (COND
+                                [(AND (EQ (NTYPX Y)
+                                             \LISTP)
+                                      (IGREATERP (fetch (CONSPAGE CNT)
+                                                    of (SETQ CNS.PAGE (fetch (POINTER 
+                                                                                            PAGEBASE)
+                                                                             of Y)))
+                                             0))             (* ; 
+         "Test for any cells left on page --- NTYPX rather than LISTP test for benefit of MAKEINIT")
+                                 (.MAKECONSCELL. CNS.PAGE X (IPLUS \CDR.ONPAGE (fetch
+                                                                                (POINTER DBLWORD#)
+                                                                                  of Y]
+                                (T (.MAKECONSCELL. (SETQ CNS.PAGE (\NEXTCONSPAGE))
+                                          X
+                                          (COND
+                                             ((NULL Y)
+                                              \CDR.NIL)
+                                             (T (IPLUS \CDR.INDIRECT (fetch (POINTER DBLWORD#)
+                                                                        of (.MAKECONSCELL. 
+                                                                                      CNS.PAGE Y 0]
+              (\DELREF CNS.PAGE)
+              (RETURN CNS.PAGE)))])
+
+(CAR
+  [LAMBDA (X)                                            (* lmm "11-FEB-82 13:56")
+    ((OPCODES CAR)
+     X])
+
+(\CAR.UFN
+  [LAMBDA (X)                                            (* lmm "18-Jul-84 00:07")
+
+    (* ;; "most cases handled in microcode --- this code also used by MAKEINIT/READSYS")
+
+    (\CALLME 'CAR)
+    (COND
+       [(LISTP X)
+        (COND
+           ((ZEROP CDRCODING)
+            (fetch (LISTP CAR) of X))
+           (T (COND
+                 ((EQ (fetch CDRCODE of X)
+                         \CDR.INDIRECT)
+                  (fetch CARFIELD of (fetch CARFIELD of X)))
+                 (T (fetch CARFIELD of X]
+       ((NULL X)
+        NIL)
+       (T (SELECTQ CAR/CDRERR
+              (T (LISPERROR "ARG NOT LIST" X))
+              ((NIL CDR) 
+                   (COND
+                      ((EQ X T)
+                       T)
+                      ((LITATOM X)
+                       NIL)
+                      (T '"{car of non-list}")))
+              (COND
+                 ((EQ X T)
+                  T)
+                 ((STRINGP X)
+                  (LISPERROR "ARG NOT LIST" X))
+                 (T '"{car of non-list}"])
+
+(CDR
+  [LAMBDA (X)                                            (* lmm "11-FEB-82 13:56")
+    ((OPCODES CDR)
+     X])
+
+(\CDR.UFN
+  [LAMBDA (X)                                            (* lmm "17-Jul-84 22:26")
+
+    (* ;; "most cases handled in microcode --- this code also used by MAKEINIT/READSYS")
+
+    (\CALLME 'CDR)
+    (COND
+       [(LISTP X)
+        (COND
+           ((ZEROP CDRCODING)
+            (fetch (LISTP CDR) of X))
+           (T (PROG ((Q (fetch CDRCODE of X)))
+                    (RETURN (COND
+                               ((EQ Q \CDR.NIL)
+                                NIL)
+                               ((IGREATERP Q \CDR.ONPAGE)
+                                (\ADDBASE (fetch (POINTER PAGEBASE) of X)
+                                       (LLSH (IDIFFERENCE Q \CDR.ONPAGE)
+                                             1)))
+                               ((EQ Q \CDR.INDIRECT)
+                                (\CDR.UFN (fetch CARFIELD of X)))
+                               (T (fetch CARFIELD of (\ADDBASE (fetch PAGEBASE
+                                                                              of X)
+                                                                    (LLSH Q 1]
+       ((NULL X)
+        NIL)
+       (T (SELECTQ CAR/CDRERR
+              ((T CDR) 
+                   (LISPERROR "ARG NOT LIST" X))
+              (NIL (COND
+                      ((LITATOM X)
+                       (GETPROPLIST X))
+                      (T "{cdr of non-list}")))
+              (COND
+                 ((STRINGP X)
+                  (LISPERROR "ARG NOT LIST" X))
+                 (T "{cdr of non-list}"])
+
+(RPLACA
+  [LAMBDA (X Y)                                          (* lmm "11-FEB-82 13:55")
+                                                             (* ; "invoke \RPLACA.UFN")
+    ((OPCODES RPLACA)
+     X Y])
+
+(\RPLACA.UFN
+  [LAMBDA (X Y)                                          (* lmm " 1-DEC-81 21:17")
+    (COND
+       [(NLISTP X)
+        (COND
+           [(NULL X)                                         (* ; "if X is NIL and Y is NIL ok")
+            (COND
+               (Y (LISPERROR "ATTEMPT TO RPLAC NIL" Y]
+           (T (LISPERROR "ARG NOT LIST" X]
+       (T (COND
+             ((ZEROP CDRCODING)
+              (replace (LISTP CAR) of X with Y)
+              X)
+             (T (UNINTERRUPTABLY
+                    (\DELREF (CAR X))
+                    (\ADDREF Y)
+                    (replace CARFIELD of (COND
+                                                    ((EQ (fetch CDRCODE of X)
+                                                            \CDR.INDIRECT)
+                                                     (fetch CARFIELD of X))
+                                                    (T X)) with Y)
+                    X)])
+
+(RPLACD
+  [LAMBDA (X Y)                                          (* lmm "11-FEB-82 13:55")
+    ((OPCODES RPLACD)
+     X Y])
+
+(\RPLACD.UFN
+  [LAMBDA (X Y)                                          (* lmm "11-JAN-82 10:15")
+    (COND
+       [(NLISTP X)
+        (COND
+           [(NULL X)                                         (* ; "if X is NIL and Y is NIL ok")
+            (COND
+               (Y (LISPERROR "ATTEMPT TO RPLAC NIL" Y]
+           (T (LISPERROR "ARG NOT LIST" X]
+       ((ZEROP CDRCODING)
+        (replace (LISTP CDR) of X with Y)
+        X)
+       (T (UNINTERRUPTABLY
+              (\DELREF (CDR X))
+              (\ADDREF Y)
+              (PROG (RP.PAGE (RP.Q (fetch CDRCODE of X)))
+                    (COND
+                       ((EQ RP.Q \CDR.INDIRECT)
+                        (SETQ RP.PAGE (fetch CARFIELD of X))
+                        (CHECK (ILEQ (fetch CDRCODE of RP.PAGE)
+                                     \CDR.MAXINDIRECT)
+                               (NEQ (fetch CDRCODE of RP.PAGE)
+                                    \CDR.INDIRECT))
+                        (SETQ RP.PAGE (\ADDBASE (fetch PAGEBASE of RP.PAGE)
+                                             (LLSH (IDIFFERENCE (fetch CDRCODE of RP.PAGE)
+                                                          \CDR.INDIRECT)
+                                                   1)))
+                        (CHECK (LISTP RP.PAGE)
+                               (EQ 0 (fetch CDRCODE of RP.PAGE)))
+                        (replace FULLCARFIELD of RP.PAGE with Y))
+                       ((ILEQ RP.Q \CDR.MAXINDIRECT)
+                        (SETQ RP.PAGE (\ADDBASE (fetch PAGEBASE of X)
+                                             (LLSH (IDIFFERENCE RP.Q \CDR.INDIRECT)
+                                                   1)))
+                        (CHECK (LISTP RP.PAGE)
+                               (EQ 0 (fetch CDRCODE of RP.PAGE)))
+                        (replace FULLCARFIELD of RP.PAGE with Y))
+                       ((NULL Y)
+                        (replace CDRCODE of X with \CDR.NIL))
+                       [(EQ (SETQ RP.PAGE (fetch PAGEBASE of X))
+                               (fetch PAGEBASE of Y))(* ; "New CDR on same page")
+                        (replace CDRCODE of X with (IPLUS \CDR.ONPAGE (fetch
+                                                                                   (POINTER DBLWORD#)
+                                                                                     of Y]
+                       [(IGREATERP (fetch (CONSPAGE CNT) of RP.PAGE)
+                               0)                            (* ; "Room on page for cdr cell")
+                        (replace CDRCODE of X with (IPLUS \CDR.INDIRECT
+                                                                      (fetch (POINTER DBLWORD#)
+                                                                         of (.MAKECONSCELL.
+                                                                                 RP.PAGE Y 0]
+                       (T [replace FULLCARFIELD of X
+                             with (.MAKECONSCELL. (SETQ RP.PAGE (\NEXTCONSPAGE))
+                                             (fetch CARFIELD of X)
+                                             (IPLUS \CDR.INDIRECT (fetch (POINTER DBLWORD#)
+                                                                     of (.MAKECONSCELL. RP.PAGE Y
+                                                                                   0]
+                          (replace CDRCODE of X with \CDR.INDIRECT)))
+                    (RETURN X)))])
+
+(DOCOLLECT
+  [LAMBDA (ITEM LST)                                     (* lmm%: "30-SEP-76 13:03:33")
+    (COND
+       ((NLISTP LST)
+        (FRPLACD (SETQ LST (LIST ITEM))
+               LST))
+       (T (CDR (FRPLACD LST (CONS ITEM (CDR LST])
+
+(\RPLCONS
+  [LAMBDA (LST ITEM)                                     (* bvm%: " 5-Feb-85 22:49")
+                                                             (* (CDR (RPLACD LST
+                                                           (CONS ITEM NIL))))
+    (COND
+       [(AND (NEQ CDRCODING 0)
+             (LISTP LST)
+             (UNINTERRUPTABLY
+                 
+                 (* ;; "Have to go uninterruptable here so that someone doesn't change the CNT field to zero out from under us")
+
+                 [PROG ((CPAGE (fetch (POINTER PAGEBASE) of LST))
+                        CELL)
+                       (RETURN (COND
+                                  ((AND (NEQ (fetch (CONSPAGE CNT) of CPAGE)
+                                             0)
+                                        (IGREATERP (fetch CDRCODE of LST)
+                                               \CDR.MAXINDIRECT))
+                                   (\ADDREF ITEM)
+                                   (\DELREF (CDR LST))
+                                   (SETQ CELL (.MAKECONSCELL. CPAGE ITEM \CDR.NIL))
+                                   (\StatsAdd1 (fetch DTDCNTLOC of \LISTPDTD))
+                                   (.INCREMENT.ALLOCATION.COUNT. 1)
+                                   (replace CDRCODE of LST with
+                                                                   (IPLUS \CDR.ONPAGE
+                                                                          (fetch (POINTER 
+                                                                                            DBLWORD#)
+                                                                             of CELL)))
+                                   CELL])]
+       (T (SETQ ITEM (CONS ITEM NIL))                    (* ; 
+             "Have to be careful how this part is written, or compiler will turn it into RPLCONS !")
+          (RPLACD LST ITEM)
+          ITEM])
+
+(ENDCOLLECT
+  [LAMBDA (X Y)                                          (* lmm "21-MAR-81 13:37")
+    (COND
+       ((NULL X)
+        Y)
+       (T (PROG1 (CDR X)
+                 (RPLACD X Y])
+
+(\INITCONSPAGE
+  [LAMBDA (BASE LINK)                                    (* ; "Edited  4-Dec-92 04:13 by jds")
+    (COND
+       ((ZEROP CDRCODING)
+        (RAID))
+       (T (PROG ((J (replace (CONSPAGE NEXTCELL) of BASE with 254))
+                 CELL)
+            LP  (COND
+                   ((IGREATERP J 4)
+                    (SETQ CELL (\ADDBASE BASE J))
+                    (replace (LISTP FULLCARFIELD) of CELL with NIL)
+                    (replace (LISTP NEXTFREE) of CELL with (SETQ J (IDIFFERENCE J 2)))
+                    (GO LP)))
+                (replace (CONSPAGE CNT) of BASE with 126)
+                                                             (* ; 
+                            "if LINK=NIL, stores a 0. This assumes that the pagebase of NIL is NIL")
+                (replace NEXTPAGE of BASE with (fetch (POINTER PAGE#) of LINK))
+                (RETURN BASE])
+
+(\NEXTCONSPAGE
+  [LAMBDA NIL                                            (* ; "Edited  8-Dec-92 01:57 by jds")
+    (CHECK (NULL \INTERRUPTABLE))
+    (PROG ((N (fetch DTDNEXTPAGE of \LISTPDTD))
+           PG)
+          (SETQ PG (\ALLOCMDSPAGE (fetch DTDTYPEENTRY of \LISTPDTD)))
+          (\INITCONSPAGE PG (\INITCONSPAGE (\ADDBASE PG WORDSPERPAGE)
+                                       (CREATE POINTER
+                                              PAGE# _ N)))
+          (replace DTDNEXTPAGE of \LISTPDTD with (PAGELOC PG))
+          (RETURN PG])
+)
+
+(ADDTOVAR \MAIKO.MOVDS (\MAIKO.CONS.UFN \CONS.UFN))
+(DEFINEQ
+
+(\RESTLIST.UFN
+  [LAMBDA (TAIL LASTN FIRSTN)                            (* bvm%: "31-Aug-86 16:30")
+
+(* ;;; "Handles &REST args by building a list of the args from FIRSTN thru LASTN, all consed onto the front of TAIL, which could be non-NIL in the case where the microcode has started the job")
+
+    (COND
+       (TAIL                                                 (* ; 
+                                                        "Some already done, better take care of gc")
+             (\GC.HANDLEOVERFLOW)))
+    (LET* [(CALLER (\MYALINK))
+           (BLINK (fetch (FX BLINK) of CALLER))
+           (IVAR (fetch (BF IVAR) of BLINK))
+           (BASE (STACKADDBASE (IDIFFERENCE IVAR WORDSPERCELL]
+          (for I from LASTN to FIRSTN by -1
+             do (SETQ TAIL (CONS (\GETBASEPTR BASE (UNFOLD I WORDSPERCELL))
+                                      TAIL)) 
+
+                   (* ;; "Might want to experiment with stopping after one iteration to let the microcode do the rest of the consing")
+ finally (RETURN TAIL])
+
+(\FINDKEY.UFN
+  [LAMBDA (KEY ARGN)                                     (* bvm%: "15-Jul-86 16:51")
+
+(* ;;; "Searches argument list of current function for an argument EQ to KEY.  Search starts at the argument index given as the alpha byte ARGN and examines every other argument.  The first arg is numbered 1; i.e., arg(i) is located at ivar0 + 2*(i-1).  If KEY is found as arg i, returns i+1 (which is later to be fed to ARG0); otherwise returns NIL.")
+
+    (LET* [(CALLER (\MYALINK))
+           (BLINK (fetch (FX BLINK) of CALLER))
+           (IVAR (fetch (BF IVAR) of BLINK))
+           (NARGS (SUB1 (FOLDLO (IDIFFERENCE BLINK IVAR)
+                               WORDSPERCELL]
+          (for I from ARGN to NARGS by 2
+             as [BASE _ (STACKADDBASE (PLUS IVAR (UNFOLD (SUB1 ARGN)
+                                                            WORDSPERCELL]
+             by (\ADDBASE BASE (TIMES 2 WORDSPERCELL)) when (EQ (\GETBASEPTR
+                                                                                 BASE 0)
+                                                                               KEY)
+             do (RETURN (ADD1 I])
+)
+
+(RPAQ? CAR/CDRERR 'CDR)
+(DECLARE%: DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS CAR/CDRERR)
+)
+
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
+
+(BLOCKRECORD LISTP (
+                        (* ;; "Describes a CONS cell.")
+
+                        (CAR POINTER)
+                        (CDR POINTER))
+                       (CREATE (CREATECELL \LISTP))
+
+                       (* ;; "FOLLOWING ARE CDR-CODE FIELDS")
+
+                       (BLOCKRECORD LISTP ((CDRCODE BITS 4)
+                                           (CARFIELD XPOINTER)))
+
+                       (* ;; "For chaining together free cells on a page:")
+
+                       (BLOCKRECORD LISTP ((NEXTFREE BYTE)
+                                           (NIL BITS 24)))
+                       [ACCESSFNS LISTP ((FULLCARFIELD NIL (\PUTBASEPTR DATUM 0 NEWVALUE]
+
+                       (* ;; "because replace of XPOINTER is slow, the CAR field is stored with PUTBASEPTR, even though that smashes the hi byte")
+
+                       )
+
+(BLOCKRECORD CONSPAGE ((CNT BYTE)
+                           (NEXTCELL BYTE)
+                           (NIL WORD)
+                           (NEXTPAGE FIXP)))
+)
+
+(RPAQQ CONSCONSTANTS (\CDR.ONPAGE \CDR.NIL \CDR.INDIRECT \CDR.MAXINDIRECT \CONSPAGE.LAST))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \CDR.ONPAGE 8)
+
+(RPAQQ \CDR.NIL 8)
+
+(RPAQQ \CDR.INDIRECT 0)
+
+(RPAQQ \CDR.MAXINDIRECT 7)
+
+(RPAQQ \CONSPAGE.LAST 65535)
+
+
+(CONSTANTS \CDR.ONPAGE \CDR.NIL \CDR.INDIRECT \CDR.MAXINDIRECT \CONSPAGE.LAST)
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS .MAKECONSCELL. MACRO (OPENLAMBDA (PAGE A D)
+                                              (PROG [(.MK.NEWCELL (\ADDBASE PAGE
+                                                                         (fetch (CONSPAGE 
+                                                                                           NEXTCELL)
+                                                                            of PAGE]
+                                                    (CHECK (NEQ (fetch (CONSPAGE CNT)
+                                                                   of PAGE)
+                                                                0)
+                                                           (EVENP (fetch (CONSPAGE NEXTCELL)
+                                                                     of PAGE)))
+                                                    (replace (CONSPAGE NEXTCELL) of PAGE
+                                                       with (fetch (LISTP NEXTFREE)
+                                                                   of .MK.NEWCELL))
+                                                    (CHECK (EVENP (fetch (CONSPAGE NEXTCELL)
+                                                                     of PAGE)))
+                                                    (add (fetch (CONSPAGE CNT) of PAGE)
+                                                           -1)
+                                                    (replace (LISTP FULLCARFIELD) of 
+                                                                                          .MK.NEWCELL
+                                                       with A)
+                                                    (replace (LISTP CDRCODE) of .MK.NEWCELL
+                                                       with D)
+                                                    (RETURN .MK.NEWCELL))))
+
+(PUTPROPS .FINDCLOSEPRIOR. MACRO
+          [OPENLAMBDA (PG A D)
+                 (LET ((CDROFFSET (LOGAND (\LOLOC D)
+                                         255))
+                       (OFFSET (fetch (CONSPAGE NEXTCELL) of PG))
+                       CELL PRIOR)
+                      (WHILE (NEQ OFFSET 0)
+                         DO (COND
+                                   ((AND (ILEQ OFFSET CDROFFSET)
+                                         (IGEQ OFFSET (IDIFFERENCE CDROFFSET 14)))
+
+                                    (* ;; 
+                               "There's a cell close enough.  Take it off the chain and return it.")
+
+                                    [COND
+                                       [PRIOR 
+                                              (* ;; 
+                                           "There was a prior entry in the chain; detach this one.")
+
+                                              (REPLACE (LISTP NEXTFREE) OF (\ADDBASE
+                                                                                    PG PRIOR)
+                                                 WITH (FETCH (LISTP NEXTFREE)
+                                                             OF (SETQ CELL (\ADDBASE PG 
+                                                                                      OFFSET]
+                                       (T 
+                                          (* ;; 
+                                        "No prior entry; set the conspage's NEXTCELL entry.")
+
+                                          (REPLACE (CONSPAGE NEXTCELL) OF PG
+                                             WITH (FETCH (LISTP NEXTFREE)
+                                                         OF (SETQ CELL (\ADDBASE PG OFFSET]
+                                    (add (fetch (CONSPAGE CNT) of PG)
+                                           -1)
+                                    (replace (LISTP FULLCARFIELD) of CELL with A)
+                                    (replace (LISTP CDRCODE) of CELL
+                                       with (LOGOR \CDR.ONPAGE (LRSH (IDIFFERENCE CDROFFSET 
+                                                                                OFFSET)
+                                                                         1)))
+                                    (RETURN CELL)))
+                               (SETQ PRIOR OFFSET)
+                               (SETQ OFFSET (FETCH (LISTP NEXTFREE) OF (\ADDBASE PG 
+                                                                                      OFFSET])
+
+(PUTPROPS .FINDCDRABLEPAIR. MACRO
+          [OPENLAMBDA (PG A D)
+                 (LET ((OFFSET (fetch (CONSPAGE NEXTCELL) of PG))
+                       CELL PRIOR PRIORPRIOR)
+                      (AND (IGEQ (FETCH (CONSPAGE CNT) OF PG)
+                                 2)
+                           (WHILE (NEQ OFFSET 0)
+                              DO (COND
+                                        ((AND PRIOR (ILEQ OFFSET PRIOR)
+                                              (IGEQ OFFSET (IDIFFERENCE PRIOR 14)))
+
+                                         (* ;; 
+                               "There's a cell close enough.  Take it off the chain and return it.")
+
+                                         [COND
+                                            [PRIORPRIOR 
+
+                                                   (* ;; 
+                                           "There was a prior entry in the chain; detach this one.")
+
+                                                   (REPLACE (LISTP NEXTFREE)
+                                                      OF (\ADDBASE PG PRIORPRIOR)
+                                                      WITH (FETCH (LISTP NEXTFREE)
+                                                                  OF (SETQ CELL (\ADDBASE
+                                                                                     PG OFFSET]
+                                            (T 
+                                               (* ;; 
+                                             "No prior entry; set the conspage's NEXTCELL entry.")
+
+                                               (REPLACE (CONSPAGE NEXTCELL) OF PG
+                                                  WITH (FETCH (LISTP NEXTFREE)
+                                                              OF (SETQ CELL (\ADDBASE PG 
+                                                                                       OFFSET]
+                                         (add (fetch (CONSPAGE CNT) of PG)
+                                                -2)
+                                         (\PUTBASEPTR (\ADDBASE PG PRIOR)
+                                                0 D)
+                                         (REPLACE (LISTP FULLCARFIELD) OF CELL WITH
+                                                                                       A)
+                                         (REPLACE (LISTP CDRCODE) OF CELL
+                                            WITH (LRSH (IDIFFERENCE PRIOR OFFSET)
+                                                           1))
+                                         (RETURN CELL)))
+                                    (SETQ PRIORPRIOR PRIOR)
+                                    (SETQ PRIOR OFFSET)
+                                    (SETQ OFFSET (FETCH (LISTP NEXTFREE) OF (\ADDBASE
+                                                                                     PG OFFSET])
+
+(PUTPROPS .FINDPAIR. MACRO [OPENLAMBDA (A D)
+                                          (LET ((PG (fetch DTDNEXTPAGE of \LISTPDTD))
+                                                CELL CPG)
+                                               [WHILE (IGREATERP PG 0)
+                                                  DO (COND
+                                                            ((SETQ CELL
+                                                              (.FINDCDRABLEPAIR. (SETQ CPG
+                                                                                  (CREATE POINTER
+                                                                                         PAGE# _ PG))
+                                                                     A D))
+                                                             (RETURN CELL))
+                                                            (T (SETQ PG (FETCH (CONSPAGE NEXTPAGE
+                                                                                          )
+                                                                           OF CPG]
+                                               (OR CELL (.FINDCDRABLEPAIR. (\NEXTCONSPAGE)
+                                                               A D])
+)
+
+
+(ADDTOVAR INEWCOMS (FNS \CONS.UFN \MAIKO.CONS.UFN \INITCONSPAGE \NEXTCONSPAGE))
+
+(ADDTOVAR EXPANDMACROFNS .MAKECONSCELL. .FINDCLOSEPRIOR. .FINDCDRABLEPAIR. .FINDPAIR.)
+)
+
+
+
+(* ; "testing out CONSes")
+
+(DEFINEQ
+
+(CHECKCONSPAGES
+  [LAMBDA NIL                                            (* bvm%: "29-Jan-85 22:51")
+    (COND
+       ((ZEROP CDRCODING)
+        NIL)
+       (T [for (CPAGE _ (create POINTER
+                                   PAGE# _ (fetch DTDNEXTPAGE of \LISTPDTD)))
+             do (COND
+                       ((NULL CPAGE)                         (* ; "End of free list")
+                        (RETURN))
+                       ((NEQ (NTYPX CPAGE)
+                             \LISTP)
+
+                        (* ;; "Free list not pointing at a cons page.  Test is not for LISTP because LISTP is formally defined to be false for list page bases")
+
+                        (HELP CPAGE))
+                       (T (SETQ CPAGE (create POINTER
+                                             PAGE# _ (fetch (CONSPAGE NEXTPAGE) of CPAGE]
+          (\MAPMDS 'LISTP (FUNCTION \CHECKCONSPAGE])
+
+(\CHECKCONSPAGE
+  [LAMBDA (PN)                                           (* bvm%: "27-Jan-85 14:52")
+                                                             (* ; "check if page PN is ok")
+    (PROG ((PTR (create POINTER
+                       PAGE# _ PN))
+           NXT CNT)
+          (SETQ CNT (fetch (CONSPAGE CNT) of PTR))
+          (!CHECK (EVENP (SETQ NXT (fetch (CONSPAGE NEXTCELL) of PTR))
+                         WORDSPERCELL))
+      LP  (COND
+             ((IGREATERP CNT 0)
+              (!CHECK (AND (NEQ NXT 0)
+                           (EVENP (SETQ NXT (fetch (LISTP CDRCODE) of (\ADDBASE PTR NXT))
+                                   )
+                                  WORDSPERCELL)))
+              (add CNT -1)
+              (GO LP)))
+          (!CHECK (EQ NXT 0])
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS !CHECK MACRO [(X)
+                                (OR X (RAID 'X])
+)
+)
+
+
+
+(* ; "other random stuff for makeinit")
+
+(DEFINEQ
+
+(MAKEINITFIRST
+  [LAMBDA NIL                                            (* bvm%: "13-Jun-86 15:41")
+    (CREATEMDSTYPETABLE)
+    (\SETUP.HUNK.TYPENUMBERS)
+    (INITDATATYPES)
+    (PREINITARRAYS)
+    (\TURN.ON.HUNKING)
+    (INITATOMS)
+    (INITDATATYPENAMES)
+    (INITUFNTABLE)
+    (INITGC)
+    (\NEWPAGE \InterfacePage NIL T])
+
+(MAKEINITLAST
+  [LAMBDA (VERSIONS)                                     (* Pavel "17-Oct-86 12:42")
+    (SETUPSTACK T)
+    (MAKEINITBFS)
+    (PROGN                                                   (* ; 
+                                        "fold in property list and values gathered from boot files")
+           [SELECTQ (SYSTEMTYPE)
+               ((D ALTO) 
+                    [LOCAL (MAPHASH MKI.PLHA (FUNCTION (LAMBDA (P A)
+                                                         (SETPROPLIST A (COPY P]
+                    [LOCAL (MAPHASH MKI.TVHA (FUNCTION (LAMBDA (V A)
+                                                         (SETTOPVAL A (COPY (LOCAL (CDR V])
+               (PROG (AL GAG)
+
+                (* ;; "the reason this is set up this way is because there is a bug in Interlisp-10 suchthat if a garbage collection happens in the middle of a MAPHASH, some of the values in the hash array may be missed because the garbage collector has moved stuff around and rehashed the data in the array.  Thus we are careful to set things up so that no garbage collection happens")
+
+                     [ALLOCAL (PROGN [MINFS (IMAX (MINFS)
+                                                  (ITIMES 2 (ARRAYSIZE (CAR MKI.PLHA)))
+                                                  (ARRAYSIZE (CAR MKI.TVHA]
+                                     (RECLAIM)
+                                     (SETQ GAG (GCGAG "[***** GARBAGE COLLECTION - ERROR ******]"))
+                                     [MAPHASH MKI.PLHA (FUNCTION (LAMBDA (P A)
+                                                                   (push AL (CONS A P]
+                                     (SETQ GAG (GCGAG GAG]
+                     [LOCAL (MAPC AL (FUNCTION (LAMBDA (X)
+                                                 (SETPROPLIST (CAR X)
+                                                        (COPY (CDR X]
+                     (ALLOCAL (PROGN (SETQ AL)
+                                     (RECLAIM)
+                                     (SETQ GAG (GCGAG GAG))
+                                     [MAPHASH MKI.TVHA (FUNCTION (LAMBDA (V A)
+                                                                   (push AL (RPLACA V A]
+                                     (GCGAG GAG)))
+                     (LOCAL (MAPC AL (FUNCTION (LAMBDA (X)
+                                                 (SETTOPVAL (CAR X)
+                                                        (COPY (CDR X]
+                                                             (* ; "set most initial variables")
+           )
+    (PROG ((AFL (FILEARRAYBASE)))                            (* ; 
+                                "put output on a double page boundary --- output at least one page")
+          [LOCAL (BOUTZEROS (IDIFFERENCE (TIMES 2 BYTESPERPAGE)
+                                   (UNFOLD (IMOD (\LOLOC AFL)
+                                                 (TIMES 2 WORDSPERPAGE))
+                                          BYTESPERWORD]
+          (SETQ MKI.CODELASTPAGE (PAGELOC (FILEARRAYBASE)))
+
+     (* ;; "now we can update the string/array space freelist to point beyond the code area --- We call POSTINITARRAYS with (a) pointer to word after end of compiled code, (b) page number of beginning of compiled code, and (c) page number after compiled code")
+
+          (POSTINITARRAYS AFL (IPLUS \FirstArrayPage MKI.CODESTARTOFFSET)
+                 MKI.CODELASTPAGE))
+    [MAPC (ALLOCAL (APPEND INITVALUES INITPTRS))
+          (FUNCTION (LAMBDA (X)                              (* ; 
+                                                          "make sure atoms exist for initial atoms")
+                      (\ATOMVALINDEX (LOCAL (CAR X]
+    [for X in INITVALUES as A in MKI.VALUES
+       do (SETQ A (LOCAL (EVALV A)))
+             (SETTOPVAL (LOCAL (CAR X))
+                    (COND
+                       ([ALLOCAL (OR (EQ A T)
+                                     (EQ A NIL)
+                                     (AND (FIXP A)
+                                          (IGEQ A -65536)
+                                          (ILEQ A 65535]
+                        (COPY A))
+                       (T (SHOULDNT]
+    [for X in INITPTRS as A in MKI.PTRS do (SETTOPVAL (LOCAL (CAR X))
+                                                                      (LOCAL (EVALV A]
+    (for X in LOCKEDVARS do 
+
+                                 (* ;; "If the variable exists, then we lock it.  Otherwise, just print a message and proceed anyway, hoping the fellow knows what he's doing.  We don't want to create a new piece of storage at this point because we've already made a note of where our last allocated page is.")
+
+                                       (IF (GETHASH X MKI.ATOMARRAY)
+                                           THEN (\LOCKVAR X)
+                                         ELSE (printout T "***Note: Locked var " X 
+                                                         " does not exist, proceeding anyway." T)))
+    (SETUPPAGEMAP)
+    (DUMPINITPAGES (IPLUS \FirstArrayPage MKI.CODESTARTOFFSET)
+           MKI.CODELASTPAGE VERSIONS])
+
+(\COPY
+  [LAMBDA (X)                                            (* ; "Edited 28-Jan-93 17:42 by jds")
+
+    (* ;; "Prints X into the MAKEINIT / READSYS system")
+
+    (SELECTQ (LOCAL (TYPENAME X))
+        ((LITATOM NEW-ATOM) 
+             (UNLESSRDSYS (MKI.ATOM X)
+                    (VATOMNUMBER X T)))
+        (LISTP (PROG [(R (LOCAL (REVERSE X)))
+                      (V (\COPY (LOCAL (CDR (LOCAL (LAST X]
+                 LP  (COND
+                        ((LOCAL (LISTP R))
+                         (SETQ V (CONS (\COPY (LOCAL (CAR R)))
+                                        V))
+                         (SETQ R (LOCAL (CDR R)))
+                         (GO LP)))
+                     (RETURN V)))
+        ((FIXP SMALLP) 
+             (PROG (V)
+                   [COND
+                      [(LOCAL (IGREATERP 0 X))               (* ; "negative")
+                       (COND
+                          ((LOCAL (IGREATERP X -65537))      (* ; "small neg")
+                           (RETURN (\ADDBASE \SMALLNEGSPACE (LOCAL (LOGAND X 65535]
+                      ((LOCAL (ILESSP X 65536))              (* ; "small pos")
+                       (RETURN (\ADDBASE \SMALLPOSPSPACE X]
+                                                             (* ; "need to create a boxed integer")
+                   (SETQ V (CREATECELL \FIXP))
+                   (\PUTBASE V 0 (LOGOR (COND
+                                               ((IGREATERP 0 X)
+                                                32768)
+                                               (T 0))
+                                            (LOGAND (LRSH X 16)
+                                                   32767)))
+                   (\PUTBASE V 1 (LOGAND X 65535))
+                   (RETURN V)))
+        (ONED-ARRAY (%%COPY-ONED-ARRAY X))
+        (STRINGP                                             (* ; "For bootstrapping only")
+                 (%%COPY-STRING-TO-ARRAY X))
+        (FLOATP (PROG ((VAL (CREATECELL \FLOATP)))
+                      (SELECTQ (SYSTEMTYPE)
+                          ((ALTO D) 
+                               (\PUTBASE VAL 0 (LOCAL (\GETBASE X 0)))
+                               (\PUTBASE VAL 1 (LOCAL (\GETBASE X 1))))
+                          (MKI.IEEE X VAL))
+                      (RETURN VAL)))
+        (CHARACTER (\VAG2 \CHARHI (LOCAL (LISP:CHAR-CODE X))))
+        (ERROR X "can't be copied to remote file"])
+
+(\UNCOPY
+  [LAMBDA (X CARLVL CDRLVL)                              (* ; "Edited 18-Mar-87 16:51 by raf")
+    (SELECTC (NTYPX X)
+        (\SMALLP (COND
+                    ((EQ (\HILOC X)
+                            \SmallPosHi)
+
+                     (* ;; "This test used to be SMALLPOSP until its definition changed to test (IGREATERP X 0), which doesn't work renamed")
+
+                     (\LOLOC X))
+                    (T (IPLUS (\LOLOC X)
+                              -65536))))
+        (\FIXP                                               (* ; "INTEGER")
+               (LOCAL (create FIXP
+                             HINUM _ (ffetch (FIXP HINUM) of X)
+                             LONUM _ (ffetch (FIXP LONUM) of X))))
+        (\FLOATP (LOCAL (create FLOATP
+                               HIWORD _ (ffetch (FLOATP HIWORD) of X)
+                               LOWORD _ (ffetch (FLOATP LOWORD) of X))))
+        (\LITATOM (VATOM (\LOLOC X)))
+        (\STRINGP (PROG ((PTR (ffetch (STRINGP BASE) of X))
+                         (OFFST (ffetch (STRINGP OFFST) of X))
+                         (LENGTH (ffetch (STRINGP LENGTH) of X))
+                         (I 1)
+                         STR)                                (* ; 
+                                         "Use ffetch to avoid bogus DTEST's in the renamed version")
+                        (SETQ STR (LOCAL (ALLOCSTRING LENGTH)))
+                        (FRPTQ LENGTH [LOCAL (RPLSTRING STR I (LOCAL (FCHARACTER (\GETBASEBYTE
+                                                                                  PTR OFFST]
+                               (add I 1)
+                               (add OFFST 1))
+                        (RETURN STR)))
+        (\CHARACTERP (LOCAL (\VAG2 \CHARHI (\LOLOC X))))
+        (%%ONED-ARRAY (LET ((SIZE (ffetch (ONED-ARRAY TOTAL-SIZE) of X))
+                            (BASE (ffetch (ONED-ARRAY BASE) of X))
+                            (OFFSET (ffetch (ONED-ARRAY OFFSET) of X))
+                            (TYPENUMBER (ffetch (ONED-ARRAY TYPE-NUMBER) of X))
+                            NCELLS LOCAL-ARRAY LOCAL-BASE)
+                           (if (EQ (%%TYPENUMBER-TO-GC-TYPE TYPENUMBER)
+                                          PTRBLOCK.GCT)
+                               then (LOCAL (VTYPEDPOINTER (TYPENAME X)
+                                                      X))
+                             else (SETQ NCELLS (FOLDHI (ITIMES (IPLUS SIZE OFFSET)
+                                                                  (%%TYPENUMBER-TO-BITS-PER-ELEMENT
+                                                                   TYPENUMBER))
+                                                          BITSPERCELL))
+                                   (SETQ LOCAL-ARRAY (LOCAL (create ONED-ARRAY)))
+                                   (SETQ LOCAL-BASE (LOCAL (\ALLOCBLOCK NCELLS)))
+                                   (LOCAL (freplace (ONED-ARRAY BASE) of LOCAL-ARRAY
+                                             with LOCAL-BASE))
+                                   (LOCAL (freplace (ONED-ARRAY STRING-P) of LOCAL-ARRAY
+                                             with (%%CHAR-TYPE-P TYPENUMBER)))
+                                   (LOCAL (freplace (ONED-ARRAY FILL-POINTER-P) of 
+                                                                                          LOCAL-ARRAY
+                                             with (ffetch (ONED-ARRAY FILL-POINTER-P)
+                                                         of X)))
+                                   (LOCAL (freplace (ONED-ARRAY TYPE-NUMBER) of LOCAL-ARRAY
+                                             with TYPENUMBER))
+                                   (LOCAL (freplace (ONED-ARRAY FILL-POINTER) of LOCAL-ARRAY
+                                             with (ffetch (ONED-ARRAY FILL-POINTER)
+                                                         of X)))
+                                   (if (NEQ OFFSET 0)
+                                       then (LOCAL (freplace (ONED-ARRAY OFFSET) of
+                                                                                         LOCAL-ARRAY
+                                                          with OFFSET))
+                                             (LOCAL (freplace (ONED-ARRAY DISPLACED-P)
+                                                       of LOCAL-ARRAY with T)))
+                                   (LOCAL (freplace (ONED-ARRAY TOTAL-SIZE) of LOCAL-ARRAY
+                                             with SIZE))
+                                   [for I from 0 to (SUB1 (LLSH NCELLS 1))
+                                      do (LOCAL (\PUTBASE LOCAL-BASE I (\GETBASE BASE I]
+                                   LOCAL-ARRAY)))
+        (\LISTP [COND
+                   [(LISTP X)
+                    (COND
+                       ((EQ CDRLVL 0)                    (* ; "Abbreviate")
+                        '(--))
+                       (T (LOCAL (CONS [COND
+                                              ([OR (EQ CARLVL 0)
+                                                   (AND (OR (EQ CARLVL 1)
+                                                            (EQ CDRLVL 1))
+                                                        (LISTP (CAR X]
+                                               '&)
+                                              (T (\UNCOPY (CAR X)
+                                                        (AND CARLVL (SUB1 CARLVL))
+                                                        (AND CDRLVL (SUB1 CDRLVL]
+                                        (\UNCOPY (CDR X)
+                                               CARLVL
+                                               (AND CDRLVL (SUB1 CDRLVL]
+                   (T                                        (* ; 
+                                               "Redundant LISTP test in case X is list page header")
+                      (ALLOCAL (VTYPEDPOINTER 'LISTP X])
+        (0 (LOCAL (VTYPEDPOINTER NIL X)))
+        (LOCAL (VTYPEDPOINTER (TYPENAME X)
+                      X])
+)
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS LOCAL MACRO ((X)
+                               X))
+
+(PUTPROPS ALLOCAL MACRO ((X)
+                                 X))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+
+(ADDTOVAR MKI.SUBFNS (CHECK . *)
+                         (RAID . HELP)
+                         (UNINTERRUPTABLY
+                              . PROGN)
+                         (\StatsAdd1 . *)
+                         (EVQ . I.\COPY)
+                         (COPY . I.\COPY))
+
+(ADDTOVAR RD.SUBFNS (CHECK . *)
+                        (RAID . HELP)
+                        (UNINTERRUPTABLY
+                             . PROGN)
+                        (\StatsAdd1 . *)
+                        (EVQ . V\COPY)
+                        (COPY . V\COPY)
+                        (1ST . V\UNCOPY))
+
+
+(ADDTOVAR INEWCOMS (FNS MAKEINITFIRST \COPY MAKEINITLAST))
+EVAL@COMPILE 
+
+(ADDTOVAR DONTCOMPILEFNS MAKEINITFIRST \COPY MAKEINITLAST \UNCOPY)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+(PUTPROPS LLNEW COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1990 1992 
+1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (5709 12152 (\ADDBASE 5719 . 6526) (\GETBASE 6528 . 6772) (\PUTBASE 6774 . 7050) (
+\PUTBASE.UFN 7052 . 7332) (\PUTBASEPTR.UFN 7334 . 7656) (\PUTBITS.UFN 7658 . 8364) (\GETBASEBYTE 8366
+ . 8793) (\PUTBASEBYTE 8795 . 9486) (\GETBASEPTR 9488 . 9838) (\PUTBASEPTR 9840 . 10158) (\HILOC 10160
+ . 10384) (\LOLOC 10386 . 10610) (\VAG2 10612 . 10910) (\RPLPTR 10912 . 11389) (\RPLPTR.UFN 11391 . 
+12150)) (12153 13568 (EQ 12163 . 12381) (EQL 12383 . 13566)) (13611 14361 (LOC 13621 . 13952) (VAG 
+13954 . 14359)) (14362 15403 (CREATEPAGES 14372 . 14861) (\NEW4PAGE 14863 . 15401)) (19946 37091 (CONS
+ 19956 . 20262) (\CONS.UFN 20264 . 22682) (\MAIKO.CONS.UFN 22684 . 24937) (CAR 24939 . 25066) (
+\CAR.UFN 25068 . 26171) (CDR 26173 . 26300) (\CDR.UFN 26302 . 27901) (RPLACA 27903 . 28130) (
+\RPLACA.UFN 28132 . 29131) (RPLACD 29133 . 29268) (\RPLACD.UFN 29270 . 33021) (DOCOLLECT 33023 . 33287
+) (\RPLCONS 33289 . 35299) (ENDCOLLECT 35301 . 35509) (\INITCONSPAGE 35511 . 36485) (\NEXTCONSPAGE 
+36487 . 37089)) (37149 39484 (\RESTLIST.UFN 37159 . 38257) (\FINDKEY.UFN 38259 . 39482)) (50410 52206 
+(CHECKCONSPAGES 50420 . 51359) (\CHECKCONSPAGE 51361 . 52204)) (52391 66997 (MAKEINITFIRST 52401 . 
+52739) (MAKEINITLAST 52741 . 58025) (\COPY 58027 . 60530) (\UNCOPY 60532 . 66995)))))
+STOP
diff --git a/CLTL2/LLNEW.LCOM b/CLTL2/LLNEW.LCOM
new file mode 100644
index 00000000..0a990698
Binary files /dev/null and b/CLTL2/LLNEW.LCOM differ
diff --git a/CLTL2/LLNEW.~2~ b/CLTL2/LLNEW.~2~
new file mode 100644
index 00000000..9a145f88
--- /dev/null
+++ b/CLTL2/LLNEW.~2~
@@ -0,0 +1,1418 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "28-Jan-93 17:42:57" {DSK}<python>lde>lispcore>sources>LLNEW.;2 68199  
+
+      changes to%:  (FNS \COPY)
+
+      previous date%: " 5-Jan-93 00:46:10" {DSK}<python>lde>lispcore>sources>LLNEW.;1)
+
+
+(* ; "
+Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT LLNEWCOMS)
+
+(RPAQQ LLNEWCOMS
+       ((PROPS (LLNEW FILETYPE))
+        [COMS                                                (* ; "low level memory access")
+              (FNS \ADDBASE \GETBASE \PUTBASE \PUTBASE.UFN \PUTBASEPTR.UFN \PUTBITS.UFN \GETBASEBYTE
+                   \PUTBASEBYTE \GETBASEPTR \PUTBASEPTR \HILOC \LOLOC \VAG2 \RPLPTR \RPLPTR.UFN)
+              (FNS EQ EQL)
+              (PROP BYTEMACRO EQL)
+              (FNS LOC VAG)
+              (FNS CREATEPAGES \NEW4PAGE)
+              (DECLARE%: DONTCOPY (EXPORT (RECORDS POINTER WORD)
+                                         (MACROS PTRGTP .COERCE.TO.SMALLPOSP. .COERCE.TO.BYTE.))
+                     (ADDVARS (INEWCOMS (FNS \GETBASEBYTE \PUTBASEBYTE CREATEPAGES \NEW4PAGE))
+                            (RDCOMS (FNS \CAR.UFN \CDR.UFN)
+                                   (FNS \COPY \UNCOPY)
+                                   (FNS \GETBASEBYTE \PUTBASEBYTE))
+                            (INITPTRS (\LISTPDTD))
+                            (MKI.SUBFNS (\ADDBASE . I.ADDBASE)
+                                   (\GETBASE . I.GETBASE)
+                                   (\PUTBASE . I.PUTBASE)
+                                   (\GETBASEPTR . I.GETBASEPTR)
+                                   (\PUTBASEPTR . I.PUTBASEPTR)
+                                   (\HILOC . I.HILOC)
+                                   (\LOLOC . I.LOLOC)
+                                   (\VAG2 . I.VAG2)
+                                   (.COERCE.TO.SMALLPOSP. . PROG1)
+                                   (.COERCE.TO.BYTE. . PROG1)
+                                   (LOCKEDPAGEP . MKI.LOCKEDPAGEP)
+                                   (\RPLPTR . I.PUTBASEPTR)
+                                   (CONS . I.\CONS.UFN))
+                            (RD.SUBFNS (\ADDBASE . VADDBASE)
+                                   (\GETBASE . VGETBASE)
+                                   (\PUTBASE . VPUTBASE)
+                                   (\GETBASEPTR . VGETBASEPTR)
+                                   (\PUTBASEPTR . VPUTBASEPTR)
+                                   (\HILOC . VHILOC)
+                                   (\LOLOC . VLOLOC)
+                                   (\VAG2 . VVAG2)
+                                   (.COERCE.TO.SMALLPOSP. . PROG1)
+                                   (.COERCE.TO.BYTE. . PROG1)
+                                   (PTRGTP . IGREATERP)
+                                   (\RPLPTR . VPUTBASEPTR)
+                                   (CAR . V\CAR.UFN)
+                                   (CDR . V\CDR.UFN)
+                                   (CAR/CDRERR . T)))
+                     EVAL@COMPILE
+                     (ADDVARS (DONTCOMPILEFNS CREATEPAGES]
+        [COMS                                                (* ; "cons cells")
+              (FNS CONS \CONS.UFN \MAIKO.CONS.UFN CAR \CAR.UFN CDR \CDR.UFN RPLACA \RPLACA.UFN RPLACD
+                   \RPLACD.UFN DOCOLLECT \RPLCONS ENDCOLLECT \INITCONSPAGE \NEXTCONSPAGE)
+              (ADDVARS (\MAIKO.MOVDS (\MAIKO.CONS.UFN \CONS.UFN)))
+              (FNS \RESTLIST.UFN \FINDKEY.UFN)
+              (INITVARS (CAR/CDRERR 'CDR))
+              (DECLARE%: DONTCOPY (GLOBALVARS CAR/CDRERR)
+                     (EXPORT (RECORDS LISTP CONSPAGE)
+                            (CONSTANTS * CONSCONSTANTS))
+                     (MACROS .MAKECONSCELL. .FINDCLOSEPRIOR. .FINDCDRABLEPAIR. .FINDPAIR.)
+                                                             (* ; "for MAKEINIT")
+                     (ADDVARS (INEWCOMS (FNS \CONS.UFN \MAIKO.CONS.UFN \INITCONSPAGE \NEXTCONSPAGE))
+                            (EXPANDMACROFNS .MAKECONSCELL. .FINDCLOSEPRIOR. .FINDCDRABLEPAIR. 
+                                   .FINDPAIR.)))
+              (COMS                                          (* ; "testing out CONSes")
+                    (FNS CHECKCONSPAGES \CHECKCONSPAGE)
+                    (DECLARE%: DONTCOPY (MACROS !CHECK]
+        [COMS                                                (* ; "other random stuff for makeinit")
+              (FNS MAKEINITFIRST MAKEINITLAST \COPY \UNCOPY)
+              (DECLARE%: DONTCOPY (EXPORT (MACROS LOCAL ALLOCAL))
+                     (ADDVARS (MKI.SUBFNS (CHECK . *)
+                                     (RAID . HELP)
+                                     (UNINTERRUPTABLY
+                                          . PROGN)
+                                     (\StatsAdd1 . *)
+                                     (EVQ . I.\COPY)
+                                     (COPY . I.\COPY))
+                            (RD.SUBFNS (CHECK . *)
+                                   (RAID . HELP)
+                                   (UNINTERRUPTABLY
+                                        . PROGN)
+                                   (\StatsAdd1 . *)
+                                   (EVQ . V\COPY)
+                                   (COPY . V\COPY)
+                                   (1ST . V\UNCOPY)))
+                     (ADDVARS (INEWCOMS (FNS MAKEINITFIRST \COPY MAKEINITLAST)))
+                     EVAL@COMPILE
+                     (ADDVARS (DONTCOMPILEFNS MAKEINITFIRST \COPY MAKEINITLAST \UNCOPY]
+        (LOCALVARS . T)))
+
+(PUTPROPS LLNEW FILETYPE :BCOMPL)
+
+
+
+(* ; "low level memory access")
+
+(DEFINEQ
+
+(\ADDBASE
+  [LAMBDA (X D)                                          (* lmm " 2-NOV-81 18:33")
+
+    (* ;; "usually done in microcode;  this version uses only arithmetic and \VAG2")
+
+    (PROG (NH NL (XH (\HILOC X))
+              (XL (\LOLOC X)))
+          (.UNBOX. D NH NL)
+          (COND
+             [(IGREATERP XL (IDIFFERENCE MAX.SMALL.INTEGER NL))
+                                                             (* ; "carry")
+              (add XH 1)
+              (SETQ XL (SUB1 (IDIFFERENCE XL (IDIFFERENCE MAX.SMALL.INTEGER NL]
+             (T (add XL NL)))
+          (COND
+             [(IGREATERP NH MAX.POS.HINUM)
+              (SETQ XH (SUB1 (IDIFFERENCE XH (IDIFFERENCE MAX.SMALL.INTEGER NH]
+             (T (add XH NH)))
+          (RETURN (\VAG2 XH XL])
+
+(\GETBASE
+  [LAMBDA (X D)                                          (* lmm " 2-NOV-81 18:33")
+
+    (* ;; "usually done in microcode;  case where D=0 MUST be done in microcode")
+
+    (\GETBASE (\ADDBASE X D)
+           0])
+
+(\PUTBASE
+  [LAMBDA (X D V)                                        (* lmm "11-FEB-83 07:35")
+
+    (* ;; "usually done in microcode;  case where D=0 MUST be handled there")
+
+    (\PUTBASE (\ADDBASE X D)
+           0
+           (.COERCE.TO.SMALLPOSP. V])
+
+(\PUTBASE.UFN
+  [LAMBDA (X V D)                                        (* lmm "11-FEB-83 07:35")
+
+    (* ;; "usually done in microcode;  case where D=0 MUST be handled there")
+
+    (\PUTBASE (\ADDBASE X D)
+           0
+           (.COERCE.TO.SMALLPOSP. V])
+
+(\PUTBASEPTR.UFN
+  [LAMBDA (X V D)                                        (* lmm "10-NOV-81 15:12")
+
+    (* ;; "usually done in microcode;  this def uses only PUTBASE, ADDBASE, etc")
+
+    (\PUTBASE X D (\HILOC V))
+    (\PUTBASE (\ADDBASE X D)
+           1
+           (\LOLOC V))
+    V])
+
+(\PUTBITS.UFN
+  [LAMBDA (X V N.FD)                                     (* lmm "11-FEB-83 07:35")
+    (PROG ((NV (.COERCE.TO.SMALLPOSP. V))
+           (WIDTH (ADD1 (LOGAND N.FD 15)))
+           (FIRST (LRSH (LOGAND N.FD 255)
+                            4))
+           MASK SHIFT)
+          (SETQ SHIFT (IDIFFERENCE 16 (IPLUS FIRST WIDTH)))
+          (SETQ MASK (SUB1 (LLSH 1 WIDTH)))
+          (\PUTBASE (SETQ X (\ADDBASE X (LRSH N.FD 8)))
+                 0
+                 (LOGOR (LOGAND (\GETBASE X 0)
+                               (LOGXOR 65535 (LLSH MASK SHIFT)))
+                        (LLSH (LOGAND NV MASK)
+                              SHIFT)))
+          (RETURN NV])
+
+(\GETBASEBYTE
+  [LAMBDA (PTR N)                                        (* bvm%: " 5-Feb-85 12:05")
+
+    (* ;; 
+"usually done in microcode;  this def.  uses only \GETBASE and arithmetic --- used by MAKEINIT too")
+
+    (COND
+       [(EVENP N)
+        (fetch (WORD HIBYTE) of (\GETBASE PTR (FOLDLO N BYTESPERWORD]
+       (T (fetch (WORD LOBYTE) of (\GETBASE PTR (FOLDLO N BYTESPERWORD])
+
+(\PUTBASEBYTE
+  [LAMBDA (PTR DISP BYTE)                                (* JonL "31-Dec-83 23:48")
+
+    (* ;; "usually done in microcode --- this def used by MAKEINIT too")
+
+    (SETQ BYTE (.COERCE.TO.BYTE. BYTE))
+    [\PUTBASE PTR (FOLDLO (SETQ DISP (\DTEST DISP 'SMALLP))
+                             BYTESPERWORD)
+           (COND
+              ((EVENP DISP BYTESPERWORD)
+               (create WORD using (\GETBASE PTR (FOLDLO DISP BYTESPERWORD))
+                                      HIBYTE _ BYTE))
+              (T (create WORD using (\GETBASE PTR (FOLDLO DISP BYTESPERWORD))
+                                        LOBYTE _ BYTE]
+    BYTE])
+
+(\GETBASEPTR
+  [LAMBDA (X D)                                          (* lmm " 2-NOV-81 18:34")
+
+    (* ;; 
+  "usually done in microcode;  this def.  uses GETBASE, VAG2, etc.  and handles overflows too")
+
+    (\VAG2 (fetch LOBYTE of (\GETBASE X D))
+           (\GETBASE (\ADDBASE X 1)
+                  D])
+
+(\PUTBASEPTR
+  [LAMBDA (X D V)                                        (* lmm " 2-NOV-81 18:35")
+
+    (* ;; "usually done in microcode;  this def uses only PUTBASE, ADDBASE, etc")
+
+    (\PUTBASE X D (\HILOC V))
+    (\PUTBASE (\ADDBASE X D)
+           1
+           (\LOLOC V))
+    V])
+
+(\HILOC
+  [LAMBDA (X)                                            (* lmm "10-MAR-81 15:02")
+                                                             (* ; "MUST be handled in microcode")
+    (\HILOC X])
+
+(\LOLOC
+  [LAMBDA (X)                                            (* lmm "10-MAR-81 15:03")
+                                                             (* ; "MUST be handled in microcode")
+    (\LOLOC X])
+
+(\VAG2
+  [LAMBDA (H L)                                          (* JonL "31-Dec-83 23:39")
+
+    (* ;; "case where H is byte and L is smallposp MUST be handled in microcode.  Other cases may run error here.")
+
+    (\VAG2 (.COERCE.TO.BYTE. H)
+           (.COERCE.TO.SMALLPOSP. L])
+
+(\RPLPTR
+  [LAMBDA (OBJ OFFSET VAL)                               (* lmm " 3-NOV-81 12:10")
+    (UNINTERRUPTABLY
+        (\ADDREF VAL)
+        (\DELREF (\GETBASEPTR (SETQ OBJ (\ADDBASE OBJ OFFSET))
+                        0))
+        (\PUTBASEBYTE OBJ 1 (\HILOC VAL))            (* ; 
+                                                           "\PUTBASEPTR smashes the high byte")
+        (\PUTBASE OBJ 1 (\LOLOC VAL))
+        VAL)])
+
+(\RPLPTR.UFN
+  [LAMBDA (OBJ VAL OFFSET)                               (* ; "Edited 14-Jan-87 16:34 by Pavel")
+
+(* ;;; "The UFN is different from the function since the offset (inline) gets pushed last.")
+
+    (LET ((SLOT (\ADDBASE OBJ OFFSET)))
+         (UNINTERRUPTABLY
+             
+             (* ;; "Fix up the reference counts.")
+
+             (\ADDREF VAL)
+             (\DELREF (\GETBASEPTR SLOT 0))
+
+             (* ;; "\PUTBASEPTR smashes the high byte, so we use two calls instead.")
+
+             (\PUTBASEBYTE SLOT 1 (\HILOC VAL))
+             (\PUTBASE SLOT 1 (\LOLOC VAL))
+
+             (* ;; "Be sure to return the OBJ; code generated by the new compiler counts on it.")
+
+             OBJ)])
+)
+(DEFINEQ
+
+(EQ
+  [LAMBDA (X Y)                                          (* lmm "10-MAR-81 15:04")
+                                                             (* ; "MUST be handled in microcode")
+    (EQ X Y])
+
+(EQL
+  [LAMBDA (X Y)                                          (* ; "Edited  6-Jul-87 09:40 by jop")
+
+(* ;;; "Like EQ except for numbers")
+
+    (COND
+       ((OR (NOT (LISP:NUMBERP X))
+            (TYPEP X 'LISP:FIXNUM))
+        (EQ X Y))
+       [(LISP:FLOATP X)
+
+        (* ;; 
+      "32 bit compare --- differs from feqp in that the predicate is not true for -0.0 and 0.0")
+
+        (AND (LISP:FLOATP Y)
+             (EQ (fetch LOWORD of X)
+                    (fetch LOWORD of Y))
+             (EQ (fetch HIWORD of X)
+                    (fetch HIWORD of Y]
+       ((LISP:INTEGERP X)
+        (AND (LISP:INTEGERP Y)
+             (IEQP X Y)))
+       [(TYPEP X 'RATIO)
+        (AND (TYPEP Y 'RATIO)
+             (EQL (LISP::RATIO-NUMERATOR X)
+                    (LISP::RATIO-NUMERATOR Y))
+             (EQL (LISP::RATIO-DENOMINATOR X)
+                    (LISP::RATIO-DENOMINATOR Y]
+       ((TYPEP X 'COMPLEX)
+        (AND (TYPEP Y 'COMPLEX)
+             (EQL (LISP::COMPLEX-REALPART X)
+                    (LISP::COMPLEX-REALPART Y))
+             (EQL (LISP::COMPLEX-IMAGPART X)
+                    (LISP::COMPLEX-IMAGPART Y])
+)
+
+(PUTPROPS EQL BYTEMACRO COMP.EQ)
+(DEFINEQ
+
+(LOC
+  [LAMBDA (X)                                            (* lmm " 2-NOV-81 18:29")
+                                                             (* ; 
+     "Return HILOC-LOLOC pair, for easier traffic with RAID.  VAG interprets such pairs correctly.")
+    (CONS (\HILOC X)
+           (\LOLOC X])
+
+(VAG
+  [LAMBDA (LOC)                                      (* lmm " 2-NOV-81 18:28")
+                                                             (* ; "LOC can be a HILOC-LOLOC pair")
+    (COND
+       [(LISTP LOC)
+        (\VAG2 (CAR LOC)
+               (OR (FIXP (CDR LOC))
+                   (FIX (CADR LOC]
+       (T (\VAG2 (\HINUM LOC)
+                 (\LONUM LOC])
+)
+(DEFINEQ
+
+(CREATEPAGES
+  [LAMBDA (VA N BLANKFLG LOCKFLG)                        (* bvm%: "29-MAR-83 16:35")
+
+    (* ;; "called only under MAKEINIT --- BLANKFLG means that MAKEINIT won't write on this page, so fake it --- to prevent storage overflow when running on Maxc and init'ing GC table")
+
+    (for I from 0 to (SUB1 N) do (\NEWPAGE (\ADDBASE VA (UNFOLD I WORDSPERPAGE))
+                                                        NIL LOCKFLG BLANKFLG))
+    VA])
+
+(\NEW4PAGE
+  [LAMBDA (PTR)                               (* ; 
+                                                "Edited 24-Oct-92 12:45 by sybalsky:mv:envos")
+
+    (* ;; "Instantiates a block of 4 new virtual pages, starting with the one at PTR.")
+
+    (\NEWPAGE (\ADDBASE (\NEWPAGE (\ADDBASE (\NEWPAGE (\ADDBASE (\NEWPAGE PTR)
+                                                                     WORDSPERPAGE))
+                                             WORDSPERPAGE))
+                     WORDSPERPAGE])
+)
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
+
+(ACCESSFNS POINTER [(PAGE# (IPLUS (LLSH (\HILOC DATUM)
+                                            8)
+                                      (LRSH (\LOLOC DATUM)
+                                            8)))
+                        (WORDINPAGE (LOGAND (\LOLOC DATUM)
+                                           255))
+                        (CELLINPAGE (LRSH (fetch WORDINPAGE of DATUM)
+                                          1))
+                        (BYTEINPAGE (LLSH (fetch WORDINPAGE of DATUM)
+                                          1))
+                        (SEGMENT# (\HILOC DATUM))
+                        (WORDINSEGMENT (\LOLOC DATUM))
+                        (CELLINSEGMENT (LRSH (fetch WORDINSEGMENT of DATUM)
+                                             1))
+                        (WORD# (fetch WORDINPAGE of DATUM))
+                        (DBLWORD# (fetch CELLINPAGE of DATUM))
+                        (PAGEBASE (\VAG2 (\HILOC DATUM)
+                                         (LOGAND (\LOLOC DATUM)
+                                                65280]
+                       (CREATE (\VAG2 (LRSH PAGE# 8)
+                                          (LLSH (LOGAND PAGE# 255)
+                                                8))))
+
+(ACCESSFNS WORD ((HIBYTE (LRSH DATUM 8))
+                     (LOBYTE (LOGAND DATUM 255)))
+                    (CREATE (IPLUS (LLSH HIBYTE 8)
+                                       LOBYTE)))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS PTRGTP MACRO [OPENLAMBDA (X Y)
+                                      (OR (IGREATERP (\HILOC X)
+                                                 (\HILOC Y))
+                                          (AND (EQ (\HILOC X)
+                                                      (\HILOC Y))
+                                               (IGREATERP (\LOLOC X)
+                                                      (\LOLOC Y])
+
+(PUTPROPS .COERCE.TO.SMALLPOSP. DMACRO [OPENLAMBDA (X)
+                                                      (COND
+                                                         ((SMALLPOSP X)
+                                                          X)
+                                                         (T (\ILLEGAL.ARG X])
+
+(PUTPROPS .COERCE.TO.BYTE. DMACRO [OPENLAMBDA (X)
+                                                 (COND
+                                                    ([AND (SMALLPOSP X)
+                                                          (ILESSP X (CONSTANT (LLSH 1 BITSPERBYTE]
+                                                     X)
+                                                    (T (\ILLEGAL.ARG X])
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+
+(ADDTOVAR INEWCOMS (FNS \GETBASEBYTE \PUTBASEBYTE CREATEPAGES \NEW4PAGE))
+
+(ADDTOVAR RDCOMS (FNS \CAR.UFN \CDR.UFN)
+                     (FNS \COPY \UNCOPY)
+                     (FNS \GETBASEBYTE \PUTBASEBYTE))
+
+(ADDTOVAR INITPTRS (\LISTPDTD))
+
+(ADDTOVAR MKI.SUBFNS (\ADDBASE . I.ADDBASE)
+                         (\GETBASE . I.GETBASE)
+                         (\PUTBASE . I.PUTBASE)
+                         (\GETBASEPTR . I.GETBASEPTR)
+                         (\PUTBASEPTR . I.PUTBASEPTR)
+                         (\HILOC . I.HILOC)
+                         (\LOLOC . I.LOLOC)
+                         (\VAG2 . I.VAG2)
+                         (.COERCE.TO.SMALLPOSP. . PROG1)
+                         (.COERCE.TO.BYTE. . PROG1)
+                         (LOCKEDPAGEP . MKI.LOCKEDPAGEP)
+                         (\RPLPTR . I.PUTBASEPTR)
+                         (CONS . I.\CONS.UFN))
+
+(ADDTOVAR RD.SUBFNS (\ADDBASE . VADDBASE)
+                        (\GETBASE . VGETBASE)
+                        (\PUTBASE . VPUTBASE)
+                        (\GETBASEPTR . VGETBASEPTR)
+                        (\PUTBASEPTR . VPUTBASEPTR)
+                        (\HILOC . VHILOC)
+                        (\LOLOC . VLOLOC)
+                        (\VAG2 . VVAG2)
+                        (.COERCE.TO.SMALLPOSP. . PROG1)
+                        (.COERCE.TO.BYTE. . PROG1)
+                        (PTRGTP . IGREATERP)
+                        (\RPLPTR . VPUTBASEPTR)
+                        (CAR . V\CAR.UFN)
+                        (CDR . V\CDR.UFN)
+                        (CAR/CDRERR . T))
+EVAL@COMPILE 
+
+(ADDTOVAR DONTCOMPILEFNS CREATEPAGES)
+)
+
+
+
+(* ; "cons cells")
+
+(DEFINEQ
+
+(CONS
+  [LAMBDA (X Y)                                          (* lmm "11-FEB-82 13:55")
+                                                             (* ; 
+                                                           "use microcode UFN to get to \CONS.UFN")
+    ((OPCODES CONS)
+     X Y])
+
+(\CONS.UFN
+  [LAMBDA (X Y)                                          (* ; "Edited  8-Dec-92 16:46 by jds")
+    [COND
+       ((ZEROP CDRCODING)
+        (RAID)
+        (PROG ((CELL (CREATECELL \LISTP)))
+              (replace (LISTP CAR) of CELL with X)
+              (replace (LISTP CDR) of CELL with Y)
+              (RETURN CELL]
+    (UNINTERRUPTABLY
+        (\ADDREF X)
+        (\ADDREF Y)
+        (\StatsAdd1 (fetch DTDCNTLOC of \LISTPDTD))
+        (.INCREMENT.ALLOCATION.COUNT. 1)
+        (PROG (CNS.PAGE CELL)
+              [SETQ CNS.PAGE (COND
+                                ((NOT Y)
+                                 [COND
+                                    ((AND (SETQ CNS.PAGE (CREATE POINTER
+                                                                PAGE# _ (FETCH DTDNEXTPAGE
+                                                                           OF \LISTPDTD)))
+                                          (IGREATERP (FETCH (CONSPAGE CNT) OF CNS.PAGE)
+                                                 0)))
+                                    (T (SETQ CNS.PAGE (\NEXTCONSPAGE]
+                                 (.MAKECONSCELL. CNS.PAGE X \CDR.NIL))
+                                ((AND (EQ (NTYPX Y)
+                                             \LISTP)
+                                      (IGREATERP (fetch (CONSPAGE CNT)
+                                                    of (SETQ CNS.PAGE (fetch (POINTER 
+                                                                                            PAGEBASE)
+                                                                             of Y)))
+                                             0)
+                                      (SETQ CELL (.FINDCLOSEPRIOR. CNS.PAGE X Y)))
+
+                                 (* ;; 
+         "Test for any cells left on page --- NTYPX rather than LISTP test for benefit of MAKEINIT")
+                                                             (* .MAKECONSCELL. CNS.PAGE X
+                                                           (IPLUS \CDR.ONPAGE
+                                                           (fetch (POINTER DBLWORD#) of Y)))
+                                 CELL)
+                                (T (.FINDPAIR. X Y]
+              (\DELREF CNS.PAGE)
+              (RETURN CNS.PAGE)))])
+
+(\MAIKO.CONS.UFN
+  [LAMBDA (X Y)                                          (* ; "Edited  3-Jun-90 21:03 by nm")
+
+    (* ;; "Maiko specific \CONS.UFN. Does not decrement \RECLAIM.COUNTDOWN.")
+
+    [COND
+       ((ZEROP CDRCODING)
+        (RAID)
+        (PROG ((CELL (CREATECELL \LISTP)))
+              (replace (LISTP CAR) of CELL with X)
+              (replace (LISTP CDR) of CELL with Y)
+              (RETURN CELL]
+    (UNINTERRUPTABLY
+        (\ADDREF X)
+        (\ADDREF Y)
+        (\StatsAdd1 (fetch DTDCNTLOC of \LISTPDTD))
+        (.CHECK.ALLOCATION.COUNT. 1)
+        (PROG (CNS.PAGE)
+              [SETQ CNS.PAGE (COND
+                                [(AND (EQ (NTYPX Y)
+                                             \LISTP)
+                                      (IGREATERP (fetch (CONSPAGE CNT)
+                                                    of (SETQ CNS.PAGE (fetch (POINTER 
+                                                                                            PAGEBASE)
+                                                                             of Y)))
+                                             0))             (* ; 
+         "Test for any cells left on page --- NTYPX rather than LISTP test for benefit of MAKEINIT")
+                                 (.MAKECONSCELL. CNS.PAGE X (IPLUS \CDR.ONPAGE (fetch
+                                                                                (POINTER DBLWORD#)
+                                                                                  of Y]
+                                (T (.MAKECONSCELL. (SETQ CNS.PAGE (\NEXTCONSPAGE))
+                                          X
+                                          (COND
+                                             ((NULL Y)
+                                              \CDR.NIL)
+                                             (T (IPLUS \CDR.INDIRECT (fetch (POINTER DBLWORD#)
+                                                                        of (.MAKECONSCELL. 
+                                                                                      CNS.PAGE Y 0]
+              (\DELREF CNS.PAGE)
+              (RETURN CNS.PAGE)))])
+
+(CAR
+  [LAMBDA (X)                                            (* lmm "11-FEB-82 13:56")
+    ((OPCODES CAR)
+     X])
+
+(\CAR.UFN
+  [LAMBDA (X)                                            (* lmm "18-Jul-84 00:07")
+
+    (* ;; "most cases handled in microcode --- this code also used by MAKEINIT/READSYS")
+
+    (\CALLME 'CAR)
+    (COND
+       [(LISTP X)
+        (COND
+           ((ZEROP CDRCODING)
+            (fetch (LISTP CAR) of X))
+           (T (COND
+                 ((EQ (fetch CDRCODE of X)
+                         \CDR.INDIRECT)
+                  (fetch CARFIELD of (fetch CARFIELD of X)))
+                 (T (fetch CARFIELD of X]
+       ((NULL X)
+        NIL)
+       (T (SELECTQ CAR/CDRERR
+              (T (LISPERROR "ARG NOT LIST" X))
+              ((NIL CDR) 
+                   (COND
+                      ((EQ X T)
+                       T)
+                      ((LITATOM X)
+                       NIL)
+                      (T '"{car of non-list}")))
+              (COND
+                 ((EQ X T)
+                  T)
+                 ((STRINGP X)
+                  (LISPERROR "ARG NOT LIST" X))
+                 (T '"{car of non-list}"])
+
+(CDR
+  [LAMBDA (X)                                            (* lmm "11-FEB-82 13:56")
+    ((OPCODES CDR)
+     X])
+
+(\CDR.UFN
+  [LAMBDA (X)                                            (* lmm "17-Jul-84 22:26")
+
+    (* ;; "most cases handled in microcode --- this code also used by MAKEINIT/READSYS")
+
+    (\CALLME 'CDR)
+    (COND
+       [(LISTP X)
+        (COND
+           ((ZEROP CDRCODING)
+            (fetch (LISTP CDR) of X))
+           (T (PROG ((Q (fetch CDRCODE of X)))
+                    (RETURN (COND
+                               ((EQ Q \CDR.NIL)
+                                NIL)
+                               ((IGREATERP Q \CDR.ONPAGE)
+                                (\ADDBASE (fetch (POINTER PAGEBASE) of X)
+                                       (LLSH (IDIFFERENCE Q \CDR.ONPAGE)
+                                             1)))
+                               ((EQ Q \CDR.INDIRECT)
+                                (\CDR.UFN (fetch CARFIELD of X)))
+                               (T (fetch CARFIELD of (\ADDBASE (fetch PAGEBASE
+                                                                              of X)
+                                                                    (LLSH Q 1]
+       ((NULL X)
+        NIL)
+       (T (SELECTQ CAR/CDRERR
+              ((T CDR) 
+                   (LISPERROR "ARG NOT LIST" X))
+              (NIL (COND
+                      ((LITATOM X)
+                       (GETPROPLIST X))
+                      (T "{cdr of non-list}")))
+              (COND
+                 ((STRINGP X)
+                  (LISPERROR "ARG NOT LIST" X))
+                 (T "{cdr of non-list}"])
+
+(RPLACA
+  [LAMBDA (X Y)                                          (* lmm "11-FEB-82 13:55")
+                                                             (* ; "invoke \RPLACA.UFN")
+    ((OPCODES RPLACA)
+     X Y])
+
+(\RPLACA.UFN
+  [LAMBDA (X Y)                                          (* lmm " 1-DEC-81 21:17")
+    (COND
+       [(NLISTP X)
+        (COND
+           [(NULL X)                                         (* ; "if X is NIL and Y is NIL ok")
+            (COND
+               (Y (LISPERROR "ATTEMPT TO RPLAC NIL" Y]
+           (T (LISPERROR "ARG NOT LIST" X]
+       (T (COND
+             ((ZEROP CDRCODING)
+              (replace (LISTP CAR) of X with Y)
+              X)
+             (T (UNINTERRUPTABLY
+                    (\DELREF (CAR X))
+                    (\ADDREF Y)
+                    (replace CARFIELD of (COND
+                                                    ((EQ (fetch CDRCODE of X)
+                                                            \CDR.INDIRECT)
+                                                     (fetch CARFIELD of X))
+                                                    (T X)) with Y)
+                    X)])
+
+(RPLACD
+  [LAMBDA (X Y)                                          (* lmm "11-FEB-82 13:55")
+    ((OPCODES RPLACD)
+     X Y])
+
+(\RPLACD.UFN
+  [LAMBDA (X Y)                                          (* lmm "11-JAN-82 10:15")
+    (COND
+       [(NLISTP X)
+        (COND
+           [(NULL X)                                         (* ; "if X is NIL and Y is NIL ok")
+            (COND
+               (Y (LISPERROR "ATTEMPT TO RPLAC NIL" Y]
+           (T (LISPERROR "ARG NOT LIST" X]
+       ((ZEROP CDRCODING)
+        (replace (LISTP CDR) of X with Y)
+        X)
+       (T (UNINTERRUPTABLY
+              (\DELREF (CDR X))
+              (\ADDREF Y)
+              (PROG (RP.PAGE (RP.Q (fetch CDRCODE of X)))
+                    (COND
+                       ((EQ RP.Q \CDR.INDIRECT)
+                        (SETQ RP.PAGE (fetch CARFIELD of X))
+                        (CHECK (ILEQ (fetch CDRCODE of RP.PAGE)
+                                     \CDR.MAXINDIRECT)
+                               (NEQ (fetch CDRCODE of RP.PAGE)
+                                    \CDR.INDIRECT))
+                        (SETQ RP.PAGE (\ADDBASE (fetch PAGEBASE of RP.PAGE)
+                                             (LLSH (IDIFFERENCE (fetch CDRCODE of RP.PAGE)
+                                                          \CDR.INDIRECT)
+                                                   1)))
+                        (CHECK (LISTP RP.PAGE)
+                               (EQ 0 (fetch CDRCODE of RP.PAGE)))
+                        (replace FULLCARFIELD of RP.PAGE with Y))
+                       ((ILEQ RP.Q \CDR.MAXINDIRECT)
+                        (SETQ RP.PAGE (\ADDBASE (fetch PAGEBASE of X)
+                                             (LLSH (IDIFFERENCE RP.Q \CDR.INDIRECT)
+                                                   1)))
+                        (CHECK (LISTP RP.PAGE)
+                               (EQ 0 (fetch CDRCODE of RP.PAGE)))
+                        (replace FULLCARFIELD of RP.PAGE with Y))
+                       ((NULL Y)
+                        (replace CDRCODE of X with \CDR.NIL))
+                       [(EQ (SETQ RP.PAGE (fetch PAGEBASE of X))
+                               (fetch PAGEBASE of Y))(* ; "New CDR on same page")
+                        (replace CDRCODE of X with (IPLUS \CDR.ONPAGE (fetch
+                                                                                   (POINTER DBLWORD#)
+                                                                                     of Y]
+                       [(IGREATERP (fetch (CONSPAGE CNT) of RP.PAGE)
+                               0)                            (* ; "Room on page for cdr cell")
+                        (replace CDRCODE of X with (IPLUS \CDR.INDIRECT
+                                                                      (fetch (POINTER DBLWORD#)
+                                                                         of (.MAKECONSCELL.
+                                                                                 RP.PAGE Y 0]
+                       (T [replace FULLCARFIELD of X
+                             with (.MAKECONSCELL. (SETQ RP.PAGE (\NEXTCONSPAGE))
+                                             (fetch CARFIELD of X)
+                                             (IPLUS \CDR.INDIRECT (fetch (POINTER DBLWORD#)
+                                                                     of (.MAKECONSCELL. RP.PAGE Y
+                                                                                   0]
+                          (replace CDRCODE of X with \CDR.INDIRECT)))
+                    (RETURN X)))])
+
+(DOCOLLECT
+  [LAMBDA (ITEM LST)                                     (* lmm%: "30-SEP-76 13:03:33")
+    (COND
+       ((NLISTP LST)
+        (FRPLACD (SETQ LST (LIST ITEM))
+               LST))
+       (T (CDR (FRPLACD LST (CONS ITEM (CDR LST])
+
+(\RPLCONS
+  [LAMBDA (LST ITEM)                                     (* bvm%: " 5-Feb-85 22:49")
+                                                             (* (CDR (RPLACD LST
+                                                           (CONS ITEM NIL))))
+    (COND
+       [(AND (NEQ CDRCODING 0)
+             (LISTP LST)
+             (UNINTERRUPTABLY
+                 
+                 (* ;; "Have to go uninterruptable here so that someone doesn't change the CNT field to zero out from under us")
+
+                 [PROG ((CPAGE (fetch (POINTER PAGEBASE) of LST))
+                        CELL)
+                       (RETURN (COND
+                                  ((AND (NEQ (fetch (CONSPAGE CNT) of CPAGE)
+                                             0)
+                                        (IGREATERP (fetch CDRCODE of LST)
+                                               \CDR.MAXINDIRECT))
+                                   (\ADDREF ITEM)
+                                   (\DELREF (CDR LST))
+                                   (SETQ CELL (.MAKECONSCELL. CPAGE ITEM \CDR.NIL))
+                                   (\StatsAdd1 (fetch DTDCNTLOC of \LISTPDTD))
+                                   (.INCREMENT.ALLOCATION.COUNT. 1)
+                                   (replace CDRCODE of LST with
+                                                                   (IPLUS \CDR.ONPAGE
+                                                                          (fetch (POINTER 
+                                                                                            DBLWORD#)
+                                                                             of CELL)))
+                                   CELL])]
+       (T (SETQ ITEM (CONS ITEM NIL))                    (* ; 
+             "Have to be careful how this part is written, or compiler will turn it into RPLCONS !")
+          (RPLACD LST ITEM)
+          ITEM])
+
+(ENDCOLLECT
+  [LAMBDA (X Y)                                          (* lmm "21-MAR-81 13:37")
+    (COND
+       ((NULL X)
+        Y)
+       (T (PROG1 (CDR X)
+                 (RPLACD X Y])
+
+(\INITCONSPAGE
+  [LAMBDA (BASE LINK)                                    (* ; "Edited  4-Dec-92 04:13 by jds")
+    (COND
+       ((ZEROP CDRCODING)
+        (RAID))
+       (T (PROG ((J (replace (CONSPAGE NEXTCELL) of BASE with 254))
+                 CELL)
+            LP  (COND
+                   ((IGREATERP J 4)
+                    (SETQ CELL (\ADDBASE BASE J))
+                    (replace (LISTP FULLCARFIELD) of CELL with NIL)
+                    (replace (LISTP NEXTFREE) of CELL with (SETQ J (IDIFFERENCE J 2)))
+                    (GO LP)))
+                (replace (CONSPAGE CNT) of BASE with 126)
+                                                             (* ; 
+                            "if LINK=NIL, stores a 0. This assumes that the pagebase of NIL is NIL")
+                (replace NEXTPAGE of BASE with (fetch (POINTER PAGE#) of LINK))
+                (RETURN BASE])
+
+(\NEXTCONSPAGE
+  [LAMBDA NIL                                            (* ; "Edited  8-Dec-92 01:57 by jds")
+    (CHECK (NULL \INTERRUPTABLE))
+    (PROG ((N (fetch DTDNEXTPAGE of \LISTPDTD))
+           PG)
+          (SETQ PG (\ALLOCMDSPAGE (fetch DTDTYPEENTRY of \LISTPDTD)))
+          (\INITCONSPAGE PG (\INITCONSPAGE (\ADDBASE PG WORDSPERPAGE)
+                                       (CREATE POINTER
+                                              PAGE# _ N)))
+          (replace DTDNEXTPAGE of \LISTPDTD with (PAGELOC PG))
+          (RETURN PG])
+)
+
+(ADDTOVAR \MAIKO.MOVDS (\MAIKO.CONS.UFN \CONS.UFN))
+(DEFINEQ
+
+(\RESTLIST.UFN
+  [LAMBDA (TAIL LASTN FIRSTN)                            (* bvm%: "31-Aug-86 16:30")
+
+(* ;;; "Handles &REST args by building a list of the args from FIRSTN thru LASTN, all consed onto the front of TAIL, which could be non-NIL in the case where the microcode has started the job")
+
+    (COND
+       (TAIL                                                 (* ; 
+                                                        "Some already done, better take care of gc")
+             (\GC.HANDLEOVERFLOW)))
+    (LET* [(CALLER (\MYALINK))
+           (BLINK (fetch (FX BLINK) of CALLER))
+           (IVAR (fetch (BF IVAR) of BLINK))
+           (BASE (STACKADDBASE (IDIFFERENCE IVAR WORDSPERCELL]
+          (for I from LASTN to FIRSTN by -1
+             do (SETQ TAIL (CONS (\GETBASEPTR BASE (UNFOLD I WORDSPERCELL))
+                                      TAIL)) 
+
+                   (* ;; "Might want to experiment with stopping after one iteration to let the microcode do the rest of the consing")
+ finally (RETURN TAIL])
+
+(\FINDKEY.UFN
+  [LAMBDA (KEY ARGN)                                     (* bvm%: "15-Jul-86 16:51")
+
+(* ;;; "Searches argument list of current function for an argument EQ to KEY.  Search starts at the argument index given as the alpha byte ARGN and examines every other argument.  The first arg is numbered 1; i.e., arg(i) is located at ivar0 + 2*(i-1).  If KEY is found as arg i, returns i+1 (which is later to be fed to ARG0); otherwise returns NIL.")
+
+    (LET* [(CALLER (\MYALINK))
+           (BLINK (fetch (FX BLINK) of CALLER))
+           (IVAR (fetch (BF IVAR) of BLINK))
+           (NARGS (SUB1 (FOLDLO (IDIFFERENCE BLINK IVAR)
+                               WORDSPERCELL]
+          (for I from ARGN to NARGS by 2
+             as [BASE _ (STACKADDBASE (PLUS IVAR (UNFOLD (SUB1 ARGN)
+                                                            WORDSPERCELL]
+             by (\ADDBASE BASE (TIMES 2 WORDSPERCELL)) when (EQ (\GETBASEPTR
+                                                                                 BASE 0)
+                                                                               KEY)
+             do (RETURN (ADD1 I])
+)
+
+(RPAQ? CAR/CDRERR 'CDR)
+(DECLARE%: DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS CAR/CDRERR)
+)
+
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
+
+(BLOCKRECORD LISTP (
+                        (* ;; "Describes a CONS cell.")
+
+                        (CAR POINTER)
+                        (CDR POINTER))
+                       (CREATE (CREATECELL \LISTP))
+
+                       (* ;; "FOLLOWING ARE CDR-CODE FIELDS")
+
+                       (BLOCKRECORD LISTP ((CDRCODE BITS 4)
+                                           (CARFIELD XPOINTER)))
+
+                       (* ;; "For chaining together free cells on a page:")
+
+                       (BLOCKRECORD LISTP ((NEXTFREE BYTE)
+                                           (NIL BITS 24)))
+                       [ACCESSFNS LISTP ((FULLCARFIELD NIL (\PUTBASEPTR DATUM 0 NEWVALUE]
+
+                       (* ;; "because replace of XPOINTER is slow, the CAR field is stored with PUTBASEPTR, even though that smashes the hi byte")
+
+                       )
+
+(BLOCKRECORD CONSPAGE ((CNT BYTE)
+                           (NEXTCELL BYTE)
+                           (NIL WORD)
+                           (NEXTPAGE FIXP)))
+)
+
+(RPAQQ CONSCONSTANTS (\CDR.ONPAGE \CDR.NIL \CDR.INDIRECT \CDR.MAXINDIRECT \CONSPAGE.LAST))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \CDR.ONPAGE 8)
+
+(RPAQQ \CDR.NIL 8)
+
+(RPAQQ \CDR.INDIRECT 0)
+
+(RPAQQ \CDR.MAXINDIRECT 7)
+
+(RPAQQ \CONSPAGE.LAST 65535)
+
+
+(CONSTANTS \CDR.ONPAGE \CDR.NIL \CDR.INDIRECT \CDR.MAXINDIRECT \CONSPAGE.LAST)
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS .MAKECONSCELL. MACRO (OPENLAMBDA (PAGE A D)
+                                              (PROG [(.MK.NEWCELL (\ADDBASE PAGE
+                                                                         (fetch (CONSPAGE 
+                                                                                           NEXTCELL)
+                                                                            of PAGE]
+                                                    (CHECK (NEQ (fetch (CONSPAGE CNT)
+                                                                   of PAGE)
+                                                                0)
+                                                           (EVENP (fetch (CONSPAGE NEXTCELL)
+                                                                     of PAGE)))
+                                                    (replace (CONSPAGE NEXTCELL) of PAGE
+                                                       with (fetch (LISTP NEXTFREE)
+                                                                   of .MK.NEWCELL))
+                                                    (CHECK (EVENP (fetch (CONSPAGE NEXTCELL)
+                                                                     of PAGE)))
+                                                    (add (fetch (CONSPAGE CNT) of PAGE)
+                                                           -1)
+                                                    (replace (LISTP FULLCARFIELD) of 
+                                                                                          .MK.NEWCELL
+                                                       with A)
+                                                    (replace (LISTP CDRCODE) of .MK.NEWCELL
+                                                       with D)
+                                                    (RETURN .MK.NEWCELL))))
+
+(PUTPROPS .FINDCLOSEPRIOR. MACRO
+          [OPENLAMBDA (PG A D)
+                 (LET ((CDROFFSET (LOGAND (\LOLOC D)
+                                         255))
+                       (OFFSET (fetch (CONSPAGE NEXTCELL) of PG))
+                       CELL PRIOR)
+                      (WHILE (NEQ OFFSET 0)
+                         DO (COND
+                                   ((AND (ILEQ OFFSET CDROFFSET)
+                                         (IGEQ OFFSET (IDIFFERENCE CDROFFSET 14)))
+
+                                    (* ;; 
+                               "There's a cell close enough.  Take it off the chain and return it.")
+
+                                    [COND
+                                       [PRIOR 
+                                              (* ;; 
+                                           "There was a prior entry in the chain; detach this one.")
+
+                                              (REPLACE (LISTP NEXTFREE) OF (\ADDBASE
+                                                                                    PG PRIOR)
+                                                 WITH (FETCH (LISTP NEXTFREE)
+                                                             OF (SETQ CELL (\ADDBASE PG 
+                                                                                      OFFSET]
+                                       (T 
+                                          (* ;; 
+                                        "No prior entry; set the conspage's NEXTCELL entry.")
+
+                                          (REPLACE (CONSPAGE NEXTCELL) OF PG
+                                             WITH (FETCH (LISTP NEXTFREE)
+                                                         OF (SETQ CELL (\ADDBASE PG OFFSET]
+                                    (add (fetch (CONSPAGE CNT) of PG)
+                                           -1)
+                                    (replace (LISTP FULLCARFIELD) of CELL with A)
+                                    (replace (LISTP CDRCODE) of CELL
+                                       with (LOGOR \CDR.ONPAGE (LRSH (IDIFFERENCE CDROFFSET 
+                                                                                OFFSET)
+                                                                         1)))
+                                    (RETURN CELL)))
+                               (SETQ PRIOR OFFSET)
+                               (SETQ OFFSET (FETCH (LISTP NEXTFREE) OF (\ADDBASE PG 
+                                                                                      OFFSET])
+
+(PUTPROPS .FINDCDRABLEPAIR. MACRO
+          [OPENLAMBDA (PG A D)
+                 (LET ((OFFSET (fetch (CONSPAGE NEXTCELL) of PG))
+                       CELL PRIOR PRIORPRIOR)
+                      (AND (IGEQ (FETCH (CONSPAGE CNT) OF PG)
+                                 2)
+                           (WHILE (NEQ OFFSET 0)
+                              DO (COND
+                                        ((AND PRIOR (ILEQ OFFSET PRIOR)
+                                              (IGEQ OFFSET (IDIFFERENCE PRIOR 14)))
+
+                                         (* ;; 
+                               "There's a cell close enough.  Take it off the chain and return it.")
+
+                                         [COND
+                                            [PRIORPRIOR 
+
+                                                   (* ;; 
+                                           "There was a prior entry in the chain; detach this one.")
+
+                                                   (REPLACE (LISTP NEXTFREE)
+                                                      OF (\ADDBASE PG PRIORPRIOR)
+                                                      WITH (FETCH (LISTP NEXTFREE)
+                                                                  OF (SETQ CELL (\ADDBASE
+                                                                                     PG OFFSET]
+                                            (T 
+                                               (* ;; 
+                                             "No prior entry; set the conspage's NEXTCELL entry.")
+
+                                               (REPLACE (CONSPAGE NEXTCELL) OF PG
+                                                  WITH (FETCH (LISTP NEXTFREE)
+                                                              OF (SETQ CELL (\ADDBASE PG 
+                                                                                       OFFSET]
+                                         (add (fetch (CONSPAGE CNT) of PG)
+                                                -2)
+                                         (\PUTBASEPTR (\ADDBASE PG PRIOR)
+                                                0 D)
+                                         (REPLACE (LISTP FULLCARFIELD) OF CELL WITH
+                                                                                       A)
+                                         (REPLACE (LISTP CDRCODE) OF CELL
+                                            WITH (LRSH (IDIFFERENCE PRIOR OFFSET)
+                                                           1))
+                                         (RETURN CELL)))
+                                    (SETQ PRIORPRIOR PRIOR)
+                                    (SETQ PRIOR OFFSET)
+                                    (SETQ OFFSET (FETCH (LISTP NEXTFREE) OF (\ADDBASE
+                                                                                     PG OFFSET])
+
+(PUTPROPS .FINDPAIR. MACRO [OPENLAMBDA (A D)
+                                          (LET ((PG (fetch DTDNEXTPAGE of \LISTPDTD))
+                                                CELL CPG)
+                                               [WHILE (IGREATERP PG 0)
+                                                  DO (COND
+                                                            ((SETQ CELL
+                                                              (.FINDCDRABLEPAIR. (SETQ CPG
+                                                                                  (CREATE POINTER
+                                                                                         PAGE# _ PG))
+                                                                     A D))
+                                                             (RETURN CELL))
+                                                            (T (SETQ PG (FETCH (CONSPAGE NEXTPAGE
+                                                                                          )
+                                                                           OF CPG]
+                                               (OR CELL (.FINDCDRABLEPAIR. (\NEXTCONSPAGE)
+                                                               A D])
+)
+
+
+(ADDTOVAR INEWCOMS (FNS \CONS.UFN \MAIKO.CONS.UFN \INITCONSPAGE \NEXTCONSPAGE))
+
+(ADDTOVAR EXPANDMACROFNS .MAKECONSCELL. .FINDCLOSEPRIOR. .FINDCDRABLEPAIR. .FINDPAIR.)
+)
+
+
+
+(* ; "testing out CONSes")
+
+(DEFINEQ
+
+(CHECKCONSPAGES
+  [LAMBDA NIL                                            (* bvm%: "29-Jan-85 22:51")
+    (COND
+       ((ZEROP CDRCODING)
+        NIL)
+       (T [for (CPAGE _ (create POINTER
+                                   PAGE# _ (fetch DTDNEXTPAGE of \LISTPDTD)))
+             do (COND
+                       ((NULL CPAGE)                         (* ; "End of free list")
+                        (RETURN))
+                       ((NEQ (NTYPX CPAGE)
+                             \LISTP)
+
+                        (* ;; "Free list not pointing at a cons page.  Test is not for LISTP because LISTP is formally defined to be false for list page bases")
+
+                        (HELP CPAGE))
+                       (T (SETQ CPAGE (create POINTER
+                                             PAGE# _ (fetch (CONSPAGE NEXTPAGE) of CPAGE]
+          (\MAPMDS 'LISTP (FUNCTION \CHECKCONSPAGE])
+
+(\CHECKCONSPAGE
+  [LAMBDA (PN)                                           (* bvm%: "27-Jan-85 14:52")
+                                                             (* ; "check if page PN is ok")
+    (PROG ((PTR (create POINTER
+                       PAGE# _ PN))
+           NXT CNT)
+          (SETQ CNT (fetch (CONSPAGE CNT) of PTR))
+          (!CHECK (EVENP (SETQ NXT (fetch (CONSPAGE NEXTCELL) of PTR))
+                         WORDSPERCELL))
+      LP  (COND
+             ((IGREATERP CNT 0)
+              (!CHECK (AND (NEQ NXT 0)
+                           (EVENP (SETQ NXT (fetch (LISTP CDRCODE) of (\ADDBASE PTR NXT))
+                                   )
+                                  WORDSPERCELL)))
+              (add CNT -1)
+              (GO LP)))
+          (!CHECK (EQ NXT 0])
+)
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS !CHECK MACRO [(X)
+                                (OR X (RAID 'X])
+)
+)
+
+
+
+(* ; "other random stuff for makeinit")
+
+(DEFINEQ
+
+(MAKEINITFIRST
+  [LAMBDA NIL                                            (* bvm%: "13-Jun-86 15:41")
+    (CREATEMDSTYPETABLE)
+    (\SETUP.HUNK.TYPENUMBERS)
+    (INITDATATYPES)
+    (PREINITARRAYS)
+    (\TURN.ON.HUNKING)
+    (INITATOMS)
+    (INITDATATYPENAMES)
+    (INITUFNTABLE)
+    (INITGC)
+    (\NEWPAGE \InterfacePage NIL T])
+
+(MAKEINITLAST
+  [LAMBDA (VERSIONS)                                     (* Pavel "17-Oct-86 12:42")
+    (SETUPSTACK T)
+    (MAKEINITBFS)
+    (PROGN                                                   (* ; 
+                                        "fold in property list and values gathered from boot files")
+           [SELECTQ (SYSTEMTYPE)
+               ((D ALTO) 
+                    [LOCAL (MAPHASH MKI.PLHA (FUNCTION (LAMBDA (P A)
+                                                         (SETPROPLIST A (COPY P]
+                    [LOCAL (MAPHASH MKI.TVHA (FUNCTION (LAMBDA (V A)
+                                                         (SETTOPVAL A (COPY (LOCAL (CDR V])
+               (PROG (AL GAG)
+
+                (* ;; "the reason this is set up this way is because there is a bug in Interlisp-10 suchthat if a garbage collection happens in the middle of a MAPHASH, some of the values in the hash array may be missed because the garbage collector has moved stuff around and rehashed the data in the array.  Thus we are careful to set things up so that no garbage collection happens")
+
+                     [ALLOCAL (PROGN [MINFS (IMAX (MINFS)
+                                                  (ITIMES 2 (ARRAYSIZE (CAR MKI.PLHA)))
+                                                  (ARRAYSIZE (CAR MKI.TVHA]
+                                     (RECLAIM)
+                                     (SETQ GAG (GCGAG "[***** GARBAGE COLLECTION - ERROR ******]"))
+                                     [MAPHASH MKI.PLHA (FUNCTION (LAMBDA (P A)
+                                                                   (push AL (CONS A P]
+                                     (SETQ GAG (GCGAG GAG]
+                     [LOCAL (MAPC AL (FUNCTION (LAMBDA (X)
+                                                 (SETPROPLIST (CAR X)
+                                                        (COPY (CDR X]
+                     (ALLOCAL (PROGN (SETQ AL)
+                                     (RECLAIM)
+                                     (SETQ GAG (GCGAG GAG))
+                                     [MAPHASH MKI.TVHA (FUNCTION (LAMBDA (V A)
+                                                                   (push AL (RPLACA V A]
+                                     (GCGAG GAG)))
+                     (LOCAL (MAPC AL (FUNCTION (LAMBDA (X)
+                                                 (SETTOPVAL (CAR X)
+                                                        (COPY (CDR X]
+                                                             (* ; "set most initial variables")
+           )
+    (PROG ((AFL (FILEARRAYBASE)))                            (* ; 
+                                "put output on a double page boundary --- output at least one page")
+          [LOCAL (BOUTZEROS (IDIFFERENCE (TIMES 2 BYTESPERPAGE)
+                                   (UNFOLD (IMOD (\LOLOC AFL)
+                                                 (TIMES 2 WORDSPERPAGE))
+                                          BYTESPERWORD]
+          (SETQ MKI.CODELASTPAGE (PAGELOC (FILEARRAYBASE)))
+
+     (* ;; "now we can update the string/array space freelist to point beyond the code area --- We call POSTINITARRAYS with (a) pointer to word after end of compiled code, (b) page number of beginning of compiled code, and (c) page number after compiled code")
+
+          (POSTINITARRAYS AFL (IPLUS \FirstArrayPage MKI.CODESTARTOFFSET)
+                 MKI.CODELASTPAGE))
+    [MAPC (ALLOCAL (APPEND INITVALUES INITPTRS))
+          (FUNCTION (LAMBDA (X)                              (* ; 
+                                                          "make sure atoms exist for initial atoms")
+                      (\ATOMVALINDEX (LOCAL (CAR X]
+    [for X in INITVALUES as A in MKI.VALUES
+       do (SETQ A (LOCAL (EVALV A)))
+             (SETTOPVAL (LOCAL (CAR X))
+                    (COND
+                       ([ALLOCAL (OR (EQ A T)
+                                     (EQ A NIL)
+                                     (AND (FIXP A)
+                                          (IGEQ A -65536)
+                                          (ILEQ A 65535]
+                        (COPY A))
+                       (T (SHOULDNT]
+    [for X in INITPTRS as A in MKI.PTRS do (SETTOPVAL (LOCAL (CAR X))
+                                                                      (LOCAL (EVALV A]
+    (for X in LOCKEDVARS do 
+
+                                 (* ;; "If the variable exists, then we lock it.  Otherwise, just print a message and proceed anyway, hoping the fellow knows what he's doing.  We don't want to create a new piece of storage at this point because we've already made a note of where our last allocated page is.")
+
+                                       (IF (GETHASH X MKI.ATOMARRAY)
+                                           THEN (\LOCKVAR X)
+                                         ELSE (printout T "***Note: Locked var " X 
+                                                         " does not exist, proceeding anyway." T)))
+    (SETUPPAGEMAP)
+    (DUMPINITPAGES (IPLUS \FirstArrayPage MKI.CODESTARTOFFSET)
+           MKI.CODELASTPAGE VERSIONS])
+
+(\COPY
+  [LAMBDA (X)                                            (* ; "Edited 28-Jan-93 17:42 by jds")
+
+    (* ;; "Prints X into the MAKEINIT / READSYS system")
+
+    (SELECTQ (LOCAL (TYPENAME X))
+        ((LITATOM NEW-ATOM) 
+             (UNLESSRDSYS (MKI.ATOM X)
+                    (VATOMNUMBER X T)))
+        (LISTP (PROG [(R (LOCAL (REVERSE X)))
+                      (V (\COPY (LOCAL (CDR (LOCAL (LAST X]
+                 LP  (COND
+                        ((LOCAL (LISTP R))
+                         (SETQ V (CONS (\COPY (LOCAL (CAR R)))
+                                        V))
+                         (SETQ R (LOCAL (CDR R)))
+                         (GO LP)))
+                     (RETURN V)))
+        ((FIXP SMALLP) 
+             (PROG (V)
+                   [COND
+                      [(LOCAL (IGREATERP 0 X))               (* ; "negative")
+                       (COND
+                          ((LOCAL (IGREATERP X -65537))      (* ; "small neg")
+                           (RETURN (\ADDBASE \SMALLNEGSPACE (LOCAL (LOGAND X 65535]
+                      ((LOCAL (ILESSP X 65536))              (* ; "small pos")
+                       (RETURN (\ADDBASE \SMALLPOSPSPACE X]
+                                                             (* ; "need to create a boxed integer")
+                   (SETQ V (CREATECELL \FIXP))
+                   (\PUTBASE V 0 (LOGOR (COND
+                                               ((IGREATERP 0 X)
+                                                32768)
+                                               (T 0))
+                                            (LOGAND (LRSH X 16)
+                                                   32767)))
+                   (\PUTBASE V 1 (LOGAND X 65535))
+                   (RETURN V)))
+        (ONED-ARRAY (%%COPY-ONED-ARRAY X))
+        (STRINGP                                             (* ; "For bootstrapping only")
+                 (%%COPY-STRING-TO-ARRAY X))
+        (FLOATP (PROG ((VAL (CREATECELL \FLOATP)))
+                      (SELECTQ (SYSTEMTYPE)
+                          ((ALTO D) 
+                               (\PUTBASE VAL 0 (LOCAL (\GETBASE X 0)))
+                               (\PUTBASE VAL 1 (LOCAL (\GETBASE X 1))))
+                          (MKI.IEEE X VAL))
+                      (RETURN VAL)))
+        (CHARACTER (\VAG2 \CHARHI (LOCAL (LISP:CHAR-CODE X))))
+        (ERROR X "can't be copied to remote file"])
+
+(\UNCOPY
+  [LAMBDA (X CARLVL CDRLVL)                              (* ; "Edited 18-Mar-87 16:51 by raf")
+    (SELECTC (NTYPX X)
+        (\SMALLP (COND
+                    ((EQ (\HILOC X)
+                            \SmallPosHi)
+
+                     (* ;; "This test used to be SMALLPOSP until its definition changed to test (IGREATERP X 0), which doesn't work renamed")
+
+                     (\LOLOC X))
+                    (T (IPLUS (\LOLOC X)
+                              -65536))))
+        (\FIXP                                               (* ; "INTEGER")
+               (LOCAL (create FIXP
+                             HINUM _ (ffetch (FIXP HINUM) of X)
+                             LONUM _ (ffetch (FIXP LONUM) of X))))
+        (\FLOATP (LOCAL (create FLOATP
+                               HIWORD _ (ffetch (FLOATP HIWORD) of X)
+                               LOWORD _ (ffetch (FLOATP LOWORD) of X))))
+        (\LITATOM (VATOM (\LOLOC X)))
+        (\STRINGP (PROG ((PTR (ffetch (STRINGP BASE) of X))
+                         (OFFST (ffetch (STRINGP OFFST) of X))
+                         (LENGTH (ffetch (STRINGP LENGTH) of X))
+                         (I 1)
+                         STR)                                (* ; 
+                                         "Use ffetch to avoid bogus DTEST's in the renamed version")
+                        (SETQ STR (LOCAL (ALLOCSTRING LENGTH)))
+                        (FRPTQ LENGTH [LOCAL (RPLSTRING STR I (LOCAL (FCHARACTER (\GETBASEBYTE
+                                                                                  PTR OFFST]
+                               (add I 1)
+                               (add OFFST 1))
+                        (RETURN STR)))
+        (\CHARACTERP (LOCAL (\VAG2 \CHARHI (\LOLOC X))))
+        (%%ONED-ARRAY (LET ((SIZE (ffetch (ONED-ARRAY TOTAL-SIZE) of X))
+                            (BASE (ffetch (ONED-ARRAY BASE) of X))
+                            (OFFSET (ffetch (ONED-ARRAY OFFSET) of X))
+                            (TYPENUMBER (ffetch (ONED-ARRAY TYPE-NUMBER) of X))
+                            NCELLS LOCAL-ARRAY LOCAL-BASE)
+                           (if (EQ (%%TYPENUMBER-TO-GC-TYPE TYPENUMBER)
+                                          PTRBLOCK.GCT)
+                               then (LOCAL (VTYPEDPOINTER (TYPENAME X)
+                                                      X))
+                             else (SETQ NCELLS (FOLDHI (ITIMES (IPLUS SIZE OFFSET)
+                                                                  (%%TYPENUMBER-TO-BITS-PER-ELEMENT
+                                                                   TYPENUMBER))
+                                                          BITSPERCELL))
+                                   (SETQ LOCAL-ARRAY (LOCAL (create ONED-ARRAY)))
+                                   (SETQ LOCAL-BASE (LOCAL (\ALLOCBLOCK NCELLS)))
+                                   (LOCAL (freplace (ONED-ARRAY BASE) of LOCAL-ARRAY
+                                             with LOCAL-BASE))
+                                   (LOCAL (freplace (ONED-ARRAY STRING-P) of LOCAL-ARRAY
+                                             with (%%CHAR-TYPE-P TYPENUMBER)))
+                                   (LOCAL (freplace (ONED-ARRAY FILL-POINTER-P) of 
+                                                                                          LOCAL-ARRAY
+                                             with (ffetch (ONED-ARRAY FILL-POINTER-P)
+                                                         of X)))
+                                   (LOCAL (freplace (ONED-ARRAY TYPE-NUMBER) of LOCAL-ARRAY
+                                             with TYPENUMBER))
+                                   (LOCAL (freplace (ONED-ARRAY FILL-POINTER) of LOCAL-ARRAY
+                                             with (ffetch (ONED-ARRAY FILL-POINTER)
+                                                         of X)))
+                                   (if (NEQ OFFSET 0)
+                                       then (LOCAL (freplace (ONED-ARRAY OFFSET) of
+                                                                                         LOCAL-ARRAY
+                                                          with OFFSET))
+                                             (LOCAL (freplace (ONED-ARRAY DISPLACED-P)
+                                                       of LOCAL-ARRAY with T)))
+                                   (LOCAL (freplace (ONED-ARRAY TOTAL-SIZE) of LOCAL-ARRAY
+                                             with SIZE))
+                                   [for I from 0 to (SUB1 (LLSH NCELLS 1))
+                                      do (LOCAL (\PUTBASE LOCAL-BASE I (\GETBASE BASE I]
+                                   LOCAL-ARRAY)))
+        (\LISTP [COND
+                   [(LISTP X)
+                    (COND
+                       ((EQ CDRLVL 0)                    (* ; "Abbreviate")
+                        '(--))
+                       (T (LOCAL (CONS [COND
+                                              ([OR (EQ CARLVL 0)
+                                                   (AND (OR (EQ CARLVL 1)
+                                                            (EQ CDRLVL 1))
+                                                        (LISTP (CAR X]
+                                               '&)
+                                              (T (\UNCOPY (CAR X)
+                                                        (AND CARLVL (SUB1 CARLVL))
+                                                        (AND CDRLVL (SUB1 CDRLVL]
+                                        (\UNCOPY (CDR X)
+                                               CARLVL
+                                               (AND CDRLVL (SUB1 CDRLVL]
+                   (T                                        (* ; 
+                                               "Redundant LISTP test in case X is list page header")
+                      (ALLOCAL (VTYPEDPOINTER 'LISTP X])
+        (0 (LOCAL (VTYPEDPOINTER NIL X)))
+        (LOCAL (VTYPEDPOINTER (TYPENAME X)
+                      X])
+)
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS LOCAL MACRO ((X)
+                               X))
+
+(PUTPROPS ALLOCAL MACRO ((X)
+                                 X))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+
+(ADDTOVAR MKI.SUBFNS (CHECK . *)
+                         (RAID . HELP)
+                         (UNINTERRUPTABLY
+                              . PROGN)
+                         (\StatsAdd1 . *)
+                         (EVQ . I.\COPY)
+                         (COPY . I.\COPY))
+
+(ADDTOVAR RD.SUBFNS (CHECK . *)
+                        (RAID . HELP)
+                        (UNINTERRUPTABLY
+                             . PROGN)
+                        (\StatsAdd1 . *)
+                        (EVQ . V\COPY)
+                        (COPY . V\COPY)
+                        (1ST . V\UNCOPY))
+
+
+(ADDTOVAR INEWCOMS (FNS MAKEINITFIRST \COPY MAKEINITLAST))
+EVAL@COMPILE 
+
+(ADDTOVAR DONTCOMPILEFNS MAKEINITFIRST \COPY MAKEINITLAST \UNCOPY)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+(PUTPROPS LLNEW COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1990 1992 
+1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (5709 12152 (\ADDBASE 5719 . 6526) (\GETBASE 6528 . 6772) (\PUTBASE 6774 . 7050) (
+\PUTBASE.UFN 7052 . 7332) (\PUTBASEPTR.UFN 7334 . 7656) (\PUTBITS.UFN 7658 . 8364) (\GETBASEBYTE 8366
+ . 8793) (\PUTBASEBYTE 8795 . 9486) (\GETBASEPTR 9488 . 9838) (\PUTBASEPTR 9840 . 10158) (\HILOC 10160
+ . 10384) (\LOLOC 10386 . 10610) (\VAG2 10612 . 10910) (\RPLPTR 10912 . 11389) (\RPLPTR.UFN 11391 . 
+12150)) (12153 13568 (EQ 12163 . 12381) (EQL 12383 . 13566)) (13611 14361 (LOC 13621 . 13952) (VAG 
+13954 . 14359)) (14362 15403 (CREATEPAGES 14372 . 14861) (\NEW4PAGE 14863 . 15401)) (19946 37091 (CONS
+ 19956 . 20262) (\CONS.UFN 20264 . 22682) (\MAIKO.CONS.UFN 22684 . 24937) (CAR 24939 . 25066) (
+\CAR.UFN 25068 . 26171) (CDR 26173 . 26300) (\CDR.UFN 26302 . 27901) (RPLACA 27903 . 28130) (
+\RPLACA.UFN 28132 . 29131) (RPLACD 29133 . 29268) (\RPLACD.UFN 29270 . 33021) (DOCOLLECT 33023 . 33287
+) (\RPLCONS 33289 . 35299) (ENDCOLLECT 35301 . 35509) (\INITCONSPAGE 35511 . 36485) (\NEXTCONSPAGE 
+36487 . 37089)) (37149 39484 (\RESTLIST.UFN 37159 . 38257) (\FINDKEY.UFN 38259 . 39482)) (50410 52206 
+(CHECKCONSPAGES 50420 . 51359) (\CHECKCONSPAGE 51361 . 52204)) (52391 66997 (MAKEINITFIRST 52401 . 
+52739) (MAKEINITLAST 52741 . 58025) (\COPY 58027 . 60530) (\UNCOPY 60532 . 66995)))))
+STOP
diff --git a/CLTL2/LLPACKAGE b/CLTL2/LLPACKAGE
new file mode 100644
index 00000000..9cff63c2
--- /dev/null
+++ b/CLTL2/LLPACKAGE
@@ -0,0 +1,1852 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
+(IL:FILECREATED "12-Oct-93 14:48:21" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLPACKAGE.;1" 98121  
+
+      IL:|previous| IL:|date:| " 9-Oct-92 17:37:19" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>LLPACKAGE.;4|)
+
+
+; Copyright (c) 1986, 1987, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:LLPACKAGECOMS)
+
+(IL:RPAQQ IL:LLPACKAGECOMS
+          (
+           (IL:* IL:|;;| "The Xerox Lisp package system, based on CMU's Spice Lisp")
+
+           
+           (IL:* IL:|;;| "Internal macros and definitions")
+
+           (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:FUNCTIONS IL:PACKAGE-LISTIFY 
+                                                            IL:\\SIMPLE-STRINGIFY IL:SYMBOL-LISTIFY 
+                                                            IL:STRING-LISTIFY IL:COPY-STRING 
+                                                            IL:\\SYMBOL-EQUALBASE))
+           (IL:FUNCTIONS IL:\\FATCHARSEENP IL:\\PACKAGIFY IL:\\STRING-EQUALBASE IL:NUMERIC-UPCASE 
+                  IL:\\UPCASEBASE IL:APROPOS-SEARCH)
+           (IL:STRUCTURES PACKAGE-HASHTABLE PACKAGE)
+           (IL:FUNCTIONS PACKAGE-NAME PACKAGE-NICKNAMES PACKAGE-SHADOWING-SYMBOLS PACKAGE-USE-LIST 
+                  PACKAGE-USED-BY-LIST)
+           (IL:FUNCTIONS IL:MAKE-PACKAGE-HASHTABLE PRINT-PACKAGE PRINT-PACKAGE-HASHTABLE)
+           (IL:VARIABLES *PACKAGE* XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* IL:*LISP-PACKAGE* 
+                  IL:*COMMON-LISP-PACKAGE* IL:*KEYWORD-PACKAGE* IL:*INTERLISP-PACKAGE* 
+                  IL:HASHTABLE-SIZE-LIMIT IL:PACKAGE-REHASH-THRESHOLD)
+           (IL:VARIABLES IL:PRIME-HASHTABLE-SIZES)
+           
+           (IL:* IL:|;;| "The package system's version of symbol creation")
+
+           (IL:FUNCTIONS MAKE-SYMBOL)
+           
+           (IL:* IL:|;;| "Packages are currently implemented using a free byte in the litatom pnamecell.  The byte is used as an index into a table.")
+
+           (IL:VARIABLES IL:*PACKAGE-FROM-NAME* IL:*PACKAGE-FROM-INDEX* XCL:*TOTAL-PACKAGES-LIMIT* 
+                  IL:*UNINTERNED-PACKAGE-INDEX*)
+           (IL:FUNCTIONS IL:\\PKG-FIND-FREE-PACKAGE-INDEX)
+           
+           (IL:* IL:|;;| "Symbol package cell handlers.")
+
+           (IL:FUNCTIONS IL:SETF-SYMBOL-PACKAGE SYMBOL-PACKAGE)
+           
+           (IL:* IL:|;;| "Symbol hashing")
+
+           (IL:FUNCTIONS IL:SYMBOL-HASH IL:REHASH-FACTOR IL:SYMBOL-HASH-REPROBE IL:ENTRY-HASH)
+           
+           (IL:* IL:|;;| "Constructing packages")
+
+           (IL:FUNCTIONS IL:COUNT-PACKAGE-HASHTABLE IL:INTERNAL-SYMBOL-COUNT IL:EXTERNAL-SYMBOL-COUNT
+                  )
+           (IL:FUNCTIONS IL:ENTER-NEW-NICKNAMES IL:MAKE-PRIME-HASHTABLE-SIZE)
+           (IL:FUNCTIONS MAKE-PACKAGE)
+           (IL:FNS DEFPACKAGE)
+           
+           (IL:* IL:|;;| "Package manipulations")
+
+           (IL:FUNCTIONS FIND-PACKAGE USE-PACKAGE IN-PACKAGE IN-PACKAGE XCL:PKG-GOTO RENAME-PACKAGE 
+                  DELETE-PACKAGE XCL:DELETED-PACKAGE-P EXPORT UNEXPORT IMPORT SHADOWING-IMPORT SHADOW
+                  UNUSE-PACKAGE)
+           
+           (IL:* IL:|;;| "Knowing about the package name space")
+
+           (IL:FUNCTIONS LIST-ALL-PACKAGES)
+           
+           (IL:* IL:|;;| "Putting symbols into packages")
+
+           (IL:FUNCTIONS IL:ADD-SYMBOL IL:WITH-SYMBOL)
+           (IL:FUNCTIONS IL:INTERN* IL:FIND-SYMBOL*)
+           (IL:FUNCTIONS INTERN FIND-SYMBOL)
+           
+           (IL:* IL:|;;| "Removing symbols from packages")
+
+           (IL:FUNCTIONS IL:NUKE-SYMBOL)
+           (IL:FUNCTIONS UNINTERN IL:MOBY-UNINTERN)
+           
+           (IL:* IL:|;;| "Iterations over package symbols")
+
+           (IL:FUNCTIONS IL:\\INDEXATOMPNAME)
+                                                             (IL:* IL:\; 
+                                          "Defined in EXPORTS.ALL and used by the DO-SYMBOLS macro")
+           (IL:DECLARE\: IL:EVAL@COMPILE                     (IL:* IL:\; 
+                    "These are used in expanding the DO-SYMBOLS macro, which is used in this file.")
+                  (IL:FUNCTIONS IL:MAKE-DO-SYMBOLS-VARS IL:MAKE-DO-SYMBOLS-CODE))
+           (IL:FUNCTIONS DO-EXTERNAL-SYMBOLS XCL:DO-LOCAL-SYMBOLS XCL:DO-INTERNAL-SYMBOLS DO-SYMBOLS
+                  DO-ALL-SYMBOLS WITH-PACKAGE-ITERATOR)
+           
+           (IL:* IL:|;;| "Finding symbols in a package or packages")
+
+           (IL:FUNCTIONS FIND-ALL-SYMBOLS)
+           (IL:FUNCTIONS IL:BRIEFLY-DESCRIBE-SYMBOL APROPOS APROPOS-LIST)
+           
+           (IL:* IL:|;;| 
+         "Reader and printer's interface to packages (plus *PACKAGE-FROM-INDEX* above)")
+
+           (IL:FUNCTIONS IL:FIND-EXTERNAL-SYMBOL)
+           (IL:FUNCTIONS IL:FIND-EXACT-SYMBOL IL:PACKAGE-NAME-AS-SYMBOL IL:\\FIND.PACKAGE.INTERNAL)
+           
+           (IL:* IL:|;;| "Proper compiler, readtable and package environment")
+
+           (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                  IL:LLPACKAGE)
+           (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS
+                  (IL:ADDVARS (IL:NLAMA DEFPACKAGE)
+                         (IL:NLAML)
+                         (IL:LAMA)))))
+
+
+
+(IL:* IL:|;;| "The Xerox Lisp package system, based on CMU's Spice Lisp")
+
+
+
+
+(IL:* IL:|;;| "Internal macros and definitions")
+
+(IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY 
+
+(DEFMACRO IL:PACKAGE-LISTIFY (IL:OBJ)
+   "Return NIL or a list of packages given NIL or a package-or-string-or-symbol or list thereof, or die trying."
+   `(LET ((IL:THING ,IL:OBJ))
+         (COND
+            ((NULL IL:THING)
+             NIL)
+            ((IL:LISTP IL:THING)
+             (LET ((IL:RESULT NIL))
+                  (DOLIST (PACKAGE IL:THING IL:RESULT)
+                      (PUSH (IL:\\PACKAGIFY PACKAGE)
+                            IL:RESULT))))
+            (T (LIST (IL:\\PACKAGIFY IL:THING))))))
+
+(DEFMACRO IL:\\SIMPLE-STRINGIFY (IL:OBJ)
+   "If OBJ is a non-stringp-string or symbol, make it a stringp."
+   `(LET ((IL:|obj| ,IL:OBJ))
+         (COND
+            ((IL:STRINGP IL:|obj|)
+             IL:|obj|)
+            ((OR (STRINGP IL:|obj|)
+                 (SYMBOLP IL:|obj|))
+             (IL:MKSTRING IL:|obj|))
+            (T (IL:ERROR "Not a string or symbol " IL:|obj|)))))
+
+(DEFMACRO IL:SYMBOL-LISTIFY (IL:OBJ)
+   "Take a symbol-or-list-of-symbols and return a list, checking types."
+   `(LET ((IL:THING ,IL:OBJ))
+         (COND
+            ((SYMBOLP IL:THING)
+             (LIST IL:THING))
+            ((IL:LISTP IL:THING)
+             (DOLIST (IL:S IL:THING)
+                 (UNLESS (SYMBOLP IL:S)
+                        (IL:ERROR "Not a symbol." IL:S)))
+             IL:THING)
+            (T (IL:ERROR "Neither a symbol nor a list of symbols." IL:THING)))))
+
+(DEFMACRO IL:STRING-LISTIFY (IL:OBJ)
+   "Take a symbol, string, or list of symbols and strings, and return a list of strings."
+   `(WHEN ,IL:OBJ
+        (ETYPECASE ,IL:OBJ
+            (STRING (LIST ,IL:OBJ))
+            (SYMBOL (LIST (SYMBOL-NAME ,IL:OBJ)))
+            (CONS (MAPCAR #'(LAMBDA (IL:S)
+                                   (ETYPECASE IL:S
+                                       (STRING IL:S)
+                                       (SYMBOL (SYMBOL-NAME IL:S))))
+                         ,IL:OBJ)))))
+
+(DEFMACRO IL:COPY-STRING (STRING)
+   `(IL:CONCAT ,STRING))
+
+(DEFMACRO IL:\\SYMBOL-EQUALBASE (SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
+   "Compare a string, given in base offset length form, to a symbol's pname string"
+   `(AND (EQL ,IL:LENGTH (IL:|ffetch| (SYMBOL IL:PNAMELENGTH) IL:|of| ,SYMBOL))
+         (DO ((IL:I 0 (IL:ADD1 IL:I))
+              (IL:SYMBOL-BASE (IL:|ffetch| (SYMBOL IL:PNAMEBASE) IL:|of| ,SYMBOL))
+              (IL:SYMBOL-FATP (IL:|ffetch| (SYMBOL IL:FATPNAMEP) IL:|of| ,SYMBOL)))
+             ((EQL IL:I ,IL:LENGTH)
+              T)
+           (IF (NOT (EQL (IL:\\GETBASECHAR IL:SYMBOL-FATP IL:SYMBOL-BASE (IL:ADD1 IL:I))
+                         (IL:\\GETBASECHAR ,IL:FATP ,IL:BASE (IL:IPLUS ,IL:OFFSET IL:I))))
+               (RETURN NIL)))))
+)
+
+(DEFMACRO IL:\\FATCHARSEENP (IL:BASE IL:OFFSET IL:LEN IL:FATP)
+   `(AND ,IL:FATP (NOT (NULL (IL:FOR IL:I IL:FROM ,IL:OFFSET
+                                IL:TO (IL:SUB1 (IL:IPLUS ,IL:OFFSET ,IL:LEN))
+                                IL:SUCHTHAT (IL:IGREATERP (IL:\\GETBASEFAT ,IL:BASE IL:I)
+                                                       IL:\\MAXTHINCHAR))))))
+
+(DEFMACRO IL:\\PACKAGIFY (IL:OBJ)
+   "If OBJ isn't already a package, turn the symbol or string into the package of that name."
+   `(LET ((IL:|obj| ,IL:OBJ))
+         (OR (COND
+                ((PACKAGEP IL:|obj|)
+                 IL:|obj|)
+                ((STRINGP IL:|obj|)
+                 (FIND-PACKAGE IL:|obj|))
+                ((SYMBOLP IL:|obj|)
+                 (FIND-PACKAGE (SYMBOL-NAME IL:|obj|)))
+                (T NIL))
+             (IL:ERROR "Not an existing package, string or symbol " IL:|obj|))))
+
+(DEFMACRO IL:\\STRING-EQUALBASE (STRING IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
+   "Compare a string to another string, with the second given in base offset length form."
+   `(AND (EQL ,IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH)
+                                ,STRING))
+         (DO ((IL:I 0 (IL:ADD1 IL:I))
+              (IL:STRING-BASE (IL:|ffetch| (IL:STRINGP IL:BASE)
+                                     ,STRING))
+              (IL:STRING-OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST)
+                                       ,STRING))
+              (IL:STRING-FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP)
+                                     ,STRING)))
+             ((EQL IL:I ,IL:LENGTH)
+              T)
+           (IF (NOT (EQL (IL:\\GETBASECHAR IL:STRING-FATP IL:STRING-BASE (IL:IPLUS IL:STRING-OFFSET 
+                                                                                IL:I))
+                         (IL:\\GETBASECHAR ,IL:FATP ,IL:BASE (IL:IPLUS ,IL:OFFSET IL:I))))
+               (RETURN NIL)))))
+
+(DEFMACRO IL:NUMERIC-UPCASE (IL:A)
+   `(LET ((IL:N ,IL:A))
+         (IF (AND (IL:IGEQ IL:N (IL:CHARCODE "a"))
+                  (IL:ILEQ IL:N (IL:CHARCODE "z")))
+             (IL:IDIFFERENCE IL:N 32)
+             IL:N)))
+
+(DEFUN IL:\\UPCASEBASE (IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
+   (IL:|for| IL:I IL:|from| IL:OFFSET IL:|to| (IL:IPLUS IL:OFFSET IL:LENGTH)
+      IL:|do| (IL:\\PUTBASECHAR IL:FATP IL:BASE IL:I (IL:NUMERIC-UPCASE (IL:\\GETBASECHAR
+                                                                                 IL:FATP IL:BASE IL:I
+                                                                                 )))))
+
+(DEFUN IL:APROPOS-SEARCH (SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
+   "The symbol to substring comparison macro for APROPOS and APROPOS-LIST.  The string is assumed to already be uppercase."
+   (DO ((IL:INDEX 0 (IL:ADD1 IL:INDEX))
+        (IL:SYMBOL-BASE (IL:|ffetch| (SYMBOL IL:PNAMEBASE) IL:|of| SYMBOL))
+        (IL:SYMBOL-FATP (IL:|ffetch| (SYMBOL IL:FATPNAMEP) IL:|of| SYMBOL))
+        (IL:TERMINUS (IL:IDIFFERENCE (IL:|ffetch| (SYMBOL IL:PNAMELENGTH) IL:|of| SYMBOL)
+                            IL:LENGTH)))
+       ((IL:IGREATERP IL:INDEX IL:TERMINUS)
+        NIL)
+     (IF (DO ((IL:JNDEX IL:OFFSET (IL:ADD1 IL:JNDEX))
+              (IL:KNDEX IL:INDEX (IL:ADD1 IL:KNDEX))
+              (IL:TERMINUS (IL:IPLUS IL:LENGTH IL:OFFSET)))
+             ((EQL IL:JNDEX IL:TERMINUS)
+              T)
+           (UNLESS (EQL (IL:\\GETBASECHAR IL:FATP IL:BASE IL:JNDEX)
+                        (IL:NUMERIC-UPCASE (IL:\\GETBASECHAR IL:SYMBOL-FATP IL:SYMBOL-BASE
+                                                      (IL:ADD1 IL:KNDEX))))
+                  (RETURN NIL)))
+         (RETURN T))))
+
+(DEFSTRUCT (PACKAGE-HASHTABLE (:CONSTRUCTOR %MAKE-PACKAGE-HASHTABLE)
+                                  (:COPIER NIL)
+                                  (:PRINT-FUNCTION PRINT-PACKAGE-HASHTABLE))
+   "Packages are implemented using a special kind of hashtable (this one).  It is an open hashtable with a parallel 8-bit I-vector of hash-codes.  The primary purpose of the hash for each entry is to reduce paging by allowing collisions and misses to be detected without paging in the symbol and pname for an entry.  If the hash for an entry doesn't match that for the symbol that we are looking for, then we can go on without touching the symbol, pname, or even hastable vector.  It turns out that, contrary to my expectations, paging is a very important consideration the design of the package representation.  Using a similar scheme without the entry hash, the fasloader was spending more than half its time paging in INTERN.  The hash code also indicates the status of an entry.  If it zero, the the entry is unused.  If it is one, then it is deleted.  Double-hashing is used for collision resolution."
+   TABLE
+   HASH
+   SIZE
+   FREE
+   DELETED)
+
+(DEFSTRUCT (PACKAGE (:CONC-NAME %PACKAGE-)
+                        (:CONSTRUCTOR %MAKE-PACKAGE)
+                        (:PREDICATE PACKAGEP)
+                        (:PRINT-FUNCTION PRINT-PACKAGE))
+   INDEX
+   (TABLES (LIST NIL))
+   NAME NAMESYMBOL NICKNAMES (USE-LIST NIL)
+   (USED-BY-LIST NIL)
+   (EXTERNAL-ONLY NIL)
+   INTERNAL-SYMBOLS EXTERNAL-SYMBOLS (SHADOWING-SYMBOLS NIL))
+
+(DEFUN PACKAGE-NAME (PACKAGE)
+   (IF (XCL:DELETED-PACKAGE-P (SETQ PACKAGE (IL:\\PACKAGIFY PACKAGE)))
+       NIL
+       (%PACKAGE-NAME PACKAGE)))
+
+(DEFUN PACKAGE-NICKNAMES (PACKAGE)
+   (%PACKAGE-NICKNAMES (IL:\\PACKAGIFY PACKAGE)))
+
+(DEFUN PACKAGE-SHADOWING-SYMBOLS (PACKAGE)
+   (%PACKAGE-SHADOWING-SYMBOLS (IL:\\PACKAGIFY PACKAGE)))
+
+(DEFUN PACKAGE-USE-LIST (PACKAGE)
+   (%PACKAGE-USE-LIST (IL:\\PACKAGIFY PACKAGE)))
+
+(DEFUN PACKAGE-USED-BY-LIST (PACKAGE)
+   (%PACKAGE-USED-BY-LIST (IL:\\PACKAGIFY PACKAGE)))
+
+(DEFUN IL:MAKE-PACKAGE-HASHTABLE (IL:SIZE &OPTIONAL (IL:RES (%MAKE-PACKAGE-HASHTABLE)))
+   "Make a package hashtable having a prime number of entries at least as great as (/ size package-rehash-threshold).  If Res is supplied, then it is destructively modified to produce the result. This is useful when changing the size, since there are many pointers to the hashtable."
+   (LET ((IL:N (IL:MAKE-PRIME-HASHTABLE-SIZE IL:SIZE)))
+        (DECLARE (TYPE FIXNUM IL:N))
+        (SETF (PACKAGE-HASHTABLE-TABLE IL:RES)
+              (LIST (MAKE-ARRAY IL:N :ELEMENT-TYPE '(UNSIGNED-BYTE 32))))
+        (SETF (PACKAGE-HASHTABLE-HASH IL:RES)
+              (LIST (MAKE-ARRAY IL:N :ELEMENT-TYPE '(UNSIGNED-BYTE 8))))
+        (LET ((IL:SIZE (IF (EQL IL:N IL:HASHTABLE-SIZE-LIMIT)
+                           IL:HASHTABLE-SIZE-LIMIT
+                           (IL:FIX (IL:FTIMES IL:N IL:PACKAGE-REHASH-THRESHOLD)))))
+             (SETF (PACKAGE-HASHTABLE-SIZE IL:RES)
+                   IL:SIZE)
+             (SETF (PACKAGE-HASHTABLE-FREE IL:RES)
+                   IL:SIZE))
+        (SETF (PACKAGE-HASHTABLE-DELETED IL:RES)
+              0)
+        IL:RES))
+
+(DEFUN PRINT-PACKAGE (PACKAGE STREAM DEPTH)
+   (IL:PRIN3 "#<Package " STREAM)
+   (IL:PRIN3 (%PACKAGE-NAME PACKAGE)
+          STREAM)
+   (IL:PRIN3 ">" STREAM))
+
+(DEFUN PRINT-PACKAGE-HASHTABLE (TABLE STREAM DEPTH)
+   (IL:PRIN3 "#<Package-hashtable: Size = " STREAM)
+   (IL:PRIN3 (PACKAGE-HASHTABLE-SIZE TABLE)
+          STREAM)
+   (IL:PRIN3 ", Free = " STREAM)
+   (IL:PRIN3 (PACKAGE-HASHTABLE-FREE TABLE)
+          STREAM)
+   (IL:PRIN3 ", Deleted = " STREAM)
+   (IL:PRIN3 (PACKAGE-HASHTABLE-DELETED TABLE)
+          STREAM)
+   (IL:PRIN3 ">" STREAM))
+
+(DEFVAR *PACKAGE* NIL
+   "The current package, in which read symbols are intern'ed.")
+
+(DEFVAR XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* '("LISP" "INTERLISP" "XEROX-COMMON-LISP")
+                                                  "Packages whose deletion requires confirmation.")
+
+(XCL:DEFGLOBALVAR IL:*LISP-PACKAGE* NIL
+   "Global for internal references to the lisp package.")
+
+(XCL:DEFGLOBALVAR IL:*COMMON-LISP-PACKAGE* NIL
+   "Place holder for the COMMON-LISP package variable")
+
+(XCL:DEFGLOBALVAR IL:*KEYWORD-PACKAGE* NIL
+   "Global for internal references to the keyword package.")
+
+(XCL:DEFGLOBALVAR IL:*INTERLISP-PACKAGE* NIL
+   "Global for internal references to the interlisp package.")
+
+(DEFCONSTANT IL:HASHTABLE-SIZE-LIMIT 65521
+   "The maximum (inclusive, prime) limit to the size of a hashtable.")
+
+(DEFPARAMETER IL:PACKAGE-REHASH-THRESHOLD 0.5
+   "The maximum density allowed in a package hashtable")
+
+(DEFCONSTANT IL:PRIME-HASHTABLE-SIZES
+   '(7 19 67 113 199 293 397 887 1373 2347 4297 8191 15991 40763 65521)
+   "Some valid (prime) hashtable sizes.")
+
+
+
+(IL:* IL:|;;| "The package system's version of symbol creation")
+
+
+(DEFUN MAKE-SYMBOL (IL:PRINT-NAME)
+   "Make an uninterned symbol."
+   (IF (NOT (STRINGP IL:PRINT-NAME))
+       (IL:ERROR "Not a string " IL:PRINT-NAME))
+   (IL:SETQ IL:PRINT-NAME (IL:MKSTRING IL:PRINT-NAME))
+   (LET ((IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| IL:PRINT-NAME))
+         (IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| IL:PRINT-NAME))
+         (IL:LEN (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| IL:PRINT-NAME))
+         (IL:OFFST (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| IL:PRINT-NAME)))
+        (IL:UNINTERRUPTABLY
+            (IL:\\CREATE.SYMBOL IL:BASE IL:OFFST IL:LEN IL:FATP (IL:\\FATCHARSEENP IL:BASE 
+                                                                       IL:OFFST IL:LEN IL:FATP)))))
+
+
+
+(IL:* IL:|;;| 
+"Packages are currently implemented using a free byte in the litatom pnamecell.  The byte is used as an index into a table."
+)
+
+
+(XCL:DEFGLOBALVAR IL:*PACKAGE-FROM-NAME* (IL:HASHARRAY 255 'IL:ERROR 'IL:STRINGHASHBITS
+                                                    'IL:STREQUAL)
+                                             "An equal hashtable from package names to packages.")
+
+(XCL:DEFGLOBALVAR IL:*PACKAGE-FROM-INDEX* (MAKE-ARRAY 256 ':INITIAL-ELEMENT NIL)
+                                              "Index to package converter.")
+
+(DEFCONSTANT XCL:*TOTAL-PACKAGES-LIMIT* 255
+   "The total number of packages that the system may have (excluding the 'uninterned' package).")
+
+(DEFCONSTANT IL:*UNINTERNED-PACKAGE-INDEX* 0
+   "Package index value for uninterned symbols.  The function \\PKG-FIND-FREE-PACKAGE-INDEX and the constant *UNINTERNED-PACKAGE-INDEX* are arranged so that SYMBOL-PACKAGE can find NIL in the index vector and NIL can also be the free slot marker.  *UNINTERNED-PACKAGE-INDEX* must be zero, otherwise change \\PKG-FIND-FREE-PACKAGE-INDEX ."
+)
+
+(DEFUN IL:\\PKG-FIND-FREE-PACKAGE-INDEX NIL
+   "Return the next free table index for a package.  Starts counting at 1 because 0 is for uninterned symbols."
+   (DO ((IL:I 1 (IL:ADD1 IL:I)))
+       ((EQL IL:I XCL:*TOTAL-PACKAGES-LIMIT*)
+        (ERROR "Package space full" NIL))
+     (DECLARE (SPECIAL IL:*PACKAGE-FROM-INDEX*))
+     (IF (NULL (AREF IL:*PACKAGE-FROM-INDEX* IL:I))
+         (RETURN IL:I))))
+
+
+
+(IL:* IL:|;;| "Symbol package cell handlers.")
+
+
+(DEFUN IL:SETF-SYMBOL-PACKAGE (IL:OBJ IL:VALUE)
+   (IL:|freplace| (SYMBOL PACKAGE) IL:|of| IL:OBJ IL:|with| IL:VALUE)
+   IL:VALUE)
+
+(DEFUN SYMBOL-PACKAGE (SYMBOL)
+   (IL:|ffetch| (SYMBOL PACKAGE) IL:|of| SYMBOL))
+
+
+
+(IL:* IL:|;;| "Symbol hashing")
+
+
+(DEFMACRO IL:SYMBOL-HASH (IL:BASE IL:OFFST IL:LEN IL:FATP)
+   "Returns the atom hash of the given string"
+   `(IF (EQL 0 ,IL:LEN)
+        0
+        (DO* ((IL:TERMINUS (IL:IPLUS ,IL:OFFST ,IL:LEN))
+              (IL:HASH (IL:LLSH (IL:UNLESSRDSYS (COND
+                                                   (,IL:FATP (LOGAND (IL:\\GETBASEFAT ,IL:BASE
+                                                                            ,IL:OFFST)
+                                                                    255))
+                                                   (T (IL:\\GETBASETHIN ,IL:BASE ,IL:OFFST)))
+                                       (IL:NTHCHARCODE ,IL:BASE ,IL:OFFST))
+                              8)
+                     (IL:IPLUS16 (IL:IPLUS16 (IL:SETQ IL:HASH (IL:IPLUS16 IL:HASH
+                                                                     (IL:LLSH (LOGAND IL:HASH 4095)
+                                                                            2)))
+                                        (IL:LLSH (LOGAND IL:HASH 255)
+                                               8))
+                            (IL:UNLESSRDSYS (COND
+                                               (,IL:FATP (LOGAND (IL:\\GETBASEFAT ,IL:BASE IL:CHAR#)
+                                                                255))
+                                               (T (IL:\\GETBASETHIN ,IL:BASE IL:CHAR#)))
+                                   (IL:NTHCHARCODE ,IL:BASE IL:CHAR#))))
+              (IL:CHAR# (IL:ADD1 ,IL:OFFST)
+                     (IL:ADD1 IL:CHAR#)))
+             ((IL:IGEQ IL:CHAR# IL:TERMINUS)
+              IL:HASH))))
+
+(DEFMACRO IL:REHASH-FACTOR (IL:HASH IL:TABLE-LENGTH)
+   `(IL:ADD1 (IL:IREMAINDER ,IL:HASH (IL:IDIFFERENCE ,IL:TABLE-LENGTH 2))))
+
+(DEFMACRO IL:SYMBOL-HASH-REPROBE (IL:HASH IL:REHASH-FACTOR IL:TABLE-LENGTH)
+   `(IL:IREMAINDER (IL:IPLUS ,IL:HASH ,IL:REHASH-FACTOR)
+           ,IL:TABLE-LENGTH))
+
+(DEFMACRO IL:ENTRY-HASH (IL:STRING-LENGTH SXHASH)
+   "Compute a number from the sxhash of the pname and the length which must be between 2 and 255."
+   `(IL:IPLUS (IL:IREMAINDER (LOGXOR ,IL:STRING-LENGTH ,SXHASH (IL:LRSH ,SXHASH 8)
+                                    (IL:LRSH ,SXHASH 16)
+                                    (IL:LRSH ,SXHASH 19))
+                     254)
+           2))
+
+
+
+(IL:* IL:|;;| "Constructing packages")
+
+
+(DEFMACRO IL:COUNT-PACKAGE-HASHTABLE (IL:TABLE)
+   "Return two values: free elements and total size."
+   `(LET ((IL:SIZE (IL:IDIFFERENCE (PACKAGE-HASHTABLE-SIZE ,IL:TABLE)
+                          (PACKAGE-HASHTABLE-DELETED ,IL:TABLE))))
+         (VALUES (IL:IDIFFERENCE IL:SIZE (PACKAGE-HASHTABLE-FREE ,IL:TABLE))
+                IL:SIZE)))
+
+(DEFUN IL:INTERNAL-SYMBOL-COUNT (PACKAGE)
+   (IF (%PACKAGE-EXTERNAL-ONLY PACKAGE)
+       0
+       (IL:COUNT-PACKAGE-HASHTABLE (%PACKAGE-INTERNAL-SYMBOLS PACKAGE))))
+
+(DEFUN IL:EXTERNAL-SYMBOL-COUNT (PACKAGE)
+   (IL:COUNT-PACKAGE-HASHTABLE (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)))
+
+(DEFUN IL:ENTER-NEW-NICKNAMES (PACKAGE IL:NICKNAMES)
+   "Enter any new Nicknames for Package into *package-names*.  If there is a conflict then give the user a chance to do something about it."
+   (DECLARE (SPECIAL IL:*PACKAGE-FROM-NAME*))
+   (CHECK-TYPE IL:NICKNAMES LIST)
+   (DOLIST (IL:N IL:NICKNAMES)
+       (IL:SETQ IL:N (IL:\\SIMPLE-STRINGIFY IL:N))
+       (LET ((IL:FOUND (IL:GETHASH IL:N IL:*PACKAGE-FROM-NAME*)))
+            (COND
+               ((NOT IL:FOUND)
+                (IL:PUTHASH IL:N PACKAGE IL:*PACKAGE-FROM-NAME*)
+                (PUSH IL:N (%PACKAGE-NICKNAMES PACKAGE)))
+               ((EQ IL:FOUND PACKAGE))
+               ((IL:STREQUAL (%PACKAGE-NAME IL:FOUND)
+                       IL:N)
+                (IL:ERROR (IL:CONCAT IL:N 
+                                 "is already a package name, so it cannot be a nickname for "
+                                 (%PACKAGE-NAME PACKAGE))))
+               (T (IL:ERROR (IL:CONCAT IL:N " is already a nickname for " (%PACKAGE-NAME IL:FOUND)))
+                  (IL:PUTHASH IL:N PACKAGE IL:*PACKAGE-FROM-NAME*)
+                  (PUSH IL:N (%PACKAGE-NICKNAMES PACKAGE)))))))
+
+(DEFUN IL:MAKE-PRIME-HASHTABLE-SIZE (IL:N)
+   "Find an appropriate size based on the expected number of elements, N, the rehash threshold and the limit on array size."
+   (LET ((IL:N (IL:LOGOR (IL:FIX (IL:FQUOTIENT IL:N IL:PACKAGE-REHASH-THRESHOLD))
+                      1)))
+        (DOLIST (IL:X IL:PRIME-HASHTABLE-SIZES IL:HASHTABLE-SIZE-LIMIT)
+            (WHEN (IL:IGEQ IL:X IL:N)
+                  (RETURN IL:X)))))
+
+(DEFUN MAKE-PACKAGE (NAME &KEY (USE '("LISP"))
+                              NICKNAMES PREFIX-NAME (EXTERNAL-ONLY NIL)
+                              (INTERNAL-SYMBOLS 10)
+                              (EXTERNAL-SYMBOLS 10)
+                              SIZE)
+   "Check for package name conflicts in name and nicknames, then make the package.  Do a use-package for each thing in the use list so that checking for conflicting exports among used packages is done."
+   (DECLARE (SPECIAL IL:*PACKAGE-FROM-INDEX* IL:*PACKAGE-FROM-NAME*))
+   (WHEN (FIND-PACKAGE NAME)
+       (IL:ERROR (IL:CONCAT "Package " NAME " already exists.")))
+   (SETF NAME (IL:MKSTRING NAME))
+   (SETF PREFIX-NAME (MAKE-SYMBOL (OR PREFIX-NAME NAME)))
+   (LET* ((%PACKAGE-INDEX (IL:\\PKG-FIND-FREE-PACKAGE-INDEX))
+          (PACKAGE (%MAKE-PACKAGE :NAME NAME :NAMESYMBOL PREFIX-NAME :EXTERNAL-ONLY EXTERNAL-ONLY 
+                          :INTERNAL-SYMBOLS (IF (NOT EXTERNAL-ONLY)
+                                                (IL:MAKE-PACKAGE-HASHTABLE
+                                                 (OR (AND SIZE (CEILING SIZE 2))
+                                                     INTERNAL-SYMBOLS))
+                                                NIL)
+                          :EXTERNAL-SYMBOLS
+                          (IL:MAKE-PACKAGE-HASHTABLE (OR (AND SIZE (IF EXTERNAL-ONLY
+                                                                           SIZE
+                                                                           (CEILING SIZE 2)))
+                                                             EXTERNAL-SYMBOLS))
+                          :INDEX %PACKAGE-INDEX)))
+         (USE-PACKAGE USE PACKAGE)
+         (IL:ENTER-NEW-NICKNAMES PACKAGE (IF (IL:STREQUAL NAME (SYMBOL-NAME PREFIX-NAME))
+                                                 NICKNAMES
+                                                 (CONS PREFIX-NAME NICKNAMES)))
+         (IL:PUTHASH NAME PACKAGE IL:*PACKAGE-FROM-NAME*)
+         (SETF (AREF IL:*PACKAGE-FROM-INDEX* %PACKAGE-INDEX)
+               PACKAGE)))
+(IL:DEFINEQ
+
+(DEFPACKAGE
+  (IL:NLAMBDA IL:ARGS                                        (IL:* IL:\; 
+                                                           "Edited  3-Apr-91 15:12 by jrb:")
+    (IL:SETQ IL:ARGS (XCL:REMOVE-COMMENTS IL:ARGS))
+    (LET ((PACKAGE (FIND-PACKAGE (CAR IL:ARGS)))
+          IL:SIZES IL:NAMESTUFF IL:SHADOWS IL:USES IL:INTERNS IL:EXPORTS IL:EXTERNAL-ONLY?)
+
+         (IL:* IL:|;;| "First, buzz through the options and bucket-sort them into the proper order")
+
+         (IL:|for| IL:OPTION IL:|in| (CDR IL:ARGS)
+            IL:|do| (IL:SELECTQ (CAR IL:OPTION)
+                              ((:INTERNAL-SYMBOLS :EXTERNAL-SYMBOLS :SIZE) 
+                                    (IL:|push| IL:SIZES IL:OPTION))
+                              ((:SHADOW :SHADOWING-IMPORT :SHADOWING-IMPORT-FROM) 
+                                    (IL:|push| IL:SHADOWS IL:OPTION))
+                              (:NICKNAMES (IL:|push| IL:NAMESTUFF (LIST :NICKNAMES (CDR IL:OPTION
+                                                                                            ))))
+                              (:PREFIX-NAME (IL:|push| IL:NAMESTUFF IL:OPTION))
+                              (:USE (IL:|push| IL:USES IL:OPTION))
+                              ((:IMPORT :IMPORT-FROM :INTERN) 
+                                    (IL:|push| IL:INTERNS IL:OPTION))
+                              (:EXPORT (IL:|push| IL:EXPORTS IL:OPTION))
+                              (:EXTERNAL-ONLY (IL:SETQ IL:EXTERNAL-ONLY? (CADR IL:OPTION)))
+                              (IL:ERROR "Invalid option for DEFPACKAGE: " (CAR IL:OPTION))))
+         (FLET ((IL:DO-SHADOWS NIL
+                       (IL:|for| IL:S IL:|in| IL:SHADOWS
+                          IL:|do| (IL:SELECTQ (CAR IL:S)
+                                            (:SHADOW (SHADOW (CDR IL:S)
+                                                            PACKAGE))
+                                            (:SHADOWING-IMPORT 
+                                                  (SHADOWING-IMPORT (CDR IL:S)
+                                                         PACKAGE))
+                                            (:SHADOWING-IMPORT-FROM 
+                                                  (LET* ((IL:SIF-PACAKGE (FIND-PACKAGE
+                                                                          (CADR IL:S)))
+                                                         (IL:SYMS (IL:|for| IL:SYM
+                                                                     IL:|in| (CDDR IL:S)
+                                                                     IL:|collect| (FIND-SYMBOL
+                                                                                       IL:SYM 
+                                                                                       IL:SIF-PACAKGE
+                                                                                       ))))
+                                                        (SHADOWING-IMPORT IL:SYMS PACKAGE)))
+                                            NIL)))
+                (IL:DO-INTERNS NIL
+                       (IL:|for| IL:I IL:|in| IL:INTERNS
+                          IL:|do| (IL:SELECTQ (CAR IL:I)
+                                            (:INTERN (DOLIST (IL:S (CDR IL:I))
+                                                         (INTERN IL:S PACKAGE)))
+                                            (:IMPORT (IMPORT (CDR IL:I)
+                                                            PACKAGE))
+                                            (:IMPORT-FROM (LET* ((IL:SIF-PACAKGE (FIND-PACKAGE
+                                                                                  (CADR IL:I)))
+                                                                 (IL:SYMS (IL:|for| IL:SYM
+                                                                             IL:|in| (CDDR IL:I)
+                                                                             IL:|collect|
+                                                                             (FIND-SYMBOL IL:SYM
+                                                                                    IL:SIF-PACAKGE)))
+                                                                 )
+                                                                (IMPORT IL:SYMS PACKAGE)))
+                                            NIL)))
+                (IL:DO-EXPORTS NIL
+                       (WHEN IL:EXPORTS
+                           (EXPORT (IL:|for| IL:S IL:|in| IL:EXPORTS
+                                          IL:|join| (IL:FOR IL:SYMBOL
+                                                           IL:IN (CDR IL:S)
+                                                           IL:COLLECT (IL:IF (IL:LITATOM
+                                                                                      IL:SYMBOL)
+                                                                              IL:THEN IL:SYMBOL
+                                                                            IL:ELSEIF
+                                                                            (IL:STRINGP IL:SYMBOL)
+                                                                              IL:THEN
+                                                                              (INTERN IL:SYMBOL 
+                                                                                     PACKAGE)
+                                                                            IL:ELSE (IL:ERROR
+                                                                                         
+                                                        "Bad object in :export option of defpackage "
+                                                                                         IL:SYMBOL)))
+                                              )
+                                  PACKAGE))))
+               (COND
+                  ((PACKAGEP PACKAGE)                        (IL:* IL:\; 
+                                 "If one already exists, test compatability of package definitions")
+                   (IF (AND IL:EXTERNAL-ONLY? (NOT (%PACKAGE-EXTERNAL-ONLY PACKAGE)))
+                       (IL:ERROR "Package NOT :external-only as asserted by defpackage: " PACKAGE))
+                   (LET (IL:VAL)
+                        (WHEN (IL:SETQ IL:VAL (IL:ASSOC :NICKNAMES IL:NAMESTUFF))
+                            (IL:ENTER-NEW-NICKNAMES PACKAGE (CADR IL:VAL)))
+                        (WHEN (IL:SETQ IL:VAL (IL:ASSOC :PREFIX-NAME IL:NAMESTUFF))
+                            (SETF (%PACKAGE-NAMESYMBOL PACKAGE)
+                                  (MAKE-SYMBOL (CADR IL:VAL)))))
+                   (IL:DO-SHADOWS)
+                   (USE-PACKAGE (IL:|for| IL:S IL:|in| IL:USES IL:|join| (CDR IL:S))
+                          PACKAGE)
+                   (IL:DO-INTERNS)
+                   (IL:DO-EXPORTS)
+
+                   (IL:* IL:|;;| "Here's the code that used to be here")
+
+                   (IL:* IL:|;;| "(|for| OPTION |in| (CDR ARGS) |do| (LET* ((KEY (COND ((LISP:KEYWORDP OPTION) OPTION) ((LISTP OPTION) (CAR OPTION)) (T (ERROR \"Bad option for defpackage \" OPTION)))) (LISP:VALUES (COND ((LISP:KEYWORDP OPTION) (LIST T)) ((LISTP OPTION) (CDR OPTION)) (T (ERROR \"Bad option for defpackage \" OPTION))))) (SELECTQ KEY ((:INTERNAL-SYMBOLS :EXTERNAL-SYMBOLS) NIL) (:EXTERNAL-ONLY (LISP:IF (NOT (LISP::%PACKAGE-EXTERNAL-ONLY PACKAGE)) (ERROR \"Package NOT :external-only as asserted by defpackage: \" PACKAGE))) (:PREFIX-NAME (LISP:SETF (LISP::%PACKAGE-NAMESYMBOL PACKAGE) (LISP:MAKE-SYMBOL (CAR LISP:VALUES)))) (:USE (LISP:USE-PACKAGE LISP:VALUES PACKAGE)) (:NICKNAMES (ENTER-NEW-NICKNAMES PACKAGE LISP:VALUES)) (:EXPORT (EXPORT (FOR SYMBOL IN LISP:VALUES COLLECT (IF (LITATOM SYMBOL) THEN SYMBOL ELSEIF (STRINGP SYMBOL) THEN (LISP:INTERN SYMBOL PACKAGE) ELSE (ERROR \"Bad object in :export option of defpackage \" SYMBOL))) PACKAGE)) (:IMPORT (IMPORT LISP:VALUES PACKAGE)) ((:SHADOW :SHADOWING-IMPORT) (LET ((SYMBOLS-TO-SHADOW (MAPCONC LISP:VALUES (FUNCTION (LAMBDA (LISP:SYMBOL) (COND ((NOT (MEMB LISP:SYMBOL (LISP::%PACKAGE-SHADOWING-SYMBOLS PACKAGE))) (LIST LISP:SYMBOL)))))))) (SELECTQ KEY (:SHADOW (LISP:SHADOW SYMBOLS-TO-SHADOW PACKAGE)) (:SHADOWING-IMPORT (LISP:SHADOWING-IMPORT SYMBOLS-TO-SHADOW PACKAGE)) NIL))) (ERROR \"Bad keyword for defpackage \" KEY))))")
+
+                   )
+                  (T                                         (IL:* IL:\; "Otherwise, make a new package to spec; insure it doesn't :USE anything yet (MAKE-PACKAGE still :USEs LISP by default; backward-compatibility, y'know)")
+                     (IL:SETQ PACKAGE (APPLY #'MAKE-PACKAGE `(,(CAR IL:ARGS)
+                                                              :USE NIL ,@(APPLY #'APPEND IL:SIZES)
+                                                              ,@(APPLY #'APPEND IL:NAMESTUFF))))
+                     (IL:DO-SHADOWS)
+                     (USE-PACKAGE (IL:|for| IL:S IL:|in| IL:USES
+                                         IL:|join| (CDR IL:S))
+                            PACKAGE)
+                     (IL:DO-INTERNS)
+                     (IL:DO-EXPORTS)
+
+                     (IL:* IL:|;;| "Here's the code that used to be here")
+
+                     (IL:* IL:|;;| "(LET ((POST-MAKE-FORMS NIL)) (SETQ PACKAGE (APPLY 'LISP:MAKE-PACKAGE (CONS (CAR ARGS) (|for| OPTION |in| (CDR ARGS) |join| (LET ((KEY (COND ((LISP:KEYWORDP OPTION) OPTION) ((LISTP OPTION) (CAR OPTION)) (T (ERROR \"Bad option for defpackage \" OPTION)))) (LISP:VALUES (COND ((LISP:KEYWORDP OPTION) (LIST T)) ((LISTP OPTION) (CDR OPTION)) (T (ERROR \"Bad option for defpackage \" OPTION))))) (SELECTQ KEY ((:USE :NICKNAMES) (LIST KEY (|if| (CAR LISP:VALUES) |then| LISP:VALUES |else| ; Handles case where NIL is being used to explicitly say the package's :USE list is empty, since the default is to use LISP. NIL))) ((:PREFIX-NAME :INTERNAL-SYMBOLS :EXTERNAL-SYMBOLS :EXTERNAL-ONLY) (LIST KEY (CAR LISP:VALUES))) ((:SHADOW :EXPORT :IMPORT :SHADOWING-IMPORT) (SETQ POST-MAKE-FORMS (CONS (CONS KEY LISP:VALUES) POST-MAKE-FORMS)) NIL) (ERROR \"Bad keyword for defpackage \" KEY))))))) (MAPC POST-MAKE-FORMS (FUNCTION (LAMBDA (FORM) (SELECTQ (CAR FORM) (:SHADOW (LISP:SHADOW (CDR FORM) PACKAGE)) (:EXPORT (EXPORT (FOR SYMBOL IN (CDR FORM) COLLECT (IF (LITATOM SYMBOL) THEN SYMBOL ELSEIF (STRINGP SYMBOL) THEN (LISP:INTERN SYMBOL PACKAGE) ELSE (ERROR \"Bad object in :export option of defpackage \" SYMBOL))) PACKAGE)) (:IMPORT (IMPORT (CDR FORM) PACKAGE)) (:SHADOWING-IMPORT (LISP:SHADOWING-IMPORT (CDR FORM) PACKAGE)) (SHOULDNT \"Bogus form on post-make-forms\"))))))")
+
+                     )))
+         PACKAGE)))
+)
+
+
+
+(IL:* IL:|;;| "Package manipulations")
+
+
+(DEFUN FIND-PACKAGE (IL:NAME)
+   "Given a name, find the package with that name or nickname"
+   (DECLARE (SPECIAL IL:*PACKAGE-FROM-NAME*))
+   (ETYPECASE IL:NAME
+       (PACKAGE IL:NAME)
+       (STRING (IL:GETHASH IL:NAME IL:*PACKAGE-FROM-NAME* NIL))
+       (SYMBOL (IL:GETHASH (SYMBOL-NAME IL:NAME)
+                      IL:*PACKAGE-FROM-NAME* NIL))))
+
+(DEFUN USE-PACKAGE (IL:PACKAGES-TO-USE &OPTIONAL (PACKAGE *PACKAGE*))
+   "Make a package use (inherit) symbols from others.  Checks for name-conflicts."
+   (DECLARE (SPECIAL *PACKAGE*))
+   (IL:SETQ PACKAGE (IL:\\PACKAGIFY PACKAGE))
+
+   (IL:* IL:|;;| " Loop over each package, use'ing one at a time...")
+
+   (DOLIST (IL:PKG (IL:PACKAGE-LISTIFY IL:PACKAGES-TO-USE))
+       (UNLESS (IL:FMEMB IL:PKG (%PACKAGE-USE-LIST PACKAGE))
+           (LET ((IL:CSET NIL)
+                 (IL:SHADOWING-SYMBOLS (%PACKAGE-SHADOWING-SYMBOLS PACKAGE))
+                 (IL:USE-LIST (%PACKAGE-USE-LIST PACKAGE)))
+
+                (IL:* IL:|;;| "If the number of symbols already available is less than the number to be inherited then it is faster to run the test the other way.  This is particularly valuable in the case of a new package use'ing Lisp.")
+
+                (COND
+                   ((IL:ILESSP (IL:IPLUS (IL:INTERNAL-SYMBOL-COUNT PACKAGE)
+                                      (IL:EXTERNAL-SYMBOL-COUNT PACKAGE)
+                                      (LET ((IL:RES 0))
+                                           (DOLIST (IL:P IL:USE-LIST IL:RES)
+                                               (INCF IL:RES (IL:EXTERNAL-SYMBOL-COUNT IL:P)))))
+                           (IL:EXTERNAL-SYMBOL-COUNT IL:PKG))
+                    (DO-SYMBOLS (IL:SYM PACKAGE)
+                           (MULTIPLE-VALUE-BIND (IL:S IL:W)
+                                  (IL:FIND-EXTERNAL-SYMBOL (SYMBOL-NAME IL:SYM)
+                                         IL:PKG)
+                                  (WHEN (AND IL:W (NOT (EQ IL:S IL:SYM))
+                                             (NOT (IL:FMEMB IL:SYM IL:SHADOWING-SYMBOLS)))
+                                      (PUSHNEW IL:SYM IL:CSET :TEST 'EQ))))
+                    (DOLIST (IL:P IL:USE-LIST)
+                        (DO-EXTERNAL-SYMBOLS
+                         (IL:SYM IL:P)
+                         (MULTIPLE-VALUE-BIND (IL:S IL:W)
+                                (IL:FIND-EXTERNAL-SYMBOL (SYMBOL-NAME IL:SYM)
+                                       IL:PKG)
+                                (WHEN (AND IL:W (NOT (EQ IL:S IL:SYM))
+                                           (NOT (IL:FMEMB (INTERN (SYMBOL-NAME IL:SYM)
+                                                                 PACKAGE)
+                                                       IL:SHADOWING-SYMBOLS)))
+                                    (PUSHNEW IL:SYM IL:CSET :TEST 'EQ))))))
+                   (T (DO-EXTERNAL-SYMBOLS (IL:SYM IL:PKG)
+                             (MULTIPLE-VALUE-BIND (IL:S IL:W)
+                                    (FIND-SYMBOL (SYMBOL-NAME IL:SYM)
+                                           PACKAGE)
+                                    (WHEN (AND IL:W (NOT (EQ IL:S IL:SYM))
+                                               (NOT (IL:FMEMB IL:S IL:SHADOWING-SYMBOLS)))
+                                        (PUSHNEW IL:S IL:CSET :TEST 'EQ))))))
+                (WHEN IL:CSET (IL:RESOLVE-USE-PACKAGE-CONFLICT IL:PKG IL:CSET PACKAGE)))
+           (PUSH IL:PKG (%PACKAGE-USE-LIST PACKAGE))
+           (PUSH (%PACKAGE-EXTERNAL-SYMBOLS IL:PKG)
+                 (CDR (%PACKAGE-TABLES PACKAGE)))
+           (PUSH PACKAGE (%PACKAGE-USED-BY-LIST IL:PKG))))
+   T)
+
+(DEFMACRO IN-PACKAGE (NAME)
+   `(EVAL-WHEN (COMPILE LOAD EVAL)
+           (IF (FIND-PACKAGE ',NAME)
+               (SETQ *PACKAGE* (FIND-PACKAGE ',NAME))
+               (ERROR "Non-existent package: ~a" ',NAME))))
+
+(DEFMACRO IN-PACKAGE (NAME)
+   `(EVAL-WHEN (COMPILE LOAD EVAL)
+           (IF (FIND-PACKAGE ',NAME)
+               (SETQ *PACKAGE* (FIND-PACKAGE ',NAME))
+               (ERROR "Non-existent package: ~a" ',NAME))))
+
+(DEFUN XCL:PKG-GOTO (XCL::NAME &REST XCL::KEYS)
+   "Like in-package, but confirms creation of new packages."
+   (WHEN (OR (PACKAGEP (FIND-PACKAGE XCL::NAME))
+             (Y-OR-N-P "Create new package ~a?" XCL::NAME))
+       (APPLY 'IN-PACKAGE XCL::NAME XCL::KEYS)))
+
+(DEFUN RENAME-PACKAGE (PACKAGE IL:NAME &OPTIONAL IL:NICKNAMES IL:PREFIX-NAME)
+   "Change the name if we can, blast any old nicknames and then add in any new ones."
+   (DECLARE (SPECIAL IL:*PACKAGE-FROM-NAME*))
+   (SETF PACKAGE (IL:\\PACKAGIFY PACKAGE))
+   (SETF IL:NAME (IL:\\SIMPLE-STRINGIFY IL:NAME))
+   (SETF IL:PREFIX-NAME (MAKE-SYMBOL (OR IL:PREFIX-NAME IL:NAME)))
+   (LET ((IL:FOUND (FIND-PACKAGE IL:NAME)))
+        (UNLESS (OR (NOT IL:FOUND)
+                    (EQ IL:FOUND PACKAGE))
+               (ERROR "A package named ~S already exists." IL:NAME))
+        (REMHASH (%PACKAGE-NAME PACKAGE)
+               IL:*PACKAGE-FROM-NAME*)
+        (SETF (%PACKAGE-NAME PACKAGE)
+              IL:NAME)
+        (SETF (%PACKAGE-NAMESYMBOL PACKAGE)
+              IL:PREFIX-NAME)
+        (IL:PUTHASH IL:NAME PACKAGE IL:*PACKAGE-FROM-NAME*)
+        (DOLIST (IL:N (%PACKAGE-NICKNAMES PACKAGE))
+            (REMHASH IL:N IL:*PACKAGE-FROM-NAME*))
+        (SETF (%PACKAGE-NICKNAMES PACKAGE)
+              NIL)
+        (IL:ENTER-NEW-NICKNAMES PACKAGE IL:NICKNAMES)
+        PACKAGE))
+
+(DEFUN DELETE-PACKAGE (XCL::PACKAGE-SPEC)
+
+(IL:* IL:|;;;| "All other packages unuse this one, all the package's symbols are uninterned and then its name is removed.")
+
+   (DECLARE (SPECIAL IL:*PACKAGE-FROM-NAME*))
+
+   (IL:* IL:|;;| "Technically this is wrong; if PACKAGE-SPEC doesn't name a package, we don't go into a continuable error.  I'll fix it later,by moving this into a later file.")
+
+   (LET ((PACKAGE (IL:\\PACKAGIFY XCL::PACKAGE-SPEC)))
+        (WHEN 
+              (IL:* IL:|;;| "Break if PACKAGE-SPEC doesn't name a package, or we're deleting the current  *PACKAGE*, or this package is on the *UNSAFE-TO-DELETE-PACKAGE-NAMES* list; return NIL immediately if the package is already deleted")
+(OR (AND (NULL PACKAGE)
+
+         (IL:* IL:|;;| "This perverted EVAL is required here because CERROR expands into a CONDITION-CASE, and the early init can't handle creating objects like that yet.  When I get disgusted with this, I'll move this function into a file later in the init")
+
+         (EVAL `(CERROR "Return NIL from DELETE-PACKAGE" 
+                       "~S does not name a package in DELETE-PACKAGE" ',XCL::PACKAGE-SPEC)))
+    (XCL:DELETED-PACKAGE-P PACKAGE)
+    (AND (EQ PACKAGE *PACKAGE*)
+         (NOT (YES-OR-NO-P "About to delete the current package; this is dangerous, are you sure?")))
+    (AND (MEMBER (%PACKAGE-NAME PACKAGE)
+                XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* :TEST 'STRING=)
+         (NOT (YES-OR-NO-P "About to delete the ~a package; this is dangerous, are you sure?"
+                     (%PACKAGE-NAME PACKAGE)))))
+            (RETURN-FROM DELETE-PACKAGE NIL))
+        (WHEN (%PACKAGE-USED-BY-LIST PACKAGE)
+            (EVAL `(CERROR "Unuse it from other packages and delete it anyway" 
+                          "~S is being deleted, but is used by ~S" ',PACKAGE
+                          ',(%PACKAGE-USED-BY-LIST PACKAGE)))
+            (DOLIST (XCL::USER (%PACKAGE-USED-BY-LIST PACKAGE))
+                (UNUSE-PACKAGE PACKAGE XCL::USER)))
+        (DOLIST (XCL::USED (%PACKAGE-USE-LIST PACKAGE))
+            (UNUSE-PACKAGE XCL::USED PACKAGE))
+        (XCL:DO-LOCAL-SYMBOLS (SYMBOL PACKAGE)
+               (WHEN (EQ PACKAGE (SYMBOL-PACKAGE SYMBOL))
+                     (UNINTERN SYMBOL PACKAGE)))
+        (REMHASH (%PACKAGE-NAME PACKAGE)
+               IL:*PACKAGE-FROM-NAME*)
+        (DOLIST (IL:NAME (%PACKAGE-NICKNAMES PACKAGE))
+            (REMHASH IL:NAME IL:*PACKAGE-FROM-NAME*))
+        (SETF (AREF IL:*PACKAGE-FROM-INDEX* (%PACKAGE-INDEX PACKAGE))
+              NIL)
+        T))
+
+(DEFUN XCL:DELETED-PACKAGE-P (PACKAGE)
+
+   (IL:* IL:|;;| "A deleted package is not findable in the IL:*PACKAGE-FROM-INDEX* array")
+
+   (NOT (EQ PACKAGE (AREF IL:*PACKAGE-FROM-INDEX* (%PACKAGE-INDEX PACKAGE)))))
+
+(DEFUN EXPORT (IL:SYMBOLS &OPTIONAL (PACKAGE *PACKAGE*))
+   "Make the symbols external in the package."
+   (DECLARE (SPECIAL *PACKAGE*))
+   (SETF PACKAGE (IL:\\PACKAGIFY PACKAGE))
+   (LET ((IL:SYMS NIL))
+
+        (IL:* IL:|;;| "Punt any symbols that are already external.")
+
+        (DOLIST (IL:SYM (IL:SYMBOL-LISTIFY IL:SYMBOLS))
+            (MULTIPLE-VALUE-BIND (IL:S IL:W)
+                   (IL:FIND-EXTERNAL-SYMBOL (SYMBOL-NAME IL:SYM)
+                          PACKAGE)
+                   (UNLESS (OR IL:W (IL:FMEMB IL:SYM IL:SYMS))
+                          (PUSH IL:SYM IL:SYMS))))
+
+        (IL:* IL:|;;| "Find symbols and packages with conflicts.")
+
+        (LET ((IL:USED-BY (%PACKAGE-USED-BY-LIST PACKAGE))
+              (IL:CPACKAGES NIL)
+              (IL:CSET NIL))
+             (DOLIST (IL:SYM IL:SYMS)
+                 (LET ((IL:NAME (SYMBOL-NAME IL:SYM)))
+                      (DOLIST (IL:P IL:USED-BY)
+                          (MULTIPLE-VALUE-BIND (IL:S IL:W)
+                                 (FIND-SYMBOL IL:NAME IL:P)
+                                 (WHEN (AND IL:W (NOT (EQ IL:S IL:SYM))
+                                            (NOT (IL:FMEMB IL:S (%PACKAGE-SHADOWING-SYMBOLS IL:P))))
+                                     (PUSHNEW IL:SYM IL:CSET)
+                                     (PUSHNEW IL:P IL:CPACKAGES))))))
+             (WHEN IL:CSET                                   (IL:* IL:\; "Resolve conflict")
+                 (IL:SETQ IL:SYMS (IL:RESOLVE-EXPORT-CONFLICT PACKAGE IL:CSET IL:CPACKAGES IL:SYMS)))
+             )
+
+        (IL:* IL:|;;| "Check that all symbols are available.  If not, ask to import them.")
+
+        (LET ((IL:MISSING NIL)
+              (IL:IMPORTS NIL))
+             (DOLIST (IL:SYM IL:SYMS)
+                 (MULTIPLE-VALUE-BIND (IL:S IL:W)
+                        (FIND-SYMBOL (SYMBOL-NAME IL:SYM)
+                               PACKAGE)
+                        (COND
+                           ((NOT (AND IL:W (EQ IL:S IL:SYM)))
+                            (PUSH IL:SYM IL:MISSING))
+                           ((EQ IL:W :INHERITED)
+                            (PUSH IL:SYM IL:IMPORTS)))))
+             (WHEN IL:MISSING                                (IL:* IL:\; "Get missing symbols")
+                 (IL:RESOLVE-EXPORT-MISSING PACKAGE IL:MISSING))
+             (WHEN IL:IMPORTS                                (IL:* IL:\; "Get inherited symbols")
+                 (IMPORT IL:IMPORTS PACKAGE)))
+
+        (IL:* IL:|;;| "And now we export the symbols.")
+
+        (LET ((IL:INTERNAL (%PACKAGE-INTERNAL-SYMBOLS PACKAGE))
+              (IL:EXTERNAL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)))
+             (DOLIST (IL:SYM IL:SYMS)
+                 (IF (NOT (%PACKAGE-EXTERNAL-ONLY PACKAGE))
+                     (IL:NUKE-SYMBOL IL:INTERNAL (SYMBOL-NAME IL:SYM)))
+                 (IL:ADD-SYMBOL IL:EXTERNAL IL:SYM)))
+        T))
+
+(DEFUN UNEXPORT (IL:SYMBOLS &OPTIONAL (PACKAGE *PACKAGE*))
+   "Check that all symbols are available, then move from external to internal."
+   (DECLARE (SPECIAL *PACKAGE*))
+   (SETF PACKAGE (IL:\\PACKAGIFY PACKAGE))
+   (WHEN (%PACKAGE-EXTERNAL-ONLY PACKAGE)
+       (IL:ERROR (IL:CONCAT "Can't unexport symbols " IL:SYMBOLS " from an external-only package " 
+                        PACKAGE)))
+   (LET ((IL:SYMS NIL))
+        (DOLIST (IL:SYM (IL:SYMBOL-LISTIFY IL:SYMBOLS))
+            (MULTIPLE-VALUE-BIND (IL:S IL:W)
+                   (FIND-SYMBOL (SYMBOL-NAME IL:SYM)
+                          PACKAGE)
+                   (COND
+                      ((OR (NOT IL:W)
+                           (NOT (EQ IL:S IL:SYM)))
+                       (ERROR "~S is not available in the ~A package." IL:SYM (SYMBOL-NAME PACKAGE)))
+                      ((EQ IL:W :EXTERNAL)
+                       (PUSHNEW IL:SYM IL:SYMS)))))
+        (LET ((IL:INTERNAL (%PACKAGE-INTERNAL-SYMBOLS PACKAGE))
+              (IL:EXTERNAL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)))
+             (DOLIST (IL:SYM IL:SYMS)
+                 (IL:ADD-SYMBOL IL:INTERNAL IL:SYM)
+                 (IL:NUKE-SYMBOL IL:EXTERNAL (SYMBOL-NAME IL:SYM))))
+        T))
+
+(DEFUN IMPORT (SYMBOLS &OPTIONAL (PACKAGE *PACKAGE*))
+   "Make the symbol internal in the package, noting name conflicts."
+   (DECLARE (SPECIAL *PACKAGE*))
+   (SETF PACKAGE (IL:\\PACKAGIFY PACKAGE))
+   (LET ((SYMS NIL)
+         (CSET NIL))
+        (DOLIST (SYM (IL:SYMBOL-LISTIFY SYMBOLS))
+            (MULTIPLE-VALUE-BIND (S W)
+                   (FIND-SYMBOL (SYMBOL-NAME SYM)
+                          PACKAGE)
+                   (COND
+                      ((NOT W)
+                       (LET ((FOUND (MEMBER SYM SYMS :TEST 'IL:STREQUAL)))
+                            (IF FOUND
+                                (WHEN (NOT (EQ (CAR FOUND)
+                                               SYM))
+                                      (PUSH SYM CSET))
+                                (PUSH SYM SYMS))))
+                      ((NOT (EQ S SYM))
+                       (PUSH SYM CSET))
+                      ((EQ W :INHERITED)
+                       (PUSH SYM SYMS)))))
+        (WHEN CSET                                           (IL:* IL:\; "Display the conflict")
+            (IL:RESOLVE-IMPORT-CONFLICT PACKAGE CSET))
+        (LET ((HASHTABLE (IF (%PACKAGE-EXTERNAL-ONLY PACKAGE)
+                             (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
+                             (%PACKAGE-INTERNAL-SYMBOLS PACKAGE))))
+             (DOLIST (SYM SYMS)
+                 (IL:ADD-SYMBOL HASHTABLE SYM)
+                 (IF (NULL (SYMBOL-PACKAGE SYM))
+                     (SETF (SYMBOL-PACKAGE SYM)
+                           PACKAGE))))
+        (IF CSET
+            (SHADOWING-IMPORT CSET PACKAGE)
+            T)))
+
+(DEFUN SHADOWING-IMPORT (IL:SYMBOLS &OPTIONAL (PACKAGE *PACKAGE*))
+   "If a conflicting symbol is present, unintern it, otherwise just stick the symbol in."
+   (DECLARE (SPECIAL *PACKAGE*))
+   (SETF PACKAGE (IL:\\PACKAGIFY PACKAGE))
+   (LET ((IL:HASHTABLE (IF (%PACKAGE-EXTERNAL-ONLY PACKAGE)
+                           (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
+                           (%PACKAGE-INTERNAL-SYMBOLS PACKAGE))))
+        (DOLIST (IL:SYM (IL:SYMBOL-LISTIFY IL:SYMBOLS))
+            (MULTIPLE-VALUE-BIND (IL:S IL:W)
+                   (FIND-SYMBOL (SYMBOL-NAME IL:SYM)
+                          PACKAGE)
+                   (UNLESS (AND IL:W (EQ IL:S IL:SYM))
+                       (WHEN (OR (EQ IL:W :INTERNAL)
+                                 (EQ IL:W :EXTERNAL))        (IL:* IL:\; 
+                                              " If it was shadowed, we don't want Unintern to fail")
+                           (SETF (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)
+                                 (DELETE IL:S (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)))
+                           (UNINTERN IL:S PACKAGE))
+                       (IL:ADD-SYMBOL IL:HASHTABLE IL:SYM))
+                   (PUSHNEW IL:SYM (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)))))
+   T)
+
+(DEFUN SHADOW (IL:SYMBOLS &OPTIONAL (PACKAGE *PACKAGE*))
+   "Hide the existing symbols with new ones in the package."
+   (DECLARE (SPECIAL *PACKAGE*))
+   (SETF PACKAGE (IL:\\PACKAGIFY PACKAGE))
+   (LET ((IL:HASHTABLE (IF (%PACKAGE-EXTERNAL-ONLY PACKAGE)
+                           (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
+                           (%PACKAGE-INTERNAL-SYMBOLS PACKAGE))))
+        (WHEN IL:SYMBOLS
+            (DOLIST (IL:NAME (IL:STRING-LISTIFY IL:SYMBOLS))
+                (MULTIPLE-VALUE-BIND (IL:S IL:W)
+                       (FIND-SYMBOL IL:NAME PACKAGE)
+                       (UNLESS (OR (EQ IL:W :INTERNAL)
+                                   (EQ IL:W :EXTERNAL))
+                           (IL:SETQ IL:S (MAKE-SYMBOL IL:NAME))
+                           (SETF (SYMBOL-PACKAGE IL:S)
+                                 PACKAGE)
+                           (IL:ADD-SYMBOL IL:HASHTABLE IL:S)
+                           (PUSHNEW IL:S (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)))))))
+   T)
+
+(DEFUN UNUSE-PACKAGE (IL:PACKAGES-TO-UNUSE &OPTIONAL (PACKAGE *PACKAGE*))
+   "Remove some packages from the use (inherit) list of another package."
+   (DECLARE (SPECIAL *PACKAGE*))
+   (SETF PACKAGE (IL:\\PACKAGIFY PACKAGE))
+   (DOLIST (IL:P (IL:PACKAGE-LISTIFY IL:PACKAGES-TO-UNUSE))
+       (SETF (%PACKAGE-USE-LIST PACKAGE)
+             (IL:REMOVE IL:P (%PACKAGE-USE-LIST PACKAGE)))
+       (SETF (%PACKAGE-TABLES PACKAGE)
+             (IL:REMOVE (%PACKAGE-EXTERNAL-SYMBOLS IL:P)
+                    (%PACKAGE-TABLES PACKAGE)))
+       (SETF (%PACKAGE-USED-BY-LIST IL:P)
+             (IL:REMOVE PACKAGE (%PACKAGE-USED-BY-LIST IL:P))))
+   T)
+
+
+
+(IL:* IL:|;;| "Knowing about the package name space")
+
+
+(DEFUN LIST-ALL-PACKAGES NIL
+   "Return a list of the names of all existing packages."
+   (DECLARE (SPECIAL IL:*PACKAGE-FROM-NAME*))
+   (LET ((IL:RES NIL))
+        (MAPHASH #'(LAMBDA (IL:K IL:V)
+                          (PUSHNEW IL:V IL:RES))
+               IL:*PACKAGE-FROM-NAME*)
+        IL:RES))
+
+
+
+(IL:* IL:|;;| "Putting symbols into packages")
+
+
+(DEFUN IL:ADD-SYMBOL (IL:TABLE SYMBOL)
+   "Add a symbol to a package hashtable.  The symbol is assumed not to be present."
+   (LET* ((IL:VEC (PACKAGE-HASHTABLE-TABLE IL:TABLE))
+          (IL:HASH (PACKAGE-HASHTABLE-HASH IL:TABLE))
+          (IL:LEN (ARRAY-TOTAL-SIZE (CAR IL:VEC)))
+          (IL:SIZE (PACKAGE-HASHTABLE-SIZE IL:TABLE))
+          (IL:SYMBOL-BASE (IL:|ffetch| (SYMBOL IL:PNAMEBASE) IL:|of| SYMBOL))
+          (IL:SYMBOL-LENGTH (IL:|ffetch| (SYMBOL IL:PNAMELENGTH) IL:|of| SYMBOL))
+          (IL:SYMBOL-FATP (IL:|ffetch| (SYMBOL IL:FATPNAMEP) IL:|of| SYMBOL))
+          (SXHASH (IL:SYMBOL-HASH IL:SYMBOL-BASE 1 IL:SYMBOL-LENGTH IL:SYMBOL-FATP))
+          (IL:H2 (IL:REHASH-FACTOR SXHASH IL:LEN)))
+         (DECLARE (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 32))
+                            IL:VEC)
+                (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8))
+                      IL:HASH))
+         (COND
+            ((<= (PACKAGE-HASHTABLE-FREE IL:TABLE)
+                 (IL:LRSH IL:SIZE 2))
+
+             (IL:* IL:|;;| "Let each hash table get at most 75% full, so we have a reasonable chance of makeing a clear hash miss in few reprobes.  Formerly, there was a BIG performance hit after the initial table overflowed.")
+
+             (COND
+                ((>= IL:SIZE IL:HASHTABLE-SIZE-LIMIT)
+
+                 (IL:* IL:|;;| 
+               "We've spilled over into needing the list-of-tables feature, so add to the list.")
+
+                 (IL:SETQ IL:VEC (IL:NCONC1 IL:VEC (MAKE-ARRAY IL:LEN :ELEMENT-TYPE
+                                                          '(UNSIGNED-BYTE 32))))
+                 (IL:SETQ IL:HASH (IL:NCONC1 IL:HASH (MAKE-ARRAY IL:LEN :ELEMENT-TYPE
+                                                            '(UNSIGNED-BYTE 8))))
+                 (SETF (PACKAGE-HASHTABLE-FREE IL:TABLE)
+                       (IL:FIX (IL:FTIMES (PACKAGE-HASHTABLE-SIZE IL:TABLE)
+                                      IL:PACKAGE-REHASH-THRESHOLD)))
+                 (IL:ADD-SYMBOL IL:TABLE SYMBOL))
+                (T 
+                   (IL:* IL:|;;| 
+                 "The initial table is still smaller than the limit.  Increase its size.")
+
+                   (LET ((IL:SIZE (PACKAGE-HASHTABLE-SIZE IL:TABLE))
+                         (IL:VEC1 (CAR IL:VEC))
+                         (IL:HASH1 (CAR IL:HASH)))
+                        (IL:MAKE-PACKAGE-HASHTABLE (IL:ITIMES IL:SIZE 2)
+                               IL:TABLE)
+                        (IL:ADD-SYMBOL IL:TABLE SYMBOL)
+                        (DOTIMES (IL:I IL:LEN)
+                            (WHEN (IL:IGREATERP (AREF IL:HASH1 IL:I)
+                                         1)
+                                (IL:ADD-SYMBOL IL:TABLE (IL:\\INDEXATOMPNAME (AREF IL:VEC1 
+                                                                                           IL:I))))))
+                   )))
+            (T (LET ((IL:THIS-HASH (CAR (IL:FLAST IL:HASH)))
+                     (IL:THIS-VEC (CAR (IL:FLAST IL:VEC))))
+                    (DO ((IL:I (IL:IREMAINDER SXHASH IL:LEN)
+                               (IL:SYMBOL-HASH-REPROBE IL:I IL:H2 IL:LEN)))
+                        ((IL:ILESSP (AREF IL:THIS-HASH IL:I)
+                                2)
+                         (IF (EQL 0 (AREF IL:THIS-HASH IL:I))
+                             (DECF (PACKAGE-HASHTABLE-FREE IL:TABLE))
+                             (DECF (PACKAGE-HASHTABLE-DELETED IL:TABLE)))
+                         (SETF (AREF IL:THIS-VEC IL:I)
+                               (IL:\\ATOMPNAMEINDEX SYMBOL))
+                         (SETF (AREF IL:THIS-HASH IL:I)
+                               (IL:ENTRY-HASH IL:SYMBOL-LENGTH SXHASH)))))))))
+
+(DEFMACRO IL:WITH-SYMBOL ((IL:INDEX-VAR IL:SYMBOL-VAR IL:TABLE IL:BASE IL:OFFSET IL:LENGTH 
+                                     IL:FATP SXHASH IL:ENTRY-HASH IL:HASH-TABLE-TABLE 
+                                     IL:HASH-TABLE-HASH)
+                              &BODY IL:FORMS)
+   "Find where the symbol named String is stored in Table.  Index-Var is bound to the index, or NIL if it is not present.  Symbol-Var is bound to the symbol.  Length and Hash are the length and sxhash of String.  Entry-Hash is the entry-hash of the string and length."
+   (LET ((IL:VEC (OR IL:HASH-TABLE-TABLE (IL:GENSYM)))
+         (IL:HASH (OR IL:HASH-TABLE-HASH (IL:GENSYM)))
+         (IL:LEN (IL:GENSYM))
+         (IL:H2 (IL:GENSYM))
+         (IL:EHASH (IL:GENSYM))
+         (IL:VECS (IL:GENSYM))
+         (IL:HASHS (IL:GENSYM))
+         (IL:LIMIT (IL:GENSYM)))
+        `(LET* ((,IL:VECS (PACKAGE-HASHTABLE-TABLE ,IL:TABLE))
+                (,IL:HASHS (PACKAGE-HASHTABLE-HASH ,IL:TABLE))
+                (,IL:LEN (ARRAY-TOTAL-SIZE (CAR ,IL:VECS)))
+                (,IL:H2 (IL:REHASH-FACTOR ,SXHASH ,IL:LEN))
+                ,IL:VEC
+                ,IL:HASH
+                ,IL:LIMIT)
+               (DECLARE (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8))
+                                  ,IL:HASH)
+                      (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 32))
+                            ,IL:VEC))
+               (PROG (,IL:INDEX-VAR ,IL:SYMBOL-VAR ,IL:EHASH)
+
+                (IL:* IL:|;;| "Loop thru all the hash tables looking for the symbol.")
+
+                 IL:OUTER-LOOP
+                     (IL:SETQ ,IL:HASH (IL:POP ,IL:HASHS))
+                                                             (IL:* IL:\; "Hashvalues")
+                     (IL:SETQ ,IL:VEC (IL:POP ,IL:VECS)) (IL:* IL:\; "The symbol vector")
+                     (IL:SETQ ,IL:INDEX-VAR (IL:IREMAINDER ,SXHASH ,IL:LEN))
+                                                             (IL:* IL:\; "Starting probe.")
+                     (IL:SETQ ,IL:LIMIT ,IL:LEN)
+                 LOOP
+                     
+
+                (IL:* IL:|;;| "Loop thru the entries in a single hash table.")
+
+                     (IL:SETQ ,IL:EHASH (AREF ,IL:HASH ,IL:INDEX-VAR))
+                     (COND
+                        ((EQL ,IL:EHASH ,IL:ENTRY-HASH)
+
+                         (IL:* IL:|;;| "SIngle-byte hash matches; try the whole name.")
+
+                         (IL:SETQ ,IL:SYMBOL-VAR (IL:\\INDEXATOMPNAME (AREF ,IL:VEC 
+                                                                                ,IL:INDEX-VAR)))
+                         (WHEN (IL:\\SYMBOL-EQUALBASE ,IL:SYMBOL-VAR ,IL:BASE ,IL:OFFSET
+                                      ,IL:LENGTH
+                                      ,IL:FATP)
+                               (GO IL:DOIT)))
+                        ((EQL 0 ,IL:EHASH)                   (IL:* IL:\; 
+                                             "Found an empty hash slot, so it's not in this table.")
+                         (COND
+                            ((NULL ,IL:HASHS)
+
+                             (IL:* IL:|;;| 
+                    "we've run out of sub-tables to look in.  Give the we-couldn't-find-it signal.")
+
+                             (IL:SETQ ,IL:INDEX-VAR NIL)
+                             (GO IL:DOIT))
+                            (T (GO IL:OUTER-LOOP))))
+                        ((EQL 0 (IL:SETQ ,IL:LIMIT (IL:SUB1 ,IL:LIMIT)))
+                                                             (IL:* IL:\; 
+                                      "We.ve been thru the whole table, so it's not in this table.")
+                         (COND
+                            ((NULL ,IL:HASHS)
+
+                             (IL:* IL:|;;| 
+                    "we've run out of sub-tables to look in.  Give the we-couldn't-find-it signal.")
+
+                             (IL:SETQ ,IL:INDEX-VAR NIL)
+                             (GO IL:DOIT))
+                            (T (GO IL:OUTER-LOOP)))))
+                     (IL:SETQ ,IL:INDEX-VAR (IL:SYMBOL-HASH-REPROBE ,IL:INDEX-VAR ,IL:H2
+                                                   ,IL:LEN))
+                     (GO LOOP)
+                 IL:DOIT
+                     (RETURN (PROGN ,@IL:FORMS))))))
+
+(DEFUN IL:INTERN* (IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:FATCHARSEENP PACKAGE IL:EXTERNALP)
+   "If the symbol doesn't exist then create it, special-casing the keyword package."
+   (DECLARE (SPECIAL IL:*KEYWORD-PACKAGE*))
+   (MULTIPLE-VALUE-BIND (SYMBOL IL:WHERE)
+          (IL:FIND-SYMBOL* IL:BASE IL:OFFSET IL:LENGTH IL:FATP PACKAGE)
+          (IF IL:WHERE
+              (VALUES SYMBOL IL:WHERE)
+              (LET ((SYMBOL (IL:UNINTERRUPTABLY
+                                (IL:\\CREATE.SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP 
+                                       IL:FATCHARSEENP))))
+                   (SETF (SYMBOL-PACKAGE SYMBOL)
+                         PACKAGE)
+                   (COND
+                      ((EQ PACKAGE IL:*KEYWORD-PACKAGE*)
+                       (IL:ADD-SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS IL:*KEYWORD-PACKAGE*)
+                              SYMBOL)
+                       (SET SYMBOL SYMBOL))
+                      ((OR IL:EXTERNALP (%PACKAGE-EXTERNAL-ONLY PACKAGE))
+                       (IL:ADD-SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
+                              SYMBOL))
+                      (T (IL:ADD-SYMBOL (%PACKAGE-INTERNAL-SYMBOLS PACKAGE)
+                                SYMBOL)))
+                   (VALUES SYMBOL NIL)))))
+
+(DEFUN IL:FIND-SYMBOL* (IL:BASE IL:OFFSET IL:LENGTH IL:FATP PACKAGE)
+   "Check internal and external symbols, then scan down the list of hashtables for inherited symbols. When an inherited symbol is found pull that table to the beginning of the list."
+
+   (IL:* IL:|;;| "Find a symbol in the package given, if it eexists.")
+
+   (LET* ((IL:HASH (IL:SYMBOL-HASH IL:BASE IL:OFFSET IL:LENGTH IL:FATP))
+          (IL:EHASH (IL:ENTRY-HASH IL:LENGTH IL:HASH))
+          (IL:RESULT (IL:\\CREATECELL IL:\\FIXP))
+          IL:SYM IL:WHERE (IL:DONE))
+         (UNLESS (%PACKAGE-EXTERNAL-ONLY PACKAGE)
+             (IL:NEW-SYMBOL-CODE (PROGN (IL:SETQ IL:SYM ((IL:OPCODES IL:SUBRCALL 145 6)
+                                                         IL:BASE IL:OFFSET IL:LENGTH IL:FATP
+                                                         (%PACKAGE-INTERNAL-SYMBOLS PACKAGE)
+                                                         IL:RESULT))
+                                        (COND
+                                           ((NOT (IL:IEQP IL:RESULT -1))
+                                            (IL:SETQ IL:WHERE :INTERNAL)
+                                            (IL:SETQ IL:DONE T))))
+                    (IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-INTERNAL-SYMBOLS PACKAGE)
+                                               IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH 
+                                               NIL NIL)
+                           (WHEN IL:FOUND
+
+                               (IL:* IL:|;;| 
+                             "Was (cl:return-from find-symbol* (cl:values cl:symbol :internal))")
+
+                               (IL:SETQ IL:WHERE :INTERNAL)
+                               (IL:SETQ IL:DONE T)))))
+         (UNLESS IL:DONE
+             (IL:NEW-SYMBOL-CODE (PROGN (IL:SETQ IL:SYM ((IL:OPCODES IL:SUBRCALL 145 6)
+                                                         IL:BASE IL:OFFSET IL:LENGTH IL:FATP
+                                                         (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
+                                                         IL:RESULT))
+                                        (COND
+                                           ((NOT (IL:IEQP IL:RESULT -1))
+                                            (IL:SETQ IL:WHERE :EXTERNAL)
+                                            (IL:SETQ IL:DONE T))))
+                    (IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
+                                               IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH 
+                                               NIL NIL)
+                           (WHEN IL:FOUND
+
+                               (IL:* IL:|;;| 
+                             "Was (cl:return-from find-symbol* (cl:values cl:symbol :external))")
+
+                               (IL:SETQ IL:SYM SYMBOL)
+                               (IL:SETQ IL:WHERE :EXTERNAL)
+                               (IL:SETQ IL:DONE T)))))
+         (UNLESS IL:DONE
+             (LET ((IL:HEAD (%PACKAGE-TABLES PACKAGE)))
+                  (DO ((IL:PREV IL:HEAD IL:TABLE)
+                       (IL:TABLE (CDR IL:HEAD)
+                              (CDR IL:TABLE)))
+                      ((OR IL:DONE (NULL IL:TABLE))
+                       (VALUES NIL NIL))
+                    (IL:NEW-SYMBOL-CODE (PROGN (IL:SETQ IL:SYM ((IL:OPCODES IL:SUBRCALL 145 6)
+                                                                IL:BASE IL:OFFSET IL:LENGTH IL:FATP
+                                                                (CAR IL:TABLE)
+                                                                IL:RESULT))
+                                               (COND
+                                                  ((NOT (IL:IEQP IL:RESULT -1))
+                                                   (UNLESS (EQ IL:PREV IL:HEAD)
+                                                       (SHIFTF (CDR IL:PREV)
+                                                              (CDR IL:TABLE)
+                                                              (CDR IL:HEAD)
+                                                              IL:TABLE))
+
+                                                   (IL:* IL:|;;| 
+                               "Was (cl:return-from find-symbol* (cl:values cl:symbol :inherited))")
+
+                                                   (IL:SETQ IL:WHERE :INHERITED)
+                                                   (IL:SETQ IL:DONE T))))
+                           (IL:WITH-SYMBOL (IL:FOUND SYMBOL (CAR IL:TABLE)
+                                                      IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH 
+                                                      IL:EHASH NIL NIL)
+                                  (WHEN IL:FOUND
+                                      (UNLESS (EQ IL:PREV IL:HEAD)
+                                          (SHIFTF (CDR IL:PREV)
+                                                 (CDR IL:TABLE)
+                                                 (CDR IL:HEAD)
+                                                 IL:TABLE))
+
+                                      (IL:* IL:|;;| 
+                               "Was (cl:return-from find-symbol* (cl:values cl:symbol :inherited))")
+
+                                      (IL:SETQ IL:SYM SYMBOL)
+                                      (IL:SETQ IL:WHERE :INHERITED)
+                                      (IL:SETQ IL:DONE T)))))))
+         (VALUES IL:SYM IL:WHERE)))
+
+(DEFUN INTERN (IL:NAME &OPTIONAL (PACKAGE *PACKAGE*))
+   "Intern the name in the package, returning a symbol."
+   (DECLARE (SPECIAL *PACKAGE*))
+   (IL:SETQ IL:NAME (COND
+                       ((IL:STRINGP IL:NAME)
+                        IL:NAME)
+                       ((STRINGP IL:NAME)
+                        (IL:MKSTRING IL:NAME))
+                       (T (IL:ERROR "Not a string " IL:NAME))))
+   (COND
+      ((NULL PACKAGE)                                        (IL:* IL:\; 
+                                                          "XCL extension, makes uninterned symbols")
+       (MAKE-SYMBOL IL:NAME))
+      (T                                                     (IL:* IL:\; 
+                                                           "Package is at least non-null")
+         (IL:SETQ PACKAGE (IL:\\PACKAGIFY PACKAGE))
+         (LET ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| IL:NAME))
+               (IL:OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| IL:NAME))
+               (IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| IL:NAME))
+               (IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| IL:NAME)))
+              (IL:INTERN* IL:BASE IL:OFFSET IL:LENGTH IL:FATP (IL:\\FATCHARSEENP IL:BASE 
+                                                                         IL:OFFSET IL:LENGTH IL:FATP)
+                     PACKAGE NIL)))))
+
+(DEFUN FIND-SYMBOL (IL:NAME &OPTIONAL (PACKAGE *PACKAGE*))
+   "Find a symbol with the given name in a package."
+   (DECLARE (SPECIAL *PACKAGE*))
+   (IL:SETQ IL:NAME (IL:\\SIMPLE-STRINGIFY IL:NAME))
+   (IL:SETQ PACKAGE (IL:\\PACKAGIFY PACKAGE))
+   (IL:FIND-SYMBOL* (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| IL:NAME)
+          (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| IL:NAME)
+          (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| IL:NAME)
+          (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| IL:NAME)
+          PACKAGE))
+
+
+
+(IL:* IL:|;;| "Removing symbols from packages")
+
+
+(DEFUN IL:NUKE-SYMBOL (IL:TABLE STRING)
+   "Mark a symbol in a package-hashtable deleted"
+   (IL:SETQ STRING (IL:MKSTRING STRING))
+   (LET* ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| STRING))
+          (IL:OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| STRING))
+          (IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| STRING))
+          (IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| STRING))
+          (IL:HASH (IL:SYMBOL-HASH IL:BASE IL:OFFSET IL:LENGTH IL:FATP))
+          (IL:EHASH (IL:ENTRY-HASH IL:LENGTH IL:HASH)))
+         (IL:WITH-SYMBOL (IL:INDEX SYMBOL IL:TABLE IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH 
+                                    IL:EHASH NIL IL:TABLE-HASH)
+                (SETF (AREF IL:TABLE-HASH IL:INDEX)
+                      1)
+                (INCF (PACKAGE-HASHTABLE-DELETED IL:TABLE)))))
+
+(DEFUN UNINTERN (SYMBOL &OPTIONAL (PACKAGE *PACKAGE*))
+   "Remove a symbol from a package.  If uninterning a shadowing symbol, then a name conflict can result, otherwise just nuke the symbol."
+   (DECLARE (SPECIAL *PACKAGE*))
+   (IL:SETQ PACKAGE (IL:\\PACKAGIFY PACKAGE))
+   (LET* ((IL:NAME (SYMBOL-NAME SYMBOL))
+          (IL:SHADOWING-SYMBOLS (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)))
+         (DECLARE (TYPE LIST IL:SHADOWING-SYMBOLS)
+                (SPECIAL *QUERY-IO*))
+         (WHEN (IL:FMEMB SYMBOL IL:SHADOWING-SYMBOLS)
+             (LET ((IL:CSET NIL))
+
+                  (IL:* IL:|;;| "If a name conflict is revealed, give the user a chance to shadowing-import one of the available symbols.")
+
+                  (DOLIST (IL:P (%PACKAGE-USE-LIST PACKAGE))
+                      (MULTIPLE-VALUE-BIND (IL:S IL:W)
+                             (IL:FIND-EXTERNAL-SYMBOL IL:NAME IL:P)
+                             (WHEN IL:W (PUSHNEW IL:S IL:CSET))))
+                  (WHEN (CDR IL:CSET)                        (IL:* IL:\; 
+                                                   "If there is more than one, handle the conflict")
+                      (IL:RESOLVE-UNINTERN-CONFLICT SYMBOL IL:CSET PACKAGE)))
+             (SETF (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)
+                   (DELETE SYMBOL IL:SHADOWING-SYMBOLS :TEST #'EQ)))
+         (MULTIPLE-VALUE-BIND (IL:S IL:W)
+                (FIND-SYMBOL IL:NAME PACKAGE)
+                (COND
+                   ((AND (EQ IL:S SYMBOL)
+                         (OR (EQ IL:W :INTERNAL)
+                             (EQ IL:W :EXTERNAL)))
+                    (IL:NUKE-SYMBOL (IF (EQ IL:W :INTERNAL)
+                                            (%PACKAGE-INTERNAL-SYMBOLS PACKAGE)
+                                            (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE))
+                           IL:NAME)
+                    (IF (EQ (SYMBOL-PACKAGE SYMBOL)
+                            PACKAGE)
+                        (SETF (SYMBOL-PACKAGE SYMBOL)
+                              NIL))
+                    T)
+                   (T NIL)))))
+
+(DEFUN IL:MOBY-UNINTERN (SYMBOL PACKAGE)
+   "Like Unintern, but if symbol is inherited chases down the package it is inherited from and uninterns it there.  Used for name-conflict resolution.  Shadowing symbols are not uninterned since they do not cause conflicts."
+   (UNLESS (IL:FMEMB SYMBOL (%PACKAGE-SHADOWING-SYMBOLS PACKAGE))
+       (OR (UNINTERN SYMBOL PACKAGE)
+           (LET ((IL:NAME (SYMBOL-NAME SYMBOL)))
+                (MULTIPLE-VALUE-BIND (IL:S IL:W)
+                       (FIND-SYMBOL IL:NAME PACKAGE)
+                       (WHEN (EQ IL:W :INHERITED)
+                           (DOLIST (IL:Q (%PACKAGE-USE-LIST PACKAGE))
+                               (MULTIPLE-VALUE-BIND (IL:U IL:X)
+                                      (IL:FIND-EXTERNAL-SYMBOL IL:NAME IL:Q)
+                                      (WHEN IL:X
+                                          (UNINTERN SYMBOL IL:Q)
+                                          (IL:RETFROM 'IL:MOBY-UNINTERN T)
+
+                                          (IL:* IL:|;;| "Was (cl:return-from moby-unintern t)")
+
+                                          )))))))))
+
+
+
+(IL:* IL:|;;| "Iterations over package symbols")
+
+
+(DEFUN IL:\\INDEXATOMPNAME (IL:X)
+   (IL:\\INDEXATOMPNAME IL:X))
+
+
+
+(IL:* IL:\; "Defined in EXPORTS.ALL and used by the DO-SYMBOLS macro")
+
+(IL:DECLARE\: IL:EVAL@COMPILE 
+
+(DEFUN IL:MAKE-DO-SYMBOLS-VARS NIL
+   `(,(IL:GENSYM)
+     ,(IL:GENSYM)
+     ,(IL:GENSYM)
+     ,(IL:GENSYM)
+     ,(IL:GENSYM)
+     ,(IL:GENSYM)))
+
+(DEFUN IL:MAKE-DO-SYMBOLS-CODE (IL:VARS IL:VAR HASH-TABLE IL:EXIT-FORM IL:FORMS &OPTIONAL
+                                          (IL:LOOPTAG NIL))
+   (LET ((IL:INDEX (FIRST IL:VARS))
+         (IL:HASH-VECTOR (SECOND IL:VARS))
+         (IL:HASH (THIRD IL:VARS))
+         (IL:TERMINUS (FOURTH IL:VARS))
+         (IL:HASH-VECTOR-LIST (FIFTH IL:VARS))
+         (IL:TABLE-VECTOR-LIST (SIXTH IL:VARS))
+         (IL:TOP (IL:GENSYM))
+         (IL:REAL-TOP (IL:GENSYM)))
+
+        (IL:* IL:|;;| 
+      "LOOPTAG is for support of WITH-PACKAGE-ITERATOR; go look at its code for details")
+
+        `((IL:SETQ ,IL:TABLE-VECTOR-LIST (PACKAGE-HASHTABLE-TABLE ,HASH-TABLE))
+          (IL:SETQ ,IL:HASH-VECTOR-LIST (PACKAGE-HASHTABLE-HASH ,HASH-TABLE))
+          ,IL:REAL-TOP
+          (IL:SETQ ,IL:INDEX 0)
+          (IL:SETQ ,IL:HASH-VECTOR (IL:POP ,IL:TABLE-VECTOR-LIST))
+          (IL:SETQ ,IL:HASH (IL:POP ,IL:HASH-VECTOR-LIST))
+          (IL:SETQ ,IL:TERMINUS (ARRAY-TOTAL-SIZE (THE (SIMPLE-ARRAY (UNSIGNED-BYTE 32))
+                                                       ,IL:HASH-VECTOR)))
+          ,IL:TOP
+          (IF (EQL ,IL:INDEX ,IL:TERMINUS)
+              (IF (NULL ,IL:TABLE-VECTOR-LIST)
+                  ,IL:EXIT-FORM
+                  (GO ,IL:REAL-TOP)))
+          (WHEN (IL:IGREATERP (AREF (THE (SIMPLE-ARRAY (UNSIGNED-BYTE 8))
+                                         ,IL:HASH)
+                                    ,IL:INDEX)
+                       1)
+              (IL:SETQ ,IL:VAR (IL:\\INDEXATOMPNAME (AREF ,IL:HASH-VECTOR ,IL:INDEX)))
+              ,@IL:FORMS)
+
+          (IL:* IL:|;;| "Only insert the LOOPTAG if it is supplied")
+
+          ,@(AND IL:LOOPTAG `(,IL:LOOPTAG))
+          (INCF ,IL:INDEX)
+          (GO ,IL:TOP))))
+)
+
+(DEFMACRO DO-EXTERNAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
+                                          IL:RESULT-FORM)
+                                   &BODY
+                                   (IL:CODE IL:DECLS))
+   "Do-External-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms once for each external symbol in the given Package with Var bound to the current symbol."
+   (LET ((IL:VARS (IL:MAKE-DO-SYMBOLS-VARS)))
+        `(PROG (,IL:VAR ,@IL:VARS)
+               ,@IL:DECLS
+               ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS ,PACKAGE)
+                        `(RETURN (PROGN (IL:SETQ ,IL:VAR NIL)
+                                        ,IL:RESULT-FORM))
+                        IL:CODE))))
+
+(DEFMACRO XCL:DO-LOCAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
+                                           IL:RESULT-FORM)
+                                    &BODY
+                                    (IL:CODE IL:DECLS))
+   "Do-Local-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms at least once for each symbol actually in the given Package with Var bound to the current symbol."
+   (LET* ((IL:DONE-INTERNAL (IL:GENSYM))
+          (IL:DONE-EXTERNAL (IL:GENSYM))
+          (IL:VARS (IL:MAKE-DO-SYMBOLS-VARS))
+          (IL:N-PACKAGE (IL:GENSYM)))
+         `(PROG* ((,IL:N-PACKAGE ,PACKAGE)
+                  ,IL:VAR
+                  ,@IL:VARS)
+                 ,@IL:DECLS
+                 (WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE)
+                     (GO ,IL:DONE-INTERNAL))
+                 ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS
+                                                                 ,PACKAGE)
+                          `(GO ,IL:DONE-INTERNAL)
+                          IL:CODE)
+                 ,IL:DONE-INTERNAL
+                 ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS
+                                                                 ,PACKAGE)
+                          `(GO ,IL:DONE-EXTERNAL)
+                          IL:CODE)
+                 ,IL:DONE-EXTERNAL
+                 (IL:SETQ ,IL:VAR NIL)
+                 (RETURN ,IL:RESULT-FORM))))
+
+(DEFMACRO XCL:DO-INTERNAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
+                                              IL:RESULT-FORM)
+                                       &BODY
+                                       (IL:CODE IL:DECLS))
+   "Do-Internal-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms at least once for each symbol actually in the given Package and not exported with Var bound to the current symbol."
+   (LET* ((IL:DONE-INTERNAL (IL:GENSYM))
+          (IL:VARS (IL:MAKE-DO-SYMBOLS-VARS))
+          (IL:N-PACKAGE (IL:GENSYM)))
+         `(PROG* ((,IL:N-PACKAGE ,PACKAGE)
+                  ,IL:VAR
+                  ,@IL:VARS)
+                 ,@IL:DECLS
+                 (WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE)
+                     (GO ,IL:DONE-INTERNAL))
+                 ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS
+                                                                 ,PACKAGE)
+                          `(GO ,IL:DONE-INTERNAL)
+                          IL:CODE)
+                 ,IL:DONE-INTERNAL
+                 (IL:SETQ ,IL:VAR NIL)
+                 (RETURN ,IL:RESULT-FORM))))
+
+(DEFMACRO DO-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
+                                 IL:RESULT-FORM)
+                          &BODY
+                          (IL:CODE IL:DECLS))
+   "Do-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms at least once for each symbol accessible in the given Package with Var bound to the current symbol."
+   (LET* ((IL:DONE-INTERNAL (IL:GENSYM))
+          (IL:DONE-EXTERNAL (IL:GENSYM))
+          (IL:NEXT-INHERIT (IL:GENSYM))
+          (IL:VARS (IL:MAKE-DO-SYMBOLS-VARS))
+          (IL:N-PACKAGE (IL:GENSYM))
+          (IL:SHADOWED (IL:GENSYM))
+          (IL:INHERITS (IL:GENSYM))
+          (IL:THIS-INHERIT (IL:GENSYM)))
+         `(PROG* ((,IL:N-PACKAGE ,PACKAGE)
+                  (,IL:SHADOWED (%PACKAGE-SHADOWING-SYMBOLS ,IL:N-PACKAGE))
+                  (,IL:INHERITS (CDR (%PACKAGE-TABLES ,IL:N-PACKAGE)))
+                  ,IL:VAR
+                  ,@IL:VARS
+                  ,IL:THIS-INHERIT)
+                 ,@IL:DECLS
+                 (WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE)
+                     (GO ,IL:DONE-INTERNAL))
+                 ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS
+                                                                 ,PACKAGE)
+                          `(GO ,IL:DONE-INTERNAL)
+                          IL:CODE)
+                 ,IL:DONE-INTERNAL
+                 ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS
+                                                                 ,PACKAGE)
+                          `(GO ,IL:DONE-EXTERNAL)
+                          IL:CODE)
+                 ,IL:DONE-EXTERNAL
+                 ,IL:NEXT-INHERIT
+                 (WHEN (NULL ,IL:INHERITS)
+                     (IL:SETQ ,IL:VAR NIL)
+                     (RETURN ,IL:RESULT-FORM))
+                 (IL:SETQ ,IL:THIS-INHERIT (CAR ,IL:INHERITS))
+                 ,@(IL:MAKE-DO-SYMBOLS-CODE
+                    IL:VARS IL:VAR IL:THIS-INHERIT `(PROGN (IL:SETQ ,IL:INHERITS (CDR ,IL:INHERITS))
+                                                           (GO ,IL:NEXT-INHERIT))
+                    `((WHEN (OR (NOT ,IL:SHADOWED)
+                                (EQ (FIND-SYMBOL (SYMBOL-NAME ,IL:VAR)
+                                           ,IL:N-PACKAGE)
+                                    ,IL:VAR))
+                            ,@IL:CODE))))))
+
+(DEFMACRO DO-ALL-SYMBOLS ((IL:VAR &OPTIONAL IL:RESULT-FORM)
+                              &BODY
+                              (IL:CODE IL:DECLS))
+   "Do-All-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms once for each symbol in each package with Var bound to the current symbol."
+   (LET* ((IL:PACKAGE-LOOP (IL:GENSYM))
+          (IL:TAG (IL:GENSYM))
+          (IL:PACKAGE-LIST (IL:GENSYM))
+          (IL:VARS (IL:MAKE-DO-SYMBOLS-VARS))
+          (IL:INTERNAL-CODE (IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR
+                                   `(%PACKAGE-INTERNAL-SYMBOLS (CAR ,IL:PACKAGE-LIST))
+                                   `(GO ,IL:TAG)
+                                   IL:CODE))
+          (IL:EXTERNAL-CODE (IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR
+                                   `(%PACKAGE-EXTERNAL-SYMBOLS (CAR ,IL:PACKAGE-LIST))
+                                   `(PROGN (IL:SETQ ,IL:PACKAGE-LIST (CDR ,IL:PACKAGE-LIST))
+                                           (GO ,IL:PACKAGE-LOOP))
+                                   IL:CODE)))
+         `(PROG (,IL:PACKAGE-LIST ,IL:VAR ,@IL:VARS)
+                ,@IL:DECLS
+                (IL:SETQ ,IL:PACKAGE-LIST (LIST-ALL-PACKAGES))
+                ,IL:PACKAGE-LOOP
+                (WHEN (NULL ,IL:PACKAGE-LIST)
+                    (IL:SETQ ,IL:VAR NIL)
+                    (RETURN ,IL:RESULT-FORM))
+                (WHEN (%PACKAGE-EXTERNAL-ONLY (CAR ,IL:PACKAGE-LIST))
+                    (GO ,IL:TAG))
+                ,@IL:INTERNAL-CODE
+                ,IL:TAG
+                ,@IL:EXTERNAL-CODE)))
+
+(DEFMACRO WITH-PACKAGE-ITERATOR ((MNAME PACKAGE-LIST &REST SYMBOL-TYPES)
+                                     &BODY FORM)
+
+   (IL:* IL:|;;| "The idea behind the mess below is to make the \"macro\" MNAME actually be a call to an FLET-bound function that walks through the package list, keeping the state of what atom to return next in a set of LET-bound gensyms.  Seperate loops for external, internal, and inherited symbols are generated only when requested in the SYMBOL-TYPES list.")
+
+   (LET
+    ((STATE (GENSYM))                                        (IL:* IL:\; "Where to resume")
+     (PLSYM (GENSYM))                                        (IL:* IL:\; "List of packages to walk")
+     (N-PACKAGE (GENSYM))                                    (IL:* IL:\; "Current package")
+     (VAR (GENSYM))                                          (IL:* IL:\; "Current atom to return")
+     (VARS (IL:MAKE-DO-SYMBOLS-VARS))                    (IL:* IL:\; "DO-SYMBOLS vars")
+     DONE-EXTERNAL DONE-INTERNAL DONE-INHERITS               (IL:* IL:\; 
+                           "Controls generation of :external, :internal, :inherited code fragments")
+     NEXT-INHERIT SHADOWED INHERITS THIS-INHERIT)
+
+    (IL:* IL:|;;| "Must be at least one symbol-type")
+
+    (UNLESS SYMBOL-TYPES (ERROR "No symbol-type specified in WITH-PACKAGE-ITERATOR"))
+
+    (IL:* IL:|;;| "First, check what parts of the code we need to generate")
+
+    (WHEN (MEMBER :EXTERNAL SYMBOL-TYPES)
+        (SETQ DONE-EXTERNAL (GENSYM))
+        (SETQ SYMBOL-TYPES (REMOVE :EXTERNAL SYMBOL-TYPES)))
+    (WHEN (MEMBER :INTERNAL SYMBOL-TYPES)
+        (SETQ DONE-INTERNAL (GENSYM))
+        (SETQ SYMBOL-TYPES (REMOVE :INTERNAL SYMBOL-TYPES)))
+    (WHEN (MEMBER :INHERITED SYMBOL-TYPES)
+        (SETQ DONE-INHERITS (GENSYM))
+        (SETQ NEXT-INHERIT (GENSYM))
+        (SETQ SHADOWED (GENSYM))
+        (SETQ INHERITS (GENSYM))
+        (SETQ THIS-INHERIT (GENSYM))
+        (SETQ SYMBOL-TYPES (REMOVE :INHERITED SYMBOL-TYPES)))
+
+    (IL:* IL:|;;| "Barf if anything is left on SYMBOL-TYPES")
+
+    (WHEN SYMBOL-TYPES (ERROR "Illegal symbol-types in WITH-PACKAGE-ITERATOR: ~a" SYMBOL-TYPES))
+
+    (IL:* IL:|;;| "Finally, the generated code")
+
+    `(LET*
+      ((,STATE 'MORE-PACKAGES)
+       (,PLSYM (IL:PACKAGE-LISTIFY ,PACKAGE-LIST))
+       ,N-PACKAGE
+       ,VAR
+       ,@VARS
+       ,@(WHEN DONE-INHERITS
+             `(,SHADOWED ,INHERITS ,THIS-INHERIT)))
+      (FLET
+       ((,MNAME
+         NIL
+         (TAGBODY
+
+          (IL:* IL:|;;| "This handles re-entry into MNAME; the STATE variable remembers what we were doing when we found the previous symbol")
+
+          (ECASE ,STATE
+              (MORE-PACKAGES (GO MORE-PACKAGES))
+              (IL:\\\,@ (WHEN DONE-EXTERNAL
+                            '((MORE-EXTERNS (GO MORE-EXTERNS)))))
+              (IL:\\\,@ (WHEN DONE-INTERNAL
+                            '((MORE-INTERNS (GO MORE-INTERNS)))))
+              (IL:\\\,@ (WHEN DONE-INHERITS
+                            '((MORE-INHERITS (GO MORE-INHERITS))))))
+          MORE-PACKAGES
+          (WHEN (NULL ,PLSYM)
+              (RETURN-FROM ,MNAME NIL))
+          (SETQ ,N-PACKAGE (POP ,PLSYM))
+
+          (IL:* IL:|;;| "The :EXTERNAL symbol loop")
+
+          ,@(WHEN DONE-EXTERNAL
+                `(,@(IL:MAKE-DO-SYMBOLS-CODE VARS VAR `(%PACKAGE-EXTERNAL-SYMBOLS ,N-PACKAGE)
+                           `(GO ,DONE-EXTERNAL)
+                           `((SETQ ,STATE 'MORE-EXTERNS)
+                             (RETURN-FROM ,MNAME (VALUES T ,VAR ,N-PACKAGE :EXTERNAL)))
+                           'MORE-EXTERNS)
+                  ,DONE-EXTERNAL))
+
+          (IL:* IL:|;;| "The :INTERNAL symbol loop")
+
+          ,@(WHEN DONE-INTERNAL
+                `((WHEN (%PACKAGE-EXTERNAL-ONLY ,N-PACKAGE)
+                      (GO ,DONE-INTERNAL))
+                  ,@(IL:MAKE-DO-SYMBOLS-CODE VARS VAR `(%PACKAGE-INTERNAL-SYMBOLS ,N-PACKAGE)
+                           `(GO ,DONE-INTERNAL)
+                           `((SETQ ,STATE 'MORE-INTERNS)
+                             (RETURN-FROM ,MNAME (VALUES T ,VAR ,N-PACKAGE :INTERNAL)))
+                           'MORE-INTERNS)
+                  ,DONE-INTERNAL))
+
+          (IL:* IL:|;;| "The :INHERITED symbol loop")
+
+          ,@(WHEN DONE-INHERITS
+                `((SETQ ,INHERITS (CDR (%PACKAGE-TABLES ,N-PACKAGE)))
+                  (SETQ ,SHADOWED (%PACKAGE-SHADOWING-SYMBOLS ,N-PACKAGE))
+                  ,NEXT-INHERIT
+                  (WHEN (NULL ,INHERITS)
+                      (GO ,DONE-INHERITS))
+                  (IL:SETQ ,THIS-INHERIT (POP ,INHERITS))
+                  ,@(IL:MAKE-DO-SYMBOLS-CODE
+                     VARS VAR THIS-INHERIT `(GO ,NEXT-INHERIT)
+                     `((WHEN (OR (NOT ,SHADOWED)
+                                 (EQ (FIND-SYMBOL (SYMBOL-NAME ,VAR)
+                                            ,N-PACKAGE)
+                                     ,VAR))
+                           (SETQ ,STATE 'MORE-INHERITS)
+                           (RETURN-FROM ,MNAME (VALUES T ,VAR ,N-PACKAGE :INHERITED))))
+                     'MORE-INHERITS)
+                  ,DONE-INHERITS))
+          (SETQ ,STATE 'MORE-PACKAGES)
+          (GO MORE-PACKAGES))))
+       ,@FORM))))
+
+
+
+(IL:* IL:|;;| "Finding symbols in a package or packages")
+
+
+(DEFUN FIND-ALL-SYMBOLS (IL:STRING-OR-SYMBOL)
+   "Find every symbol in all packages with the given name."
+   (LET ((STRING (IL:MKSTRING IL:STRING-OR-SYMBOL))
+         (IL:RES NIL))
+        (DECLARE (SPECIAL IL:*PACKAGE-FROM-NAME*))
+        (MAPHASH #'(LAMBDA (IL:K IL:V)
+                          (MULTIPLE-VALUE-BIND (IL:S IL:W)
+                                 (FIND-SYMBOL STRING IL:V)
+                                 (WHEN IL:W (PUSHNEW IL:S IL:RES))))
+               IL:*PACKAGE-FROM-NAME*)
+        IL:RES))
+
+(DEFUN IL:BRIEFLY-DESCRIBE-SYMBOL (SYMBOL)
+   "Short form description of a symbol."
+   (FRESH-LINE)
+   (PRIN1 SYMBOL)
+   (WHEN (BOUNDP SYMBOL)
+       (WRITE-STRING ", value: ")
+       (PRIN1 (SYMBOL-VALUE SYMBOL)))
+   (IF (FBOUNDP SYMBOL)
+       (WRITE-STRING " (defined)")))
+
+(DEFUN APROPOS (STRING &OPTIONAL PACKAGE IL:EXTERNAL-ONLY)
+   "Find all symbols matching the string pattern in the given (or current) package.  The search can be limited to external symbols only.  Prints a short description of each found symbols."
+   (IL:SETQ STRING (IL:COPY-STRING (IL:\\SIMPLE-STRINGIFY STRING)))
+   (LET ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| STRING))
+         (IL:OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| STRING))
+         (IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| STRING))
+         (IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| STRING)))
+        (IL:\\UPCASEBASE IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
+        (IF (NULL PACKAGE)
+            (DO-ALL-SYMBOLS (SYMBOL)
+                   (IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
+                       (IL:BRIEFLY-DESCRIBE-SYMBOL SYMBOL)))
+            (LET ((PACKAGE (IL:\\PACKAGIFY PACKAGE)))
+                 (IF IL:EXTERNAL-ONLY
+                     (DO-EXTERNAL-SYMBOLS (SYMBOL PACKAGE)
+                            (IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
+                                (IL:BRIEFLY-DESCRIBE-SYMBOL SYMBOL)))
+                     (DO-SYMBOLS (SYMBOL PACKAGE)
+                            (IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
+                                (IL:BRIEFLY-DESCRIBE-SYMBOL SYMBOL)))))))
+   (VALUES))
+
+(DEFUN APROPOS-LIST (STRING &OPTIONAL PACKAGE IL:EXTERNAL-ONLY)
+   "Find all symbols matching the string pattern in the given (or current) package.  The search can be limited to external symbols only.  Returns a list of the matching symbols."
+   (LET ((STRING (IL:COPY-STRING (IL:\\SIMPLE-STRINGIFY (IL:MKSTRING STRING))))
+         (LIST 'NIL))
+        (LET ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| STRING))
+              (IL:OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| STRING))
+              (IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| STRING))
+              (IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| STRING)))
+             (IL:\\UPCASEBASE IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
+             (IF (NULL PACKAGE)
+                 (DO-ALL-SYMBOLS (SYMBOL)
+                        (IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
+                            (PUSH SYMBOL LIST)))
+                 (LET ((PACKAGE (IL:\\PACKAGIFY PACKAGE)))
+                      (IF IL:EXTERNAL-ONLY
+                          (DO-EXTERNAL-SYMBOLS (SYMBOL PACKAGE)
+                                 (IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH 
+                                            IL:FATP)
+                                     (PUSH SYMBOL LIST)))
+                          (DO-SYMBOLS (SYMBOL PACKAGE)
+                                 (IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH 
+                                            IL:FATP)
+                                     (PUSH SYMBOL LIST)))))))
+        LIST))
+
+
+
+(IL:* IL:|;;| "Reader and printer's interface to packages (plus *PACKAGE-FROM-INDEX* above)")
+
+
+(DEFUN IL:FIND-EXTERNAL-SYMBOL (STRING PACKAGE)
+   (IL:SETQ STRING (IL:MKSTRING STRING))                     (IL:* IL:\; 
+                                                      "Convert symbols to strings (for the reader)")
+   (LET* ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| STRING))
+          (IL:OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| STRING))
+          (IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| STRING))
+          (IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| STRING))
+          (IL:HASH (IL:SYMBOL-HASH IL:BASE IL:OFFSET IL:LENGTH IL:FATP))
+          (IL:EHASH (IL:ENTRY-HASH IL:LENGTH IL:HASH))
+          (IL:RESULT (IL:\\CREATECELL IL:\\FIXP))
+          IL:SYM)
+         (IL:NEW-SYMBOL-CODE (PROGN (IL:SETQ IL:SYM ((IL:OPCODES IL:SUBRCALL 145 6)
+                                                     IL:BASE IL:OFFSET IL:LENGTH IL:FATP (
+                                                                            %PACKAGE-EXTERNAL-SYMBOLS
+                                                                                          PACKAGE)
+                                                     IL:RESULT))
+                                    (VALUES IL:SYM (NOT (IL:IEQP IL:RESULT -1))))
+                (IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
+                                           IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH NIL 
+                                           NIL)
+                       (VALUES SYMBOL IL:FOUND)))))
+
+(DEFUN IL:FIND-EXACT-SYMBOL (SYMBOL PACKAGE)
+   "True if name of SYMBOL when looked up in PACKAGE is found and is exactly SYMBOL"
+   (MULTIPLE-VALUE-BIND (IL:FOUNDSYM IL:WHERE)
+          (IL:FIND-SYMBOL* (IL:|ffetch| (SYMBOL IL:PNAMEBASE) IL:|of| SYMBOL)
+                 1
+                 (IL:|ffetch| (SYMBOL IL:PNAMELENGTH) IL:|of| SYMBOL)
+                 (IL:|ffetch| (SYMBOL IL:FATPNAMEP) IL:|of| SYMBOL)
+                 PACKAGE)
+          (AND IL:WHERE (EQ IL:FOUNDSYM SYMBOL))))
+
+(DEFUN IL:PACKAGE-NAME-AS-SYMBOL (PACKAGE)
+   (%PACKAGE-NAMESYMBOL PACKAGE))
+
+(DEFUN IL:\\FIND.PACKAGE.INTERNAL (IL:BASE IL:OFFSET IL:LEN IL:FATP)
+   (FIND-PACKAGE (IL:\\GETBASESTRING IL:BASE IL:OFFSET IL:LEN IL:FATP)))
+
+
+
+(IL:* IL:|;;| "Proper compiler, readtable and package environment")
+
+
+(IL:PUTPROPS IL:LLPACKAGE IL:FILETYPE COMPILE-FILE)
+
+(IL:PUTPROPS IL:LLPACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA DEFPACKAGE)
+
+(IL:ADDTOVAR IL:NLAML )
+
+(IL:ADDTOVAR IL:LAMA )
+)
+(IL:PUTPROPS IL:LLPACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1992 1993))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL (26313 37296 (DEFPACKAGE 26326 . 37294)))))
+IL:STOP
diff --git a/CLTL2/LLPACKAGE.LCOM b/CLTL2/LLPACKAGE.LCOM
new file mode 100644
index 00000000..c6003811
Binary files /dev/null and b/CLTL2/LLPACKAGE.LCOM differ
diff --git a/CLTL2/LLREAD b/CLTL2/LLREAD
new file mode 100644
index 00000000..edac9c44
--- /dev/null
+++ b/CLTL2/LLREAD
@@ -0,0 +1,1532 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+(FILECREATED "12-Oct-93 22:11:23" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLREAD.;2" 121366 
+
+      changes to%:  (FNS \RSTRING2)
+                    (MACROS \NSIN)
+
+      previous date%: " 4-May-91 08:47:17" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLREAD.;1")
+
+
+(* ; "
+Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT LLREADCOMS)
+
+(RPAQQ LLREADCOMS
+       [(COMS                                                (* ; "Reader entrypoints")
+              (FNS LASTC PEEKC PEEKCCODE RATOM READ READC READCCODE READP SETREADMACROFLG 
+                   SKIPSEPRCODES SKIPSEPRS \NSIN.24BITENCODING.ERROR SKREAD))
+        (COMS                                                (* ; "CommonLisp read entry points")
+              (FNS CL:READ CL:READ-PRESERVING-WHITESPACE CL:READ-DELIMITED-LIST CL:PARSE-INTEGER))
+        (COMS                                                (* ; "reading strings")
+              (FNS RSTRING READ-EXTENDED-TOKEN \RSTRING2))
+        (COMS                                                (* ; "Core of the reader")
+              (FNS \TOP-LEVEL-READ \SUBREAD \SUBREADCONCAT \SUBREAD-FLIPCASE READTABLE-CASEARRAY 
+                   \READ.SYMBOL \INVALID.SYMBOL \APPLYREADMACRO INREADMACROP))
+        (COMS                                                (* ; "Read macro for '")
+              (FNS READQUOTE))
+        (COMS                                                (* ; "# macro")
+              (FNS READVBAR READHASHMACRO DEFMACRO-LAMBDA-LIST-KEYWORD-P DIGITBASEP READNUMBERINBASE
+                   ESTIMATE-DIMENSIONALITY SKIP.HASH.COMMENT CMLREAD.FEATURE.PARSER))
+        (COMS                                                (* ; "Reading characters with #\")
+              (FNS CHARACTER.READ CHARCODE.DECODE)
+              (VARS CHARACTERNAMES CHARACTERSETNAMES))
+        (DECLARE%: DOEVAL@COMPILE DONTCOPY (CONSTANTS * READTYPES)
+               (MACROS .CALL.SUBREAD. FIXDOT RBCONTEXT PROPRB \RDCONC)
+               (EXPORT (MACROS \BACKCHAR \BACKNSCHAR \CHECKEOLC \INCHAR \INCCODE \PEEKCCODE \NSIN 
+                              \NSPEEK NUMERIC-CHARSET))
+               (SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn)
+               (GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*)
+               (RESOURCES \PNAMECASEBITS)
+                                                             (* ; "For READTABLE-CASE :INVERT"))
+        [COMS                                                (* ; 
+                                                           "Support for various external formats")
+              [COMS                                          (* ; "JIS to XCCS conversion table.")
+                    (VARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CODE-MAP* 
+                          *HANKAKU-TO-ZENKAKU-CODE-MAP*)
+                    (GLOBALVARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CONV-TABLE-LIST* 
+                           *JIS-TO-XCCS-CODE-MAP* *HANKAKU-TO-ZENKAKU-CODE-MAP* 
+                           *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* 
+                           *JIS-6KU-TO-XCCS-CONV-TABLE* *XCCS-TO-JIS-CONV-TABLE* 
+                           *HANKAKU-TO-ZENKAKU-CONV-TABLE* *ZENKAKU-TO-HANKAKU-CONV-TABLE*)
+                    (FNS \MAKE.JIS.TO.XCCS.CONV.TABLE)
+                    (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\MAKE.JIS.TO.XCCS.CONV.TABLE]
+              [COMS                                          (* ; "JIS to XCCS converter")
+                    (INITVARS (*REPLACE-NO-FONT-CODE* T)
+                           (*DEFAULT-NOT-CONVERTED-FAT-CODE* 8739))
+                    (GLOBALVARS *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*)
+                    (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CONV.JIS.TO.XCCS 
+                                                                      \DO.CONV.JIS.TO.XCCS]
+              [COMS                                          (* ; "XCCS to JIS converter")
+                    (FNS CONVHANKAKU)
+                    (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CONV.XCCS.TO.JIS 
+                                                                      \DO.CONV.XCCS.TO.JIS \ASCIIP 
+                                                                      \NOT.EQUIVALENT.TO.JIS 
+                                                                      \CONV.HANKAKU.TO.ZENKAKUP 
+                                                                      \CONV.ZENKAKU.KANA]
+              (COMS (FNS \JISIN \JISPEEK \BACKJISCHAR \SHIFTJISIN \SHIFTJISPEEK \BACKSHIFTJISCHAR 
+                         \EUCIN \EUCPEEK \BACKEUCCHAR \THROUGHIN \THROUGHPEEK \BACKTHROUGHCHAR)
+                    (DECLARE%: DOEVAL@COMPILE DONTCOPY
+                           (EXPORT 
+
+                                 (* ;; "XCCS specific macro.  Although the decoder and encoder are implemented as functions in general, only for XCCS, they are implemeted as macros for efficiency reason.")
+
+                                  (MACROS \XCCSIN \XCCSPEEK \BACKXCCSCHAR \XCCSP)
+                                  
+                                  (* ;; "JIS specific macro")
+
+                                  (MACROS \EXTRACT.NO.FONT.CODE \EXTARACT.CONV.TABLE 
+                                         \NOT.EQUIVALENT.TO.XCCS \EXTRACT.SET \EXTRACT.CODE 
+                                         \CHNAGE.KI.MODE \KIMODEP \HANKAKUP \KANJIP \NOTGAIJIP 
+                                         \INVALID.TENP \CONV.HANKAKU.KANA \OUTKI \OUTKO)
+                                  
+                                  (* ;; "Shift-JIS specific macro")
+
+                                  (MACROS \CONV.SJIS.TO.JIS \CONV.JIS.TO.SJIS \SJIS.KANJI.FIRST.BYTEP
+                                         )
+                                  
+                                  (* ;; "EUC specific macro")
+
+                                  (MACROS \EUC.KANJI.FIRST.BYTEP \GAIJIP \EUC.HANKAKUP]
+        (INITVARS (*SIGNAL-24BIT-NSENCODING-ERROR*)
+               (*READ-NEWLINE-SUPPRESS*)
+               (\RefillBufferFn (FUNCTION \READCREFILL)))
+                                                             (* ; 
+  "Top level val of \RefillBufferFn means act like READC--we must be doing a raw BIN (or PEEKBIN?)")
+        (LOCALVARS . T)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML)
+                      (LAMA CONVHANKAKU CL:PARSE-INTEGER CL:READ-DELIMITED-LIST 
+                            CL:READ-PRESERVING-WHITESPACE CL:READ])
+
+
+
+(* ; "Reader entrypoints")
+
+(DEFINEQ
+
+(LASTC
+(LAMBDA (FILE) (* ; "Edited  6-Jan-88 15:31 by jds") (* ;; "Be careful only to do BIN's if we first were able to back up, so that an EOF doesn't happen.  This is really an inadequate implementation, because it fails for files that cannot be backed up.  Eventually, we must change the character reading functions READ, RATOM, READC to save the last character they read in an STREAM field.") (LET* ((STREAM (\GETSTREAM FILE (QUOTE INPUT))) (LASTCCODE (FETCH (STREAM LASTCCODE) OF STREAM))) (* ;; "(FCHARACTER (SELCHARQ C (CR (SELECTC (ffetch EOLCONVENTION of STREAM) (CR.EOLC (CHARCODE EOL)) C)) (LF (SELECTC (ffetch EOLCONVENTION of STREAM) (LF.EOLC (CHARCODE EOL)) (CRLF.EOLC (COND ((EQ (CHARCODE CR) (UNINTERRUPTABLY (AND (\BACKNSCHAR STREAM SHIFTEDCHARSET) (PROG1 (PROGN (\BACKNSCHAR STREAM SHIFTEDCHARSET) (\NSIN STREAM SHIFTEDCHARSET)) (\NSIN STREAM SHIFTEDCHARSET))))) (CHARCODE EOL)) (T C))) C)) (NIL 0) C))") (COND ((IEQP LASTCCODE 65535) NIL) (T (FCHARACTER LASTCCODE)))))
+)
+
+(PEEKC
+(LAMBDA (FILE FLG) (* rmk%: "10-Apr-85 11:55") (* ;; "FLG says to proceed as if Control were T--not implemented correctly here NIL") (LET ((\RefillBufferFn (FUNCTION \PEEKREFILL)) (STREAM (\GETSTREAM FILE (QUOTE INPUT)))) (DECLARE (SPECVARS \RefillBufferFn)) (FCHARACTER (PEEKCCODE STREAM))))
+)
+
+(PEEKCCODE
+(LAMBDA (FILE NOERROR) (* bvm%: "12-Sep-86 15:19") (LET ((\RefillBufferFn (FUNCTION \PEEKREFILL)) (STREAM (\GETSTREAM FILE (QUOTE INPUT)))) (DECLARE (SPECVARS \RefillBufferFn)) (\PEEKCCODE STREAM NOERROR)))
+)
+
+(RATOM
+(LAMBDA (FILE RDTBL) (* ; "Edited  3-Apr-91 21:08 by jrb:") (* ;;; "Like READ except interpret break characters as single character atoms.  I.e., always returns an atom") (SETQ RDTBL (\GTREADTABLE RDTBL)) (LET ((*READTABLE* RDTBL) (*PACKAGE* (if (fetch (READTABLEP USESILPACKAGE) of RDTBL) then *INTERLISP-PACKAGE* else *PACKAGE*)) (\RefillBufferFn (FUNCTION \RATOM/RSTRING-REFILL))) (DECLARE (SPECVARS *READTABLE* *PACKAGE* \RefillBufferFn)) (.CALL.SUBREAD. FILE NIL NIL NIL T RATOM.RT)))
+)
+
+(READ
+(LAMBDA (FILE RDTBL FLG) (* ; "Edited 19-Mar-87 18:35 by bvm:") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (*READ-NEWLINE-SUPPRESS* FLG)) (DECLARE (SPECVARS *READTABLE* *READ-NEWLINE-SUPPRESS*)) (* ;; "*READ-NEWLINE-SUPPRESS* is used freely by \FILLBUFFER") (* ;; "Call reader with PRESERVE-WHITESPACE = T, since that's the semantics Interlisp has always had before (though maybe not explicitly stated).") (\TOP-LEVEL-READ FILE NIL NIL NIL T)))
+)
+
+(READC
+(LAMBDA (FILE RDTBL) (* ; "Edited  6-Jan-88 15:30 by jds") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (\RefillBufferFn (FUNCTION \READCREFILL))) (DECLARE (SPECVARS *READTABLE* \RefillBufferFn)) (FCHARACTER (REPLACE (STREAM LASTCCODE) OF (\INSTREAMARG FILE) WITH (\INCCODE (\INSTREAMARG FILE))))))
+)
+
+(READCCODE
+(LAMBDA (FILE RDTBL) (* ; "Edited  3-Jun-88 01:30 by atm") (* ;;; "returns a 16 bit character code.  \INCHAR does the EOL conversion and this function converts to a 16 bit value.  Saves the character for LASTC as well.") (SETQ FILE (\GETSTREAM FILE (QUOTE INPUT))) (FDEVOP (QUOTE READCHARCODE) (fetch (STREAM DEVICE) of FILE) FILE RDTBL))
+)
+
+(READP
+(LAMBDA (FILE FLG) (* rmk%: " 5-Apr-85 09:09") (* ; "The 10 does not do the EOL check on the peeked character.") (LET* ((STREAM (\GETSTREAM FILE (QUOTE INPUT))) (DEVICE (ffetch (STREAM DEVICE) of STREAM))) (COND ((ffetch (FDEV READP) of DEVICE) (FDEVOP (QUOTE READP) DEVICE STREAM FLG)) (T (\GENERIC.READP STREAM FLG)))))
+)
+
+(SETREADMACROFLG
+(LAMBDA (FLG) (* rmk%: "25-OCT-83 16:13") (* ; "D doesn't cause the read-macro context error, hence doesn't maintain this flag") NIL)
+)
+
+(SKIPSEPRCODES
+(LAMBDA (FILE RDTBL) (* ; "Edited  6-Jan-88 13:09 by jds") (* ;; "Passes over non-separators to peek at the first non-separator on FILE.  Returns either last peeked character, or NIL if no non-seprs left in the file.") (bind PREVC C SHIFTEDCHARSET (STREAM _ (\GETSTREAM FILE (QUOTE INPUT))) (SA _ (fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL))) (\RefillBufferFn _ (QUOTE \PEEKREFILL)) first (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) declare (SPECVARS \RefillBufferFn) while (EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET T) (RETURN))))) do (SETQ PREVC C) (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) finally (AND PREVC (replace (STREAM LASTCCODE) of STREAM with PREVC)) (RETURN C)))
+)
+
+(SKIPSEPRS
+(LAMBDA (FILE RDTBL) (* ; "Edited 11-Sep-87 17:52 by bvm:") (* ;; "Passes over non-separators to peek at the first non-separator on FILE.  Returns either last peeked character, or NIL if no non-seprs left in the file.") (bind C SHIFTEDCHARSET (STREAM _ (\GETSTREAM FILE (QUOTE INPUT))) (SA _ (fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL))) (\RefillBufferFn _ (QUOTE \PEEKREFILL)) first (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) declare (SPECVARS \RefillBufferFn) while (EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET T) (RETURN))))) do (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) finally (RETURN (FCHARACTER C))))
+)
+
+(\NSIN.24BITENCODING.ERROR
+(LAMBDA (STREAM) (* bvm%: "12-Mar-86 15:35") (DECLARE (USEDFREE *SIGNAL-24BIT-NSENCODING-ERROR*)) (* ;;; "Called if we see the sequence shift,shift on STREAM -- means shift to 24-bit character set, which we don't support.  Usually this just means we're erroneously reading a binary file as text.  If this function returns, its value is taken as a character set to shift to") (COND (*SIGNAL-24BIT-NSENCODING-ERROR* (* ; "Only cause error if user/reader cares") (ERROR "24-bit NS encoding not supported" STREAM))) (* ; "Return charset zero") 0)
+)
+
+(SKREAD
+(LAMBDA (FILE REREADSTRING RDTBL) (* ; "Edited  6-Apr-88 11:06 by amd") (LET ((*READ-SUPPRESS* (QUOTE SKREAD)) (*READTABLE* (\GTREADTABLE RDTBL)) (\RBFLG) (STRM (\GETSTREAM FILE (QUOTE INPUT))) CH) (DECLARE (LISP:SPECIAL *READTABLE* *READ-SUPPRESS* \RBFLG)) (COND (REREADSTRING (* ; "REREADSTRING is string of chars already read.") (SETQ STRM (LISP:MAKE-CONCATENATED-STREAM (LISP:MAKE-STRING-INPUT-STREAM (MKSTRING REREADSTRING)) STRM)))) (* ; "Because of return requirements, have to preview stream for unbalanced closing bracket/paren") (if (NULL (SETQ CH (SKIPSEPRCODES STRM))) then (\EOF.ACTION STRM) else (SELECTC (PROG1 (\SYNCODE (fetch (READTABLEP READSA) of *READTABLE*) CH) (* ;; "Read in suppressed mode.  Reader sets \Rbflg free if read ended on unbalanced bracket.  Reason we do the READ in all cases is so that we need to consume the unbalanced paren/bracket, just as if we really had read it; however, READ doesn't set \Rbflg for these cases") (\TOP-LEVEL-READ STRM NIL NIL NIL T)) (RIGHTPAREN.RC (* ; "unbalanced right paren") (QUOTE %))) (RIGHTBRACKET.RC (* ; "unbalanced right bracket") (QUOTE %])) (AND \RBFLG (QUOTE %]))))))
+)
+)
+
+
+
+(* ; "CommonLisp read entry points")
+
+(DEFINEQ
+
+(LISP:READ
+(LISP:LAMBDA (&OPTIONAL (INPUT-STREAM *STANDARD-INPUT*) (EOF-ERROR-P T) EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Dec-86 18:48 by bvm") (COND (RECURSIVE-P (* ; "Dive straight into reader using current settings of everything") (.CALL.SUBREAD. INPUT-STREAM)) (T (\TOP-LEVEL-READ INPUT-STREAM (NOT EOF-ERROR-P) EOF-VALUE))))
+)
+
+(LISP:READ-PRESERVING-WHITESPACE
+(LISP:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*) (EOF-ERRORP T) (EOF-VALUE NIL) (RECURSIVEP NIL)) (* ; "Edited 19-Mar-87 18:33 by bvm:") (* ;; "Reads from stream and returns the object read, preserving the whitespace that followed the object.") (COND (RECURSIVEP (* ; "Dive straight into reader using current settings of everything") (.CALL.SUBREAD. STREAM)) (T (\TOP-LEVEL-READ STREAM (NOT EOF-ERRORP) EOF-VALUE NIL T))))
+)
+
+(LISP:READ-DELIMITED-LIST
+(LISP:LAMBDA (CHAR &OPTIONAL (INPUT-STREAM *STANDARD-INPUT*) RECURSIVE-P) (* ; "Edited 14-Dec-86 18:48 by bvm") (* ;;; "Read a list of elements terminated by CHAR.  CHAR must not be a separator char, and ideally should not be a constituent char (if it is, it must be preceded by whitespace for READ-DELIMITED-LIST to work)") (LET ((ENDCODE (OR (FIXP CHAR) (LISP:CHAR-CODE CHAR))) (INSTREAM (\GETSTREAM INPUT-STREAM (QUOTE INPUT)))) (if RECURSIVE-P then (* ; "Have to dive into reader without disturbing *CIRCLE-READ-LIST*") (.CALL.SUBREAD. INPUT-STREAM NIL NIL ENDCODE) else (\TOP-LEVEL-READ INPUT-STREAM NIL NIL ENDCODE))))
+)
+
+(LISP:PARSE-INTEGER
+(LISP:LAMBDA (STRING &KEY START END (RADIX 10) JUNK-ALLOWED) (* ; "Edited  8-Feb-91 13:24 by gadener") (LISP:IF (NOT (LISP:STRINGP STRING)) (ERROR "This is not a string : ~S" STRING) (PROG ((SA (fetch (READTABLEP READSA) of CMLRDTBL)) (BASE (fetch (STRINGP BASE) of STRING)) (LEN (fetch (STRINGP LENGTH) of STRING)) (OFFST (fetch (STRINGP OFFST) of STRING)) (FATP (fetch (STRINGP FATSTRINGP) of STRING)) MAXDIGITCODE MAXALPHACODE INDEX STOP CHAR SIGN STARTINT ENDINT ERR) (SETQ RADIX (\CHECKRADIX RADIX)) (SETQ INDEX (+ OFFST (if (NULL START) then 0 elseif (< START 0) then (\ILLEGAL.ARG START) else START))) (SETQ STOP (+ OFFST (if (NULL END) then LEN elseif (OR (> END LEN) (< END 0)) then (\ILLEGAL.ARG END) else END))) (SETQ MAXDIGITCODE (+ (CHARCODE 0) RADIX -1)) (SETQ MAXALPHACODE (AND (> RADIX 10) (+ (CHARCODE A) RADIX -11))) (while (AND (< INDEX STOP) (EQ (\SYNCODE SA (\GETBASECHAR FATP BASE INDEX)) SEPRCHAR.RC)) do (* ; "Skip over separators") (SETQ INDEX (LISP:1+ INDEX))) (COND ((>= INDEX STOP) (* ; "no characters remain") (RETURN (COND (JUNK-ALLOWED (* ; "don't error") (LISP:VALUES NIL STOP)) (T (SETQ ERR "No non-whitespace characters in integer string: ~S") (GO FAIL)))))) (* ;; "Start parsing a number.  Allowed to start with a single sign, then digits in radix, nothing else.  Assume collating sequence is (+, -) < digits < uppercase letters < lowercase letters.") (do (SETQ CHAR (\GETBASECHAR FATP BASE INDEX)) (if (<= CHAR MAXDIGITCODE) then (* ; "sign or digit") (if (>= CHAR (CHARCODE 0)) then (* ; " digit") (OR STARTINT (SETQ STARTINT INDEX)) elseif (AND (NOT SIGN) (NOT STARTINT)) then (* ; "maybe sign.  No good if not at start") (SELCHARQ CHAR (- (SETQ SIGN (QUOTE -))) (+ (SETQ SIGN (QUOTE +))) (RETURN)) else (RETURN)) elseif (AND MAXALPHACODE (<= (if (>= CHAR (CHARCODE "a")) then (* ; "uppercase it first") (- CHAR (- (CHARCODE "a") (CHARCODE "A"))) else CHAR) MAXALPHACODE)) then (* ; "is alphabetic digit") (OR STARTINT (SETQ STARTINT INDEX)) else (RETURN)) repeatwhile (< (add INDEX 1) STOP)) (SETQ ENDINT INDEX) (RETURN (LISP:VALUES (COND ((AND STARTINT (OR JUNK-ALLOWED (EQ INDEX STOP) (do (if (NEQ (\SYNCODE SA CHAR) SEPRCHAR.RC) then (* ; " junk found") (RETURN NIL) elseif (EQ (add INDEX 1) STOP) then (* ; "at end of string, win") (RETURN T) else (SETQ CHAR (\GETBASECHAR FATP BASE INDEX)))))) (\MKINTEGER BASE STARTINT ENDINT (EQ SIGN (QUOTE -)) RADIX FATP)) (JUNK-ALLOWED NIL) ((NULL STARTINT) (SETQ ERR "There aren't any digits in this integer string: ~S.") (GO FAIL)) (T (SETQ ERR "There is junk in this integer string: ~S.") (GO FAIL))) (- INDEX OFFST))) FAIL (LISP:ERROR ERR (if (OR START END) then (LISP:SUBSEQ STRING (OR START 0) (OR END LEN)) else STRING)))))
+)
+)
+
+
+
+(* ; "reading strings")
+
+(DEFINEQ
+
+(RSTRING
+(LAMBDA (FILE RDTBL RSFLG) (* ; "Edited 22-Mar-87 20:53 by bvm:") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (\RefillBufferFn (QUOTE \RATOM/RSTRING-REFILL)) (*READ-SUPPRESS* NIL)) (DECLARE (SPECVARS *READTABLE* \RefillBufferFn *READ-SUPPRESS*)) (* ;; "It's not clear that *READ-SUPPRESS* is supposed to affect anything other than calls to READ.  So play it safe and force \Rstring2 to really read a string.") (WITH-RESOURCE (\PNAMESTRING) (\RSTRING2 (\GETSTREAM FILE (QUOTE INPUT)) (fetch READSA of *READTABLE*) (OR RSFLG T) \PNAMESTRING))))
+)
+
+(READ-EXTENDED-TOKEN
+(LAMBDA (STREAM RDTBL ESCAPE-ALLOWED-P) (* ; "Edited  3-Apr-91 21:16 by jrb:") (* ;; "This is a cross between RSTRING and \SUBREAD.  Read a %"token%" from STREAM, as defined by the Common Lisp reader and the syntax in RDTBL.  EOF terminates as well.  If ESCAPE-ALLOWED-P is true, escapes are honored and if one appears, a second value of T is returned.  Otherwise, escapes are treated as vanilla chars and the caller can barf on them itself if it desires.") (SETQ RDTBL (\GTREADTABLE RDTBL)) (WITH-RESOURCE (\PNAMESTRING \PNAMECASEBITS) (PROG ((CASEBASE (READTABLE-CASEARRAY RDTBL)) (PBASE (ffetch (STRINGP XBASE) of \PNAMESTRING)) (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (SA (fetch READSA of RDTBL)) (INVERTCASE (AND (fetch (READTABLEP LOWER/FLIPCASE) of RDTBL) (NOT (fetch (READTABLEP CASEINSENSITIVE) of RDTBL)))) J CH SNX ANSLIST ANSTAIL ESCAPE-APPEARED ESCAPING FATSEEN) (AND INVERTCASE (for old J from 16 to 0 bind (CASEBITSBASE _ (ffetch (ARRAYP BASE) of \PNAMECASEBITS)) do (\PUTBASE CASEBITSBASE J 0))) (SETQ J 0) LP (if (\EOFP STREAM) then (* ; "end of file terminates string just like a sepr/break") (GO FINISH)) (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)) (* ; "NOTE: This should really be (\CHECKEOLC (\NSIN --) --), but eol is usually a break or sepr and the \BACKNSCHAR doesn't work right.  Fix this when we unread correctly") (SETQ SNX (\SYNCODE SA CH)) (COND ((AND ESCAPE-ALLOWED-P (SELECTC SNX (ESCAPE.RC (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (ffetch EOLCONVENTION of STREAM) STREAM)) (SETQ ESCAPE-APPEARED T) (SETA \PNAMECASEBITS J 1)) (MULTIPLE-ESCAPE.RC (SETQ ESCAPING (NOT ESCAPING)) (SETQ ESCAPE-APPEARED T) (GO LP)) NIL))) (ESCAPING (* ; "eat chars until next |")) ((fetch STOPATOM of SNX) (\BACKNSCHAR STREAM SHIFTEDCHARSET) (GO FINISH)) ((AND CASEBASE (ILEQ CH \MAXTHINCHAR)) (SETQ CH (\GETBASEBYTE CASEBASE CH)))) (COND ((EQ J \PNAMELIMIT) (* ; "Filled PNSTR so have to save those chars away and start filling up a new buffer") (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) 0 \PNAMESTRING J)) (COND (ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL)))) (T (SETQ ANSTAIL (SETQ ANSLIST (CONS J NIL))))) (SETQ J 0))) (\PNAMESTRINGPUTCHAR PBASE J CH) (COND ((AND (NOT FATSEEN) (IGREATERP CH \MAXTHINCHAR)) (SETQ FATSEEN T))) (AND INVERTCASE ESCAPING (SETA \PNAMECASEBITS J 1)) (SETQ J (ADD1 J)) (GO LP) FINISH (AND INVERTCASE (NOT ANSLIST) (\SUBREAD-FLIPCASE PBASE \PNAMECASEBITS (SUB1 J) CASEBASE)) (SETQ CH (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) 0 \PNAMESTRING J)) (COND (ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS CH NIL))) (SETQ CH (CONCATLIST ANSLIST)))) (RETURN (if ESCAPE-APPEARED then (* ; "do it this way because multiple values are slow") (LISP:VALUES CH T) else CH)))))
+)
+
+(\RSTRING2
+  [LAMBDA (STREAM SA RSFLG PNSTR)                            (* ; 
+                                                      "Edited  4-Aug-93 12:38 by sybalskY:MV:ENVOS")
+
+(* ;;; "The main string reader.  Reads characters from STREAM according to the syntax table SA and returns a string.  PNSTR is an instance of the global resource \PNAMESTRING, which we can use all to ourselves as a buffer.")
+
+(* ;;; "If RSFLG is T then the call is from RSTRING, in which case the string is terminated by a break or sepr in SA.  If RSFLG is NIL then the string is terminated by a string delimiter.  If RSFLG is SKIP then CR's and the following separator chars are discarded as an otherwise normal string is read")
+
+    (DECLARE (USEDFREE *READTABLE* *READ-SUPPRESS*))
+    (PROG ((EOLC (ffetch EOLCONVENTION of STREAM))
+           (PBASE (SELECTQ (SYSTEMTYPE)
+                      (VAX PNSTR)
+                      (ffetch (STRINGP XBASE) of PNSTR)))
+           (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM)
+                                  256))
+           (J 0)
+           EOLCHAR CH SNX ANSLIST ANSTAIL LASTC FATSEEN SKIPPING)
+          (SELECTC EOLC
+              (CRLF.EOLC (SETQ EOLCHAR (CHARCODE CR)))
+              (CR.EOLC (SETQ EOLCHAR (CHARCODE CR)))
+              (LF.EOLC (SETQ EOLCHAR (CHARCODE LF)))
+              NIL)
+      RS2LP
+          (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET))
+          [COND
+             ((EQ CH EOLCHAR)
+
+              (* ;; "We just read the stream's EOL character, so we have to turn it into our EOL.  Most places do this with \CHECKEOLC, but we can't do that here, because if the eol is CRLF and would terminate the read, \BACKNSCHAR won't work right.")
+
+              (COND
+                 ([AND (EQ RSFLG T)
+                       (fetch STOPATOM of (\SYNCODE SA (CHARCODE CR]
+                                                             (* ; 
+                                          "From RSTRING, eol terminates read.  Leave eol in buffer")
+                  (\BACKNSCHAR STREAM SHIFTEDCHARSET)
+                  (GO FINISH))
+                 (T (COND
+                       ((AND (EQ EOLC CRLF.EOLC)
+                             (EQ (\PEEKBIN STREAM T)
+                                 (CHARCODE LF)))             (* ; "Eat the LF after the CR")
+                        (\BIN STREAM)))
+                    (SETQ CH (CHARCODE CR]
+          (SETQ SNX (\SYNCODE SA CH))
+          (SELECTC SNX
+              (OTHER.RC                                      (* ; "Normal case, nothing to do"))
+              (ESCAPE.RC [COND
+                            ((fetch ESCAPEFLG of *READTABLE*)
+                             (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)
+                                             EOLC STREAM))
+                             (COND
+                                ((AND (EQ RSFLG 'SKIP)
+                                      (EQ CH (CHARCODE CR))) (* ; 
+                  "Strip leading spaces after escaped returns, too, but leave the CR in the string")
+                                 (SETQ SKIPPING 0)
+                                 (GO PUTCHAR])
+              (SELECTQ RSFLG
+                  (NIL                                     (* ; "end check is dbl quote")
+                         (COND
+                            ((EQ SNX STRINGDELIM.RC)         (* ; "Got it")
+                             (SETQ LASTC CH)
+                             (GO FINISH))))
+                  (T                                         (* ; 
+            "if called from RSTRING, end check is break or sepr, and we must leave delim in stream")
+                     (COND
+                        ((fetch STOPATOM of SNX)
+                         (\BACKNSCHAR STREAM SHIFTEDCHARSET)
+                         (GO FINISH))))
+                  (SKIP                                      (* ; 
+                                                       "Like NIL but strip cr's and leading spaces")
+                        (SELECTC SNX
+                            (STRINGDELIM.RC 
+                                 (SETQ LASTC CH)
+                                 (GO FINISH))
+                            (SEPRCHAR.RC                     (* ; "Assume that CR is a sepr")
+                                         (COND
+                                            [SKIPPING (COND
+                                                         ((EQ CH (CHARCODE EOL))
+                                                             (* ; 
+                                                           "Multiple CR's while skipping are kept")
+                                                          (COND
+                                                             ((EQ SKIPPING T)
+                                                             (* ; 
+                    "Turn previous space back into CR.  Note that J is guaranteed to be at least 1")
+                                                              (\PNAMESTRINGPUTCHAR PBASE (SUB1 J)
+                                                                     CH)
+                                                              (SETQ SKIPPING 0)))
+                                                          (GO PUTCHAR))
+                                                         (T  (* ; "Continue skipping seprs")
+                                                            (GO RS2LP]
+                                            ((EQ CH (CHARCODE EOL))
+                                                             (* ; 
+                                                      "Turn CR into space and start skipping seprs")
+                                             (SETQ SKIPPING T)
+                                             (SETQ CH (CHARCODE SPACE))
+                                             (GO PUTCHAR))))
+                            NIL))
+                  (SHOULDNT)))
+          (SETQ SKIPPING NIL)
+      PUTCHAR
+          [COND
+             ((NOT *READ-SUPPRESS*)                          (* ; "Accumulate character")
+              (COND
+                 ((EQ J \PNAMELIMIT)                         (* ; 
+                  "Filled PNSTR so have to save those chars away and start filling up a new buffer")
+                  (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN)
+                                 0 PNSTR J))
+                  [COND
+                     [ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL]
+                     (T (SETQ ANSTAIL (SETQ ANSLIST (CONS J NIL]
+                  (SETQ J 0)))
+              (\PNAMESTRINGPUTCHAR PBASE J CH)
+              (SETQ LASTC CH)
+              (COND
+                 ((AND (NOT FATSEEN)
+                       (IGREATERP CH \MAXTHINCHAR))
+                  (SETQ FATSEEN T)))
+              (SETQ J (ADD1 J]
+          (COND
+             ((OR (NEQ RSFLG T)
+                  (NOT (\EOFP STREAM)))                      (* ; "in RSTRING (RSFLG=T), if we've read something already, then end of file terminates string just like a sepr/break")
+              (GO RS2LP)))
+      FINISH
+          (AND LASTC (replace (STREAM LASTCCODE) of STREAM with LASTC))
+          (RETURN (COND
+                     ((NOT *READ-SUPPRESS*)
+                      (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN)
+                                     0 PNSTR J))
+                      (COND
+                         (ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL)))
+                                (CONCATLIST ANSLIST))
+                         (T J])
+)
+
+
+
+(* ; "Core of the reader")
+
+(DEFINEQ
+
+(\TOP-LEVEL-READ
+(LAMBDA (STREAM EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE) (* ; "Edited 13-Dec-88 16:28 by jds") (* ;; "Entry to the guts of the reader from a place where you may not be already under the reader.  CHAR is for READ-DELIMITED-LIST -- it is charcode to terminate read, in which case we are reading a sequence of things instead of a single thing.  EOF-SUPPRESS is the opposite of CL:READ's EOF-ERROR-P arg.") (* ;; " I EOF-SUPPRESS, set the stream's EODOFSTREAMOP to retfrom here with EOF-VALUE as its result.") (LET ((*PACKAGE* (COND ((fetch (READTABLEP USESILPACKAGE) of (\DTEST *READTABLE* (QUOTE READTABLEP))) *INTERLISP-PACKAGE*) (T *PACKAGE*))) (\RefillBufferFn (FUNCTION \READREFILL)) (*CIRCLE-READ-LIST* NIL) (OLD-EOS-OP (fetch ENDOFSTREAMOP of STREAM))) (DECLARE (SPECVARS *PACKAGE* \RefillBufferFn *CIRCLE-READ-LIST* EOF-VALUE)) (LISP:UNWIND-PROTECT (PROGN (AND EOF-SUPPRESS (REPLACE ENDOFSTREAMOP OF STREAM WITH (LISP:FUNCTION (LAMBDA (STREAM) (RETFROM (QUOTE \TOP-LEVEL-READ) EOF-VALUE))))) (LET ((RESULT (.CALL.SUBREAD. STREAM EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE))) (if *CIRCLE-READ-LIST* then (* ; "There were calls to #=, so go fix up all the ## references.") (HASH-STRUCTURE-SMASH RESULT)) RESULT)) (REPLACE ENDOFSTREAMOP OF STREAM WITH OLD-EOS-OP))))
+)
+
+(\SUBREAD
+(LAMBDA (STREAM SA READTYPE PNSTR CASEBASE CASEBITS EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE) (* ; "Edited 22-Apr-91 11:35 by jrb:") (* ;; "Values of READTYPE are: --- READ.RT for top level of READ, --- NOPROPRB.RT if right-bracket isn't to be propagated -- sublist beginning with left-bracket --- PROPRB.RT if propagation is not suppressed -- sublist beginning with left-paren --- RATOM.RT for call from RATOM") (* ;; "PNSTR is an instance of the global resource \PNAMESTRING, acquired in READ and passed on from level to level.  It is released during read-macro applications, then reacquired.") (* ;; "CASEBASE is base of uppercasearray if read table is case-insensitive.") (* ;; "If EOF-SUPPRESS is true, then if we are at end of file we should return EOF-VALUE instead of erroring (we need this because we might actually be sitting before end of file in front of something that reads nothing, e.g., a comment, so caller can't check EOFP itself).  Always false on recursive calls.") (* ;; "If CHAR is supplied, it is a character code which, when read (in isolation), should terminate this call to read.  Never on when at top-level.") (* ;; "\RBFLG is propagated for top-level calls, in case they are embedded in read-macros.  SKREAD also depends on this.") (* ;; "If PRESERVE-WHITESPACE is true, doesn't throw away the whitespace that terminates the read.") (DECLARE (USEDFREE *READTABLE* \RBFLG)) (* ;; "\RDCONC is a macro that adds a new element as specified by its first argument to the current sublist.  Its other arguments will be executed instead if we are the top-level call") (PROG ((TOPLEVELP (SELECTC READTYPE ((LIST READ.RT RATOM.RT) T) NIL)) (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (PBASE (SELECTQ (SYSTEMTYPE) (VAX PNSTR) (ffetch (STRINGP XBASE) of PNSTR))) (INVERTCASE (AND (fetch (READTABLEP LOWER/FLIPCASE) of *READTABLE*) (NOT (fetch (READTABLEP CASEINSENSITIVE) of *READTABLE*)))) SNX LST END ELT DOTLOC CH J ESCAPEFLG INVALIDFLG PACKAGE NCOLONS AT-EOF EOF-POSSIBILITY EXTRASEGMENTS LASTC) (if (AND TOPLEVELP (NOT (\INTERMP STREAM))) then (* ;; "EOF is allowed to terminate tokens on direct READ calls.  Not if reading from terminal, because \FILLBUFFER made sure to put something at the end.") (SETQ EOF-POSSIBILITY T)) NEWTOKEN (* ;; "Here ready to scan a new token.  First skip over separator characters") (AND INVERTCASE (for old J from 0 to 15 bind (CASEBITSBASE _ (ffetch (ARRAYP BASE) of CASEBITS)) do (\PUTBASE CASEBITSBASE J 0))) (SETQ J 0) (SETQ EXTRASEGMENTS (SETQ INVALIDFLG (SETQ ESCAPEFLG (SETQ PACKAGE (SETQ NCOLONS NIL))))) (if (AND EOF-SUPPRESS (NULL (SKIPSEPRCODES STREAM))) then (* ; "caller specified eof-error-p of NIL.  Happens only on top-level calls") (RETURN EOF-VALUE)) (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (* ; "By Skipping Separator Characters,Happens CHARSET-Mode Exchanging. (Solution of AR#114 in FX, edited by tt [Jan-22-'90])") (repeatwhile (EQ (SETQ SNX (\SYNCODE SA (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)))) SEPRCHAR.RC)) (COND ((EQ CH CHAR) (* ; "Read desired terminating char.  TOPLEVELP is always false here") (replace (STREAM LASTCCODE) of STREAM with CH) (* ; "Save last char for LASTC.") (RETURN LST)) ((EQ SNX OTHER.RC) (* ; "Start of an atom") (COND ((AND (EQ CH (CHARCODE %.)) (fetch STOPATOM of (\SYNCODE SA (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET)))) (* ;; "An isolated, unescaped dot.  This special check on every atom could be eliminated if . had a special SNX code") (SETQ DOTLOC END) (* ; "DOTLOC points to CONS cell one before the dot, NIL for car of list, as desired."))) (GO GOTATOMCHAR)) ((fetch STOPATOM of SNX) (* ; "This character definitely does not start an atom") (COND ((EQ READTYPE RATOM.RT) (GO SINGLECHARATOM)) (T (GO BREAK)))) ((EQ SNX PACKAGEDELIM.RC) (* ; "Starting a symbol with a package delimiter -- must be a keyword") (SETQ NCOLONS 1) (SETQ PACKAGE *KEYWORD-PACKAGE*) (SETQ ESCAPEFLG T) (GO NEXTATOMCHAR)) ((AND (SELECTC (fetch MACROCONTEXT of SNX) (FIRST.RMC T) (ALONE.RMC (fetch STOPATOM of (\SYNCODE SA (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET)))) NIL) (fetch READMACROFLG of *READTABLE*)) (COND ((EQ READTYPE RATOM.RT) (GO SINGLECHARATOM)) (T (GO MACRO)))) (T (* ; "Some character that starts an atom but has non-trivial syntax attributes"))) ATOMLOOP (* ;; "At this point, we are accumulating an atom, and CH does not have syntax OTHER, so we have to check special cases") (SELECTC SNX (ESCAPE.RC (* ; "Take next character to be alphabetic, case exact") (COND ((fetch ESCAPEFLG of *READTABLE*) (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (ffetch EOLCONVENTION of STREAM) STREAM)) (* ; "No EOFP check needed -- it's an error to have escape char with nothing following") (SETQ ESCAPEFLG T) (AND INVERTCASE (SETA CASEBITS J 1)) (GO PUTATOMCHAR)))) (MULTIPLE-ESCAPE.RC (* ;; "Take characters up to next multiple escape to be alphabetic, except that single escape chars still escape the next char") (SETQ ESCAPEFLG T) (bind ESCFLG do (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (ffetch EOLCONVENTION of STREAM) STREAM)) (COND ((NOT (COND (ESCFLG (SETQ ESCFLG NIL)) (T (SELECTC (SETQ SNX (\SYNCODE SA CH)) (MULTIPLE-ESCAPE.RC (* ; "Finished escaped sequence, resume normal processing") (GO NEXTATOMCHAR)) (ESCAPE.RC (* ; "Pass the next char thru verbatim") (SETQ ESCFLG T)) NIL)))) (* ; "All others are pname chars, quoted") (if (NOT *READ-SUPPRESS*) then (COND ((EQ J \PNAMELIMIT) (* ; "if there have been escapes, can't be a number, so ok to error now.") (LISPERROR "ATOM TOO LONG" (\SUBREADCONCAT EXTRASEGMENTS PBASE J)) (GO NEWTOKEN))) (\PNAMESTRINGPUTCHAR PBASE J CH) (AND INVERTCASE (SETA CASEBITS J 1)) (add J 1)))))) NIL) GOTATOMCHAR (* ;; "CH is a vanilla atom char to accumulate") (COND ((AND CASEBASE (ILEQ CH \MAXTHINCHAR)) (* ; "Uppercase atom characters") (SETQ CH (\GETBASEBYTE CASEBASE CH)))) PUTATOMCHAR (if (NOT *READ-SUPPRESS*) then (COND ((EQ J \PNAMELIMIT) (* ; "Symbol is too long.  However, it could just be a bignum, so keep accumulating characters until we have to do something.") (push EXTRASEGMENTS (\SMASHSTRING (ALLOCSTRING J NIL NIL T) 0 PNSTR J)) (SETQ J 0))) (\PNAMESTRINGPUTCHAR PBASE J CH) (add J 1) (SETQ LASTC CH) (* ; "Save CH for LASTC.")) NEXTATOMCHAR (if (AND EOF-POSSIBILITY (SETQ AT-EOF (\EOFP STREAM))) then (* ; "EOF terminates atoms at top level") (GO FINISHATOM) elseif (EQ (SETQ SNX (\SYNCODE SA (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)))) OTHER.RC) then (* ; "normal case tested first--another vanilla constituent char, so keep accumulating atom chars") (GO GOTATOMCHAR) elseif (fetch STOPATOM of SNX) then (* ; "Terminates atom") (GO FINISHATOM) elseif (EQ SNX PACKAGEDELIM.RC) then (GO GOTPACKAGEDELIM) else (GO ATOMLOOP)) FINISHATOM (* ;; "Come here when an atom has been terminated, either by a break/sepr char or by end of file.") (if INVALIDFLG then (replace (STREAM LASTCCODE) of STREAM with (OR LASTC CH 65535)) (\INVALID.SYMBOL PBASE J NCOLONS PACKAGE EXTRASEGMENTS)) (SETQ ELT (AND (NOT *READ-SUPPRESS*) (if EXTRASEGMENTS then (* ;; "More than \PNAMELIMIT chars were read.  Can't be a symbol, but might be a number.  Pack up all the strings we have into a single string and try to parse it as a number.") (SETQ EXTRASEGMENTS (\SUBREADCONCAT EXTRASEGMENTS PBASE J)) (OR (AND (NULL (OR PACKAGE ESCAPEFLG NCOLONS)) (\PARSE.NUMBER (fetch (STRINGP BASE) of EXTRASEGMENTS) (fetch (STRINGP OFFST) of EXTRASEGMENTS) (fetch (STRINGP LENGTH) of EXTRASEGMENTS) \FATPNAMESTRINGP)) (LISPERROR "ATOM TOO LONG" EXTRASEGMENTS)) else (if INVERTCASE then (* ;; "Case of the unescaped letters was inverted, but maybe shouldn't have been (if they came in mixed-case).  Need to check here.  It's done as a post-processing pass to make the other cases fast (anyone who uses the :INVERT case and expects it to be fast deserves to lose).") (\SUBREAD-FLIPCASE PBASE CASEBITS (SUB1 J) CASEBASE)) (\READ.SYMBOL PBASE 0 J \FATPNAMESTRINGP PACKAGE (EQ NCOLONS 1) ESCAPEFLG)))) (replace (STREAM LASTCCODE) of STREAM with CH) (* ; "Save last READ char for LASTC.") (if AT-EOF then (* ; "top-level read, atom terminated by EOF") (RETURN ELT)) (\RDCONC ELT (PROGN (COND ((OR PRESERVE-WHITESPACE (NEQ SNX SEPRCHAR.RC)) (* ; "At top-level, put back the terminating character if preserving whitespace or terminator is significant") (replace (STREAM LASTCCODE) of STREAM with (OR LASTC CH 65535)) (* ; "And LASTC will return the last REAL char read.") (\BACKNSCHAR STREAM SHIFTEDCHARSET))) (RETURN ELT))) (if (EQ SNX SEPRCHAR.RC) then (* ; "Terminated with sepr, go on to next char") (GO NEWTOKEN) elseif (EQ CH CHAR) then (* ; "read terminates here") (replace (STREAM LASTCCODE) of STREAM with CH) (RETURN LST) else (* ; "Terminated with break, jump into the break char code") (GO BREAK)) GOTPACKAGEDELIM (* ;; "Come here if CH is a package delimiter.  Note that we have already scanned at least one character of the token, so this must be an interior delim") (COND (*READ-SUPPRESS* (* ; "Don't care about packages")) ((AND (EQ J 0) (NULL EXTRASEGMENTS)) (* ;; "No chars accumulated, so must be 2 colons in a row.  Note that the case where we've just started scanning a token happens up at NEWTOKEN") (SETQ LASTC CH) (COND ((AND (EQ NCOLONS 1) (NEQ PACKAGE *KEYWORD-PACKAGE*)) (* ; "Two colons in a row means internal symbol") (SETQ NCOLONS 2)) (T (* ; "Error, e.g., `FOO:::BAZ' or `::BAR'") (SETQ INVALIDFLG T) (GO GOTATOMCHAR)))) ((NULL NCOLONS) (* ; "We have just scanned the package name") (SETQ NCOLONS 1) (SETQ LASTC CH) (SETQ PACKAGE (COND (EXTRASEGMENTS (LISPERROR "ATOM TOO LONG" (\SUBREADCONCAT EXTRASEGMENTS PBASE J)) (SETQ EXTRASEGMENTS NIL)) ((\FIND.PACKAGE.INTERNAL PBASE 0 J \FATPNAMESTRINGP)) (T (* ; "Error, but don't signal yet -- save name as string for benefit of error handlers") (\GETBASESTRING PBASE 0 J \FATPNAMESTRINGP)))) (SETQ J 0)) (T (* ; "Have alread seen one or more colons, and have scanned more symbol.  This colon is an error.") (SETQ LASTC CH) (SETQ INVALIDFLG T) (GO GOTATOMCHAR))) (SETQ ESCAPEFLG T) (* ; "Result MUST be a symbol now") (GO NEXTATOMCHAR) SINGLECHARATOM (* ;; "Come here to create a symbol whose single character is CH -- no package stuff to worry about.  This happens mainly for RATOM.  We create the single char atom in IL for backward compatibility.") (\PNAMESTRINGPUTCHAR PBASE 0 CH) (SETQ ELT (\READ.SYMBOL PBASE 0 1 \FATPNAMESTRINGP *INTERLISP-PACKAGE*)) (replace (STREAM LASTCCODE) of STREAM with CH) (\RDCONC ELT (RETURN ELT)) (GO NEWTOKEN) (* ;; "End of atom scanning code") BREAK (* ;; "At this point, we have just read a break character, stored in CH") (replace (STREAM LASTCCODE) of STREAM with CH) (SELECTC SNX (LEFTPAREN.RC (* ;; "recursively read a list.  If that list (or any of it's non-bracketed sublists) is terminated by a right bracket it terminates our read as well.  PROPRB macro worries about right-bracket propagation: if the subread encounters a right bracket (sets \RBFLG), PROPRB returns true.  In addition, if we were not called by a left-bracket (READTYPE = NOPROPRB.RT) it sets \RBFLG in caller, thereby propagating the bracket upward.") (COND ((PROG1 (PROPRB (SETQ ELT (\SUBREAD STREAM SA PROPRB.RT PNSTR CASEBASE CASEBITS))) (\RDCONC ELT (RETURN ELT))) (* ;; "PROG1 is true if the subread encountered a right bracket") (FIXDOT) (* ; "Fix dotted pair if necessary") (RETURN LST)))) (LEFTBRACKET.RC (* ;; "recursively read a list, terminated by either right paren or right bracket.  In this case, right bracket is not propagated upward--we continue reading elements after it.") (SETQ ELT (\SUBREAD STREAM SA NOPROPRB.RT PNSTR CASEBASE CASEBITS)) (\RDCONC ELT (RETURN ELT))) ((LIST RIGHTPAREN.RC RIGHTBRACKET.RC) (* ;; "Terminate one or more lists, return what we have accumulated so far.  In the case of Right bracket, if caller did not have the matching left bracket, we have to allow the bracket to close more than one list.") (RETURN (COND (TOPLEVELP (* ;; "Naked right paren/bracket returns NIL.  This is sort of bogus in common lisp, but changing it would be a significant change to Interlisp folks.") NIL) (CHAR (* ;; "call from READ-DELIMITED-LIST doesn't want to terminate this way.  Could read as NIL and not terminate, but seems best to error.") (LISP:ERROR "Unmatched ~A encountered while reading to a ~A" (LISP:CODE-CHAR CH) (LISP:CODE-CHAR CHAR)) LST) (T (FIXDOT) (AND (EQ SNX RIGHTBRACKET.RC) (NEQ READTYPE NOPROPRB.RT) (SETQ \RBFLG T)) LST)))) (STRINGDELIM.RC (* ;; "Invoke string reader") (SETQ ELT (\RSTRING2 STREAM SA NIL PNSTR)) (\RDCONC ELT (RETURN ELT))) (COND ((OR (EQ SNX BREAKCHAR.RC) (NOT (fetch READMACROFLG of *READTABLE*))) (* ; "A breakchar or a disabled always macro") (GO SINGLECHARATOM)) (T (GO MACRO)))) (GO NEWTOKEN) MACRO (SELECTQ (fetch MACROTYPE of (SETQ SNX (\GETREADMACRODEF CH *READTABLE*))) (MACRO (COND ((PROG1 (PROPRB (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (LISP:MULTIPLE-VALUE-LIST (\APPLYREADMACRO STREAM SNX)))) (* ; "Ignore right-bracket if macro is called at top-level read")) (COND ((NULL ELT) (* ; "Macro returned zero values, read as nothing")) (T (SETQ ELT (CAR ELT)) (\RDCONC ELT (RETURN ELT))))) (FIXDOT) (* ; "Encountered right bracket if we get here -- return what we have") (RETURN LST)))) (INFIX (* ;; "We give macro TCONC list of what we've accumulated so far--it gets to modify it as it pleases and return it.  We continue from there.") (COND ((PROG1 (PROPRB (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (\APPLYREADMACRO STREAM SNX (AND LST (CONS LST END)))))) (COND (TOPLEVELP (* ; "What does INFIX mean at top level??  See IRM") (COND ((AND (LISTP ELT) (CDR ELT)) (* ; "Result is in TCONC format, so it's returnable") (RETURN (COND ((EQ (CDR ELT) (CAR ELT)) (* ; "TCONC list of one element--return the element. This is how INFIX top level macro can return a non-list.  ") (CAAR ELT)) (T (CAR ELT))))))) (T (* ; "Reading sublist.  Take apart TCONC list and continue.") (SETQ LST (CAR ELT)) (SETQ END (CDR ELT))))) (FIXDOT) (* ; "Macro hit right bracket if we got to here") (RETURN LST)))) (SPLICE (* ;; "Macro returns arbitrary number of values to be spliced inline.") (RBCONTEXT (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (\APPLYREADMACRO STREAM SNX)))) (* ; "Note: we don't care if there was terminating right-bracket") (* ; "Why? -bvm") (COND ((OR (NULL ELT) TOPLEVELP) (* ;; "On the 10, it actually returns ELT if it is a list and the next token is a closing paren or bracket.  Hard to see how to get that behavior--rmk") (GO NEWTOKEN)) ((NLISTP ELT) (* ; "The 10 throws initial non-lists away (What if LST/END aren't set?)") (SETQ ELT (AND LST (LIST (QUOTE %.) ELT))) (SETQ DOTLOC END))) (COND ((NOT *READ-SUPPRESS*) (COND (LST (RPLACD END ELT)) (T (SETQ LST ELT))) (SETQ END (LAST ELT)) (COND ((CDR END) (* ; "A dotted pair") (SETQ DOTLOC END) (RPLACD END (CONS (QUOTE %.) (SETQ END (CONS (CDR END)))))))))) (SHOULDNT)) (GO NEWTOKEN)))
+)
+
+(\SUBREADCONCAT
+(LAMBDA (EXTRASEGMENTS PBASE J) (* ; "Edited 16-Jan-87 15:08 by bvm:") (* ;; "Produces a string consisting of all the characters \SUBREAD has been buffering up into a token.  Last J chars are stored at PBASE.  EXTRASEGMENTS is a list of strings in reverse order in the case that more characters were scanned than the pname string accommodates.") (SETQ PBASE (\GETBASESTRING PBASE 0 J \FATPNAMESTRINGP)) (if EXTRASEGMENTS then (CONCATLIST (NCONC1 (REVERSE EXTRASEGMENTS) PBASE)) else PBASE))
+)
+
+(\SUBREAD-FLIPCASE
+(LAMBDA (STRINGBASE CASEBITS LEN CASEBASE) (* ; "Edited 10-Feb-91 17:08 by jrb:") (* ;; "Handles the possible case inversion required by the :INVERT READTABLE-CASE setting.") (* ;; "STRINGBASE is the base of the string used by \SUBREAD to accumulate characters for symbols") (* ;; "CASEBITS is a bit-array with 1s in the places corresponding to escaped characters in STRINGBASE") (* ;; "LEN points to the last character in STRINGBASE (0-based addressing)") (* ;; "CASEBASE is the base of the casearray") (LET (PBVAL UPPERSEEN LOWERSEEN) (if (for I from 0 to LEN by 1 do (AND UPPERSEEN LOWERSEEN (RETURN T)) (if (ZEROP (ELT CASEBITS I)) then (SETQ PBVAL (\GETBASECHAR \FATPNAMESTRINGP STRINGBASE I)) (COND ((AND (IGEQ PBVAL (CHARCODE a)) (ILEQ PBVAL (CHARCODE z))) (SETQ LOWERSEEN T)) ((AND (IGEQ PBVAL (CHARCODE A)) (ILEQ PBVAL (CHARCODE Z))) (SETQ UPPERSEEN T)))) finally (RETURN (AND UPPERSEEN LOWERSEEN))) then (for I from 0 to LEN by 1 when (AND (ZEROP (ELT CASEBITS I)) (ILEQ (SETQ PBVAL (\GETBASECHAR \FATPNAMESTRINGP STRINGBASE I)) \MAXTHINCHAR)) do (\PNAMESTRINGPUTCHAR STRINGBASE I (\GETBASEBYTE CASEBASE PBVAL))))))
+)
+
+(READTABLE-CASEARRAY
+(LAMBDA (READTABLE) (* ; "Edited  9-Feb-91 11:24 by jrb:") (SELECTQ (COMMON-LISP:READTABLE-CASE READTABLE) (:PRESERVE NIL) (:UPCASE (ffetch (ARRAYP BASE) of UPPERCASEARRAY)) (:DOWNCASE (ffetch (ARRAYP BASE) of LOWERCASEARRAY)) (:INVERT (ffetch (ARRAYP BASE) of FLIPCASEARRAY)) (ERROR "Bogus value of CL:READTABLE-CASE" (COMMON-LISP:READTABLE-CASE READTABLE))))
+)
+
+(\READ.SYMBOL
+(LAMBDA (BASE OFFSET LEN FATP PACKAGE EXTERNALP NONNUMERICP) (* bvm%: " 3-Aug-86 15:25") (* ;;; "Read a number or symbol from the string defined by BASE OFFSET LEN FATP PACKAGE is NIL if no package was specified, a package object or a string if an unknown package was typed (causes error).  EXTERNALP is true if symbol was typed with one colon, which requires that the symbol exist and be external.  NONNUMERICP is true if we know the symbol is not a number, e.g., some characters in it were escaped.") (* ;;; "For now a dummy definition") (COND (PACKAGE (* ; "For debugging") (CONCAT PACKAGE (COND (EXTERNALP ":") (T "::")) (\GETBASESTRING BASE OFFSET LEN FATP))) (T (OR (AND (NOT NONNUMERICP) (\PARSE.NUMBER BASE OFFSET LEN FATP)) (\MKATOM BASE OFFSET LEN FATP T)))))
+)
+
+(\INVALID.SYMBOL
+(LAMBDA (BASE LEN NCOLONS PACKAGE EXTRASEGMENTS) (* ; "Edited 15-Jan-87 17:33 by bvm:") (* ;;; "Called when scanning a symbol that has more than 2 colons, or more than 1 non-consecutive colon.  If return from here, will read the symbol as though the extra colons were escaped.") (LISP:CERROR "Treat the extra colon(s) as if they were escaped" "Invalid symbol syntax in %"~A%"" (CONCAT (if (AND PACKAGE (NEQ PACKAGE *KEYWORD-PACKAGE*)) then (if (STRINGP PACKAGE) then PACKAGE else (LISP:PACKAGE-NAME PACKAGE)) else "") (SELECTQ NCOLONS (1 ":") (2 "::") "") (\SUBREADCONCAT EXTRASEGMENTS BASE LEN))))
+)
+
+(\APPLYREADMACRO
+(LAMBDA (STREAM MACDEF ANSCELL) (* bvm%: " 4-May-86 16:38") (* ; "INREADMACROP searches for this framename") (DECLARE (USEDFREE *READTABLE*)) (APPLY* (fetch MACROFN of MACDEF) STREAM *READTABLE* ANSCELL))
+)
+
+(INREADMACROP
+(LAMBDA NIL (* edited%: "26-MAY-79 00:12") (PROG (TEM (\READDEPTH -1)) (DECLARE (SPECVARS \READDEPTH)) (COND ((NULL (SETQ TEM (STKPOS (QUOTE \APPLYREADMACRO)))) (RETURN NIL))) (MAPDL (FUNCTION (LAMBDA (NM POS) (COND ((EQ NM (QUOTE \SUBREAD)) (SETQ \READDEPTH (ADD1 \READDEPTH)))))) TEM) (RELSTK TEM) (RETURN \READDEPTH)))
+)
+)
+
+
+
+(* ; "Read macro for '")
+
+(DEFINEQ
+
+(READQUOTE
+(LAMBDA (FILE) (* ; "Edited 19-Mar-87 16:10 by bvm:") (LIST (QUOTE QUOTE) (LISP:READ FILE T NIL T))))
+)
+
+
+
+(* ; "# macro")
+
+(DEFINEQ
+
+(READVBAR
+(LAMBDA (STREAM RDTBL) (* bvm%: "14-May-86 17:31") (* ;;; "Read Interlisp's | macro.  Originally this char was just a sepr in FILERDTBL but was then extended in various hokey ways, because it was the only character plausibly available for redefinition.  Today it is extended still further to be Common Lisp # in all the cases not already taken by some other meaning") (SELCHARQ (PEEKCCODE STREAM) (%' (* ; "commonlisp defines #'X to mean (FUNCTION X), but here it's BQUOTE") (READCCODE STREAM) (READBQUOTE STREAM RDTBL)) ((%( { ^) (* ; "Used by HPRINT") (HREAD STREAM)) (%# (READCCODE STREAM) (* ; "|# = Common Lisp #") (READHASHMACRO STREAM RDTBL)) ((EOL TAB SPACE) (* ; "CR or tab, treat as separator") (LISP:VALUES)) (PROGN (* ; "Everything else not already preempted by old-style | is interpreted as Common Lisp") (READHASHMACRO STREAM RDTBL))))
+)
+
+(READHASHMACRO
+(LAMBDA (STREAM RDTBL INDEX) (* amd "15-Oct-86 16:36") (* ;;; "Implements the standard # macro dispatch -- reads next character to find out what to do.  Can return zero values if we just want to skip something.") (LET ((READFN (COND ((fetch (READTABLEP COMMONLISP) of RDTBL) (* ;; "Kludge: if we have to recursively read something that will not end up as the resulting list structure, use the reader that passes thru CMLTRANSLATE") (FUNCTION LISP:READ)) (T (FUNCTION READ)))) NEXTCHAR READVAL) (while (DIGITCHARP (SETQ NEXTCHAR (PEEKCCODE STREAM RDTBL))) do (SETQ INDEX (PLUS (TIMES (OR INDEX 0) 10) (DIFFERENCE (READCCODE STREAM RDTBL) (CHARCODE 0))))) (SELCHARQ NEXTCHAR ("(" (LET ((CONTENTS (APPLY* READFN STREAM))) (COND (INDEX (FILL-VECTOR (LISP:MAKE-ARRAY INDEX) CONTENTS)) (T (LISP:MAKE-ARRAY (LENGTH CONTENTS) :INITIAL-CONTENTS CONTENTS))))) (PROGN (* ; "Those cases we left the dispatching char in buffer for convenience of the next read.  Now eat it") (SELCHARQ (READCCODE STREAM RDTBL) (%' (LIST (QUOTE FUNCTION) (READ STREAM RDTBL))) (%. (EVAL (APPLY* READFN STREAM))) (%, (LIST (QUOTE LOADTIMECONSTANT) (READ STREAM RDTBL))) (\ (CHARACTER.READ STREAM)) ("*" (* ; "Read bit vector") (LET ((CONTENTS (while (MEMQ (PEEKCCODE STREAM RDTBL) (CHARCODE (0 1))) collect (IDIFFERENCE (READCCODE STREAM RDTBL) (CHARCODE 0))))) (COND (INDEX (FILL-VECTOR (LISP:MAKE-ARRAY INDEX :ELEMENT-TYPE (QUOTE BIT)) CONTENTS)) (T (LISP:MAKE-ARRAY (LENGTH CONTENTS) :INITIAL-CONTENTS CONTENTS :ELEMENT-TYPE (QUOTE BIT)))))) (":" (* ;; "The same thing HASH-COLON does.") (LISP:MAKE-SYMBOL (READ-EXTENDED-TOKEN STREAM RDTBL))) ((O o) (READNUMBERINBASE STREAM 8)) ((B b) (READNUMBERINBASE STREAM 2)) ((X x) (READNUMBERINBASE STREAM 16)) ((R r) (READNUMBERINBASE STREAM INDEX)) ((A a) (LET ((CONTENTS (APPLY* READFN STREAM))) (LISP:MAKE-ARRAY (ESTIMATE-DIMENSIONALITY INDEX CONTENTS) :INITIAL-CONTENTS CONTENTS))) ((S s) (CREATE-STRUCTURE (APPLY* READFN STREAM))) ((C c) (DESTRUCTURING-BIND (NUM DEN) (APPLY* READFN STREAM) (COMPLEX NUM DEN))) (+ (* ; "Skip expression if feature not present") (COND ((NOT (CMLREAD.FEATURE.PARSER (READ STREAM RDTBL))) (LISP:READ STREAM RDTBL))) (LISP:VALUES)) (- (* ; "Skip expression if feature IS present") (COND ((CMLREAD.FEATURE.PARSER (READ STREAM RDTBL)) (LISP:READ STREAM RDTBL))) (LISP:VALUES)) ("|" (* ; "special comment") (SKIP.HASH.COMMENT STREAM RDTBL) (LISP:VALUES)) (< (ERROR "#< construct is un-READ-able" (READ))) ((SPACE TAB NEWLINE PAGE RETURN %)) (ERROR "Illegal read syntax " (CHARCODE.UNDECODE NEXTCHAR))) (%" (* ; "An extension -- read string without cr's and leading spaces") (RSTRING STREAM RDTBL (QUOTE SKIP))) (APPLY* (OR (GET (CHARACTER NEXTCHAR) (QUOTE HASHREADMACRO)) (ERROR "Undefined hashmacro char" NEXTCHAR)) STREAM RDTBL))))))
+)
+
+(DEFMACRO-LAMBDA-LIST-KEYWORD-P
+(LAMBDA (S) (* bvm%: " 3-Nov-86 15:12") (AND (FMEMB S (QUOTE (&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS &AUX &BODY &WHOLE))) T))
+)
+
+(DIGITBASEP
+(LAMBDA (CODE RADIX) (* lmm "11-Jun-85 00:54") (COND ((AND (GEQ CODE (CHARCODE 0)) (LESSP CODE (PLUS (CHARCODE 0) RADIX))) (DIFFERENCE CODE (CHARCODE 0))) ((GREATERP RADIX 10) (COND ((AND (GEQ CODE (CHARCODE a)) (LEQ CODE (CHARCODE z))) (add CODE (DIFFERENCE (CHARCODE A) (CHARCODE a))))) (COND ((AND (GEQ CODE (CHARCODE A)) (LEQ CODE (CHARCODE Z))) (SETQ CODE (PLUS 10 (DIFFERENCE CODE (CHARCODE A)))) (COND ((LESSP CODE RADIX) CODE)))))))
+)
+
+(READNUMBERINBASE
+(LAMBDA (STREAM RADIX) (* bvm%: " 4-Nov-86 21:34") (PROG ((BODY (READ-EXTENDED-TOKEN STREAM)) (I 1) CH VAL NUMERATOR SIGN BASE) (* ; "First check for leading sign") (if *READ-SUPPRESS* then (* ; "work is done") (RETURN NIL)) (SELCHARQ (SETQ CH (NTHCHARCODE BODY 1)) (+ (GO NEXTCH)) (- (SETQ SIGN T) (GO NEXTCH)) NIL) LP (if (SETQ BASE (DIGITBASEP CH RADIX)) then (SETQ VAL (+ (TIMES (OR VAL 0) RADIX) BASE)) elseif (EQ CH (CHARCODE "/")) then (* ; "Ratio marker") (if (OR NUMERATOR (NULL VAL)) then (GO MALFORMED)) (SETQ NUMERATOR VAL) (SETQ VAL NIL) else (* ; "Terminated by a character that is not a token delimiter") (GO MALFORMED)) NEXTCH (if (SETQ CH (NTHCHARCODE BODY (add I 1))) then (GO LP) else (* ; "end of token, fall thru")) DONE (if (NULL VAL) then (GO MALFORMED)) (if NUMERATOR then (SETQ VAL (%%/ NUMERATOR VAL))) (RETURN (if SIGN then (- VAL) else VAL)) MALFORMED (RETURN (LISP:ERROR "Malformed base ~D rational ~S" RADIX BODY))))
+)
+
+(ESTIMATE-DIMENSIONALITY
+(LAMBDA (RANK CONTENTS) (* bvm%: " 9-May-86 16:06") (COND ((NULL RANK) (ERROR "No rank found while reading array" NIL)) ((EQ RANK 0) NIL) (T (to RANK as (D _ CONTENTS) by (CAR D) collect (LENGTH D)))))
+)
+
+(SKIP.HASH.COMMENT
+(LAMBDA (STREAM RDTBL) (* bvm%: "12-Sep-86 21:02") (PROG NIL (* ;; "a tiny fsm that recognizes #| ... |# with possible nestings of itself") LP (SELCHARQ (READCCODE STREAM RDTBL) ("#" (GO SHARP)) ("|" (GO VBAR)) (GO LP)) SHARP (SELCHARQ (READCCODE STREAM RDTBL) ("|" (* ; "#| -- recursively skip nested section") (SKIP.HASH.COMMENT STREAM RDTBL) (GO LP)) ("#" (GO SHARP)) (GO LP)) VBAR (SELCHARQ (READCCODE STREAM RDTBL) ("|" (GO VBAR)) ("#" (* ; "found closing |#") (RETURN)) (GO LP))))
+)
+
+(CMLREAD.FEATURE.PARSER
+(LAMBDA (EXPR) (* bvm%: " 3-Nov-86 15:07") (COND ((LISP:CONSP EXPR) (SELECTQ (CAR EXPR) ((:AND AND) (EVERY (CDR EXPR) (FUNCTION CMLREAD.FEATURE.PARSER))) ((:OR OR) (SOME (CDR EXPR) (FUNCTION CMLREAD.FEATURE.PARSER))) ((:NOT NOT) (NOT (CMLREAD.FEATURE.PARSER (CADR EXPR)))) (ERROR "Bad feature expression" EXPR))) ((FMEMB EXPR *FEATURES*) T)))
+)
+)
+
+
+
+(* ; "Reading characters with #\")
+
+(DEFINEQ
+
+(CHARACTER.READ
+(LAMBDA (STREAM) (* bvm%: " 4-Nov-86 21:50") (* ;;; "Called by the #\ macro -- reads a character object consisting of the thing next named") (LET ((NEXTCHAR (READCCODE STREAM)) CH) (COND ((OR (NULL (SETQ CH (PEEKCCODE STREAM T))) (fetch STOPATOM of (\SYNCODE (fetch READSA of *READTABLE*) CH))) (* ; "Terminates next, so it's just this char") (LISP:CODE-CHAR NEXTCHAR)) (*READ-SUPPRESS* (* ; "don't try to decode it, could be illegal") (READ-EXTENDED-TOKEN STREAM) NIL) (T (* ; "Read a whole name, up to the next break/sepr") (LISP:CODE-CHAR (CHARCODE.DECODE (CONCAT (ALLOCSTRING 1 NEXTCHAR) (READ-EXTENDED-TOKEN STREAM))))))))
+)
+
+(CHARCODE.DECODE
+(LAMBDA (C NOERROR) (* ; "Edited 18-Feb-87 22:03 by bvm:") (DECLARE (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES)) (COND ((NOT C) NIL) ((LISTP C) (CONS (CHARCODE.DECODE (CAR C) NOERROR) (CHARCODE.DECODE (CDR C) NOERROR))) ((NOT (OR (ATOM C) (STRINGP C))) (AND (NOT NOERROR) (ERROR "BAD CHARACTER SPECIFICATION" C))) ((EQ (NCHARS C) 1) (CHCON1 C)) (T (SELCHARQ (CHCON1 C) (^ (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1) NOERROR)) (LOGAND C (LOGNOT 96)))) (%# (* ;; "We use IPLUS instead of LOGOR here because some people want ##char to read as Xerox Meta, i.e., 1,char") (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1) NOERROR)) (IPLUS C 128))) (LET ((STR (MKSTRING C))) (for X in CHARACTERNAMES when (STRING.EQUAL (CAR X) STR) do (RETURN (OR (NUMBERP (CADR X)) (CHARCODE.DECODE (CADR X) NOERROR))) finally (RETURN (LET ((POS (STRPOSL (QUOTE (%, - "." "|")) STR)) CH CSET) (* ; "In the form charset,char") (COND ((AND POS (SETQ CH (OR (LISP:PARSE-INTEGER STR :START POS :RADIX 8 :JUNK-ALLOWED T) (CHARCODE.DECODE (SUBSTRING STR (ADD1 POS)) NOERROR))) (< CH 256) (>= CH 0)) (* ; "parsed the char part as an octal number or character spec") (if (AND (SETQ CSET (OR (LISP:PARSE-INTEGER STR :END (SUB1 POS) :RADIX 8 :JUNK-ALLOWED T) (for PAIR in CHARACTERSETNAMES first (SETQ POS (SUBSTRING STR 1 (SUB1 POS))) when (STRING.EQUAL (CAR PAIR) POS) do (RETURN (CADR PAIR))))) (< CSET 256) (>= CSET 0)) then (* ; "parsed the charset part as an octal number or standard charset name") (LOGOR CH (LLSH CSET 8)) elseif (NOT NOERROR) then (ERROR "BAD CHARACTERSET SPECIFICATION" C))) ((NOT NOERROR) (ERROR "BAD CHARACTER SPECIFICATION" C)))))))))))
+)
+)
+
+(RPAQQ CHARACTERNAMES
+       ((INFINITY 8551)
+        ("Page" 12)
+        ("Form" 12)
+        ("FF" 12)
+        ("Rubout" 127)
+        ("Del" 127)
+        ("Null" 0)
+        ("Escape" 27)
+        ("Esc" 27)
+        ("Bell" 7)
+        ("Tab" 9)
+        ("Backspace" 8)
+        ("Bs" 8)
+        ("Newline" 13)
+        ("CR" 13)
+        ("EOL" 13)
+        ("Return" 13)
+        ("Tenexeol" 31)
+        ("Space" 32)
+        ("Sp" 32)
+        ("Linefeed" 10)
+        ("LF" 10)))
+
+(RPAQQ CHARACTERSETNAMES (("Greek" 38)
+                              ("Cyrillic" 39)
+                              ("Hira" 36)
+                              ("Hiragana" 36)
+                              ("Kata" 37)
+                              ("Katakana" 37)
+                              ("Kanji" 48)))
+(DECLARE%: DOEVAL@COMPILE DONTCOPY 
+
+(RPAQQ READTYPES (READ.RT RATOM.RT NOPROPRB.RT PROPRB.RT))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ READ.RT NIL)
+
+(RPAQQ RATOM.RT 1)
+
+(RPAQQ NOPROPRB.RT T)
+
+(RPAQQ PROPRB.RT 0)
+
+
+(CONSTANTS READ.RT RATOM.RT NOPROPRB.RT PROPRB.RT)
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS .CALL.SUBREAD. MACRO
+          [X (DESTRUCTURING-BIND (STREAM EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE READTYPE)
+                    X
+                    `(WITH-RESOURCES (\PNAMESTRING \PNAMECASEBITS)
+                            (\SUBREAD (\GETSTREAM ,STREAM 'INPUT)
+                                   (fetch (READTABLEP READSA) of *READTABLE*)
+                                   ,[COND
+                                       (READTYPE)
+                                       (T `(COND
+                                              (,CHAR -1)
+                                              (T READ.RT]
+                                   \PNAMESTRING
+                                   (READTABLE-CASEARRAY *READTABLE*)
+                                   \PNAMECASEBITS
+                                   ,EOF-SUPPRESS
+                                   ,EOF-VALUE
+                                   ,CHAR
+                                   ,PRESERVE-WHITESPACE])
+
+(PUTPROPS FIXDOT MACRO [NIL (PROGN                 (* ; 
+                                                      "Fix a non-first dot followed by a singleton")
+                                             (AND DOTLOC (CDDR DOTLOC)
+                                                  (NULL (CDDDR DOTLOC))
+                                                  (RPLACD DOTLOC (CADDR DOTLOC])
+
+(PUTPROPS RBCONTEXT MACRO ((X . Y)
+                                   ([LAMBDA (\RBFLG)
+                                      (DECLARE (SPECVARS \RBFLG))
+                                      (PROGN X . Y)
+                                      \RBFLG]
+                                    NIL)))
+
+(PUTPROPS PROPRB MACRO [(X . Y)                      (* ; 
+                                                           "Propagates the right-bracket flag")
+                                (AND (RBCONTEXT X . Y)
+                                     (OR (EQ READTYPE NOPROPRB.RT)
+                                         (SETQ \RBFLG T])
+
+(PUTPROPS \RDCONC MACRO [(ELT . TOPFORMS)
+
+                                 (* ;; "Add ELT to the accumulating list to be returned by \SUBREAD.  If at top level and no list accumulated, then run TOPFORMS")
+
+                                 (COND
+                                    [LST (RPLACD END (SETQ END (CONS ELT]
+                                    (TOPLEVELP . TOPFORMS)
+                                    ((NOT *READ-SUPPRESS*)   (* ; 
+                                  "Don't bother consing the result if it's going to be thrown away")
+                                     (SETQ END (SETQ LST (CONS ELT])
+)
+
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \BACKCHAR MACRO (OPENLAMBDA (STREAM)       (* ; "Backs up over an NS character")
+                                         (\BACKNSCHAR STREAM (UNFOLD (ACCESS-CHARSET STREAM)
+                                                                    256))))
+
+(PUTPROPS \BACKNSCHAR MACRO [(ST SHIFTEDCHARSET COUNTERVAR)
+                                     (COND
+                                        ((\XCCSP ST)
+                                         (\BACKXCCSCHAR ST SHIFTEDCHARSET COUNTERVAR))
+                                        (T (COND
+                                              ['COUNTERVAR (SETQ COUNTERVAR
+                                                            (IDIFFERENCE COUNTERVAR
+                                                                   (CL:FUNCALL (ffetch
+                                                                                (STREAM BACKCHARFN)
+                                                                                  of ST)
+                                                                          ST T]
+                                              (T (CL:FUNCALL (ffetch (STREAM BACKCHARFN)
+                                                                of ST)
+                                                        ST NIL])
+
+(PUTPROPS \CHECKEOLC MACRO
+          (OPENLAMBDA
+           (CH EOLC STREAM PEEKBINFLG COUNTERVAR)
+
+           (* ;; "Subtracts number of bytes read from COUNTERVAR, which may be NIL.  In fact, should be NIL if PEEKBINFLG is T.")
+
+           (SELCHARQ CH
+                (CR (SELECTC EOLC
+                        (CR.EOLC (CHARCODE EOL))
+                        (CRLF.EOLC (COND
+                                      [PEEKBINFLG 
+
+                                 (* ;; "T from PEEKC, compile-time constant.  In this case, must leave the fileptr where it was, except for possibly advancing over character set shifts")
+
+                                             (COND
+                                                ([EQ (CHARCODE LF)
+                                                     (UNINTERRUPTABLY
+                                                         (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM
+                                                                                      )
+                                                                              256))
+
+                                 (* ;; "Read the NS CR.  We know that there aren't any font-shift characters in front of the CR, because they would have already been read by the \NSPEEK that got the CR character.  Since we are going to NS back the CR character, we don't need to update the counter variable")
+
+                                                         (PROG1 (\PEEKBIN STREAM T)
+
+                                 (* ;; "LF must be in next BYTE after NS CR, regardless of coding.  Character-set shifting bytes can't intervene.  Then we back up over the CR that was \NSINed above.")
+
+                                                             (\BACKNSCHAR STREAM)))]
+                                                 (CHARCODE EOL))
+                                                (T (CHARCODE CR]
+                                      ((EQ (CHARCODE LF)
+                                           (\PEEKBIN STREAM T))
+                                       (\BIN STREAM)
+                                       (AND 'COUNTERVAR (SETQ COUNTERVAR (SUB1 COUNTERVAR)))
+                                       (CHARCODE EOL))
+                                      (T (CHARCODE CR))))
+                        (CHARCODE CR)))
+                (LF (COND
+                       ((EQ EOLC LF.EOLC)
+                        (CHARCODE EOL))
+                       (T (CHARCODE LF))))
+                CH)))
+
+(PUTPROPS \INCHAR MACRO (OPENLAMBDA (STREAM COUNTERVAR)
+                                                             (* ; "returns a 16 bit character code")
+                                       (\CHECKEOLC (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM)
+                                                                        256)
+                                                          NIL COUNTERVAR)
+                                              (FFETCH EOLCONVENTION OF STREAM)
+                                              STREAM NIL COUNTERVAR)))
+
+(PUTPROPS \INCCODE MACRO (OPENLAMBDA (STREAM COUNTERVAR)
+                                                             (* ; "returns a 16 bit character code")
+                                        (\CHECKEOLC (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM)
+                                                                         256)
+                                                           NIL COUNTERVAR)
+                                               (ffetch EOLCONVENTION of STREAM)
+                                               STREAM NIL COUNTERVAR)))
+
+(PUTPROPS \PEEKCCODE MACRO (OPENLAMBDA (STREAM NOERROR)
+                                          (\CHECKEOLC (\NSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM)
+                                                                             256)
+                                                             NIL NOERROR)
+                                                 (ffetch EOLCONVENTION of STREAM)
+                                                 STREAM T)))
+
+(PUTPROPS \NSIN MACRO [(ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR)
+
+(* ;;; "Dispatches to the appropriate character code decoder.  If you want to support a new character encoding format, you have to write a decoder and add it here.")
+
+                               (COND
+                                  ((\XCCSP ST)
+                                   (\XCCSIN ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR))
+                                  (T (COND
+                                        ('COUNTERVAR (CL:MULTIPLE-VALUE-BIND
+                                                      (CODE NUM)
+                                                      (CL:FUNCALL (ffetch (STREAM INCCODEFN)
+                                                                     of ST)
+                                                             ST T)
+                                                      (AND NUM (SETQ COUNTERVAR (IDIFFERENCE 
+                                                                                       COUNTERVAR NUM
+                                                                                       )))
+                                                      CODE))
+                                        (T (CL:FUNCALL (ffetch (STREAM INCCODEFN) of ST)
+                                                  ST NIL])
+
+(PUTPROPS \NSPEEK MACRO [(ST SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR)
+
+(* ;;; "Dispatches to the appropriate character code decoder.  If you want to support a new character encoding format, you have to write a decoder and add it here.")
+
+                                 (COND
+                                    ((\XCCSP ST)
+                                     (\XCCSPEEK ST (UNFOLD (ACCESS-CHARSET ST)
+                                                          256)
+                                            NIL NOERROR))
+                                    (T (COND
+                                          ('COUNTERVAR (CL:MULTIPLE-VALUE-BIND
+                                                        (CODE NUM)
+                                                        (CL:FUNCALL (ffetch (STREAM PEEKCCODEFN)
+                                                                       of ST)
+                                                               ST NOERROR T)
+                                                        (AND NUM (SETQ COUNTERVAR (IDIFFERENCE 
+                                                                                         COUNTERVAR 
+                                                                                         NUM)))
+                                                        CODE))
+                                          (T (CL:FUNCALL (ffetch (STREAM PEEKCCODEFN)
+                                                            of ST)
+                                                    ST NOERROR NIL])
+
+(PUTPROPS NUMERIC-CHARSET MACRO (= . ACCESS-CHARSET))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn)
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*)
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+[PUTDEF '\PNAMECASEBITS 'RESOURCES '(NEW (ARRAY \PNAMELIMIT '(BITS 1)
+                                                0]
+)
+)
+
+
+
+(* ; "Support for various external formats")
+
+
+
+
+(* ; "JIS to XCCS conversion table.")
+
+
+(RPAQQ *JIS-TO-XCCS-CONV-NO-FONT-TABLE*
+       ((8484 . 8484)
+        (8485 . 8485)
+        (8497 . 9155)
+        (8798 . 61376)
+        (8802 . 8802)
+        (8805 . 64892)
+        (8806 . 64894)
+        (8820 . 9148)
+        (8821 . 9132)
+        (8822 . 213)
+        (8830 . 8830)
+        (10273 . 61189)
+        (10274 . 61188)
+        (10275 . 10275)
+        (10276 . 10276)
+        (10277 . 10277)
+        (10278 . 10278)
+        (10279 . 10279)
+        (10280 . 10280)
+        (10281 . 10281)
+        (10282 . 10282)
+        (10283 . 61414)
+        (10284 . 61410)
+        (10285 . 61409)
+        (10286 . 10286)
+        (10287 . 10287)
+        (10288 . 10288)
+        (10289 . 10289)
+        (10290 . 10290)
+        (10291 . 10291)
+        (10292 . 10292)
+        (10293 . 10293)
+        (10294 . 61411)
+        (10295 . 10295)
+        (10296 . 10296)
+        (10297 . 10297)
+        (10298 . 10298)
+        (10299 . 10299)
+        (10300 . 10300)
+        (10301 . 10301)
+        (10302 . 10302)
+        (10303 . 10303)
+        (10304 . 10304)))
+
+(RPAQQ *JIS-TO-XCCS-CODE-MAP*
+       ((1 (1 33 . 33)
+           (2 33 . 34)
+           (3 33 . 35)
+           (6 0 . 183)
+           (7 0 . 58)
+           (8 0 . 59)
+           (9 0 . 63)
+           (10 0 . 33)
+           (11 33 . 43)
+           (12 33 . 44)
+           (13 0 . 194)
+           (14 0 . 193)
+           (15 0 . 200)
+           (16 0 . 195)
+           (18 0 . 204)
+           (19 33 . 51)
+           (20 33 . 52)
+           (21 33 . 53)
+           (22 33 . 54)
+           (23 33 . 55)
+           (24 33 . 56)
+           (25 33 . 57)
+           (26 33 . 58)
+           (27 33 . 59)
+           (28 33 . 60)
+           (29 239 . 36)
+           (30 33 . 62)
+           (31 0 . 47)
+           (32 0 . 92)
+           (33 0 . 126)
+           (34 33 . 66)
+           (35 0 . 124)
+           (36 33 . 68)
+           (37 33 . 69)
+           (38 0 . 169)
+           (39 0 . 39)
+           (40 0 . 170)
+           (41 0 . 186)
+           (42 0 . 40)
+           (43 0 . 41)
+           (44 33 . 76)
+           (45 33 . 77)
+           (46 0 . 91)
+           (47 0 . 93)
+           (48 0 . 123)
+           (49 0 . 125)
+           (50 239 . 50)
+           (51 239 . 51)
+           (52 0 . 171)
+           (53 0 . 187)
+           (54 33 . 86)
+           (55 33 . 87)
+           (56 33 . 88)
+           (57 33 . 89)
+           (58 33 . 90)
+           (59 33 . 91)
+           (60 0 . 43)
+           (61 0 . 45)
+           (62 0 . 177)
+           (63 0 . 180)
+           (64 0 . 184)
+           (65 0 . 61)
+           (66 33 . 98)
+           (67 0 . 60)
+           (68 0 . 62)
+           (69 33 . 101)
+           (70 33 . 102)
+           (71 33 . 103)
+           (72 33 . 104)
+           (73 33 . 105)
+           (74 33 . 106)
+           (75 0 . 176)
+           (76 33 . 108)
+           (77 33 . 109)
+           (78 33 . 110)
+           (79 0 . 165)
+           (80 0 . 164)
+           (81 0 . 162)
+           (82 0 . 163)
+           (83 0 . 37)
+           (84 0 . 35)
+           (85 0 . 38)
+           (86 0 . 42)
+           (87 0 . 64)
+           (88 0 . 167)
+           (89 33 . 121)
+           (90 33 . 122)
+           (91 33 . 123)
+           (92 33 . 124)
+           (93 33 . 125)
+           (94 33 . 126))
+        (2 (1 34 . 33)
+           (2 34 . 34)
+           (3 34 . 35)
+           (4 34 . 36)
+           (5 34 . 37)
+           (6 34 . 38)
+           (7 34 . 39)
+           (8 34 . 40)
+           (9 34 . 41)
+           (10 0 . 174)
+           (11 0 . 172)
+           (12 0 . 173)
+           (13 0 . 175)
+           (14 34 . 46)
+           (26 239 . 74)
+           (27 239 . 76)
+           (28 239 . 89)
+           (29 239 . 88)
+           (30 239 . 91)
+           (31 239 . 90)
+           (32 239 . 87)
+           (33 239 . 86)
+           (42 239 . 182)
+           (43 239 . 183)
+           (44 239 . 106)
+           (45 239 . 79)
+           (46 239 . 78)
+           (47 239 . 181)
+           (48 239 . 180)
+           (60 239 . 108)
+           (61 239 . 112)
+           (63 239 . 186)
+           (64 239 . 185)
+           (65 239 . 114)
+           (67 239 . 66)
+           (68 239 . 67)
+           (71 239 . 113)
+           (72 239 . 111)
+           (73 239 . 117)
+           (74 34 . 106)
+           (82 241 . 40)
+           (83 239 . 65)
+           (87 239 . 48)
+           (88 239 . 49)
+           (89 0 . 176))
+        (6 (1 38 . 65)
+           (2 38 . 66)
+           (3 38 . 68)
+           (4 38 . 69)
+           (5 38 . 70)
+           (6 38 . 73)
+           (7 38 . 74)
+           (8 38 . 75)
+           (9 38 . 76)
+           (10 38 . 77)
+           (11 38 . 78)
+           (12 38 . 79)
+           (13 38 . 80)
+           (14 38 . 81)
+           (15 38 . 82)
+           (16 38 . 83)
+           (17 38 . 85)
+           (18 38 . 86)
+           (19 38 . 88)
+           (20 38 . 89)
+           (21 38 . 90)
+           (22 38 . 91)
+           (23 38 . 92)
+           (24 38 . 93)
+           (33 38 . 97)
+           (34 38 . 98)
+           (35 38 . 100)
+           (36 38 . 101)
+           (37 38 . 102)
+           (38 38 . 105)
+           (39 38 . 106)
+           (40 38 . 107)
+           (41 38 . 108)
+           (42 38 . 109)
+           (43 38 . 110)
+           (44 38 . 111)
+           (45 38 . 112)
+           (46 38 . 113)
+           (47 38 . 114)
+           (48 38 . 115)
+           (49 38 . 117)
+           (50 38 . 118)
+           (51 38 . 120)
+           (52 38 . 121)
+           (53 38 . 122)
+           (54 38 . 123)
+           (55 38 . 124)
+           (56 38 . 125))))
+
+(RPAQQ *HANKAKU-TO-ZENKAKU-CODE-MAP*
+       ((161 . 8483)
+        (162 . 8534)
+        (163 . 8535)
+        (164 . 8482)
+        (165 . 183)
+        (166 . 9586)
+        (167 . 9505)
+        (168 . 9507)
+        (169 . 9509)
+        (170 . 9511)
+        (171 . 9513)
+        (172 . 9571)
+        (173 . 9573)
+        (174 . 9575)
+        (175 . 9539)
+        (176 . 8508)
+        (177 . 9506)
+        (178 . 9508)
+        (179 . 9510)
+        (180 . 9512)
+        (181 . 9514)
+        (182 . 9515)
+        (183 . 9517)
+        (184 . 9519)
+        (185 . 9521)
+        (186 . 9523)
+        (187 . 9525)
+        (188 . 9527)
+        (189 . 9529)
+        (190 . 9531)
+        (191 . 9533)
+        (192 . 9535)
+        (193 . 9537)
+        (194 . 9540)
+        (195 . 9542)
+        (196 . 9544)
+        (197 . 9546)
+        (198 . 9547)
+        (199 . 9548)
+        (200 . 9549)
+        (201 . 9550)
+        (202 . 9551)
+        (203 . 9554)
+        (204 . 9557)
+        (205 . 9560)
+        (206 . 9563)
+        (207 . 9566)
+        (208 . 9567)
+        (209 . 9568)
+        (210 . 9569)
+        (211 . 9570)
+        (212 . 9572)
+        (213 . 9574)
+        (214 . 9576)
+        (215 . 9577)
+        (216 . 9578)
+        (217 . 9579)
+        (218 . 9580)
+        (219 . 9581)
+        (220 . 9583)
+        (221 . 9587)
+        (222 . 8491)
+        (223 . 8492)))
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CONV-TABLE-LIST* *JIS-TO-XCCS-CODE-MAP* 
+       *HANKAKU-TO-ZENKAKU-CODE-MAP* *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* 
+       *JIS-6KU-TO-XCCS-CONV-TABLE* *XCCS-TO-JIS-CONV-TABLE* *HANKAKU-TO-ZENKAKU-CONV-TABLE* 
+       *ZENKAKU-TO-HANKAKU-CONV-TABLE*)
+)
+(DEFINEQ
+
+(\MAKE.JIS.TO.XCCS.CONV.TABLE
+(LAMBDA NIL (* ; "Edited 20-Feb-91 19:28 by nm") (* ;;; "The JIS codes which are not equivalent to XCCS reside in 1, 2, 3, 6, 8 and 84 KU.  In case of 3 and 84 KU, the corresponding XCCS is calicutated from JIS.  In case of 1,2 and 6 KU, we have to prepare conversion tables for each because the mapping between XCCS and JIS are random.  8 KU is treated specially because no displayable font is assigned for 8 KU in XCCS.  They are handled with *JIS-TO-XCCS-CONV-NO-FONT-TABLE*.") (* ;;; "Each conversion table is an byte array of size 188 (94 * 2).  94 is a largest number of TEN.  TEN is one origin.  Each JIS code is represented with two bytes in the table.  The first byte is a character set and the second byte is a character code in XCCS.  If both of the first byte and the second byte are 255, it means the JIS code is not defined for the entry.  If the first byte is 255 and the second byte is 0, it means a JIS code is defined for the entry and there is a XCCS code corresponding to the JIS code, but no displayable font is assigned for the code in XCCS.  In the last case, the real XCCS code is found in *JIS-TO-XCCS-CONV-NO-FONT-TABLE*.") (* ;;; "*HANKAKU-TO-ZENKAKU-CONV-TABLE* holds the mapping between JIS HANAKAKU-KANA code to XCCS.  XCCS does not support HANKAKU code.") (SETQ *JIS-1KU-TO-XCCS-CONV-TABLE* (ARRAY 188 (QUOTE BYTE) 255)) (SETQ *JIS-2KU-TO-XCCS-CONV-TABLE* (ARRAY 188 (QUOTE BYTE) 255)) (SETQ *JIS-6KU-TO-XCCS-CONV-TABLE* (ARRAY 188 (QUOTE BYTE) 255)) (SETQ *XCCS-TO-JIS-CONV-TABLE* (HASHARRAY 256)) (SETQ *HANKAKU-TO-ZENKAKU-CONV-TABLE* (HASHARRAY 64)) (SETQ *ZENKAKU-TO-HANKAKU-CONV-TABLE* (HASHARRAY 64)) (LISP:DO ((TABLES (LIST *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* *JIS-6KU-TO-XCCS-CONV-TABLE*) (CDR TABLES)) (KU (QUOTE (1 2 6)) (CDR KU)) CODEMAP) ((LISP:ENDP TABLES)) (SETQ CODEMAP (CDR (ASSOC (CAR KU) *JIS-TO-XCCS-CODE-MAP*))) (for MAP in CODEMAP do (SETA (CAR TABLES) (IDIFFERENCE (UNFOLD (CAR MAP) 2) 1) (CADR MAP)) (SETA (CAR TABLES) (UNFOLD (CAR MAP) 2) (CDDR MAP)))) (bind KU TEN TABLE for ENTRY in *JIS-TO-XCCS-CONV-NO-FONT-TABLE* do (SETQ KU (IDIFFERENCE (FOLDLO (CAR ENTRY) 256) 32)) (SETQ TABLE (SELECTQ KU (1 *JIS-1KU-TO-XCCS-CONV-TABLE*) (2 *JIS-2KU-TO-XCCS-CONV-TABLE*) (6 *JIS-6KU-TO-XCCS-CONV-TABLE*) NIL)) (AND TABLE (SETA TABLE (UNFOLD (IDIFFERENCE (LOGAND 255 (CAR ENTRY)) 32) 2) 0))) (for MAP in *HANKAKU-TO-ZENKAKU-CODE-MAP* do (PUTHASH (CAR MAP) (CDR MAP) *HANKAKU-TO-ZENKAKU-CONV-TABLE*)) (for MAP in *HANKAKU-TO-ZENKAKU-CODE-MAP* do (PUTHASH (CDR MAP) (CAR MAP) *ZENKAKU-TO-HANKAKU-CONV-TABLE*)) (for MAP in (APPEND (for KU in *JIS-TO-XCCS-CODE-MAP* join (for TEN in (CDR KU) collect (BQUOTE ((\, (LOGOR (UNFOLD (CADR TEN) 256) (CDDR TEN))) \, (LOGOR (UNFOLD (IPLUS (CAR KU) 32) 256) (IPLUS (CAR TEN) 32)))))) *JIS-TO-XCCS-CONV-NO-FONT-TABLE*) do (PUTHASH (CAR MAP) (CDR MAP) *XCCS-TO-JIS-CONV-TABLE*)) (SETQ *JIS-TO-XCCS-CONV-TABLE-LIST* (BQUOTE ((33 \, *JIS-1KU-TO-XCCS-CONV-TABLE*) (34 \, *JIS-2KU-TO-XCCS-CONV-TABLE*) (38 \, *JIS-6KU-TO-XCCS-CONV-TABLE*)))))
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(\MAKE.JIS.TO.XCCS.CONV.TABLE)
+)
+
+
+
+(* ; "JIS to XCCS converter")
+
+
+(RPAQ? *REPLACE-NO-FONT-CODE* T)
+
+(RPAQ? *DEFAULT-NOT-CONVERTED-FAT-CODE* 8739)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \CONV.JIS.TO.XCCS MACRO [OPENLAMBDA (KU TEN)
+
+(* ;;; "Some character code is not equivalent between JIS and XCCS.  In such case, we have to convert the character to corresponding XCCS.")
+
+                                                 (COND
+                                                    ((\NOT.EQUIVALENT.TO.XCCS KU)
+                                                     (\DO.CONV.JIS.TO.XCCS KU TEN))
+                                                    (T (LOGOR (UNFOLD KU 256)
+                                                              TEN])
+
+(PUTPROPS \DO.CONV.JIS.TO.XCCS MACRO
+          [(KU TEN)
+
+(* ;;; " Convert a JIS code divided into KU (high 8 bit) and TEN (low 8 bit) to an corresponding XCCS code.")
+
+           (COND
+              ((\INVALID.TENP TEN)
+               *DEFAULT-NOT-CONVERTED-FAT-CODE*)
+              (T (SELECTQ KU
+                     ((33 34 38)                             (* ; "1, 2 and 6 KU")
+                          [LET* ((CONVTABLE (\EXTARACT.CONV.TABLE KU))
+                                 (SET (\EXTRACT.SET TEN CONVTABLE))
+                                 (CODE (\EXTRACT.CODE TEN CONVTABLE)))
+                                (COND
+                                   ((NEQ SET 255)
+                                    (LOGOR (UNFOLD SET 256)
+                                           CODE))
+                                   (T (COND
+                                         ((EQ CODE 255)      (* ; "Not defined in JIS.")
+                                          *DEFAULT-NOT-CONVERTED-FAT-CODE*)
+                                         (T                  (* ; 
+       "Defined in JIS but the displayable font is not assigned in the corresponding code in XCCS.")
+                                            (COND
+                                               (*REPLACE-NO-FONT-CODE* 
+                                                      *DEFAULT-NOT-CONVERTED-FAT-CODE*)
+                                               (T (\EXTRACT.NO.FONT.CODE (LOGOR (UNFOLD KU 256)
+                                                                                TEN])
+                     (35                                     (* ; "3 KU")
+                                                             (* ; 
+                                "Alpha numeric codes are all defined as single byte codes in XCCS.")
+                         TEN)
+                     (40                                     (* ; "8 KU")
+                         (COND
+                            [(< 0 TEN 33)
+                             (COND
+                                (*REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*)
+                                (T (\EXTRACT.NO.FONT.CODE (LOGOR KU TEN]
+                            (T *DEFAULT-NOT-CONVERTED-FAT-CODE*)))
+                     (116                                    (* ; "84 KU")
+                          (COND
+                             ((< 0 TEN 5)
+                              (LOGOR 29952 TEN))
+                             (T *DEFAULT-NOT-CONVERTED-FAT-CODE*)))
+                     (117                                    (* ; "85 KU")
+                          (COND
+                             ((< 0 TEN 28)
+                              (LOGOR 29696 TEN))
+                             (T *DEFAULT-NOT-CONVERTED-FAT-CODE*)))
+                     *DEFAULT-NOT-CONVERTED-FAT-CODE*])
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+
+
+
+(* ; "XCCS to JIS converter")
+
+(DEFINEQ
+
+(CONVHANKAKU
+(LAMBDA ARGS (* ; "Edited  8-Feb-91 13:42 by nm") (PROG1 (STREAMPROP (ARG ARGS 1) :HTOZP) (AND (> ARGS 1) (STREAMPROP (ARG ARGS 1) :HTOZP (ARG ARGS 2)))))
+)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \CONV.XCCS.TO.JIS MACRO (OPENLAMBDA (OUTSTREAM CC)
+
+(* ;;; "Returns JIS code corresponding to XCCS charcode.  Handle HANKAKU as well as ZENKAKU.  If OUTSTREAM wants to convert ZENKAKUKANA to HANKAKUKANA, do so.  Never returns two byte charcode for alpha-numeric character, they are all treated as single byte characode.")
+
+                                                 (OR (COND
+                                                        ((\ASCIIP CC)
+                                                         CC)
+                                                        ((\NOT.EQUIVALENT.TO.JIS CC)
+                                                         (\DO.CONV.XCCS.TO.JIS CC))
+                                                        ((\CONV.HANKAKU.TO.ZENKAKUP OUTSTREAM)
+                                                             (* ; 
+                          "ZENKAKUKANA comes here, because their charcodes are equiavalent to JIS.")
+                                                         (\CONV.ZENKAKU.KANA CC))
+                                                        (T CC))
+                                                     CC)))
+
+(PUTPROPS \DO.CONV.XCCS.TO.JIS MACRO ((CC)
+                                              (GETHASH CC *XCCS-TO-JIS-CONV-TABLE*)))
+
+(PUTPROPS \ASCIIP MACRO (OPENLAMBDA (CC)
+                                       (AND (EQ (FOLDLO CC 256)
+                                                0)
+                                            (< (LOGAND CC 255)
+                                               128))))
+
+(PUTPROPS \NOT.EQUIVALENT.TO.JIS MACRO (OPENLAMBDA (CC)
+                                                      (OR (EQ (FOLDLO CC 256)
+                                                              0)
+                                                          (EQ (FOLDLO CC 256)
+                                                              33)
+                                                          (EQ (FOLDLO CC 256)
+                                                              34)
+                                                          (EQ (FOLDLO CC 256)
+                                                              38)
+                                                          (EQ (FOLDLO CC 256)
+                                                              40)
+                                                          (EQ (FOLDLO CC 256)
+                                                              239)
+                                                          (EQ (FOLDLO CC 256)
+                                                              241))))
+
+(PUTPROPS \CONV.HANKAKU.TO.ZENKAKUP MACRO ((OUTSTREAM)
+                                                   (STREAMPROP OUTSTREAM :HTOZP)))
+
+(PUTPROPS \CONV.ZENKAKU.KANA MACRO ((CHAR)
+                                            (GETHASH CHAR *ZENKAKU-TO-HANKAKU-CONV-TABLE*)))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+(DEFINEQ
+
+(\JISIN
+(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 15:47 by nm") (* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with JIS.  Allows the incorrect usage of KI and KO based on the two different JIS, OLDJIS and NEWJIS, because it is very likely that these two different sets of KI and KO are used simultaneously, although it is against a standard!  ") (* ;;; "If COUNP is non-NIL, the number of bytes read is returned as a second value.  Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG (CH1 CH2 CH3 (IN16BITFLG (\KIMODEP STREAM T)) (CHARNUM 0)) RETRY (AND (SETQ CH1 (\BIN STREAM)) (COND ((EQ CH1 (CHARCODE ESC)) (* ; "Might be KI or KO.") (SETQ CH2 (\BIN STREAM)) (COND ((EQ CH2 (CHARCODE $)) (* ; "Might be KI") (SETQ CH3 (\BIN STREAM)) (COND ((OR (EQ CH3 (CHARCODE B)) (EQ CH3 (CHARCODE @))) (* ; "KI") (\CHNAGE.KI.MODE STREAM T T) (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3))) (* ; "Here we have to try the same preocedure again, because bogus duplicated KI/KO sequence might come again!") (SETQ IN16BITFLG T) (GO RETRY)) (T (COND (IN16BITFLG (* ; "Under processing 16 bit code.") (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) (IPLUS 2 CHARNUM)))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM)))) (T (RETURN (CHARCODE ESC))))))))) ((EQ CH2 (CHARCODE %()) (* ; "Might be KO") (SETQ CH3 (\BIN STREAM)) (COND ((OR (EQ CH3 (CHARCODE J)) (EQ CH3 (CHARCODE H))) (* ; "KO") (\CHNAGE.KI.MODE STREAM T NIL) (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3))) (* ; "Oops.  Yes, we have to try again to ignore duplicated KI/KO sequence.") (SETQ IN16BITFLG NIL) (GO RETRY)) (T (COND (IN16BITFLG (* ; "Under processing 16 bit code.") (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) (IPLUS 2 CHARNUM)))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM)))) (T (RETURN (CHARCODE ESC))))))))) (IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (LISP:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) (IPLUS 2 CHARNUM)))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM)))) (T (RETURN (CHARCODE ESC))))))) (IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (LISP:VALUES (\CONV.JIS.TO.XCCS CH1 (\BIN STREAM)) (IPLUS 2 CHARNUM)))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 (\BIN STREAM)))))) ((\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA is converted to ZENKAKU-KATAKANA because XCCS does not support HANKAKU-KATAKANA.") (COND (COUNTP (RETURN (LISP:VALUES (\CONV.HANKAKU.KANA CH1) (IPLUS 1 CHARNUM)))) (T (RETURN (\CONV.HANKAKU.KANA CH1))))) (T (* ;; "C0, SP, DEL, C1, 10/0, or 15/15 of 0 character set.") (COND (COUNTP (RETURN (LISP:VALUES CH1 (IPLUS 1 CHARNUM)))) (T (RETURN CH1))))))))
+)
+
+(\JISPEEK
+(LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 25-Feb-91 16:27 by nm") (* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with JIS.  Allows the incorrect usage of KI and KO based on the two different JIS, OLDJIS and NEWJIS, because it is very likely that these two different sets of KI and KO are used simultaneously, although it is against a standard!  May actually read the KI or KO.  ") (* ;;; "If COUNTP is non-NIL, the number of bytes read is returned as a second value.  Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG ((IN16BITFLG (\KIMODEP STREAM T)) (CHARNUM 0) (CH1 (\PEEKBIN STREAM NOERROR)) CH2 CH3) RETRY (COND ((NULL CH1) (COND (COUNTP (RETURN (LISP:VALUES NIL CHARNUM))) (T (RETURN NIL)))) ((EQ CH1 (CHARCODE ESC)) (* ; "Might be KI or KO.") (\BIN STREAM) (* ; "Consume the first ESC.") (SETQ CH2 (\PEEKBIN STREAM NOERROR)) (COND ((NULL CH2) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES NIL CHARNUM))) (T (RETURN NIL)))) ((EQ CH2 (CHARCODE $)) (* ; "Might be KI") (\BIN STREAM) (* ; "Consume the $.") (SETQ CH3 (\PEEKBIN STREAM NOERROR)) (COND ((NULL CH3) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES NIL CHARNUM))) (T (RETURN NIL)))) ((OR (EQ CH3 (CHARCODE B)) (EQ CH3 (CHARCODE @))) (* ; "KI") (\CHNAGE.KI.MODE STREAM T T) (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3))) (\BIN STREAM) (* ; "Consume the B or @.") (SETQ IN16BITFLG T) (GO RETRY)) (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (LISP:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (COND (COUNTP (RETURN (LISP:VALUES (CHARCODE ESC) CHARNUM))) (T (RETURN (CHARCODE ESC))))))))) ((EQ CH2 (CHARCODE %()) (* ; "Might be KO") (\BIN STREAM) (* ; "Consume the (.") (SETQ CH3 (\PEEKBIN STREAM NOERROR)) (COND ((NULL CH3) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES NIL CHARNUM))) (T (RETURN NIL)))) ((OR (EQ CH3 (CHARCODE J)) (EQ CH3 (CHARCODE H))) (* ; "KO") (\CHNAGE.KI.MODE STREAM T NIL) (AND COUNTP (SETQ CHARNUM 3)) (\BIN STREAM) (* ; "Consume the J or H.") (SETQ IN16BITFLG NIL) (GO RETRY)) (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (LISP:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (COND (COUNTP (RETURN (LISP:VALUES (CHARCODE ESC) CHARNUM))) (T (RETURN (CHARCODE ESC))))))))) (IN16BITFLG (* ; "Under processing 16 bit code.") (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES (CHARCODE ESC) CHARNUM))) (T (RETURN (CHARCODE ESC))))))) (IN16BITFLG (* ; "Under processing 16 bit code.") (\BIN STREAM) (* ; "Consume the first byte.") (SETQ CH2 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (COND (CH2 (COND (COUNTP (RETURN (LISP:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (COND (COUNTP (RETURN (LISP:VALUES NIL CHARNUM))) (T (RETURN NIL)))))) ((\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA is converted to ZENKAKU-KATAKANA because XCCS does not support HANKAKU-KATAKANA.") (COND (COUNTP (RETURN (LISP:VALUES (\CONV.HANKAKU.KANA CH1) CHARNUM))) (T (RETURN (\CONV.HANKAKU.KANA CH1))))) (T (* ;; "C0, SP, DEL, C1, 10/0, or 15/15 of 0 character set.") (COND (COUNTP (RETURN (LISP:VALUES CH1 CHARNUM))) (T (RETURN CH1)))))))
+)
+
+(\BACKJISCHAR
+(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 17:05 by nm") (COND ((\BACKFILEPTR STREAM) (COND ((\KIMODEP STREAM T) (COND ((\BACKFILEPTR STREAM) (AND COUNTP 2)) (T (AND COUNTP 1)))) (COUNTP 1))) (COUNTP 0)))
+)
+
+(\SHIFTJISIN
+(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 15:49 by nm") (* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with Shift-JIS.  If COUNP is non-NIL, the number of bytes read is returned as a second value.  Doesn't do EOL conversion -- \INCHAR or \INCCODE do that..") (LET ((CH1 (\BIN STREAM)) CH2) (AND CH1 (COND ((\SJIS.KANJI.FIRST.BYTEP CH1) (* ; "Read next byte and compose a kanji character.") (\CONV.SJIS.TO.JIS CH1 (\BIN STREAM)) (* ; "CH1 and CH2 is adjusted to represent JIS code in \CONV.SJIS.TO.JIS.") (COND (COUNTP (LISP:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) 2)) (T (\CONV.JIS.TO.XCCS CH1 CH2)))) (T (* ; "ASCII or HANKAKU-KATAKANA") (COND ((\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA") (COND (COUNTP (LISP:VALUES (\CONV.HANKAKU.KANA CH1) 1)) (T (\CONV.HANKAKU.KANA CH1)))) (T (* ; "ASCII") (COND (COUNTP (LISP:VALUES CH1 1)) (T CH1)))))))))
+)
+
+(\SHIFTJISPEEK
+(LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 25-Feb-91 16:30 by nm") (* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with Shift-JIS. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG ((CH1 (\PEEKBIN STREAM NOERROR)) CH2) (COND ((NULL CH1) (COND (COUNTP (RETURN (LISP:VALUES NIL 0))) (T (RETURN NIL)))) ((\SJIS.KANJI.FIRST.BYTEP CH1) (* ; "Read next byte and compose a kanji character.") (\BIN STREAM) (* ; "Consume the first byte.") (COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES NIL 0))) (T (RETURN NIL))))) (\BACKFILEPTR STREAM) (\CONV.SJIS.TO.JIS CH1 CH2) (* ; "CH1 and CH2 is adjusted to represent JIS code in \CONV.SJIS.TO.JIS.") (COND (COUNTP (RETURN (LISP:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) 0))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (* ; "ASCII or HANKAKU-KATAKANA") (RETURN (COND ((\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA") (COND (COUNTP (RETURN (LISP:VALUES (\CONV.HANKAKU.KANA CH1) 0))) (T (RETURN (\CONV.HANKAKU.KANA CH1))))) (T (* ; "ASCII") (COND (COUNTP (RETURN (LISP:VALUES CH1 0))) (T (RETURN CH1))))))))))
+)
+
+(\BACKSHIFTJISCHAR
+(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 17:05 by nm") (COND ((\BACKFILEPTR STREAM) (COND ((\BACKFILEPTR STREAM) (COND ((\SJIS.KANJI.FIRST.BYTEP (\PEEKBIN STREAM)) (AND COUNTP 2)) (T (\BIN STREAM) (AND COUNTP 1)))) (COUNTP 1))) (COUNTP 0)))
+)
+
+(\EUCIN
+(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 15:54 by nm") (* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with EUC (Extended Unix Codes).  Although EUC is independent of a particular language, the language implemented here is Japanese, thus this should be called as UJIS (Unixnized extended JIS code).  JEIDA uses EUC as UJIS.  ") (* ;;; "If COUNP is non-NIL, the number of bytes read is returned as a second value.  Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (LET ((CH1 (\BIN STREAM)) CH2) (AND CH1 (COND ((\EUC.KANJI.FIRST.BYTEP CH1) (* ; "Read next byte and compose a kanji character.") (COND (COUNTP (LISP:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND (\BIN STREAM) 127)) 2)) (T (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND (\BIN STREAM) 127))))) ((\EUC.HANKAKUP CH1) (COND (COUNTP (LISP:VALUES (\CONV.HANKAKU.KANA (\BIN STREAM)) 2)) (T (\CONV.HANKAKU.KANA (\BIN STREAM))))) ((\GAIJIP CH1) (COND (COUNTP (LISP:VALUES (\CONV.JIS.TO.XCCS (LOGAND (\BIN STREAM) 127) (LOGAND (\BIN STREAM) 127)) 3)) (T (\CONV.JIS.TO.XCCS (LOGAND (\BIN STREAM) 127) (LOGAND (\BIN STREAM) 127))))) (T (* ; "ASCII, C0, C1, SP or DEL") (COND (COUNTP (LISP:VALUES CH1 1)) (T CH1)))))))
+)
+
+(\EUCPEEK
+(LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 25-Feb-91 16:35 by nm") (* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with EUC (Extended Unix Codes).  Although EUC is independent of a particular language, the language implemented here is Japanese, thus this should be called as UJIS (Unixnized extended JIS code).  JEIDA uses EUC as UJIS. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG ((CH1 (\PEEKBIN STREAM NOERROR)) CH2) (COND ((NULL CH1) (COND (COUNTP (RETURN (LISP:VALUES NIL 0))) (T (RETURN NIL)))) ((\EUC.KANJI.FIRST.BYTEP CH1) (* ; "Read next byte and compose a kanji character.") (\BIN STREAM) (* ; "Consume the first byte.") (COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES NIL 0))) (T (RETURN NIL))))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127)) 0))) (T (RETURN (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127)))))) ((\EUC.HANKAKUP CH1) (\BIN STREAM) (* ; "Consume the SS2.") (COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES NIL 0))) (T (RETURN NIL))))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES (\CONV.HANKAKU.KANA CH2) 0))) (T (RETURN (\CONV.HANKAKU.KANA CH2))))) ((\GAIJIP CH1) (\BIN STREAM) (* ; "Consume the SS3.") (COND ((NULL (SETQ CH1 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES NIL 0))) (T (RETURN NIL))))) (\BIN STREAM) (* ; "Consume the first byte in GAIJI.") (COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES NIL 0))) (T (RETURN NIL))))) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127)) 0))) (T (RETURN (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127)))))) (T (* ; "ASCII, C0, C1, SP or DEL") (COND (COUNTP (RETURN (LISP:VALUES CH1 0))) (T (RETURN CH1)))))))
+)
+
+(\BACKEUCCHAR
+(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 17:06 by nm") (COND ((\BACKFILEPTR STREAM) (COND ((BITTEST (\PEEKBIN STREAM) (MASK.1'S 7 1)) (* ; "C1, KAINJI, HANKAKU or GAIJI") (COND ((\BACKFILEPTR STREAM) (COND ((\EUC.HANKAKUP (\PEEKBIN STREAM)) (AND COUNTP 2)) ((BITTEST (\PEEKBIN STREAM) (MASK.1'S 7 1)) (* ; "KANJI or GAIJI") (COND ((\BACKFILEPTR STREAM) (COND ((\GAIJIP (\PEEKBIN STREAM)) (AND COUNTP 3)) (T (* ; "KANJI") (\BIN STREAM) (AND COUNTP 2)))) (COUNTP 2))) (T (* ; "C1") (\BIN STREAM) (AND COUNTP 1)))) (COUNTP 1))) (COUNTP 1))) (COUNTP 0)))
+)
+
+(\THROUGHIN
+(LAMBDA (STREAM COUNTP) (* ; "Edited 26-Feb-91 13:36 by nm") (* ;;; "Read in a single byte from STREAM and returns it without any character conversion, just through as if.") (* ;;; "If COUNP is non-NIL, always 1 is returned as the second value.") (COND (COUNTP (LISP:VALUES (\BIN STREAM) 1)) (T (\BIN STREAM))))
+)
+
+(\THROUGHPEEK
+(LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 26-Feb-91 13:40 by nm") (* ;;; "Returns a 8 bit code without any character conversion, just through as if.") (* ;;; "If COUNTP is non-NIL, always 0 is returned as its second value.") (COND (COUNTP (LISP:VALUES (\PEEKBIN STREAM NOERROR) 0)) (T (\PEEKBIN STREAM NOERROR))))
+)
+
+(\BACKTHROUGHCHAR
+(LAMBDA (STREAM COUNTP) (* ; "Edited 26-Feb-91 13:43 by nm") (COND ((\BACKFILEPTR STREAM) 1) (COUNTP 0)))
+)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \XCCSIN MACRO [(STREAM SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR)
+
+(* ;;; "returns a 16 bit character code.  SHIFTEDCSET is STREAM's char set left shifted 8, SHIFTEDCSETVAR if non-NIL is the variable to set if char set changes.  COUNTERVAR if non-NIL is decremented by number of bytes read.  Doesn't do EOL conversion -- \INCHAR and \INCCODE do that.")
+
+                                 (LET ((CHAR (\BIN STREAM))
+                                       SCSET)
+                                      (COND
+                                         [(EQ CHAR NSCHARSETSHIFT)
+                                                             (* ; "Shifting character sets")
+                                          [ACCESS-CHARSET STREAM
+                                                 (SETQ SCSET (COND
+                                                                ((NEQ NSCHARSETSHIFT (SETQ CHAR
+                                                                                      (\BIN STREAM)))
+                                                                 (AND 'COUNTERVAR (SETQ COUNTERVAR
+                                                                                   (IDIFFERENCE
+                                                                                    COUNTERVAR 2)))
+                                                                 CHAR)
+                                                                ((PROGN 
+                                                             (* ; 
+                                                           "2 shift-bytes means not run-encoded")
+                                                                        (AND 'COUNTERVAR
+                                                                             (SETQ COUNTERVAR
+                                                                              (IDIFFERENCE COUNTERVAR
+                                                                                     3)))
+                                                                        (EQ 0 (\BIN STREAM)))
+                                                                 \NORUNCODE)
+                                                                (T (\NSIN.24BITENCODING.ERROR
+                                                                    STREAM]
+                                          (SETQ CHAR (\BIN STREAM))
+                                          (SETQ SCSET (COND
+                                                         ('SHIFTEDCSETVAR 
+                                                             (* ; "CHARSETVAR=NIL means don't set")
+                                                                (SETQ SHIFTEDCSETVAR (UNFOLD SCSET 
+                                                                                            256)))
+                                                         (T (UNFOLD SCSET 256]
+                                         (T (SETQ SCSET SHIFTEDCSET)))
+                                      (COND
+                                         ((EQ SCSET (UNFOLD \NORUNCODE 256))
+                                                             (* ; 
+                                           "just read two bytes and combine them to a 16 bit value")
+                                          (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2
+                                                                                   )))
+                                          (LOGOR (UNFOLD CHAR 256)
+                                                 (\BIN STREAM)))
+                                         (CHAR (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE 
+                                                                                        COUNTERVAR 1)
+                                                                 ))
+                                               (AND CHAR (LOGOR SCSET CHAR])
+
+(PUTPROPS \XCCSPEEK MACRO [(STREAM SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR)
+
+                                 (* ;; "Returns a 16 bit character code.  Doesn't do EOL conversion--\INCHAR does that.  May actually read the character-set shift, storing the result in the stream.  COUNTERVAR, if given, is updated to reflect any such bytes that are actually read")
+
+                                   (PROG ((CHAR (\PEEKBIN STREAM NOERROR))
+                                          SCSET)
+                                         (COND
+                                            ((NULL CHAR)
+                                             (RETURN NIL))
+                                            [(EQ CHAR NSCHARSETSHIFT)
+                                                             (* ; "CHARSETVAR=NIL means don't set")
+                                             (\BIN STREAM)   (* ; "Consume the char shift byte")
+                                             [ACCESS-CHARSET STREAM
+                                                    (SETQ SCSET (COND
+                                                                   ((NEQ NSCHARSETSHIFT
+                                                                         (SETQ CHAR (\BIN STREAM)))
+                                                             (* ; 
+     "Note: no eof error check on this \BIN -- an eof in the middle of a charset shift is an error")
+                                                                    (AND 'COUNTERVAR
+                                                                         (SETQ COUNTERVAR
+                                                                          (IDIFFERENCE COUNTERVAR 2))
+                                                                         )
+                                                                    CHAR)
+                                                                   ((PROGN 
+                                                             (* ; 
+                                                           "2 shift-bytes means not run-encoded")
+                                                                           (AND 'COUNTERVAR
+                                                                                (SETQ COUNTERVAR
+                                                                                 (IDIFFERENCE 
+                                                                                        COUNTERVAR 3)
+                                                                                 ))
+                                                                           (EQ 0 (\BIN STREAM)))
+                                                                    \NORUNCODE)
+                                                                   (T (\NSIN.24BITENCODING.ERROR
+                                                                       STREAM]
+                                             [SETQ SCSET (COND
+                                                            ('SHIFTEDCSETVAR 
+                                                             (* ; "CHARSETVAR=NIL means don't set")
+                                                                   (SETQ SHIFTEDCSETVAR
+                                                                    (UNFOLD SCSET 256)))
+                                                            (T (UNFOLD SCSET 256]
+                                             (COND
+                                                ((NULL (SETQ CHAR (\PEEKBIN STREAM NOERROR)))
+                                                 (RETURN NIL]
+                                            (T (SETQ SCSET SHIFTEDCSET)))
+                                         (RETURN (COND
+                                                    ((EQ SCSET (UNFOLD \NORUNCODE 256))
+
+                                              (* ;; "just peek two bytes and combine them to a 16 bit value.  Again, is an error if we hit eof in mid-character")
+
+                                                     (\BIN STREAM)
+                                                     (PROG1 (LOGOR (UNFOLD CHAR 256)
+                                                                   (\PEEKBIN STREAM NOERROR))
+                                                            (\BACKFILEPTR STREAM)))
+                                                    (T (LOGOR SHIFTEDCSET CHAR])
+
+(PUTPROPS \BACKXCCSCHAR MACRO [(STREAM SHIFTEDCHARSET COUNTERVAR)
+                                       (AND (\BACKFILEPTR STREAM)
+                                            (COND
+                                               [[COND
+                                                   (SHIFTEDCHARSET (EQ SHIFTEDCHARSET
+                                                                       (UNFOLD \NORUNCODE 256)))
+                                                   (T (EQ \NORUNCODE (ACCESS-CHARSET STREAM]
+                                                (COND
+                                                   ((\BACKFILEPTR STREAM)
+                                                    (AND 'COUNTERVAR (add COUNTERVAR 2))
+                                                    T)
+                                                   ('COUNTERVAR (add COUNTERVAR 1]
+                                               ('COUNTERVAR (add COUNTERVAR 1])
+
+(PUTPROPS \XCCSP MACRO [OPENLAMBDA (ST)
+                                      (NOT (ffetch (STREAM NOTXCCS) of (\DTEST ST
+                                                                                      'STREAM])
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \EXTRACT.NO.FONT.CODE MACRO ((JISCODE)
+                                               (CDR (ASSOC JISCODE *JIS-TO-XCCS-CONV-NO-FONT-TABLE*))
+                                               ))
+
+(PUTPROPS \EXTARACT.CONV.TABLE MACRO ((KU)
+                                              (CDR (ASSOC KU *JIS-TO-XCCS-CONV-TABLE-LIST*))))
+
+(PUTPROPS \NOT.EQUIVALENT.TO.XCCS MACRO ((KU)
+
+(* ;;; " The JIS codes which are not equiavelent to XCCS reside in 1, 2, 3, 6, 8 and 84 KU.  Although from 84-5 to 94-94 inclusive are not defined in JIS, that is they are GAIJI, they are also handled here.")
+
+                                                 (OR (EQ KU 33)
+                                                     (EQ KU 34)
+                                                     (EQ KU 35)
+                                                     (EQ KU 38)
+                                                     (EQ KU 40)
+                                                     (EQ KU 116)
+                                                     (EQ KU 117))))
+
+(PUTPROPS \EXTRACT.SET MACRO ((TEN TABLE)
+                                      (ELT TABLE (IDIFFERENCE (UNFOLD (IDIFFERENCE TEN 32)
+                                                                     2)
+                                                        1))))
+
+(PUTPROPS \EXTRACT.CODE MACRO ((TEN TABLE)
+                                       (ELT TABLE (UNFOLD (IDIFFERENCE TEN 32)
+                                                         2))))
+
+(PUTPROPS \CHNAGE.KI.MODE MACRO [OPENLAMBDA (ST INPUTFLG ENTERP)
+
+(* ;;; 
+"INPUTFLG is true if \CHNAGE.KI.MODE is called in the context in which ST is an input stream.")
+
+                                               (COND
+                                                  [INPUTFLG (COND
+                                                               (ENTERP (freplace (STREAM 
+                                                                                           IN.KANJIIN
+                                                                                            )
+                                                                          of (\DTEST ST
+                                                                                        'STREAM)
+                                                                          with T))
+                                                               (T (freplace (STREAM IN.KANJIIN)
+                                                                     of (\DTEST ST 'STREAM)
+                                                                     with NIL]
+                                                  (T (COND
+                                                        (ENTERP (freplace (STREAM OUT.KANJIIN)
+                                                                   of (\DTEST ST 'STREAM)
+                                                                   with T))
+                                                        (T (freplace (STREAM OUT.KANJIIN)
+                                                              of (\DTEST ST 'STREAM) with
+                                                                                         NIL])
+
+(PUTPROPS \KIMODEP MACRO [OPENLAMBDA (ST INPUTFLG)
+
+(* ;;; "INPUTFLG is true if \KIMODEP is called in the context in which ST is an input stream.")
+
+                                        (COND
+                                           [INPUTFLG (ffetch (STREAM IN.KANJIIN)
+                                                        of (\DTEST ST 'STREAM]
+                                           (T (ffetch (STREAM OUT.KANJIIN)
+                                                 of (\DTEST ST 'STREAM])
+
+(PUTPROPS \HANKAKUP MACRO ((CHAR)
+                                   (< 160 CHAR 224)))
+
+(PUTPROPS \KANJIP MACRO ((CHAR)
+                                 (< 12158 CHAR 29733)))
+
+(PUTPROPS \NOTGAIJIP MACRO ((CHAR)
+                                    (OR (< 8480 CHAR 10305)
+                                        (< 12158 CHAR 29733))))
+
+(PUTPROPS \INVALID.TENP MACRO (OPENLAMBDA (TEN)
+                                             (OR (< TEN 33)
+                                                 (< 126 TEN))))
+
+(PUTPROPS \CONV.HANKAKU.KANA MACRO ((CHAR)
+                                            (GETHASH CHAR *HANKAKU-TO-ZENKAKU-CONV-TABLE*)))
+
+(PUTPROPS \OUTKI MACRO ((STREAM)
+                                (\BOUT OUTSTREAM (CHARCODE ESC))
+                                (\BOUT OUTSTREAM (CHARCODE $))
+                                (\BOUT OUTSTREAM (CHARCODE B))))
+
+(PUTPROPS \OUTKO MACRO ((STREAM)
+                                (\BOUT OUTSTREAM (CHARCODE ESC))
+                                (\BOUT OUTSTREAM (CHARCODE %())
+                                (\BOUT OUTSTREAM (CHARCODE J))))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \CONV.SJIS.TO.JIS MACRO [OPENLAMBDA (HI LO)
+
+(* ;;; "Convert Shift-JIS to JIS.  The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of JIS code respectively.")
+
+                                                 [SETQ CH1 (IDIFFERENCE HI (COND
+                                                                              ((> HI 159)
+                                                                               177)
+                                                                              (T 113]
+                                                 (SETQ CH1 (IPLUS (UNFOLD CH1 2)
+                                                                  1))
+                                                 (SETQ CH2 (COND
+                                                              [(> LO 158)
+                                                               (PROG1 (IDIFFERENCE LO 126)
+                                                                   (SETQ CH1 (IPLUS CH1 1)))]
+                                                              (T (IDIFFERENCE LO (COND
+                                                                                    ((> LO 126)
+                                                                                     (IPLUS 31 1))
+                                                                                    (T 31])
+
+(PUTPROPS \CONV.JIS.TO.SJIS MACRO [OPENLAMBDA (HI LO)
+
+(* ;;; "Convert JIS to Shift-JIS.  The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of Shift-JIS code respectively.")
+
+                                                 [SETQ CH2 (COND
+                                                              ((ODDP HI)
+                                                               (SETQ CH2 (IPLUS LO 31))
+                                                               (COND
+                                                                  ((>= CH2 127)
+                                                                   (IPLUS CH2 1))
+                                                                  (T CH2)))
+                                                              (T (IPLUS LO 126]
+                                                 (SETQ CH1 (IPLUS (FOLDLO (IDIFFERENCE HI 33)
+                                                                         2)
+                                                                  129))
+                                                 (AND (> CH1 159)
+                                                      (SETQ CH1 (IPLUS CH1 64])
+
+(PUTPROPS \SJIS.KANJI.FIRST.BYTEP MACRO (OPENLAMBDA (CHAR)
+                                                       (OR (< 127 CHAR 160)
+                                                           (< 223 CHAR 256))))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \EUC.KANJI.FIRST.BYTEP MACRO ((CHAR)
+                                                (< 160 CHAR 255)))
+
+(PUTPROPS \GAIJIP MACRO ((CHAR)
+                                 (EQ CHAR 143)))
+
+(PUTPROPS \EUC.HANKAKUP MACRO ((CHAR)
+                                       (EQ CHAR 142)))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+
+(RPAQ? *SIGNAL-24BIT-NSENCODING-ERROR* )
+
+(RPAQ? *READ-NEWLINE-SUPPRESS* )
+
+(RPAQ? \RefillBufferFn (FUNCTION \READCREFILL))
+
+
+
+(* ; 
+"Top level val of \RefillBufferFn means act like READC--we must be doing a raw BIN (or PEEKBIN?)")
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA CONVHANKAKU CL:PARSE-INTEGER CL:READ-DELIMITED-LIST CL:READ-PRESERVING-WHITESPACE
+                         CL:READ)
+)
+(PUTPROPS LLREAD COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 
+1991 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (6813 13667 (LASTC 6823 . 7816) (PEEKC 7818 . 8123) (PEEKCCODE 8125 . 8348) (RATOM 
+8350 . 8852) (READ 8854 . 9308) (READC 9310 . 9617) (READCCODE 9619 . 9974) (READP 9976 . 10310) (
+SETREADMACROFLG 10312 . 10468) (SKIPSEPRCODES 10470 . 11235) (SKIPSEPRS 11237 . 11929) (
+\NSIN.24BITENCODING.ERROR 11931 . 12506) (SKREAD 12508 . 13665)) (13713 17922 (CL:READ 13723 . 14058) 
+(CL:READ-PRESERVING-WHITESPACE 14060 . 14522) (CL:READ-DELIMITED-LIST 14524 . 15180) (CL:PARSE-INTEGER
+ 15182 . 17920)) (17955 29055 (RSTRING 17965 . 18519) (READ-EXTENDED-TOKEN 18521 . 21321) (\RSTRING2 
+21323 . 29053)) (29091 49402 (\TOP-LEVEL-READ 29101 . 30405) (\SUBREAD 30407 . 45359) (\SUBREADCONCAT 
+45361 . 45873) (\SUBREAD-FLIPCASE 45875 . 47025) (READTABLE-CASEARRAY 47027 . 47414) (\READ.SYMBOL 
+47416 . 48205) (\INVALID.SYMBOL 48207 . 48828) (\APPLYREADMACRO 48830 . 49057) (INREADMACROP 49059 . 
+49400)) (49436 49564 (READQUOTE 49446 . 49562)) (49589 55986 (READVBAR 49599 . 50464) (READHASHMACRO 
+50466 . 53266) (DEFMACRO-LAMBDA-LIST-KEYWORD-P 53268 . 53431) (DIGITBASEP 53433 . 53891) (
+READNUMBERINBASE 53893 . 54863) (ESTIMATE-DIMENSIONALITY 54865 . 55097) (SKIP.HASH.COMMENT 55099 . 
+55610) (CMLREAD.FEATURE.PARSER 55612 . 55984)) (56030 58355 (CHARACTER.READ 56040 . 56689) (
+CHARCODE.DECODE 56691 . 58353)) (78466 81556 (\MAKE.JIS.TO.XCCS.CONV.TABLE 78476 . 81554)) (85497 
+85682 (CONVHANKAKU 85507 . 85680)) (88788 102661 (\JISIN 88798 . 91820) (\JISPEEK 91822 . 95409) (
+\BACKJISCHAR 95411 . 95639) (\SHIFTJISIN 95641 . 96538) (\SHIFTJISPEEK 96540 . 97703) (
+\BACKSHIFTJISCHAR 97705 . 97976) (\EUCIN 97978 . 99215) (\EUCPEEK 99217 . 101281) (\BACKEUCCHAR 101283
+ . 101859) (\THROUGHIN 101861 . 102190) (\THROUGHPEEK 102192 . 102528) (\BACKTHROUGHCHAR 102530 . 
+102659)))))
+STOP
diff --git a/CLTL2/LLREAD.LCOM b/CLTL2/LLREAD.LCOM
new file mode 100644
index 00000000..41b969d9
Binary files /dev/null and b/CLTL2/LLREAD.LCOM differ
diff --git a/CLTL2/LLRESTART b/CLTL2/LLRESTART
new file mode 100644
index 00000000..b597d67a
--- /dev/null
+++ b/CLTL2/LLRESTART
@@ -0,0 +1,24 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "CONDITIONS")
+(IL:FILECREATED " 4-Mar-92 10:31:07" IL:|{DSK}<usr>local>lde>lispcore>sources>LLRESTART.;3| 982    
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:LLRESTARTCOMS) (IL:STRUCTURES RESTART)
+
+      IL:|previous| IL:|date:| "16-May-90 20:02:41" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>LLRESTART.;1|)
+
+
+; Copyright (c) 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:LLRESTARTCOMS)
+
+(IL:RPAQQ IL:LLRESTARTCOMS ((IL:STRUCTURES RESTART) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:LLRESTART)))
+
+(DEFSTRUCT (RESTART (:PRINT-FUNCTION %RESTART-PRINTER)) IL:NAME IL:TAG IL:SELECTOR IL:TEST IL:REPORT INTERACTIVE-FN FUNCTION)
+
+(IL:PUTPROPS IL:LLRESTART IL:FILETYPE COMPILE-FILE)
+
+(IL:PUTPROPS IL:LLRESTART IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "CONDITIONS"))
+(IL:PUTPROPS IL:LLRESTART IL:COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/LLRESTART.LCOM b/CLTL2/LLRESTART.LCOM
new file mode 100644
index 00000000..bdb485db
--- /dev/null
+++ b/CLTL2/LLRESTART.LCOM
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "CONDITIONS")
(IL:FILECREATED "22-Nov-93 16:06:08" ("compiled on " 
IL:|{DSK}<king>export>lispcore>sources>CLTL2>LLRESTART.;1|) "11-Nov-93 16:58:33" IL:|bcompl'd| IL:|in|
 "Medley 11-Nov-93 ..." IL:|dated| "11-Nov-93 17:07:44")
(IL:FILECREATED " 4-Mar-92 10:31:07" IL:|{DSK}<usr>local>lde>lispcore>sources>LLRESTART.;3| 982 
IL:|changes| IL:|to:| (IL:VARS IL:LLRESTARTCOMS) (IL:STRUCTURES RESTART) IL:|previous| IL:|date:| 
"16-May-90 20:02:41" IL:|{DSK}<usr>local>lde>lispcore>sources>LLRESTART.;1|)
(IL:PRETTYCOMPRINT IL:LLRESTARTCOMS)
(IL:RPAQQ IL:LLRESTARTCOMS ((IL:STRUCTURES RESTART) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) 
IL:LLRESTART)))
(DEFSTRUCT (RESTART (:PRINT-FUNCTION %RESTART-PRINTER)) IL:NAME IL:TAG IL:SELECTOR IL:TEST IL:REPORT 
INTERACTIVE-FN FUNCTION)
(IL:PUTPROPS IL:LLRESTART IL:FILETYPE COMPILE-FILE)
(IL:PUTPROPS IL:LLRESTART IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "CONDITIONS"))
(IL:PUTPROPS IL:LLRESTART IL:COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1992))
IL:NIL
\ No newline at end of file
diff --git a/CLTL2/LLSUBRS b/CLTL2/LLSUBRS
new file mode 100644
index 00000000..6a390e32
--- /dev/null
+++ b/CLTL2/LLSUBRS
@@ -0,0 +1,720 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 16:42:05" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLSUBRS.;1" 28802  
+
+      previous date%: "17-Dec-92 14:28:41" "{Pele:mv:envos}<LispCore>Sources>LLSUBRS.;15")
+
+
+(* ; "
+Copyright (c) 1983, 1984, 1985, 1986, 1988, 1989, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT LLSUBRSCOMS)
+
+(RPAQQ LLSUBRSCOMS
+       ((DECLARE%: EVAL@COMPILE DONTCOPY (ADDVARS (DONTCOMPILEFNS SUBRCALL MISCN FIX-SUBR-NAME 
+                                                         WRITECALLSUBRS)))
+        
+
+(* ;;; "MISCN  Vars & Functions")
+
+        (EXPORT (VARS \MISCN-TABLE-LIST))
+        (FUNCTIONS MISCN)
+        (OPTIMIZERS MISCN)
+        (FNS MISCN-NUMBER \MISCN.UFN \UNDEFINED-MISCN-UFN MISCN-COLLECT \GET-MY-BF \INIT-MISCN-TABLE)
+        (PROP ARGNAMES MISCN)
+        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MISCN-UFN-SPEC MISCN-UFN-ENTRY))
+        
+
+(* ;;; " USER-SUBR Vars & Functions")
+
+        (EXPORT (VARS \USER-SUBR-LIST))
+        (FUNCTIONS USER-SUBR ADD-USER-SUBR)
+        (FNS \USER-SUBR-UFN \INIT-USER-SUBR-TABLE \UNDEFINED-USER-SUBR-UFN USER-SUBR-NUMBER EQ-TO-CAR
+             EQ-TO-CADR)
+        (PROP ARGNAMES USER-SUBR)
+        
+
+(* ;;; "SUBRCALL Vars & Functions")
+
+        (EXPORT (VARS \INITSUBRS))
+        (FUNCTIONS SUBRCALL)
+        (OPTIMIZERS SUBRCALL)
+        (FNS SUBRNUMBER)
+        
+        (* ;; "use this to make a subrs.h file for Maiko ")
+
+        (FNS WRITECALLSUBRS FIX-SUBR-NAME)
+        (PROP ARGNAMES SUBRCALL)
+        (DECLARE%: DONTCOPY (RESOURCES UNIXSTRING))
+        (INITRESOURCES UNIXSTRING)
+        (FNS \MOREVMEMFILE \WRITEMAP \COPYSYS0SUBR \PUPLEVEL1STATE SHOWDISPLAY SETSCREENCOLOR 
+             \WRITERAWPBI \READRAWPBI RAID \LISPFINISH \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT
+             DISKPARTITION \CHECKBCPLPASSWORD SUSPEND-LISP UNIX-USERNAME UNIX-FULLNAME UNIX-GETENV 
+             UNIX-GETPARM)
+        (IFPROP ARGNAMES SHOWDISPLAY SETSCREENCOLOR \WRITERAWPBI \READRAWPBI RAID \LISPFINISH 
+               \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT DISKPARTITION \CHECKBCPLPASSWORD)
+        (PROPS (LLSUBRS FILETYPE))))
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+
+(ADDTOVAR DONTCOMPILEFNS SUBRCALL MISCN FIX-SUBR-NAME WRITECALLSUBRS)
+)
+
+
+
+(* ;;; "MISCN  Vars & Functions")
+
+(* "FOLLOWING DEFINITIONS EXPORTED")
+(RPAQQ \MISCN-TABLE-LIST
+       ((USER-SUBR 0 \USER-SUBR-UFN T)
+        (LISP:VALUES 1 LISP::VALUES-UFN NIL)
+        (LISP:SXHASH 2 LISP::SXHASH-UFN NIL)
+        (LISP::EQLHASHBITSFN 3 LISP::EQLHASHBITSFN-UFN NIL)
+        (STRINGHASHBITS 4 \STRINGHASHBITS-UFN NIL)
+        (STRING-EQUAL-HASHBITS 5 \STRING-EQUAL-HASHBITS-UFN NIL)
+        (LISP:VALUES-LIST 6 LISP::VALUES-LIST-UFN NIL)
+        (LCFetchMethod 7 LCFetchMethod NIL)
+        (LCFetchMethodOrHelp 8 NIL NIL)
+        (LCFindVarIndex 9 NIL NIL)
+        (LCGetIVValue 10 NIL NIL)
+        (LCPutIVValue 11 NIL NIL)))
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DEFMACRO MISCN (NAME &REST ARGS)
+   [LET [(ARGNAMES (MAPCAR ARGS #'(LAMBDA (X)
+                                    (GENSYM]
+        `(LISP:FUNCALL [LISP:COMPILE NIL '(LAMBDA ,ARGNAMES
+                                              ((OPCODES MISCN ,(MISCN-NUMBER NAME)
+                                                      ,(LENGTH ARGS))
+                                               ,@ARGNAMES]
+                ,@ARGS])
+
+(DEFOPTIMIZER MISCN (NAME &REST ARGS)
+                        `((OPCODES MISCN ,(MISCN-NUMBER NAME)
+                                 ,(LENGTH ARGS))
+                          ,@ARGS))
+(DEFINEQ
+
+(MISCN-NUMBER
+  [LAMBDA (NAME)                                             (* ; 
+                                                           "Edited  7-Nov-88 15:21 by krivacic")
+    (CADR (OR (ASSOC NAME \MISCN-TABLE-LIST)
+              (ERROR NAME " not a MISCN index"])
+
+(\MISCN.UFN
+  [LAMBDA (ALPHA-BETA)                                       (* ; "Edited  8-Jun-89 16:57 by jds")
+
+    (* ;; "The UFN for the MISCN opcode.")
+
+    (DECLARE (GLOBALVARS \MISCN-TABLE))
+
+    (* ;; "Get the misc index & number of args from the code stream")
+
+    (LET ((INDEX (LRSH ALPHA-BETA 8))
+          (ARG-COUNT (LOGAND ALPHA-BETA 255)))
+
+         (* ;; "compute the position of the real IVARS on the stack.  Create a pointer to these args and pass it to the Handler routine.")
+
+         (COND
+            ((NOT (AND (BOUNDP '\MISCN-TABLE)
+                       \MISCN-TABLE))
+             (\INIT-MISCN-TABLE)))
+         (LET* [(CALLER (\MYALINK))
+                (MY-BF (\GET-MY-BF))
+                (MY-IVAR (fetch (BF IVAR) of MY-BF))
+                (RESULT-IVAR (- MY-IVAR (LLSH ARG-COUNT 1)))
+                (MY-PARMS-PTR (\VAG2 1 RESULT-IVAR))
+                (UFN-ENTRY (\ADDBASE \MISCN-TABLE (LLSH INDEX 1]
+               (COND
+                  ((fetch (MISCN-UFN-ENTRY MISCN-MVS) OF UFN-ENTRY)
+
+                   (* ;; "This UFN can return Multiple values, so we need to preserve them.")
+
+                   (LISP:UNWIND-PROTECT
+                       (APPLY* (\GETBASEPTR UFN-ENTRY 0)
+                              INDEX ARG-COUNT MY-PARMS-PTR)
+                       (replace (BF IVAR) of MY-BF with RESULT-IVAR)
+                       (REPLACE (FX NEXTBLOCK) OF CALLER WITH RESULT-IVAR)))
+                  (T 
+                     (* ;; "He said no MVs are possible, so don't even TRY to preserve them.  This is an expanded and cleaned up version of CL:UNWIND-PROTECT, so watch it!")
+
+                     (PROG1 (.UNWIND.PROTECT. [FUNCTION (LAMBDA NIL
+                                                          (replace (BF IVAR) of MY-BF
+                                                             with RESULT-IVAR]
+                                   (APPLY* (\GETBASEPTR UFN-ENTRY 0)
+                                          INDEX ARG-COUNT MY-PARMS-PTR))
+                         (replace (BF IVAR) of MY-BF with RESULT-IVAR)
+                         (REPLACE (FX NEXTBLOCK) OF CALLER WITH RESULT-IVAR))])
+
+(\UNDEFINED-MISCN-UFN
+  [LAMBDA (INDEX ARG-COUNT ARG-PTR)                          (* ; 
+                                                           "Edited  3-Nov-88 15:56 by krivacic")
+    (PRINTOUT T "index " INDEX ", arg count " ARG-COUNT T)
+    (ERROR (LISP:FORMAT T "Undefined MISCN[~d] with ~d args." INDEX ARG-COUNT)
+           (MISCN-COLLECT ARG-COUNT ARG-PTR])
+
+(MISCN-COLLECT
+  [LAMBDA (ARG-COUNT ARG-PTR)                                (* ; 
+                                                           "Edited  3-Nov-88 11:52 by krivacic")
+    (FOR I FROM 0 TO (- ARG-COUNT 1) COLLECT (\GETBASEPTR ARG-PTR (LLSH I 1])
+
+(\GET-MY-BF
+  [LAMBDA NIL                                              (* ; 
+                                                           "Edited  3-Nov-88 11:08 by krivacic")
+
+    (* ;; "Returns the stack index of the caller's BF.")
+
+    (- (\MYALINK)
+       2])
+
+(\INIT-MISCN-TABLE
+  [LAMBDA NIL
+    (DECLARE (GLOBALVARS \MISCN-TABLE-LIST \MISCN-TABLE))(* ; "Edited  7-Mar-89 09:43 by jds")
+    (LET ((OP-NUMBER 36)
+          (OP-LENGTH 3)
+          BASE)
+         (SETQ \MISCN-TABLE (ARRAY 256 'POINTER '\UNDEFINED-MISCN-UFN 0))
+         (SETQ BASE (FETCH (ARRAYP BASE) OF \MISCN-TABLE))
+         (for MISCN-ENTRY in \MISCN-TABLE-LIST do (SETA \MISCN-TABLE (CADR MISCN-ENTRY)
+                                                                    (CADDR MISCN-ENTRY))
+                                                             (REPLACE (MISCN-UFN-ENTRY MISCN-MVS)
+                                                                OF (\ADDBASE2 BASE
+                                                                              (FETCH (
+                                                                                       MISCN-UFN-SPEC
+                                                                                          INDEX)
+                                                                                 OF MISCN-ENTRY))
+                                                                WITH (FETCH (MISCN-UFN-SPEC
+                                                                                     MVS)
+                                                                            OF MISCN-ENTRY)))
+         (SETQ \MISCN-TABLE BASE])
+)
+
+(PUTPROPS MISCN ARGNAMES (NAME &REST ARGS))
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: EVAL@COMPILE
+
+(RECORD MISCN-UFN-SPEC (
+                            (* ;; 
+                "This is the description for a MISCN opcode's UFN, as placed in \MISCN-TABLE-LIST.")
+
+                            NAME                             (* ; 
+                                                    "Name of the MISCN, for the MISCN macro's use.")
+                            INDEX                            (* ; "Sub-opcode index.")
+                            UFN-NAME                         (* ; "Name of the UFN")
+                            MVS                              (* ; 
+              "T if the UFN can returnmultiple values.  If this is NIL, MVs WILL NOT BE PRESERVED.")
+                            ))
+
+(BLOCKRECORD MISCN-UFN-ENTRY ((MISCN-MVS FLAG)
+                                  (NIL BITS 3)
+                                  (MISCN-UFN POINTER)))
+)
+)
+
+
+
+(* ;;; " USER-SUBR Vars & Functions")
+
+(* "FOLLOWING DEFINITIONS EXPORTED")
+(RPAQQ \USER-SUBR-LIST ((DUMMY 10 DUMMY-UFN)
+                            (SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN)))
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DEFMACRO USER-SUBR (USER-SUBR-NAME &REST ARGS)
+   `(MISCN USER-SUBR ,(USER-SUBR-NUMBER USER-SUBR-NAME)
+           ,@ARGS))
+
+(LISP:DEFUN ADD-USER-SUBR (USER-SUBR-NAME USER-SUBR-INDEX USER-SUBR-UFN)
+   (DECLARE (GLOBALVARS \USER-SUBR-TABLE \USER-SUBR-LIST))
+
+   (* ;; "Make Sure \USER-SUBR-TABLE is made")
+
+   (IF (NOT (AND (BOUNDP '\USER-SUBR-TABLE)
+                     \USER-SUBR-TABLE))
+       THEN (\INIT-USER-SUBR-TABLE))
+
+   (* ;; "See if the Name is already defined")
+
+   [AND (FASSOC USER-SUBR-NAME \USER-SUBR-LIST)
+        (LISP:CERROR "Delete old User-subr" "User-subr ~S already defined" USER-SUBR-NAME)
+        (SETA \USER-SUBR-TABLE (CADR (FASSOC USER-SUBR-NAME \USER-SUBR-LIST))
+              '\UNDEFINED-USER-SUBR-UFN)
+        (SETQ \USER-SUBR-LIST (LISP:REMOVE USER-SUBR-NAME \USER-SUBR-LIST :TEST 'EQ-TO-CAR]
+
+   (* ;; "See if the UFN is already defined")
+
+   [AND (OR (NEQ (ELT \USER-SUBR-TABLE USER-SUBR-INDEX)
+                 '\UNDEFINED-USER-SUBR-UFN)
+            (LISP:FIND USER-SUBR-INDEX \USER-SUBR-LIST :KEY #'LISP:SECOND))
+        (LISP:CERROR "Delete old User-subr" " User-subr index ~d already defined" USER-SUBR-INDEX)
+        (SETQ \USER-SUBR-LIST (LISP:REMOVE USER-SUBR-INDEX \USER-SUBR-LIST :TEST 'EQ-TO-CADR]
+   (LISP:PUSH (LIST USER-SUBR-NAME USER-SUBR-INDEX (OR USER-SUBR-UFN '\UNDEFINED-USER-SUBR-UFN))
+          \USER-SUBR-LIST)
+   (\INIT-USER-SUBR-TABLE))
+(DEFINEQ
+
+(\USER-SUBR-UFN
+  [LAMBDA (INDEX ARG-COUNT ARG-PTR)
+    (DECLARE (GLOBALVARS \USER-SUBR-TABLE))              (* ; 
+                                                           "Edited  4-Nov-88 18:43 by krivacic")
+    (IF (NOT (AND (BOUNDP '\USER-SUBR-TABLE)
+                      \USER-SUBR-TABLE))
+        THEN (\INIT-USER-SUBR-TABLE))
+    (LET ((USER-SUBR-INDEX (\GETBASE ARG-PTR 1)))
+
+         (* ;; "User SUBR ufn.  Index on the User subr indexes")
+
+         (APPLY* (ELT \USER-SUBR-TABLE USER-SUBR-INDEX)
+                USER-SUBR-INDEX
+                (- ARG-COUNT 1)
+                (\ADDBASE ARG-PTR 2])
+
+(\INIT-USER-SUBR-TABLE
+  [LAMBDA NIL
+    (DECLARE (GLOBALVARS \USER-SUBR-TABLE \USER-SUBR-LIST))
+                                                             (* ; 
+                                                           "Edited  4-Nov-88 18:58 by krivacic")
+    (SETQ \USER-SUBR-TABLE (ARRAY 256 'POINTER '\UNDEFINED-USER-SUBR-UFN 0))
+    (for SUBR-ENTRY in \USER-SUBR-LIST do (SETA \USER-SUBR-TABLE (CADR SUBR-ENTRY)
+                                                            (CADDR SUBR-ENTRY])
+
+(\UNDEFINED-USER-SUBR-UFN
+  [LAMBDA (USER-SUBR-INDEX ARG-COUNT ARG-PTR)                (* ; 
+                                                           "Edited  7-Nov-88 14:33 by krivacic")
+
+    (* ;; "User SUBR ufn.  Index on the User subr indexes")
+
+    (ERROR (LISP:FORMAT NIL "Undefined USER-SUBR[~d] with ~d args." USER-SUBR-INDEX ARG-COUNT)
+           (MISCN-COLLECT ARG-COUNT ARG-PTR])
+
+(USER-SUBR-NUMBER
+  [LAMBDA (NAME)                                             (* ; 
+                                                           "Edited  4-Nov-88 18:42 by krivacic")
+    (CADR (OR (ASSOC NAME \USER-SUBR-LIST)
+              (ERROR NAME " not a USER-SUBR index"])
+
+(EQ-TO-CAR
+  [LAMBDA (ITEM LIST)
+    (EQ ITEM (CAR LIST])
+
+(EQ-TO-CADR
+  [LAMBDA (ITEM LIST)
+    (EQ ITEM (CADR LIST])
+)
+
+(PUTPROPS USER-SUBR ARGNAMES (USER-SUBR-NAME &REST ARGS))
+
+
+
+(* ;;; "SUBRCALL Vars & Functions")
+
+(* "FOLLOWING DEFINITIONS EXPORTED")
+(RPAQQ \INITSUBRS
+       ((BACKGROUNDSUBR 6)
+        (CHECKBCPLPASSWORD 7)
+        (DISKPARTITION 8)
+        (DSPBOUT 9)
+        (DSPRATE 10)
+        (GATHERSTATS 11)
+        (GETPACKETBUFFER 12)
+        (LISPFINISH 13)
+        (MOREVMEMFILE 14)
+        (RAID 15)
+        (READRAWPBI 16)
+        (WRITERAWPBI 17)
+        (SETSCREENCOLOR 18)
+        (SHOWDISPLAY 19)
+        (PUPLEVEL1STATE 20)
+        (WRITESTATS 21)
+        (CONTEXTSWITCH 22)
+        (COPYSYS0SUBR 23)
+        (WRITEMAP 24)
+        (UFS-GETFILENAME 34)
+        (UFS-DELETEFILE 35)
+        (UFS-RENAMEFILE 36)
+        (COM-READPAGES 37)
+        (COM-WRITEPAGES 38)
+        (COM-TRUNCATEFILE 39)
+        (UFS-DIRECTORYNAMEP 41)
+        (COM-GETFREEBLOCK 45)
+        (SETUNIXTIME 48)
+        (GETUNIXTIME 49)
+        (COPYTIMESTATS 50)
+        (UNIX-USERNAME 51)
+        (UNIX-FULLNAME 52)
+        (UNIX-GETENV 53)
+        (UNIX-GETPARM 54)
+        (CHECK-SUM 55)
+        (ETHER-SUSPEND 56)
+        (ETHER-RESUME 57)
+        (ETHER-AVAILABLE 58)
+        (ETHER-RESET 59)
+        (ETHER-GET 60)
+        (ETHER-SEND 61)
+        (ETHER-SETFILTER 62)
+        (ETHER-CHECK 63)
+        (DSPCURSOR 64)
+        (SETMOUSEXY 65)
+        (DSP-VIDEOCOLOR 66)
+        (DSP-SCREENWIDTH 67)
+        (DSP-SCREENHEIGHT 68)
+        (BITBLTSUB 69)
+        (BLTCHAR 70)
+        (TEDIT.BLTCHAR 71)
+        (BITBLT.BITMAP 72)
+        (BLTSHADE.BITMAP 73)
+        (RS232C-CMD 74)
+        (RS232C-READ-INIT 75)
+        (RS232C-WRITE 76)
+        (KEYBOARDBEEP 80)
+        (KEYBOARDMAP 81)
+        (KEYBOARDSTATE 82)
+        (VMEMSAVE 89)
+        (LISP-FINISH 90)
+        (NEWPAGE 91)
+        (DORECLAIM 92)
+        (DUMMY-135Q 93)
+        (NATIVE-MEMORY-REFERENCE 94)
+        (OLD-COMPILE-LOAD-NATIVE 95)
+        (DISABLEGC 96)
+        (COM-SETFILEINFO 103)
+        (COM-OPENFILE 104)
+        (COM-CLOSEFILE 105)
+        (DSK-GETFILENAME 106)
+        (DSK-DELETEFILE 107)
+        (DSK-RENAMEFILE 108)
+        (COM-NEXT-FILE 110)
+        (COM-FINISH-FINFO 111)
+        (COM-GEN-FILES 112)
+        (DSK-DIRECTORYNAMEP 113)
+        (COM-GETFILEINFO 114)
+        (COM-CHANGEDIR 116)
+        (UNIX-HANDLECOMM 117)
+        (RPC-CALL 119)
+        (MESSAGE-READP 120)
+        (MESSAGE-READ 121)
+        (MONITOR-CONTROL 128)
+        (GET-NATIVE-ADDR-FROM-LISP-PTR 131)
+        (GET-LISP-PTR-FROM-NATIVE-ADDR 132)
+        (LOAD-NATIVE-FILE 133)
+        (SUSPEND-LISP 134)
+        (NEW-BLTCHAR 135)
+        (COLOR-INIT 136)
+        (COLOR-SCREENMODE 137)
+        (COLOR-MAP 138)
+        (COLOR-BASE 139)
+        (C-SlowBltChar 140)
+        (UNCOLORIZE-BITMAP 141)
+        (COLORIZE-BITMAP 142)
+        (COLOR-8BPPDRAWLINE 143)
+        (TCP-OP 144)
+        (WITH-SYMBOL 145)
+        (CAUSE-INTERRUPT 146)
+        (OPEN-SOCKET 160)
+        (CLOSE-SOCKET 161)
+        (READ-SOCKET 162)
+        (WRITE-SOCKET 163)
+        (CALL-C-FUNCTION 167)
+        (DLD-LINK 168)
+        (DLD-UNLINK-BY-FILE 169)
+        (DLD-UNLINK-BY-SYMBOL 170)
+        (DLD-GET-SYMBOL 171)
+        (DLD-GET-FUNC 172)
+        (DLD-FUNCTION-EXECUTABLE-P 173)
+        (DLD-LIST-UNDEFINED-SYMBOLS 174)
+        (C-MALLOC 175)
+        (C-FREE 176)
+        (C-PUTBASEBYTE 177)
+        (C-GETBASEBYTE 178)
+        (CHAR-OPENFILE 200)
+        (CHAR-BIN 201)
+        (CHAR-BOUT 202)
+        (CHAR-IOCTL 203)
+        (CHAR-CLOSEFILE 204)
+        (CHAR-EOFP 205)
+        (CHAR-READP 206)
+        (CHAR-BINS 207)
+        (CHAR-BOUTS 208)
+        (CHAR-FILLBUFFER 209)))
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(DEFMACRO SUBRCALL (NAME &REST ARGS)
+   [LET [(ARGNAMES (MAPCAR ARGS #'(LAMBDA (X)
+                                    (GENSYM]
+        `(LISP:FUNCALL [LISP:COMPILE NIL '(LAMBDA ,ARGNAMES
+                                              ((OPCODES SUBRCALL ,(SUBRNUMBER NAME)
+                                                      ,(LENGTH ARGS))
+                                               ,@ARGNAMES]
+                ,@ARGS])
+
+(DEFOPTIMIZER SUBRCALL (NAME &REST ARGS)
+                           `((OPCODES SUBRCALL ,(SUBRNUMBER NAME)
+                                    ,(LENGTH ARGS))
+                             ,@ARGS))
+(DEFINEQ
+
+(SUBRNUMBER
+  [LAMBDA (NAME)                                             (* ; "Edited  5-Feb-92 16:49 by jds")
+
+    (* ;; "Given a SUBR's NAME or number, return the corresponding subr number.")
+
+    (LET (NUMBER)
+         (COND
+            ((FIXP NAME)
+             (LISP:WARN "SUBR name (~d) is a number; should be abstracted." NAME)
+             NAME)
+            ((CADR (ASSOC NAME \INITSUBRS)))
+            ([SETQ NUMBER (CADR (LISP:ASSOC NAME \INITSUBRS :TEST (FUNCTION STRING.EQUAL]
+             (LISP:WARN "SUBR name ~s is in wrong package.  Using ~d as subr number." NAME NUMBER))
+            (T (ERROR NAME " not a SUBR"])
+)
+
+
+
+(* ;; "use this to make a subrs.h file for Maiko ")
+
+(DEFINEQ
+
+(WRITECALLSUBRS
+  [LAMBDA NIL                                              (* ; "Edited  6-Nov-89 15:39 by jds")
+    (LISP:WITH-OPEN-FILE (*STANDARD-OUTPUT* "subrs.h" :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
+           (LISP:FORMAT T "/* This file written from LLSUBRS on ~A                      */~&" (DATE))
+           (LISP:FORMAT T "/* Do not edit this file! Instead, edit the list \initsubrs */~&")
+           (LISP:FORMAT T "/* on the lisp file LLSUBRS and then call WRITECALLSUBRS to  */~&")
+           (LISP:FORMAT T "/* generate a new version.                                   */~&")
+           (for X in \INITSUBRS do (LISP:FORMAT T "#define sb_~A	0~O~&"
+                                                      (FIX-SUBR-NAME (CAR X))
+                                                      (CADR X)))
+           (LISP:FORMAT T "~&~&/* MISCN opcodes */~&")
+           (for X in \MISCN-TABLE-LIST do (LISP:FORMAT T "#define miscn_~A	0~O~&"
+                                                             (FIX-SUBR-NAME (CAR X))
+                                                             (CADR X)))
+           (LISP:FORMAT T "~&~&/* Assigned USER SUBR numbers */~&")
+           (for X in \USER-SUBR-LIST do (LISP:FORMAT T "#define user_subr_~A	0~O~&"
+                                                           (FIX-SUBR-NAME (CAR X))
+                                                           (CADR X])
+
+(FIX-SUBR-NAME
+  [LAMBDA (NAME)                                             (* ; "Edited 13-Feb-89 16:17 by jds")
+
+    (* ;; "Fix up a SUBR name for use as a symbol in the C code, by:")
+
+    (* ;; "Converting all -'s to _'s")
+
+    (* ;; "Converting all .'s to _'s")
+
+    (* ;; "Removing all \'s.")
+
+    (* ;; "This allows us to use fairly normal Lisp symbols for SUBR names (like \TEDIT.BLTCHAR), while having them translate pleasantly.")
+
+    (CONCATCODES (DREMOVE (CHARCODE \)
+                        (SUBST (CHARCODE _)
+                               (CHARCODE %.)
+                               (SUBST (CHARCODE _)
+                                      (CHARCODE -)
+                                      (CHCON NAME])
+)
+
+(PUTPROPS SUBRCALL ARGNAMES (NAME &REST ARGS))
+(DECLARE%: DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+[PUTDEF 'UNIXSTRING 'RESOURCES '(NEW (ALLOCSTRING 512]
+)
+)
+
+(/SETTOPVAL '\UNIXSTRING.GLOBALRESOURCE NIL)
+(DEFINEQ
+
+(\MOREVMEMFILE
+  [LAMBDA (FILEPAGE)                                         (* ; 
+                                                           "Edited 27-Apr-88 13:36 by MASINTER")
+    (SUBRCALL MOREVMEMFILE FILEPAGE])
+
+(\WRITEMAP
+  [LAMBDA (VP RP FLAGS)                                      (* ; 
+                                                           "Edited 27-Apr-88 13:37 by MASINTER")
+    (SUBRCALL WRITEMAP VP RP FLAGS])
+
+(\COPYSYS0SUBR
+  [LAMBDA (FID)                                              (* ; 
+                                                           "Edited 20-Apr-88 12:36 by MASINTER")
+    (SUBRCALL COPYSYS0SUBR FID])
+
+(\PUPLEVEL1STATE
+  [LAMBDA (FLG)                                              (* ; 
+                                                           "Edited 20-Apr-88 12:37 by MASINTER")
+    (SUBRCALL PUPLEVEL1STATE FLG])
+
+(SHOWDISPLAY
+  [LAMBDA (BASE RASTERWIDTH)                                 (* ; 
+                                                           "Edited 27-Apr-88 13:40 by MASINTER")
+
+    (* ;; "comments are done with semicolons one comment is at the right margin, it automatically do you type ")
+
+    (SUBRCALL SHOWDISPLAY BASE RASTERWIDTH])
+
+(SETSCREENCOLOR
+  [LAMBDA (FLG)                                              (* ; 
+                                                           "Edited 20-Apr-88 12:37 by MASINTER")
+    (SUBRCALL SETSCREENCOLOR FLG])
+
+(\WRITERAWPBI
+  [LAMBDA (PBI)                                              (* ; 
+                                                           "Edited 20-Apr-88 12:38 by MASINTER")
+    (SUBRCALL WRITERAWPBI PBI])
+
+(\READRAWPBI
+  [LAMBDA NIL                                              (* ; 
+                                                           "Edited 20-Apr-88 12:38 by MASINTER")
+    (SUBRCALL READRAWPBI])
+
+(RAID
+  [LAMBDA (MESS1 MESS2 FLG)                                  (* ; 
+                                                           "Edited 20-Apr-88 12:38 by MASINTER")
+    (SUBRCALL RAID MESS1 MESS2 FLG])
+
+(\LISPFINISH
+  [LAMBDA (DUMMY)                                            (* ; 
+                                                           "Edited 20-Apr-88 12:38 by MASINTER")
+    (SUBRCALL LISPFINISH DUMMY])
+
+(\GETPACKETBUFFER
+  [LAMBDA NIL                                              (* ; 
+                                                           "Edited 20-Apr-88 12:38 by MASINTER")
+    (SUBRCALL GETPACKETBUFFER])
+
+(\GATHERSTATS
+  [LAMBDA (FID)                                              (* ; 
+                                                           "Edited 20-Apr-88 12:38 by MASINTER")
+    (SUBRCALL GATHERSTATS FID])
+
+(\DSPRATE
+  [LAMBDA (AC0 AC1 AC2)                                      (* ; 
+                                                           "Edited 20-Apr-88 12:39 by MASINTER")
+                                                             (* ; 
+                                                           "Edited 20-Apr-88 12:39 by MASINTER")
+    (SUBRCALL DSPRATE AC0 AC1 AC2])
+
+(DSPBOUT
+  [LAMBDA (CHARCODE)                                         (* ; 
+                                                           "Edited 20-Apr-88 12:39 by MASINTER")
+    (SUBRCALL DSPBOUT CHARCODE])
+
+(DISKPARTITION
+  [LAMBDA NIL                                              (* ; 
+                                                           "Edited 20-Apr-88 12:39 by MASINTER")
+    (SELECTQ (MACHINETYPE)
+        ((DORADO DOLPHIN) 
+             (SUBRCALL DISKPARTITION))
+        ((DANDELION DOVE) 
+             (\DFSCurrentVolume))
+        NIL])
+
+(\CHECKBCPLPASSWORD
+  [LAMBDA (USER PASSWORD)                                    (* ; "Edited 14-Jun-88 13:33 by drc:")
+    (SUBRCALL CHECKBCPLPASSWORD USER PASSWORD])
+
+(SUSPEND-LISP
+  [LAMBDA NIL                                              (* ; "Edited 20-Jun-88 15:24 by greep")
+    (if (EQ (MACHINETYPE)
+                'MAIKO)
+        then (SUBRCALL SUSPEND-LISP)
+              T
+      else NIL])
+
+(UNIX-USERNAME
+  [LAMBDA NIL                                              (* ; 
+                                                           "Edited  1-Aug-88 23:22 by masinter")
+    (if (EQ \MACHINETYPE \MAIKO)
+        then (WITH-RESOURCE UNIXSTRING (if (SUBRCALL UNIX-USERNAME UNIXSTRING)
+                                               then (CONCAT (SUBSTRING UNIXSTRING 1
+                                                                       (LISP:POSITION #\Null 
+                                                                              UNIXSTRING])
+
+(UNIX-FULLNAME
+  [LAMBDA NIL                                              (* ; 
+                                                           "Edited 18-Jul-88 03:47 by masinter")
+    (if (EQ \MACHINETYPE \MAIKO)
+        then (WITH-RESOURCES UNIXSTRING (if (SUBRCALL UNIX-FULLNAME UNIXSTRING)
+                                                then (CONCAT (SUBSTRING UNIXSTRING 1
+                                                                        (LISP:POSITION #\Null 
+                                                                               UNIXSTRING])
+
+(UNIX-GETENV
+  [LAMBDA (NAME)                                             (* ; 
+                                                           "Edited  1-Aug-88 23:13 by masinter")
+    (if (EQ \MACHINETYPE \MAIKO)
+        then (WITH-RESOURCE UNIXSTRING (if (SUBRCALL UNIX-GETENV (MKSTRING NAME)
+                                                          UNIXSTRING)
+                                               then (CONCAT (SUBSTRING UNIXSTRING 1
+                                                                       (LISP:POSITION #\Null 
+                                                                              UNIXSTRING])
+
+(UNIX-GETPARM
+  [LAMBDA (NAME)                                             (* ; "Edited 27-Feb-91 17:11 by nm")
+
+    (* ;; "Read information from the C emulator.  Usually gets info about configuration of the machine we're running on.")
+
+    (* ;; 
+"Used to use CL:POSITION, but now called in the INIT if you're on a Sun, so I changed it to STRPOS.")
+
+    (* ;; "SUBRCALL UNIX-GETPARM now returns the length of the string.")
+
+    (if (EQ \MACHINETYPE \MAIKO)
+        then (LET (LEN)
+                      (WITH-RESOURCE UNIXSTRING (SETQ LEN (SUBRCALL UNIX-GETPARM (MKSTRING NAME)
+                                                                 UNIXSTRING))
+                             (COND
+                                [(SMALLP LEN)
+                                 (if (> LEN 0)
+                                     then (CONCAT (SUBSTRING UNIXSTRING 1 LEN]
+                                (LEN (CONCAT (SUBSTRING UNIXSTRING 1 (SUB1 (STRPOS #\Null UNIXSTRING])
+)
+
+(PUTPROPS SHOWDISPLAY ARGNAMES (BASE RASTERWIDTH))
+
+(PUTPROPS SETSCREENCOLOR ARGNAMES (FLG))
+
+(PUTPROPS \WRITERAWPBI ARGNAMES (PBI))
+
+(PUTPROPS \READRAWPBI ARGNAMES NIL)
+
+(PUTPROPS RAID ARGNAMES (MESS1 MESS2 FLG))
+
+(PUTPROPS \LISPFINISH ARGNAMES (DUMMY))
+
+(PUTPROPS \GETPACKETBUFFER ARGNAMES NIL)
+
+(PUTPROPS \GATHERSTATS ARGNAMES (FID))
+
+(PUTPROPS \DSPRATE ARGNAMES (AC0 AC1 AC2))
+
+(PUTPROPS DSPBOUT ARGNAMES (CHARCODE))
+
+(PUTPROPS DISKPARTITION ARGNAMES NIL)
+
+(PUTPROPS \CHECKBCPLPASSWORD ARGNAMES (PASS LISP:VECTOR))
+
+(PUTPROPS LLSUBRS FILETYPE LISP:COMPILE-FILE)
+(PUTPROPS LLSUBRS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1988 1989 1990 1991 1992 
+1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (3699 8653 (MISCN-NUMBER 3709 . 3992) (\MISCN.UFN 3994 . 6255) (\UNDEFINED-MISCN-UFN 
+6257 . 6642) (MISCN-COLLECT 6644 . 6928) (\GET-MY-BF 6930 . 7209) (\INIT-MISCN-TABLE 7211 . 8651)) (
+11345 13366 (\USER-SUBR-UFN 11355 . 11997) (\INIT-USER-SUBR-TABLE 11999 . 12529) (
+\UNDEFINED-USER-SUBR-UFN 12531 . 12945) (USER-SUBR-NUMBER 12947 . 13236) (EQ-TO-CAR 13238 . 13299) (
+EQ-TO-CADR 13301 . 13364)) (17653 18308 (SUBRNUMBER 17663 . 18306)) (18369 20603 (WRITECALLSUBRS 18379
+ . 19846) (FIX-SUBR-NAME 19848 . 20601)) (20814 27992 (\MOREVMEMFILE 20824 . 21056) (\WRITEMAP 21058
+ . 21285) (\COPYSYS0SUBR 21287 . 21514) (\PUPLEVEL1STATE 21516 . 21747) (SHOWDISPLAY 21749 . 22105) (
+SETSCREENCOLOR 22107 . 22337) (\WRITERAWPBI 22339 . 22564) (\READRAWPBI 22566 . 22785) (RAID 22787 . 
+23009) (\LISPFINISH 23011 . 23236) (\GETPACKETBUFFER 23238 . 23467) (\GATHERSTATS 23469 . 23694) (
+\DSPRATE 23696 . 24093) (DSPBOUT 24095 . 24316) (DISKPARTITION 24318 . 24682) (\CHECKBCPLPASSWORD 
+24684 . 24863) (SUSPEND-LISP 24865 . 25125) (UNIX-USERNAME 25127 . 25718) (UNIX-FULLNAME 25720 . 26315
+) (UNIX-GETENV 26317 . 26978) (UNIX-GETPARM 26980 . 27990)))))
+STOP
diff --git a/CLTL2/LLSUBRS.LCOM b/CLTL2/LLSUBRS.LCOM
new file mode 100644
index 00000000..42316bdd
Binary files /dev/null and b/CLTL2/LLSUBRS.LCOM differ
diff --git a/CLTL2/LLSYMBOL b/CLTL2/LLSYMBOL
new file mode 100644
index 00000000..ddbb5208
--- /dev/null
+++ b/CLTL2/LLSYMBOL
@@ -0,0 +1,84 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
+(IL:FILECREATED " 4-Jan-92 12:51:42" IL:|{DSK}<usr>local>lde>lispcore>sources>LLSYMBOL.;2| 9415   
+
+      IL:|changes| IL:|to:|  (IL:FUNCTIONS FBOUNDP CL:FDEFINITION CL::SET-FDEFINITION FMAKUNBOUND) (IL:VARS IL:LLSYMBOLCOMS)
+ (XCL:OPTIMIZERS CL:FDEFINITION) (IL:SETFS CL:FDEFINITION)
+
+      IL:|previous| IL:|date:| "11-Jun-90 17:56:50" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>LLSYMBOL.;1|)
+
+
+; Copyright (c) 1986, 1987, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:LLSYMBOLCOMS)
+
+(IL:RPAQQ IL:LLSYMBOLCOMS ((IL:* IL:|;;| "Symbol functions.") (IL:* IL:|;;| "SET ,  BOUNDP and REMPROP are the same as and shared with Interlisp-D") (IL:FUNCTIONS MAKUNBOUND SYMBOL-NAME SYMBOL-VALUE GET GETF GET-PROPERTIES) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE (IL:P (IL:MOVD (QUOTE IL:GETPROPLIST) (QUOTE SYMBOL-PLIST)))) (IL:FUNCTIONS FBOUNDP FMAKUNBOUND SYMBOL-FUNCTION CL:FDEFINITION IL:SETF-SYMBOL-FUNCTION CL::SET-FDEFINITION) (XCL:OPTIMIZERS CL:FDEFINITION) (IL:COMS (IL:* IL:|;;| "GENSYM Code") (IL:VARIABLES *GENSYM-COUNTER* *GENSYM-PREFIX* *GENTEMP-COUNTER*) (IL:FUNCTIONS GENSYM GENTEMP)) (IL:FUNCTIONS COPY-SYMBOL IL:MAKE-KEYWORD KEYWORDP) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:LLSYMBOL)))
+
+
+
+(IL:* IL:|;;| "Symbol functions.")
+
+
+
+
+(IL:* IL:|;;| "SET ,  BOUNDP and REMPROP are the same as and shared with Interlisp-D")
+
+
+(DEFUN MAKUNBOUND (SYMBOL) (IL:* IL:|;;| "Make a symbol unbound.") (IL:* IL:|;;| " Unbound symbols are set to IL:NOBIND") (IF (CONSTANTP SYMBOL) (PROGN (XCL::SET-CONSTANTP SYMBOL NIL) (PROCLAIM (IL:BQUOTE (SPECIAL (IL:\\\, SYMBOL)))))) (SET SYMBOL (QUOTE IL:NOBIND)) SYMBOL)
+
+(DEFUN SYMBOL-NAME (SYMBOL) (IF (SYMBOLP SYMBOL) (IL:* IL:|;;| "Make a read-only string header displaced to the pname base") (IL:%MAKE-ONED-ARRAY (IL:|ffetch| (IL:LITATOM IL:PNAMELENGTH) IL:|of| SYMBOL) (QUOTE STRING-CHAR) NIL (IL:|ffetch| (IL:LITATOM IL:FATPNAMEP) IL:|of| SYMBOL) T NIL (IL:|ffetch| (IL:LITATOM IL:PNAMEBASE) IL:|of| SYMBOL) 1) (ERROR (QUOTE CONDITIONS:SIMPLE-TYPE-ERROR) :EXPECTED-TYPE (QUOTE SYMBOL) :CULPRIT SYMBOL)))
+
+(DEFUN SYMBOL-VALUE (SYMBOL) (IL:* IL:|;;| "Like EVALV, but must give error if unbound - uses fact that \\eval has an opcode which hooks into free variable microcode") (IF (SYMBOLP SYMBOL) (IL:\\EVAL SYMBOL) (ERROR (QUOTE CONDITIONS:SIMPLE-TYPE-ERROR) :EXPECTED-TYPE (QUOTE SYMBOL) :CULPRIT SYMBOL)))
+
+(DEFUN GET (SYMBOL INDICATOR &OPTIONAL (DEFAULT NIL)) (IL:* IL:|;;| "Look on the property list of SYMBOL for the specified INDICATOR. If this is found, return the associated value, else return DEFAULT.") (GETF (IL:GETPROPLIST SYMBOL) INDICATOR DEFAULT))
+
+(DEFUN GETF (PLACE INDICATOR &OPTIONAL (DEFAULT NIL)) (IL:* IL:|;;| "Searches the property list stored in Place for an indicator EQ to Indicator.  If one is found, the corresponding value is returned, else the Default is returned.") (DO ((PLIST PLACE (CDDR PLIST))) ((NULL PLIST) DEFAULT) (WHEN (EQ (CAR PLIST) INDICATOR) (IF (NOT (CONSP (CDR PLIST))) (ERROR "Malformed property list: ~s" PLACE) (RETURN (CADR PLIST))))))
+
+(DEFUN GET-PROPERTIES (PLACE INDICATOR-LIST) (DO ((PLIST PLACE (CDDR PLIST))) ((NULL PLIST) (VALUES NIL NIL NIL)) (WHEN (MEMBER (CAR PLIST) INDICATOR-LIST :TEST (FUNCTION EQ)) (IF (NOT (CONSP (CDR PLIST))) (ERROR "Malformed p-list: ~s" PLACE) (RETURN (VALUES (CAR PLIST) (CADR PLIST) PLIST))))))
+(IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE 
+
+(IL:MOVD (QUOTE IL:GETPROPLIST) (QUOTE SYMBOL-PLIST))
+)
+
+(DEFUN FBOUNDP (FN) (OR (AND (SYMBOLP FN) (OR (IL:ARGTYPE FN) (MACRO-FUNCTION FN) (SPECIAL-FORM-P FN)) T) (AND (CL::SETF-NAME-P FN) (GET (CADR FN) :SETF-DEFUN) T)))
+
+(DEFUN FMAKUNBOUND (SYMBOL) (IL:* IL:|;;| "Has lots of special knowledge of prop list names") (SETF (SYMBOL-FUNCTION SYMBOL) NIL) (SETF (MACRO-FUNCTION SYMBOL) NIL) (REMPROP SYMBOL (QUOTE IL:SPECIAL-FORM)) (REMPROP SYMBOL (QUOTE IL:CODE)) (REMPROP SYMBOL (QUOTE IL:EXPR)) (LET ((CL::SETF-DEFUN (GET SYMBOL :SETF-DEFUN))) (WHEN CL::SETF-DEFUN (SETF (SYMBOL-FUNCTION CL::SETF-DEFUN) NIL) (REMPROP SYMBOL :SETF-DEFUN))) SYMBOL)
+
+(DEFUN SYMBOL-FUNCTION (SYMBOL &AUX (DEF (IL:GETD SYMBOL))) (IL:* IL:|;;| "this function is preformance-critical, as it is used in the compilation of #'FOO => (CL:SYMBOL-FUNCTION 'FOO). Thus, this definition checks for the GETD definition first. It might even be reasonable to open-code the GETD here. It *is* unreasonable to call MACRO-FUNCTION and SPECIAL-FORM-P first.") (COND (DEF) (IL:* IL:\; "GETD returned non-NIL") ((SETQ DEF (MACRO-FUNCTION SYMBOL)) (IL:* IL:\; "Return something representing the macro's implementation.") (CONS (QUOTE :MACRO) DEF)) ((SETQ DEF (SPECIAL-FORM-P SYMBOL)) (IL:* IL:\; "Return something representing the special-form's implementation.") (CONS (QUOTE :SPECIAL-FORM) DEF)) (T (ERROR (QUOTE XCL:UNDEFINED-FUNCTION) :NAME SYMBOL))))
+
+(DEFUN CL:FDEFINITION (CL::FUNCTION-NAME) (IL:* IL:|;;| "CLtL2 doesn't say whether the result of (FDEFINITION '(SETF FOO)) should be executable or not.  I vote yes with this code - JRB") (COND ((CL::SETF-NAME-P CL::FUNCTION-NAME) (LET ((CL::SETF-NAME (GET (CADR CL::FUNCTION-NAME) :SETF-DEFUN))) (IF CL::SETF-NAME (SYMBOL-FUNCTION CL::SETF-NAME) (ERROR (QUOTE XCL:UNDEFINED-FUNCTION) :NAME CL::FUNCTION-NAME)))) ((SYMBOLP CL::FUNCTION-NAME) (SYMBOL-FUNCTION CL::FUNCTION-NAME)) (T (ERROR "~s cannot name an FDEFINITION" CL::FUNCTION-NAME))))
+
+(DEFUN IL:SETF-SYMBOL-FUNCTION (SYMBOL DEFINITION) (IL:* IL:|;;| "NOTE: If you change this, be sure to change the undoable version on CMLUNDO!") (IL:* IL:|;;| " inverse of SYMBOL-FUNCTION") (IL:VIRGINFN SYMBOL T) (COND ((CONSP DEFINITION) (IL:* IL:|;;| "Either it's a LAMBDA form or one of the special lists put together by SYMBOL-FUNCTION for macros and special forms.") (CASE (CAR DEFINITION) (:MACRO (SETF (MACRO-FUNCTION SYMBOL) (CDR DEFINITION))) (:SPECIAL-FORM (SETF (GET SYMBOL (QUOTE IL:SPECIAL-FORM)) (CDR DEFINITION))) (T (IL:PUTD SYMBOL DEFINITION T)))) (IL:* IL:|;;| "If it's (SETF (SYMBOL-FUNCTION 'FOO) 'BAR) then we give FOO the same definition as BAR.  This isn't quite like Lucid and Symbolics, but it will do for now.") ((AND (SYMBOLP DEFINITION) (NOT (NULL DEFINITION))) (IL:PUTD SYMBOL (IL:GETD DEFINITION) T)) (IL:* IL:|;;| "It's probably a compiled-code object or an interpreted closure.  In any case, go ahead and put it in there; if it's illegal, we'll find out when we try to apply it.") (T (IL:PUTD SYMBOL DEFINITION T))) (IL:* IL:|;;| "(SETF (SYMBOL-FUNCTION ...) ...) is supposed to remove macro definitions.  We only remove the ones that could come from DEFMACRO.") (UNLESS (OR (NULL DEFINITION) (AND (CONSP DEFINITION) (EQ (CAR DEFINITION) :MACRO))) (REMPROP SYMBOL (QUOTE IL:MACRO-FN))) DEFINITION)
+
+(DEFUN CL::SET-FDEFINITION (CL::FUNCTION-NAME CL::NEWVALUE) (IL:* IL:|;;| "If you change this, be sure to change the undoable version on CMLUNDO.") (IF (CL::SETF-NAME-P CL::FUNCTION-NAME) (LET* ((CL::REAL-NAME (SECOND CL::FUNCTION-NAME)) (CL::DEFUN-SETF-NAME (XCL::DEFUN-SETF-NAME CL::REAL-NAME))) (IL:* IL:|;;| "We smash the SYMBOL-FUNCTION of DEFUN-SETF-NAME rather than just changing the :SETF-DEFUN property to insure the SETF function's having a consistent name") (SETF (GET CL::REAL-NAME :SETF-DEFUN) CL::DEFUN-SETF-NAME) (SETF (SYMBOL-FUNCTION CL::DEFUN-SETF-NAME) CL::NEWVALUE)) (IL:SETF-SYMBOL-FUNCTION CL::FUNCTION-NAME CL::NEWVALUE)) CL::NEWVALUE)
+
+(XCL:DEFOPTIMIZER CL:FDEFINITION (CL::FUNCTION-NAME) (IF (AND (CONSTANTP CL::FUNCTION-NAME) (SYMBOLP (EVAL CL::FUNCTION-NAME))) (IL:BQUOTE (SYMBOL-FUNCTION (IL:\\\, CL::FUNCTION-NAME))) (QUOTE COMPILER:PASS)))
+
+
+
+(IL:* IL:|;;| "GENSYM Code")
+
+
+(DEFVAR *GENSYM-COUNTER* 0)
+
+(DEFVAR *GENSYM-PREFIX* "G")
+
+(DEFVAR *GENTEMP-COUNTER* 0)
+
+(DEFUN GENSYM (&OPTIONAL (X NIL X-P)) (IF X-P (ETYPECASE X (STRING (SETQ *GENSYM-PREFIX* X)) (INTEGER (SETQ *GENSYM-COUNTER* X)))) (PROG1 (MAKE-SYMBOL (CONCATENATE (QUOTE STRING) *GENSYM-PREFIX* (IL:MKSTRING *GENSYM-COUNTER*))) (SETQ *GENSYM-COUNTER* (1+ *GENSYM-COUNTER*))))
+
+(DEFUN GENTEMP (&OPTIONAL (PREFIX "T") (PACKAGE *PACKAGE*)) (IL:* IL:|;;| "*gentemp-counter* holds a good guess for the suffix  ") (LET ((COUNTER *GENTEMP-COUNTER*) NAMESTRING) (IL:* IL:\; "Use IL:MKSTRING rather than princ-to-string, since princ-to-string occurs late in the loadup") (LOOP (SETQ NAMESTRING (CONCATENATE (QUOTE STRING) PREFIX (IL:MKSTRING COUNTER))) (WHEN (NULL (FIND-SYMBOL NAMESTRING PACKAGE)) (SETQ *GENTEMP-COUNTER* (1+ COUNTER)) (RETURN (INTERN NAMESTRING PACKAGE))) (SETQ COUNTER (1+ COUNTER)))))
+
+(DEFUN COPY-SYMBOL (SYM &OPTIONAL COPY-PROPS) (LET ((NEW-SYM (MAKE-SYMBOL (SYMBOL-NAME SYM)))) (WHEN COPY-PROPS (IF (BOUNDP SYM) (SETF (SYMBOL-VALUE NEW-SYM) (SYMBOL-VALUE SYM))) (IF (FBOUNDP SYM) (SETF (SYMBOL-FUNCTION NEW-SYM) (SYMBOL-FUNCTION SYM))) (SETF (SYMBOL-PLIST NEW-SYM) (COPY-LIST (SYMBOL-PLIST SYM)))) NEW-SYM))
+
+(DEFUN IL:MAKE-KEYWORD (SYMBOL) (DECLARE (SPECIAL IL:*KEYWORD-PACKAGE*)) (VALUES (INTERN (SYMBOL-NAME SYMBOL) IL:*KEYWORD-PACKAGE*)))
+
+(DEFUN KEYWORDP (OBJECT) (AND (SYMBOLP OBJECT) (EQ (SYMBOL-PACKAGE OBJECT) IL:*KEYWORD-PACKAGE*)))
+
+(IL:PUTPROPS IL:LLSYMBOL IL:FILETYPE COMPILE-FILE)
+
+(IL:PUTPROPS IL:LLSYMBOL IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
+(IL:PUTPROPS IL:LLSYMBOL IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/LLSYMBOL.LCOM b/CLTL2/LLSYMBOL.LCOM
new file mode 100644
index 00000000..8a932a22
Binary files /dev/null and b/CLTL2/LLSYMBOL.LCOM differ
diff --git a/CLTL2/LLTIMER b/CLTL2/LLTIMER
new file mode 100644
index 00000000..89984e16
--- /dev/null
+++ b/CLTL2/LLTIMER
@@ -0,0 +1,795 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 16:44:27" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLTIMER.;2" 37571  
+
+      previous date%: " 3-Sep-91 18:14:34" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLTIMER.;1")
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT LLTIMERCOMS)
+
+(RPAQQ LLTIMERCOMS
+       ([COMS 
+
+(* ;;; "Lowest level Clock stuff")
+
+              (FNS \CLOCK0 \DAYTIME0 \GETINTERNALCLOCK \SETDAYTIME0 CLOCKDIFFERENCE 
+                   \SECONDSCLOCKGREATERP \CLOCKGREATERP \RCLOCK0)
+              (FNS CLOCK0)
+              (OPTIMIZERS \RCLOCK0)
+              (INITVARS (\RCLKMILLISECOND 1680))
+              (GLOBALVARS \RCLKSECOND \RCLKMILLISECOND)
+              [COMS 
+                    (* ;; "Maiko-specific elements")
+
+                    (FNS \MAIKO.DAYTIME \MAIKO.DAYTIME0 \MAIKO.CLOCK0 \MAIKO.CLOCK 
+                         \MAIKO.COPY-TIME-STATS \MAIKO.SETTIME)
+                    
+                    (* ;; "The elements of \MAIKO.MOVDS get movd by \MAIKO.FAULTINIT")
+
+                    (ADDVARS (\MAIKO.MOVDS (\MAIKO.DAYTIME DAYTIME)
+                                    (\MAIKO.DAYTIME0 \DAYTIME0)
+                                    (\MAIKO.CLOCK0 \CLOCK0)
+                                    (\MAIKO.CLOCK0 CLOCK0)
+                                    (\MAIKO.CLOCK CLOCK)
+                                    (\MAIKO.SETTIME \NS.SETTIME)
+                                    (\MAIKO.SETTIME \PUP.SETTIME)
+                                    (\MAIKO.SETTIME SETTIME)
+                                    (\MAIKO.COPY-TIME-STATS LISP::%%COPY-TIME-STATS]
+              (DECLARE%: DONTCOPY (EXPORT (MACROS \UPDATETIMERS)
+                                                             (* ; "Locations in alto emulator")
+                                         (CONSTANTS (\RTCSECONDS 378)
+                                                (\RTCMILLISECONDS 380)
+                                                (\RTCBASE 382)
+                                                (\OFFSET.SECONDS 0)
+                                                (\OFFSET.MILLISECONDS 2)
+                                                (\OFFSET.BASE 4)
+                                                (\ALTO.RCLKSECOND 1680000)
+                                                (\ALTO.RCLKMILLISECOND 1680)
+                                                (\DLION.RCLKMILLISECOND 35)
+                                                (\DLION.RCLKSECOND 34746)
+                                                (\DOVE.RCLKMILLISECOND 63)
+                                                (\DOVE.RCLKSECOND 62500)))
+                     
+                     (* ;; "Locked stuff.  Have to lock anything used by pagefault code, including the ufns that they use until all microcodes have them")
+
+                     (ADDVARS (INEWCOMS (ALLOCAL (ADDVARS (LOCKEDFNS \CLOCK0 \GETINTERNALCLOCK 
+                                                                 \BOXIDIFFERENCE \BOXIPLUS \BLT 
+                                                                 \SLOWIQUOTIENT)
+                                                        (LOCKEDVARS \RCLKSECOND \RCLKMILLISECOND 
+                                                               \MISCSTATS]
+        [COMS                                                (* ; "basic date and time")
+              (FNS CLOCK DAYTIME ALTO.TO.LISP.DATE LISP.TO.ALTO.DATE)
+              (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (PROP MACRO ALTO.TO.LISP.DATE 
+                                                             LISP.TO.ALTO.DATE]
+        (COMS                                                (* ; "DURATION and TIMER things")
+              (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS TIMER.MAKESAFETIMER TIMER.TIMEREXPIRED? 
+                                                      EXPAND.SETUPTIMER)
+                                                             (* ; 
+               "Following macro needn't be installed since the function call is fairly slow anyway")
+                     (MACROS SETUPTIMER.DATE)
+                     (FNS \SETUPTIMERmacrofn)))
+        (COMS 
+              (* ;; "macros for dealing with timers")
+
+              (MACROS SETUPTIMER)
+              (MACROS \TIMER.TIMERP \TIMER.MAKETIMER \TIMER.PLUS \TIMER.DIFFERENCE \TIMER.IN.SECONDS
+                     \TIMER.IN.MILLISECONDS \TIMER.IN.TICKS)
+              (FNS \SETUPTIMERmacrofn \CanonicalizeTimerUnits)
+              (FNS SETUPTIMER SETUPTIMER.DATE TIMEREXPIRED? TIME.UNTIL)
+              (VARS (\TIMEREXPIRED.BOX (SETUPTIMER 0)))
+              (GLOBALVARS \TIMEREXPIRED.BOX \RCLKMILLISECOND \RCLKSECOND))
+        
+        (* ;; "Arrange for the proper compiler.")
+
+        (PROP FILETYPE LLTIMER)))
+
+
+
+(* ;;; "Lowest level Clock stuff")
+
+(DEFINEQ
+
+(\CLOCK0
+  [LAMBDA (BOX)                                              (* lmm "11-Sep-84 11:58")
+
+         (* Stores millisecond clock in BOX. Do this by fetching the current millisecond 
+       clock and adding in the number of milliseconds since the clock was last updated)
+
+    (SETQ BOX (\DTEST BOX 'FIXP))
+    (UNINTERRUPTABLY
+        (\GETINTERNALCLOCK \OFFSET.MILLISECONDS BOX)
+        [bind (EXCESS _ (LOCF (fetch EXCESSTIMETMP of \MISCSTATS)))
+           while (OR (IGREATERP EXCESS \RCLKSECOND)
+                         (ILESSP EXCESS 0)) do 
+
+         (* Excess time. unsigned, is more than a second, so clock has not been updated 
+       in ages (perhaps someone sat in Raid for a while)%.
+       We don't want IQUOTIENT here to do a CREATECELL, so do some of the division by 
+       subtraction. Instead of \RCLKSECOND, it would really be better to use 
+       \RCLKMILLISECOND*MAX.SMALL.INTEGER, but this is a rare case already, so be lazy)
+
+                                                  (\BOXIPLUS BOX 1000)
+                                                  (\BOXIDIFFERENCE EXCESS \RCLKSECOND)
+           finally                                       (* Now it is safe to use IQUOTIENT)
+                 (RETURN (\BOXIPLUS BOX (IQUOTIENT (COND
+                                                      ((IGREATERP EXCESS MAX.SMALL.INTEGER)
+                                                       EXCESS)
+                                                      (T (fetch (FIXP LONUM) of EXCESS)))
+                                               \RCLKMILLISECOND])])
+
+(\DAYTIME0
+  [LAMBDA (BOX)                                              (* bvm%: "24-JUN-82 15:39")
+    (UNINTERRUPTABLY
+        (\GETINTERNALCLOCK \OFFSET.SECONDS (\DTEST BOX 'FIXP)))])
+
+(\GETINTERNALCLOCK
+  [LAMBDA (CLOCKOFFSET BOX)                                  (* bvm%: "24-JUN-82 15:39")
+
+         (* Stores in BOX the contents of internal timer denoted by CLOCKOFFSET
+       (0 = SECONDS, 2 = MILLISECONDS)%. Excess time is in EXCESSTIMETEMP.
+       Must be called UNINTERRUPTABLY)
+
+    (\BLT (LOCF (fetch SECONDSTMP of \MISCSTATS))
+          (LOCF (fetch SECONDSCLOCK of \MISCSTATS))
+          (UNFOLD 3 WORDSPERCELL))                           (* Copy system clocks into scratch 
+                                                           area, so there is no update conflict)
+    (\BLT BOX (\ADDBASE (LOCF (fetch SECONDSTMP of \MISCSTATS))
+                     CLOCKOFFSET)
+          WORDSPERCELL)                                      (* Copy clock to caller)
+    (\BOXIDIFFERENCE (\RCLK (LOCF (fetch EXCESSTIMETMP of \MISCSTATS)))
+           (LOCF (fetch BASETMP of \MISCSTATS)))     (* Compute processor time since 
+                                                           clock was updated)
+    BOX])
+
+(\SETDAYTIME0
+  [LAMBDA (BOX)                                              (* bvm%: " 8-Jul-85 20:39")
+                                                             (* Sets the seconds calendar to 
+                                                           contents of BOX)
+    (SETQ BOX (\DTEST BOX 'FIXP))
+    (UNINTERRUPTABLY
+        (\RCLK (LOCF (fetch BASETMP of \MISCSTATS)))
+
+         (* Reset the base; clocks will not be adjusted for at least a second after this)
+
+        (\BLT (LOCF (fetch SECONDSTMP of \MISCSTATS))
+              BOX WORDSPERCELL)
+        [LET [(TMP (ITIMES 1000 (fetch (FIXP LONUM) of BOX]
+
+         (* Need to set msecs clock to 1000 * secs clock, but try not to do too much 
+       bignum arithmetic...)
+
+             (replace (FIXP LONUM) of (LOCF (fetch MILLISECONDSTMP of \MISCSTATS))
+                with (LOGAND TMP MAX.SMALLP))
+             (replace (FIXP HINUM) of (LOCF (fetch MILLISECONDSTMP of \MISCSTATS))
+                with (IPLUS16 (LRSH TMP BITSPERWORD)
+                                (LOGAND (ITIMES (fetch (FIXP HINUM) of BOX)
+                                               1000)
+                                       MAX.SMALLP]
+        (\BLT (LOCF (fetch SECONDSCLOCK of \MISCSTATS))
+              (LOCF (fetch SECONDSTMP of \MISCSTATS))
+              (UNFOLD 3 WORDSPERCELL))                       (* Finally store them all at once, 
+                                                           uninterruptably)
+        [COND
+           ((EQ \MACHINETYPE \DANDELION)                     (* Tell the iop the new time, too)
+            (repeatwhile (IGEQ (fetch DLPROCESSORCMD of \IOPAGE)
+                                   \DL.PROCESSORBUSY))
+            (replace DLPROCESSOR2 of \IOPAGE with (\GETBASE BOX 1))
+            (replace DLPROCESSOR1 of \IOPAGE with (\GETBASE BOX 0))
+            (replace DLPROCESSORCMD of \IOPAGE with \DL.SETTOD)
+            (replace DLTODVALID of \IOPAGE with 0)
+            (repeatwhile (IGEQ (fetch DLPROCESSORCMD of \IOPAGE)
+                                   \DL.PROCESSORBUSY))
+            (repeatwhile (EQ (fetch DLTODVALID of \IOPAGE)
+                                 0]
+        (\PROCESS.RESET.TIMERS))
+    BOX])
+
+(CLOCKDIFFERENCE
+  [LAMBDA (OLDCLOCK)                                         (* bvm%: "24-JUN-82 15:40")
+    (UNINTERRUPTABLY
+        (IPLUS (\BOXIDIFFERENCE (\CLOCK0 (LOCF (fetch CLOCKTEMP0 of \MISCSTATS)))
+                      OLDCLOCK)))])
+
+(\SECONDSCLOCKGREATERP
+  [LAMBDA (OLDCLOCK SECONDS)                                 (* bvm%: " 7-Dec-83 15:27")
+    (UNINTERRUPTABLY
+        (\BLT (LOCF (fetch CLOCKTEMP0 of \MISCSTATS))
+              (LOCF (fetch SECONDSCLOCK of \MISCSTATS))
+              WORDSPERCELL)
+        (IGREATERP (\BOXIDIFFERENCE (LOCF (fetch CLOCKTEMP0 of \MISCSTATS))
+                          OLDCLOCK)
+               SECONDS))])
+
+(\CLOCKGREATERP
+  [LAMBDA (OLDCLOCK MSECS)                                   (* bvm%: "17-Dec-83 16:38")
+
+         (* * True if more than MSECS milliseconds have elapsed since OLDCLOCK was set)
+
+    (UNINTERRUPTABLY
+        (IGREATERP (\BOXIDIFFERENCE (\CLOCK0 (LOCF (fetch CLOCKTEMP0 of \MISCSTATS)))
+                          OLDCLOCK)
+               MSECS))])
+
+(\RCLOCK0
+  [LAMBDA (BOX)                                              (* JonL "19-APR-83 01:47")
+    (\RCLK (\DTEST BOX 'FIXP])
+)
+(DEFINEQ
+
+(CLOCK0
+  [LAMBDA (BOX)                                              (* bvm%: " 1-APR-83 15:26")
+
+         (* Store millisecond clock at BOX. Unfortunately, there are still a few folks 
+       that call this without a true box, so accomodate them for now)
+
+    (COND
+       ((EQ (NTYPX BOX)
+            \FIXP)
+        (\CLOCK0 BOX))
+       (T (\MP.ERROR \MP.CLOCK0 "Call to CLOCK0 with arg not a number box.  ^N to continue." BOX)
+          (UNINTERRUPTABLY
+              (\BLT BOX (\CLOCK0 (LOCF (fetch CLOCKTEMP0 of \MISCSTATS)))
+                    WORDSPERCELL))
+          BOX])
+)
+
+(DEFOPTIMIZER \RCLOCK0 (BOX)
+                           `(\RCLK (\DTEST ,BOX 'FIXP)))
+
+(RPAQ? \RCLKMILLISECOND 1680)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \RCLKSECOND \RCLKMILLISECOND)
+)
+
+
+
+(* ;; "Maiko-specific elements")
+
+(DEFINEQ
+
+(\MAIKO.DAYTIME
+  [LAMBDA (BOX)                                              (* ; 
+                                                           "Edited  2-May-88 16:20 by MASINTER")
+    (SUBRCALL GETUNIXTIME 5 BOX])
+
+(\MAIKO.DAYTIME0
+  [LAMBDA (BOX)                                              (* ; 
+                                                           "Edited  2-May-88 16:20 by MASINTER")
+    (SUBRCALL GETUNIXTIME 4 BOX])
+
+(\MAIKO.CLOCK0
+  [LAMBDA (BOX)                                              (* ; 
+                                                           "Edited  2-May-88 16:19 by MASINTER")
+    (SUBRCALL GETUNIXTIME 0 BOX])
+
+(\MAIKO.CLOCK
+  [LAMBDA (N BOX)                                            (* ; 
+                                                           "Edited  2-May-88 16:11 by MASINTER")
+    (SUBRCALL GETUNIXTIME N BOX])
+
+(\MAIKO.COPY-TIME-STATS
+  [LAMBDA (REFERENCE-BLOCK DESTINIATION-BLOCK)               (* ; 
+                                                           "Edited  2-May-88 17:16 by MASINTER")
+    (SUBRCALL COPYTIMESTATS REFERENCE-BLOCK DESTINIATION-BLOCK])
+
+(\MAIKO.SETTIME
+  [LAMBDA (RETFLG)                                           (* ; 
+                                                           "Edited 13-May-88 15:22 by MASINTER")
+    (LISP:UNLESS (AND RETFLG (NOT (STRINGP RETFLG)))
+        (SETQ \TimeZoneComp (SUBRCALL GETUNIXTIME 8 NIL)))
+    (\PROCESS.RESET.TIMERS)
+    (DAYTIME])
+)
+
+
+
+(* ;; "The elements of \MAIKO.MOVDS get movd by \MAIKO.FAULTINIT")
+
+
+(ADDTOVAR \MAIKO.MOVDS (\MAIKO.DAYTIME DAYTIME)
+                           (\MAIKO.DAYTIME0 \DAYTIME0)
+                           (\MAIKO.CLOCK0 \CLOCK0)
+                           (\MAIKO.CLOCK0 CLOCK0)
+                           (\MAIKO.CLOCK CLOCK)
+                           (\MAIKO.SETTIME \NS.SETTIME)
+                           (\MAIKO.SETTIME \PUP.SETTIME)
+                           (\MAIKO.SETTIME SETTIME)
+                           (\MAIKO.COPY-TIME-STATS LISP::%%COPY-TIME-STATS))
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS \UPDATETIMERS MACRO [NIL 
+
+         (* * Moves excess time from the processor clock to our software clocks.
+       Needs to be run often, uninterruptably, preferably from the vertical retrace 
+       interrupt)
+                                                             (* Get processor clock)
+                                             (PROG [(EXCESS (\BOXIDIFFERENCE
+                                                             (\RCLK (LOCF (fetch RCLKTEMP0
+                                                                             of \MISCSTATS)))
+                                                             (LOCF (fetch BASECLOCK of 
+                                                                                           \MISCSTATS
+                                                                          ]
+                                                   (RETURN (COND
+                                                              ((OR (IGEQ EXCESS \RCLKSECOND)
+                                                                   (ILESSP EXCESS 0))
+                                                             (* More than one second has elapsed 
+                                                           since we updated clocks)
+                                                               (\BOXIPLUS (LOCF (fetch BASECLOCK
+                                                                                   of \MISCSTATS)
+                                                                                )
+                                                                      \RCLKSECOND)
+                                                             (* Increment base by one second)
+                                                               (\BOXIPLUS (LOCF (fetch 
+                                                                                    MILLISECONDSCLOCK
+                                                                                   of \MISCSTATS)
+                                                                                )
+                                                                      1000)
+                                                             (* Increment clocks by 1 second)
+                                                               (\BOXIPLUS (LOCF (fetch 
+                                                                                       SECONDSCLOCK
+                                                                                   of \MISCSTATS)
+                                                                                )
+                                                                      1)
+                                                               T])
+)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \RTCSECONDS 378)
+
+(RPAQQ \RTCMILLISECONDS 380)
+
+(RPAQQ \RTCBASE 382)
+
+(RPAQQ \OFFSET.SECONDS 0)
+
+(RPAQQ \OFFSET.MILLISECONDS 2)
+
+(RPAQQ \OFFSET.BASE 4)
+
+(RPAQQ \ALTO.RCLKSECOND 1680000)
+
+(RPAQQ \ALTO.RCLKMILLISECOND 1680)
+
+(RPAQQ \DLION.RCLKMILLISECOND 35)
+
+(RPAQQ \DLION.RCLKSECOND 34746)
+
+(RPAQQ \DOVE.RCLKMILLISECOND 63)
+
+(RPAQQ \DOVE.RCLKSECOND 62500)
+
+
+(CONSTANTS (\RTCSECONDS 378)
+       (\RTCMILLISECONDS 380)
+       (\RTCBASE 382)
+       (\OFFSET.SECONDS 0)
+       (\OFFSET.MILLISECONDS 2)
+       (\OFFSET.BASE 4)
+       (\ALTO.RCLKSECOND 1680000)
+       (\ALTO.RCLKMILLISECOND 1680)
+       (\DLION.RCLKMILLISECOND 35)
+       (\DLION.RCLKSECOND 34746)
+       (\DOVE.RCLKMILLISECOND 63)
+       (\DOVE.RCLKSECOND 62500))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+
+(ADDTOVAR INEWCOMS (ALLOCAL (ADDVARS (LOCKEDFNS \CLOCK0 \GETINTERNALCLOCK \BOXIDIFFERENCE 
+                                                \BOXIPLUS \BLT \SLOWIQUOTIENT)
+                                       (LOCKEDVARS \RCLKSECOND \RCLKMILLISECOND \MISCSTATS))))
+)
+
+
+
+(* ; "basic date and time")
+
+(DEFINEQ
+
+(CLOCK
+  [LAMBDA (N BOX)                                            (* lmm "15-OCT-82 11:44")
+    (SELECTQ (OR N 0)
+        (0                                                   (* time of day in MS)
+           [\CLOCK0 (COND
+                           ((type? FIXP BOX)
+                            BOX)
+                           (T (CREATECELL \FIXP])
+        (1                                                   (* time this VM was started)
+           (fetch STARTTIME of \MISCSTATS))
+        (2                                                   (* run time for this VM)
+           (\BOXIDIFFERENCE (\BOXIDIFFERENCE (\BOXIDIFFERENCE (\BOXIDIFFERENCE
+                                                               [\CLOCK0 (COND
+                                                                               ((type? FIXP BOX)
+                                                                                BOX)
+                                                                               (T (CREATECELL \FIXP]
+                                                               (LOCF (fetch SWAPWAITTIME
+                                                                        of \MISCSTATS)))
+                                                    (LOCF (fetch KEYBOARDWAITTIME of 
+                                                                                           \MISCSTATS
+                                                                 )))
+                                   (LOCF (fetch STARTTIME of \MISCSTATS)))
+                  (LOCF (fetch GCTIME of \MISCSTATS))))
+        (3                                                   (* GC TIME)
+           (fetch GCTIME of \MISCSTATS))
+        (\ILLEGAL.ARG N])
+
+(DAYTIME
+  [LAMBDA NIL                                              (* bvm%: " 8-Jul-85 20:01")
+    (ALTO.TO.LISP.DATE (\DAYTIME0 (CREATECELL \FIXP])
+
+(ALTO.TO.LISP.DATE
+  [LAMBDA (DATE)                                             (* bvm%: "18-FEB-81 00:35")
+
+         (* DATE is a 32-bit unsigned integer. To avoid signbit lossage, we subtract 
+       MIN.INTEGER from DATE, thereby making day 0 in the middle of the range.
+       Do this by toggling the high-order bit to avoid integer overflow.)
+
+    (LOGXOR DATE -2147483648])
+
+(LISP.TO.ALTO.DATE
+  [LAMBDA (DATE)                                             (* bvm%: "18-FEB-81 00:35")
+    (LOGXOR DATE -2147483648])
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")
+(PUTPROPS ALTO.TO.LISP.DATE MACRO ((DATE)
+                                           (LOGXOR DATE -2147483648)))
+
+(PUTPROPS LISP.TO.ALTO.DATE MACRO ((DATE)
+                                           (LOGXOR DATE -2147483648)))
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+
+
+
+(* ; "DURATION and TIMER things")
+
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS TIMER.MAKESAFETIMER DMACRO (OPENLAMBDA (TIMER BOX)
+                                                    (\PUTBASEFIXP BOX 0 TIMER)
+                                                    BOX))
+
+(PUTPROPS TIMER.TIMEREXPIRED? DMACRO ((OLDTIMER INTERVAL)
+                                              (UNINTERRUPTABLY
+                                                  (IGEQ (\BOXIDIFFERENCE OLDTIMER INTERVAL)
+                                                        0))))
+
+(PUTPROPS EXPAND.SETUPTIMER MACRO (L (\SETUPTIMERmacrofn L T)))
+)
+
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS SETUPTIMER.DATE MACRO ((DTS TIMER)
+                                         (SETUPTIMER (IDIFFERENCE (IDATE DTS)
+                                                                (IDATE))
+                                                TIMER
+                                                'SECONDS
+                                                'SECONDS)))
+)
+
+(DEFINEQ
+
+(\SETUPTIMERmacrofn
+  [LAMBDA (X NOERRORCHKS)                                    (* lmm "12-Apr-85 13:46")
+    (PROG ((INTERVALFORM (CAR X))
+           (TIMERFORM (CADR X))
+           (TimerUnits (CONSTANTEXPRESSIONP (CADDR X)))
+           (IntervalUnits (CONSTANTEXPRESSIONP (CADDDR X)))
+           (CLOCKFNNAME))
+          (if (OR (NULL TimerUnits)
+                      (NULL IntervalUnits))
+              then 
+
+         (* If either of the units are true computibles, then we can't select clock 
+       functions at macroexpansion time.)
+
+                    (RETURN 'IGNOREMACRO))
+          (SETQ TimerUnits (CANONICAL.TIMERUNITS (CAR TimerUnits)))
+          [SETQ IntervalUnits (if (NULL (CAR IntervalUnits))
+                                  then TimerUnits
+                                else (CANONICAL.TIMERUNITS (CAR IntervalUnits]
+
+         (* Notice how the following SELECTQ may also modify the code expression for the 
+       INTERVALFORM to do any necessary transformations between the specifiend timer 
+       units and the specified interval units.)
+
+          (SETQ CLOCKFNNAME (SELECTQ TimerUnits
+                                (TICKS (SELECTQ IntervalUnits
+                                           ((MILLISECONDS) 
+                                                (SETQ INTERVALFORM `(ITIMES %, INTERVALFORM 
+                                                                           \RCLKMILLISECOND)))
+                                           ((SECONDS) 
+                                                (SETQ INTERVALFORM `(ITIMES %, INTERVALFORM 
+                                                                           \RCLKSECOND)))
+                                           NIL)
+                                       '\TIMER.IN.TICKS)
+                                (MILLISECONDS (SELECTQ IntervalUnits
+                                                  (TICKS (SETQ INTERVALFORM
+                                                          `(IQUOTIENT %, INTERVALFORM 
+                                                                  \RCLKMILLISECOND)))
+                                                  (SECONDS (SETQ INTERVALFORM
+                                                            `(ITIMES %, INTERVALFORM 1000)))
+                                                  NIL)
+                                              '\TIMER.IN.MILLISECONDS)
+                                (SECONDS (SELECTQ IntervalUnits
+                                             (MILLISECONDS (SETQ INTERVALFORM
+                                                            `(IQUOTIENT %, INTERVALFORM 1000)))
+                                             (TICKS (SETQ INTERVALFORM `(IQUOTIENT %, INTERVALFORM 
+                                                                               \RCLKSECOND)))
+                                             NIL)
+                                         '\TIMER.IN.SECONDS)
+                                (SHOULDNT)))
+          [if (NOT NOERRORCHKS)
+              then (SETQ TIMERFORM
+                        (if (CONSTANTEXPRESSIONP TIMERFORM)
+                            then '(\TIMER.MAKETIMER)
+                          else (LET [(FORM '(COND
+                                                   ((\TIMER.TIMERP Timer?)
+                                                    Timer?)
+                                                   (T (\TIMER.MAKETIMER]
+                                        (if (NLISTP TIMERFORM)
+                                            then (SUBST TIMERFORM 'Timer? FORM)
+                                          else `([LAMBDA (Timer?)
+                                                       (DECLARE (LOCALVARS Timer?))
+                                                       %, FORM]
+                                                     %, TIMERFORM]
+          (RETURN `(\TIMER.PLUS (%, CLOCKFNNAME %, TIMERFORM)
+                          %, INTERVALFORM])
+)
+)
+
+
+
+(* ;; "macros for dealing with timers")
+
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS SETUPTIMER MACRO (X (\SETUPTIMERmacrofn X)))
+)
+(DECLARE%: EVAL@COMPILE 
+
+[PROGN (PUTPROPS \TIMER.TIMERP MACRO ((X)
+                                              (FIXP X)))
+       (PUTPROPS \TIMER.TIMERP DMACRO ((X)
+                                               (TYPENAMEP X 'FIXP)))]
+
+(PUTPROPS \TIMER.MAKETIMER DMACRO (NIL (NCREATE 'FIXP)))
+
+(PUTPROPS \TIMER.PLUS DMACRO ((OLDTIMER INTERVAL)
+                                      (\BOXIPLUS OLDTIMER INTERVAL)))
+
+(PUTPROPS \TIMER.DIFFERENCE DMACRO ((TIMER2 TIMER1)
+                                            (IDIFFERENCE TIMER2 TIMER1)))
+
+(PUTPROPS \TIMER.IN.SECONDS DMACRO ((OLDTIMER)
+                                            (\DAYTIME0 OLDTIMER)))
+
+(PUTPROPS \TIMER.IN.MILLISECONDS DMACRO ((OLDTIMER)
+                                                 (\CLOCK0 OLDTIMER)))
+
+(PUTPROPS \TIMER.IN.TICKS DMACRO ((OLDTIMER)
+                                          (\RCLOCK0 OLDTIMER)))
+)
+(DEFINEQ
+
+(\SETUPTIMERmacrofn
+  [LAMBDA (X NOERRORCHKS)                                    (* lmm "12-Apr-85 13:46")
+    (PROG ((INTERVALFORM (CAR X))
+           (TIMERFORM (CADR X))
+           (TimerUnits (CONSTANTEXPRESSIONP (CADDR X)))
+           (IntervalUnits (CONSTANTEXPRESSIONP (CADDDR X)))
+           (CLOCKFNNAME))
+          (if (OR (NULL TimerUnits)
+                      (NULL IntervalUnits))
+              then 
+
+         (* If either of the units are true computibles, then we can't select clock 
+       functions at macroexpansion time.)
+
+                    (RETURN 'IGNOREMACRO))
+          (SETQ TimerUnits (CANONICAL.TIMERUNITS (CAR TimerUnits)))
+          [SETQ IntervalUnits (if (NULL (CAR IntervalUnits))
+                                  then TimerUnits
+                                else (CANONICAL.TIMERUNITS (CAR IntervalUnits]
+
+         (* Notice how the following SELECTQ may also modify the code expression for the 
+       INTERVALFORM to do any necessary transformations between the specifiend timer 
+       units and the specified interval units.)
+
+          (SETQ CLOCKFNNAME (SELECTQ TimerUnits
+                                (TICKS (SELECTQ IntervalUnits
+                                           ((MILLISECONDS) 
+                                                (SETQ INTERVALFORM `(ITIMES %, INTERVALFORM 
+                                                                           \RCLKMILLISECOND)))
+                                           ((SECONDS) 
+                                                (SETQ INTERVALFORM `(ITIMES %, INTERVALFORM 
+                                                                           \RCLKSECOND)))
+                                           NIL)
+                                       '\TIMER.IN.TICKS)
+                                (MILLISECONDS (SELECTQ IntervalUnits
+                                                  (TICKS (SETQ INTERVALFORM
+                                                          `(IQUOTIENT %, INTERVALFORM 
+                                                                  \RCLKMILLISECOND)))
+                                                  (SECONDS (SETQ INTERVALFORM
+                                                            `(ITIMES %, INTERVALFORM 1000)))
+                                                  NIL)
+                                              '\TIMER.IN.MILLISECONDS)
+                                (SECONDS (SELECTQ IntervalUnits
+                                             (MILLISECONDS (SETQ INTERVALFORM
+                                                            `(IQUOTIENT %, INTERVALFORM 1000)))
+                                             (TICKS (SETQ INTERVALFORM `(IQUOTIENT %, INTERVALFORM 
+                                                                               \RCLKSECOND)))
+                                             NIL)
+                                         '\TIMER.IN.SECONDS)
+                                (SHOULDNT)))
+          [if (NOT NOERRORCHKS)
+              then (SETQ TIMERFORM
+                        (if (CONSTANTEXPRESSIONP TIMERFORM)
+                            then '(\TIMER.MAKETIMER)
+                          else (LET [(FORM '(COND
+                                                   ((\TIMER.TIMERP Timer?)
+                                                    Timer?)
+                                                   (T (\TIMER.MAKETIMER]
+                                        (if (NLISTP TIMERFORM)
+                                            then (SUBST TIMERFORM 'Timer? FORM)
+                                          else `([LAMBDA (Timer?)
+                                                       (DECLARE (LOCALVARS Timer?))
+                                                       %, FORM]
+                                                     %, TIMERFORM]
+          (RETURN `(\TIMER.PLUS (%, CLOCKFNNAME %, TIMERFORM)
+                          %, INTERVALFORM])
+
+(\CanonicalizeTimerUnits
+  [LAMBDA (X)                                                (* lmm "12-Apr-85 13:09")
+
+         (* Generally, the U-CASE versions have been "beat out" by the 
+       CANONICAL.TIMERUNITS.FOR.MISC macro; but there are ocasional calls to this 
+       function directly such, as in \DURATIONTRAN and the TIMEREXPIRED? macro.)
+
+    (PROG ((Y X)
+           CONVERTEDP)
+      A   (RETURN (SELECTQ Y
+                      (TICKS 'TICKS)
+                      ((NIL MILLISECONDS MS) 
+                           'MILLISECONDS)
+                      (SECONDS 'SECONDS)
+                      (if (NOT CONVERTEDP)
+                          then (SETQ Y (U-CASE Y))
+                                (SETQ CONVERTEDP T)
+                                (GO A)
+                        else (ERROR '|Invalid arg for timer units| X])
+)
+(DEFINEQ
+
+(SETUPTIMER
+  [LAMBDA (INTERVAL OldTimer? timerUnits intervalUnits)      (* lmm "12-Apr-85 13:19")
+    (SETQ INTERVAL (IPLUS INTERVAL 0))
+
+         (* If an error or coercion is to occur on this one, do it before the call to 
+       the clock-funciton)
+
+    (if (NOT (\TIMER.TIMERP OldTimer?))
+        then (SETQ OldTimer? (\TIMER.MAKETIMER)))
+    (SETQ timerUnits (CANONICAL.TIMERUNITS timerUnits))
+    (SETQ intervalUnits (if (NULL intervalUnits)
+                            then timerUnits
+                          else (CANONICAL.TIMERUNITS intervalUnits)))
+
+         (* Notice that in each wing of the SELECTQ below, the modification to INTERVAL 
+       is done before the clock-function call implicit in SETUPTIMER)
+
+    (SELECTQ timerUnits
+        ((TICKS) 
+             (SELECTQ intervalUnits
+                 ((MILLISECONDS) 
+                      (SETQ INTERVAL (ITIMES \RCLKMILLISECOND INTERVAL)))
+                 ((SECONDS) 
+                      (SETQ INTERVAL (ITIMES \RCLKSECOND INTERVAL)))
+                 NIL)
+             (EXPAND.SETUPTIMER INTERVAL OldTimer? 'TICKS))
+        ((MILLISECONDS) 
+             (SELECTQ intervalUnits
+                 ((TICKS) 
+                      (SETQ INTERVAL (IQUOTIENT INTERVAL \RCLKMILLISECOND)))
+                 ((SECONDS) 
+                      (SETQ INTERVAL (ITIMES 1000 INTERVAL)))
+                 NIL)
+             (EXPAND.SETUPTIMER INTERVAL OldTimer? 'MILLISECONDS))
+        ((SECONDS) 
+             (SELECTQ intervalUnits
+                 ((MILLISECONDS) 
+                      (SETQ INTERVAL (IQUOTIENT INTERVAL 1000)))
+                 ((TICKS) 
+                      (SETQ INTERVAL (IQUOTIENT INTERVAL \RCLKSECOND)))
+                 NIL)
+             (EXPAND.SETUPTIMER INTERVAL OldTimer? 'SECONDS))
+        (SHOULDNT])
+
+(SETUPTIMER.DATE
+  [LAMBDA (DTS OldTimer?)                                    (* Pavel " 6-Oct-86 21:46")
+    (SETUPTIMER (IDIFFERENCE (IDATE DTS)
+                           (IDATE))
+           OldTimer?
+           'SECONDS
+           'SECONDS])
+
+(TIMEREXPIRED?
+  [LAMBDA (TIMER ClockValue.or.timerUnits)                   (* lmm "12-Apr-85 13:19")
+    (COND
+       ((NOT (\TIMER.TIMERP TIMER))                          (* Do the check out here so that an 
+                                                           error won't happen underneath the 
+                                                           UNINTERRUPTABLY)
+        (LISPERROR "ILLEGAL ARG" TIMER))
+       ((\TIMER.TIMERP ClockValue.or.timerUnits)             (* Note that in Interlisp-D the 
+                                                           TIMER.TIMEREXPIRED? macro will 
+                                                           clobber its first arg.)
+        (TIMER.TIMEREXPIRED? (TIMER.MAKESAFETIMER ClockValue.or.timerUnits \TIMEREXPIRED.BOX)
+               TIMER))
+       (T 
+
+         (* Distribute thru the SELECTQ this way so that Interlisp-10 compiler can 
+       optimize out the boxing. Leave the UNINTERRUPTABLY so that Interlisp-D won't 
+       interrupt between putting the value in \TIMEREXPIRED.BOX and the IGEQ test.)
+
+          (SELECTQ (CANONICAL.TIMERUNITS ClockValue.or.timerUnits)
+              ((TICKS) 
+                   (TIMER.TIMEREXPIRED? (\TIMER.IN.TICKS \TIMEREXPIRED.BOX)
+                          TIMER))
+              ((MILLISECONDS) 
+                   (TIMER.TIMEREXPIRED? (\TIMER.IN.MILLISECONDS \TIMEREXPIRED.BOX)
+                          TIMER))
+              ((SECONDS) 
+                   (TIMER.TIMEREXPIRED? (\TIMER.IN.SECONDS \TIMEREXPIRED.BOX)
+                          TIMER))
+              NIL])
+
+(TIME.UNTIL
+  [LAMBDA (TIMER UNITS)                                      (* lmm "12-Apr-85 13:47")
+    (COND
+       ((NOT (\TIMER.TIMERP TIMER))                          (* Do the check out here so that an 
+                                                           error won't happen underneath the 
+                                                           UNINTERRUPTABLY)
+        (LISPERROR "ILLEGAL ARG" TIMER))
+       (T (SELECTQ (CANONICAL.TIMERUNITS UNITS)
+              (TICKS (\TIMER.DIFFERENCE TIMER (\TIMER.IN.TICKS \TIMEREXPIRED.BOX)))
+              (MILLISECONDS (\TIMER.DIFFERENCE TIMER (\TIMER.IN.MILLISECONDS \TIMEREXPIRED.BOX)))
+              (SECONDS (\TIMER.DIFFERENCE TIMER (\TIMER.IN.SECONDS \TIMEREXPIRED.BOX)))
+              (SHOULDNT])
+)
+
+(RPAQ \TIMEREXPIRED.BOX (SETUPTIMER 0))
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \TIMEREXPIRED.BOX \RCLKMILLISECOND \RCLKSECOND)
+)
+
+
+
+(* ;; "Arrange for the proper compiler.")
+
+
+(PUTPROPS LLTIMER FILETYPE :FAKE-COMPILE-FILE)
+(PUTPROPS LLTIMER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (4942 11567 (\CLOCK0 4952 . 6603) (\DAYTIME0 6605 . 6803) (\GETINTERNALCLOCK 6805 . 
+7914) (\SETDAYTIME0 7916 . 10330) (CLOCKDIFFERENCE 10332 . 10596) (\SECONDSCLOCKGREATERP 10598 . 11039
+) (\CLOCKGREATERP 11041 . 11427) (\RCLOCK0 11429 . 11565)) (11568 12194 (CLOCK0 11578 . 12192)) (12442
+ 13978 (\MAIKO.DAYTIME 12452 . 12677) (\MAIKO.DAYTIME0 12679 . 12905) (\MAIKO.CLOCK0 12907 . 13131) (
+\MAIKO.CLOCK 13133 . 13356) (\MAIKO.COPY-TIME-STATS 13358 . 13622) (\MAIKO.SETTIME 13624 . 13976)) (
+18634 21170 (CLOCK 18644 . 20450) (DAYTIME 20452 . 20619) (ALTO.TO.LISP.DATE 20621 . 21020) (
+LISP.TO.ALTO.DATE 21022 . 21168)) (22600 26644 (\SETUPTIMERmacrofn 22610 . 26642)) (27762 32682 (
+\SETUPTIMERmacrofn 27772 . 31804) (\CanonicalizeTimerUnits 31806 . 32680)) (32683 37205 (SETUPTIMER 
+32693 . 34535) (SETUPTIMER.DATE 34537 . 34794) (TIMEREXPIRED? 34796 . 36420) (TIME.UNTIL 36422 . 37203
+)))))
+STOP
diff --git a/CLTL2/LLTIMER.LCOM b/CLTL2/LLTIMER.LCOM
new file mode 100644
index 00000000..0fa3d536
Binary files /dev/null and b/CLTL2/LLTIMER.LCOM differ
diff --git a/CLTL2/LOADFNS b/CLTL2/LOADFNS
new file mode 100644
index 00000000..7599f5e7
--- /dev/null
+++ b/CLTL2/LOADFNS
@@ -0,0 +1,847 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "22-Sep-92 19:18:29" {DSK}<usr>local>lde>lispcore>sources>LOADFNS.;2 45703  
+
+      changes to%:  (FNS LOADCOMP LOADCOMP?)
+
+      previous date%: "16-May-90 20:14:50" {DSK}<usr>local>lde>lispcore>sources>LOADFNS.;1)
+
+
+(* ; "
+Copyright (c) 1983, 1984, 1986, 1987, 1989, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT LOADFNSCOMS)
+
+(RPAQQ LOADFNSCOMS ((FNS LOADFROM LOADBLOCK GETBLOCKDEC LOADCOMP LOADCOMP? LOADVARS LOADEFS LOADFILEMAP LOADFNS LOADFNS-FINDFILE LOADFNS-MAKELIST) (FNS LOADFNSCAN SCANFILE0 SCANCOMPILEDFN SCANDEFINEQ SCANEXP SCANDECLARE%: SCANFILE1 SCANFILE2 TMPSUBFN RETRYSCAN SCANFILEHELP) (VARS (NOT-FOUNDTAG (QUOTE NOT-FOUND%:))) (GLOBALVARS LASTWORD LOADOPTIONS SYSFILES NOT-FOUNDTAG) (LOCALVARS . T) (BLOCKS (SCANFILEBLOCK (ENTRIES LOADFNSCAN TMPSUBFN SCANFILE1) LOADFNSCAN SCANFILE0 SCANCOMPILEDFN SCANDEFINEQ SCANEXP SCANDECLARE%: SCANFILE1 SCANFILE2 TMPSUBFN (LOCALFREEVARS FNADRLST DICT DICT0 ADR) (SPECVARS VARLST) (RETFNS SCANFILE0)))))
+(DEFINEQ
+
+(LOADFROM
+  [LAMBDA (FILE FNS LDFLG)                                   (* wt%: "21-SEP-79 12:03")
+                                                             (* ; "'notices' file.")
+    (PROG1 (LOADFNS FNS FILE LDFLG 'LOADFROM)
+           (AND DWIMFLG FNS (SETQ LASTWORD (COND
+                                              ((ATOM FNS)
+                                               FNS)
+                                              (T (CAR (LAST FNS])
+
+(LOADBLOCK
+  [LAMBDA (FN FILE LDFLG)                                    (* bvm%: "27-Sep-86 15:17")
+    (PROG (TEM)
+          (OR FILE (SETQ FILE (LOADFNS-FINDFILE FN)))
+          (RETURN (AND [SETQ TEM (SUBSET (OR (GETBLOCKDEC FN FILE T)
+                                             (LIST FN))
+                                        (FUNCTION (LAMBDA (FN)
+                                                    (NOT (EXPRP (VIRGINFN FN]
+                       (LOADFNS TEM FILE LDFLG])
+
+(GETBLOCKDEC
+  [LAMBDA (FN FILE FNSONLY)                                  (* bvm%: " 7-Oct-86 18:23")
+          
+          (* ;; "Return the block declaration of FILE that contains FN.  If FNSONLY is true, returns just a list of the functions in the block.")
+
+    (OR FILE (SETQ FILE (LOADFNS-FINDFILE FN)))
+    (for BLOCK in (FILECOMSLST FILE 'BLOCKS) when (MEMB FN BLOCK)
+       do (RETURN (if (NULL FNSONLY)
+                      then BLOCK
+                    elseif (AND (CAR BLOCK)
+                                (SUBSET (CDR BLOCK)
+                                       (FUNCTION LITATOM)))
+                    else                                     (* ; 
+                                                "car of block decl is block name or NIL for no block")
+                         (LIST FN])
+
+(LOADCOMP
+(LAMBDA (FILE LDFLG) (* bvm%: "27-Sep-86 16:32") (RESETLST (LET ((FULLNAME (OR (FINDFILE FILE T) FILE)) BLOCKS ROOT) (DECLARE (SPECVARS BLOCKS)) (* ; "don't let block declarations get thru") (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (NAME VAL) (* ; "remove LOADCOMP prop if didn't finish successfully") (AND RESETSTATE (PUTPROP NAME (QUOTE LOADCOMP) VAL)))) (SETQ ROOT (COMSNAME FULLNAME)) (GETPROP ROOT (QUOTE LOADCOMP)))) (/PUTPROP ROOT (QUOTE LOADCOMP) FULLNAME) (* ; "Save FULLNAME for LOADCOMP?  Do this now rather than after the LOADFNS to avoid circularity if A loadcomp's B and B loadcomp's A.") (LOADFNS T FULLNAME LDFLG (QUOTE LOADCOMP)))))
+)
+
+(LOADCOMP?
+(LAMBDA (FILE LDFLG) (* ; "Edited 22-Sep-89 16:35 by bvm") (LET* ((FOUND (FINDFILE FILE T)) (FULLNAME (OR FOUND FILE)) (LOADED (GETPROP (COMSNAME FULLNAME) (QUOTE LOADCOMP)))) (if (OR (NULL LOADED) (AND FOUND (NOT (STRING-EQUAL LOADED FOUND)))) then (* ;; "Do the LOADCOMP if one's never been done, or the current version is not the one that was loadcomp'ed before.  If can't find a current version, assume the previously  loadcomp'ed one is ok.") (LOADCOMP FULLNAME LDFLG)) FULLNAME))
+)
+
+(LOADVARS
+  [LAMBDA (VARS FILE LDFLG)
+    (LOADFNS NIL FILE LDFLG VARS])
+
+(LOADEFS
+  [LAMBDA (FNS FILE)                                         (* wt%: " 9-APR-80 20:27")
+    (LOADFNS FNS FILE 'GETDEF])
+
+(LOADFILEMAP
+  [LAMBDA (FILE)                                             (* wt%: "16-MAY-79 22:05")
+          
+          (* ;; "user wants the full filemap.  scan file if necessary.  if updatemapflg=T and any changes are made, e.g. map does not exist on file, or is wrong (due to transferring from dorado to maxc), loadfns will rewrite the map")
+
+    (LOADFNS NIL FILE NIL 'FILEMAP])
+
+(LOADFNS
+  [LAMBDA (FNS FILE LDFLG VARS)                              (* bvm%: "17-Nov-86 23:28")
+
+(* ;;; "All of LOADVARS, LOADCOMP, LOADFILEMAP, LOADFROM come thru here.")
+
+    (DECLARE (SPECVARS FILE LDFLG VARS))                     (* ; "Used free by RETRYSCAN")
+    (RESETLST
+     (PROG ((*PACKAGE* *INTERLISP-PACKAGE*)
+            (DFNFLG DFNFLG)
+            (BUILDMAPFLG BUILDMAPFLG)
+            (FILEPKGFLG FILEPKGFLG)
+            (ADDSPELLFLG ADDSPELLFLG)
+            (LISPXHIST LISPXHIST)
+            (FILECREATEDLST)
+            (PRLST (AND FILEPKGFLG (FILEPKGCHANGES)))
+            INSTREAM FNLST VARLST DONELST ROOTNAME FILEMAP TEM FILEMAPEND FILECREATEDLOC FILENV 
+            RESETSAVER MAPUPDATED)
+           (DECLARE (SPECVARS *PACKAGE* DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FNLST 
+                           VARLST DONELST FILECREATEDLST FILECREATEDLOC))
+                                                             (* ; 
+                       "FILECREATEDLST is set by SCANEXP when it encounters a FILECREATED expression")
+       TOP (COND
+              ((OR (EQ LDFLG 'EXPRESSIONS)
+                   (EQ LDFLG 'GETDEF)
+                   (MEMB LDFLG LOADOPTIONS))
+               (SETQ DFNFLG LDFLG))
+              ((AND DWIMFLG (SETQ TEM (FIXSPELL LDFLG NIL LOADOPTIONS T)))
+               (SETQ LDFLG TEM)
+               (SETQ DFNFLG LDFLG))
+              (T (SETQ LDFLG (ERROR "unrecognized load option" LDFLG))
+                 (GO TOP)))
+           (COND
+              ((EQ LDFLG 'SYSLOAD)
+               (SETQ DFNFLG T)
+               (SETQ ADDSPELLFLG NIL)
+               (SETQ BUILDMAPFLG NIL)
+               (SETQ FILEPKGFLG NIL)
+               (SETQ LISPXHIST NIL)))
+           [AND LISPXHIST (COND
+                             ((SETQ TEM (FMEMB 'SIDE LISPXHIST))
+                              (FRPLACA (CADR TEM)
+                                     -1))
+                             (T (LISPXPUT 'SIDE (LIST -1)
+                                       NIL LISPXHIST]        (* ; 
+                    "So that UNDOSAVE will keep saving regardless of how many undosaves are involved")
+           (SETQ FNLST (LOADFNS-MAKELIST FNS T))             (* ; "Get list of functions")
+           [COND
+              ((NULL FILE)                                   (* ; 
+                                                  "Infer what file caller meant (this is a feature!)")
+               (SETQ FILE (LOADFNS-FINDFILE (CAR FNLST]
+       RETRY
+           [RESETSAVE NIL (SETQ RESETSAVER (LIST 'CLOSEF? (SETQ INSTREAM (OPENSTREAM FILE
+                                                                                'INPUT]
+                                                             (* ; 
+                                  "CLOSEF?  not CLOSEF because UPDATEFILEMAP might close file for us")
+           (RESETSAVE (INPUT INSTREAM))
+           (SETQ FILE (FULLNAME INSTREAM))                   (* ; 
+  "Gets full file name.  Also note that there may have been some error correction done in OPENSTREAM")
+           (COND
+              ((NOT (RANDACCESSP INSTREAM))
+               (SETQ FILE (ERROR FILE "not a random access file"))
+               (GO RETRY)))
+           (SETFILEPTR INSTREAM 0)
+           (SETQ ROOTNAME (ROOTFILENAME FILE))
+           (CL:MULTIPLE-VALUE-SETQ (FILENV FILEMAP FILECREATEDLOC FILECREATEDLST)
+                  (GET-ENVIRONMENT-AND-FILEMAP INSTREAM))
+           (SETQ VARLST (SELECTQ VARS
+                            (NIL NIL)
+                            (VARS                            (* ; 
+                                                         "Means load, i.e., evaluate, ALL rpaq/rpaqq")
+                                  'VARS)
+                            (FNS/VARS (LIST (FILECOMS ROOTNAME 'COMS)
+                                            (FILECOMS ROOTNAME 'BLOCKS)))
+                            (LOADCOMP                        (* ; 
+                                     "evaluate the EVAL@COMPILE expresions, notice the fns and vars.")
+                                      (SETQ FNLST T)
+                                      VARS)
+                            (FILEMAP                         (* ; 
+                                          "Return the filemap, or build one if not already available")
+                                     (if (AND FILEMAP (NULL (CAR FILEMAP)))
+                                         then (RETURN FILEMAP)
+                                       elseif (NULL BUILDMAPFLG)
+                                         then (RETURN NIL))
+                                     'FILEMAP)
+                            (LOADFROM 
+          
+          (* ;; "evaluate all non-defineq expressions, but just return file name as value, i.e.  dont bother adding to donelst")
+
+                                      'LOADFROM)
+                            (DONTCOPY                        (* ; 
+                                                       "means load all DECLARE: DONTCOPY expressions")
+                                      VARS)
+                            (LOADFNS-MAKELIST VARS)))
+           (SETQ FILEMAPEND (if FILEMAP
+                                then (CAR FILEMAP)
+                              else T))                       (* ; 
+                                                      "Remember how far the filemap scan got already")
+           [WITH-READER-ENVIRONMENT
+            FILENV
+            (SETQ FILEMAP (LOADFNSCAN FILEMAP))
+
+(* ;;; "SCANFILE0 returns a 'map' for the file.  The form of the map is (ADR ADRLST ADRLST ...) where ADR is last address scanned to in file, or NIL if entire file was scanned, or (ADR) where the scan stopped after a function in the middle of a DEFINEQ.  Each ADRLST is either of the form (ADR1 ADR2 . FN) or (ADR1 ADR2 (FN ADRX . ADRY) (FN ADRX . ADRY) ...).
+
+The first case corresponds to a compiled function, the second to a DEFINEQ.  In the first case, ADR1 is the address of the first character AFTER the function name in the file (for use by LAPRD) and ADR2 the address of the first character after the de definition, i.e., after LAPRD or LCSKIP has finished.
+
+In the second case, ADR1 is the address of the lef paren before the DEFINEQ, and ADR2 either the address of the first character after the entire DEFINEQ expression, or the address of the first chracter after the last function that was scanned.  In (FN ADRX . ADRY), ADR is the address of of the left parentheses before the function name, ADRY the address of the character after the right paren that closes the definition.  
+
+A map of non-functions is not kept because (a) it would not be of use to MAKEFILE since it always recomputes VARS, and (B) most requests for other than functions require scanning the entire file anyway, e.g. to find all RPAQQ's, and (C) the expressions are usually small compared to DEFINEQ's.")
+
+            [if FILEMAP
+                then
+                (if (NEQ FILEMAPEND (CAR FILEMAP))
+                    then                                     (* ; "something was added")
+                         (PUTFILEMAP FILE FILEMAP FILECREATEDLST)
+                         (if (AND UPDATEMAPFLG (UPDATEFILEMAP INSTREAM FILEMAP))
+                             then (SETQ MAPUPDATED T)))
+                (if (AND DWIMFLG (NOT NOSPELLFLG)
+                         (LISTP FNLST))
+                    then                                     (* ; 
+                                                       "There are still FNS left that we didn't find")
+                    (if (SETQ TEM
+                         (for X on FNLST
+                            bind [KNOWNFNS _ (for TRIPLE in (CDR FILEMAP)
+                                                join         (* ; 
+                                   "makes a list of functions found for use for spelling correction.")
+                                                     (if (LISTP (SETQ TEM (CDDR TRIPLE)))
+                                                         then 
+                                                             (* ; 
+                            "This is for normal source files, where TRIPLE = (start end . fnEntries)")
+                                                              (MAPCAR TEM (FUNCTION CAR))
+                                                       elseif TEM
+                                                         then 
+                                                             (* ; 
+                                                      "For compiled files, TRIPLE = (start end . fn)")
+                                                              (LIST TEM]
+                            when (AND (NOT (FMEMB (CAR X)
+                                                  KNOWNFNS))
+                                      (FIXSPELL (CAR X)
+                                             70 KNOWNFNS NIL X)) collect 
+          
+          (* ;; "The FMEMB check is necessary for when VARS=DEFS, as the reason that the function was not removed from FNLST may have been because this was a compiled file.")
+
+                                                                       (CAR X)))
+                        then (if MAPUPDATED
+                                 then                        (* ; "UPDATEFILEMAP had closed the file")
+                                      [RPLACA (CDR RESETSAVER)
+                                             (SETQ INSTREAM (OPENSTREAM FILE 'INPUT]
+                                      (INPUT INSTREAM))
+                             (SCANFILE1 FILEMAP TEM]
+            (if (AND NOT-FOUNDTAG (LISTP FNLST))
+                then (SETQ DONELST (CONS (CONS NOT-FOUNDTAG FNLST)
+                                         DONELST)))
+            (if
+             [AND
+              NOT-FOUNDTAG
+              (LISTP VARLST)
+              (SETQ TEM
+               (if (FNTYP VARLST)
+                   then (AND (NULL DONELST)
+                             (LIST VARLST))
+                 else (for X in VARLST collect X
+                         unless (PROGN 
+          
+          (* ;; "Reason for this is if user says LOADVARS (DEFLIST file), then DEFLIST is not removed from VARLST, since you want all such instances.")
+
+                                       (for Y in DONELST
+                                          thereis (if (ATOM X)
+                                                      then (OR (EQ X (CAR Y))
+                                                               (EQ X (CADR Y)))
+                                                    else (EDIT4E X Y]
+                then (SETQ DONELST (CONS (CONS NOT-FOUNDTAG TEM)
+                                         DONELST)))
+            (if (EQ LDFLG 'SYSLOAD)
+                then (AND (NOT (MEMB (SETQ ROOTNAME (ROOTFILENAME FILE (CDR FILECREATEDLST)))
+                                     SYSFILES))
+                          (SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME)))
+                     (SMASHFILECOMS ROOTNAME)
+              elseif FILEPKGFLG
+                then (AND (NEQ VARS 'FILEMAP)
+                          (NEQ LDFLG 'EXPRESSIONS)
+                          (NEQ LDFLG 'GETDEF)
+                          (ADDFILE FILE (SELECTQ VARS
+                                            ((T LOADFROM) 
+                                                 'LOADFNS)
+                                            (LOADCOMP 'LOADCOMP)
+                                            'loadfns)
+                                 PRLST FILECREATEDLST]
+           (RETURN (if (EQ VARS 'FILEMAP)
+                       then FILEMAP
+                     elseif (EQ VARS 'LOADFROM)
+                       then FILE
+                     else (DREVERSE DONELST])
+
+(LOADFNS-FINDFILE
+  [LAMBDA (FN)                                               (* bvm%: "27-Sep-86 15:03")
+          
+          (* ;; "When LOADFNS is not given a file to load from, figure out using WHEREIS")
+
+    (LET ((DWIMFLG T)
+          (FILEPKGFLG T))
+         (DECLARE (SPECVARS DWIMFLG FILEPKGFLG))
+         (OR (EDITLOADFNS? FN)
+             (AND (EQ (NARGS 'WHEREIS)
+                      4)
+                  (EDITLOADFNS? FN NIL NIL T))
+             (ERROR FN '"'s file not found" T])
+
+(LOADFNS-MAKELIST
+  [LAMBDA (LST FNSFLG)                                       (* bvm%: " 2-Oct-86 15:40")
+          
+          (* ;; "Turn FNS or VARS arg to LOADFNS into an actual list of functions/variables to load, or T to load all.")
+
+    (if (EQ LST T)
+        then                                                 (* ; 
+                                                     "Eleanor's option, load every fn found in FILE.")
+             T
+      elseif (NULL LST)
+        then NIL
+      elseif (LITATOM LST)
+        then (LIST LST)
+      elseif (NLISTP LST)
+        then (ERROR '"illegal arg" LST)
+      elseif (NULL FNSFLG)
+        then                                                 (* ; 
+                                               "VARS arg is a list of patterns, so canonicalize them")
+             (for Y in LST collect (EDITFPAT Y))
+      else (for F in LST when (if (LITATOM F)
+                                  then T
+                                else (LISPXPRIN1 '" isn't a function name -- ignored.
+")
+                                     NIL) collect F])
+)
+(DEFINEQ
+
+(LOADFNSCAN
+  [LAMBDA (DICT)                                             (* wt%: " 7-DEC-79 11:57")
+    (PROG (ADR)
+          (SCANFILE0)
+          (RETURN DICT])
+
+(SCANFILE0
+  [LAMBDA NIL                                                (* bvm%: "29-Aug-86 23:15")
+    (PROG (NXT NXT1 NXT2 FNADRLST (DICT0 (CDR DICT)))
+          [COND
+             [(NULL DICT)
+              (AND BUILDMAPFLG (SETQ DICT (LIST 0]
+             (FNLST                                          (* ; 
+                                         "Have some filemap, so go get functions that are on the map")
+                    (SCANFILE1 (CDR DICT]
+          (COND
+             ([AND (NULL VARLST)
+                   (OR (NULL FNLST)
+                       (AND DICT (NULL (CAR DICT]
+          
+          (* ;; "Either all functions were found, or else the entire file having been scaaned, no point in scanning further")
+
+              (RETURN DICT)))
+          (COND
+             ((AND VARLST (NEQ VARLST 'FILEMAP))
+          
+          (* ;; "Note that at this point there may or may not be some functions to be scanned for.  in any event, since there are VARS to be obtained, we have to start scanning at the beginning, although DICT can be of use to save scanning of DEFINEQ's.")
+
+              (SETFILEPTR NIL (OR FILECREATEDLOC 0)))
+             ((LISTP (CAR DICT))                             (* ; 
+                                                       "The scan stopped in the middle of a DEFINEQ.")
+              (SETFILEPTR NIL (SETQ ADR (CAAR DICT)))
+              [AND BUILDMAPFLG (SETQ FNADRLST (LCONC NIL (CAR (LAST DICT]
+              (SETQ DICT0 NIL)
+              (SCANDEFINEQ T))
+             (DICT                                           (* ; 
+                                                            "Scan stopped after a compiled function.")
+                   (SETFILEPTR NIL (CAR DICT))
+                   (SETQ DICT0 NIL)))
+      PEEKLP
+          (SETQ NXT1 (SKIPSEPRCODES))
+          (COND
+             [(OR (SYNTAXP NXT1 'LEFTPAREN)
+                  (SYNTAXP NXT1 'LEFTBRACKET))               (* ; "Opening paren and bracket.")
+              (SETQ ADR (GETFILEPTR))
+              (READC)                                        (* ; "Flush the peeked-at paren.")
+              (SETQ NXT1 (RATOM))
+              (COND
+                 ((EQ NXT1 'DEFINEQ)
+                  (SCANDEFINEQ))
+                 (T                                          (* ; 
+  "some functions may be inside of declare:'s so have to look at each expression, even if varlst=NIL")
+                    (SETQ NXT2 (RATOM))                      (* ; 
+                                                "Corresponds to CADR of the expression.  in the file")
+                    (SETFILEPTR NIL ADR)                     (* ; 
+                                            "file pointer now points to just before the expression..")
+                    (SCANEXP NXT1 NXT2 (NEQ VARLST 'LOADCOMP]
+             ((OR (EQ (SETQ NXT (READ))
+                      'STOP)
+                  (NULL NXT))                                (* ; "End of file.")
+              (AND (CAR DICT)
+                   (RPLACA DICT NIL))                        (* ; 
+                                                             "says scan of entire map now complete")
+              (RETURN))
+             ((LITATOM NXT)
+              (SETQ ADR (GETFILEPTR))
+              (SCANCOMPILEDFN NXT)))
+          (GO PEEKLP])
+
+(SCANCOMPILEDFN
+  [LAMBDA (FNAME)                                            (* wt%: " 9-APR-80 20:54")
+    (PROG NIL
+          [COND
+             (DICT0 (AND (NOT (EQP (CAAR DICT0)
+                                   ADR))
+                         [NOT (SETQ DICT0 (SOME DICT0 (FUNCTION (LAMBDA (X)
+                                                                  (IEQP ADR (CAR X]
+                         (RETRYSCAN))
+          
+          (* ;; "redudnacy check the SOME is bcause of the (admittedly obsucre but actually happened) case where there are DEFINEQ's inside of a DECLARE:..  in this case, they would appear on the filemap, but DICT0 would not have been stepped because the DEFINIEQ's would not have been seen in the scan.")
+
+                    (SETFILEPTR NIL (CADAR DICT0))
+          
+          (* ;; "We know this function is not of interest, or it ould have been picked up in SCANFILE1.  Furthermore, we know its final address, so no need to LCSKIP")
+
+                    (SETQ DICT0 (CDR DICT0))
+                    (RETURN T))
+             (BUILDMAPFLG (NCONC1 DICT (SETQ FNADRLST (CONS (GETFILEPTR)
+                                                            (CONS NIL FNAME]
+          [COND
+             [[AND FNLST (NEQ LDFLG 'EXPRESSIONS)
+                   (NEQ LDFLG 'GETDEF)
+                   (NEQ VARS 'LOADCOMP)
+                   (OR (EQ FNLST T)
+                       (MEMB FNAME FNLST)
+                       (SOME FNLST (FUNCTION (LAMBDA (X)
+                                               (TMPSUBFN FNAME X]
+          
+          (* ;; "We want FNAME if it is on FNLST, or a SUBFN of anything on FNLST.  or if FNLST, is T, i.e. load everything.")
+
+              (LAPRD FNAME)
+              (SETQ DONELST (CONS FNAME DONELST))
+              [AND FNADRLST (RPLACA (CDR FNADRLST)
+                                   (SETQ ADR (GETFILEPTR]
+              (COND
+                 ((AND (NEQ FNLST T)
+                       (NULL (SETQ FNLST (DREMOVE FNAME FNLST)))
+                       (NULL VARLST))
+                  (AND DICT (RPLACA DICT ADR))
+                  (RETFROM 'SCANFILE0]
+             (T (LCSKIP FNAME)
+                (AND FNADRLST (RPLACA (CDR FNADRLST)
+                                     (GETFILEPTR]
+          (RETURN T])
+
+(SCANDEFINEQ
+  [LAMBDA (CONTINUEFLG)                                      (* bvm%: " 7-Oct-86 18:07")
+          
+          (* ;; "Called with file pointer just after atom DEFINEQ.  DICT0, if non-NIL, is the tail of DICT that corresponds to how far we've gotten. I.e., (CAR DICT0) should represent this DEFINEQ.")
+
+    (PROG (FNAME)
+          (COND
+             (CONTINUEFLG (GO DEFQLP))
+             ([AND DICT0 (NOT (IEQP (CAAR DICT0)
+                                    ADR))
+                   (NOT (SETQ DICT0 (find TAIL on DICT0 suchthat (IEQP ADR (CAAR TAIL]
+              (RETRYSCAN)))
+          
+          (* ;; "Double check.  the SOME is because of the (admittedly obscure but it happens) case where there are DEFINEQ's inside of a DECLARE:..  in this case, they would appear on the filemap, but DICT0 would not have been stepped because the DEFINEQ's would not have been seen in the scan.  Now we know that CAR of DICT0 corrresponds to this DEFINEQ.  We process DEFINEQ's the same when there are functions to be found, i.e. when FNLST is non-NIL, as when there aren't any, on the grounds that it takes about as long to do many little SKREAD's as one big SKREAD, and this way we also get to build the map.")
+
+          [COND
+             ((CADAR DICT0)
+          
+          (* ;; "This entire DEFINEQ was scanned, and ADR is the address of the first character after it.  Move file pointer and go on, i.e. dont have to do SKREAD.  Note that this applies even if we are looking for functions, i.e. FNLST not NIL, because in this case all functions of interest would have been picked up by SCANFILE1.")
+
+              (SETFILEPTR NIL (CADAR DICT0))
+              (SETQ DICT0 (CDR DICT0))
+              (RETURN T))
+             (DICT0 
+          
+          (* ;; "The scan previously stopped in the middle of a DEFINEQ.  The address of the end of the scan, i.e. (CAAR DICT), corresponds to the character after the last function scanned.")
+
+                    [SETFILEPTR NIL (COND
+                                       ((LISTP (CAR DICT))
+                                        (CAAR DICT))
+                                       (T 
+          
+          (* ;; "Another redudancy check.  If the entire DEFINEQ had been processed, then CADAR of DICT0 would be non-NIL, and caught above.  Therefore, processing stopped in the middle of the DEFINEQ, and CAR of DICT should be a list.")
+
+                                          (RETRYSCAN]
+                    [AND BUILDMAPFLG (SETQ FNADRLST (LCONC NIL (CAR DICT0]
+                    (SETQ DICT0 NIL))
+             (BUILDMAPFLG (SETQ FNADRLST (TCONC NIL ADR))
+                    (TCONC FNADRLST NIL)
+                    (NCONC1 DICT (CAR FNADRLST]
+      DEFQLP
+          (SELECTQ (RATOM)
+              (%)                                            (* ; "Closes DEFINEQ.")
+                  (AND FNADRLST (RPLACA (CDAR FNADRLST)
+                                       (GETFILEPTR)))        (* ; 
+                            "FNADRLST is a ONC format list, hence want to RPLACA CDAR, not just CDR.")
+                  (RETURN T))
+              (%] (SCANFILEHELP))
+              ((%( %[) 
+                   (SETQ ADR (SUB1 (GETFILEPTR)))            (* ; 
+                                                     "The address of the position of the left paren.")
+                   (SETQ FNAME (READ))
+                   (AND FNADRLST (TCONC FNADRLST (LIST FNAME ADR))))
+              (SCANFILEHELP))
+          (SETFILEPTR NIL ADR)
+          
+          (* ;; "Positions file pointer at left paren or bracket so if fn/def pair is closed by either right paren or bracket, read or skread will do the right thing.")
+
+          (COND
+             [(AND FNLST (OR (EQ FNLST T)
+                             (MEMB FNAME FNLST)))
+              (SELECTQ VARS
+                  (LOADCOMP (AND (NOT (FMEMB FNAME NOFIXFNSLST))
+                                 (SETQ NOFIXFNSLST (CONS FNAME NOFIXFNSLST)))
+                            (SKREAD))
+                  (SETQ DONELST (NCONC [COND
+                                          ((OR (EQ LDFLG 'EXPRESSIONS)
+                                               (EQ LDFLG 'GETDEF))
+                                           (LIST (READ)))
+                                          (T (DEFINE (LIST (READ]
+                                       DONELST)))
+              (AND (NEQ FNLST T)
+                   (SETQ FNLST (DREMOVE FNAME FNLST]
+             (T (SKREAD)))
+          (AND FNADRLST (RPLACD (CDADR FNADRLST)
+                               (GETFILEPTR)))
+          
+          (* ;; "FNADRLST is a TCONC format, so its CADR is its last element.  This is supposed to be of the form (FN ADRX  . ADRY).  This adds the ADRY.")
+
+          [COND
+             ((AND (NULL FNLST)
+                   (NULL VARLST))
+          
+          (* ;; "Actually this check only need be made in the case that a function was actually read, i.e. second clause in above COND, but it's cheap enough.")
+
+              [AND DICT (RPLACA DICT (LIST (ADD1 (GETFILEPTR](* ; 
+                                                             "says scan stopped in middle of defineq")
+              (RETFROM 'SCANFILE0]
+          (GO DEFQLP])
+
+(SCANEXP
+  [LAMBDA (EXP1 EXP2 EVALFLG)                                (* bvm%: "27-Sep-86 15:28")
+          
+          (* ;; "exp1 is car of the expression, exp2 cadr.  file pointer is just before opening left paren and scanexp reads expression if it needs to.")
+
+    (DECLARE (USEDFREE FILECREATEDLST))
+    (PROG (EXP)
+          (COND
+             ((EQ VARLST 'COMPILING)                         (* ; "wants whole declare:")
+              (GO YES))
+             ((EQ EXP1 'DECLARE%:)
+              (COND
+                 (EXP (SETFILEPTR NIL ADR)))                 (* ; 
+                                                             "SKIP OVER THE PAREN AND THE DECLARE:")
+              (RATOM)
+              (RATOM)
+              (if (EQ VARLST 'DONTCOPY)
+                  then (SCANDECLARE%: NIL T)
+                else (SCANDECLARE%: EVALFLG))
+              (RETURN T)))
+          (SELECTQ VARLST
+              ((T LOADFROM) 
+                   (AND EVALFLG (GO YES)))
+              (VARS [AND EVALFLG (COND
+                                    ((OR (EQ EXP1 'RPAQQ)
+                                         (EQ EXP1 'RPAQ)
+                                         (EQ EXP1 'RPAQ?))
+                                     (GO YES])
+              (LOADCOMP (AND EVALFLG (GO YES))
+                        (SELECTQ EXP1
+                            ((RPAQQ RPAQ RPAQ?) 
+                                 (SETQ NOFIXVARSLST (AND (NOT (FMEMB EXP2 NOFIXVARSLST))
+                                                         (CONS EXP2 NOFIXVARSLST))))
+                            NIL))
+              (AND (LISTP VARLST)
+                   [COND
+                      ((FNTYP VARLST)
+                       (COND
+                          ((NULL (SETQ EXP (APPLY* VARLST EXP1 EXP2)))
+                                                             (* ; 
+                                               "the functional expression is ree to move filepinter.")
+                           (SETFILEPTR NIL ADR)
+                           NIL)
+                          ((NLISTP EXP)                      (* ; 
+                                          "matched, but user elected not to return entire expression")
+                           (SETFILEPTR NIL ADR)
+                           (SETQ EXP (READ)))
+                          (T T)))
+                      (T (SOME VARLST (FUNCTION (LAMBDA (X)
+                                                  (COND
+                                                     ((OR (EQ EXP1 X)
+                                                          (EQ EXP2 X)))
+                                                     ((LISTP X)
+                                                             (* ; "edit pattern")
+                                                      [COND
+                                                         ((NULL EXP)
+          
+          (* ;; "The expression on VARLST is a list, which is interpreted as an edit pattern; therefore we have to read the entire expression from the file.  Note that this is only done once, i.e., if there are several patterns on VARLST, the expression from the file is read only once.")
+
+                                                          (SETQ EXP (READ]
+                                                      (EDIT4E X EXP]
+                   (GO YES)))
+          (COND
+             ((EQ EXP1 'FILECREATED)
+              [SETQ FILECREATEDLST (NCONC1 FILECREATEDLST (CDR (OR EXP (SETQ EXP (READ]
+                                                             (* ; 
+                                 "So that ADDFILE will have necessary information when it is called.")
+              (FILECREATED1 (CDR EXP))                       (* ; 
+                                                      "does error checking on filecreated expression")
+              )
+             ((NULL EXP)
+              (SKREAD)))
+          (RETURN T)
+      YES                                                    (* ; 
+                                                "This IS one of the expressions specified by VARLST.")
+          [COND
+             ((NULL EXP)
+          
+          (* ;; "If EXP is non-null, means for some reason it had to be READ, e.g., there was an edit pattern in VARLST.  In this case not necessary to SKREAD since we have already passed over that expression.")
+
+              (SETQ EXP (READ]
+          [COND
+             ((AND (NEQ VARLST 'LOADFROM)
+                   (NEQ VARLST 'LOADCOMP))
+              (SETQ DONELST (CONS EXP DONELST]
+          (COND
+             ((AND (NEQ LDFLG 'EXPRESSIONS)
+                   (NEQ LDFLG 'GETDEF))
+              (EVAL EXP)))
+          (RETURN T])
+
+(SCANDECLARE%:
+  [LAMBDA (EVALFLG DONTCOPIES)                               (* bvm%: "30-Aug-86 16:06")
+          
+          (* ;; "handles DECLARE:'s only called for either VARS=COMP, or for looking for specific expression or expresions, e.g. VARS, or edit pattern.  For EXPRESSIONS, T, etc., higher call to SCANEXP has already decided what to do.")
+
+    (PROG ((VARLST (if DONTCOPIES
+                       then T
+                     else VARLST))
+           TEM)
+      LP  (SETQ ADR (GETFILEPTR))
+          [SELECTQ (SETQ TEM (RATOM))
+              ((%( %[) 
+                   (SETQ ADR (SUB1 (GETFILEPTR)))
+          
+          (* ;; "reason for this is that there may have been some separators before the (, e.g. a space and c.r., and in this case the ADR will not match up with what was stored in the file map, which would be the position just before the (.  The right way to do this is of course not to RATOM but to do a loop with peekc until you ee a non-separator and then record the address.  however, thi is inefficient and unnecessary since this is the nly case where it matters")
+
+                   (SELECTQ (SETQ TEM (RATOM))
+                       (DEFINEQ (PROG ((ADR ADR))
+                                      (SCANDEFINEQ)
+          
+          (* ;; "easier to call scandefineq even if FNS is NIL because it knows how to position file pointer without aving to call skread by using filemap")
+
+                                  )
+                                [COND
+                                   ((AND EVALFLG (EQ VARLST 'LOADCOMP)
+                                         (EQ FNLST T))
+          
+          (* ;; "LOADCOMP is handled specially.  the SCANDEFINEQ would not have actually done any defining, just scanned for the purposes of constructing the map.")
+
+                                    (SETFILEPTR NIL ADR)
+                                    (SETQ TEM (READ))
+                                    (COND
+                                       ((OR (EQ LDFLG 'EXPRESSIONS)
+                                            (EQ LDFLG 'GETDEF))
+                                        (SETQ DONELST (CONS TEM DONELST)))
+                                       (T (EVAL TEM])
+                       (DECLARE%: (SCANDECLARE%: EVALFLG DONTCOPIES))
+                       (SCANEXP TEM (PROG1 (RATOM)
+                                           (SETFILEPTR NIL ADR))
+                              EVALFLG)))
+              ((%) %]) 
+                   (RETURN T))
+              (COND
+                 (DONTCOPIES (SELECTQ TEM
+                                 (DONTCOPY (SETQ EVALFLG T))
+                                 ((EVAL@COMPILEWHEN) 
+                                      (SKREAD))
+                                 (COPYWHEN (SKREAD)
+                                           (SETQ EVALFLG T))
+                                 NIL))
+                 ((NEQ LDFLG 'GETDEF)                        (* ; 
+                                                    "getdef means ignore tags, find it if its there.")
+                  (SELECTQ TEM
+                      ((EVAL@COMPILE DOEVAL@COMPILE) 
+                           (AND (EQ VARLST 'LOADCOMP)
+                                (SETQ EVALFLG T)))
+                      (DONTEVAL@COMPILE 
+                           (AND (EQ VARLST 'LOADCOMP)
+                                (SETQ EVALFLG NIL)))
+                      ((EVAL@LOAD DOEVAL@LOAD) 
+                           (AND (NEQ VARLST 'LOADCOMP)
+                                (SETQ EVALFLG T)))
+                      (DONTEVAL@LOAD (AND (NEQ VARLST 'LOADCOMP)
+                                          (SETQ EVALFLG NIL)))
+                      (EVAL@COMPILEWHEN 
+                           (SETQ TEM (READ))
+                           (AND (EQ VARLST 'LOADCOMP)
+                                (SETQ EVALFLG (EVAL TEM))))
+                      (EVAL@LOADWHEN (SETQ TEM (READ))
+                                     (AND (NEQ VARLST 'LOADCOMP)
+                                          (SETQ EVALFLG (EVAL TEM))))
+                      (COPYWHEN (SKREAD))
+                      NIL]
+          (GO LP])
+
+(SCANFILE1
+  [LAMBDA (DICT LST)                                         (* ; "Edited 20-Mar-87 18:06 by bvm:")
+    (AND (NULL LST)
+         (SETQ LST FNLST))
+          
+          (* ;; "looks up functions on LST, if given, but removes them from FNLST.  This so can be called directly from LOADFNS.")
+
+    (PROG ((DICTTAIL DICT)
+           X FNAME TEM)
+      $$LP
+          (COND
+             ((OR (NLISTP DICTTAIL)
+                  (NOT LST))
+              (RETURN NIL)))
+          (SETQ X (CAR DICTTAIL))
+          
+          (* ;; "X = map entry.  For compiled definitions is (start end . fn).  For source files, it's (start end . triples), where each triple is (fn start . end).")
+
+          (COND
+             [(NLISTP (SETQ FNAME (CDDR X)))                 (* ; "compiled definition.")
+              (COND
+                 ((OR (EQ LDFLG 'EXPRESSIONS)
+                      (EQ LDFLG 'GETDEF)
+                      (EQ VARS 'LOADCOMP))                   (* ; 
+                                                             "User wants symbolic definitions only.")
+                  )
+                 ([OR (EQ LST T)
+                      (MEMB FNAME LST)
+                      (SOME LST (FUNCTION (LAMBDA (Y)
+                                            (TMPSUBFN FNAME Y]
+                                                             (* ; 
+               "User wants all functions, this one in particular, or this is a subfn of a desired fn")
+                  (SETFILEPTR NIL (CAR X))
+                  (COND
+                     ([NOT (OR (EQ (SETQ TEM (READ))
+                                   'BINARY)
+                               (GETPROP TEM 'CODEREADER]
+          
+          (* ;; "a file map was built in core, but it isnt right, e.g. user ftped another file by same name since this map was built in core.  so remove map and retry")
+
+                      (RETRYSCAN)))
+                  (SETFILEPTR NIL (CAR X))
+                  (LAPRD FNAME)
+                  (SCANFILE2 FNAME]
+             (T                                              (* ; "DEFINEQ.")
+                (for Y in (CDDR X) do [COND
+                                         [(EQ VARS 'LOADCOMP)
+                                          (AND (NOT (FMEMB (CAR Y)
+                                                           NOFIXFNSLST))
+                                               (SETQ NOFIXFNSLST (CONS (CAR Y)
+                                                                       NOFIXFNSLST]
+                                         ((OR (EQ LST T)
+                                              (MEMB (CAR Y)
+                                                    LST))
+                                          (SETFILEPTR NIL (CADR Y))
+                                          (COND
+                                             ([NEQ (CAR Y)
+                                                   (CAR (SETQ TEM (READ]
+                                              (ERROR '"filemap does not agree with contents of"
+                                                     (INPUT)
+                                                     T)))
+                                          (COND
+                                             ((OR (EQ LDFLG 'EXPRESSIONS)
+                                                  (EQ LDFLG 'GETDEF))
+                                              (SCANFILE2 TEM))
+                                             (T (DEFINE (LIST TEM))
+                                                (SCANFILE2 (CAR TEM] while LST)))
+          (SETQ DICTTAIL (CDR DICTTAIL))
+          (GO $$LP])
+
+(SCANFILE2
+  [LAMBDA (X)
+    (SETQ DONELST (CONS X DONELST))
+    (AND (NEQ FNLST T)
+         (SETQ FNLST (DREMOVE (COND
+                                 ((LISTP X)
+                                  (CAR X))
+                                 (T X))
+                            FNLST])
+
+(TMPSUBFN
+  [LAMBDA (X FN)                                             (* bvm%: "28-Aug-86 14:13")
+          
+          (* ;; "This guy wants names like FNAnnnnAmmmm...")
+
+    (PROG ((N (STRPOS FN X 1 NIL T T))
+           NX C)
+          (if (OR (NULL N)
+                  (NEQ (IREMAINDER (IDIFFERENCE (SETQ NX (ADD1 (NCHARS X)))
+                                          N)
+                              5)
+                       0))
+              then                                           (* ; 
+                       "X does not start with FN, or end in an integral number of 5 character pieces")
+                   (RETURN))
+      LP  (if [OR (NEQ (NTHCHARCODE X N)
+                       (CHARCODE A))
+                  (NOT (for I from 1 to 4 always (AND (SETQ C (NTHCHARCODE X (IPLUS I N)))
+                                                      (IGEQ C (CHARCODE 0))
+                                                      (ILEQ C (CHARCODE 9]
+              then (RETURN)
+            elseif (IGEQ (add N 5)
+                         NX)
+              then (RETURN T))
+          (GO LP])
+
+(RETRYSCAN
+  [LAMBDA NIL                                                (* bvm%: "28-Aug-86 17:05")
+    (COND
+       ((GETHASH FILE *FILEMAP-HASH*)
+        (REMHASH FILE *FILEMAP-HASH*)
+        (PRIN1 "something is wrong with the filemap for " T)
+        (PRINT FILE T)
+        (PRIN1 "rebuilding map..." T)
+        (RETFROM 'LOADFNSCAN (LOADFNSCAN)))
+       (T (SCANFILEHELP])
+
+(SCANFILEHELP
+  [LAMBDA NIL                                                (* JonL "15-Dec-83 21:04")
+          
+          (* ;; 
+          "This function used to spit out a 'sermon' about sysouting and informing W.  Teitelman.")
+
+    (PRIN1 '"something is wrong with either the filemap or format of " T)
+    (PRIN1 (INPUT)
+           T)
+    (TERPRI T)
+    (PRIN1 '"Here are some possibilities:
+(1) you edited the file with a text editor;
+(2) you printed a DEFINEQ in the file directly, i.e. without using
+      the FNS command;
+(3) the file got clobbered.
+
+If you are convinced it is none of the above, then please inform
+the 1100Support program." T)
+    (TERPRI T)
+    (PRIN1 '"Note: for (1) and (2), you may still be
+able to use this file by setting USEMAPFLG to NIL,
+and then reexecuting the operation that caused this
+message." T)
+    (TERPRI T)
+    (HELP])
+)
+
+(RPAQQ NOT-FOUNDTAG NOT-FOUND%:)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS LASTWORD LOADOPTIONS SYSFILES NOT-FOUNDTAG)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
+
+(BLOCK%: SCANFILEBLOCK (ENTRIES LOADFNSCAN TMPSUBFN SCANFILE1) LOADFNSCAN SCANFILE0 SCANCOMPILEDFN SCANDEFINEQ SCANEXP SCANDECLARE%: SCANFILE1 SCANFILE2 TMPSUBFN (LOCALFREEVARS FNADRLST DICT DICT0 ADR) (SPECVARS VARLST) (RETFNS SCANFILE0))
+)
+(PUTPROPS LOADFNS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1986 1987 1989 1990 1992))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (1089 18541 (LOADFROM 1099 . 1572) (LOADBLOCK 1574 . 2082) (GETBLOCKDEC 2084 . 2949) (
+LOADCOMP 2951 . 3614) (LOADCOMP? 3616 . 4118) (LOADVARS 4120 . 4200) (LOADEFS 4202 . 4346) (
+LOADFILEMAP 4348 . 4752) (LOADFNS 4754 . 16826) (LOADFNS-FINDFILE 16828 . 17344) (LOADFNS-MAKELIST 
+17346 . 18539)) (18542 45112 (LOADFNSCAN 18552 . 18730) (SCANFILE0 18732 . 22139) (SCANCOMPILEDFN 
+22141 . 24443) (SCANDEFINEQ 24445 . 29743) (SCANEXP 29745 . 34507) (SCANDECLARE%: 34509 . 38700) (
+SCANFILE1 38702 . 42373) (SCANFILE2 42375 . 42661) (TMPSUBFN 42663 . 43827) (RETRYSCAN 43829 . 44226) 
+(SCANFILEHELP 44228 . 45110)))))
+STOP
diff --git a/CLTL2/LOADFNS.LCOM b/CLTL2/LOADFNS.LCOM
new file mode 100644
index 00000000..be03c094
Binary files /dev/null and b/CLTL2/LOADFNS.LCOM differ
diff --git a/CLTL2/MACHINEINDEPENDENT b/CLTL2/MACHINEINDEPENDENT
new file mode 100644
index 00000000..569f6fbd
--- /dev/null
+++ b/CLTL2/MACHINEINDEPENDENT
@@ -0,0 +1,572 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+(FILECREATED "22-Sep-92 19:22:00" |{DSK}<usr>local>lde>lispcore>sources>MACHINEINDEPENDENT.;2| 73176  
+
+      |changes| |to:|  (FNS NAMEFIELD COMSNAME NAMEFIELD-STRING) (VARS MACHINEINDEPENDENTCOMS)
+
+      |previous| |date:| "27-Feb-91 18:30:38" 
+|{DSK}<usr>local>lde>lispcore>sources>MACHINEINDEPENDENT.;1|)
+
+
+; Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 by Venue & Xerox Corporation.  All rights reserved.
+; The following program was created in 1983 but has not been published
+; within the meaning of the copyright law, is furnished under license,
+; and may not be used, copied and/or disclosed except in accordance
+; with the terms of said license.
+
+(PRETTYCOMPRINT MACHINEINDEPENDENTCOMS)
+
+(RPAQQ MACHINEINDEPENDENTCOMS ((COMS (* \; " \"File loader\"") (FNS LOAD? FILESLOAD DOFILESLOAD FINDFILE-WITH-EXTENSIONS) (INITVARS (*COMPILED-EXTENSIONS* (LIST FASL.EXT COMPILE.EXT)))) (COMS (* \; "random machine-independent utilities") (FNS DMPHASH HASHOVERFLOW) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS HASHOVERFLOW.ARRAYTEST HASHOVERFLOW.UPDATEARRAY)) (FNS BKBUFS CHANGENAME CHNGNM CLBUFS COMSNAME DEFINE FNS.PUTDEF EQMEMB EQUALN FNCHECK FNTYP1 LCSKIP MAPRINT MKLIST NAMEFIELD NAMEFIELD-STRING NLIST PRINTBELLS PROMPTCHAR RAISEP READFILE READLINE REMPROPLIST RESETBUFS TAB UNSAVED1 WRITEFILE CLOSE-AND-MAYBE-DELETE UNSAFE.TO.MODIFY) (VARS UNSAFE.TO.MODIFY.FNS) (COMS (* \; "FILEDATE, for finding out the creation date of source files, from the compiled files.") (* |;;| "FASL isn't loaded when MACHINEINDEPENDENT is, so we have to fake the FASL checker for now.  It's defined in FASLOAD.") (FNS FILEDATE) (P (MOVD? (QUOTE NILL) (QUOTE FASL-FILEDATE)))) (P (MOVD? (QUOTE CL:FMAKUNBOUND) (QUOTE UNDOABLY-FMAKUNBOUND))) (* \; "used in FNS.PUTDEF before CMLUNDO loaded")) (COMS (* \; "Functions for retrieving and remembering FILEMAPs and file reader environments") (FNS FILEMAP \\PARSE-FILE-HEADER GET-ENVIRONMENT-AND-FILEMAP LOOKUP-ENVIRONMENT-AND-FILEMAP GET-FILEMAP-FROM-FILECREATED \\FILEMAP-HASHOVERFLOW FLUSHFILEMAPS LISPSOURCEFILEP GETFILEMAP PUTFILEMAP UPDATEFILEMAP PRINT-READER-ENVIRONMENT) (INITVARS (*FILEMAP-LIMIT* 20) (*FILEMAP-VERSIONS* 2) (*FILEMAP-HASH* (HASHARRAY *FILEMAP-LIMIT* (FUNCTION \\FILEMAP-HASHOVERFLOW) (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING.EQUAL)))) (DECLARE\: EVAL@COMPILE DONTCOPY (RECORDS FILEMAPHASH) (GLOBALVARS *FILEMAP-LIMIT* *FILEMAP-VERSIONS* *FILEMAP-HASH*))) (COMS (* * LVLPRINT) (FNS LVLPRINT LVLPRIN1 LVLPRIN2 LVLPRIN LVLPRIN0)) (COMS (* \; "used by PRINTOUT") (FNS FLUSHRIGHT PRINTPARA PRINTPARA1)) (COMS (* \; "SUBLIS and friends") (FNS SUBLIS SUBPAIR DSUBLIS)) (COMS (* * CONSTANTS) (FNS CONSTANTOK) (P (MOVD? (QUOTE EVQ) (QUOTE CONSTANT)) (MOVD? (QUOTE EVQ) (QUOTE DEFERREDCONSTANT)) (MOVD? (QUOTE EVQ) (QUOTE LOADTIMECONSTANT)))) (COMS (* * SCRATCHLIST) (PROP MACRO SCRATCHLIST ADDTOSCRATCHLIST) (PROP INFO SCRATCHLIST)) (GLOBALVARS SYSFILES LOADOPTIONS LISPXCOMS CLISPTRANFLG COMMENTFLG HISTSTR4 LISPXREADFN REREADFLG HISTSTR0 CTRLUFLG NOLINKMESS PROMPTCHARFORMS PROMPT#FLG FILERDTBL SPELLINGS2 USERWORDS BELLS CLISPARRAY) (FNS NLAMBDA.ARGS) (DECLARE\: DONTEVAL@LOAD DOCOPY (* \; "initialization of variables used in many places") (ADDVARS (CLISPARRAY) (CLISPFLG) (CTRLUFLG) (EDITCALLS) (EDITHISTORY) (EDITUNDOSAVES) (EDITUNDOSTATS) (GLOBALVARS) (LCASEFLG) (LISPXBUFS) (LISPXCOMS) (LISPXFNS) (LISPXHIST) (LISPXHISTORY) (LISPXPRINTFLG) (NOCLEARSTKLST) (NOFIXFNSLST) (NOFIXVARSLST) (P.A.STATS) (PROMPTCHARFORMS) (READBUF) (READBUFSOURCE) (REREADFLG) (RESETSTATE) (SPELLSTATS1)) (VARS (CHCONLST (QUOTE (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) (CHCONLST1 (QUOTE (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) (CHCONLST2 (QUOTE (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) (CLEARSTKLST T) (CLISPTRANFLG (QUOTE CLISP\ )) (HISTSTR0 "<c.r.>") (HISTSTR2 "repeat") (HISTSTR3 "from event:") (HISTSTR4 "ignore") (LISPXREADFN (QUOTE READ)) (USEMAPFLG T)) (P (MAPC (QUOTE ((APPLY BLKAPPLY) (SETTOPVAL SETATOMVAL) (GETTOPVAL GETATOMVAL) (APPLY* BLKAPPLY*) (RPLACA FRPLACA) (RPLACD FRPLACD) (STKNTH FSTKNTH) (STKNAME FSTKNAME) (CHARACTER FCHARACTER) (STKARG FSTKARG) (CHCON DCHCON) (UNPACK DUNPACK) (ADDPROP /ADDPROP) (ATTACH /ATTACH) (DREMOVE /DREMOVE) (DSUBST /DSUBST) (NCONC /NCONC) (NCONC1 /NCONC1) (PUT /PUT) (PUTPROP /PUTPROP) (PUTD /PUTD) (REMPROP /REMPROP) (RPLACA /RPLACA) (RPLACD /RPLACD) (SET /SET) (SETATOMVAL /SETATOMVAL) (SETTOPVAL /SETTOPVAL) (SETPROPLIST /SETPROPLIST) (SET SAVESET) (PRINT LISPXPRINT) (PRIN1 LISPXPRIN1) (PRIN2 LISPXPRIN2) (SPACES LISPXSPACES) (TAB LISPXTAB) (TERPRI LISPXTERPRI) (PRINT SHOWPRINT) (PRIN2 SHOWPRIN2) (PUTHASH /PUTHASH) (QUOTE *) (FNCLOSER /FNCLOSER) (FNCLOSERA /FNCLOSERA) (FNCLOSERD /FNCLOSERD) (EVQ DELFILE) (NILL SMASHFILECOMS) (PUTASSOC /PUTASSOC) (LISTPUT1 PUTL) (NILL I.S.OPR) (NILL RESETUNDO) (NILL LISPXWATCH) (QUOTE ADDSTATS) (NILL FREEVARS) (QUOTE USEDFREE) (COPYBYTES COPYCHARS))) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X))))) (MAPC (QUOTE ((TIME PRIN1 LISPXPRIN1) (TIME SPACES LISPXSPACES) (TIME PRINT LISPXPRINT) (DEFC PRINT LISPXPRINT) (DEFC PUTD /PUTD) (DEFC PUTPROP /PUTPROP) (DOLINK FNCLOSERD /FNCLOSERD) (DOLINK FNCLOSERA /FNCLOSERA) (DEFLIST PUTPROP /PUTPROP) (SAVEDEF1 PUTPROP /PUTPROP) (MKSWAPBLOCK PUTD /PUTD))) (FUNCTION (LAMBDA (X) (AND (CCODEP (CAR X)) (APPLY (QUOTE CHANGENAME) X))))) (MAPC (QUOTE ((EVALQT (LAMBDA NIL (PROG (TEM) (RESETRESTORE NIL (QUOTE RESET)) LP (PROMPTCHAR (QUOTE _) T) (LISPX (LISPXREAD T T)) (GO LP)))) (LISPX (LAMBDA (LISPXX) (PRINT (AND LISPXX (PROG (LISPXLINE LISPXHIST TEM) (RETURN (COND ((AND (NLISTP LISPXX) (SETQ LISPXLINE (READLINE T NIL T))) (APPLY LISPXX (CAR LISPXLINE))) (T (EVAL LISPXX)))))) T T))) (LISPXREAD (LAMBDA (FILE RDTBL) (COND (READBUF (PROG1 (CAR READBUF) (SETQ READBUF (CDR READBUF)))) (T (READ FILE RDTBL))))) (LISPXREADP (LAMBDA (FLG) (COND ((AND READBUF (SETQ READBUF (LISPXREADBUF READBUF))) T) (T (READP T FLG))))) (LISPXUNREAD (LAMBDA (LST) (SETQ READBUF (APPEND LST (CONS HISTSTR0 READBUF))))) (LISPXREADBUF (LAMBDA (RDBUF) (PROG NIL LP (COND ((NLISTP RDBUF) (RETURN NIL)) ((EQ (CAR RDBUF) HISTSTR0) (SETQ RDBUF (CDR RDBUF)) (GO LP)) (T (RETURN RDBUF)))))) (LISPX/ (LAMBDA (X) X)) (LOWERCASE (LAMBDA (FLG) (PROG1 LCASEFLG (RAISE (NULL FLG)) (RPAQ LCASEFLG FLG)))) (FILEPOS (LAMBDA (STR FILE) (PROG NIL LP (COND ((EQ (PEEKC FILE) (NTHCHAR STR 1)) (RETURN T))) (READC FILE) (GO LP)))) (FILEPKGCOM (NLAMBDA NIL NIL)))) (FUNCTION (LAMBDA (L) (OR (GETD (CAR L)) (PUTD (CAR L) (CADR L)))))))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA RESETBUFS DMPHASH FILESLOAD) (NLAML FILEMAP) (LAMA READFILE NLIST))) (LOCALVARS . T)))
+
+
+
+(* \; " \"File loader\"")
+
+(DEFINEQ
+
+(load?
+(lambda (file ldflg printflg) (* |lmm| " 2-Sep-85 13:15") (|bind| full |until| (setq full (findfile file)) |do| (setq file (lisperror "FILE NOT FOUND" file t)) |finally| (return (|if| (fmemb full loadedfilelst) |then| full |else| (let* ((root (rootfilename full)) (dates (getprop root (quote filedates))) (fileprop (getprop root (quote file)))) (|if| (and dates (|if| (eq (filenamefield full (quote extension)) compile.ext) |then| (and (or (null fileprop) (fmemb (cdar fileprop) (quote (|Compiled| compiled)))) (equal (caar dates) (filedate full t))) |else| (and fileprop (eq (cdar fileprop) t) (or (eq (cdar dates) full) (equal (caar dates) (filedate full)))))) |then| full |else| (load full ldflg printflg)))))))
+)
+
+(filesload
+(nlambda files (* |lmm| "10-Dec-84 17:23") (* |;;| "Calls to this are written on files by the FILES command.  This function does the load-time evaluation of the command.") (dofilesload (nlambda.args files)))
+)
+
+(dofilesload
+(lambda (files) (declare (usedfree ldflg)) (* \; "Edited  4-May-88 14:23 by bvm") (* \; "does the work of FILESLOAD") (|for| file |inside| files |bind| dirs loadoptionsflg forcedext? noerrorflg word full (fn _ (quote load?)) (ext _ :compiled) |first| (cond ((boundp (quote ldflg)) (* |;;| "Under a load;  give priority to directory of currently loading file. ") (let ((inputname (fullname *standard-input*))) (|if| (and (neq inputname *standard-input*) (neq inputname t)) |then| (* \; "If reading from terminal or nameless stream, don't do this.") (setq dirs (cons (packfilename.string (quote version) nil (quote name) nil (quote extension) nil (quote body) inputname) (cons t directories))) (setq loadoptionsflg ldflg))))) |join| (cond ((or (litatom file) (stringp file)) (* \; "A file to do something with") (prog nil (cond ((and (eq fn (quote load?)) (getprop (rootfilename file) (quote filedates))) (* \; "Already loaded") (return))) lp (cond ((setq full (selectq ext (nil (* \; "No extension to guide us") (findfile file t dirs)) (:compiled (* \; "Look for some sort of compiled file, or failing that a source") (or (findfile-with-extensions file dirs *compiled-extensions*) (and (not forcedext?) (findfile file t dirs)))) (progn (* \; "Look for explicitly supplied extension") (findfile (packfilename.string (quote body) file (quote extension) ext) t dirs))))) (noerrorflg (return)) ((and (setq file (cl:cerror "Forget about loading ~A" "File ~A not found~@[ on~{ ~A~}~]" file dirs)) (or (litatom file) (stringp file))) (* \; "User RETURNed a new file name") (go lp)) (t (* \; "if proceed from ERROR, blow off loading this file") (return))) (return (list (selectq fn (checkimports (* \; "LOADOPTIONSFLG has a different meaning for imports") (checkimports full t) full) (load? (* \; "already weeded out the ones with filedates") (load full loadoptionsflg)) (cl:funcall fn full loadoptionsflg)))))) (t (|while| (listp file) |do| (selectq (car file) (loadcomp (setqq fn loadcomp?) (setq loadoptionsflg nil) (setq ext nil)) (loadfrom (setqq fn loadfrom) (setq ext nil)) (from (|pop| file) (setq dirs (mklist (cond ((or (eq (setq word (car file)) (quote valueof)) (cond ((and (eq word (quote value)) (eq (cadr file) (quote of))) (|pop| file) t))) (|pop| file) (eval (car file))) ((and (selcharq (chcon1 word) (({ <) nil) t) (boundp (setq word (pack* word (quote directories)))) (setq word (evalv word))) (* \; "KLUDGE: Turns, e.g., (FROM LISPUSERS) into (FROM VALUEOF LISPUSERSDIRECTORIES)") word) (t (car file)))))) (compiled (setq forcedext? t) (setq ext :compiled)) (load (setqq fn load?)) ((extension ext) (setq file (listp (cdr file))) (setq ext (car file))) ((source symbolic) (setq ext nil)) (import (setqq fn checkimports) (setq ext nil)) (noerror (setq noerrorflg t)) (cond ((fmemb (car file) loadoptions) (setq loadoptionsflg (car file))) (t (* \; "invalid option in FILESLOAD") nil))) (|pop| file)) nil))))
+)
+
+(findfile-with-extensions
+(lambda (file dirlst extensions) (* \; "Edited  8-Dec-86 17:57 by bvm") (* |;;;| "Search for FILE on the directories contained in DIRLST, where NIL and T refer to the login and connected dirs, respectively.  On each directory, prefer files having extension found in EXTENSIONS in the indicated order.  If FILE already has an extension, EXTENSIONS is ignored; if FILE already has a host/dir, DIRLST is ignored.") (|if| file |then| (let ((fields (unpackfilename.string file)) dir&fields hasdirectory hasextension val) (|for| tail |on| fields |by| (cddr tail) |do| (selectq (car tail) (extension (setq hasextension t)) ((host device directory) (setq hasdirectory t)) nil)) (|if| hasdirectory |then| (* \; "Don't search dirs, just look where it says") (|if| hasextension |then| (infilep file) |else| (|for| ext |in| extensions |when| (setq val (infilep (packfilename.string (bquote (extension (\\\, ext) (\\\,@ fields)))))) |do| (return val))) |else| (|for| dir |inside| (|if| (null dirlst) |then| (* \; "If DIRLST is defaulted, always look first on connected dir.") (|if| directories |then| (cons t (remove t directories)) |else| t) |else| (* \; "use explicit DIRLST, ignoring connected dir unless it's on DIRECTORIES") dirlst) |when| (progn (setq dir&fields (selectq dir (nil (* \; "Login dir") (bquote (directory (\\\, (directoryname nil)) (\\\,@ fields)))) (t (* \; "Connected dir") fields) (bquote (directory (\\\, dir) (\\\,@ fields))))) (setq val (|if| hasextension |then| (infilep (packfilename.string dir&fields)) |else| (|for| ext |in| extensions |when| (setq val (infilep (packfilename.string (bquote (extension (\\\, ext) (\\\,@ dir&fields)))))) |do| (return val))))) |do| (return val))))))
+)
+)
+
+(RPAQ? *COMPILED-EXTENSIONS* (LIST FASL.EXT COMPILE.EXT))
+
+
+
+(* \; "random machine-independent utilities")
+
+(DEFINEQ
+
+(dmphash
+(nlambda l (* |rmk:| " 6-Apr-84 14:30") (mapc l (function (lambda (arrayname) (declare (specvars arrayname)) (ersetq (prog ((a (evalv arrayname (quote dmphash))) ap) (print (list (quote rpaq) arrayname (cond ((listp a) (setq ap (car a)) (list (quote cons) (list (quote harray) (harraysize ap) (kwote (harrayprop ap (quote overflow)))) (kwote (cdr a)))) (t (list (quote hasharray) (harraysize a) (kwote (harrayprop ap (quote overflow)))))))) (maphash (or ap a) (function (lambda (val item) (print (list (quote puthash) (kwote item) (kwote val) arrayname)))))))))))
+)
+
+(HASHOVERFLOW
+  (LAMBDA (HARRAY)                                       (* \; "Edited 26-Feb-91 13:16 by jds")
+
+    (* |;;| "Should be called from PUTHASH on hash overflow, but for implementations where PUTHASH calls ERRORX directly, may be called from ERRORX2 when the offender is a listp.  HARRAY is guaranteed to be either HARRAYP or (LIST HARRAYP)")
+
+    (PROG ((OLDARRAY (HASHOVERFLOW.ARRAYTEST HARRAY))
+           NEWARRAY NEWSIZE OLDNUMKEYS OVACTION NEWOVFLW)
+          (COND
+             ((LISTP HARRAY)
+              (SETQ OVACTION (CDR HARRAY))
+
+              (* |;;| "Get OVERFLOW method from original HARRAY since it would erroneously be ERROR if we got the method from the coerced OLDARRAY")
+
+              (SETQ NEWOVFLW 'ERROR))
+             (T (SETQ OVACTION (SETQ NEWOVFLW (HARRAYPROP OLDARRAY 'OVERFLOW)))))
+          (SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY 'NUMKEYS))
+
+     (* |;;| "Compute the new array size:")
+
+          (SETQ NEWSIZE (SELECTQ OVACTION
+                            (NIL 
+                                 (* |;;| "SIZE*1.5 --- favor to bbn, since pdp-11 doesnt have floatng point, and LRSH on other systems might be faster than IQUOTIENT")
+
+                                 (* |;;| 
+                               "[32749 IS THE BIGGEST PRIME < 32765, THE LIMIT ON ARRAY SIZES]")
+
+                                 (IMAX (+ OLDNUMKEYS 3)
+                                       (IMIN 32749 (+ OLDNUMKEYS (LRSH (CL:1+ OLDNUMKEYS)
+                                                                       1)))))
+                            (ERROR (|do| (ERRORX (LIST 26 HARRAY))))
+                            (|if| (FLOATP OVACTION)
+                                |then| (IMAX (+ OLDNUMKEYS 3)
+                                                 (IMIN 32760 (FIXR (FTIMES OLDNUMKEYS OVACTION))))
+                              |elseif| (FIXP OVACTION)
+                                |then| (IMAX (+ OLDNUMKEYS 3)
+                                                 (IMIN 32749 (+ OLDNUMKEYS OVACTION)))
+                              |elseif| (AND (FNTYP OVACTION)
+                                                (NUMBERP (SETQ OVACTION (APPLY* OVACTION HARRAY))))
+                                |then| (|if| (FLOATP OVACTION)
+                                               |then|    (* \; 
+                                         "recompute NUMKEYS since OVACTION might have removed keys")
+                                                     (IMAX (+ (SETQ OLDNUMKEYS (HARRAYPROP
+                                                                                OLDARRAY
+                                                                                'NUMKEYS))
+                                                              3)
+                                                           (IMIN 32749 (FIXR (FTIMES OLDNUMKEYS 
+                                                                                    OVACTION))))
+                                             |else| OVACTION)
+                              |else|                     (* \; "Default: multiply by 1.5")
+                                    (SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY 'NUMKEYS))
+                                    (IMAX (+ OLDNUMKEYS 3)
+                                          (IMIN 32749 (+ OLDNUMKEYS (LRSH (CL:1+ OLDNUMKEYS)
+                                                                          1)))))))
+          (SETQ NEWARRAY (REHASH OLDARRAY (HASHARRAY NEWSIZE NEWOVFLW (HARRAYPROP OLDARRAY
+                                                                             'HASHBITSFN)
+                                                 (HARRAYPROP OLDARRAY 'EQUIVFN))))
+          (HASHOVERFLOW.UPDATEARRAY HARRAY NEWARRAY OLDARRAY)
+          (RETURN HARRAY))))
+)
+(DECLARE\: EVAL@COMPILE DONTCOPY 
+(DECLARE\: EVAL@COMPILE 
+
+(PROGN (PUTPROPS HASHOVERFLOW.ARRAYTEST MACRO ((HARRAY) (CAR (OR (LISTP HARRAY) (ERRORX (LIST 27 HARRAY)))))) (PUTPROPS HASHOVERFLOW.ARRAYTEST DMACRO ((HARRAY) (\\DTEST HARRAY (QUOTE HARRAYP)))))
+
+(PROGN (PUTPROPS HASHOVERFLOW.UPDATEARRAY MACRO ((HARRAY NEWARRAY OLDARRAY) (FRPLACA HARRAY NEWARRAY))) (PUTPROPS HASHOVERFLOW.UPDATEARRAY DMACRO ((HARRAY NEWARRAY OLDARRAY) (\\COPYHARRAYP NEWARRAY OLDARRAY))))
+)
+)
+(DEFINEQ
+
+(bkbufs
+(lambda (bufs id) (* dd\: " 6-Oct-81 15:34") (prog (l s) (cond ((nlistp bufs) (return)) (t (setq l (car bufs)) (setq s (cdr bufs)))) (cond ((readp t) (* |;;| "User types ahead before command causing buffer to be restored was executed.  In this case, his type-ahead would come BEFORE the restored buffer, when it should be after it, because the command causing the buffer to be restored had to have been given before the type-ahead.") (printbells) (dobe) (clearbuf t t) (bksysbuf s) (bksysbuf (sysbuf t)) (sysbuf)) (s (bksysbuf s))) (cond (l (and id (prin1 id t)) (* |;;| "ID will be suppressed by LISPX to prevent it being typed in middle of input.  Note that anything put back in SYSBUF will be printed (echoed) as it is read.") (prin1 l t) (bklinbuf l))) (return)))
+)
+
+(changename
+(lambda (fn from to) (* |wt:| "18-SEP-78 21:29") (cond ((changename1 (getd fn) from to fn) (and filepkgflg (exprp fn) (markaschanged fn (quote fns))) fn)))
+)
+
+(chngnm
+(lambda (fn old flg) (prog (new def x y z) (setq fn (fncheck fn nil t)) (* \; "No error, becuase maybe OLD isnt defined yet, e.g. BREAK ((FOO IN FUM)) where FOO not defined.") (setq old (or (fncheck old t t) old)) (setq def (getd (or (getp fn (quote advised)) (getp fn (quote broken)) fn))) (setq new (pack (list old (quote -in-) fn))) (cond (flg (and (null (stkpos new)) (/putd new)) (cond ((setq z (/dremove old (getp fn (quote nameschanged)))) (/put fn (quote nameschanged) z)) (t (/remprop fn (quote nameschanged)))) (/remprop new (quote alias)) (setq y old) (setq x new)) (t (setq y new) (setq x old) (cond ((and (memb old (getp fn (quote nameschanged))) (getd new) (getp new (quote alias))) (return new))))) (cond ((null def) (return (cons def (quote (|not| |defined|))))) ((null (resetvars ((nolinkmess t)) (return (changename1 def x y fn)))) (return (cons x (append (quote (|not| |found| |in|)) (list fn)))))) (cond ((null flg) (cond ((null (setq def (getd old))) (setq def (list (quote nlambda) (gensym))) (print (cons old (quote (|was| |undefined|))) t t))) (/putd new (saved old nil def old)) (/addprop fn (quote nameschanged) old) (/put new (quote alias) (cons fn old)))) (return y)))
+)
+
+(clbufs
+(lambda (noclearflg notypeflg buf) (* \; "wt: 10-MAR-77 21 5") (* |;;| "NOCLEARFLG=T means CLEARBUF has already been done, and anything in the buffer now is type-ahead, e.g.  calls from EVALQT, and call from BREAK on control-h INTERRUPT.") (* |;;| "NOTYPEFLG=T means user should not be typing ahead.  If READP is T, warn him to stop and wait.  Occurs when CLBUFS is being done BEFORE some action, e.g.  DWIM interaction, loading SYSBUF for EXEC commands, etc.  as opposed to AFTER some action, e.g.  an error occurred.") (prog (lbuf sbuf) (cond (noclearflg (go skip)) ((and notypeflg (readp t)) (printbells) (dobe))) (clearbuf t t) (setq readbuf buf) skip (setq ctrluflg nil) (* \; "In case user control-e's or control-d's after typing control-u and changing his mind.") (setq lbuf (linbuf t)) (setq sbuf (sysbuf t)) (linbuf) (sysbuf) (cond ((strequal lbuf (quote "
+")) (setq lbuf nil))) (return (cond ((or sbuf lbuf) (cons lbuf sbuf)))))))
+
+(COMSNAME
+(LAMBDA (FILE SUFFIXFLG DIRFLG) (* |;;| "IF SUFFIXFLG is T, returns name and suffix field, otherwise just NAMEFIELD") (LET ((STR (NAMEFIELD-STRING FILE SUFFIXFLG DIRFLG))) (* |;;| "COMS names must be smashed to upper-case; if you want the unsmashed filename, use NAMEFIELD") (|if| (NOT (U-CASEP STR)) |then| (SETQ STR (U-CASE STR))) (MKATOM STR)))
+)
+
+(define
+(lambda (x type-in) (* |mpl| "15-Jul-85 11:22") (mapcar x (function (lambda (x) (cond ((nlistp x) (error (quote "incorrect defining form") x))) (fns.putdef (car x) (quote fns) (cond ((null (cddr x)) (cadr x)) (t (cons (quote lambda) (cdr x)))) (|if| type-in |then| (quote defined) |else| (quote load)))))))
+)
+
+(fns.putdef
+(lambda (name type definition reason) (* \; "Edited 20-Nov-87 14:24 by woz") (prog nil (|if| (or (and definition (nlistp definition)) (not (fmemb (car definition) lambdasplst))) |then| (error definition "Illegal function definition")) (selectq dfnflg ((nil t) (|if| (unsafe.to.modify name "redefine") |then| (error name " not redefined" t))) nil) (|if| (eq reason (quote defined)) |then| (* |;;| "woz: i think this test is wrong; what about CHANGED?  SEdit special cases FNS in sedit::completion, and calls FIXEDITDATE directly, but shouldn't have to.") (fixeditdate definition)) (if (and (hasdef name (quote functions)) (neq (car definition) (quote nlambda))) then (* \; "For a while, we can't prevent the use of both a DEFMACRO and NLAMBDA for the same name.") (deldef name (quote functions))) (cond ((or (null dfnflg) (eq dfnflg t)) (cond ((getd name) (virginfn name t) (* |;;| "((EQUAL DEFINITION (GETD NAME)) (RETURN NAME)) Used to be part of the following COND.  ripped out because editing out of the function cell wasn't completing fully.") (cond ((null dfnflg) (progn (* \; "if EXEC-FORMAT existed earlier, I'd use it") (lispxprin1 "New fns definition for " t) (lispxprin2 name t) (lispxprin1 ".
+" t)) (savedef name))))) (cond (addspellflg (addspell name))) (undoably-setf (cl:symbol-function name) definition) (* |;;| "Removed:  (REMPROP NAME 'EXPR)  because it wasn't saving the definition where UNSAVEDEF could find it.")) (t (* \; "DFNFLG is PROP or ALLPROP.  However, treat anything else the same as PROP.") (and addspellflg (addspell name 0)) (cl:unless (eq definition (getd name)) (* |;;| "woz:  don't want to have an EXPR property if have the definition in the function cell, so be careful here.") (cl:when (and (or (null reason) (eq reason (quote changed))) (eq definition (getprop name (quote expr)))) (* |;;| "editing a definition out of the saved EXPR property, and since DFNFLG is PROP, let the user know not installed") (lispxprin1 "New fns definition for " t) (lispxprin2 name t) (lispxprin1 " (but not installed).
+" t)) (/putprop name (quote expr) definition)))) (cond (filepkgflg (markaschanged name (quote fns) reason))) (return name)))
+)
+
+(eqmemb
+(lambda (x y) (* |lmm:| 17 apr 75 305) (or (eq x y) (and (listp y) (fmemb x y) t))))
+
+(equaln
+(lambda (x y depth) (* |wt:| "12-JUN-80 10:57") (* |;;| "like EQUAL but stops, returning T, if depth of car recursion plus depth of cdr recursion ever exceeds DEPTH.") (cond ((eq x y)) ((nlistp x) (cond ((numberp x) (and (numberp y) (eqp x y))) ((stringp x) (strequal x y)) ((stackp x) (eqp x y)))) ((nlistp y) nil) ((and depth (ilessp depth 1)) (quote ?)) (t (selectq (equaln (car x) (car y) (and depth (setq depth (sub1 depth)))) (? (quote ?)) (t (equaln (cdr x) (cdr y) depth)) nil))))
+)
+
+(fncheck
+(lambda (fn noerrorflg spellflg propflg tail) (* |bvm:| "30-OCT-83 21:59") (prog (x block block/fn) top (cond ((not (litatom fn)) (go error)) ((getd fn)) ((getp fn (quote expr)) (and (null propflg) (go error))) ((null dwimflg) (go error)) ((and (car (nlsetq (setq x (or (misspelled? fn 70 userwords spellflg tail (function getd)) (misspelled? fn 70 spellings2 spellflg tail))))) (neq x fn)) (setq fn x) (go top)) ((and (eq (systemtype) (quote d)) (|for| fl |in| (whereis fn) |thereis| (|for| file |inside| (or (getp fl (quote filegroup)) fl) |thereis| (setq block (|find| b |in| (filecomslst file (quote blocks)) |suchthat| (and (car x) (memb fn block)))))) (getd (setq block/fn (pack* (quote \\) (car block) (quote /) fn)))) (* |;;| "In Interlisp-D, get actual name of internal block fn.  This is a little odd, since in a truly block-compiled system you couldn't get at the subfns") (setq fn block/fn)) (t (go error))) (and addspellflg (addspell fn 0)) (return fn) error (cond (noerrorflg (return nil))) (setq fn (error fn (quote "not a function") (null (relstk (or (stkpos (quote load)) (stkpos (quote loadfrom))))))) (go top)))
+)
+
+(fntyp1
+(lambda (x) (and clisparray (setq x (gethash x clisparray)) (fntyp x))))
+
+(lcskip
+(lambda (fn flg) (* |bvm:| "24-Oct-86 17:09") (* |;;| "Skip or copy FN, FLG T to copy") (prog (len la) (|if| (eq (peekccode) (charcode space)) |then| (cond ((eq (setq la (read)) (quote binary)) (return (binskip fn flg nil nil la))) ((setq len (getprop la (quote codereader))) (* \; "Peter's hook for interfacing byte compiler.") (return (apply* (cdr len) fn flg nil nil la))))) (error "Bad or incompatible compiled function" fn)))
+)
+
+(maprint
+(lambda (lst file left right sep pfn lspxprntflg) (* |wt:| 15-sep-77 15 43) (resetvars ((lispxprintflg lspxprntflg)) (cond ((null pfn) (setq pfn (function lispxprin1)))) (cond ((null sep) (setq sep (quote \ )))) (cond (left (lispxprin1 left file))) (cond ((nlistp lst) (go exit))) lp (apply* pfn (car lst) file) (cond ((null (setq lst (cdr lst))) (go exit)) ((nlistp lst) (lispxprin1 (quote " . ") file) (apply* pfn lst file) (go exit))) (lispxprin1 sep file) (go lp) exit (cond (right (lispxprin1 right file)))))
+)
+
+(mklist
+(lambda (x) (* |lmm:| 21 aug 75 428) (and x (or (listp x) (list x)))))
+
+(NAMEFIELD
+(LAMBDA (FILE SUFFIXFLG DIRFLG) (* \; "Edited  5-Dec-90 22:32 by nm") (* |;;| "IF SUFFIXFLG is T, returns name and suffix field, otherwise just NAMEFIELD") (MKATOM (NAMEFIELD-STRING FILE SUFFIXFLG DIRFLG)))
+)
+
+(NAMEFIELD-STRING
+(LAMBDA (FILE SUFFIXFLG DIRFLG) (* |;;| "IF SUFFIXFLG is T, returns name and suffix field, otherwise just NAMEFIELD") (LET ((STR (COND ((EQ DIRFLG (QUOTE ONLY)) (UNPACKFILENAME.STRING FILE (QUOTE DIRECTORY))) ((EQ SUFFIXFLG (QUOTE ONLY)) (UNPACKFILENAME.STRING FILE (QUOTE EXTENSION))) ((AND (NULL SUFFIXFLG) (NULL DIRFLG)) (UNPACKFILENAME.STRING FILE (QUOTE NAME))) (T (* |;;| "The general case.  EXTENSION is fairly icky because UNPACKFILENAME.STRING behaves differently than UNPACKFILENAME, in that it returns a null string instead of NIL for extensionless files") (PACKFILENAME.STRING (QUOTE DIRECTORY) (AND DIRFLG (UNPACKFILENAME.STRING FILE (QUOTE DIRECTORY))) (QUOTE NAME) (UNPACKFILENAME.STRING FILE (QUOTE NAME)) (QUOTE EXTENSION) (AND SUFFIXFLG (SETQ SUFFIXFLG (UNPACKFILENAME.STRING FILE (QUOTE EXTENSION))) (> (NCHARS SUFFIXFLG) 0) SUFFIXFLG)))))) STR))
+)
+
+(nlist
+(lambda n (* |bvm:| "14-Feb-85 23:48") (prog (v (i n)) lp (cond ((eq i 0) (return v)) ((or v (arg n i)) (setq v (cons (arg n i) v)))) (setq i (sub1 i)) (go lp)))
+)
+
+(printbells
+(lambda nil (* |wt:| 10-mar-77 21 15) (prin3 bells t)))
+
+(promptchar
+(lambda (id flg history) (declare (specvars id history promptstr)) (* |lmm| " 9-Jun-85 20:53") (* |;;| "First checks READBUF, and strips off any leading pseudo-carriage rettursn, and computes the new readbuf for repeated operations.  If following this, READBUF is not NIL, never prints ID.  Otherwise prints ID if FLG is T, or if READP is NIL.  FLG is T for calls from EVALQT and BREAK, NIL from editor.") (prog (n mod promptstr) (cond (flg (and readbuf (setq readbuf (lispxreadbuf readbuf)) (return nil)) (* \; "redoing an event")) ((lispxreadp) (* \; "LISPXREADP returns T if there is anything on this line, but returns NIL if just a c.r.") (return nil))) (cond ((and history prompt#flg) (setq promptstr (cond ((igreaterp (setq n (add1 (cadr history))) (setq mod (or (cadddr history) 100))) (* \; "This event is the roll-over event.") (idifference n mod)) (t n))))) (cond (promptcharforms (* |;;| "gives user a hook for operations to be performed each event, e.g.  monitoring functions, checking if typescript window is up etc.  also these forms can change what is printed by resetting promptstr and / or id") (mapc promptcharforms (function (lambda (x) (ersetq (eval x))))))) (and promptstr (prin2 promptstr t)) (and id (prin1 id t))))
+)
+
+(raisep
+(lambda (ttbl) (* |wt:| 1-aug-77 14 15) (* |;;| "True if lisp is in mode where it raises lower case inputs to uppercase.") (cond ((raise nil ttbl) (raise t ttbl) t)))
+)
+
+(readfile
+(cl:lambda (file &optional rdtbl (endtoken (quote stop)) package) (declare (globalvars loadparameters)) (* \; "Edited 20-Jan-87 16:22 by bvm:") (with-reader-environment *old-interlisp-read-environment* (resetlst (resetsave nil (list (quote closef?) (setq file (openstream file (quote input) nil nil loadparameters)))) (if (eq (skipseprcodes file) (charcode ";")) then (setq *readtable* cmlrdtbl) (setq *package* (cl:find-package "USER"))) (|if| rdtbl |then| (setq *readtable* (\\dtest rdtbl (quote readtablep)))) (|if| package |then| (setq *package* (\\dtest package (quote package)))) (let ((eoftoken "eof") env tem helpclock) (declare (specvars helpclock)) (cl:values (|until| (or (eq (setq tem (cl:read file nil eoftoken)) eoftoken) (eq tem endtoken)) |collect| (|if| (eq (car tem) (quote define-file-info)) |then| (* \; "have to eval this to get the reader environment right for the rest of the file") (set-reader-environment (setq env (\\do-define-file-info file (cdr tem))))) tem) env)))))
+)
+
+(readline
+(lambda (rdtbl line lispxflg) (* ajb " 1-Aug-85 14:50") (declare (specvars line lispxflg spaceflg)) (prog ((fl t) tem spaceflg chrcode start) top (cond ((listp readbuf) (go lp2)) ((null (readp t)) (clearbuf t) (* |;;| "This is in case there is a c.r. in the single character buffer.  Note that if there were other atoms on the line terminated by a c.r., after readline finished, the c.r. would be gone.  Thus this check for consistency.") (return line))) lp (setq spaceflg nil) lp1 (cond ((syntaxp (setq chrcode (chcon1 (setq tem (peekc fl (or rdtbl t))))) (quote eol)) (* \; "C.R.") (readc fl) (cond ((and line spaceflg) (and (eq fl t) (prin1 (quote |...|) t)) (go lp)) (t (go out)))) ((or (syntaxp chrcode (quote rightparen) rdtbl) (syntaxp chrcode (quote rightbracket) rdtbl)) (read fl rdtbl) (and lispxflg (null (cdr line)) (setq line (nconc1 line nil))) (* |;;| "The `]' is treated as NIL if it is the only thing on the line when READLINE is called with LISPXFLG=T.  The reason for CDR is that LISPX calls readline giving it the initial atom on the line.") (go out)) ((and (eq chrcode (charcode space)) (syntaxp chrcode (quote sepr) rdtbl)) (* \; "SPACE the syntaxp check is to allow for space being a read macro") (setq spaceflg t) (readc fl) (go lp1))) (setq tem (cond ((or (eq lispxreadfn (quote read)) (imagestreamtypep t (quote text))) (* \; "So the call will be linked, so the user can break on read.") (* \; "TEXTSTREAMS must use READ") (read fl rdtbl)) (t (apply* lispxreadfn fl rdtbl)))) (* |;;| "The reason for not embedding the setq in the ncon1 is that the act of reading may change L, e.g.  via a ^W read macro.") (cond ((eq tem histstr4) (* |;;| "fo implemeing read macros that are for effect only.  ignore the value returned by read.  if we had soft interrupts from iowaits, we wouldnt needs this.") (go lp1))) (setq line (nconc1 line tem)) (cond ((syntaxp (setq tem (chcon1 (lastc fl))) (quote rightbracket) rdtbl) (* |;;| "The reason why readline is driven by the last character insead of doing a peekc before reding is that due to eadmacros, it is possible for several things to be read, e.g.  A B C '(FOO) terminated by square bracket should terminate the line.  However, it is not sufficient just to check whether the value read is a list or not since `()' and NIL must also be treated differently.") (go out)) ((null (syntaxp tem (quote rightparen) rdtbl)) (go lp)) ((and lispxflg (null spaceflg) (null (cddr line))) (* |;;| "A list terminates the line if if called from LISPX and is both the firt thing on a line and not preceded by a space.") (go out)) (t (and (eq fl t) (prin1 (quote |...|) t)) (go lp))) (go lp) out (cond ((and (listp line) ctrluflg) (* \; "User typed control-u during reading.") (setq ctrluflg nil) (cond ((null (nlsetq (edite line))) (* \; "Exited with a STOP.") (setq rereadflg (quote abort)))))) (cond (start (cond ((neq start (cadadr readbuf)) (shouldnt)) (t (* \; "the rplaca is to handle small numbers") (rplaca (cdadr readbuf) (setn start (getfileptr fl))))) (setfileptr fl -1))) (return line) lp2 (cond ((eq (car readbuf) histstr0) (setq readbuf (cdr readbuf)) (return line)) ((null (setq readbuf (lispxreadbuf readbuf))) (* |;;| "checks for things like HISTSTR2 etc.  this can occur if you redo an event contaiing a readline.  can also occur under a break if you call a function which calls readline, because break unreads stuff, leaving the `from event' tag on.") (go top))) (setq tem readbuf) (setq readbuf (cdr readbuf)) (setq line (nconc1 line (car tem))) (cond ((null readbuf) (* |;;| "really shouldnt happen, as there should be a `<c.r.>' marker.  however, in the case of a fix command, user might delete it.") (return line))) (go lp2)))
+)
+
+(remproplist
+(lambda (atm props) (* \; "wt: 30-JUL-77 13 32") (prog (lst lst1 tem) (cond ((null (setq lst1 (setq lst (getproplist atm)))) (return nil))) lp (cond ((nlistp lst1) (go out)) ((not (fmemb (car lst1) props))) ((eq lst1 lst) (setq lst (cddr lst))) ((setq tem (cddr lst1)) (rplnode2 lst1 tem) (go lp)) (t (* \; "the last property, also not the first one.") (rplacd (nleft lst 1 lst1)) (go out))) (setq lst1 (cddr lst1)) (go lp) out (setproplist atm lst) (return)))
+)
+
+(resetbufs
+(nlambda forms (* |lmm| " 9-APR-78 00:27") (declare (localvars . t)) (prog (($$bufs (progn (linbuf) (sysbuf) (clbufs nil t readbuf)))) (return (prog1 (apply (function progn) forms (quote internal)) (and $$bufs (bkbufs $$bufs))))))
+)
+
+(tab
+(lambda (pos minspaces file) (prog (x) (cond ((not (igreaterp (iplus (setq x (position file)) (or (numberp minspaces) 1)) pos)) (spaces (idifference pos x) file)) ((eq minspaces t) (* \; "MINSPACES=T means space over to POS unless you are already beyond it.")) (t (terpri file) (spaces pos file)))))
+)
+
+(unsaved1
+(lambda (fn typ) (* |bvm:| "29-Sep-86 23:24") (prog (def prop) top (cond ((not (litatom fn))) ((setq def (cond ((setq prop typ) (get fn typ)) ((get fn (setq prop (quote expr)))) ((get fn (setq prop (quote code)))) ((get fn (setq prop (quote subr)))))) (virginfn fn t) (/remprop fn prop) (cond ((neq dfnflg t) (savedef fn))) (/putd fn def t) (and addspellflg (addspell fn)) (return prop)) ((or (getd fn) (getproplist fn)) (* \; "Not a misspelling") (return (cond (typ (concat "(" typ " not found)")) (t "(nothing found)")))) ((setq prop (fncheck fn t)) (setq fn prop) (go top))) (error fn (quote "not a function"))))
+)
+
+(writefile
+(lambda (x file) (* |bvm:| "30-Aug-86 16:45") (* |;;| "X is a list of expression (or an atom that evaluates to a list) X is written on FILE.  If X begins with a PRINTDATE expression, a new one is written.  Following the PRETTYDEF conventions, if FILE is listed, it is left open.  Otherwise a stop is printed and it is closed.") (with-reader-environment *old-interlisp-read-environment* (resetlst (prog (stream opened) (cond ((listp file) (setq file (car file)) (setq opened t))) (resetsave nil (list (function close-and-maybe-delete) (setq stream (openstream file (quote output))))) (resetsave (output stream)) (cond ((atom x) (setq x (eval x)))) (prin1 "
+(PRIN1 (QUOTE \"
+WRITEFILE OF ") (prin2 (setq file (fullname stream))) (prin1 " MADE BY ") (prin1 (username)) (prin1 " ON ") (prin1 (date)) (prin1 "
+\")T)
+
+") (|for| x1 |in| x |do| (printdef x1 nil (eq (car (listp x1)) (quote defineq))) (terpri)) (|if| (null opened) |then| (endfile)) (return file)))))
+)
+
+(close-and-maybe-delete
+(lambda (stream) (* \; "Edited 19-Mar-87 16:43 by jrb:") (* |;;;| "For use in RESETSAVE.  Closes STREAM, and if happened under error, deletes the file") (|if| (openp stream) |then| (setq stream (closef stream))) (and resetstate (delfile stream)))
+)
+
+(unsafe.to.modify
+(lambda (fn option) (* |lmm| "31-Jul-85 02:06") (|if| (fmemb fn unsafe.to.modify.fns) |then| (printout t "Warning: " fn " may be unsafe to " (or option "modify") " -- continue? ") (|if| (eq (|if| (getd (quote askuser)) |then| (askuser dwimwait (quote n)) |else| (read t)) (quote y)) |then| nil |else| t)))
+)
+)
+
+(RPAQQ UNSAFE.TO.MODIFY.FNS (/PUT /PUTD /REMPROP ADDCHAR ADDCHAR ADDSPELL ADVISEWDS ALLOCSTRING APPLY APPLY ASSOC AWAIT.EVENT BITBLT.ERASE BITMAPCOPY BITMAPCREATE BKBITBLT BLOCK BLOCK BLTCHAR BLTCHAR BLTSHADE BREAK BREAK0 BREAK1 CHARSET CHCON1 CLEAR.LINE? CLOCK CLOCKDIFFERENCE CLOSEW CONCAT CREATEW CURSOR CURSORHOTSPOT DELETETO DO.CRLF DRAWLINE DSPBACKUP DSPCLIPPINGREGION DSPCLIPPINGREGION DSPCREATE DSPDESTINATION DSPFILL DSPFONT DSPLEFTMARGIN DSPRIGHTMARGIN DSPSCROLL DSPSOURCETYPE DSPXOFFSET DSPXPOSITION DSPYPOSITION EQLENGTH EQP EQUAL ERASE.TO.END.OF.LINE ERASE.TO.END.OF.PAGE ERRORMESS1 ERRORSET EVAL EVALQT EXPRP FASSOC FILENAMEFIELD FIXR FLIPCURSOR FLAST FMEMB GENSYM GETHASH GETMOUSESTATE GETPROP GETSTREAM GETWINDOWUSERPROP HELP HISTORYSAVE IDATE IMAGESTREAMTYPEP IMOD INIT.CURSOR INTEGERLENGTH INTERRUPTABLE INTERSECTREGIONS IREMAINDER LAST LASTC LISPX LISPX/ LISPXFIND LISPXFIND1 LISPXPRINT LISPXPUT LISPXPUT LISPXREAD LISPXREADBUF LISPXUNREAD LISTGET LISTPUT MEMB MKATOM MKSTRING MONITOR.AWAIT.EVENT MOVETOUPPERLEFT NOTIFY.EVENT NTH NTHCHARCODE OBTAIN.MONITORLOCK OPENW OPENWP OVERFLOW? PACK* PAGEHEIGHT PRIN1 PRIN1 PRIN2 PRIN2 PRIN3 PRIN3 PRINT PRINT PRINTCCODE PRINTLEVEL PROGN PROMPTCHAR PUTWINDOWPROP QUOTE READ CL:READ READLINE READLINE READP REALSTKNTH REGIONP RELEASE.PUP RELSTK RESETRESTORE RESHOWTITLE RETFROM RPLCHARCODE RPLSTRING SETCURSOR SETTERMTABLE SHOWPRIN2 SHOWPRINT SHOWWFRAME SHOWWTITLE SKIPSEPRS SPACES STKPOS STREAMP SUBATOM SUBSTRING SYNTAXP TERPRI TIMEREXPIRED? TIMEREXPIRED? TOTOPW TTBIN TTBITWIDTH TTCRLF TTDELETELINE TTSKREAD TTWAITFORINPUT TTWAITFORINPUT TTYDISPLAYSTREAM TTYIN TTYIN.CLEANUP TTYIN.FINISH TTYIN.READ TTYIN.SETUP TTYIN1 TTYIN1RESTART TTYINREAD TYPENAME UNBREAK0 UNDOSAVE UNPACKFILENAME.STRING WFROMDS WINDOW.MOUSE.HANDLER))
+
+
+
+(* \; "FILEDATE, for finding out the creation date of source files, from the compiled files.")
+
+
+
+
+(* |;;| 
+"FASL isn't loaded when MACHINEINDEPENDENT is, so we have to fake the FASL checker for now.  It's defined in FASLOAD."
+)
+
+(DEFINEQ
+
+(filedate
+(lambda (file cflg) (* \; "Edited 17-Feb-89 11:26 by jds") (* \; "CFLG IS T FOR COMPILED FILES") (cond (file (car (nlsetq (resetlst (prog (stream oldptr value) (cond ((setq stream (openp file (quote input))) (setq oldptr (getfileptr stream))) (t (* \; "OPENSTREAM used instead of INFILEP to allow for error correction.") (resetsave nil (list (quote closef) (setq stream (openstream file (quote input))))))) (* |;;| "This code used to have some gross kludgery for checking file dates of grouped files during the loadup procedure, now gone -bvm") (cond ((randaccessp stream) (setfileptr stream 0) (cond ((setq value (fasl-filedate stream cflg)) (* |;;| " Aha, a Dfasl file") (* |;;| " Having decided it's a DFASL, FASL-FILEDATE returned the date, and it's in VALUE already.")) (t (* \; "Any other filetype") (setfileptr stream 0) (cl:multiple-value-bind (env form) (\\parse-file-header stream (quote return)) (cond ((and cflg (listp form)) (* \; "First expression is for compiled file, next one is its source") (setq form (with-reader-environment env (read stream))))) (cond ((eq (car (listp form)) (quote filecreated)) (setq value (car (listp (cdr form))))))))))) (cond (oldptr (setfileptr stream oldptr))) (return value))))))))
+)
+)
+
+(MOVD? (QUOTE NILL) (QUOTE FASL-FILEDATE))
+
+(MOVD? (QUOTE CL:FMAKUNBOUND) (QUOTE UNDOABLY-FMAKUNBOUND))
+
+
+
+(* \; "used in FNS.PUTDEF before CMLUNDO loaded")
+
+
+
+
+(* \; "Functions for retrieving and remembering FILEMAPs and file reader environments")
+
+(DEFINEQ
+
+(filemap
+(nlambda (filemap) (* |bvm:| "27-Aug-86 23:41") (* |;;;| "Called by the FILEMAP expression at the end of every standard Interlisp file") (declare (usedfree filecreatedlst)) (* \; "FILECREATEDLST bound in LOAD or LOADFNS and set by FILECREATED") (putfilemap (fullname (getstream nil (quote input))) filemap filecreatedlst nil t))
+)
+
+(\\parse-file-header
+(lambda (stream filecreatedfn returnform initialenv) (* |bvm:| " 8-Sep-86 12:37") (* |;;;| "Parses the stuff at front of STREAM, which is assumed positioned at zero, and returns as its first value a reader environment for the file, or NIL if this is not a Lisp source file.  If a FILECREATED expression is found, then calls FILECREATEDFN with the file pointer positioned immediately after the symbol FILECREATED, and returns the fn's value as its second value.  FILECREATEDFN = RETURN returns the entire FILECREATED expression.   Finally, in the case where no FILECREATED expression was found, returns as second value the actual first expression if RETURNFORM is true (this is needed for callers that don't want to lose when the stream is non-randaccess).
+
+The first expression on the file is read in the current reader environment.  Usually this wants to be IL.") (with-reader-environment (or initialenv *old-interlisp-read-environment*) (selcharq (skipseprcodes stream) (";" (* \; "Assume is common lisp file") *common-lisp-read-environment*) ("(" (* \; "Start of Lisp expression, could be either DEFINE-FILE-INFO or FILECREATED") (prog (env firstsym result here) top (setq here (getfileptr stream)) (readccode stream) (setq firstsym (and (syntaxp (skipseprcodes stream) (quote other)) (ratom stream))) (cond ((and (eq firstsym (quote define-file-info)) (null env)) (setq env (\\do-define-file-info stream (cl:read-delimited-list (charcode ")") stream))) (cond ((and filecreatedfn (eq (skipseprcodes stream) (charcode "("))) (set-reader-environment env) (go top)) (t (* |;;| "Odd case--a DEFINE-FILE-INFO expression but no FILECREATED afterwards or caller doesn't want to see it") (return (cl:values env nil here)))))) (|if| (eq firstsym (quote filecreated)) |then| (or env (setq env *old-interlisp-read-environment*)) (setq result (selectq filecreatedfn (return (cons (quote filecreated) (cl:read-delimited-list (charcode ")") stream))) (nil nil) (cl:funcall filecreatedfn stream))) |elseif| returnform |then| (setq result (cl:read-delimited-list (charcode ")") stream))) (return (cl:values env result here)))) nil)))
+)
+
+(get-environment-and-filemap
+(lambda (stream dontcache) (* |bvm:| "26-Sep-86 11:39") (* |;;| "Returns three values: the stream's reader environment, its filemap, either obtained from the file itself, or from its property list, and the byte location where the FILECREATED expression starts.") (let ((full (cond ((streamp stream) (fullname stream)) (t stream))) mapentry map env oldpos) (setq mapentry (gethash full *filemap-hash*)) (cond ((and mapentry (or (setq map (|fetch| fmfilemap |of| mapentry)) (null usemapflg))) (* |;;| "Have all we need.  Return the map only if USEMAPFLG is true or the map was obtained by scanning the file") (|replace| fmrecent? |of| mapentry |with| t) (cl:values (|fetch| fmenvironment |of| mapentry) (and map (or usemapflg (not (|fetch| fmfromfile? |of| mapentry))) map) (|fetch| fmfilecreatedloc |of| mapentry) (|fetch| fmfilecreatedlst |of| mapentry))) ((or (not (setq stream (openp stream (quote input)))) (not (randaccessp stream))) (* \; "Out of luck") nil) (t (* \; "Have to read file") (setq oldpos (getfileptr stream)) (setfileptr stream 0) (cl:multiple-value-bind (env newmap fclocation) (\\parse-file-header stream (cond ((and (null map) usemapflg) (function get-filemap-from-filecreated)))) (setfileptr stream oldpos) (cond ((and newmap (not dontcache)) (putfilemap full newmap nil env t fclocation))) (cl:values env (or newmap map) fclocation))))))
+)
+
+(lookup-environment-and-filemap
+(lambda (full rootnamep) (* \; "Edited  4-May-88 15:30 by bvm") (* |;;| "Returns four values: the file's reader environment, its filemap, either obtained from the file itself, or from its property list, the byte location where the FILECREATED expression starts, and the FILECREATEDLST of the file (used by ADDFILE).  Unlike GET-ENVIRONMENT-AND-FILEMAP, this function merely looks up cached info. If ROOTNAMEP is true, then FULLNAME is actually a root name, and we want to look up the most recent.") (let ((highest-version -1) mapentry) (|if| rootnamep |then| (maphash *filemap-hash* (function (lambda (entry key) (let (v) (|if| (and (strpos full key nil nil nil nil uppercasearray) (string-equal full (rootfilename key)) (igreaterp (setq v (or (filenamefield key (quote version)) 0)) highest-version)) |then| (setq mapentry entry) (setq highest-version v)))))) |else| (setq mapentry (gethash full *filemap-hash*))) (|if| mapentry |then| (|replace| fmrecent? |of| mapentry |with| t) (cl:values (|fetch| fmenvironment |of| mapentry) (|fetch| fmfilemap |of| mapentry) (|fetch| fmfilecreatedloc |of| mapentry) (|fetch| fmfilecreatedlst |of| mapentry)))))
+)
+
+(get-filemap-from-filecreated
+(lambda (stream) (* |bvm:| "29-Aug-86 15:06") (* |;;| "get map from address shown in FILECREATED expression, which is of form (FILECREATED file date mapaddr)") (skread stream) (skread stream) (car (nlsetq (let ((mapaddr (read stream))) (cond ((and (fixp mapaddr) (lessp mapaddr (geteofptr stream)) (progn (setfileptr stream mapaddr) (eq (skipseprcodes stream) (charcode "("))) (eq (car (setq mapaddr (read stream))) (quote filemap))) (cadr mapaddr)))))))
+)
+
+(\\filemap-hashoverflow
+(lambda (harray) (* |bvm:| "26-Sep-86 12:11") (* |;;;| "Called when *FILEMAP-HASH* overflows.  Trim back old entries") (let ((numentries (harrayprop harray (quote numkeys))) entries) (|if| (> numentries *filemap-limit*) |then| (maphash harray (function (lambda (val key) (* \; "Gather up contents of table") (let ((root (|fetch| fmrootname |of| val)) tem) (|if| (not (setq tem (fassoc root entries))) |then| (|push| entries (setq tem (list root)))) (|push| (cdr tem) (cons (|if| (cdr (|fetch| fmfilecreatedlst |of| val)) |then| (* \; "compiled file, don't keep if there is no other reason to") 0 |else| (filenamefield key (quote version))) (cons key val))))))) (* |;;| "each element of ENTRIES is (root . versions), where each version is (vers# fullname . hashvalue)") (|for| group |in| entries |bind| onfilelst pair nflush dates |do| (setq onfilelst (memb (car group) filelst)) (setq nflush (- (length (cdr group)) *filemap-versions*)) (|for| tail |on| (progn (* \; "Sort files by increasing version") (sort (cdr group) t)) |as| i |from| 1 |do| (setq pair (cdar tail)) (|if| (and (<= i nflush) (or (null (setq dates (get (car group) (quote filedates)))) (not (string.equal (cdar dates) (car pair))))) |then| (* |;;| "flush old versions until we have gotten down to limit.  The STRING.EQUAL test is because the \"current version\" of a file might have a lower version number (being on a different directory) than the highest version you have looked at anywhere") (remhash (car pair) harray) (|add| numentries -1) |elseif| (|fetch| fmrecent? |of| (cdr pair)) |then| (* \; "spare recently touched files, but clear the flag") (|replace| fmrecent? |of| (cdr pair) |with| nil) |elseif| (or (not onfilelst) (cdr tail)) |then| (* \; "trim maps not looked at recently, but spare the highest version of anything on filelst") (remhash (car pair) harray) (|add| numentries -1)))) (* |;;| "finally say how big to rehash the array.  Normally we want it not to change size.") (imax *filemap-limit* (fixr (ftimes numentries 1.2))))))
+)
+
+(flushfilemaps
+(lambda (rootname) (* |bvm:| "26-Sep-86 11:37") (|if| (eq rootname t) |then| (clrhash *filemap-hash*) |else| (maphash *filemap-hash* (function (lambda (me fullname) (|if| (string-equal (|fetch| fmrootname |of| me) rootname) |then| (remhash fullname *filemap-hash*)))))) rootname)
+)
+
+(lispsourcefilep
+(lambda (file) (* |bvm:| "29-Sep-86 23:15") (* |;;;| "If the first few characters of FILE `look like' those output by MAKEFILE then return the alleged address in the file of its FILEMAP expression.") (resetlst (|if| (not (streamp file)) |then| (resetsave nil (list (quote closef) (setq file (openstream file (quote input)))))) (|if| (randaccessp file) |then| (let ((here (getfileptr file))) (prog1 (cl:multiple-value-bind (env map) (\\parse-file-header file (function (lambda (stream) (* \; "Pointed now right after the FILECREATED expression") (car (nlsetq (skread stream) (skread stream) (fixp (read stream))))))) map) (setfileptr file here))))))
+)
+
+(getfilemap
+(lambda (stream fl) (* |bvm:| "27-Aug-86 15:48") (* |;;;| "Value is map for STREAM either obtained from the file itself, or from its property list.  STREAM is presumed open.  FL is (NAMEFIELD STREAM T)") (and usemapflg (cl:multiple-value-bind (env map) (get-environment-and-filemap stream) map)))
+)
+
+(putfilemap
+(lambda (file filemap filcreatedlst env fromfile? fclocation) (* |bvm:| "26-Sep-86 11:51") (* \; "Called from: LOAD LOADFNS PRETTYDEF FILEMAP") (* |;;| "As far as I can tell, the only use for FILCREATEDLST is to tell ADDFILE in LOADFNS that the file is a compiled file") (|if| (null filemap) |then| (remhash file *filemap-hash*) |elseif| buildmapflg |then| (let* ((oldentry (gethash file *filemap-hash*)) (newentry (|create| filemaphash |using| oldentry fmfromfile? _ fromfile? fmrecent? _ t))) (|if| (null oldentry) |then| (|replace| fmrootname |of| newentry |with| (rootfilename file (cdr filcreatedlst)))) (|if| env |then| (|replace| fmenvironment |of| newentry |with| env) |elseif| (null oldentry) |then| (|replace| fmenvironment |of| newentry |with| (make-reader-environment))) (|if| (listp filemap) |then| (|replace| fmfilemap |of| newentry |with| filemap)) (|if| fclocation |then| (|replace| fmfilecreatedloc |of| newentry |with| fclocation)) (|if| filcreatedlst |then| (|replace| fmfilecreatedlst |of| newentry |with| filcreatedlst)) (puthash file newentry *filemap-hash*))))
+)
+
+(updatefilemap
+(lambda (stream filemap) (* |bvm:| "24-Oct-86 17:15") (* |;;;| "Writes new FILEMAP on file currently open as STREAM.  If we return T, the stream has been closed.
+
+This has little hope of working any more.") (|if| nil |then| (* \; "This has little hope of working any more") (let ((declarestring (concat "(DECLARE: DONTCOPY
+  " "(FILEMAP")) filemaplocadr tem filemapadr filemaploclen fullname) (setfileptr stream 0) (skipseprs stream) (* \; "Could be some font shifts or other garbage") (readc stream) (* \; "Skip paren or bracket") (|if| (and (eq (ratom stream) (quote filecreated)) (progn (skread stream) (* \; "Date") (skread stream) (* \; "Name") (|do| (cond ((eq (setq tem (readccode stream)) (charcode space)) (* \; "found a space") (return t)) ((not (syntaxp tem (quote seprchar))) (* \; "no spaces, lose") (return))))) (fixp (setq filemapadr (progn (* \; "skip over seprs") (setq filemaplocadr (getfileptr stream)) (* \; "Address of first character of file-map location") (prog1 (ratom stream) (setq filemaploclen (idifference (getfileptr stream) filemaplocadr)))))) (setq filemapadr (or (ffilepos declarestring stream (fix (times filemapadr 0.9))) (ffilepos declarestring stream 0))) (eq (progn (skread stream) (ratom stream)) (quote stop)) (ileq (nchars filemapadr t) filemaploclen)) |then| (* |;;| "normally, this will be called so that we are positioned at the filemap.  --- check for (FILECREATED & & number --) first to avoid searching compiled files for filemap.") (setq fullname (closef stream)) (|if| (setq stream (car (nlsetq (openstream fullname (quote both) (quote old) nil (quote (don\'t.change.date)))))) |then| (resetlst (resetsave nil (list (quote closef) stream)) (setfileptr stream filemapadr) (prin3 "(DECLARE: DONTCOPY
+  " stream) (setq filemapadr (getfileptr stream)) (prin3 "(FILEMAP " stream) (position stream (constant (nchars "(FILEMAP "))) (let ((*print-radix* 10)) (prin2 filemap stream)) (prin1 "))" stream) (terpri stream) (print (quote stop) stream) (setfileptr stream filemaplocadr) (printnum (list (quote fix) filemaploclen) filemapadr stream) (cond ((neq dfnflg t) (prin3 "****rewrote file map for " t) (print fullname t t))))) t))))
+)
+
+(print-reader-environment
+(lambda (env stream) (* |bvm:| "24-Oct-86 15:53") (* |;;;| "If ENV is not the old default interlisp reader environment, writes a DEFINE-FILE-INFO expression on STREAM that will produce this environment when the file is loaded.") (|if| (not (equal-reader-environment env *old-interlisp-read-environment*)) |then| (let ((*package* *interlisp-package*) (*print-base* 10) pkg) (print (cons (quote define-file-info) (or (|fetch| respec |of| env) (bquote ((\\\,@ (and (setq pkg (|fetch| repackage |of| env)) (bquote (:package (\\\, (cl:package-name pkg)))))) :readtable (\\\, (readtableprop (|fetch| rereadtable |of| env) (quote name))) :base (\\\, (|fetch| rebase |of| env)))))) stream filerdtbl))))
+)
+)
+
+(RPAQ? *FILEMAP-LIMIT* 20)
+
+(RPAQ? *FILEMAP-VERSIONS* 2)
+
+(RPAQ? *FILEMAP-HASH* (HASHARRAY *FILEMAP-LIMIT* (FUNCTION \\FILEMAP-HASHOVERFLOW) (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING.EQUAL)))
+(DECLARE\: EVAL@COMPILE DONTCOPY 
+(DECLARE\: EVAL@COMPILE
+
+(RECORD FILEMAPHASH (FMENVIRONMENT FMROOTNAME FMFROMFILE? FMRECENT? FMFILECREATEDLOC FMFILECREATEDLST . FMFILEMAP)
+)
+)
+
+(DECLARE\: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS *FILEMAP-LIMIT* *FILEMAP-VERSIONS* *FILEMAP-HASH*)
+)
+)
+(* * LVLPRINT)
+
+(DEFINEQ
+
+(lvlprint
+(lambda (x file carlvl cdrlvl tail) (* |wt:| 12-may-76 22 6) (lvlprin2 x file carlvl cdrlvl tail) (terpri file) x)
+)
+
+(lvlprin1
+(lambda (x file carlvl cdrlvl tail) (declare (specvars file prin2flg)) (prog (prin2flg) (lvlprin x carlvl cdrlvl tail) (return x)))
+)
+
+(lvlprin2
+(lambda (x file carlvl cdrlvl tail) (declare (specvars file prin2flg)) (* |wt:| 12-may-76 22 6) (prog ((prin2flg t)) (lvlprin x carlvl cdrlvl tail) (return x)))
+)
+
+(lvlprin
+(lambda (x carlvl cdrlvl tail) (* \; "Edited 10-Nov-87 13:10 by jds") (* \; "wt: 12-MAY-76 22 23") (cond ((nlistp x) (cond ((and tail (eq x (cdr (last tail))) (not (memb x tail))) (prin1 (quote "...  . ") file) (cond (prin2flg (prin2 x file t)) (t (prin1 x file))) (* |;;| "We use standard system read table for printing on grounds that even if this is going to a file, user is only dumping it with bpnt to look at it, not to read it back in.") (prin1 ")" file)) (prin2flg (prin2 x file t)) (t (prin1 x file)))) (t (prin1 (cond ((and tail (tailp x tail)) (* \; "Tail") (quote "... ")) (t "(")) file) (lvlprin0 x carlvl cdrlvl) (prin1 ")" file))))
+)
+
+(lvlprin0
+(lambda (x carlvl cdrlvl) (* \; "Edited 10-Nov-87 13:11 by jds") (* \; "LVLPRIN0 is like subprint.  it prints the interior segment of a list") (and (eq (car x) clisptranflg) (setq x (cddr x))) (prog ((cdrlvl0 cdrlvl)) (go lp1) lp (cond ((null (setq x (cdr x))) (return)) ((nlistp x) (prin1 (quote " . ") file) (cond (prin2flg (prin2 x file t)) (t (prin1 x file))) (return)) (t (spaces 1 file))) lp1 (cond ((eq cdrlvl 0) (prin1 "--" file) (return)) ((nlistp (car x)) (cond (prin2flg (prin2 (car x) file t t)) (t (prin1 (car x) file)))) ((or (eq carlvl 0) (and cdrlvl0 (eq (sub1 cdrlvl0) 0))) (* \; "the reason for the second check is that why bother to recurse only to print (--).  & is better") (prin1 (quote &) file)) ((and (eq file t) (superprinteq (caar x) commentflg) **comment**flg) (prin1 **comment**flg file)) (t (prin1 (quote \() file) (lvlprin0 (car x) (and carlvl (iplus carlvl (cond ((minusp carlvl) 1) (t -1)))) (and cdrlvl0 (sub1 cdrlvl0))) (prin1 (quote \)) file))) (and cdrlvl (setq cdrlvl (sub1 cdrlvl))) (go lp)))
+)
+)
+
+
+
+(* \; "used by PRINTOUT")
+
+(DEFINEQ
+
+(flushright
+(lambda (pos x min p2flag centerflag file) (* |lmm| "10-Feb-86 12:10") (* |;;| "Right-flushes X at position POS.  If P2FLAG, uses PRIN2-pname;  if CENTERFLAG, centers X between current position and POS") (setq pos (idifference (cond ((minusp pos) (idifference (position file) pos)) ((zerop pos) (linelength nil file)) (t pos)) (nchars x p2flag))) (cond (centerflag (setq pos (quotient (iplus pos (position file)) 2)))) (tab pos min file) (cond (p2flag (prin2 x file)) (t (prin1 x file))))
+)
+
+(printpara
+(lambda (lmarg rmarg list p2flag parenflag file) (* |rmk:| "22-MAY-81 13:45") (* |;;| "Prints LIST in paragraph format.  The first line starts at the current line position, but all subsequent lines begin at LMARG (0 is the left margin, NIL is the current POSITION, negative LMARG is (POSITION) + LMARG).  Printing is with PRIN2 if P2FLAG, otherwise PRIN1.  The right margin is at column RMARG if RMARG is positive, (LINELENGTH NIL FILE) minus RMARG for RMARG LEQ 0") (declare (specvars lmarg rmarg p2flag file)) (cond ((null lmarg) (setq lmarg (position file))) ((minusp lmarg) (setq lmarg (idifference (position file) lmarg)))) (cond ((ileq rmarg 0) (setq rmarg (iplus rmarg (linelength nil file))))) (position file (printpara1 list (position file) (cond (parenflag 1) (t 0)) (cond (parenflag 1) (t 0)))))
+)
+
+(printpara1
+(lambda (list pos opencount closecount) (* |wt:| " 9-SEP-78 09:54") (* |;;| "PRIN3 and PRIN4 are used here, so we don't have to set and unset LINELENGTH.  We keep our own idea of the current line position in POS, which is returned as the value of PRINTPARA1.  OPENCOUNT is the number of open parens that must precede the first non-list we print, CLOSECOUNT is the number of close parens that should follow the last non-list we print.  They are passed as arguments so that their numbers can be taken into account in deciding whether a non-list fits on the line or not.") (prog ($$val l len (cc 0)) $$lp (setq l (car (or (listp list) (go $$out)))) (* \; "POS is the correct column position at the end of each iteration") (cond ((nlistp (cdr list)) (setq cc closecount))) (* \; "The last iteration.  Now we really want to use CLOSECOUNT, so we move it to CC.") (cond ((listp l) (setq pos (printpara1 l pos (add1 opencount) (add1 cc))) (setq opencount 0) (* \; "The lower call printed the open and closed parens, including the ones for this level, if any.") (setq cc 0)) (t (cond ((ilessp rmarg (iplus opencount cc (setq pos (iplus pos (setq len (nchars l p2flag)))))) (terpri file) (* \; "TAB wouldn't work, cause POSITION doesn't know where we are.") (rptq lmarg (prin3 (quote \ ) file)) (setq pos (iplus lmarg len)))) (cond ((igreaterp opencount 0) (rptq opencount (prin3 (quote \() file)) (setq pos (iplus pos opencount)) (setq opencount 0))) (cond (p2flag (prin4 l file)) (t (prin3 l file))))) (cond ((and (igreaterp rmarg (add1 pos)) (listp (cdr list))) (prin3 (quote \ ) file) (setq pos (add1 pos)))) $$iterate (setq list (cdr list)) (go $$lp) $$out (rptq cc (cond ((ilessp rmarg (setq pos (add1 pos))) (terpri file) (* \; "We do the closes one-by-one, in case they won't fit on a line with only 1 atom") (rptq lmarg (prin3 (quote \ ) file)) (prin3 (quote \)) file) (setq pos (add1 lmarg))) (t (prin3 (quote \)) file)))) (return $$val)) pos)
+)
+)
+
+
+
+(* \; "SUBLIS and friends")
+
+(DEFINEQ
+
+(sublis
+(lambda (alst expr flg) (cond ((listp expr) ((lambda (d a) (cond ((or (neq a (car expr)) (neq d (cdr expr)) flg) (cons a d)) (t expr))) (and (cdr expr) (sublis alst (cdr expr) flg)) (sublis alst (car expr) flg))) (t (let ((y (fassoc expr alst))) (cond (y (cond (flg (copy (cdr y))) (t (cdr y)))) (t expr))))))
+)
+
+(subpair
+(lambda (old new expr flg) (* |lmm| "25-FEB-82 15:29") (cond ((listp expr) ((lambda (d a) (cond ((or (neq a (car expr)) (neq d (cdr expr)) flg) (cons a d)) (t expr))) (and (cdr expr) (subpair old new (cdr expr) flg)) (subpair old new (car expr) flg))) (t (prog nil lp (return (cond ((null old) expr) ((nlistp old) (cond ((eq expr old) (cond (flg (copy new)) (t new))) (t expr))) ((eq expr (car old)) (cond (flg (copy (car new))) (t (car new)))) (t (setq old (cdr old)) (setq new (cdr new)) (go lp))))))))
+)
+
+(dsublis
+(lambda (alst expr flg) (cond ((nlistp expr) (sublis alst expr flg)) (t (let ((a (dsublis alst (car expr) flg))) (or (eq a (car expr)) (rplaca expr a))) (let ((d (dsublis alst (cdr expr) flg))) (or (eq d (cdr expr)) (rplacd expr d))) expr)))
+)
+)
+(* * CONSTANTS)
+
+(DEFINEQ
+
+(constantok
+(lambda (x depth) (* |lmm| " 1-OCT-78 22:03") (or depth (setq depth 100)) (cond ((or (smallp x) (stringp x) (floatp x)) depth) ((fixp x) (and (not (smallp (iplus x))) depth)) ((litatom x) (and (igreaterp (nchars x) 0) depth)) ((listp x) (and (setq depth (constantok (car x) (sub1 depth))) (constantok (cdr x) depth)))))
+)
+)
+
+(MOVD? (QUOTE EVQ) (QUOTE CONSTANT))
+
+(MOVD? (QUOTE EVQ) (QUOTE DEFERREDCONSTANT))
+
+(MOVD? (QUOTE EVQ) (QUOTE LOADTIMECONSTANT))
+(* * SCRATCHLIST)
+
+
+(PUTPROPS SCRATCHLIST MACRO ((SCRATCHLIST . FORMS) ((LAMBDA (!SCRATCHLIST !SCRATCHTAIL) (DECLARE (SPECVARS !SCRATCHLIST !SCRATCHTAIL)) (SETQ !SCRATCHTAIL !SCRATCHLIST) (PROGN . FORMS) (COND ((EQ !SCRATCHTAIL !SCRATCHLIST) NIL) (T (PROG ((L2 (CDR !SCRATCHLIST))) (RPLACD !SCRATCHLIST (PROG1 (CDR !SCRATCHTAIL) (RPLACD !SCRATCHTAIL NIL))) (FRPLACD (FLAST !SCRATCHLIST) L2) (RETURN L2))))) (OR (LISTP SCRATCHLIST) (CONS)) NIL)))
+
+(PUTPROPS ADDTOSCRATCHLIST MACRO ((VALUE) (FRPLACA (SETQ !SCRATCHTAIL (OR (LISTP (CDR !SCRATCHTAIL)) (CDR (FRPLACD !SCRATCHTAIL (CONS))))) VALUE)))
+
+(PUTPROPS SCRATCHLIST INFO EVAL)
+(DECLARE\: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS SYSFILES LOADOPTIONS LISPXCOMS CLISPTRANFLG COMMENTFLG HISTSTR4 LISPXREADFN REREADFLG HISTSTR0 CTRLUFLG NOLINKMESS PROMPTCHARFORMS PROMPT#FLG FILERDTBL SPELLINGS2 USERWORDS BELLS CLISPARRAY)
+)
+(DEFINEQ
+
+(nlambda.args
+(lambda (x) (* |bvm:| "26-Apr-86 16:41") (* |;;;| "Standard function to take argument to NLAMBDA function, e.g. BREAK, and check to see if accidentally quoted.") (* |;;;| "Handles both BREAK 'FOO as a command and (BREAK 'FOO 'BAR).  In the former case, X is (QUOTE FOO), in the latter it is ((QUOTE FOO) (QUOTE BAR)).") (cond ((nlistp x) (and x (list x))) ((and (eq (car x) (quote quote)) (listp (cdr x)))) ((and (listp (car x)) (eq (caar x) (quote quote))) (cons (cadr (car x)) (nlambda.args (cdr x)))) (t x)))
+)
+)
+(DECLARE\: DONTEVAL@LOAD DOCOPY 
+
+(ADDTOVAR CLISPARRAY)
+
+(ADDTOVAR CLISPFLG)
+
+(ADDTOVAR CTRLUFLG)
+
+(ADDTOVAR EDITCALLS)
+
+(ADDTOVAR EDITHISTORY)
+
+(ADDTOVAR EDITUNDOSAVES)
+
+(ADDTOVAR EDITUNDOSTATS)
+
+(ADDTOVAR GLOBALVARS)
+
+(ADDTOVAR LCASEFLG)
+
+(ADDTOVAR LISPXBUFS)
+
+(ADDTOVAR LISPXCOMS)
+
+(ADDTOVAR LISPXFNS)
+
+(ADDTOVAR LISPXHIST)
+
+(ADDTOVAR LISPXHISTORY)
+
+(ADDTOVAR LISPXPRINTFLG)
+
+(ADDTOVAR NOCLEARSTKLST)
+
+(ADDTOVAR NOFIXFNSLST)
+
+(ADDTOVAR NOFIXVARSLST)
+
+(ADDTOVAR P.A.STATS)
+
+(ADDTOVAR PROMPTCHARFORMS)
+
+(ADDTOVAR READBUF)
+
+(ADDTOVAR READBUFSOURCE)
+
+(ADDTOVAR REREADFLG)
+
+(ADDTOVAR RESETSTATE)
+
+(ADDTOVAR SPELLSTATS1)
+
+
+(RPAQQ CHCONLST (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))
+
+(RPAQQ CHCONLST1 (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))
+
+(RPAQQ CHCONLST2 (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))
+
+(RPAQQ CLEARSTKLST T)
+
+(RPAQQ CLISPTRANFLG CLISP\ )
+
+(RPAQ HISTSTR0 "<c.r.>")
+
+(RPAQ HISTSTR2 "repeat")
+
+(RPAQ HISTSTR3 "from event:")
+
+(RPAQ HISTSTR4 "ignore")
+
+(RPAQQ LISPXREADFN READ)
+
+(RPAQQ USEMAPFLG T)
+
+
+(MAPC (QUOTE ((APPLY BLKAPPLY) (SETTOPVAL SETATOMVAL) (GETTOPVAL GETATOMVAL) (APPLY* BLKAPPLY*) (RPLACA FRPLACA) (RPLACD FRPLACD) (STKNTH FSTKNTH) (STKNAME FSTKNAME) (CHARACTER FCHARACTER) (STKARG FSTKARG) (CHCON DCHCON) (UNPACK DUNPACK) (ADDPROP /ADDPROP) (ATTACH /ATTACH) (DREMOVE /DREMOVE) (DSUBST /DSUBST) (NCONC /NCONC) (NCONC1 /NCONC1) (PUT /PUT) (PUTPROP /PUTPROP) (PUTD /PUTD) (REMPROP /REMPROP) (RPLACA /RPLACA) (RPLACD /RPLACD) (SET /SET) (SETATOMVAL /SETATOMVAL) (SETTOPVAL /SETTOPVAL) (SETPROPLIST /SETPROPLIST) (SET SAVESET) (PRINT LISPXPRINT) (PRIN1 LISPXPRIN1) (PRIN2 LISPXPRIN2) (SPACES LISPXSPACES) (TAB LISPXTAB) (TERPRI LISPXTERPRI) (PRINT SHOWPRINT) (PRIN2 SHOWPRIN2) (PUTHASH /PUTHASH) (QUOTE *) (FNCLOSER /FNCLOSER) (FNCLOSERA /FNCLOSERA) (FNCLOSERD /FNCLOSERD) (EVQ DELFILE) (NILL SMASHFILECOMS) (PUTASSOC /PUTASSOC) (LISTPUT1 PUTL) (NILL I.S.OPR) (NILL RESETUNDO) (NILL LISPXWATCH) (QUOTE ADDSTATS) (NILL FREEVARS) (QUOTE USEDFREE) (COPYBYTES COPYCHARS))) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X)))))
+
+(MAPC (QUOTE ((TIME PRIN1 LISPXPRIN1) (TIME SPACES LISPXSPACES) (TIME PRINT LISPXPRINT) (DEFC PRINT LISPXPRINT) (DEFC PUTD /PUTD) (DEFC PUTPROP /PUTPROP) (DOLINK FNCLOSERD /FNCLOSERD) (DOLINK FNCLOSERA /FNCLOSERA) (DEFLIST PUTPROP /PUTPROP) (SAVEDEF1 PUTPROP /PUTPROP) (MKSWAPBLOCK PUTD /PUTD))) (FUNCTION (LAMBDA (X) (AND (CCODEP (CAR X)) (APPLY (QUOTE CHANGENAME) X)))))
+
+(MAPC (QUOTE ((EVALQT (LAMBDA NIL (PROG (TEM) (RESETRESTORE NIL (QUOTE RESET)) LP (PROMPTCHAR (QUOTE _) T) (LISPX (LISPXREAD T T)) (GO LP)))) (LISPX (LAMBDA (LISPXX) (PRINT (AND LISPXX (PROG (LISPXLINE LISPXHIST TEM) (RETURN (COND ((AND (NLISTP LISPXX) (SETQ LISPXLINE (READLINE T NIL T))) (APPLY LISPXX (CAR LISPXLINE))) (T (EVAL LISPXX)))))) T T))) (LISPXREAD (LAMBDA (FILE RDTBL) (COND (READBUF (PROG1 (CAR READBUF) (SETQ READBUF (CDR READBUF)))) (T (READ FILE RDTBL))))) (LISPXREADP (LAMBDA (FLG) (COND ((AND READBUF (SETQ READBUF (LISPXREADBUF READBUF))) T) (T (READP T FLG))))) (LISPXUNREAD (LAMBDA (LST) (SETQ READBUF (APPEND LST (CONS HISTSTR0 READBUF))))) (LISPXREADBUF (LAMBDA (RDBUF) (PROG NIL LP (COND ((NLISTP RDBUF) (RETURN NIL)) ((EQ (CAR RDBUF) HISTSTR0) (SETQ RDBUF (CDR RDBUF)) (GO LP)) (T (RETURN RDBUF)))))) (LISPX/ (LAMBDA (X) X)) (LOWERCASE (LAMBDA (FLG) (PROG1 LCASEFLG (RAISE (NULL FLG)) (RPAQ LCASEFLG FLG)))) (FILEPOS (LAMBDA (STR FILE) (PROG NIL LP (COND ((EQ (PEEKC FILE) (NTHCHAR STR 1)) (RETURN T))) (READC FILE) (GO LP)))) (FILEPKGCOM (NLAMBDA NIL NIL)))) (FUNCTION (LAMBDA (L) (OR (GETD (CAR L)) (PUTD (CAR L) (CADR L))))))
+)
+(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA RESETBUFS DMPHASH FILESLOAD)
+
+(ADDTOVAR NLAML FILEMAP)
+
+(ADDTOVAR LAMA READFILE NLIST)
+)
+(DECLARE\: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+(PRETTYCOMPRINT MACHINEINDEPENDENTCOMS)
+
+(RPAQQ MACHINEINDEPENDENTCOMS ((COMS (* \; " \"File loader\"") (FNS LOAD? FILESLOAD DOFILESLOAD FINDFILE-WITH-EXTENSIONS) (INITVARS (*COMPILED-EXTENSIONS* (LIST FASL.EXT COMPILE.EXT)))) (COMS (* \; "random machine-independent utilities") (FNS DMPHASH HASHOVERFLOW) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS HASHOVERFLOW.ARRAYTEST HASHOVERFLOW.UPDATEARRAY)) (FNS BKBUFS CHANGENAME CHNGNM CLBUFS COMSNAME DEFINE FNS.PUTDEF EQMEMB EQUALN FNCHECK FNTYP1 LCSKIP MAPRINT MKLIST NAMEFIELD NAMEFIELD-STRING NLIST PRINTBELLS PROMPTCHAR RAISEP READFILE READLINE REMPROPLIST RESETBUFS TAB UNSAVED1 WRITEFILE CLOSE-AND-MAYBE-DELETE UNSAFE.TO.MODIFY) (VARS UNSAFE.TO.MODIFY.FNS) (COMS (* \; "FILEDATE, for finding out the creation date of source files, from the compiled files.") (* |;;| "FASL isn't loaded when MACHINEINDEPENDENT is, so we have to fake the FASL checker for now.  It's defined in FASLOAD.") (FNS FILEDATE) (P (MOVD? (QUOTE NILL) (QUOTE FASL-FILEDATE)))) (P (MOVD? (QUOTE CL:FMAKUNBOUND) (QUOTE UNDOABLY-FMAKUNBOUND))) (* \; "used in FNS.PUTDEF before CMLUNDO loaded")) (COMS (* \; "Functions for retrieving and remembering FILEMAPs and file reader environments") (FNS FILEMAP \\PARSE-FILE-HEADER GET-ENVIRONMENT-AND-FILEMAP LOOKUP-ENVIRONMENT-AND-FILEMAP GET-FILEMAP-FROM-FILECREATED \\FILEMAP-HASHOVERFLOW FLUSHFILEMAPS LISPSOURCEFILEP GETFILEMAP PUTFILEMAP UPDATEFILEMAP PRINT-READER-ENVIRONMENT) (INITVARS (*FILEMAP-LIMIT* 20) (*FILEMAP-VERSIONS* 2) (*FILEMAP-HASH* (HASHARRAY *FILEMAP-LIMIT* (FUNCTION \\FILEMAP-HASHOVERFLOW) (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING.EQUAL)))) (DECLARE\: EVAL@COMPILE DONTCOPY (RECORDS FILEMAPHASH) (GLOBALVARS *FILEMAP-LIMIT* *FILEMAP-VERSIONS* *FILEMAP-HASH*))) (COMS (* * LVLPRINT) (FNS LVLPRINT LVLPRIN1 LVLPRIN2 LVLPRIN LVLPRIN0)) (COMS (* \; "used by PRINTOUT") (FNS FLUSHRIGHT PRINTPARA PRINTPARA1)) (COMS (* \; "SUBLIS and friends") (FNS SUBLIS SUBPAIR DSUBLIS)) (COMS (* * CONSTANTS) (FNS CONSTANTOK) (P (MOVD? (QUOTE EVQ) (QUOTE CONSTANT)) (MOVD? (QUOTE EVQ) (QUOTE DEFERREDCONSTANT)) (MOVD? (QUOTE EVQ) (QUOTE LOADTIMECONSTANT)))) (COMS (* * SCRATCHLIST) (PROP MACRO SCRATCHLIST ADDTOSCRATCHLIST) (PROP INFO SCRATCHLIST)) (GLOBALVARS SYSFILES LOADOPTIONS LISPXCOMS CLISPTRANFLG COMMENTFLG HISTSTR4 LISPXREADFN REREADFLG HISTSTR0 CTRLUFLG NOLINKMESS PROMPTCHARFORMS PROMPT#FLG FILERDTBL SPELLINGS2 USERWORDS BELLS CLISPARRAY) (FNS NLAMBDA.ARGS) (DECLARE\: DONTEVAL@LOAD DOCOPY (* \; "initialization of variables used in many places") (ADDVARS (CLISPARRAY) (CLISPFLG) (CTRLUFLG) (EDITCALLS) (EDITHISTORY) (EDITUNDOSAVES) (EDITUNDOSTATS) (GLOBALVARS) (LCASEFLG) (LISPXBUFS) (LISPXCOMS) (LISPXFNS) (LISPXHIST) (LISPXHISTORY) (LISPXPRINTFLG) (NOCLEARSTKLST) (NOFIXFNSLST) (NOFIXVARSLST) (P.A.STATS) (PROMPTCHARFORMS) (READBUF) (READBUFSOURCE) (REREADFLG) (RESETSTATE) (SPELLSTATS1)) (VARS (CHCONLST (QUOTE (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) (CHCONLST1 (QUOTE (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) (CHCONLST2 (QUOTE (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) (CLEARSTKLST T) (CLISPTRANFLG (QUOTE CLISP\ )) (HISTSTR0 "<c.r.>") (HISTSTR2 "repeat") (HISTSTR3 "from event:") (HISTSTR4 "ignore") (LISPXREADFN (QUOTE READ)) (USEMAPFLG T)) (P (MAPC (QUOTE ((APPLY BLKAPPLY) (SETTOPVAL SETATOMVAL) (GETTOPVAL GETATOMVAL) (APPLY* BLKAPPLY*) (RPLACA FRPLACA) (RPLACD FRPLACD) (STKNTH FSTKNTH) (STKNAME FSTKNAME) (CHARACTER FCHARACTER) (STKARG FSTKARG) (CHCON DCHCON) (UNPACK DUNPACK) (ADDPROP /ADDPROP) (ATTACH /ATTACH) (DREMOVE /DREMOVE) (DSUBST /DSUBST) (NCONC /NCONC) (NCONC1 /NCONC1) (PUT /PUT) (PUTPROP /PUTPROP) (PUTD /PUTD) (REMPROP /REMPROP) (RPLACA /RPLACA) (RPLACD /RPLACD) (SET /SET) (SETATOMVAL /SETATOMVAL) (SETTOPVAL /SETTOPVAL) (SETPROPLIST /SETPROPLIST) (SET SAVESET) (PRINT LISPXPRINT) (PRIN1 LISPXPRIN1) (PRIN2 LISPXPRIN2) (SPACES LISPXSPACES) (TAB LISPXTAB) (TERPRI LISPXTERPRI) (PRINT SHOWPRINT) (PRIN2 SHOWPRIN2) (PUTHASH /PUTHASH) (QUOTE *) (FNCLOSER /FNCLOSER) (FNCLOSERA /FNCLOSERA) (FNCLOSERD /FNCLOSERD) (EVQ DELFILE) (NILL SMASHFILECOMS) (PUTASSOC /PUTASSOC) (LISTPUT1 PUTL) (NILL I.S.OPR) (NILL RESETUNDO) (NILL LISPXWATCH) (QUOTE ADDSTATS) (NILL FREEVARS) (QUOTE USEDFREE) (COPYBYTES COPYCHARS))) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X))))) (MAPC (QUOTE ((TIME PRIN1 LISPXPRIN1) (TIME SPACES LISPXSPACES) (TIME PRINT LISPXPRINT) (DEFC PRINT LISPXPRINT) (DEFC PUTD /PUTD) (DEFC PUTPROP /PUTPROP) (DOLINK FNCLOSERD /FNCLOSERD) (DOLINK FNCLOSERA /FNCLOSERA) (DEFLIST PUTPROP /PUTPROP) (SAVEDEF1 PUTPROP /PUTPROP) (MKSWAPBLOCK PUTD /PUTD))) (FUNCTION (LAMBDA (X) (AND (CCODEP (CAR X)) (APPLY (QUOTE CHANGENAME) X))))) (MAPC (QUOTE ((EVALQT (LAMBDA NIL (PROG (TEM) (RESETRESTORE NIL (QUOTE RESET)) LP (PROMPTCHAR (QUOTE _) T) (LISPX (LISPXREAD T T)) (GO LP)))) (LISPX (LAMBDA (LISPXX) (PRINT (AND LISPXX (PROG (LISPXLINE LISPXHIST TEM) (RETURN (COND ((AND (NLISTP LISPXX) (SETQ LISPXLINE (READLINE T NIL T))) (APPLY LISPXX (CAR LISPXLINE))) (T (EVAL LISPXX)))))) T T))) (LISPXREAD (LAMBDA (FILE RDTBL) (COND (READBUF (PROG1 (CAR READBUF) (SETQ READBUF (CDR READBUF)))) (T (READ FILE RDTBL))))) (LISPXREADP (LAMBDA (FLG) (COND ((AND READBUF (SETQ READBUF (LISPXREADBUF READBUF))) T) (T (READP T FLG))))) (LISPXUNREAD (LAMBDA (LST) (SETQ READBUF (APPEND LST (CONS HISTSTR0 READBUF))))) (LISPXREADBUF (LAMBDA (RDBUF) (PROG NIL LP (COND ((NLISTP RDBUF) (RETURN NIL)) ((EQ (CAR RDBUF) HISTSTR0) (SETQ RDBUF (CDR RDBUF)) (GO LP)) (T (RETURN RDBUF)))))) (LISPX/ (LAMBDA (X) X)) (LOWERCASE (LAMBDA (FLG) (PROG1 LCASEFLG (RAISE (NULL FLG)) (RPAQ LCASEFLG FLG)))) (FILEPOS (LAMBDA (STR FILE) (PROG NIL LP (COND ((EQ (PEEKC FILE) (NTHCHAR STR 1)) (RETURN T))) (READC FILE) (GO LP)))) (FILEPKGCOM (NLAMBDA NIL NIL)))) (FUNCTION (LAMBDA (L) (OR (GETD (CAR L)) (PUTD (CAR L) (CADR L)))))))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA FILEMAP RESETBUFS DMPHASH FILESLOAD) (NLAML) (LAMA READFILE NLIST))) (LOCALVARS . T)))
+(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA FILEMAP RESETBUFS DMPHASH FILESLOAD)
+
+(ADDTOVAR NLAML)
+
+(ADDTOVAR LAMA READFILE NLIST)
+)
+(PUTPROPS MACHINEINDEPENDENT COPYRIGHT ("Venue & Xerox Corporation" T 1983 1984 1985 1986 1987 1988 
+1989 1990 1991 1992))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (6882 12518 (LOAD? 6892 . 7619) (FILESLOAD 7621 . 7845) (DOFILESLOAD 7847 . 10784) (
+FINDFILE-WITH-EXTENSIONS 10786 . 12516)) (12632 17087 (DMPHASH 12642 . 13220) (HASHOVERFLOW 13222 . 
+17085)) (17560 37255 (BKBUFS 17570 . 18351) (CHANGENAME 18353 . 18526) (CHNGNM 18528 . 19738) (CLBUFS 
+19740 . 20692) (COMSNAME 20694 . 21057) (DEFINE 21059 . 21379) (FNS.PUTDEF 21381 . 23561) (EQMEMB 
+23563 . 23659) (EQUALN 23661 . 24163) (FNCHECK 24165 . 25310) (FNTYP1 25312 . 25396) (LCSKIP 25398 . 
+25842) (MAPRINT 25844 . 26372) (MKLIST 26374 . 26456) (NAMEFIELD 26458 . 26681) (NAMEFIELD-STRING 
+26683 . 27572) (NLIST 27574 . 27748) (PRINTBELLS 27750 . 27821) (PROMPTCHAR 27823 . 29079) (RAISEP 
+29081 . 29261) (READFILE 29263 . 30274) (READLINE 30276 . 33992) (REMPROPLIST 33994 . 34473) (
+RESETBUFS 34475 . 34722) (TAB 34724 . 35034) (UNSAVED1 35036 . 35667) (WRITEFILE 35669 . 36644) (
+CLOSE-AND-MAYBE-DELETE 36646 . 36922) (UNSAFE.TO.MODIFY 36924 . 37253)) (39280 40535 (FILEDATE 39290
+ . 40533)) (40795 53747 (FILEMAP 40805 . 41148) (\\PARSE-FILE-HEADER 41150 . 43297) (
+GET-ENVIRONMENT-AND-FILEMAP 43299 . 44695) (LOOKUP-ENVIRONMENT-AND-FILEMAP 44697 . 45885) (
+GET-FILEMAP-FROM-FILECREATED 45887 . 46377) (\\FILEMAP-HASHOVERFLOW 46379 . 48427) (FLUSHFILEMAPS 
+48429 . 48729) (LISPSOURCEFILEP 48731 . 49402) (GETFILEMAP 49404 . 49718) (PUTFILEMAP 49720 . 50821) (
+UPDATEFILEMAP 50823 . 53017) (PRINT-READER-ENVIRONMENT 53019 . 53745)) (54256 56436 (LVLPRINT 54266 . 
+54396) (LVLPRIN1 54398 . 54545) (LVLPRIN2 54547 . 54723) (LVLPRIN 54725 . 55386) (LVLPRIN0 55388 . 
+56434)) (56471 59778 (FLUSHRIGHT 56481 . 56987) (PRINTPARA 56989 . 57812) (PRINTPARA1 57814 . 59776)) 
+(59815 60929 (SUBLIS 59825 . 60148) (SUBPAIR 60150 . 60669) (DSUBLIS 60671 . 60927)) (60952 61301 (
+CONSTANTOK 60962 . 61299)) (62307 62850 (NLAMBDA.ARGS 62317 . 62848)))))
+STOP
diff --git a/CLTL2/MACHINEINDEPENDENT.LCOM b/CLTL2/MACHINEINDEPENDENT.LCOM
new file mode 100644
index 00000000..1b6be337
Binary files /dev/null and b/CLTL2/MACHINEINDEPENDENT.LCOM differ
diff --git a/CLTL2/MAKEINIT b/CLTL2/MAKEINIT
new file mode 100644
index 00000000..27ca375f
--- /dev/null
+++ b/CLTL2/MAKEINIT
@@ -0,0 +1,493 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "12-Oct-93 22:22:00" "{Pele:mv:envos}<LispCore>Sources>CLTL2>MAKEINIT.;1" 26075  
+
+      changes to%:  (FNS I.\ATOMCELL)
+
+      previous date%: "22-Sep-92 19:17:22" {DSK}<mo>usr>users>sybalsky>cltl2>sources>MAKEINIT.;1)
+
+
+(* ; "
+Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT MAKEINITCOMS)
+
+(RPAQQ MAKEINITCOMS
+       ((FNS LOADMAKEINIT LOADMKIFILES RELOAD MAKEINIT MKI.START)
+        (COMS                                                (* ; 
+                                     "reading compiled files and processing well-known expressions")
+              (FNS MKI.PASSFILE SCRATCHARRAY DOFORM CONSTFORMP NOTICECOMS EVALFORMAKEINIT)
+              (FNS I.ADDTOVAR I.DECLARE%: I.DEFINE-FILE-INFO I.FILECREATED I.PUTPROPS I.RPAQ I.RPAQQ
+                   I.RPAQ? I.SETTOPVAL I.NOUNDO)
+              (PROP MKI ADDTOVAR DECLARE%: DEFINE-FILE-INFO FILECREATED PUTPROPS RPAQ RPAQ? RPAQQ 
+                    LISPXPRINT PRETTYCOMPRINT * SETTOPVAL SETQQ SETQ /SETTOPVAL))
+        (FNS I.ATOMNUMBER I.\ATOMCELL I.FIXUPNUM I.FIXUPPTR I.FIXUPSYM I.WORDSPERNAMEENTRY 
+             I.SETSTKNTOFFSET)
+        (COMS                                                (* ; "stuff for MAXC")
+              (FNS MKI.ATOM MKI.IEEE))
+        [COMS                                                (* ; 
+                  "stuff to maintain symbol values, prop lists during makeinit--all dumped at end.")
+              (FNS MKI.DSET MKI.ADDTO MKI.PUTPROP)
+              (VARS (MKI.ARRAY)
+                    (MKI.TVHA (HASHARRAY 400))
+                    (MKI.PLHA (HASHARRAY 150))
+                    (MKI.ATOMARRAY (HASHARRAY 5000))
+                    (INIT.EXT 'SYSOUT]
+        (COMS (FNS DUMPVP BOUTZEROS BIN16 BOUT16)
+              (VARS (MKI.FirstDataByte 1024)
+                    (MKI.Page0Byte 512)
+                    (MKI.DATE (DATE))
+                    MKI.CODESTARTOFFSET MKI.SEQUENTIAL PRINTEXPRS))
+        (INITVARS (PRINTEXPRS T)
+               (REMOTECOMPILE.EXT COMPILE.EXT))
+        [DECLARE%: DONTEVAL@LOAD DOCOPY (P (PUTPROP (COMSNAME (INPUT)
+                                                           T)
+                                                  'LOADDATE
+                                                  (GETFILEINFO (INPUT)
+                                                         'ICREATIONDATE]
+        (DECLARE%: EVAL@COMPILE (PROP MACRO SETXVAR IEQ)
+               DONTCOPY
+               (FILES (LOADCOMP)
+                      MEM))))
+(DEFINEQ
+
+(LOADMAKEINIT
+(LAMBDA (LARGEFLG) (* lmm "31-JUL-81 14:27") (SELECTQ (SYSTEMTYPE) ((D ALTO)) (PROGN (ADDTOVAR DIRECTORIES BLISP) (GCGAG 1000) (COND ((NOT LARGEFLG) (SETSEPR (QUOTE (%| 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26)) 1 FILERDTBL) (MINFS 45000 (QUOTE ARRAYP)) (MINFS 10000 (QUOTE FIXP)) (MINFS 3000 (QUOTE STRING.CHARS)) (MINFS 2000 (QUOTE ATOM.CHARS)))) (MOVD? (QUOTE NILL) (QUOTE MKNUMATOM)) (* ;; "This is a kludge to get around the problem that, while MKATOM is in LLNEW, MKNUMATOM is not, and MKATOM calls MKNUMATOM when given an atom beginning with a digit.  It turns out that MKNUMATOM will always return NIL in the cases called from MAKEINIT because MAKEINIT is merely copying things which it knows are really LITATOM and spelled like it.") (MOVD? (QUOTE *) (QUOTE BLOCKRECORD)) (PUTDQ? FIXSPELL1 (LAMBDA (OLD NEW) (PRINT (LIST OLD (QUOTE ->) NEW) T T))))) (LOADMKIFILES) (SELECTQ (SYSTEMTYPE) ((D ALTO)) (PROGN (MINFS 10000 (QUOTE ALTOPOINTER)) (* ; "doesn't work until after datatype declaration has been loaded") (RECLAIM (QUOTE ARRAYP)) (RECLAIM (QUOTE ATOM.CHARS)) (MINFS 10000 (QUOTE ARRAYP)) (MINFS 5000 (QUOTE LISTP)) (SYSOUT (QUOTE MKI.SAV)))))
+)
+
+(LOADMKIFILES
+(LAMBDA NIL (* mjs "13-Mar-84 14:41") (for X in (UNION MAKEINITFILES (SELECTQ (SYSTEMTYPE) ((ALTO D) NIL) MAXC.MAKEINITFILES)) do (RELOAD (PACKFILENAME (QUOTE BODY) X (QUOTE EXTENSION) COMPILE.EXT))))
+)
+
+(RELOAD
+(LAMBDA (FILE) (* lmm "13-APR-81 21:16") (PROG (DATE FULLFILENAME) RETRY (COND ((ILESSP (OR (GETPROP FILE (QUOTE LOADDATE)) MIN.INTEGER) (SETQ DATE (GETFILEINFO (SETQ FULLFILENAME (OR (FINDFILE FILE T) (GO NOTFOUND))) (QUOTE ICREATIONDATE)))) (LOAD FULLFILENAME T) (PUTPROP FILE (QUOTE LOADDATE) DATE))) (RETURN T) NOTFOUND (COND ((GETP (COMSNAME FILE) (QUOTE FILEDATES)) (PRINT (CONS FILE (QUOTE (already loaded))) T) (RETURN))) (ERROR FILE "not found.") (GO RETRY)))
+)
+
+(MAKEINIT
+  [LAMBDA (VERSIONS TYPE TOFILE LOADUPDIRS FONTDIRS)     (* ; "Edited 19-Jul-90 17:26 by jds")
+    (LOADMKIFILES)                                       (* ; 
+                                    "Load the files that have to be here to start making the init.")
+    (PROG ([TYPELST (OR (LISTP TYPE)
+                        (OR (CDR (ASSOC TYPE MAKEINITTYPES))
+                            (ERROR TYPE '?]
+           FILES SIZEGUESS AFTERINITFILESET EXPRESSIONS)
+
+     (* ;; "TYPELST is a list of the form (type file-list after-init-files init-size-guess)")
+
+          (SETQ FILES (CADR TYPELST))
+          (SETQ AFTERINITFILESET (CADDR TYPELST))
+          (SETQ SIZEGUESS (CADDDR TYPELST))
+          (RESETLST
+              [RESETSAVE (OUTPUT (SETQ TOFILE
+                                  (OPENSTREAM (PACKFILENAME.STRING 'BODY (OR TOFILE (CAR TYPELST)
+                                                                             'XXX)
+                                                     'EXTENSION INIT.EXT)
+                                         'OUTPUT
+                                         'NEW 8 (COND
+                                                   [NIL      (* ; 
+                             "Can't do this until we can do GETFILEPTR on a sequential output file")
+                                                        (APPEND MKI.SEQUENTIAL '((TYPE BINARY))
+                                                               (AND SIZEGUESS
+                                                                    (CONS (LIST 'LENGTH
+                                                                                (UNFOLD SIZEGUESS 
+                                                                                       BYTESPERPAGE]
+                                                   (T '((TYPE BINARY]
+              (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (FL)
+                                               (AND (OPENP FL)
+                                                    (CLOSEF FL))
+                                               (AND RESETSTATE (DELFILE (FULLNAME FL]
+                                   TOFILE))
+              (PROG ((OUTX TOFILE))
+                    (SETQ DIRECTORIES LOADUPDIRS)
+                    (MKI.START)
+                    (for X in FILES do (MKI.PASSFILE X))
+
+               (* ;; "Generally loads the files in 0LISPSET and 1LISPSET, with 2LISPSET getting loaded immediately after the init starts.")
+
+                    (AND LOADUPDIRS (MKI.DSET 'LOADUPDIRECTORIES LOADUPDIRS))
+                    (AND FONTDIRS (MKI.DSET 'DISPLAYFONTDIRECTORIES FONTDIRS))
+                    [COND
+                       (AFTERINITFILESET                     (* ; "Load stuff that has to be loaded before we can call LOADUP.  Ugly expression here is because FILESLOAD is on MACHINEINDEPENDENT.")
+                        [MKI.ADDTO
+                         'MAKEINIT.EXPRESSIONS
+                         `((MAPC ',(EVAL AFTERINITFILESET)
+                                 (FUNCTION (LAMBDA (FILE)
+                                             (OR [SOME LOADUPDIRECTORIES
+                                                       (FUNCTION (LAMBDA (DIR FL)
+                                                                   (COND
+                                                                      ((SETQ FL
+                                                                        (INFILEP (PACKFILENAME.STRING
+                                                                                  'DIRECTORY DIR
+                                                                                  'NAME FILE
+                                                                                  'EXTENSION 
+                                                                                  COMPILE.EXT)))
+                                                                       (LOAD FL 'SYSLOAD)
+                                                                       T]
+                                                 (PRINT (CONS FILE '(not found))
+                                                        T]
+                        (MKI.ADDTO 'BOOTFILES '(MAKEINIT.EXPRESSIONS]
+                    (I.MAKEINITLAST VERSIONS)))
+          (RETURN (FULLNAME TOFILE])
+
+(MKI.START
+(LAMBDA NIL (* bvm%: "12-Dec-84 15:23") (SETQ RESETPTR) (SETQ RESETPC) (BOUTZEROS MKI.FirstDataByte) (CLRHASH MKI.TVHA) (CLRHASH MKI.PLHA) (CLRHASH MKI.ATOMARRAY) (RESETMEMORY) (SETQ MKI.VALUES (for X in INITVALUES bind Y collect (SET (SETQ Y (PACK* "I." (SUBSTRING (CAR X) 2 -1))) (EVAL (CADR X))) Y)) (SETQ MKI.PTRS (for X in INITPTRS bind Y collect (SET (SETQ Y (PACK* "I." (SUBSTRING (CAR X) 2 -1))) (CADR X)) Y)) (I.MAKEINITFIRST) (MKI.DSET NIL NIL) (MKI.DSET T T) (MKI.DSET (QUOTE MAKEINITDATES) (LIST MKI.DATE (DATE))) (for X in INITCONSTANTS when (NEQ (CAR X) (QUOTE *)) do (I.FSETVAL (CAR X) (COND ((LISTP (CADR X)) (I.VAG2 (CAADR X) (CADR (CADR X)))) (T (I.\COPY (CADR X)))))))
+)
+)
+
+
+
+(* ; "reading compiled files and processing well-known expressions")
+
+(DEFINEQ
+
+(MKI.PASSFILE
+(LAMBDA (FILESET) (* ; "Edited 30-Mar-87 17:17 by bvm:") (* ;;; "Read a DCOM file and load its contents into the INIT.") (* ;;; "FILESET can be one of a number, which is a LISPSET number, or a list of file names, or a file name") (COND ((NUMBERP FILESET) (* ; "We were given a nLISPSET number.  Pack it up to get the list of files") (MKI.PASSFILE (EVALV (PACK* FILESET (QUOTE LISPSET))))) ((LISTP FILESET) (* ; "We were given a list of file names") (MAPC FILESET (FUNCTION MKI.PASSFILE))) (T (* ; "It's a file name.  Read it in.") (INPUT (SETQ FILESET (OPENSTREAM (OR (FINDFILE (PACKFILENAME.STRING (QUOTE BODY) FILESET (QUOTE EXTENSION) REMOTECOMPILE.EXT) T) FILESET) (QUOTE INPUT) (QUOTE OLD) 8 MKI.SEQUENTIAL))) (MKI.ADDTO (QUOTE LOADEDFILELST) (LIST (SETQ FILESET (FULLNAME FILESET)))) (PRINT FILESET T T) (LET* ((FILEROOT (COMSNAME FILESET)) (COMSNAMES (LIST (PACK* FILEROOT (QUOTE COMS)))) SKIPVARS MEXPRS X) (DECLARE (SPECVARS COMSNAMES SKIPVARS MEXPRS)) (* ; " used by I.RPAQQ and DOFORM") (* ;;; "Loop here reading from the dcom file into the init.") (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT* (until (SELECTQ (SETQ X (READ)) ((STOP NIL) (* ; "End of file") T) NIL) do (COND ((NLISTP X) (* ;; "Start of a code object.  Skip the code indicator (assume it says to read with DCODERD) and read the code") (IF (NOT (LITATOM (READ))) THEN (ERROR "Bad compiled function" X)) (I.DCODERD X)) (T (* ; "It's a form.  go either do it now or add it to the forms to execute inside the init.") (DOFORM X))) finally (COND ((CAR MEXPRS) (* ; "There are expressions to be executed in the INIT when it comes up.  Save them.") (MKI.ADDTO (SETQ FILESET (PACK* FILEROOT ".EXPRESSIONS")) (CAR MEXPRS)) (MKI.ADDTO (QUOTE BOOTFILES) (LIST FILESET)))))) (CLOSEF (INPUT))))))
+)
+
+(SCRATCHARRAY
+(LAMBDA (NBYTES ALIGN) (* ; "Edited 30-Mar-87 16:20 by bvm:") (COND ((OR (NULL MKI.ARRAY) (IGREATERP NBYTES (ARRAYSIZE MKI.ARRAY))) (* ;; "make sure the scratch array is big enough.  Note that the scratch array is unboxed, not code, since we aren't going to be storing legitimate local code in it (let's not fool the garbage collector too much).") (SETQ MKI.ARRAY (create ARRAYP TYP _ \ST.BYTE BASE _ (\ALLOCBLOCK (FOLDHI NBYTES BYTESPERCELL) UNBOXEDBLOCK.GCT 0 CELLSPERQUAD) LENGTH _ NBYTES ORIG _ 0)))) (for I from 0 to (SUB1 (UNFOLD ALIGN BYTESPERCELL)) do (\BYTESETA MKI.ARRAY I 0)) (* ; "clear the fnheader area") MKI.ARRAY)
+)
+
+(DOFORM
+(LAMBDA (X NOPROP) (* bvm%: "30-Aug-86 15:36") (* ;;; "Handle a raw form found in a dcom file that's going into a makeinit.") (LET ((FN (GETPROP (CAR X) (QUOTE MKI)))) (if (AND FN (NOT NOPROP)) then (* ; "it's a local command that can be run `renamed' .  Execute it in the local context.") (* ASSERT%: (CALLS I.ADDTOVAR I.DECLARE%: I.DEFINE-FILE-INFO I.DEFLIST I.FILECREATED I.PRETTYDEFMACROS I.PUTPROPS I.RPAQ I.RPAQQ I.SETHASHQ)) (APPLY* FN X) else (* ;; "it's a command that has to be done remotely, since we don't know how to do it from here.  Add it to the collection of init expressions.") (COND (PRINTEXPRS (PRINT X T T))) (SETQ MEXPRS (TCONC MEXPRS X)))))
+)
+
+(CONSTFORMP
+(LAMBDA (X) (* lmm " 7-MAR-80 08:54") (COND ((LISTP X) (SELECTQ (CAR X) ((QUOTE FUNCTION) X) NIL)) ((LITATOM X) (SELECTQ X (NIL (QUOTE (QUOTE NIL))) (T T) (AND (SETQ X (GETHASH X MKI.TVHA)) (KWOTE (CDR X))))) (T X)))
+)
+
+(NOTICECOMS
+(LAMBDA (VAL) (* lmm "10-Mar-85 14:51") (for X in VAL when (LISTP X) do (COND ((AND (EQ (CADR X) (QUOTE *)) (LITATOM (CADDR X))) (COND ((EQ (CAR X) (QUOTE COMS)) (push COMSNAMES (CADDR X))) (T (push SKIPVARS (CADDR X))))) (T (SELECTQ (CAR X) ((COMS DECLARE%:) (NOTICECOMS (CDR X))) NIL)))))
+)
+
+(EVALFORMAKEINIT
+(LAMBDA (FORM) (* bvm%: " 2-NOV-83 15:22") (COND ((LISTP FORM) (SELECTQ (CAR FORM) (MKATOM (COND ((STRINGP (CADR FORM)) (MKATOM (CADR FORM))) (T (HELP)))) (HELP))) ((FIXP FORM) FORM) (T (HELP))))
+)
+)
+(DEFINEQ
+
+(I.ADDTOVAR
+(LAMBDA (FORM) (* lmm " 2-DEC-81 23:58") (MKI.ADDTO (CADR FORM) (CDDR FORM))))
+
+(I.DECLARE%:
+(LAMBDA (FORM) (* lmm "18-FEB-80 14:04") (PROG ((L FORM) (FLAG T) X FN) LP (COND ((NULL (SETQ L (CDR L))) (RETURN)) ((NLISTP (SETQ X (CAR L))) (SELECTQ X ((EVAL@LOAD DOEVAL@LOAD) (SETQ FLAG T)) (DONTEVAL@LOAD (SETQ FLAG NIL)) NIL)) (T (DOFORM X))) (GO LP)))
+)
+
+(I.DEFINE-FILE-INFO
+(LAMBDA (FORM) (* bvm%: "30-Aug-86 15:32") (* ;;; "Set reader environment for reading rest of file") (SET-READER-ENVIRONMENT (\DO-DEFINE-FILE-INFO NIL (CDR FORM))))
+)
+
+(I.FILECREATED
+(LAMBDA (X) (* ; "Edited 12-Jan-88 11:00 by bvm") (* ;; "Form is (FILECREATED date filename . otherstuff)") (COND ((NLISTP (CADDR X)) (* ; "FILENAME a list is for the %"compiled on%" expression") (LET ((NAME (COMSNAME (CADDR X)))) (MKI.ADDTO (QUOTE BOOTLOADEDFILES) (LIST NAME)) (MKI.PUTPROP NAME (QUOTE FILEDATES) (LIST (CONS (CADR X) (CADDR X))))))))
+)
+
+(I.PUTPROPS
+(LAMBDA (FORM) (* lpd%: "29-APR-77 13:22") (MKI.PUTPROP (CADR FORM) (CADDR FORM) (CADDDR FORM))))
+
+(I.RPAQ
+(LAMBDA (FORM) (* edited%: "10-Jul-84 14:05") (PROG ((VAL (CADDR FORM)) V) (COND ((SETQ V (CONSTFORMP VAL)) (MKI.DSET (CADR FORM) (EVAL V))) (T (DOFORM (LIST (QUOTE SETTOPVAL) (KWOTE (CADR FORM)) VAL) T)))))
+)
+
+(I.RPAQQ
+(LAMBDA (FORM) (* lmm "30-APR-80 22:12") (PROG ((ATM (CADR FORM)) (VAL (CADDR FORM))) (COND ((FMEMB ATM COMSNAMES) (NOTICECOMS VAL)) ((FMEMB ATM SKIPVARS)) (T (MKI.DSET ATM VAL)))))
+)
+
+(I.RPAQ?
+(LAMBDA (FORM) (* lmm " 7-MAR-80 08:36") (PROG ((VAL (CADDR FORM)) V) (COND ((SETQ V (CONSTFORMP VAL)) (MKI.DSET (CADR FORM) (EVAL V))) (T (DOFORM (LIST (QUOTE SETTOPVAL) (KWOTE (CADR FORM)) VAL))))))
+)
+
+(I.SETTOPVAL
+(LAMBDA (FORM) (* edited%: "10-Jul-84 14:07") (PROG (V) (if (AND (EQ (CAR (LISTP (CADR FORM))) (QUOTE QUOTE)) (SETQ V (CONSTFORMP (CADDR FORM)))) then (MKI.DSET (CADR (CADR FORM)) (EVAL V)) else (DOFORM FORM T))))
+)
+
+(I.NOUNDO
+(LAMBDA (FORM) (* edited%: "10-Jul-84 14:02") (if (EQ (NTHCHAR (CAR FORM) 1) (QUOTE /)) then (DOFORM (CONS (SUBATOM (CAR FORM) 2 -1) (CDR FORM))) else (SHOULDNT)))
+)
+)
+
+(PUTPROPS ADDTOVAR MKI I.ADDTOVAR)
+
+(PUTPROPS DECLARE%: MKI I.DECLARE%:)
+
+(PUTPROPS DEFINE-FILE-INFO MKI I.DEFINE-FILE-INFO)
+
+(PUTPROPS FILECREATED MKI I.FILECREATED)
+
+(PUTPROPS PUTPROPS MKI I.PUTPROPS)
+
+(PUTPROPS RPAQ MKI I.RPAQ)
+
+(PUTPROPS RPAQ? MKI I.RPAQ?)
+
+(PUTPROPS RPAQQ MKI I.RPAQQ)
+
+(PUTPROPS LISPXPRINT MKI NILL)
+
+(PUTPROPS PRETTYCOMPRINT MKI NILL)
+
+(PUTPROPS * MKI NILL)
+
+(PUTPROPS SETTOPVAL MKI I.SETTOPVAL)
+
+(PUTPROPS SETQQ MKI I.RPAQQ)
+
+(PUTPROPS SETQ MKI I.RPAQ)
+
+(PUTPROPS /SETTOPVAL MKI I.NOUNDO)
+(DEFINEQ
+
+(I.ATOMNUMBER
+  [LAMBDA (A)                                            (* ; "Edited 23-Jan-91 19:02 by jds")
+
+    (* ;; "Given a symbol, return the symbol's atom #, in the INIT being made.")
+
+    (* ;; 
+"NB that this will work only so long as there are no NEW-SYMBOLs in the INIT, because of the LOLOC.")
+
+    (I.LOLOC (COND
+                ((LITATOM A)
+                 (MKI.ATOM A))
+                (T A])
+
+(I.\ATOMCELL
+  [LAMBDA (X N)                                              (* ; 
+                                                      "Edited 26-Oct-92 14:24 by sybalsky:mv:envos")
+    (LET ((ATOMNO (I.ATOMNUMBER X)))
+         (COND
+            (NIL 
+                   (* ;; "THIS WAS THE PRE-BIGVM CODE:")
+
+                   (LET [(LOC (SELECTC N
+                                  (10 (I.ATOMNUMBER X))
+                                  (12 (I.ATOMNUMBER X))
+                                  (2 (I.ATOMNUMBER X))
+                                  (8 (I.ATOMNUMBER X))
+                                  (SHOULDNT]
+                        (I.ADDBASE (I.VAG2 N LOC)
+                               LOC)))
+            [(EQ (LRSH ATOMNO 16)
+                 0)                                          (* ; "Xerox Lisp traditional symbol")
+             (LET [(LOC (SELECTC N
+                            (10 4)
+                            (12 2)
+                            (2 6)
+                            (8 0)
+                            (SHOULDNT]
+                  (I.ADDBASE (I.VAG2 8 0)
+                         (IPLUS LOC (ITIMES 10 ATOMNO]
+            (T                                               (* ; 
+                                       "New symbol that appears after traditional symbol runs out.")
+               (LET [(OFFSET (SELECTC N
+                                 (10 4)
+                                 (12 2)
+                                 (2 6)
+                                 (8 0)
+                                 (SHOULDNT]
+                    (I.ADDBASE ATOMNO OFFSET])
+
+(I.FIXUPNUM
+  [LAMBDA (CA BN NUM MASK)                               (* ; "Edited 17-Jul-90 14:28 by jds")
+
+    (* ;; "�2�Perform atom-number fixup for a code block.")
+
+    (COND
+       ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)
+
+        (* ;; "If it's on a machine wiht 3 byte atom numbers, treat it as a pointer.")
+
+        (I.FIXUPPTR CA BN NUM))
+       (T 
+          (* ;; "Otherwise, fill in the two bytes.")
+
+          (\BYTESETA CA (SUB1 BN)
+                 (LOGOR (LOGAND (\BYTELT CA (SUB1 BN))
+                               (LRSH (LOGXOR MASK 65535)
+                                     8))
+                        (LOGAND (LRSH (LOGAND NUM MASK)
+                                      8)
+                               255)))
+          (\BYTESETA CA BN (LOGAND NUM 255])
+
+(I.FIXUPPTR
+  [LAMBDA (CA BN PTR)                                    (* ; "Edited 22-Jul-90 12:10 by jds")
+
+    (* ;; "Specific for MAXC --- actual ptr is same as simulated ptr")
+
+    (PROG ((LOLOC (I.LOLOC PTR)))
+          (\BYTESETA CA (SUB1 BN)
+                 (LRSH LOLOC 8))
+          (\BYTESETA CA BN (LOGAND LOLOC 255))
+          (\BYTESETA CA (IDIFFERENCE BN 2)
+                 (LOGOR (\BYTELT CA (IDIFFERENCE BN 2))
+                        (I.HILOC PTR])
+
+(I.FIXUPSYM
+  [LAMBDA (CA BN NUM MASK)                               (* ; "Edited 23-Jan-91 19:04 by jds")
+
+    (* ;; "�2�Perform SYMBOL fixup for a code block.")
+
+    (COND
+       ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)
+
+        (* ;; "If it's on a machine wiht 3 byte atom numbers, treat it as a pointer.")
+
+        (I.FIXUPPTR CA BN (I.ATOMNUMBER NUM)))
+       (T 
+          (* ;; "Otherwise, fill in the two bytes.")
+
+          (\BYTESETA CA (SUB1 BN)
+                 (LOGOR (LOGAND (\BYTELT CA (SUB1 BN))
+                               (LRSH (LOGXOR MASK 65535)
+                                     8))
+                        (LOGAND (LRSH (LOGAND (I.ATOMNUMBER NUM)
+                                             MASK)
+                                      8)
+                               255)))
+          (\BYTESETA CA BN (LOGAND (I.ATOMNUMBER NUM)
+                                  255])
+
+(I.WORDSPERNAMEENTRY
+  [LAMBDA NIL                                            (* ; "Edited 25-Jan-91 15:35 by jds")
+
+    (* ;; "For MAKEINIT, returns the number of words in a name-table entry.")
+
+    (* ;; "For the old 2-byte atom case, it's 1 word; for 3-byte atoms, 2 words.")
+
+    (* ;; "An %"Entry%" means an entry in each half of the name table (symbol & type/offset).")
+
+    (* ;; "While we're building the INIT, react to either :3-BYTE or :3-BYTE-INIT in the target architecture -- we're automatically CROSSCOMPILING as far as this function is concerned.")
+
+    (COND
+       ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)
+        2)
+       ((FMEMB :3-BYTE-INIT COMPILER::*TARGET-ARCHITECTURE*)
+        2)
+       (T 1])
+
+(I.SETSTKNTOFFSET
+  [LAMBDA (BASE OFFSET TYPE VAL)                         (* ; "Edited 25-Jan-91 16:00 by jds")
+
+    (* ;; "FOR MAKEINIT:  Set the offset entry for a name-table entry, from the symbol to fill in plus the variable-type marker value SHIFTED LEFT 14 BITS ALREADY.")
+
+    (COND
+       ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)
+        (I.FIXUPNUM BASE (IDIFFERENCE OFFSET BYTESPERWORD)
+               TYPE)
+        (I.FIXUPNUM BASE OFFSET VAL))
+       ((FMEMB :3-BYTE-INIT COMPILER::*TARGET-ARCHITECTURE*)
+        (I.FIXUPNUM BASE (IDIFFERENCE OFFSET BYTESPERWORD)
+               TYPE)
+        (I.FIXUPNUM BASE OFFSET VAL))
+       (T (I.FIXUPNUM BASE OFFSET (IPLUS TYPE VAL])
+)
+
+
+
+(* ; "stuff for MAXC")
+
+(DEFINEQ
+
+(MKI.ATOM
+(LAMBDA (X) (* lmm "29-JUL-81 22:46") (* ; "for MAXC") (AND X (OR (GETHASH X MKI.ATOMARRAY) (PUTHASH X (COND ((EQ X (QUOTE NOBIND)) PTRNOBIND) (T (I.COPYATOM X))) MKI.ATOMARRAY))))
+)
+
+(MKI.IEEE
+(LAMBDA (X BOX) (* bvm%: "16-Dec-80 00:44") (* ;; "Converts pdp-10 floating-point number X to IEEE standard for Dolphin, storing (with I.PUTBASE) into BOX.  For MAXC only.") (PROG (MAGNITUDE (SIGN 0) (EXP 0) (FRAC 0)) RETRY (SETQ MAGNITUDE (COND ((MINUSP X) (SETQ SIGN 32768) (IMINUS (OPENR (LOC X)))) (T (OPENR (LOC X))))) (COND ((ZEROP MAGNITUDE) (GO DONE)) ((IEQP (LOGAND MAGNITUDE 67108864) 0) (* ; "unnormalized number???") (SETQ X (FPLUS X 0.0)) (GO RETRY))) (COND ((ILEQ (SETQ EXP (IDIFFERENCE (LRSH MAGNITUDE 27) 2)) 0) (* ;; "Exponent bias is off by 1, plus another 1 because of the implicit high bit.  Thus have to watch for underflow") (ERROR "Unrepresentable floating-point number" X) (SETQ EXP (SETQ SIGN 0)) (* ; "If continued, make it zero") (GO DONE))) (SETQ FRAC (IPLUS (LOGAND (LRSH MAGNITUDE 3) 16777215) (COND ((OR (ILESSP (LOGAND MAGNITUDE 7) 4) (EQ (LOGAND MAGNITUDE 15) 4)) (* ; "Round down") 0) (T 1)))) (COND ((IGREATERP FRAC 16777215) (* ; "Rounding overflowed the high bit") (SETQ FRAC (LRSH FRAC 1)) (* ; "EXP can't overflow, because of bias difference") (SETQ EXP (ADD1 EXP)))) (* ; "FRAC is now a 24-bit fraction with its high bit on") DONE (I.PUTBASE BOX 0 (LOGOR SIGN (LLSH EXP 7) (LOGAND (LRSH FRAC 16) 127))) (I.PUTBASE BOX 1 (LOGAND FRAC 65535))))
+)
+)
+
+
+
+(* ; "stuff to maintain symbol values, prop lists during makeinit--all dumped at end.")
+
+(DEFINEQ
+
+(MKI.DSET
+(LAMBDA (A VAL) (* ; "Edited 12-Jan-88 11:03 by bvm") (LET ((LST (GETHASH A MKI.TVHA))) (COND (LST (COND ((NOT (EQUAL VAL (CDR LST))) (EXEC-FORMAT "(Value of ~S changed from ~S to ~S)~%%" A (CDR LST) VAL))) (RPLACD LST VAL)) (T (PUTHASH A (CONS NIL VAL) MKI.TVHA)))))
+)
+
+(MKI.ADDTO
+(LAMBDA (A VAL) (* lpd%: "29-APR-77 13:20") (PROG ((LST (GETHASH A MKI.TVHA))) (COND (LST (RPLACD LST (UNION VAL (CDR LST)))) (T (PUTHASH A (CONS NIL VAL) MKI.TVHA)))))
+)
+
+(MKI.PUTPROP
+(LAMBDA (A PROP VAL) (* ; "Edited 12-Jan-88 11:04 by bvm") (LET ((LST (GETHASH A MKI.PLHA))) (COND (LST (COND ((LISTGET LST PROP) (EXEC-FORMAT "(Property ~S of ~S has been changed)~%%" A PROP))) (LISTPUT LST PROP VAL)) (T (PUTHASH A (LIST PROP VAL) MKI.PLHA)))))
+)
+)
+
+(RPAQQ MKI.ARRAY NIL)
+
+(RPAQ MKI.TVHA (HASHARRAY 400))
+
+(RPAQ MKI.PLHA (HASHARRAY 150))
+
+(RPAQ MKI.ATOMARRAY (HASHARRAY 5000))
+
+(RPAQQ INIT.EXT SYSOUT)
+(DEFINEQ
+
+(DUMPVP
+(LAMBDA (VP) (* lpd%: "27-APR-77 20:24") (PRIN1 (QUOTE *) T) (WriteoutPage OUTX VP)))
+
+(BOUTZEROS
+(LAMBDA (N) (* lmm "16-MAY-81 16:49") (FRPTQ N (\BOUT OUTX 0))))
+
+(BIN16
+(LAMBDA (J) (* lmm "16-MAY-81 16:49") (IPLUS (LLSH (\BIN J) 8) (\BIN J))))
+
+(BOUT16
+(LAMBDA (J N) (* lmm "16-MAY-81 16:51") (\BOUT J (LRSH N 8)) (\BOUT J (LOGAND N 255))))
+)
+
+(RPAQQ MKI.FirstDataByte 1024)
+
+(RPAQQ MKI.Page0Byte 512)
+
+(RPAQ MKI.DATE (DATE))
+
+(RPAQQ MKI.CODESTARTOFFSET 60)
+
+(RPAQQ MKI.SEQUENTIAL ((SEQUENTIAL T)))
+
+(RPAQQ PRINTEXPRS T)
+
+(RPAQ? PRINTEXPRS T)
+
+(RPAQ? REMOTECOMPILE.EXT COMPILE.EXT)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(PUTPROP (COMSNAME (INPUT)
+                T)
+       'LOADDATE
+       (GETFILEINFO (INPUT)
+              'ICREATIONDATE))
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS SETXVAR MACRO [X `(SETQ.NOREF %, (CADAR X)
+                                           %,
+                                           (CADR X])
+
+(PUTPROPS IEQ MACRO ((X Y)
+                             (IEQP X Y)))
+DONTCOPY 
+
+(FILESLOAD (LOADCOMP)
+       MEM)
+)
+(PUTPROPS MAKEINIT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991
+ 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (2671 9662 (LOADMAKEINIT 2681 . 3884) (LOADMKIFILES 3886 . 4106) (RELOAD 4108 . 4590) 
+(MAKEINIT 4592 . 8954) (MKI.START 8956 . 9660)) (9740 13640 (MKI.PASSFILE 9750 . 11542) (SCRATCHARRAY 
+11544 . 12193) (DOFORM 12195 . 12872) (CONSTFORMP 12874 . 13108) (NOTICECOMS 13110 . 13418) (
+EVALFORMAKEINIT 13420 . 13638)) (13641 15760 (I.ADDTOVAR 13651 . 13745) (I.DECLARE%: 13747 . 14023) (
+I.DEFINE-FILE-INFO 14025 . 14215) (I.FILECREATED 14217 . 14590) (I.PUTPROPS 14592 . 14705) (I.RPAQ 
+14707 . 14928) (I.RPAQQ 14930 . 15126) (I.RPAQ? 15128 . 15343) (I.SETTOPVAL 15345 . 15577) (I.NOUNDO 
+15579 . 15758)) (16396 22240 (I.ATOMNUMBER 16406 . 16841) (I.\ATOMCELL 16843 . 18496) (I.FIXUPNUM 
+18498 . 19315) (I.FIXUPPTR 19317 . 19798) (I.FIXUPSYM 19800 . 20748) (I.WORDSPERNAMEENTRY 20750 . 
+21505) (I.SETSTKNTOFFSET 21507 . 22238)) (22272 23780 (MKI.ATOM 22282 . 22478) (MKI.IEEE 22480 . 23778
+)) (23877 24642 (MKI.DSET 23887 . 24170) (MKI.ADDTO 24172 . 24357) (MKI.PUTPROP 24359 . 24640)) (24818
+ 25196 (DUMPVP 24828 . 24925) (BOUTZEROS 24927 . 25006) (BIN16 25008 . 25093) (BOUT16 25095 . 25194)))
+))
+STOP
diff --git a/CLTL2/MAKEINIT.LCOM b/CLTL2/MAKEINIT.LCOM
new file mode 100644
index 00000000..db50f8ea
Binary files /dev/null and b/CLTL2/MAKEINIT.LCOM differ
diff --git a/CLTL2/MISC b/CLTL2/MISC
new file mode 100644
index 00000000..a5819efb
--- /dev/null
+++ b/CLTL2/MISC
@@ -0,0 +1,409 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "30-Aug-91 09:56:27" {DSK}<new>sources>lispcore>sources>MISC.;2 32227  
+
+      changes to%:  (FNS TAILP LAST) (VARS MISCCOMS)
+
+      previous date%: "16-May-90 20:40:30" {DSK}<new>sources>lispcore>sources>MISC.;1)
+
+
+(* ; "
+Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT MISCCOMS)
+
+(RPAQQ MISCCOMS ((FNS ADD1VAR ADDTOVAR APPENDTOVAR APPEND \APPEND2 ASSOC ATTACH CHANGEPROP CONCATLIST COPY DEFINEQ DEFLIST DREMOVE DREVERSE DSUBST EQLENGTH EVERY GETLIS INTERSECTION KWOTE LAST LASTN LCONC LDIFF LDIFFERENCE LENGTH LISTGET LISTGET1 LISTPUT LISTPUT1 LSUBST MAP MAP2C MAP2CAR MAPC MAPCAR MAPCON MAPCONC MAPLIST MEMBER NLEFT NOTANY NOTEVERY NTH PUTASSOC RATOMS REMOVE REVERSE RPT RPTQ FRPTQ SASSOC SAVEDEF SAVEDEF1 SELECT SELECT1 SELECTC SETQQ SOME STRMEMB SUB1VAR SUBSET SUBST TAILP TCONC UNION) (COMS (* ; "ERRORSET stuff") (FNS ERSETQ NLSETQ XNLSETQ RESETLST RESETSAVE RESETFORM RESETVARS RESETVAR SI::RESETUNWIND) (FNS SI::NLSETQHANDLER) (INITVARS (SI::*NLSETQFLAG*) (RESETSTATE)) (PROP INFO RESETTOPVALS)) (COMS (FNS GENSYM GENSYM? \GS.INITBUF) (* ; "GENSYM garbage") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\GS.BUFSIZE 100))) (INITVARS (GENNUM 0) (\GS.OGENNUM -1) (\GS.NUMLEN 0) (\GS.BUF NIL) (\GS.STR (ALLOCSTRING 0))) (GLOBALVARS GENNUM \GS.OGENNUM \GS.NUMLEN \GS.BUF \GS.STR)) (ALISTS (PRETTYEQUIVLST SELECTC) (DWIMEQUIVLST SELECTC)) (LOCALVARS . T) (P (CL:PROCLAIM (QUOTE (GLOBAL MAKESYSDATE MAKESYSNAME)))) (PROP FILETYPE MISC) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA RESETVARS RESETFORM RESETSAVE RESETLST NLSETQ ERSETQ SELECTC SELECT FRPTQ RPTQ DEFINEQ APPENDTOVAR ADDTOVAR) (NLAML RESETVAR XNLSETQ SUB1VAR SETQQ ADD1VAR) (LAMA APPEND)))))
+(DEFINEQ
+
+(ADD1VAR
+(NLAMBDA (ADD1X) (SET ADD1X (ADD1 (EVAL ADD1X)))))
+
+(ADDTOVAR
+(NLAMBDA X (* ; "Edited  8-Jan-88 12:50 by bvm") (LET* ((VAR (CAR X)) (VAL (OR (AND (EQ DFNFLG (QUOTE ALLPROP)) (GETPROP VAR (QUOTE VALUE))) (LISTP (EVALV VAR)))) TYPE) (if (AND (NEQ DFNFLG (QUOTE ALLPROP)) (SETQ TYPE (GETPROP VAR (QUOTE VARTYPE))) (SETQ TYPE (OR (LISTGET1 (LISTP TYPE) (QUOTE ALIST)) (EQ TYPE (QUOTE ALIST))))) then (* ;; "The variable appears to be an A-list.  Treat it as such unless we see evidence to the contrary.") (for PAIR in (CDR X) BIND ADDED-NONLIST? do (if (NLISTP PAIR) then (* ;; "This is evidence to the contrary.  We arrange for the variable itself to be marked as changed below.") (SETQ VAL (CONS PAIR VAL)) (SETQ ADDED-NONLIST? T) else (LET ((OLDENTRY (if (EQ TYPE (QUOTE USERMACROS)) then (find OP in VAL suchthat (AND (EQ (CAR OP) (CAR PAIR)) (EQ (NULL (CADR OP)) (NULL (CADR PAIR))))) else (FASSOC (CAR PAIR) VAL)))) (if (NOT (EQUAL OLDENTRY PAIR)) then (if (AND OLDENTRY (NEQ DFNFLG T)) then (EXEC-FORMAT "(new ~S entry for ~S)~%%" VAR (CAR PAIR))) (MARKASCHANGED (LIST VAR (CAR PAIR)) (QUOTE ALISTS) (NULL OLDENTRY)) (SETQ VAL (CONS PAIR (if OLDENTRY then (/DREMOVE OLDENTRY VAL) else VAL)))))) FINALLY (if ADDED-NONLIST? then (SAVESET VAR VAL NIL (QUOTE NOSTACKUNDO)) else (/SET VAR VAL))) else (* ;; "The variable doesn't appear to be an A-list.") (LET ((DFNFLG (if (EQ DFNFLG (QUOTE ALLPROP)) then (QUOTE PROP) else DFNFLG))) (DECLARE (SPECVARS DFNFLG)) (if (OR VAL (CDR X)) then (SAVESET VAR (UNION (CDR X) VAL) NIL (QUOTE NOSTACKUNDO)) elseif (EQ (EVALV VAR) (QUOTE NOBIND)) then (* ;; "The semantics of (ADDVARS (FOO)) are to initialize FOO to NIL if it is NOBIND, otherwise leave it alone.") (/SET VAR NIL)))) VAR))
+)
+
+(APPENDTOVAR
+(NLAMBDA X (* ; "Edited  9-Mar-87 15:48 by Pavel") (LET* ((VAR (CAR X)) (VAL (OR (AND (EQ DFNFLG (QUOTE ALLPROP)) (GETPROP VAR (QUOTE VALUE))) (LISTP (EVALV VAR)))) TYPE) (IF (AND (NEQ DFNFLG (QUOTE ALLPROP)) (SETQ TYPE (GETPROP VAR (QUOTE VARTYPE))) (SETQ TYPE (OR (LISTGET1 (LISTP TYPE) (QUOTE ALIST)) (EQ TYPE (QUOTE ALIST))))) THEN (* ;; "The variable appears to be an A-list.  Treat it as such unless we see evidence to the contrary.") (LET ((ADDED-NONLIST? NIL)) (FOR PAIR IN (CDR X) DO (IF (NLISTP PAIR) THEN (* ;; "This is evidence to the contrary.  We arrange for the variable itself to be marked as changed below.") (SETQ VAL (APPEND VAL (LIST PAIR))) (SETQ ADDED-NONLIST? T) ELSE (LET ((OLDENTRY (IF (EQ TYPE (QUOTE USERMACROS)) THEN (FIND OP IN VAL SUCHTHAT (AND (EQ (CAR OP) (CAR PAIR)) (EQ (NULL (CADR OP)) (NULL (CADR PAIR))))) ELSE (FASSOC (CAR PAIR) VAL)))) (IF (NOT (EQUAL OLDENTRY PAIR)) THEN (IF (AND OLDENTRY (NEQ DFNFLG T)) THEN (EXEC-FORMAT "(new ~S entry for ~S)~%%" VAR (CAR PAIR))) (MARKASCHANGED (LIST VAR (CAR PAIR)) (QUOTE ALISTS) (NULL OLDENTRY)) (SETQ VAL (APPEND (IF OLDENTRY THEN (/DREMOVE OLDENTRY VAL) ELSE VAL) (LIST PAIR))))))) (IF ADDED-NONLIST? THEN (SAVESET VAR VAL NIL (QUOTE NOPRINT)) ELSE (/SET VAR VAL))) ELSE (* ;; "The variable doesn't appear to be an A-list.") (LET ((DFNFLG (IF (EQ DFNFLG (QUOTE ALLPROP)) THEN (QUOTE PROP) ELSE DFNFLG))) (DECLARE (SPECVARS DFNFLG)) (IF (OR VAL (CDR X)) THEN (SAVESET VAR (APPEND VAL (LDIFFERENCE (CDR X) VAL)) NIL (QUOTE NOPRINT)) ELSEIF (EQ (EVALV VAR) (QUOTE NOBIND)) THEN (* ;; "The semantics of (ADDVARS (FOO)) are to initialize FOO to NIL if it is NOBIND, otherwise leave it alone.") (/SET VAR NIL)))) VAR))
+)
+
+(APPEND
+(LAMBDA L (* lmm "30-Jun-84 00:37") (* ; "fixed bug so that (APPEND (QUOTE (A B . C))) was (QUOTE (A B . C))") (COND ((EQ L 0) NIL) ((EQ L 1) (\APPEND2 (ARG L 1) NIL)) (T (bind (VAL _ (ARG L L)) (N _ L) while (IGREATERP (add N -1) 0) do (SETQ VAL (\APPEND2 (ARG L N) VAL)) finally (RETURN VAL)))))
+)
+
+(\APPEND2
+(LAMBDA (L1 L2) (* lmm "30-Jun-84 00:30") (COND ((LISTP L1) (PROG ((VAL (CONS (CAR L1) L2)) TAIL) (SETQ TAIL VAL) LP (FRPLACD TAIL (SETQ TAIL (LIST (CAR (OR (LISTP (SETQ L1 (CDR L1))) (PROGN (FRPLACD TAIL (OR L2 L1)) (RETURN VAL))))))) (GO LP))) ((NLISTP L2) L1) (T L2)))
+)
+
+(ASSOC
+(LAMBDA (KEY ALST) (* bvm%: "20-FEB-81 14:58") (PROG NIL LP (COND ((NLISTP ALST) (RETURN)) ((AND (LISTP (CAR ALST)) (EQ (CAAR ALST) KEY)) (RETURN (CAR ALST)))) (SETQ ALST (CDR ALST)) (GO LP)))
+)
+
+(ATTACH
+(LAMBDA (X L) (COND ((LISTP L) (FRPLACA (FRPLACD L (CONS (CAR L) (CDR L))) X)) ((NULL L) (CONS X)) (T (ERRORX (LIST 4 L)))))
+)
+
+(CHANGEPROP
+(LAMBDA (X PROP1 PROP2) (* wt%: "31-MAY-79 22:28") (PROG ((Z (COND ((LITATOM X) (GETPROPLIST X)) (T (ERRORX (LIST 14 X)))))) LP (RETURN (COND ((NLISTP Z) NIL) ((EQ (CAR Z) PROP1) (FRPLACA Z PROP2) X) (T (SETQ Z (CDR (LISTP (CDR Z)))) (GO LP))))))
+)
+
+(CONCATLIST
+(LAMBDA (L) (* ; "Edited 24-Nov-86 17:37 by jop:") (PROG (STR FATP) (* ; "Try to pre-determine FATP, at least for strings and litatoms, where it is easy to tell.") (SETQ STR (ALLOCSTRING (for X in L sum (OR FATP (COND ((STRINGP X) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X))) ((LITATOM X) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X))))) (NCHARS X)) NIL NIL FATP)) (for X in L as I from 1 by (NCHARS X) do (RPLSTRING STR I X)) (RETURN STR)))
+)
+
+(COPY
+(LAMBDA (X) (* lmm "16-FEB-82 22:07") (COND ((NLISTP X) X) (T (PROG (TAIL (VAL (LIST (COPY (CAR X))))) (SETQ TAIL VAL) LP (COND ((NLISTP (SETQ X (CDR X))) (AND X (FRPLACD TAIL X)) (RETURN VAL))) (FRPLACD TAIL (SETQ TAIL (CONS (COPY (CAR X))))) (GO LP)))))
+)
+
+(DEFINEQ
+(NLAMBDA X (DEFINE X)))
+
+(DEFLIST
+(LAMBDA (L PROP) (PROG NIL LP (COND ((NLISTP L) (RETURN))) (PUTPROP (CAAR L) PROP (CADAR L)) (* ; "NOTE: this call to PUTPROP is changed to /PUTPROP later in the loadup.") (SETQ L (CDR L)) (GO LP)))
+)
+
+(DREMOVE
+(LAMBDA (X L) (COND ((NLISTP L) NIL) ((EQ X (CAR L)) (COND ((CDR L) (FRPLACA L (CADR L)) (FRPLACD L (CDDR L)) (DREMOVE X L)))) (T (PROG (Z) (DECLARE (LOCALVARS Z)) (SETQ Z L) LP (COND ((NLISTP (CDR L)) (RETURN Z)) ((EQ X (CADR L)) (FRPLACD L (CDDR L))) (T (SETQ L (CDR L)))) (GO LP)))))
+)
+
+(DREVERSE
+(LAMBDA (L) (PROG (Y Z) (DECLARE (LOCALVARS Y Z)) R1 (COND ((NLISTP (SETQ Y L)) (RETURN Z))) (SETQ L (CDR L)) (SETQ Z (FRPLACD Y Z)) (GO R1)))
+)
+
+(DSUBST
+(LAMBDA (NEW OLD EXPR) (* lmm "16-FEB-82 22:10") (PROG (B) (COND ((EQ OLD (SETQ B EXPR)) (RETURN (COPY NEW)))) LP (COND ((NLISTP EXPR) (RETURN B)) ((EQUAL OLD (CAR EXPR)) (FRPLACA EXPR (COPY NEW))) (T (DSUBST NEW OLD (CAR EXPR)))) (COND ((AND OLD (EQ OLD (CDR EXPR))) (FRPLACD EXPR (COPY NEW)) (RETURN B))) (SETQ EXPR (CDR EXPR)) (GO LP)))
+)
+
+(EQLENGTH
+(LAMBDA (X N) (* bvm%: "14-Feb-85 00:34") (* ;; "Generated by paatern match.  INcluded so user can load code that has been dwimified and or compiled into a nonclisp system and run it.") (COND ((ILESSP N 0) NIL) ((EQ N 0) (NLISTP X)) (T (AND (LISTP (SETQ X (NTH X N))) (NLISTP (CDR X))))))
+)
+
+(EVERY
+(LAMBDA (EVERYX EVERYFN1 EVERYFN2) (* ;; "Note that EVERY does not compile open, although SOME does.") (PROG NIL CL:LOOP (COND ((NLISTP EVERYX) (RETURN T)) ((NULL (APPLY* EVERYFN1 (CAR EVERYX) EVERYX)) (RETURN NIL))) (SETQ EVERYX (COND (EVERYFN2 (APPLY* EVERYFN2 EVERYX)) (T (CDR EVERYX)))) (GO CL:LOOP)))
+)
+
+(GETLIS
+(LAMBDA (X PROPS) (* wt%: "31-MAY-79 22:25") (PROG ((Z (COND ((LITATOM X) (GETPROPLIST X)) (T X)))) LP (RETURN (COND ((NLISTP Z) NIL) ((FMEMB (CAR Z) PROPS) Z) (T (SETQ Z (CDR (LISTP (CDR Z)))) (GO LP))))))
+)
+
+(INTERSECTION
+(LAMBDA (X Y) (PROG ((R (CONS)) S) (DECLARE (LOCALVARS R S)) LP (COND ((NLISTP X) (RETURN (CAR R))) ((COND ((LITATOM (SETQ S (CAR X))) (AND (FMEMB S Y) (NULL (FMEMB S (CAR R))))) (T (AND (MEMBER S Y) (NULL (MEMBER S (CAR R)))))) (TCONC R S))) (SETQ X (CDR X)) (GO LP)))
+)
+
+(KWOTE
+(LAMBDA (X) (* dcl%: 15 SEP 75 15%:25) (COND ((OR (NULL X) (EQ X T) (NUMBERP X)) X) (T (LIST (QUOTE QUOTE) X))))
+)
+
+(LAST
+(LAMBDA (X N) (* ; "Edited 30-Aug-91 09:54 by jrb:") (PROG (XX) (DECLARE (LOCALVARS XX)) (* ;; "Added argument N for CLtL2 compatibility") (COND (N (GO BL))) L (COND ((NLISTP X) (RETURN XX))) (SETQ XX X) (SETQ X (CDR X)) (GO L) BL (SETQ XX (IDIFFERENCE (LENGTH X) N)) (COND ((ILESSP XX 0) (RETURN X)) ((ILESSP N 0) (ERROR "LAST: N is negative" N)) (T (RETURN (NTH X (ADD1 XX)))))))
+)
+
+(LASTN
+(LAMBDA (L N) (PROG (X Y) (DECLARE (LOCALVARS X Y)) (COND ((NLISTP L) (RETURN NIL)) ((NULL (SETQ X (FNTH L N))) (RETURN))) LP (COND ((NULL (SETQ X (CDR X))) (RETURN (CONS Y L)))) (SETQ Y (NCONC1 Y (CAR L))) (SETQ L (CDR L)) (GO LP)))
+)
+
+(LCONC
+(LAMBDA (PTR X) (PROG (XX) (DECLARE (LOCALVARS XX)) (RETURN (COND ((NULL X) PTR) ((OR (NLISTP X) (CDR (SETQ XX (LAST X)))) (SETQ XX X) (GO ERROR)) ((NULL PTR) (CONS X XX)) ((NLISTP PTR) (SETQ XX PTR) (GO ERROR)) ((NULL (CAR PTR)) (FRPLACA (FRPLACD PTR XX) X)) (T (FRPLACD (CDR PTR) X) (FRPLACD PTR XX)))) ERROR (ERROR (QUOTE "bad argument - LCONC") XX)))
+)
+
+(LDIFF
+(LAMBDA (X Y Z) (COND ((EQ X Y) Z) ((AND (NULL Y) (NULL Z)) X) (T (PROG (V) (COND (Z (SETQ V (CDR (FRPLACD (SETQ V (FLAST Z)) (FRPLACD (CONS (CAR X) V)))))) (T (SETQ V (SETQ Z (CONS (CAR X)))))) CL:LOOP (SETQ X (CDR X)) (COND ((EQ X Y) (RETURN Z)) ((NULL X) (RETURN (ERROR (QUOTE "LDIFF: not a tail") Y)))) (SETQ V (CDR (FRPLACD V (FRPLACD (CONS (CAR X) V))))) (GO CL:LOOP)))))
+)
+
+(LDIFFERENCE
+(LAMBDA (X Y) (* lmm "27-Mar-84 16:26") (for Z in X when (NOT (MEMBER Z Y)) collect Z)))
+
+(LENGTH
+(LAMBDA (X) (PROG ((N 0)) (DECLARE (LOCALVARS N)) LP (COND ((NLISTP X) (RETURN N)) (T (SETN N (ADD1 N)) (SETQ X (CDR X)) (GO LP)))))
+)
+
+(LISTGET
+(LAMBDA (LST PROP) (* ; "Edited  3-Sep-87 12:18 by bvm:") (* ;; "like GETPROP but works on lists, searching them two cdrs at a time.") (PROG NIL LP (COND ((NLISTP LST) (RETURN)) ((EQ (CAR LST) PROP) (RETURN (CADR LST)))) (SETQ LST (CDR (LISTP (CDR LST)))) (GO LP)))
+)
+
+(LISTGET1
+(LAMBDA (LST PROP) (* ;; "Used to be called GET.  Like LISTGET but only searches one cdr at a time.") (PROG NIL LP (COND ((NLISTP LST) (RETURN)) ((EQ (CAR LST) PROP) (RETURN (CADR LST)))) (SETQ LST (CDR LST)) (GO LP)))
+)
+
+(LISTPUT
+(LAMBDA (LST PROP VAL) (* ;; "Like PUT but works on lists.  Inverse of LISTGET") (PROG ((X (OR (LISTP LST) (ERRORX (LIST 4 LST)))) X0) CL:LOOP (COND ((NLISTP (CDR X)) (* ; "Odd parity;  either (A B C) or (A B C . D) --- drop thru and add at beginning")) ((EQ (CAR X) PROP) (* ; "found it") (FRPLACA (CDR X) VAL) (RETURN VAL)) ((LISTP (SETQ X (CDDR (SETQ X0 X)))) (GO CL:LOOP)) ((NULL X) (* ;; "Ran out without finding PROP on even parity.  add at end If X is not NIL, means ended in a non-list following even parity, e.g. (A B . C) so drop through and add at front.") (FRPLACD (CDR X0) (LIST PROP VAL)) (RETURN VAL))) ADDFRONT (FRPLNODE LST PROP (CONS VAL (CONS (CAR LST) (CDR LST)))) (RETURN VAL)))
+)
+
+(LISTPUT1
+(LAMBDA (LST PROP VAL) (* lmm "22-Oct-85 16:44") (* ;; "Used to be called PUTL.  Like LISTPUT but only searches one cdr at a time.  Inverse of LISTGET1") (PROG ((X LST)) LP (COND ((NLISTP X) (* ; "Note no checks for lists ending in dotted pairs.") (RETURN (NCONC LST (LIST PROP VAL)))) ((EQ (CAR X) PROP) (COND ((CDR X) (FRPLACA (CDR X) VAL)) (T (FRPLACD X (LIST VAL)))) (RETURN LST))) (SETQ X (CDR X)) (GO LP)))
+)
+
+(LSUBST
+(LAMBDA (NEW OLD EXPR) (* lmm "16-FEB-82 22:11") (* ;; "Substitutes X as a segment for Y in Z.  E.g. LSUBST ((A B) Y (X Y Z)) is (X A B Z) not meaningful for Y an atom and CDR of a list.  if X is NIL, operation effectively deletes Y, i.e. produces a copy without Y in it.") (COND ((NULL EXPR) NIL) ((NLISTP EXPR) (COND ((EQ OLD EXPR) NEW) (T EXPR))) ((EQUAL OLD (CAR EXPR)) (NCONC (COPY NEW) (LSUBST NEW OLD (CDR EXPR)))) (T (CONS (LSUBST NEW OLD (CAR EXPR)) (LSUBST NEW OLD (CDR EXPR))))))
+)
+
+(MAP
+(LAMBDA (MAPX MAPFN1 MAPFN2) (PROG NIL LP (COND ((NLISTP MAPX) (RETURN))) (APPLY* MAPFN1 MAPX) (SETQ MAPX (COND (MAPFN2 (APPLY* MAPFN2 MAPX)) (T (CDR MAPX)))) (GO LP)))
+)
+
+(MAP2C
+(LAMBDA (MAPX MAPY MAPFN1 MAPFN2) (PROG NIL LP (COND ((OR (NLISTP MAPX) (NLISTP MAPY)) (RETURN))) (APPLY* MAPFN1 (CAR MAPX) (CAR MAPY)) (COND (MAPFN2 (SETQ MAPX (APPLY* MAPFN2 MAPX)) (SETQ MAPY (APPLY* MAPFN2 MAPY))) (T (SETQ MAPX (CDR MAPX)) (SETQ MAPY (CDR MAPY)))) (GO LP)))
+)
+
+(MAP2CAR
+(LAMBDA (MAPX MAPY MAPFN1 MAPFN2) (PROG (CL:MAPL MAPE) LP (COND ((OR (NLISTP MAPX) (NLISTP MAPY)) (RETURN CL:MAPL))) (SETQ MAPE (CONS (APPLY* MAPFN1 (CAR MAPX) (CAR MAPY)) MAPE)) (COND (CL:MAPL (FRPLACD (CDR MAPE) (FRPLACD MAPE))) (T (SETQ CL:MAPL MAPE))) (COND (MAPFN2 (SETQ MAPY (APPLY* MAPFN2 MAPY)) (SETQ MAPX (APPLY* MAPFN2 MAPX))) (T (SETQ MAPY (CDR MAPY)) (SETQ MAPX (CDR MAPX)))) (GO LP)))
+)
+
+(MAPC
+(LAMBDA (MAPX MAPFN1 MAPFN2) (PROG NIL LP (COND ((NLISTP MAPX) (RETURN))) (APPLY* MAPFN1 (CAR MAPX)) (SETQ MAPX (COND (MAPFN2 (APPLY* MAPFN2 MAPX)) (T (CDR MAPX)))) (GO LP)))
+)
+
+(MAPCAR
+(LAMBDA (MAPX MAPFN1 MAPFN2) (PROG (CL:MAPL MAPE) LP (COND ((NLISTP MAPX) (RETURN CL:MAPL))) (SETQ MAPE (CONS (APPLY* MAPFN1 (CAR MAPX)) MAPE)) (COND (CL:MAPL (FRPLACD (CDR MAPE) (FRPLACD MAPE))) (T (SETQ CL:MAPL MAPE))) (SETQ MAPX (COND (MAPFN2 (APPLY* MAPFN2 MAPX)) (T (CDR MAPX)))) (GO LP)))
+)
+
+(MAPCON
+(LAMBDA (MAPX MAPFN1 MAPFN2) (PROG (CL:MAPL MAPE MAPY) LP (COND ((NLISTP MAPX) (RETURN CL:MAPL)) ((LISTP (SETQ MAPY (APPLY* MAPFN1 MAPX))) (COND (MAPE (FRPLACD MAPE MAPY)) (T (SETQ CL:MAPL (SETQ MAPE MAPY)))) (PROG NIL LP (COND ((SETQ MAPY (CDR MAPE)) (SETQ MAPE MAPY) (GO LP)))))) (SETQ MAPX (COND (MAPFN2 (APPLY* MAPFN2 MAPX)) (T (CDR MAPX)))) (GO LP)))
+)
+
+(MAPCONC
+(LAMBDA (MAPX MAPFN1 MAPFN2) (PROG (CL:MAPL MAPE MAPY) LP (COND ((NLISTP MAPX) (RETURN CL:MAPL)) ((LISTP (SETQ MAPY (APPLY* MAPFN1 (CAR MAPX)))) (COND (MAPE (FRPLACD MAPE MAPY)) (T (SETQ CL:MAPL (SETQ MAPE MAPY)))) (PROG NIL LP (COND ((SETQ MAPY (CDR MAPE)) (SETQ MAPE MAPY) (GO LP)))))) (SETQ MAPX (COND (MAPFN2 (APPLY* MAPFN2 MAPX)) (T (CDR MAPX)))) (GO LP)))
+)
+
+(MAPLIST
+(LAMBDA (MAPX MAPFN1 MAPFN2) (PROG (CL:MAPL MAPE) LP (COND ((NLISTP MAPX) (RETURN CL:MAPL))) (SETQ MAPE (CONS (APPLY* MAPFN1 MAPX) MAPE)) (COND (CL:MAPL (FRPLACD (CDR MAPE) (FRPLACD MAPE))) (T (SETQ CL:MAPL MAPE))) (SETQ MAPX (COND (MAPFN2 (APPLY* MAPFN2 MAPX)) (T (CDR MAPX)))) (GO LP)))
+)
+
+(MEMBER
+(LAMBDA (X Y) (PROG NIL LP (RETURN (COND ((NLISTP Y) NIL) ((COND ((LITATOM X) (EQ X (CAR Y))) (T (EQUAL X (CAR Y)))) Y) (T (SETQ Y (CDR Y)) (GO LP))))))
+)
+
+(NLEFT
+(LAMBDA (L N TAIL) (* bvm%: "14-Feb-85 00:35") (* ;; "Returns TAIL of L containing N elements more than TAIL, e.g. if TAIL is NIL (the usual case) NLEFT ((A B C D E) 2) is (D E).  If FOO is (A B C D E) and FIE is (CDDDR FOO), (NLEFT FOO 1 FIE) is (C D E).") (PROG ((X L) (Y L)) LP (COND ((EQ N 0) (GO LP1)) ((OR (EQ X TAIL) (NLISTP X)) (RETURN NIL))) (SETQ X (CDR X)) (SUB1VAR N) (GO LP) LP1 (COND ((OR (EQ X TAIL) (NLISTP X)) (RETURN Y))) (SETQ X (CDR X)) (SETQ Y (CDR Y)) (GO LP1)))
+)
+
+(NOTANY
+(LAMBDA (SOMEX SOMEFN1 SOMEFN2) (NULL (SOME SOMEX SOMEFN1 SOMEFN2))))
+
+(NOTEVERY
+(LAMBDA (EVERYX EVERYFN1 EVERYFN2) (NULL (EVERY EVERYX EVERYFN1 EVERYFN2))))
+
+(NTH
+(LAMBDA (X N) (COND ((IGREATERP 1 N) (CONS NIL X)) (T (PROG NIL LP (COND ((NOT (IGREATERP N 1)) (RETURN X)) ((NLISTP X) (RETURN NIL))) (SETQ X (CDR X)) (SETQ N (SUB1 N)) (GO LP)))))
+)
+
+(PUTASSOC
+(LAMBDA (KEY VAL ALST) (* lmm%: 5 SEP 75 119) (PROG ((X (OR (LISTP ALST) (ERRORX (LIST 4 ALST))))) (DECLARE (LOCALVARS X)) LP (COND ((EQ (CAR (OR (LISTP (CAR X)) (GO NEXT))) KEY) (FRPLACD (CAR X) VAL) (RETURN VAL))) NEXT (SETQ X (OR (LISTP (CDR X)) (PROGN (FRPLACD X (LIST (CONS KEY VAL))) (RETURN VAL)))) (GO LP)))
+)
+
+(RATOMS
+(LAMBDA (A FILE RDTBL) (PROG (L X) B (COND ((EQ (SETQ X (RATOM FILE RDTBL)) A) (RETURN (CAR L))) ((SETQ L (TCONC L X)) (GO B)))))
+)
+
+(REMOVE
+(LAMBDA (X L) (COND ((NLISTP L) NIL) ((EQUAL X (CAR L)) (REMOVE X (CDR L))) (T (CONS (CAR L) (REMOVE X (CDR L))))))
+)
+
+(REVERSE
+(LAMBDA (L) (PROG (U) (DECLARE (LOCALVARS U)) CL:LOOP (COND ((NLISTP L) (RETURN U))) (SETQ U (CONS (CAR L) U)) (SETQ L (CDR L)) (GO CL:LOOP)))
+)
+
+(RPT
+(LAMBDA (RPTN RPTF) (DECLARE (SPECVARS RPTN) (LOCALVARS RPTF)) (* ; "Edited  6-Apr-87 13:57 by Pavel") (PROG (RPTV) (DECLARE (LOCALVARS RPTV)) LP (COND ((IGREATERP RPTN 0) (SETQ RPTV (EVAL RPTF (QUOTE INTERNAL))) (SETQ RPTN (SUB1 RPTN)) (GO LP)) (T (RETURN RPTV)))))
+)
+
+(RPTQ
+(NLAMBDA RPTZ (PROG ((RPTN (EVAL (CAR RPTZ) (QUOTE INTERNAL))) RPTV) (DECLARE (SPECVARS RPTN)) RPTQLOOP (COND ((IGREATERP RPTN 0) (SETQ RPTV (APPLY (FUNCTION PROGN) (CDR RPTZ) (QUOTE INTERNAL))) (SETQ RPTN (SUB1 RPTN)) (GO RPTQLOOP))) (RETURN RPTV)))
+)
+
+(FRPTQ
+(NLAMBDA RPTZ (DECLARE (LOCALVARS . T)) (PROG ((RPTN (EVAL (CAR RPTZ) (QUOTE INTERNAL))) RPTV) RPTQLOOP (COND ((IGREATERP RPTN 0) (SETQ RPTV (APPLY (FUNCTION PROGN) (CDR RPTZ) (QUOTE INTERNAL))) (SETQ RPTN (SUB1 RPTN)) (GO RPTQLOOP))) (RETURN RPTV)))
+)
+
+(SASSOC
+(LAMBDA (KEY ALST) (PROG NIL LP (COND ((NLISTP ALST) (RETURN NIL)) ((EQUAL (CAAR ALST) KEY) (RETURN (CAR ALST)))) (SETQ ALST (CDR ALST)) (GO LP)))
+)
+
+(SAVEDEF
+(LAMBDA (X) (COND ((ATOM X) (SAVEDEF1 X)) (T (MAPCAR X (FUNCTION SAVEDEF1))))))
+
+(SAVEDEF1
+(LAMBDA (X) (PROG ((DF (GETD X))) (RETURN (COND (DF (PUTPROP X (SETQ X (SELECTQ (FNTYP X) ((SUBR SUBR* FSUBR FSUBR*) (QUOTE SUBR)) ((EXPR EXPR* FEXPR FEXPR*) (QUOTE EXPR)) ((CEXPR CEXPR* CFEXPR CFEXPR*) (QUOTE CODE)) (COND ((EXPRP X) (QUOTE EXPR)) (T (QUOTE LIST))))) DF) (* ; "NOTE: this call to PUTPROP is changed to /PUTPROP later in the loadup.") X)))))
+)
+
+(SELECT
+(NLAMBDA .SELEC. (DECLARE (LOCALVARS . T)) (* dcl%: 12 Dec 78 09%:08) (APPLY (QUOTE PROGN) (SELECT1 (EVAL (CAR .SELEC.) (QUOTE SELECTQ)) (CDR .SELEC.)) (QUOTE SELECTQ)))
+)
+
+(SELECT1
+(LAMBDA (M L) (DECLARE (LOCALVARS . T)) (* edited%: 8 Dec 78 13%:53) (PROG (C A) LP (SETQ C L) (COND ((NULL (SETQ L (CDR L))) (RETURN C)) ((NLISTP (CAR (SETQ C (CAR C)))) (AND (EQ M (EVAL (CAR C) (QUOTE INTERNAL))) (RETURN (CDR C))) (GO LP))) (SETQ A (CAR C)) L2 (COND ((EQ M (EVAL (CAR A) (QUOTE INTERNAL))) (RETURN (CDR C))) ((LISTP (SETQ A (CDR A))) (GO L2)) (T (GO LP)))))
+)
+
+(SELECTC
+(NLAMBDA SELCQ (* lmm "28-FEB-82 16:07") (DECLARE (LOCALVARS . T)) (APPLY (QUOTE PROGN) ((LAMBDA (M L) (PROG (C TL) LP (SETQ C L) (COND ((NULL (SETQ L (CDR L))) (RETURN C)) ((OR (EQ (SETQ TL (EVAL (CAR (SETQ C (CAR C))) (QUOTE INTERNAL))) M) (AND (LISTP TL) (FMEMB M TL))) (RETURN (CDR C)))) (GO LP))) (EVAL (CAR SELCQ) (QUOTE SELECTQ)) (CDR SELCQ)) (QUOTE SELECTQ)))
+)
+
+(SETQQ
+(NLAMBDA (X Y) (SET X Y)))
+
+(SOME
+(LAMBDA (SOMEX SOMEFN1 SOMEFN2) (* ; "SOME compiles open.") (PROG NIL CL:LOOP (COND ((NLISTP SOMEX) (RETURN NIL)) ((APPLY* SOMEFN1 (CAR SOMEX) SOMEX) (RETURN SOMEX))) (SETQ SOMEX (COND (SOMEFN2 (APPLY* SOMEFN2 SOMEX)) (T (CDR SOMEX)))) (GO CL:LOOP)))
+)
+
+(STRMEMB
+(LAMBDA (X Y) (* rmk%: " 6-JUN-82 15:08") (PROG (C N) (DECLARE (LOCALVARS C N)) (SETQ Y (SUBSTRING Y 1)) B (SETQ N 1) A (COND ((NULL (SETQ C (NTHCHARCODE X N))) (RETURN Y))) (COND ((EQ C (NTHCHARCODE Y N)) (SETQ N (ADD1 N)) (GO A))) (COND ((NULL (GNC Y)) (RETURN)) (T (GO B)))))
+)
+
+(SUB1VAR
+(NLAMBDA (SUB1X) (SET SUB1X (SUB1 (EVAL SUB1X)))))
+
+(SUBSET
+(LAMBDA (MAPX MAPFN1 MAPFN2) (DECLARE (LOCALVARS . T)) (PROG (RESULT TAIL) LP (COND ((NLISTP MAPX) (RETURN RESULT)) ((APPLY* MAPFN1 (CAR MAPX)) (COND ((NULL RESULT) (SETQ RESULT (SETQ TAIL (CONS (CAR MAPX))))) (T (SETQ TAIL (CDR (FRPLACD TAIL (FRPLACD (CONS (CAR MAPX) TAIL))))) (* ; "Eseentially an open TCONC."))))) (SETQ MAPX (COND (MAPFN2 (APPLY* MAPFN2 MAPX)) (T (CDR MAPX)))) (GO LP)))
+)
+
+(SUBST
+(LAMBDA (NEW OLD EXPR) (* lmm "16-FEB-82 22:11") (COND ((NULL EXPR) NIL) ((NLISTP EXPR) (COND ((EQ OLD EXPR) (COPY NEW)) (T EXPR))) (T (CONS (COND ((EQUAL OLD (CAR EXPR)) (COPY NEW)) (T (SUBST NEW OLD (CAR EXPR)))) (SUBST NEW OLD (CDR EXPR))))))
+)
+
+(TAILP
+(LAMBDA (X Y) (* ; "Edited 29-Aug-91 21:23 by jrb:") (* ;; "True if X is A tail of Y X and Y non-null.") (* ; "Included with editor for block compilation purposes.") (AND X (PROG NIL LP (COND ((EQ X Y) (RETURN X)) ((NLISTP Y) (RETURN NIL))) (SETQ Y (CDR Y)) (GO LP))))
+)
+
+(TCONC
+(LAMBDA (PTR X) (PROG (XX) (DECLARE (LOCALVARS XX)) (RETURN (COND ((NULL PTR) (CONS (SETQ XX (CONS X NIL)) XX)) ((NLISTP PTR) (ERROR (QUOTE "bad argument - TCONC") PTR)) ((NULL (CDR PTR)) (FRPLACA PTR (CONS X NIL)) (FRPLACD PTR (CAR PTR))) (T (FRPLACD PTR (CDR (FRPLACD (CDR PTR) (FRPLACD (CONS X (CDR PTR)))))))))))
+)
+
+(UNION
+(LAMBDA (X Y) (DECLARE (LOCALVARS . T)) (* bvm%: "30-Jun-86 16:59") (* ;;; "Defined explicitly to be Y prepended with any elements of X not in Y") (for ELT in X bind HEAD TAIL unless (COND ((LITATOM ELT) (* ; "Optimize MEMBER for a common case") (FMEMB ELT Y)) (T (MEMBER ELT Y))) do (COND (TAIL (RPLACD TAIL (SETQ TAIL (CONS ELT NIL)))) (T (SETQ HEAD (SETQ TAIL (CONS ELT NIL))))) finally (RETURN (COND (TAIL (RPLACD TAIL Y) HEAD) (T Y)))))
+)
+)
+
+
+
+(* ; "ERRORSET stuff")
+
+(DEFINEQ
+
+(ERSETQ
+(NLAMBDA ERSETX (* bvm%: "14-Oct-86 11:42") (ERRORSET (CONS (QUOTE PROGN) ERSETX) T)))
+
+(NLSETQ
+(NLAMBDA NLSETX (* bvm%: "14-Oct-86 11:41") (ERRORSET (CONS (QUOTE PROGN) NLSETX) NIL)))
+
+(XNLSETQ
+(NLAMBDA (XNLSETQX XNLSETFLG XNLSETFN) (ERRORSET XNLSETQX XNLSETFLG XNLSETFN)))
+
+(RESETLST
+(NLAMBDA RESETX (* bvm%: "11-Nov-86 22:26") (* ;; "RESETLST and RESETSAVE together permit the user to combine the effects of several RESETVAR's and RESETFORM's under one function.  RESETLST acts like an ERRORSET which takes an indefinite number of forms, i.e. like PROGN, and errorset protects them, and restores all RESETSAVE's performed while inside of RESETLST.  RESETLST compiles open.") (RESETLST (\EVPROGN RESETX)))
+)
+
+(RESETSAVE
+(NLAMBDA RESETX (* wt%: "23-JUL-79 21:08") (DECLARE (LOCALVARS . T)) (* ;; "for use under a RESETLST.") (SETQ SI::*RESETFORMS* (CONS (COND ((AND (CAR RESETX) (LITATOM (CAR RESETX))) (* ;; "This is the (RESETSAVE var value) form") (PROG1 (CONS (CAR RESETX) (GETTOPVAL (CAR RESETX))) (SETTOPVAL (CAR RESETX) (\EVAL (CADR RESETX))))) ((CDR RESETX) (* ;; "This is the (RESETSAVE savingform restore-form).  CADR of the entry we save is the value of the saving form.  The variable OLDVALUE is bound to this value during restoration.  This makes it more convenient for the restoration to be conditional, e.g. the user can perform (RESETSAVE (FOO mumble) '(AND pred (FIE OLDVALUE)))") (LIST (\EVAL (CADR RESETX)) (\EVAL (CAR RESETX)))) (T (* ;; "This is the (RESETSAVE (fn arg)) form, a special case of the above.  Save (fn oldval) as the restoration expression.") (LET ((FORM (CAR RESETX))) (LIST (LIST (COND ((EQ (CAR FORM) (QUOTE SETQ)) (* ;; "Silly special case: in (RESETSAVE (SETQ var (fn arg))) ignore the SETQ for restoration purposes.") (CAR (CADDR FORM))) (T (CAR FORM))) (\EVAL FORM)))))) SI::*RESETFORMS*)))
+)
+
+(RESETFORM
+(NLAMBDA RESETZ (* ; "Edited  3-Sep-87 12:15 by bvm:") (* ;; "Similar to RESETVAR.  Permits evaluation of a form while resetting a system state, and provides for the system to be returned to that state after evaluation.  RESETX is a form, e.g. (OUTPUT T), (PRINTLEVEL 2) etc. RESETX is evaluated and its value saved.  Then RESETY is evaluated under errorset protection and then (CAR RESETX) is applied to the result of the evaluation of X.  If an error occurs during the evaluation of FORM, the effect of RESETX is still 'undone'") (LET ((SI::*RESETFORMS* (LIST (LIST (LIST (CAAR RESETZ) (\EVAL (CAR RESETZ))))))) (DECLARE (SPECVARS SI::*RESETFORMS*)) (CL:UNWIND-PROTECT (\EVPROGN (CDR RESETZ)) (SI::RESETUNWIND))))
+)
+
+(RESETVARS
+(NLAMBDA RESETX (* ; "Edited 25-Nov-86 23:16 by bvm:") (LET ((SI::*RESETFORMS* (PROGN (* ; "Initialize *RESETFORMS* to list of vars and old values") (for V in (CAR RESETX) collect (if (LISTP V) then (SETQ V (CAR V))) (CONS V (GETTOPVAL V)))))) (DECLARE (LOCALVARS . T) (SPECVARS SI::*RESETFORMS*)) (CL:UNWIND-PROTECT (PROGN (* ; "Set the variables to new values, execute prog body") (for V in (CAR RESETX) do (if (LISTP V) then (SETTOPVAL (CAR V) (\EVPROG1 (CDR V))) else (* ; "initial value NIL") (SETTOPVAL V NIL))) (APPLY (QUOTE PROG) (CONS NIL (CDR RESETX)) (QUOTE INTERNAL))) (SI::RESETUNWIND))))
+)
+
+(RESETVAR
+(NLAMBDA (RESETX RESETY RESETZ) (* ; "Edited 19-Mar-87 16:06 by jrb:") (* ;; "Permits evaluation of a form while resetting a top level variable, and provides for the variable to be automatcally restored after valuation.  In this way, the user pays when he wants to 'rebind' a globalvariable, but does not have to pay for the possiblity, as would be the case if variables such as DFNFLG, LISPXHISTORY, etc. were not global, i.e. were looked up.  In the event of a control-D, or control-C reenter, the variabes will still be restored by EVALQT.  Note that STKEVALs will not do the right t on variables reset by RESETVAR.") (LET ((SI::*RESETFORMS* (LIST (CONS RESETX (GETTOPVAL RESETX))))) (DECLARE (SPECVARS SI::*RESETFORMS*)) (CL:UNWIND-PROTECT (PROGN (SETTOPVAL RESETX (\EVAL RESETY)) (\EVAL RESETZ)) (SI::RESETUNWIND))))
+)
+
+(SI::RESETUNWIND
+(LAMBDA (NORMALP) (* bvm%: " 4-Nov-86 16:53") (while (LISTP SI::*RESETFORMS*) bind OLDVALUE RESETZ do (SETQ RESETZ (pop SI::*RESETFORMS*)) (if (LISTP (CAR RESETZ)) then (* ; "RESETSAVE and RESETFORM do this") (SETQ OLDVALUE (if (CDR RESETZ) then (* ;; "occurs for RESETSAVE's when second argument is specified.  In this case, (CADR RESETZ) is the value of the saving form, i.e. the first argument to RESETSAVE.") (CADR RESETZ) else (CADAR RESETZ))) (APPLY (CAAR RESETZ) (CDAR RESETZ)) else (* ; "RESETSAVE of a symbol sets its value") (SETTOPVAL (CAR RESETZ) (CDR RESETZ)))))
+)
+)
+(DEFINEQ
+
+(SI::NLSETQHANDLER
+(LAMBDA (C) (* bvm%: "16-Sep-86 19:19") (if (AND SI::*NLSETQFLAG* NLSETQGAG) then (ABORT C))))
+)
+
+(RPAQ? SI::*NLSETQFLAG*)
+
+(RPAQ? RESETSTATE)
+
+(PUTPROPS RESETTOPVALS INFO (EVAL BINDS))
+(DEFINEQ
+
+(GENSYM
+(LAMBDA (PREFIX NUMSUFFIX OSTRBUFFER NEW? CHARCODE) (* bvm%: "25-Aug-86 16:03") (* ;;; "Create a unique SYMBOL with the given prefix.") (OR (NULL PREFIX) (STRINGP PREFIX) (LITATOM PREFIX) (CL:STRINGP PREFIX) (\ILLEGAL.ARG PREFIX)) (* ; "The prefix has to be something string-like") (OR (NULL NUMSUFFIX) (FIXP NUMSUFFIX) (\ILLEGAL.ARG NUMSUFFIX)) (* ; "Any number-suffix better be numeric") (OR (NULL OSTRBUFFER) (STRINGP OSTRBUFFER) (\ILLEGAL.ARG OSTRBUFFER)) (* ; "Any buffer you supply better be an Interlisp string") (OR (NULL CHARCODE) (CHARCODEP CHARCODE) (\ILLEGAL.ARG CHARCODE)) (* ; "Any charcode better really be one") (PROG ((BUFSIZE \GS.BUFSIZE) (NUMLEN \GS.NUMLEN) (BUF (OR (STRINGP \GS.BUF) (SETQ \GS.BUF (ALLOCSTRING \GS.BUFSIZE)))) (PREFIXLEN 0) BEG.I ATOM) (COND ((OR (NULL PREFIX) (EQ (SETQ PREFIXLEN (NCHARS PREFIX)) 0)) (SETQ PREFIX) (COND ((NULL CHARCODE) (* ; "Here's the default case") (SETQ CHARCODE (CHARCODE A))))) ((IGREATERP PREFIXLEN (IDIFFERENCE BUFSIZE 10)) (ERROR PREFIX "Too long"))) (COND ((COND (OSTRBUFFER (COND ((NULL NUMSUFFIX) (HELP "OSTRBUFFER supplied without NUMSUFFIX")) ((ILESSP (SETQ BUFSIZE (NCHARS OSTRBUFFER)) (IPLUS 12 PREFIXLEN)) (ERROR OSTRBUFFER "Too short"))) T) (NUMSUFFIX (* ; "Insulate the normal \GS.BUF from random intrusions") (SETQ OSTRBUFFER (ALLOCSTRING (SETQ BUFSIZE (IPLUS PREFIXLEN 12)))) T)) (SETQ BUF OSTRBUFFER))) A (UNINTERRUPTABLY (COND ((COND (OSTRBUFFER (* ; "Use the user-supplied buffer, or a freshly cons'd one if he supplied NUMSUFFIX without OSTRBUFFER") T) ((NOT (FIXP GENNUM)) (* ; "Disaster recovery") (SETQ GENNUM 0) T)) (SETQ NUMLEN (\GS.INITBUF BUF BUFSIZE (OR NUMSUFFIX GENNUM)))) (T (* ;; "In this case, we have kept account of the contents of \GS.BUF so we don't have to call \GS.INITBUF afresh, but rather merely 'patch up' the effect of adding 1 to GENNUM") (COND ((COND ((NOT (IEQP GENNUM \GS.OGENNUM)) (* ; "User perhaps has reset GENNUM") (COND ((ILESSP GENNUM 0) (SETQ GENNUM 0))) T) ((IGEQ GENNUM MAX.FIXP) (* ; "Sigh, two's complement wrap-around") (SETQ GENNUM 0) T)) (SETQ NUMLEN (\GS.INITBUF BUF BUFSIZE GENNUM)))) (* ; "Increment the GENNUM counter and the string buffer buffer.") (COND ((for CNT C to NUMLEN as I from BUFSIZE by -1 do (* ; "Simulates a BCD type add in the gensym string") (SETQ C (NTHCHARCODE \GS.BUF I)) (COND ((ILEQ (add C 1) (CHARCODE 9)) (* ; "ha, carry stops here") (RPLCHARCODE BUF I C) (RETURN)) (T (RPLCHARCODE BUF I (CHARCODE 0)))) finally (RETURN T)) (* ; "Sigh, we have to extend the numerical part") (RPLCHARCODE BUF (IDIFFERENCE BUFSIZE NUMLEN) (CHARCODE 1)) (SETQ NUMLEN (add \GS.NUMLEN 1)))) (SETQ \GS.OGENNUM (add GENNUM 1)))) (* ; "BEG.I will be the beginning index, in the buffer, for the atom") (SETQ BEG.I (ADD1 (IDIFFERENCE BUFSIZE NUMLEN))) (COND (CHARCODE (RPLCHARCODE BUF (add BEG.I -1) CHARCODE))) (COND (PREFIX (RPLSTRING BUF (SETQ BEG.I (IDIFFERENCE BEG.I PREFIXLEN)) PREFIX))) (SETQ \GS.STR (SUBSTRING BUF BEG.I BUFSIZE \GS.STR)) (SETQ ATOM (MKATOM \GS.STR))) (COND ((NUMBERP ATOM) (\ILLEGAL.ARG PREFIX))) (RETURN ATOM)))
+)
+
+(GENSYM?
+(LAMBDA (X) (* lmm " 1-JUN-81 08:30") (AND (LITATOM X) (EQ (NTHCHARCODE X -5) (CHARCODE A)) (FIXP (NTHCHAR X -4)) (FIXP (NTHCHAR X -3)) (FIXP (NTHCHAR X -2)) (FIXP (NTHCHAR X -1)) T))
+)
+
+(\GS.INITBUF
+(LAMBDA (BUF BUFSIZE N) (* lmm "14-Apr-85 20:36") (* ;; "Initializes BUF (which must be a stringp of length BUFSIZE) with the digits of N right-justified and left-0 padded up to a minimum of 4 digits.  Returns the decimal length of N") (PROG (NUMLEN) (RPLSTRING BUF (IDIFFERENCE BUFSIZE (if (ILESSP N 10000) then (* ; "Trick to get leading zeros") (SETQ N (IPLUS N 10000)) (SETQ NUMLEN 4) else (SUB1 (SETQ NUMLEN (NCHARS N))))) N) (AND (EQ BUF \GS.BUF) (SETQ \GS.NUMLEN NUMLEN)) (RETURN NUMLEN)))
+)
+)
+
+
+
+(* ; "GENSYM garbage")
+
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \GS.BUFSIZE 100)
+
+
+(CONSTANTS (\GS.BUFSIZE 100))
+)
+)
+
+(RPAQ? GENNUM 0)
+
+(RPAQ? \GS.OGENNUM -1)
+
+(RPAQ? \GS.NUMLEN 0)
+
+(RPAQ? \GS.BUF NIL)
+
+(RPAQ? \GS.STR (ALLOCSTRING 0))
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS GENNUM \GS.OGENNUM \GS.NUMLEN \GS.BUF \GS.STR)
+)
+
+(ADDTOVAR PRETTYEQUIVLST (SELECTC . SELECTQ))
+
+(ADDTOVAR DWIMEQUIVLST (SELECTC . SELECTQ))
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+
+(CL:PROCLAIM (QUOTE (GLOBAL MAKESYSDATE MAKESYSNAME)))
+
+(PUTPROPS MISC FILETYPE :BCOMPL)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA RESETVARS RESETFORM RESETSAVE RESETLST NLSETQ ERSETQ SELECTC SELECT FRPTQ RPTQ DEFINEQ APPENDTOVAR ADDTOVAR)
+
+(ADDTOVAR NLAML RESETVAR XNLSETQ SUB1VAR SETQQ ADD1VAR)
+
+(ADDTOVAR LAMA APPEND)
+)
+(PUTPROPS MISC COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (1872 22502 (ADD1VAR 1882 . 1945) (ADDTOVAR 1947 . 3626) (APPENDTOVAR 3628 . 5342) (
+APPEND 5344 . 5655) (\APPEND2 5657 . 5944) (ASSOC 5946 . 6151) (ATTACH 6153 . 6291) (CHANGEPROP 6293
+ . 6557) (CONCATLIST 6559 . 7021) (COPY 7023 . 7290) (DEFINEQ 7292 . 7328) (DEFLIST 7330 . 7543) (
+DREMOVE 7545 . 7846) (DREVERSE 7848 . 8006) (DSUBST 8008 . 8361) (EQLENGTH 8363 . 8667) (EVERY 8669 . 
+8987) (GETLIS 8989 . 9209) (INTERSECTION 9211 . 9500) (KWOTE 9502 . 9627) (LAST 9629 . 10022) (LASTN 
+10024 . 10270) (LCONC 10272 . 10639) (LDIFF 10641 . 11031) (LDIFFERENCE 11033 . 11138) (LENGTH 11140
+ . 11286) (LISTGET 11288 . 11568) (LISTGET1 11570 . 11804) (LISTPUT 11806 . 12520) (LISTPUT1 12522 . 
+12950) (LSUBST 12952 . 13456) (MAP 13458 . 13637) (MAP2C 13639 . 13929) (MAP2CAR 13931 . 14343) (MAPC 
+14345 . 14531) (MAPCAR 14533 . 14841) (MAPCON 14843 . 15212) (MAPCONC 15214 . 15590) (MAPLIST 15592 . 
+15895) (MEMBER 15897 . 16063) (NLEFT 16065 . 16562) (NOTANY 16564 . 16645) (NOTEVERY 16647 . 16737) (
+NTH 16739 . 16931) (PUTASSOC 16933 . 17264) (RATOMS 17266 . 17409) (REMOVE 17411 . 17540) (REVERSE 
+17542 . 17699) (RPT 17701 . 17978) (RPTQ 17980 . 18242) (FRPTQ 18244 . 18507) (SASSOC 18509 . 18669) (
+SAVEDEF 18671 . 18763) (SAVEDEF1 18765 . 19138) (SELECT 19140 . 19323) (SELECT1 19325 . 19716) (
+SELECTC 19718 . 20100) (SETQQ 20102 . 20139) (SOME 20141 . 20403) (STRMEMB 20405 . 20698) (SUB1VAR 
+20700 . 20763) (SUBSET 20765 . 21170) (SUBST 21172 . 21430) (TAILP 21432 . 21713) (TCONC 21715 . 22044
+) (UNION 22046 . 22500)) (22534 27202 (ERSETQ 22544 . 22642) (NLSETQ 22644 . 22744) (XNLSETQ 22746 . 
+22838) (RESETLST 22840 . 23277) (RESETSAVE 23279 . 24407) (RESETFORM 24409 . 25141) (RESETVARS 25143
+ . 25761) (RESETVAR 25763 . 26600) (SI::RESETUNWIND 26602 . 27200)) (27203 27332 (SI::NLSETQHANDLER 
+27213 . 27330)) (27422 31229 (GENSYM 27432 . 30510) (GENSYM? 30512 . 30710) (\GS.INITBUF 30712 . 31227
+)))))
+STOP
diff --git a/CLTL2/MISC.LCOM b/CLTL2/MISC.LCOM
new file mode 100644
index 00000000..05cdaf96
Binary files /dev/null and b/CLTL2/MISC.LCOM differ
diff --git a/CLTL2/NEWPRINTDEF b/CLTL2/NEWPRINTDEF
new file mode 100644
index 00000000..d5f606f2
--- /dev/null
+++ b/CLTL2/NEWPRINTDEF
@@ -0,0 +1,1301 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 16:47:22" "{Pele:mv:envos}<LispCore>Sources>CLTL2>NEWPRINTDEF.;2" 68847  
+
+      previous date%: " 3-Sep-91 18:15:55" "{Pele:mv:envos}<LispCore>Sources>CLTL2>NEWPRINTDEF.;1")
+
+
+(* ; "
+Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993 by Venue.  All rights reserved.
+")
+
+(PRETTYCOMPRINT NEWPRINTDEFCOMS)
+
+(RPAQQ NEWPRINTDEFCOMS
+       [(COMS 
+
+(* ;;; "A version of PRINTDEF abstracted so that it can be parameterized for non-teletype devices.")
+
+              
+
+(* ;;; "One example is file DSPRINTDEF which provides one definition for the abstract fns such as WIDTH, XPOSITION etc used here.")
+
+              (FNS PRINTDEF SUPERPRINT SUPERPRINT0 SUBPRINT SUBPRINT1 PRINTPROG PRINTPROGVARS PRINTSQ
+                   BACKARROWP SUBPRINT/ENDLINE RPARS FITP DSFIT1 DSFIT2 SUPERPRINT/SPACE 
+                   SUBPRINT/WRAPPERTAIL))
+        [COMS                                                (* ; "Comment prettyprinter")
+              (FNS SUPERPRINT/COMMENT SEMI-COLON-COMMENT-P SUPERPRINT/COMMENT1 SUPERPRINT/COMMENT2)
+              (INITVARS (COMMENTCOLUMN '(0.6 . 0.1))
+                     (*PRINT-SEMICOLON-COMMENTS* NIL)
+                     (*BACKQUOTE-WRAPPERS* '(BQUOTE %, %,@ %,.]
+        (COMS                                                (* ; 
+                                          "Prettyprintmacros for common lisp and other poor things")
+              (FNS CODEWRAPPER.PRETTYPRINT PROG1.PRETTYPRINT CASE.PRETTYPRINT PROGV.PRETTYPRINT 
+                   DO.PRETTYPRINT INDENTATION.FROM.HERE SEQUENTIAL.PRETTYPRINT)
+              (ALISTS (PRETTYPRINTMACROS UNINTERRUPTABLY LISP:UNWIND-PROTECT RESETLST LISP:BLOCK 
+                             LISP:IF PROG1 LISP:WHEN LISP:UNLESS WITH-READER-ENVIRONMENT LISP:CATCH 
+                             CASE LISP:ECASE LISP:ETYPECASE LISP:TYPECASE LISP:PROGV WITH.MONITOR 
+                             LISP:DO* LISP:DO LISP:DOLIST LISP:DOTIMES)
+                     (PRETTYEQUIVLST PROG* LISP:COMPILER-LET)))
+        [DECLARE%: EVAL@COMPILE DOCOPY (P (LISP:PROCLAIM '(LISP:SPECIAL DEFAULTFONT BOLDFONT USERFONT
+                                                                 SYSTEMFONT CLISPFONT BIGFONT 
+                                                                 PRETTYPRINTMACROS]
+        (DECLARE%: EVAL@COMPILE DONTCOPY
+               (GLOBALVARS CLISPARRAY CHANGESARRAY AVERAGEFNLENGTH %#CAREFULCOLUMNS AVERAGEVARLENGTH
+                      FONTWORDS FONTFNS CLISPCHARS FUNNYATOMLST PRETTYEQUIVLST COMMENTFLG 
+                      *BACKQUOTE-WRAPPERS*)
+               (BLOCKS (DSPRETTY PRINTDEF SUPERPRINT SUPERPRINT0 SUBPRINT SUBPRINT1 PRINTPROG 
+                              PRINTPROGVARS PRINTSQ BACKARROWP RPARS FITP DSFIT1 DSFIT2
+                              (ENTRIES PRINTDEF SUPERPRINT FITP)
+                              (SPECVARS TAIL LEFT FNSLST FIRSTPOS COMMENTCOL FORMFLG FILEFLG)
+                              (LOCALFREEVARS TAILFLG CHANGEFLG)))
+               (DECLARE%: DONTEVAL@LOAD (FILES (LOADCOMP)
+                                               DSPRINTDEF])
+
+
+
+(* ;;; "A version of PRINTDEF abstracted so that it can be parameterized for non-teletype devices.")
+
+
+
+
+(* ;;; 
+"One example is file DSPRINTDEF which provides one definition for the abstract fns such as WIDTH, XPOSITION etc used here."
+)
+
+(DEFINEQ
+
+(PRINTDEF
+  [LAMBDA (EXPR LEFT FORMFLG TAILFLG FNSLST FILE)            (* ; "Edited 15-Apr-88 11:59 by bvm")
+    (LET ((*STANDARD-OUTPUT* (GETSTREAM FILE 'OUTPUT))
+          (MAKEMAP NIL)
+          (%#RPARS (COND
+                      ((AND %#RPARS (SYNTAXP (CHARCODE "]")
+                                           'RIGHTBRACKET))   (* ; 
+                                                "can only use brackets if read table supports them")
+                       %#RPARS)))
+          SPACEWIDTH)
+         (DECLARE (SPECVARS MAKEMAP SPACEWIDTH %#RPARS))
+         (PROG [(FIRSTPOS (DSPLEFTMARGIN NIL *STANDARD-OUTPUT*))
+                (RMARGIN (SUB1 (DSPRIGHTMARGIN NIL *STANDARD-OUTPUT*)))
+                (TAIL (LIST EXPR))
+                COMMENTCOL CHANGEFLG (FILEFLG (NEQ *STANDARD-OUTPUT* (TTYDISPLAYSTREAM]
+               (DECLARE (SPECVARS RMARGIN FILEFLG FIRSTPOS))
+               (COND
+                  ((AND (NOT (IMAGESTREAMP *STANDARD-OUTPUT*))
+                        (NOT FONTCHANGEFLG))
+                   (DSPFONT 0 *STANDARD-OUTPUT*)))
+               (RESETLST
+                   (RESETSAVE NIL (LIST (FUNCTION DSPFONT)
+                                          (DSPFONT NIL *STANDARD-OUTPUT*)
+                                          *STANDARD-OUTPUT*))
+                   (SETFONT DEFAULTFONT *STANDARD-OUTPUT*)
+                   [COND
+                      [PRETTYFLG [SETQ LEFT (COND
+                                               ((NOT LEFT)
+                                                FIRSTPOS)
+                                               ((NUMBERP LEFT)
+                                                (PLUS FIRSTPOS (BLANKS LEFT)))
+                                               (T (DSPXPOSITION NIL *STANDARD-OUTPUT*]
+                             (COND
+                                ((GREATERP (DSPXPOSITION NIL *STANDARD-OUTPUT*)
+                                        LEFT)
+                                 (TERPRI *STANDARD-OUTPUT*)))
+                             (DSPXPOSITION LEFT *STANDARD-OUTPUT*)
+                             (COND
+                                (TAILFLG (SUBPRINT EXPR NIL NIL *STANDARD-OUTPUT*))
+                                (T (SUPERPRINT EXPR TAIL NIL *STANDARD-OUTPUT*]
+                      (T (COND
+                            (TAILFLG (MAPRINT EXPR *STANDARD-OUTPUT* NIL NIL NIL
+                                            (FUNCTION PRIN2S)))
+                            (T (PRIN2S EXPR TAIL *STANDARD-OUTPUT*])])
+
+(SUPERPRINT
+  [LAMBDA (E TAIL BRFLG FILE)                                (* ; "Edited 14-Apr-88 18:44 by bvm")
+    (SETQ FILE (\GETSTREAM FILE 'OUTPUT))
+    (COND
+       [(NLISTP E)
+        (OR [AND (NOT MAKEMAP)
+                 (NOT (ATOM E))
+                 (LET ((MACRO (ASSOC (TYPENAME E)
+                                     PRETTYPRINTYPEMACROS)))
+                      (AND MACRO (NEQ (APPLY* (CDR MACRO)
+                                             E)
+                                      E]
+            (COND
+               ((STRINGP E)
+                (PRIN2STRING E TAIL FILE LEFT RMARGIN))
+               (T (LET [(TEM (IDIFFERENCE RMARGIN (WIDTH E FILE T]
+                                                             (* ; 
+                                                     "TEM is the last position at which E will fit")
+                       (COND
+                          ((AND (ILESSP TEM (DSPXPOSITION NIL FILE))
+                                (IGREATERP TEM FIRSTPOS))
+                           (SUBPRINT/ENDLINE (IMIN LEFT TEM)
+                                  FILE)))
+                       (PRIN2S E TAIL FILE]
+       ((AND (SUPERPRINTEQ (CAR E)
+                    COMMENTFLG)
+             (OR FORMFLG (SEMI-COLON-COMMENT-P E)))
+        (SUPERPRINT/COMMENT E FILE))
+       ((AND PRETTYTRANFLG (NOT (ARGTYPE (CAR E)))
+             (GETHASH E CLISPARRAY))
+        (SUPERPRINT0 (GETHASH E CLISPARRAY)
+               TAIL BRFLG FILE))
+       (T (SUPERPRINT0 E TAIL BRFLG FILE])
+
+(SUPERPRINT0
+  [LAMBDA (E TAIL BRFLG FILE)                                (* ; "Edited 14-Apr-88 18:44 by bvm")
+                                                             (* ; 
+                             "BRFLG says do not print a ) as expression will be terminated by a ].")
+    (PROG ((FN (CAR E))
+           MACRO)
+          [COND
+             ((NOT (LISP:SYMBOLP FN)))
+             ((AND (SETQ MACRO (GET FN 'PRETTYWRAPPER))
+                   (LISTP (CDR E))
+                   (NULL (CDDR E))
+                   (SETQ MACRO (LISP:FUNCALL MACRO E FILE))) (* ; 
+"Special case that DEDIT can handle: a 'wrapper' form wants to pretty print via a read macro syntax")
+              (RETURN (SUPERPRINT/WRAPPER MACRO E TAIL BRFLG FILE)))
+             ((SETQ MACRO (AND (NOT MAKEMAP)
+                               (ASSOC FN PRETTYPRINTMACROS)))
+              (COND
+                 ((NOT (SETQ MACRO (APPLY* (CDR MACRO)
+                                          E)))               (* ; "macro printed the thing")
+                  (RETURN E))
+                 ((NEQ E MACRO)                              (* ; 
+                                                        "macro returns something else to print (!)")
+                  (RETURN (SUPERPRINT MACRO TAIL BRFLG FILE)))
+                 (T (SETQ E MACRO]
+          (LET [(LEFT NIL)
+                (NEWBR (AND (NULL BRFLG)
+                            (FIXP %#RPARS)
+                            (RPARS E %#RPARS]            (* ; 
+                         "LEFT is set from within SUBPRINT.  Only appears here for call to ENDLINE")
+               (PRINOPEN TAIL (COND
+                                 (NEWBR '%[)
+                                 (T '%())
+                      FILE)
+               (SUBPRINT E (OR BRFLG NEWBR)
+                      NIL FILE)
+               [COND
+                  ((ILESSP RMARGIN (IPLUS (DSPXPOSITION NIL FILE)
+                                          (WIDTH ")" FILE)))
+                   (PROG (TAIL)
+
+                    (* ;; "need to rebind tail because if next expression is a comment dont want to print it yet because we still have the right paren to print.")
+
+                         (SUBPRINT/ENDLINE LEFT FILE]
+               (PRINSHUT TAIL (COND
+                                 (NEWBR '%])
+                                 (BRFLG NIL)
+                                 (T '%)))
+                      FILE))
+          (RETURN E])
+
+(SUBPRINT
+  [LAMBDA (TAIL BRFLG END FILE)                              (* ; "Edited 26-Apr-88 10:48 by bvm")
+
+    (* ;; "Prettyprint the elements of TAIL until we reach END.")
+
+    (PROG [CURRENT DOCRFLG NEXT TEM OLDY CLISPWORD (FORMFLG FORMFLG)
+                 (FORMFLG0 FORMFLG)
+                 (TAIL0 TAIL)
+                 (LEFT0 (DSPXPOSITION NIL FILE))
+                 (CLW0 (CAR (SUPERPRINTGETPROP (CAR TAIL)
+                                   'CLISPWORD]
+          (SETQ LEFT LEFT0)                                  (* ; 
+                                                   "LEFT is set from SUBPRINT.  Start where we are")
+      LP  [COND
+             ((EQ TAIL END)
+              (RETURN TAIL))
+             ((NULL TAIL)
+              (RETURN))
+             ((NLISTP TAIL)
+              (RETURN (PRINDOTP TAIL FILE]
+          (SETQ OLDY (DSPYPOSITION NIL FILE))
+          (SETQ CURRENT (CAR TAIL))
+          [if (LITATOM CURRENT)
+              then (if (AND (NEQ TAIL TAIL0)
+                                    (LISTP (CDR TAIL))
+                                    (NULL (CDDR TAIL))
+                                    (FMEMB CURRENT *BACKQUOTE-WRAPPERS*)
+                                    (SETQ TEM (GET CURRENT 'PRETTYWRAPPER))
+                                    (NEQ (CDR TAIL)
+                                         END)
+                                    (NOT MAKEMAP)
+                                    (SETQ TEM (LISP:FUNCALL TEM TAIL FILE)))
+                           then                          (* ; "tail of expression is something with a pretty wrapper, e.g., (foo . ,bar), which if we printed it normally would come out (foo \, bar)")
+                                 (SUBPRINT/WRAPPERTAIL TAIL TEM BRFLG)
+                                 (RETURN)
+                         elseif [AND CLISPFLG FORMFLG0 (SETQ CLISPWORD (SUPERPRINTGETPROP
+                                                                            CURRENT
+                                                                            'CLISPWORD]
+                           then (OR (EQ CLW0 (CAR CLISPWORD))
+                                        (SETQ CLISPWORD NIL]
+          [SETQ FORMFLG (AND FORMFLG0 (NOT (SUPERPRINTEQ (CAR TAIL0)
+                                                  'QUOTE]
+
+     (* ;; "says whether next expression is to be treated as a form.  used to be an argument to superprint but this value of formflg should also affect the call to endline from subprint.")
+
+          (SETFONT (PROG1 (AND FORMFLG0 (LITATOM CURRENT)
+                               (SETFONT (COND
+                                           ((LISTP CLISPWORD)
+                                            CLISPFONT)
+                                           ((FMEMB CURRENT FONTWORDS)
+                                            USERFONT)
+                                           ((AND (EQ TAIL0 TAIL)
+                                                 (NULL END))
+                                            (COND
+                                               ((OR (FMEMB CURRENT FNSLST)
+                                                    (FMEMB CURRENT (LISTP FONTFNS)))
+                                                USERFONT)
+                                               ((FGETD CURRENT)
+                                                SYSTEMFONT)))
+                                           ((AND (SUPERPRINTGETPROP CURRENT 'CLISPTYPE)
+                                                 (NOT (FMEMB CURRENT CLISPCHARS)))
+                                                             (* ; 
+                                                           "Infix operators like GT AND etc.")
+                                            CLISPFONT))
+                                      FILE))
+
+                       (* ;; "When printing a function via a call to prettydef and fontflg is turned on and the function is either on FNS or on FONTFLG do a fontchange.")
+
+                       (SETQ CURRENT (SUPERPRINT CURRENT TAIL (AND (NULL (CDR TAIL))
+                                                                       BRFLG)
+                                            FILE)))
+                 FILE)                                       (* ; 
+                     "Reason for (SETQ CURRENT --) is in case CURRENT is printed as something else")
+
+     (* ;; "Popping TAIL used to be done in the call to SUPERPRINT.  But this can cause subsequent comments to be printed first if ENDLINE is called because of no space.  BRFLG only affects last expression in list.")
+
+          (SETQ TAIL (CDR TAIL))
+
+     (* ;; 
+   "CURRENT is always the element just printed;  NEXT the one about to be i.e.  CAR of TAIL")
+
+      LP0 (COND
+             ((OR (EQ TAIL END)
+                  (NLISTP TAIL))
+              (GO LP))
+             ((OR (NULL CLISPFLG)
+                  (NULL FORMFLG)
+                  (NULL FORMFLG0))                           (* ; "Skip this clisp stuff")
+              (GO LP1))
+             [(NOT (LITATOM (SETQ NEXT (CAR TAIL]
+             ([AND (SETQ TEM (SUPERPRINTGETPROP NEXT 'CLISPWORD))
+                   (OR (NLISTP TEM)
+                       (EQ CLW0 (CAR TEM]
+
+              (* ;; "AND and OR are treated like prettywords because they are broadscope operators i.e. they permit segments and therefore the standard FITP test can't be used.")
+
+              (GO CLISPWORD))
+             ([AND (EQ (CADR (LISTP TAIL))
+                       '_)
+                   (OR (SUPERPRINTEQ (CAR TAIL0)
+                              'CREATE)
+                       (SUPERPRINTEQ (CAR TAIL0)
+                              'create]
+              (GO CR)))
+          (COND
+             ((LISTP CURRENT))
+             ((NOT (LITATOM CURRENT))
+              (GO LP1))
+             ((SELECTQ (CAR CLISPWORD)
+                  ((IFWORD FORWORD) 
+                       T)
+                  NIL)
+              (SETQ DOCRFLG NIL)
+              (COND
+                 ((NULL END)
+                  (SETQ END T)))                             (* ; "See use of END below")
+              )
+             ([NOT (OR (NULL CLISPIFYPACKFLG)
+                       (ATOM NEXT)
+                       (COND
+                          [(EQ TAIL (CDR TAIL0))
+                           (OR (FGETD CURRENT)
+                               (SUPERPRINTGETPROP CURRENT 'EXPR]
+                          (T (BOUNDP CURRENT)))
+                       (FMEMB CURRENT FUNNYATOMLST)
+                       (NOT (FMEMB (SETQ TEM (NTHCHAR CURRENT -1))
+                                   CLISPCHARS))
+                       (EQ TEM '>]                           (* ; "E.g.  X* (FOO) Don't space")
+              (GO LP))
+             ((BACKARROWP CURRENT)                       (* ; 
+          "E.G.  IF -- THEN FOO_X FIE_Y is more readable if the assignments are on separate lines.")
+              (GO CR)))
+      LP1 [COND
+             ((EQ TAIL (CDR TAIL0))                          (* ; 
+                                          "First time through i.e. just superprinted HEAD of list.")
+              (COND
+                 ((LISTP CURRENT)
+                  (GO CR))
+                 ((AND FORMFLG0 (SELECTQ (OR (CDR (FASSOC CURRENT PRETTYEQUIVLST))
+                                             CURRENT)
+                                    (COND (SETQ LEFT (IPLUS LEFT0 (WIDTH "CO" FILE)))
+                                          (GO CR))
+                                    ((PROG RESETVARS) 
+                                         (RETURN (PRINTPROG TAIL BRFLG FILE CURRENT)))
+                                    (SELECTQ (RETURN (PRINTSQ TAIL BRFLG FILE)))
+                                    ((SETQ RESETVAR) 
+                                         (GO SP))
+                                    (FUNCTION                (* ; 
+         "If FUNCTION has a second arg, fall thru and reset margin.  Else leave it for compactness")
+                                              (OR (CDR TAIL)
+                                                  (GO SP)))
+                                    ([LAMBDA NLAMBDA] 
+                                         (SETQ DOCRFLG T)
+                                         (SETQ LEFT (IPLUS LEFT0 (BLANKS 1)))
+                                         (SUPERPRINT/SPACE FILE)
+                                         (GO LP))
+                                    NIL)))
+                 ((NOT (FITP TAIL T [OR (LISTP END)
+                                            (AND CLISPWORD (SUBPRINT1 TAIL (CAR CLISPWORD]
+                              NIL FILE))
+                  (GO CR)                                    (* ; "Don't reset I.")
+                  )
+                 (T (SUPERPRINT/SPACE FILE)              (* ; "Default head of form handling")
+                    [SETQ LEFT (IMIN (DSPXPOSITION NIL FILE)
+                                     (IPLUS LEFT0 (BLANKS 6] (* ; "Dont indent too far")
+                    (GO LP]
+          (COND
+             ([AND (NEQ OLDY (DSPYPOSITION NIL FILE))
+                   (OR (NOT (ATOM CURRENT))
+                       (EQ CURRENT '>]
+              (GO CR)))
+
+     (* ;; "Printing last 'thing' (usually a list) caused a c.r.  Also occurs if printing angle brackets which contain a list inside e.g. < (FOO (FIE) X) > and c.r. will occur after >.")
+
+          (SETQ NEXT (CAR TAIL))
+          (COND
+             [(LISTP CURRENT)
+              (COND
+                 ((OR (NULL END)
+                      (SUPERPRINTEQ (CAR CURRENT)
+                             COMMENTFLG))
+                  (GO CR))
+                 ((AND (LISTP NEXT)
+                       (SUPERPRINTEQ (CAR NEXT)
+                              COMMENTFLG))
+                  (GO SP))
+                 ([AND (LITATOM NEXT)
+                       (OR (SUPERPRINTGETPROP NEXT 'CLISPWORD)
+                           (SUPERPRINTGETPROP NEXT 'CLISPTYPE]
+                  (GO SP))
+                 (T (GO CR]
+             ((NLISTP NEXT)
+              (GO SP))
+             (DOCRFLG 
+
+                    (* ;; "DOCRFLG is set to T whenever a carriage return is performed.  It is reset to NIL whenever a carriage return is NOT performed e.g.  when two atoms are adjacent.  while it is T carriage returns are performed FOLLOWING all expressions.  For example in (A B (C) D (E) F G (H)) (C) D (E) and F would be on separate lines but F G and (H) would all be on the same line.")
+
+                    (GO CR))
+             ((FITP NEXT NIL NIL NIL FILE)
+              (GO SP))
+             (T (GO CR)))
+      SP  (SETQ DOCRFLG NIL)
+          (SUPERPRINT/SPACE FILE)
+          (GO LP)
+      CR  (SETQ DOCRFLG T)
+          (SUBPRINT/ENDLINE NIL FILE)
+          (GO LP)
+      CLISPWORD
+          (PROG ((LEFT LEFT)
+                 (LEFT0 LEFT0)
+                 (CEND))
+                (SELECTQ (OR (CDR (FASSOC NEXT PRETTYEQUIVLST))
+                             NEXT)
+                    ((THEN ELSE ELSEIF then else elseif)     (* ; 
+                                                    "THEN ELSE and ELSEIF always start a new line.")
+                         (SETQ LEFT (IPLUS (SUBPRINT/ENDLINE (IPLUS LEFT0
+                                                                        (BLANKS (SELECTQ NEXT
+                                                                                    ((THEN then) 
+                                                                                         3)
+                                                                                    1)))
+                                                  FILE)
+                                           (BLANKS 1)))
+
+                         (* ;; "Note that in most cases LEFT will be reset again in subprint after printing the CLISPWORD.  It will remain this value only if the next expression wont fit.")
+
+                         (SETQ TAIL (SUBPRINT TAIL BRFLG (SUBPRINT1 (CDR TAIL)
+                                                                    'IFWORD END)
+                                           FILE))
+                         (RETURN))
+                    ((AND OR and or)                         (* ; 
+            "So when new left margin is coputed in next cond it will be based on inner expression.")
+                         (SETQ LEFT0 LEFT)
+                         (SETQ CEND (SUBPRINT1 (CDR TAIL)
+                                           NIL END)))
+                    ((! !!) 
+                         (SETQ CEND (CDDR TAIL)))
+                    (SETQ CEND (SUBPRINT1 (CDR TAIL)
+                                      (CAR (GETP (CAR TAIL0)
+                                                 'CLISPWORD))
+                                      END)))
+                (SETQ LEFT (IPLUS (COND
+                                     ((AND (EQ OLDY (DSPYPOSITION NIL FILE))
+                                           (FITP TAIL NIL CEND NIL FILE))
+                                      (SUPERPRINT/SPACE FILE)
+                                      (DSPXPOSITION NIL FILE))
+                                     (T 
+
+                                 (* ;; "Either last expression involved a CR e.g.  FOR X IN (FOO (FIE) (FUM)) DO -- OR the segment of the list between here and the next CLISPFORWORD will not fit.")
+
+                                        (SUBPRINT/ENDLINE (IPLUS LEFT0 (BLANKS 2))
+                                               FILE)))
+                                  (BLANKS 1)))
+                (SETQ OLDY (DSPYPOSITION NIL FILE))
+                (SETQ CURRENT (CAR (NLEFT TAIL 1 CEND)))
+                (SETQ TAIL (SUBPRINT TAIL BRFLG CEND FILE)))
+          (GO LP0)
+
+     (* ;; "We are now in the position of just having printed the element before E and are ready to look ahead at the next one so go to LP0.")
+
+      ])
+
+(SUBPRINT1
+  [LAMBDA (LST X END)                                        (* bas%: "24-NOV-81 15:28")
+    (bind TMP for L on LST until [OR (EQ L END)
+                                                     [AND (LITATOM (CAR L))
+                                                          (SETQ TMP (GETPROP (CAR L)
+                                                                           'CLISPWORD))
+                                                          (OR (NULL X)
+                                                              (EQ X (CAR TMP]
+                                                     (AND (EQ X 'RECORDWORD)
+                                                          (EQ (CADR L)
+                                                              '_] finally (RETURN L])
+
+(PRINTPROG
+  [LAMBDA (TAIL BRFLG FILE PROGWORD)                         (* ; "Edited 14-Apr-88 18:44 by bvm")
+    (PROG [(LABELL (IDIFFERENCE (DSPXPOSITION NIL FILE)
+                          (STRINGWIDTH "ROG" FILE)))
+           (FORMLEFT (IPLUS (DSPXPOSITION NIL FILE)
+                            (STRINGWIDTH " " FILE]           (* ; 
+                            "LABELL is the position PROG labels start in;  FORMLEFT that for forms")
+          (DSPXPOSITION FORMLEFT FILE)
+          (COND
+             ((AND (CAR TAIL)
+                   (LITATOM (CAR TAIL)))
+              (SUPERPRINT (CAR TAIL)
+                     TAIL
+                     (PROGN (SETQ TAIL (CDR TAIL))
+                            T)
+                     FILE)
+              (SPACES 1 FILE)))                              (* ; "Print PROG variables.")
+          (PRINTPROGVARS TAIL FILE (AND (NULL (SETQ TAIL (CDR TAIL)))
+                                            BRFLG))
+      LP1 (COND
+             ((LISTP TAIL)
+              (SUBPRINT/ENDLINE LABELL FILE)))           (* ; 
+                                                      "ENDLINE resets TAIL when it sees a comment.")
+      LP2 (COND
+             ((NLISTP TAIL)
+              (AND TAIL (PRINDOTP TAIL FILE))
+              (RETURN))
+             ((LISTP (CAR TAIL))
+              (COND
+                 ((ILEQ FORMLEFT (DSPXPOSITION NIL FILE))
+                  (PRINENDLINE FORMLEFT FILE))
+                 (T (DSPXPOSITION FORMLEFT FILE)))
+              (SUPERPRINT (CAR TAIL)
+                     TAIL
+                     (AND (NULL (SETQ TAIL (CDR TAIL)))
+                          BRFLG)
+                     FILE)
+              (GO LP1))
+             (T (COND
+                   ((ILESSP LABELL (DSPXPOSITION NIL FILE))(* ; "Two labels in a row")
+                    (PRINENDLINE LABELL FILE)))
+                (SUPERPRINT (CAR TAIL)
+                       TAIL NIL FILE)                      (* ; "Print the label.")
+                (pop TAIL)
+                (GO LP2])
+
+(PRINTPROGVARS
+  [LAMBDA (TAIL FILE BRFLG)                                  (* bvm%: " 4-May-86 15:01")
+
+(* ;;; "(CAR TAIL) is a VARS list for a PROG etc. Print it suitably")
+
+    (SUPERPRINT (CAR TAIL)
+           TAIL BRFLG FILE])
+
+(PRINTSQ
+  [LAMBDA (TAIL BRFLG FILE)                                  (* bvm%: " 2-Jun-86 15:07")
+    (PROG ((KEYL (QUOTIENT (PLUS LEFT (DSPXPOSITION NIL FILE))
+                        2))
+           FOLD LEFT REST)                                   (* ; 
+                                         "KEYL is the position keys start in;  LEFT that for forms")
+                                                             (* ; 
+                                                           "Print select expression FORMFLG=T")
+          (SUPERPRINT/SPACE FILE)
+          [SETQ FOLD (IPLUS (SETQ LEFT (DSPXPOSITION NIL FILE))
+                            (TIMES 2 (DIFFERENCE LEFT KEYL]
+          (SUPERPRINT (CAR TAIL)
+                 TAIL NIL FILE)
+      LP  (OR (SETQ TAIL (CDR TAIL))
+              (RETURN))
+          (PRINENDLINE KEYL FILE)
+          (COND
+             ((NLISTP TAIL)
+              (RETURN (PRINDOTP TAIL FILE)))
+             [(CDR TAIL)
+              (COND
+                 ((LISTP (CAR TAIL))
+                  (PRINOPEN TAIL '%( FILE)
+                  (PROG (FORMFLG)                            (* ; "Print keys not as function")
+                        (SUPERPRINT (CAAR TAIL)
+                               (CAR TAIL)
+                               NIL FILE))
+                  (AND (SETQ REST (CDAR TAIL))
+                       (PROG ((LEFT LEFT)
+                              (HERE (DSPXPOSITION NIL FILE)))
+                             (SUPERPRINT/SPACE FILE)
+                             (COND
+                                ((OR (LISTP (CAAR TAIL))
+                                     (IGEQ HERE FOLD))
+                                 [COND
+                                    ((AND (LISTP (CAR REST))
+                                          (EQMEMB (CAAR REST)
+                                                 COMMENTFLG))(* ; "Start comment on same line")
+                                     (PROG ((LEFT LEFT))
+                                           (SUBPRINT REST NIL (CDR REST)
+                                                  FILE))
+                                     (SETQ REST (CDR REST]
+                                 (PRINENDLINE LEFT FILE))
+                                (T (SETQ LEFT HERE)))
+                             (SUBPRINT REST NIL NIL FILE)))
+                  (PRINSHUT TAIL '%) FILE))
+                 (T (PRIN2S (CAR TAIL)
+                           TAIL FILE]
+             (T (SUPERPRINT (CAR TAIL)
+                       TAIL BRFLG FILE)))
+          (GO LP])
+
+(BACKARROWP
+  [LAMBDA (X)                                                (* bas%: "17-NOV-82 15:19")
+    (AND (STRPOS '_ X)
+         (NEQ (NTHCHARCODE X -1)
+              (CHARCODE _])
+
+(SUBPRINT/ENDLINE
+  [LAMBDA (N FILE)                                           (* lmm "30-Jul-85 03:20")
+    (AND FORMFLG (while (SUPERPRINTEQ [CAR (LISTP (CAR (LISTP TAIL]
+                                   COMMENTFLG) do (SUPERPRINT (CAR TAIL)
+                                                             TAIL NIL FILE) 
+                                                             (* ; "a comment")
+                                                     (pop TAIL)))
+    (PRINENDLINE (OR N LEFT)
+           FILE)
+    N])
+
+(RPARS
+  [LAMBDA (E NP)                                             (* bas%: "11-MAR-83 11:45")
+    (COND
+       ((ILEQ NP 0))
+       ((NLISTP E)
+        NIL)
+       (T (SELECTQ (CAR E)
+              ([LAMBDA NLAMBDA] 
+                   T)
+              (DEFINEQ 
+                       (* ;; "Dont want square brakcets around DEFINEQ expressions, because this means last function pair is special with respect to LOADFNS")
+
+                       NIL)
+              (RPARS (CAR (LAST E))
+                     (SUB1 NP])
+
+(FITP
+  [LAMBDA (X TAILFLG ENDTAIL LSTCOL FILE)                    (* ; "Edited 14-Apr-88 18:39 by bvm")
+
+    (* ;; "Value is T unless X doesnt fit.  There are two cases: one where X is a tail (only called for the first tail i.e. CDR of an expression) and the second where it is an element.  They differ in their treatment of linear lists of atoms.  If one is about to print (FOO A B C D E F) and it wont fit on a line then do a carriage return and start printing.  However if A B C D E F doesnt fit doesnt mean to do a carriage return (and then line all the atoms up in a column).  The idea is that long lists are given as much room as possible (the first carriage return) but not at the expense of making them be vertical.")
+
+    (DECLARE (SPECVARS ENDTAIL))                         (* ; 
+                                     "ENDTAIL is the end of TAIL e.g. when printing CLISP segments")
+    (OR FILE (SETQ FILE *STANDARD-OUTPUT*))                  (* ; 
+                   "Don't let FILE be NIL, since CHARWIDTH and STRINGWIDTH won't default correctly")
+    (LET* [(SPACEWIDTH (CHARWIDTH (CHARCODE SPACE)
+                              FILE))
+           (CAREFUL (BLANKS %#CAREFULCOLUMNS))
+           (N (- (OR LSTCOL RMARGIN)
+                 (DSPXPOSITION NIL FILE]
+          (DECLARE (SPECVARS SPACEWIDTH CAREFUL))
+          (COND
+             (TAILFLG (AND (> N (BLANKS (+ AVERAGEVARLENGTH 2)))
+                           (DSFIT1 X N NIL FILE)))
+             (T (DSFIT2 X N NIL FILE])
+
+(DSFIT1
+  [LAMBDA (LST N N1 FILE)                                    (* lmm "30-Jul-85 03:08")
+    (DECLARE (USEDFREE CAREFUL ENDTAIL))
+
+    (* ;; "Checks to see if LST could fit in N spaces.")
+
+    (bind (M _ (COND
+                      (TAILFLG NIL)
+                      (T N))) for L on LST until (EQ L ENDTAIL)
+       do (COND
+                 [(NLISTP (CAR L))
+                  (COND
+                     (M [SETQ M (IDIFFERENCE M (IPLUS (COND
+                                                         ((ILESSP M CAREFUL)
+                                                             (* ; 
+                                 "When getting near right margin actually perform the WIDTH check.")
+                                                          (WIDTH (CAR L)
+                                                                 FILE T))
+                                                         (T (BLANKS AVERAGEVARLENGTH)))
+                                                      (BLANKS 1]
+                        (COND
+                           ((ILESSP M 0)
+                            (RETURN NIL]
+                 ((DSFIT2 (CAR L)
+                         (OR N1 N)
+                         NIL FILE)
+
+                  (* ;; "The extra argument to DSFIT1 is for use in connectionwith CLISPPRETTYWORDS e.g. FOR IF etc. Normally we figure that any lists can be printed at the position corresponding to the first argument ut with FOR's and IF's et al they would always be preceded by the corresponding CLISP word.")
+
+                  (AND M (SETQ M N))                         (* ; 
+                                           "Reset count when LISTP reached as margin will be reset")
+                  )
+                 (T (RETURN NIL))) finally (RETURN T])
+
+(DSFIT2
+  [LAMBDA (X N NC FILE)                                      (* lmm "30-Jul-85 03:09")
+    (DECLARE (USEDFREE CAREFUL))                         (* ; "NC is local to DSFIT2")
+    (COND
+       ((SUPERPRINTEQ (CAR X)
+               COMMENTFLG)
+        T)
+       [(LISTP (CAR X))                                      (* ; 
+                                         "Non-atomic CAR of form e.g. COND clause open lambda etc.")
+        (AND [ILESSP 0 (SETQ N (IDIFFERENCE N (WIDTH "()" FILE]
+             (DSFIT2 (CAR X)
+                    N NIL FILE)
+             (OR (NULL (CDR X))
+                 (DSFIT1 (CDR X)
+                        N NIL FILE]
+       ([ILESSP N (IPLUS (WIDTH "()" FILE)
+                         (SETQ NC (COND
+                                     ((ILESSP N CAREFUL)
+                                      (WIDTH (CAR X)
+                                             FILE T))
+                                     (T (BLANKS AVERAGEFNLENGTH]
+
+        (* ;; "Checks to see if there is space for function name and two parentheses.  when there are more than CAREFUL columns left approximate using AVERAGEFNLENGTH.")
+
+        NIL)
+       ((NULL (CDR X))
+        T)
+       ([ILEQ [SELECTQ (CAR X)
+                  (COND 0)
+                  (FUNCTION (WIDTH "(FUNCTION LAMBDA ABC)" FILE))
+                  ([LAMBDA NLAMBDA] 
+                       (WIDTH "(LAMBDA ABC" FILE))
+                  (SETQ (IPLUS (WIDTH "(SETQ " FILE)
+                               (BLANKS AVERAGEVARLENGTH)))
+                  (PROGN (SETQ N (IDIFFERENCE N NC))
+                         (BLANKS (ADD1 AVERAGEFNLENGTH]
+              (SETQ N (IDIFFERENCE N (BLANKS 2]
+
+        (* ;; "The two spaces correspond to the amount LEFT would be decremented on the recursive call to superprint.  the default clause in the selectq checks to see if function and at least one atomic argument (we know there is at least one) will fit.  The call to DSFIT1 checks to see if using normal alignment algorithm the expression can fit.")
+
+        (DSFIT1 (CDR X)
+               N
+               (SELECTQ (CAR (SUPERPRINTGETPROP (CAR X)
+                                    'CLISPWORD))
+                   ((IFWORD FORWORD) 
+                        (IDIFFERENCE N (IPLUS NC (BLANKS 1))))
+                   NIL)
+               FILE])
+
+(SUPERPRINT/SPACE
+  [LAMBDA (FILE)                                             (* ; "Edited 31-Mar-88 12:18 by bvm")
+
+    (* ;; "Print a space, preparing for next item to be printed")
+
+    (DECLARE (LISP:SPECIAL RMARGIN SPACEWIDTH LEFT))     (* ; "bound by prettyprinter stuff")
+    (if (< (- RMARGIN (DSPXPOSITION NIL FILE))
+               (TIMES 2 SPACEWIDTH))
+        then                                             (* ; 
+   "printing a space will overflow the line, or if not then the next char would, so go to new line")
+              (PRINENDLINE LEFT FILE)
+      else (PRIN3 " " FILE])
+
+(SUBPRINT/WRAPPERTAIL
+  [LAMBDA (TAIL MACRO BRFLG)                                 (* ; "Edited 15-Apr-88 11:54 by bvm")
+
+    (* ;; "Called when TAIL = ... wrapperform body), e.g, QUOTE FOO).  We print this as a dotted tail with the wrapper instead.")
+
+    (LET ((DOT ". ")
+          (BODY (CADR TAIL)))
+         (if (NOT (if (NLISTP BODY)
+                          then (< (+ (DSPXPOSITION)
+                                         (WIDTH DOT)
+                                         (WIDTH MACRO)
+                                         (WIDTH BODY NIL T)
+                                         (WIDTH ")"))
+                                      RMARGIN)
+                        else (FITP BODY)))
+             then                                        (* ; "Start a new line")
+                   (PRINENDLINE LEFT))
+         (PRIN3 DOT)
+         (PRIN3 MACRO)
+         (SUPERPRINT BODY (CDR TAIL)
+                BRFLG *STANDARD-OUTPUT*])
+)
+
+
+
+(* ; "Comment prettyprinter")
+
+(DEFINEQ
+
+(SUPERPRINT/COMMENT
+  [LAMBDA (L FILE)                                           (* ; "Edited 13-Apr-88 12:55 by bvm")
+    (DECLARE (USEDFREE LEFT TAIL RMARGIN FILEFLG MAKEMAP))
+    (COND
+       ((AND **COMMENT**FLG (NOT FILEFLG)
+             (NOT MAKEMAP))
+
+        (* ;; "If we're eliding comments, not printing to a file, and not in DEdit, then just print the elision string")
+
+        (COND
+           ((> (+ (DSPXPOSITION NIL FILE)
+                  (STRINGWIDTH **COMMENT**FLG FILE))
+               (DSPRIGHTMARGIN NIL FILE))                  (* ; 
+                                                      "Watch out for overflowing the current line.")
+            (PRINENDLINE (DSPLEFTMARGIN NIL FILE)
+                   FILE)))
+        (PRIN1S **COMMENT**FLG NIL FILE))
+       (T (PROG ((DSLMARG (DSPLEFTMARGIN NIL FILE))
+                 (HERE (DSPXPOSITION NIL FILE))
+                 (COMMENT-RMARGIN RMARGIN)
+                 (SEMIP (SEMI-COLON-COMMENT-P L))
+                 COMMENT-LMARGIN RIGHTFLG BODY HALFLINE)
+                [if SEMIP
+                    then                                 (* ; "Extract the comment body")
+                          (COND
+                             ((OR [NOT (STRINGP (SETQ BODY (CAR (LISTP (CDR (LISTP (CDR L]
+                                  (CDDDR L))                 (* ; "Not a good semi-colon comment")
+                              (SETQ SEMIP NIL]
+                [COND
+                   [[SETQ RIGHTFLG (if SEMIP
+                                       then              (* ; 
+                                                          "Only 1-semi comments go in right margin")
+                                             (EQ SEMIP 1)
+                                     else                (* ; 
+                                                           "Short single * comments go at right")
+                                           (AND (NOT (SUPERPRINTEQ (CADR L)
+                                                            COMMENTFLG))
+                                                (<= (LENGTH L)
+                                                    15]      (* ; 
+                                                           "Print comment in the righthand margin")
+                    (SETQ COMMENT-LMARGIN (OR COMMENTCOL (SUPERPRINT/COMMENT1 L RMARGIN FILE]
+                   ((AND SEMIP (NOT MAKEMAP))                (* ; 
+                                  "Semi-colon comment > 1, unless under DEdit (lest we confuse it)")
+                    (AND SEMIP (> SEMIP 2)
+                         (NOT MAKEMAP))
+                    (SETQ COMMENT-LMARGIN
+                     (if (EQ SEMIP 2)
+                         then                            (* ; "indent like code, but no more than a third of the way over if it would take more than 2 lines to print this.")
+                               [MIN LEFT (MAX (- RMARGIN (FIXR (TIMES (STRINGWIDTH BODY FILE)
+                                                                      0.52)))
+                                              (+ DSLMARG (IQUOTIENT (- RMARGIN DSLMARG)
+                                                                3]
+                       else                              (* ; 
+                                                           "Comment should be printed flush left.")
+                             DSLMARG)))
+                   (T (LET ((INDENT (IQUOTIENT (- RMARGIN DSLMARG)
+                                           11)))             (* ; 
+                      "Print old-style comment centered and wide, indented about 10%% from margins")
+                           (SETQ COMMENT-LMARGIN (+ DSLMARG INDENT))
+                           (SETQ COMMENT-RMARGIN (- RMARGIN INDENT))
+                           (COND
+                              ((EQ HERE COMMENT-LMARGIN)
+
+                               (* ;; "HACK: Almost certainly called from REPP, so we must supress the normal leading and trailing blank lines as they have already been done")
+
+                               (SETQ RIGHTFLG T]
+                (COND
+                   ((AND (NULL RIGHTFLG)
+                         (OR (NOT SEMIP)
+                             (> SEMIP 1)))                   (* ; 
+                                                           "Centered comment starts on new line")
+                    (if (> HERE COMMENT-LMARGIN)
+                        then                             (* ; 
+                                              "We have not yet moved down a line, so do that first")
+                              (TERPRI FILE))
+                    [if (AND (EQ SEMIP 2)
+                                 (IMAGESTREAMP FILE))
+                        then                             (* ; "For 2-semi comments, only go down half line, accomplished by moving up half line now before this next endline")
+                              (RELMOVETO 0 (SETQ HALFLINE (IQUOTIENT (- (DSPLINEFEED NIL FILE))
+                                                                 2]
+                    (PRINENDLINE COMMENT-LMARGIN FILE))
+                   ((< COMMENT-LMARGIN (DSPXPOSITION NIL FILE))
+                                                             (* ; 
+                                                       "Past the starting point, so start new line")
+                    (PRINENDLINE COMMENT-LMARGIN FILE))
+                   (T (DSPXPOSITION COMMENT-LMARGIN FILE)))
+                (SETFONT (PROG1 (SETFONT COMMENTFONT FILE)
+                             (COND
+                                ((AND SEMIP (NOT MAKEMAP)
+                                      (OR *PRINT-SEMICOLON-COMMENTS* (IMAGESTREAMP FILE)))
+                                                             (* ; "do nice semi-colon stuff")
+                                 (PRIN2-LONG-STRING BODY FILE NIL NIL COMMENT-LMARGIN 
+                                        COMMENT-RMARGIN T SEMIP))
+                                (T                           (* ; 
+                             "Old comment or in DEdit (makemap true), so have to do it the old way")
+                                   (SETQ SEMIP NIL)
+                                   (SUPERPRINT/COMMENT2 L COMMENT-LMARGIN (IQUOTIENT (+ 
+                                                                                      COMMENT-LMARGIN
+                                                                                            
+                                                                                      COMMENT-RMARGIN
+                                                                                            )
+                                                                                     2)
+                                          COMMENT-RMARGIN FILE))))
+                       FILE)
+                (if (OR (NULL SEMIP)
+                            (> SEMIP 2))
+                    then                                 (* ; 
+                                   "Old centered comments and big semi-colon comments get new line")
+                          (OR RIGHTFLG (PRINENDLINE DSLMARG FILE))
+                  elseif (NULL (CDR TAIL))
+                    then                                 (* ; "Nothing more will be printed.  So even though we were a short comment, we need to go to new line so that the closing paren is on a new line, rather than here after the comment (AR 8475)")
+                          (PRINENDLINE LEFT FILE)
+                  elseif [AND HALFLINE (NOT (AND (LISTP (CDR TAIL))
+                                                     (SEMI-COLON-COMMENT-P (LISTP (CADR TAIL]
+                    then                                 (* ; "Set off double-semi-colon comment by half line.  Don't do for consecutive comments, since the next comment will take care of it")
+                          (RELMOVETO 0 HALFLINE)
+                          (PRINENDLINE DSLMARG FILE))
+                (RETURN L])
+
+(SEMI-COLON-COMMENT-P
+  [LAMBDA (E)                                                (* ; "Edited 20-Sep-87 18:30 by raf")
+
+    (* ;; "If E is a comment, returns a number giving number of semis (or type).")
+
+    (SELECTQ (CADR E)
+        (;                                                   (* ; 
+                                                           "SEdit-style right-margin comment")
+           1)
+        (;;                                                  (* ; 
+                                                           "SEdit-style current-indent comment")
+            2)
+        (;;;                                                 (* ; "SEdit-style flush left comment")
+             3)
+        (;;;;                                                (* ; "Page boundary type comment")
+              4)
+        (%|                                                  (* ; 
+                                                           "Balanced (hash vertical bar) comment")
+            5)
+        NIL])
+
+(SUPERPRINT/COMMENT1
+  [LAMBDA (CF RMARGIN FILE)                                  (* bvm%: "26-Mar-86 14:03")
+
+(* ;;; "Computes the left margin for comments printed on the right")
+
+    (LET ((EDITDATEP (EDITDATE? CF))
+          LM MINLEFT DEFAULT)
+         (SETQ MINLEFT (IDIFFERENCE [IDIFFERENCE RMARGIN (COND
+                                                            [EDITDATEP 
+                                                             (* ; 
+                                                      "Min space is size of this edit date comment")
+                                                                   (LET ((FONT (DSPFONT COMMENTFONT 
+                                                                                      FILE)))
+                                                                        (PROG1 (WIDTH CF FILE T)
+                                                                               (DSPFONT FONT FILE]
+                                                            (T 
+                                                             (* ; "Else an arbitrary space")
+                                                               (BLANKS 15]
+                              (BLANKS 1)))
+         (SETQ DEFAULT (FIXR (TIMES (OR (FLOATP (CAR (LISTP COMMENTCOLUMN)))
+                                        0.6)
+                                    RMARGIN)))
+         (SETQ LM (IMAX (IQUOTIENT RMARGIN 2)
+                        (IMIN MINLEFT DEFAULT)))             (* ; 
+                                        "use at least enough space, but no more than half the line")
+         (COND
+            ((NOT EDITDATEP)                                 (* ; 
+                                     "Don't have the editdate dictate margin for rest of function!")
+             (SETQ COMMENTCOL LM)))
+         LM])
+
+(SUPERPRINT/COMMENT2
+  [LAMBDA (CMT COMMENT-LMARGIN COMMENT-MIDPOINT COMMENT-RMARGIN FILE)
+                                                             (* bvm%: "28-May-86 15:15")
+    (SETQ FILE (\GETSTREAM FILE 'OUTPUT))
+    (PRINOPEN TAIL '%( FILE)
+    (for TAIL on CMT bind LASTITEM THISITEM
+       do (SETQ THISITEM (CAR TAIL))                     (* ; 
+                                                         "Decide whether to continue on a new line")
+             (COND
+                ([OR (EQ LASTITEM '-)
+                     [AND (IGEQ (DSPXPOSITION NIL FILE)
+                                COMMENT-MIDPOINT)
+                          (OR (LISTP THISITEM)
+                              (AND (LITATOM LASTITEM)
+                                   (SELCHARQ (NTHCHARCODE LASTITEM -1)
+                                        ((; %. -) 
+                                             T)
+                                        NIL]
+                     (PROGN (COND
+                               ((AND (NEQ TAIL CMT)
+                                     (OR (NLISTP LASTITEM)
+                                         (SELECTQ THISITEM
+                                             ((%. %, ; %:) 
+                                                  NIL)
+                                             T)))            (* ; 
+                          "Space before next element unless it looks like punctuation after a list")
+                                (SUPERPRINT/SPACE FILE)))
+                            (AND (NLISTP THISITEM)
+                                 (NOT (STRINGP THISITEM))
+                                 (IGEQ (IPLUS (DSPXPOSITION NIL FILE)
+                                              (WIDTH THISITEM FILE T)
+                                              (WIDTH (COND
+                                                        ((CDR TAIL)
+                                                         " ")
+                                                        (T   (* ; 
+     "Leave space for the paren; i.e., don't print last atom on one line and the paren on the next")
+                                                           ")"))
+                                                     FILE))
+                                       COMMENT-RMARGIN]
+                 (PRINENDLINE COMMENT-LMARGIN FILE)))
+             (COND
+                ((LISTP (SETQ LASTITEM THISITEM))
+                 (SUPERPRINT/COMMENT2 LASTITEM COMMENT-LMARGIN COMMENT-MIDPOINT COMMENT-RMARGIN 
+                        FILE))
+                ((STRINGP LASTITEM)
+                 (PRIN2STRING LASTITEM TAIL FILE COMMENT-LMARGIN COMMENT-RMARGIN T))
+                (T (PRIN2S LASTITEM TAIL FILE))) finally (AND TAIL (PRINDOTP TAIL FILE)))
+    (PRINSHUT TAIL '%) FILE])
+)
+
+(RPAQ? COMMENTCOLUMN '(0.6 . 0.1))
+
+(RPAQ? *PRINT-SEMICOLON-COMMENTS* NIL)
+
+(RPAQ? *BACKQUOTE-WRAPPERS* '(BQUOTE %, %,@ %,.))
+
+
+
+(* ; "Prettyprintmacros for common lisp and other poor things")
+
+(DEFINEQ
+
+(CODEWRAPPER.PRETTYPRINT
+  [LAMBDA (FORM)                                             (* ; "Edited 30-Mar-88 11:44 by bvm")
+
+    (* ;; "Prettyprints things that wrap code like PROGN.  We usually want them to start the code on the next line, rather than put the first expression way to the right of all the rest.")
+
+    (PRIN1 "(")
+    (LET ((HERE (INDENTATION.FROM.HERE)))
+         (PRIN2 (pop FORM))                              (* ; "Print the %"function%" itself")
+         (if (NLISTP FORM)
+             then                                        (* ; "Ignore degenerate cases")
+                   (PRINTDEF FORM T T T FNSLST)
+           else (SEQUENTIAL.PRETTYPRINT FORM HERE))
+         (PRIN1 ")")
+         NIL])
+
+(PROG1.PRETTYPRINT
+  [LAMBDA (EXPR)                                             (* ; "Edited 14-Apr-88 18:39 by bvm")
+
+    (* ;; "Prettyprinter advice for PROG1, CL:IF, UNLESS, etc.  Default way's main problem is that if the first expression is a non-list but some later expression is a list, it doesn't put ALL the subsequent expressions equally indented.  Thus, you get something like (PROG1 A (expression) <cr> (expression) ...)")
+
+    (if [OR [NLISTP (CDR (LISTP (CDR EXPR]
+                (AND (NLISTP (CDDDR EXPR))
+                     (for E in (LISTP (CADDR EXPR)) never (LISTP E]
+        then                                             (* ; "2 or fewer elements, or 3 elements, the last of which is very simple--let default prettyprinter do it")
+              EXPR
+      else (PRIN1 "(")
+            (LET [(HERE (INDENTATION.FROM.HERE))
+                  (LEFT (PROGN (PRIN2 (pop EXPR))        (* ; "Print the car of form")
+                               (SPACES 1)
+                               (DSPXPOSITION]
+                 (DECLARE (SPECVARS LEFT))
+                 (if (OR (if (>= HERE LEFT)
+                                 then                    (* ; 
+           "Default indentation wants to be greater than the function length, so change it to here")
+                                       (SETQ HERE LEFT))
+                             (NLISTP (CAR EXPR))
+                             (FITP (CAR EXPR)))
+                     then (SUPERPRINT (CAR EXPR)
+                                     EXPR NIL *STANDARD-OUTPUT*) 
+                                                             (* ; 
+                                                   "Print the first element right at this position")
+                           (pop EXPR))
+                 (SEQUENTIAL.PRETTYPRINT EXPR HERE))
+            (PRIN1 ")")                                      (* ; "Return NIL to say we handled it")
+            NIL])
+
+(CASE.PRETTYPRINT
+  [LAMBDA (EXPR)                                             (* ; "Edited 26-Apr-88 10:52 by bvm")
+    (if (NLISTP (CDR EXPR))
+        then                                             (* ; "Degenerate case--punt")
+              EXPR
+      else
+      (PRIN1 "(")
+      (LET
+       ((HERE (INDENTATION.FROM.HERE))
+        (LEFT (PROGN (PRIN2 (pop EXPR))                  (* ; "Print the car of form")
+                     (SPACES 1)
+                     (DSPXPOSITION)))
+        (TAIL EXPR)
+        INNERLEFT CASE)
+       (DECLARE (SPECVARS LEFT TAIL))
+       (if (OR (if (>= HERE LEFT)
+                       then                              (* ; 
+           "Default indentation wants to be greater than the function length, so change it to here")
+                             (SETQ HERE LEFT))
+                   (NLISTP (CAR TAIL))
+                   (FITP (CAR TAIL)))
+           then (SUPERPRINT (CAR TAIL)
+                           TAIL NIL *STANDARD-OUTPUT*)     (* ; 
+                                                   "Print the first element right at this position")
+                 (pop TAIL))
+       [SETQ INNERLEFT (+ (SETQ LEFT HERE)
+                          (TIMES 3 (CHARWIDTH (CHARCODE X)
+                                          *STANDARD-OUTPUT*]
+       (do
+        (if (NLISTP TAIL)
+            then (if TAIL
+                         then                            (* ; "dotted tail?")
+                               (PRINENDLINE LEFT *STANDARD-OUTPUT*)
+                               (PRINTDEF TAIL T T T))
+                  (PRIN1 ")")
+                  (RETURN NIL)
+          elseif (SEMI-COLON-COMMENT-P (LISTP (CAR TAIL)))
+            then                                         (* ; 
+                                                     "Print any comments stuck in between elements")
+                  (SUPERPRINT/COMMENT (CAR TAIL)
+                         *STANDARD-OUTPUT*)
+                  (pop TAIL)
+          else                                           (* ; 
+                                                      "Start new line, after printing any comments")
+          (PRINENDLINE LEFT *STANDARD-OUTPUT*)
+          (if (NLISTP (SETQ CASE (CAR TAIL)))
+              then                                       (* ; "Degenerate case?")
+                    (PRIN2 CASE)
+            elseif (FMEMB (CAR CASE)
+                              *BACKQUOTE-WRAPPERS*)
+              then                                       (* ; "backquoted case")
+                    (SUPERPRINT CASE TAIL NIL *STANDARD-OUTPUT*)
+            else
+            (PRIN1 "(")
+            (LET (FORMFLG)
+                 (DECLARE (SPECVARS FORMFLG))            (* ; "Print the key(s) as data")
+                 (SUPERPRINT (CAR CASE)
+                        CASE NIL *STANDARD-OUTPUT*)
+                 (SPACES 1))
+            [if (NLISTP (SETQ CASE (CDR CASE)))
+                then                                     (* ; "No tail, but handle degenerates")
+                      (PRINTDEF CASE T T T)
+              else
+              (SEQUENTIAL.PRETTYPRINT
+               CASE
+               (LET ((HERE (DSPXPOSITION)))
+                    (if [OR (<= HERE INNERLEFT)
+                                (AND (NULL (CDR CASE))
+                                     (if (LISTP (CDR CASE))
+                                         then            (* ; "Multiple things to print")
+                                               NIL
+                                       elseif (NLISTP (CAR CASE))
+                                         then            (* ; 
+                                                           "Print simple consequent if space")
+                                               (< (STRINGWIDTH (CAR CASE)
+                                                         *STANDARD-OUTPUT* T)
+                                                  (- (DSPRIGHTMARGIN)
+                                                     HERE))
+                                       else (FITP CASE T]
+                        then                             (* ; 
+                                        "Key didn't go too far over, so just prettyprint from here")
+                              HERE
+                      else INNERLEFT]
+            (PRIN1 ")"))
+          (pop TAIL])
+
+(PROGV.PRETTYPRINT
+  [LAMBDA (EXPR)                                             (* ; "Edited 14-Apr-88 18:37 by bvm")
+
+    (* ;; "Prettyprinter advice for PROGV.  Default way's main problem is that if the vars and values are non-lists the %"body%" of the form doesn't get uniformly indented.  Thus, you get something like (PROGV vars values (expression) <cr> (expression) ...)")
+
+    (if [OR (NLISTP (CDR EXPR))
+                (LISTP (CADR EXPR))
+                (NLISTP (CDR (LISTP (CDDR EXPR]
+        then                                             (* ; 
+                 "3 or fewer elements, or the second is a list--default prettyprinter will do fine")
+              EXPR
+      else (PRIN1 "(")
+            (LET [(HERE (INDENTATION.FROM.HERE))
+                  (LEFT (PROGN (PRIN2 (pop EXPR))        (* ; "Print the car of form")
+                               (SPACES 1)
+                               (DSPXPOSITION]
+                 (DECLARE (SPECVARS LEFT))
+                 (SUPERPRINT (CAR EXPR)
+                        EXPR NIL *STANDARD-OUTPUT*)        (* ; 
+                                                  "Print the first element (vars) at this position")
+                 (pop EXPR)
+                 (if (OR (NLISTP (CAR EXPR))
+                             (FITP (CAR EXPR)))
+                     then (SPACES 1)                     (* ; 
+                                                           "Room for next element (values) here")
+                           (SUPERPRINT (CAR EXPR)
+                                  EXPR NIL *STANDARD-OUTPUT*)
+                           (pop EXPR))                   (* ; "Finally, print the body")
+                 (SEQUENTIAL.PRETTYPRINT EXPR HERE))
+            (PRIN1 ")")                                      (* ; "Return NIL to say we handled it")
+            NIL])
+
+(DO.PRETTYPRINT
+  [LAMBDA (EXPR)                                             (* ; "Edited 26-Apr-88 11:30 by bvm")
+
+    (* ;; "Prettyprinter advice for DO, DO*, DOLIST, DOTIMES.  Default way's main problem is that the body is indented at the same level as the clauses.  Syntax: (do clauses exit . body)")
+
+    (if [NOT (LISTP (CDR (LISTP (CDR EXPR]
+        then                                             (* ; 
+                                          "2 or fewer elements--default prettyprinter will do fine")
+              EXPR
+      else (PRIN1 "(")
+            [LET* ((START (DSPXPOSITION))
+                   (HEAD (CAR EXPR))
+                   (LEFT (PROGN (PRIN2 HEAD)                 (* ; "Print the car of form")
+                                (SPACES 1)
+                                (DSPXPOSITION)))
+                   (TAIL (CDR EXPR)))
+                  (DECLARE (SPECVARS LEFT TAIL))
+                  (SUPERPRINT (CAR TAIL)
+                         TAIL NIL *STANDARD-OUTPUT*)       (* ; 
+                                           "Print the first element (var clauses) at this position")
+                  (pop TAIL)
+                  (SELECTQ HEAD
+                      ((LISP:DO LISP:DO*)                    (* ; "There's another clause here")
+                           (SUBPRINT/ENDLINE LEFT *STANDARD-OUTPUT*)
+                                                             (* ; 
+                                           "Indent next at same level, printing any comments first")
+                           (if (LISTP TAIL)
+                               then                      (* ; 
+                     "Unless degenerate case, print the second element (end test) at this position")
+                                     (if (NULL (CAR TAIL))
+                                         then            (* ; "Empty exit condition")
+                                               (PRIN1 "()")
+                                       else (SUPERPRINT (CAR TAIL)
+                                                       TAIL NIL *STANDARD-OUTPUT*))
+                                     (pop TAIL)))
+                      NIL)
+
+                  (* ;; "Finally, print the body, with left margin halfway between left edge of form and the initial clauses")
+
+                  (SEQUENTIAL.PRETTYPRINT TAIL (+ START (MIN (TIMES 3 SPACEWIDTH)
+                                                                 (IQUOTIENT (- LEFT START)
+                                                                        2]
+            (PRIN1 ")")                                      (* ; "Return NIL to say we handled it")
+            NIL])
+
+(INDENTATION.FROM.HERE
+  [LAMBDA NIL                                              (* ; "Edited 28-Mar-88 18:17 by bvm")
+
+    (* ;; "Returns X-pos about 3 chars over, for use in indenting code")
+
+    (+ (DSPXPOSITION)
+       (TIMES 3 (CHARWIDTH (CHARCODE X)
+                       *STANDARD-OUTPUT*])
+
+(SEQUENTIAL.PRETTYPRINT
+  [LAMBDA (TAIL LEFT)                                        (* ; "Edited 26-Apr-88 11:15 by bvm")
+    (DECLARE (SPECVARS TAIL LEFT))
+
+    (* ;; "Print each element of tail indented at position LEFT.")
+
+    (PROG (TEM)
+          (if (<= (DSPXPOSITION)
+                      LEFT)
+              then                                       (* ; 
+                            "Don't start with newline if we aren't to the right of the left margin")
+                    (GO MIDDLE))
+      TOP (if (OR (NULL TAIL)
+                      (PROGN (SUBPRINT/ENDLINE LEFT *STANDARD-OUTPUT*)
+                             (NULL TAIL)))
+              then                                       (* ; "Done")
+                    (RETURN))
+      MIDDLE
+          (if (NLISTP TAIL)
+              then                                       (* ; "Degenerate tail")
+                    (RETURN (PRINTDEF TAIL T T T))
+            elseif (AND (LISTP (CDR TAIL))
+                            (FMEMB (CAR TAIL)
+                                   *BACKQUOTE-WRAPPERS*)
+                            (NULL (CDDR TAIL))
+                            (SETQ TEM (GET (CAR TAIL)
+                                           'PRETTYWRAPPER))
+                            (SETQ TEM (LISP:FUNCALL TEM TAIL *STANDARD-OUTPUT*)))
+              then                                       (* ; "Dotted backquote tail (sigh)")
+                    (RETURN (SUBPRINT/WRAPPERTAIL TAIL TEM)))
+          (SUPERPRINT (CAR TAIL)
+                 TAIL NIL *STANDARD-OUTPUT*)
+          (pop TAIL)
+          (GO TOP])
+)
+
+(ADDTOVAR PRETTYPRINTMACROS
+          (UNINTERRUPTABLY . CODEWRAPPER.PRETTYPRINT)
+          (LISP:UNWIND-PROTECT . CODEWRAPPER.PRETTYPRINT)
+          (RESETLST . CODEWRAPPER.PRETTYPRINT)
+          (LISP:BLOCK . PROG1.PRETTYPRINT)
+          (LISP:IF . PROG1.PRETTYPRINT)
+          (PROG1 . PROG1.PRETTYPRINT)
+          (LISP:WHEN . PROG1.PRETTYPRINT)
+          (LISP:UNLESS . PROG1.PRETTYPRINT)
+          (WITH-READER-ENVIRONMENT . PROG1.PRETTYPRINT)
+          (LISP:CATCH . PROG1.PRETTYPRINT)
+          (CASE . CASE.PRETTYPRINT)
+          (LISP:ECASE . CASE.PRETTYPRINT)
+          (LISP:ETYPECASE . CASE.PRETTYPRINT)
+          (LISP:TYPECASE . CASE.PRETTYPRINT)
+          (LISP:PROGV . PROGV.PRETTYPRINT)
+          (WITH.MONITOR . PROG1.PRETTYPRINT)
+          (LISP:DO* . DO.PRETTYPRINT)
+          (LISP:DO . DO.PRETTYPRINT)
+          (LISP:DOLIST . DO.PRETTYPRINT)
+          (LISP:DOTIMES . DO.PRETTYPRINT))
+
+(ADDTOVAR PRETTYEQUIVLST (PROG* . PROG)
+                             (LISP:COMPILER-LET . LET))
+(DECLARE%: EVAL@COMPILE DOCOPY 
+
+(LISP:PROCLAIM '(LISP:SPECIAL DEFAULTFONT BOLDFONT USERFONT SYSTEMFONT CLISPFONT BIGFONT 
+                       PRETTYPRINTMACROS))
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS CLISPARRAY CHANGESARRAY AVERAGEFNLENGTH %#CAREFULCOLUMNS AVERAGEVARLENGTH FONTWORDS 
+       FONTFNS CLISPCHARS FUNNYATOMLST PRETTYEQUIVLST COMMENTFLG *BACKQUOTE-WRAPPERS*)
+)
+
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
+
+(BLOCK%: DSPRETTY PRINTDEF SUPERPRINT SUPERPRINT0 SUBPRINT SUBPRINT1 PRINTPROG PRINTPROGVARS PRINTSQ
+       BACKARROWP RPARS FITP DSFIT1 DSFIT2 (ENTRIES PRINTDEF SUPERPRINT FITP)
+       (SPECVARS TAIL LEFT FNSLST FIRSTPOS COMMENTCOL FORMFLG FILEFLG)
+       (LOCALFREEVARS TAILFLG CHANGEFLG))
+)
+
+(DECLARE%: DONTEVAL@LOAD 
+
+(FILESLOAD (LOADCOMP)
+       DSPRINTDEF)
+)
+)
+(PUTPROPS NEWPRINTDEF COPYRIGHT ("Venue" 1982 1983 1984 1985 1986 1987 1988 1990 1991 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (3455 38543 (PRINTDEF 3465 . 6013) (SUPERPRINT 6015 . 7559) (SUPERPRINT0 7561 . 10064)
+ (SUBPRINT 10066 . 24119) (SUBPRINT1 24121 . 24928) (PRINTPROG 24930 . 27015) (PRINTPROGVARS 27017 . 
+27264) (PRINTSQ 27266 . 29869) (BACKARROWP 29871 . 30063) (SUBPRINT/ENDLINE 30065 . 30616) (RPARS 
+30618 . 31158) (FITP 31160 . 32703) (DSFIT1 32705 . 34545) (DSFIT2 34547 . 36909) (SUPERPRINT/SPACE 
+36911 . 37546) (SUBPRINT/WRAPPERTAIL 37548 . 38541)) (38582 52544 (SUPERPRINT/COMMENT 38592 . 46783) (
+SEMI-COLON-COMMENT-P 46785 . 47837) (SUPERPRINT/COMMENT1 47839 . 49711) (SUPERPRINT/COMMENT2 49713 . 
+52542)) (52758 66874 (CODEWRAPPER.PRETTYPRINT 52768 . 53537) (PROG1.PRETTYPRINT 53539 . 55571) (
+CASE.PRETTYPRINT 55573 . 60167) (PROGV.PRETTYPRINT 60169 . 62108) (DO.PRETTYPRINT 62110 . 64884) (
+INDENTATION.FROM.HERE 64886 . 65199) (SEQUENTIAL.PRETTYPRINT 65201 . 66872)))))
+STOP
diff --git a/CLTL2/NEWPRINTDEF.LCOM b/CLTL2/NEWPRINTDEF.LCOM
new file mode 100644
index 00000000..2ae412d3
Binary files /dev/null and b/CLTL2/NEWPRINTDEF.LCOM differ
diff --git a/CLTL2/PACKAGE-CONVERSION-TABLE b/CLTL2/PACKAGE-CONVERSION-TABLE
new file mode 100644
index 00000000..6e54707c
--- /dev/null
+++ b/CLTL2/PACKAGE-CONVERSION-TABLE
@@ -0,0 +1,146 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+(FILECREATED "30-Mar-92 14:30:31" 
+|{DSK}<usr>local>lde>lispcore>sources>PACKAGE-CONVERSION-TABLE.;12| 9666   
+
+      |changes| |to:|  (VARIABLES LITATOM-PACKAGE-CONVERSION-TABLE)
+
+      |previous| |date:| "27-Mar-92 13:20:41" 
+|{DSK}<usr>local>lde>lispcore>sources>PACKAGE-CONVERSION-TABLE.;11|)
+
+
+; Copyright (c) 1986, 1988, 1990, 1991, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT PACKAGE-CONVERSION-TABLECOMS)
+
+(RPAQQ PACKAGE-CONVERSION-TABLECOMS (
+
+(* |;;;| "Set up the LITATOM-PACKAGE-CONVERSION-TABLE for use by the INIT.")
+
+                                         (VARIABLES LITATOM-PACKAGE-CONVERSION-TABLE)
+                                         
+                                         (* |;;| "Arrange to use the correct compiler.")
+
+                                         (PROP FILETYPE PACKAGE-CONVERSION-TABLE)))
+
+
+
+(* |;;;| "Set up the LITATOM-PACKAGE-CONVERSION-TABLE for use by the INIT.")
+
+
+(LISP:DEFVAR LITATOM-PACKAGE-CONVERSION-TABLE
+
+   (* |;;| "NOTE!  This list is defined BOTH in PACKAGE-STARTUP and the file PACKAGE-CONVERSION-TABLE.  PACKAGE-CONVERSION-TABLE is loaded early in the init  to help TYPE-VARIABLE-FROM-TYPE-NAME do the right thing when packages are off, so that copy of the table is the dominant one.  If you're thinking of changing this table, STOP right now and load PACKAGE-CONVERSION-TABLE so the change will show up in the init - JRB")
+
+   (* |;;| "And to answer the obvious question: No, we can't put a FILES reference in either of these files.  It would have to be a \"load the other one only when the source for this one is being loaded\" which doesn't exist.")
+
+   '(("CL::" NIL "COMMON-LISP" :INTERNAL)
+
+     (* |;;| "Minor incantation below which facilitates the sharing of symbols bewtween the LISP and COMMON-LISP packages.")
+
+     (* |;;| "Note the doubled \"LISP:\"  and \"CL:\" clauses.  NAMESTRING-CONVERSION-CLAUSE matches the first string against the front of the atom's pname, then searches the list of strings for exceptions.  The first \"CL:\" clause causes any atom that isn't in CL only to be homed in CL and shared in LISP; the second clause catches the exceptions that fall through and homes them in LISP only.  Ditto the two \"LISP\" clauses.  Ditto^2 the two XCL clauses.  Many of the XCL entries will be unnecessary as files get remade with the new package environment")
+
+     (* |;;| "The CL: exceptions should be the same as the NEWCLSYMS list (except for the CL: prefixes); the LISP: exceptions should cover the OLDCLSYMS and SPLITCLSYMS lists similarly.")
+
+     ("CL:" ("CL:REAL" "CL:BASE-CHARACTER" "CL:EXTENDED-CHARACTER" "CL:READTABLE-CASE" 
+                   "CL:SIMPLE-STRING" "CL:BASE-STRING" "CL:SIMPLE-BASE-STRING" "CL:BROADCAST-STREAM"
+                   "CL:CONCATENATED-STREAM" "CL:ECHO-STREAM" "CL:SYNONYM-STREAM" "CL:STRING-STREAM" 
+                   "CL:FILE-STREAM" "CL:TWO-WAY-STREAM" "CL:UPGRADED-ARRAY-ELEMENT-TYPE" 
+                   "CL:UPGRADED-COMPLEX-PART-TYPE" "CL:LOAD-TIME-EVAL" "CL:REALP" "CL:FDEFINITION" 
+                   "CL:NTH-VALUE" "CL:DESTRUCTURING-BIND" "CL:DEFINE-COMPILER-MACRO" 
+                   "CL:COMPILER-MACRO-FUNCTION" "CL:COMPILER-MACROEXPAND" "CL:COMPILER-MACROEXPAND-1"
+                   "CL:VARIABLE-INFORMATION" "CL:FUNCTION-INFORMATION" "CL:DECLARATION-INFORMATION" 
+                   "CL:AUGMENT-ENVIRONMENT" "CL:DEFINE-DECLARATION" "CL:PARSE-MACRO" "CL:ENCLOSE" 
+                   "CL:DECLAIM" "CL:DYNAMIC-EXTENT" "CL:*GENSYM-COUNTER*" "CL:WITH-PACKAGE-ITERATOR"
+                   "CL:LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" 
+                   "CL:LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" 
+                   "CL:LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" 
+                   "CL:LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" 
+                   "CL:LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" 
+                   "CL:LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" 
+                   "CL:LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" 
+                   "CL:LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" "CL:COMPLEMENT" "CL:MAP-INTO" 
+                   "CL:WITH-HASH-TABLE-ITERATOR" "CL:HASH-TABLE-REHASH-SIZE" 
+                   "CL:HASH-TABLE-REHASH-THRESHOLD" "CL:HASH-TABLE-SIZE" "CL:HASH-TABLE-TEST" 
+                   "CL:ROW-MAJOR-AREF" "CL:OPEN-STREAM-P" "CL:BROADCAST-STREAM-STREAMS" 
+                   "CL:CONCATENATED-STREAM-STREAMS" "CL:ECHO-STREAM-INPUT-STREAM" 
+                   "CL:ECHO-STREAM-OUTPUT-STREAM" "CL:SYNONYM-STREAM-SYMBOL" 
+                   "CL:TWO-WAY-STREAM-INPUT-STREAM" "CL:TWO-WAY-STREAM-OUTPUT-STREAM" 
+                   "CL:INTERACTIVE-STREAM-P" "CL:STREAM-EXTERNAL-FORMAT" "CL:*READ-EVAL*" 
+                   "CL:READTABLE-CASE" "CL:*PRINT-READABLY*" "CL:WITH-STANDARD-IO-SYNTAX" 
+                   "CL:PRINT-UNREADABLE-OBJECT" "CL:WILD-PATHNAME-P" "CL:PATHNAME-MATCH-P" 
+                   "CL:TRANSLATE-PATHNAME" "CL:LOGICAL-PATHNAME" "CL:TRANSLATE-LOGICAL-PATHNAME" 
+                   "CL:LOGICAL-PATHNAME-TRANSLATIONS" "CL:LOAD-LOGICAL-PATHNAME-TRANSLATIONS" 
+                   "CL:COMPILE-FILE-PATHNAME" "CL:FILE-STRING-LENGTH" "CL:*LOAD-PRINT*" 
+                   "CL:*LOAD-PATHNAME*" "CL:*LOAD-TRUENAME*" "CL:MAKE-LOAD-FORM" 
+                   "CL:MAKE-LOAD-FORM-SAVING-SLOTS" "CL:*COMPILE-VERBOSE" "CL:*COMPILE-PRINT*" 
+                   "CL:*COMPILE-FILE-PATHNAME*" "CL:*COMPILE-FILE-TRUENAME*" "CL:LOAD-TIME-VALUE" 
+                   "CL:FUNCTION-LAMBDA-EXPRESSION" "CL:WITH-COMPILATION-UNIT" "CL:IN-PACKAGE" 
+                   "CL:LOCALLY")
+            ("COMMON-LISP" "LISP")
+            :EXTERNAL)
+     ("CL:" NIL "COMMON-LISP" :EXTERNAL)
+     ("LISP::" NIL "LISP" :INTERNAL)
+     ("LISP:" ("LISP:COMMON" "LISP:COMMONP" "LISP:STRING-CHAR" "LISP:STRING-CHAR-P" "LISP:INT-CHAR" 
+                     "LISP:COMPILER-LET" "LISP:CHAR-BIT" "LISP:SET-CHAR-BIT" "LISP:*MODULES*" 
+                     "LISP:PROVIDE" "LISP:REQUIRE" "LISP:CHAR-FONT-LIMIT" "LISP:CHAR-BITS-LIMIT" 
+                     "LISP:CHAR-BITS" "LISP:CHAR-FONT" "LISP:MAKE-CHAR" "LISP:CHAR-CONTROL-BIT" 
+                     "LISP:CHAR-META-BIT" "LISP:CHAR-SUPER-BIT" "LISP:CHAR-HYPER-BIT" 
+                     "LISP:*BREAK-ON-WARNINGS*" "LISP:LOCALLY" "LISP:IN-PACKAGE")
+            ("COMMON-LISP" "LISP")
+            :EXTERNAL)
+     ("LISP:" NIL "LISP" :EXTERNAL)
+     (":" NIL "KEYWORD" :EXTERNAL)
+     ("CONDITIONS::" NIL "CONDITIONS" :INTERNAL)
+     ("CONDITIONS:" ("CONDITIONS:*BREAK-ON-SIGNALS*" "CONDITIONS:COMPUTE-RESTARTS" 
+                           "CONDITIONS:CONTINUE" "CONDITIONS:DIVISION-BY-ZERO" 
+                           "CONDITIONS:FILE-ERROR" "CONDITIONS:FILE-ERROR-PATHNAME" 
+                           "CONDITIONS:FIND-RESTART" "CONDITIONS:FLOATING-POINT-OVERFLOW" 
+                           "CONDITIONS:FLOATING-POINT-UNDERFLOW" "CONDITIONS:INVOKE-DEBUGGER" 
+                           "CONDITIONS:INVOKE-RESTART" "CONDITIONS:INVOKE-RESTART-INTERACTIVELY" 
+                           "CONDITIONS:MUFFLE-WARNING" "CONDITIONS:PROGRAM-ERROR" 
+                           "CONDITIONS:RESTART" "CONDITIONS:RESTART-BIND" "CONDITIONS:RESTART-CASE" 
+                           "CONDITIONS:TYPE-ERROR-DATUM" "CONDITIONS:UNBOUND-SLOT" 
+                           "CONDITIONS:WITH-CONDITION-RESTARTS" "CONDITIONS:WITH-SIMPLE-RESTART")
+            "CONDITIONS" :EXTERNAL)
+     ("CONDITIONS:" NIL ("COMMON-LISP" "CONDITIONS")
+            :EXTERNAL)
+     ("XCL::" NIL "XCL" :INTERNAL)
+
+     (* |;;| "Similar trick here as for COMMON-LISP vs. LISP above")
+
+     ("XCL:" ("XCL:ABORT" "XCL:ARITHMETIC-ERROR" "XCL:BROADCAST-STREAM-STREAMS" "XCL:CELL-ERROR" 
+                    "XCL:CELL-ERROR-NAME" "XCL:CONCATENATED-STREAM-STREAMS" "XCL:CONDITION" 
+                    "XCL:CONTROL-ERROR" "XCL:DEFINE-CONDITION" "XCL:DEFPACKAGE" "XCL:DELETE-PACKAGE"
+                    "XCL:DESTRUCTURING-BIND" "XCL:DIVISION-BY-ZERO" "XCL:ECHO-STREAM-INPUT-STREAM" 
+                    "XCL:ECHO-STREAM-OUTPUT-STREAM" "XCL:END-OF-FILE" "XCL:FILE-ERROR" 
+                    "XCL:FLOATING-POINT-OVERFLOW" "XCL:FLOATING-POINT-UNDERFLOW" "XCL:HANDLER-BIND" 
+                    "XCL:IGNORE-ERRORS" "XCL:MAKE-CONDITION" "XCL:MAKE-VECTOR" "XCL:OPEN-STREAM-P" 
+                    "XCL:PACKAGE-ERROR" "XCL:PROGRAM-ERROR" "XCL:ROW-MAJOR-AREF" 
+                    "XCL:SERIOUS-CONDITION" "XCL:SIGNAL" "XCL:SIMPLE-CONDITION" 
+                    "XCL:SIMPLE-CONDITION-FORMAT-ARGUMENTS" "XCL:SIMPLE-CONDITION-FORMAT-STRING" 
+                    "XCL:SIMPLE-ERROR" "XCL:SIMPLE-STRING" "XCL:SIMPLE-TYPE-ERROR" 
+                    "XCL:SIMPLE-WARNING" "XCL:STORAGE-CONDITION" "XCL:STORE-VALUE" "XCL:STREAM-ERROR"
+                    "XCL:STREAM-ERROR-STREAM" "XCL:STRING-STREAM-P" "XCL:SYNONYM-STREAM-SYMBOL" 
+                    "XCL:TWO-WAY-STREAM-INPUT-STREAM" "XCL:TWO-WAY-STREAM-OUTPUT-STREAM" 
+                    "XCL:TYPE-ERROR" "XCL:UNBOUND-VARIABLE" "XCL:UNDEFINED-FUNCTION" "XCL:USE-VALUE"
+                    "XCL:WARNING")
+            "XCL" :EXTERNAL)
+     ("XCL:" NIL ("COMMON-LISP" "XCL")
+            :EXTERNAL)
+     ("SI::" NIL "SI" :INTERNAL)
+     ("SI:" NIL "SI" :EXTERNAL)
+     ("COMPILER::" NIL "COMPILER" :INTERNAL)
+     ("COMPILER:" NIL "COMPILER" :EXTERNAL)
+     ("FASL::" NIL "FASL" :INTERNAL)
+     ("FASL:" NIL "FASL" :EXTERNAL)))
+
+
+
+(* |;;| "Arrange to use the correct compiler.")
+
+
+(PUTPROPS PACKAGE-CONVERSION-TABLE FILETYPE LISP:COMPILE-FILE)
+(PUTPROPS PACKAGE-CONVERSION-TABLE COPYRIGHT ("Venue & Xerox Corporation" 1986 1988 1990 1991 1992))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/CLTL2/PACKAGE-CONVERSION-TABLE.LCOM b/CLTL2/PACKAGE-CONVERSION-TABLE.LCOM
new file mode 100644
index 00000000..049caacf
--- /dev/null
+++ b/CLTL2/PACKAGE-CONVERSION-TABLE.LCOM
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED " 9-Nov-93 01:36:05" ("compiled on " 
|{DSK}<king>export>lispcore>sources>CLTL2>PACKAGE-CONVERSION-TABLE.;1|) "19-Feb-93 17:03:08" 
"COMPILE-FILEd" |in| "Medley 19-Feb-93 ..." |dated| "19-Feb-93 18:20:42")
(FILECREATED "30-Mar-92 14:30:31" |{DSK}<usr>local>lde>lispcore>sources>PACKAGE-CONVERSION-TABLE.;12| 
9666 |changes| |to:| (VARIABLES LITATOM-PACKAGE-CONVERSION-TABLE) |previous| |date:| 
"27-Mar-92 13:20:41" |{DSK}<usr>local>lde>lispcore>sources>PACKAGE-CONVERSION-TABLE.;11|)
(RPAQQ PACKAGE-CONVERSION-TABLECOMS ((* |;;;| 
"Set up the LITATOM-PACKAGE-CONVERSION-TABLE for use by the INIT.") (VARIABLES 
LITATOM-PACKAGE-CONVERSION-TABLE) (* |;;| "Arrange to use the correct compiler.") (PROP FILETYPE 
PACKAGE-CONVERSION-TABLE)))
(CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE)))
(OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE
 (("CL::" NIL "COMMON-LISP" :INTERNAL) ("CL:" ("CL:REAL" "CL:BASE-CHARACTER" "CL:EXTENDED-CHARACTER" 
"CL:READTABLE-CASE" "CL:SIMPLE-STRING" "CL:BASE-STRING" "CL:SIMPLE-BASE-STRING" "CL:BROADCAST-STREAM" 
"CL:CONCATENATED-STREAM" "CL:ECHO-STREAM" "CL:SYNONYM-STREAM" "CL:STRING-STREAM" "CL:FILE-STREAM" 
"CL:TWO-WAY-STREAM" "CL:UPGRADED-ARRAY-ELEMENT-TYPE" "CL:UPGRADED-COMPLEX-PART-TYPE" 
"CL:LOAD-TIME-EVAL" "CL:REALP" "CL:FDEFINITION" "CL:NTH-VALUE" "CL:DESTRUCTURING-BIND" 
"CL:DEFINE-COMPILER-MACRO" "CL:COMPILER-MACRO-FUNCTION" "CL:COMPILER-MACROEXPAND" 
"CL:COMPILER-MACROEXPAND-1" "CL:VARIABLE-INFORMATION" "CL:FUNCTION-INFORMATION" 
"CL:DECLARATION-INFORMATION" "CL:AUGMENT-ENVIRONMENT" "CL:DEFINE-DECLARATION" "CL:PARSE-MACRO" 
"CL:ENCLOSE" "CL:DECLAIM" "CL:DYNAMIC-EXTENT" "CL:*GENSYM-COUNTER*" "CL:WITH-PACKAGE-ITERATOR" 
"CL:LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" "CL:LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" 
"CL:LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" "CL:LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" 
"CL:LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" "CL:LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" 
"CL:LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" "CL:LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" "CL:COMPLEMENT" 
"CL:MAP-INTO" "CL:WITH-HASH-TABLE-ITERATOR" "CL:HASH-TABLE-REHASH-SIZE" 
"CL:HASH-TABLE-REHASH-THRESHOLD" "CL:HASH-TABLE-SIZE" "CL:HASH-TABLE-TEST" "CL:ROW-MAJOR-AREF" 
"CL:OPEN-STREAM-P" "CL:BROADCAST-STREAM-STREAMS" "CL:CONCATENATED-STREAM-STREAMS" 
"CL:ECHO-STREAM-INPUT-STREAM" "CL:ECHO-STREAM-OUTPUT-STREAM" "CL:SYNONYM-STREAM-SYMBOL" 
"CL:TWO-WAY-STREAM-INPUT-STREAM" "CL:TWO-WAY-STREAM-OUTPUT-STREAM" "CL:INTERACTIVE-STREAM-P" 
"CL:STREAM-EXTERNAL-FORMAT" "CL:*READ-EVAL*" "CL:READTABLE-CASE" "CL:*PRINT-READABLY*" 
"CL:WITH-STANDARD-IO-SYNTAX" "CL:PRINT-UNREADABLE-OBJECT" "CL:WILD-PATHNAME-P" "CL:PATHNAME-MATCH-P" 
"CL:TRANSLATE-PATHNAME" "CL:LOGICAL-PATHNAME" "CL:TRANSLATE-LOGICAL-PATHNAME" 
"CL:LOGICAL-PATHNAME-TRANSLATIONS" "CL:LOAD-LOGICAL-PATHNAME-TRANSLATIONS" "CL:COMPILE-FILE-PATHNAME" 
"CL:FILE-STRING-LENGTH" "CL:*LOAD-PRINT*" "CL:*LOAD-PATHNAME*" "CL:*LOAD-TRUENAME*" 
"CL:MAKE-LOAD-FORM" "CL:MAKE-LOAD-FORM-SAVING-SLOTS" "CL:*COMPILE-VERBOSE" "CL:*COMPILE-PRINT*" 
"CL:*COMPILE-FILE-PATHNAME*" "CL:*COMPILE-FILE-TRUENAME*" "CL:LOAD-TIME-VALUE" 
"CL:FUNCTION-LAMBDA-EXPRESSION" "CL:WITH-COMPILATION-UNIT" "CL:IN-PACKAGE" "CL:LOCALLY") (
"COMMON-LISP" "LISP") :EXTERNAL) ("CL:" NIL "COMMON-LISP" :EXTERNAL) ("LISP::" NIL "LISP" :INTERNAL) (
"LISP:" ("LISP:COMMON" "LISP:COMMONP" "LISP:STRING-CHAR" "LISP:STRING-CHAR-P" "LISP:INT-CHAR" 
"LISP:COMPILER-LET" "LISP:CHAR-BIT" "LISP:SET-CHAR-BIT" "LISP:*MODULES*" "LISP:PROVIDE" "LISP:REQUIRE"
 "LISP:CHAR-FONT-LIMIT" "LISP:CHAR-BITS-LIMIT" "LISP:CHAR-BITS" "LISP:CHAR-FONT" "LISP:MAKE-CHAR" 
"LISP:CHAR-CONTROL-BIT" "LISP:CHAR-META-BIT" "LISP:CHAR-SUPER-BIT" "LISP:CHAR-HYPER-BIT" 
"LISP:*BREAK-ON-WARNINGS*" "LISP:LOCALLY" "LISP:IN-PACKAGE") ("COMMON-LISP" "LISP") :EXTERNAL) (
"LISP:" NIL "LISP" :EXTERNAL) (":" NIL "KEYWORD" :EXTERNAL) ("CONDITIONS::" NIL "CONDITIONS" :INTERNAL
) ("CONDITIONS:" ("CONDITIONS:*BREAK-ON-SIGNALS*" "CONDITIONS:COMPUTE-RESTARTS" "CONDITIONS:CONTINUE" 
"CONDITIONS:DIVISION-BY-ZERO" "CONDITIONS:FILE-ERROR" "CONDITIONS:FILE-ERROR-PATHNAME" 
"CONDITIONS:FIND-RESTART" "CONDITIONS:FLOATING-POINT-OVERFLOW" "CONDITIONS:FLOATING-POINT-UNDERFLOW" 
"CONDITIONS:INVOKE-DEBUGGER" "CONDITIONS:INVOKE-RESTART" "CONDITIONS:INVOKE-RESTART-INTERACTIVELY" 
"CONDITIONS:MUFFLE-WARNING" "CONDITIONS:PROGRAM-ERROR" "CONDITIONS:RESTART" "CONDITIONS:RESTART-BIND" 
"CONDITIONS:RESTART-CASE" "CONDITIONS:TYPE-ERROR-DATUM" "CONDITIONS:UNBOUND-SLOT" 
"CONDITIONS:WITH-CONDITION-RESTARTS" "CONDITIONS:WITH-SIMPLE-RESTART") "CONDITIONS" :EXTERNAL) (
"CONDITIONS:" NIL ("COMMON-LISP" "CONDITIONS") :EXTERNAL) ("XCL::" NIL "XCL" :INTERNAL) ("XCL:" (
"XCL:ABORT" "XCL:ARITHMETIC-ERROR" "XCL:BROADCAST-STREAM-STREAMS" "XCL:CELL-ERROR" 
"XCL:CELL-ERROR-NAME" "XCL:CONCATENATED-STREAM-STREAMS" "XCL:CONDITION" "XCL:CONTROL-ERROR" 
"XCL:DEFINE-CONDITION" "XCL:DEFPACKAGE" "XCL:DELETE-PACKAGE" "XCL:DESTRUCTURING-BIND" 
"XCL:DIVISION-BY-ZERO" "XCL:ECHO-STREAM-INPUT-STREAM" "XCL:ECHO-STREAM-OUTPUT-STREAM" 
"XCL:END-OF-FILE" "XCL:FILE-ERROR" "XCL:FLOATING-POINT-OVERFLOW" "XCL:FLOATING-POINT-UNDERFLOW" 
"XCL:HANDLER-BIND" "XCL:IGNORE-ERRORS" "XCL:MAKE-CONDITION" "XCL:MAKE-VECTOR" "XCL:OPEN-STREAM-P" 
"XCL:PACKAGE-ERROR" "XCL:PROGRAM-ERROR" "XCL:ROW-MAJOR-AREF" "XCL:SERIOUS-CONDITION" "XCL:SIGNAL" 
"XCL:SIMPLE-CONDITION" "XCL:SIMPLE-CONDITION-FORMAT-ARGUMENTS" "XCL:SIMPLE-CONDITION-FORMAT-STRING" 
"XCL:SIMPLE-ERROR" "XCL:SIMPLE-STRING" "XCL:SIMPLE-TYPE-ERROR" "XCL:SIMPLE-WARNING" 
"XCL:STORAGE-CONDITION" "XCL:STORE-VALUE" "XCL:STREAM-ERROR" "XCL:STREAM-ERROR-STREAM" 
"XCL:STRING-STREAM-P" "XCL:SYNONYM-STREAM-SYMBOL" "XCL:TWO-WAY-STREAM-INPUT-STREAM" 
"XCL:TWO-WAY-STREAM-OUTPUT-STREAM" "XCL:TYPE-ERROR" "XCL:UNBOUND-VARIABLE" "XCL:UNDEFINED-FUNCTION" 
"XCL:USE-VALUE" "XCL:WARNING") "XCL" :EXTERNAL) ("XCL:" NIL ("COMMON-LISP" "XCL") :EXTERNAL) ("SI::" 
NIL "SI" :INTERNAL) ("SI:" NIL "SI" :EXTERNAL) ("COMPILER::" NIL "COMPILER" :INTERNAL) ("COMPILER:" 
NIL "COMPILER" :EXTERNAL) ("FASL::" NIL "FASL" :INTERNAL) ("FASL:" NIL "FASL" :EXTERNAL)))))
(PUTPROPS PACKAGE-CONVERSION-TABLE FILETYPE CL:COMPILE-FILE)
(PUTPROPS PACKAGE-CONVERSION-TABLE COPYRIGHT ("Venue & Xerox Corporation" 1986 1988 1990 1991 1992))
NIL
\ No newline at end of file
diff --git a/CLTL2/PACKAGE-STARTUP b/CLTL2/PACKAGE-STARTUP
new file mode 100644
index 00000000..0222fc91
--- /dev/null
+++ b/CLTL2/PACKAGE-STARTUP
@@ -0,0 +1,164 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
+(FILECREATED " 8-Apr-92 22:12:54" |{DSK}<usr>local>lde>lispcore>sources>PACKAGE-STARTUP.;23| 46549  
+
+      |changes| |to:|  (FUNCTIONS PACKAGE-MAKE)
+
+      |previous| |date:| " 8-Apr-92 16:56:56" 
+|{DSK}<usr>local>lde>lispcore>sources>PACKAGE-STARTUP.;22|)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT PACKAGE-STARTUPCOMS)
+
+(RPAQQ PACKAGE-STARTUPCOMS ((* |;;;| "Initialize the package system (LLPACKAGE must be loaded)") (* |;;| "Simple definitions for the init.  Improved in CMLPACKAGE") (FUNCTIONS RETURN-FIRST-OF-THREE ERROR-MISSING-EXTERNAL-SYMBOL) (P (MOVD? (QUOTE ERROR-MISSING-EXTERNAL-SYMBOL) (QUOTE RESOLVE-MISSING-EXTERNAL-SYMBOL)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-MISSING-PACKAGE)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-USE-PACKAGE-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-MISSING-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-IMPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-UNINTERN-CONFLICT)) (MOVD? (QUOTE RETURN-FIRST-OF-THREE) (QUOTE RESOLVE-READER-CONFLICT)) (* \; "In pre-package init all symbols are prefixed, thus the INTERLISP symbol is always default")) (* |;;| "Reader changes") (FUNCTIONS CHECK-SYMBOL-NAMESTRING \\NEW.READ.SYMBOL \\NEW.MKATOM) (VARIABLES LITATOM-PACKAGE-CONVERSION-ENABLED) (* |;;| "Initialization tables and functions") (VARIABLES CMLSYMBOLS.VARS CMLSYMBOLS.FNNAMES CMLSYMBOLS.DECLARATORS CMLSYMBOLS.TYPENAMES CMLSYMBOLS.MACROS CMLSYMBOLS.SPECIALFORMS CMLSYMBOLS.LAMBDA.LIST.KEYWORDS CMLSYMBOLS.OTHER) (VARIABLES (* \; "Be very careful with this.") CMLSYMBOLS.SHARED) (* |;;| "Initialization for the COMMON-LISP-package") (VARIABLES NEWCLSYMS OLDCLSYMS SPLITCLSYMS STRANGECLSYMS XCLCLSYMS) (FUNCTIONS LITATOM.EXISTS) (VARIABLES LITATOM-PACKAGE-CONVERSION-TABLE) (FUNCTIONS NAMESTRING-CONVERSION-CLAUSE CONVERT-LITATOM CONCOCT-SYMBOL TRANSFER-SYMBOL INTERN-LITATOM \\LITATOM.EATCHARS) (FUNCTIONS PACKAGE-INIT PACKAGE-CLEAR PACKAGE-MAKE PACKAGE-HIERARCHY-INIT PACKAGE-ENABLE PACKAGE-DISABLE) (* |;;| "A function to move the \"CL\" nickname between the LISP and COMMON-LISP packages") (FUNCTIONS FLIP-CL) (* |;;| "A hack for initialization") (FUNCTIONS ID) (PROP (FILETYPE MAKEFILE-ENVIRONMENT) PACKAGE-STARTUP) (* |;;| "Initialize package system, plus functions needed in llpackage at init time") (DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD? (QUOTE EQ) (QUOTE EQL)) (MOVD? (QUOTE LENGTH) (QUOTE CL:LENGTH)) (MOVD? (QUOTE ID) (QUOTE CL:IDENTITY)) (MOVD? (QUOTE ID) (QUOTE REMOVE-COMMENTS)) (PACKAGE-INIT)))))
+
+
+
+(* |;;;| "Initialize the package system (LLPACKAGE must be loaded)")
+
+
+
+
+(* |;;| "Simple definitions for the init.  Improved in CMLPACKAGE")
+
+
+(CL:DEFUN RETURN-FIRST-OF-THREE (ONE TWO THREE) (DECLARE (IGNORE TWO THREE)) ONE)
+
+(CL:DEFUN ERROR-MISSING-EXTERNAL-SYMBOL (NAME PACKAGE) (ERROR (CONCAT "External symbol |" NAME "| not found in package " PACKAGE)))
+
+(MOVD? (QUOTE ERROR-MISSING-EXTERNAL-SYMBOL) (QUOTE RESOLVE-MISSING-EXTERNAL-SYMBOL))
+
+(MOVD? (QUOTE ERROR) (QUOTE RESOLVE-MISSING-PACKAGE))
+
+(MOVD? (QUOTE ERROR) (QUOTE RESOLVE-USE-PACKAGE-CONFLICT))
+
+(MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-CONFLICT))
+
+(MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-MISSING-CONFLICT))
+
+(MOVD? (QUOTE ERROR) (QUOTE RESOLVE-IMPORT-CONFLICT))
+
+(MOVD? (QUOTE ERROR) (QUOTE RESOLVE-UNINTERN-CONFLICT))
+
+(MOVD? (QUOTE RETURN-FIRST-OF-THREE) (QUOTE RESOLVE-READER-CONFLICT))
+
+(* \; "In pre-package init all symbols are prefixed, thus the INTERLISP symbol is always default")
+
+
+
+(* |;;| "Reader changes")
+
+
+(CL:DEFUN CHECK-SYMBOL-NAMESTRING (BASE OFFSET LEN FATP) "Check whether a symbol would rather be in a package." (LET* ((CLAUSE (OR (NAMESTRING-CONVERSION-CLAUSE BASE OFFSET LEN FATP) (CL:RETURN-FROM CHECK-SYMBOL-NAMESTRING NIL))) (PREFIX (CL:FIRST CLAUSE)) (CL:PACKAGE-NAME (CL:THIRD CLAUSE)) (WHERE (CL:FOURTH CLAUSE)) (PREFIX-LENGTH (|ffetch| (STRINGP LENGTH) PREFIX))) (COND (CL:PACKAGE-NAME (INTERN* BASE PREFIX-LENGTH (IDIFFERENCE LEN PREFIX-LENGTH) FATP (\\FATCHARSEENP BASE OFFSET LEN FATP) (CL:FIND-PACKAGE CL:PACKAGE-NAME) (EQ WHERE :EXTERNAL))) (T (UNINTERRUPTABLY (\\CREATE.SYMBOL BASE OFFSET LEN FATP (\\FATCHARSEENP BASE OFFSET LEN FATP)))))))
+
+(CL:DEFUN \\NEW.READ.SYMBOL (BASE OFFSET LEN FATP PACKAGE EXTERNALP NONNUMERICP) "Read a number or symbol from the string defined by BASE OFFSET LEN FATP PACKAGE is NIL if no package was specified, a package object or a string if an unknown package was typed (causes error).  EXTERNALP is true if symbol was typed with one colon, which requires that the symbol exist and be external (unless it was a keyword).  NONNUMERICP is true if we know the symbol is not a number, e.g., some characters in it were escaped." (DECLARE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-ENABLED *READTABLE* FILERDTBL CODERDTBL *PACKAGE* *LISP-PACKAGE* *INTERLISP-PACKAGE*)) (OR (AND (NOT NONNUMERICP) (\\PARSE.NUMBER BASE OFFSET LEN FATP)) (AND (* |;;| "The reader conversion feature is contained in this expression") LITATOM-PACKAGE-CONVERSION-ENABLED (NULL PACKAGE) (OR (EQ *READTABLE* FILERDTBL) (EQ *READTABLE* CODERDTBL)) (OR (CHECK-SYMBOL-NAMESTRING BASE OFFSET LEN FATP) (CL:MULTIPLE-VALUE-BIND (CLSYM CLSYMWHERE) (FIND-SYMBOL* BASE OFFSET LEN FATP *LISP-PACKAGE*) (LET ((ILSYM (FIND-SYMBOL* BASE OFFSET LEN FATP *INTERLISP-PACKAGE*))) (COND ((NULL ILSYM) (* \; "No IL symbol, try CL") CLSYM) ((NULL CLSYM) (* \; "No CL symbol, use IL") ILSYM) ((EQ ILSYM CLSYM) (* \; "SAME") ILSYM) (T (* \; "Both symbols exist, resolve.  During the INIT where packages are turned off this is defined to return its first argument.") (RESOLVE-READER-CONFLICT ILSYM CLSYM CLSYMWHERE))))))) (COND ((STRINGP PACKAGE) (RESOLVE-MISSING-PACKAGE PACKAGE (\\GETBASESTRING BASE OFFSET LEN FATP) EXTERNALP)) ((OR (NOT EXTERNALP) (EQ PACKAGE *KEYWORD-PACKAGE*)) (INTERN* BASE OFFSET LEN FATP (\\FATCHARSEENP BASE OFFSET LEN FATP) (OR PACKAGE *PACKAGE*) NIL)) (T (CL:MULTIPLE-VALUE-BIND (CL:SYMBOL ACCESSIBLE) (FIND-SYMBOL* BASE OFFSET LEN FATP (OR PACKAGE *PACKAGE*)) (COND ((EQ ACCESSIBLE :EXTERNAL) CL:SYMBOL) ((LISP::%PACKAGE-EXTERNAL-ONLY PACKAGE) (* \; "External only packages don't error creating external symbols on read") (INTERN* BASE OFFSET LEN FATP (\\FATCHARSEENP BASE OFFSET LEN FATP) (OR PACKAGE *PACKAGE*) T)) (T (RESOLVE-MISSING-EXTERNAL-SYMBOL (\\GETBASESTRING BASE OFFSET LEN FATP) PACKAGE))))))))
+
+(CL:DEFUN \\NEW.MKATOM (BASE OFFST LEN FATP) "A version of \\MKATOM which makes symbols in the Interlisp package instead of the old litatom table." (PROG ((FATCHARSEENP (\\FATCHARSEENP BASE OFFST LEN FATP)) (FIRSTCHAR (UNLESSRDSYS (\\GETBASECHAR FATP BASE OFFST) (NTHCHARCODE BASE OFFST))) TEMP) (DECLARE (SPECVARS *INTERLISP-PACKAGE*)) (UNLESSRDSYS (COND ((AND (EQ LEN 1) (ILEQ FIRSTCHAR \\MAXTHINCHAR) |\\OneCharAtomBase|) (* \; "The one-character atoms live in well known places, no need to hash") (RETURN (COND ((IGREATERP FIRSTCHAR (CHARCODE "9")) (\\ADDBASE |\\OneCharAtomBase| (IDIFFERENCE FIRSTCHAR 10))) ((IGEQ FIRSTCHAR (CHARCODE "0")) (* \; "These one-character atoms are integers") (IDIFFERENCE FIRSTCHAR (CHARCODE "0"))) (T (\\ADDBASE |\\OneCharAtomBase| FIRSTCHAR))))) ((AND (ILEQ FIRSTCHAR (CHARCODE "9")) (SETQ TEMP (\\PARSE.NUMBER BASE OFFST LEN FATP))) (* |;;| "\\PARSE.NUMBER returns a number or NIL") (RETURN TEMP)))) (RETURN (CL:VALUES (INTERN* BASE OFFST LEN FATP FATCHARSEENP *INTERLISP-PACKAGE* T)))))
+
+(CL:DEFVAR LITATOM-PACKAGE-CONVERSION-ENABLED NIL)
+
+
+
+(* |;;| "Initialization tables and functions")
+
+
+(CL:DEFPARAMETER CMLSYMBOLS.VARS (QUOTE ("*" "**" "***" "*APPLYHOOK*" "*BREAK-ON-WARNINGS*" "*DEBUG-IO*" "*DEFAULT-PATHNAME-DEFAULTS*" "*ERROR-OUTPUT*" "*EVALHOOK*" "*FEATURES*" "*LOAD-VERBOSE*" "*MACROEXPAND-HOOK*" "*MODULES*" "*PACKAGE*" "*PRINT-ARRAY*" "*PRINT-BASE*" "*PRINT-CASE*" "*PRINT-CIRCLE*" "*PRINT-ESCAPE*" "*PRINT-GENSYM*" "*PRINT-LENGTH*" "*PRINT-LEVEL*" "*PRINT-PRETTY*" "*PRINT-RADIX*" "*QUERY-IO*" "*RANDOM-STATE*" "*READ-BASE*" "*READ-DEFAULT-FLOAT-FORMAT*" "*READ-SUPPRESS*" "*READTABLE*" "*STANDARD-INPUT*" "*STANDARD-OUTPUT*" "*TERMINAL-IO*" "*TRACE-OUTPUT*" "+" "++" "+++" "-" "/" "//" "///" "ARRAY-DIMENSION-LIMIT" "ARRAY-RANK-LIMIT" "ARRAY-TOTAL-SIZE-LIMIT" "BOOLE-1" "BOOLE-2" "BOOLE-AND" "BOOLE-ANDC1" "BOOLE-ANDC2" "BOOLE-C1" "BOOLE-C2" "BOOLE-CLR" "BOOLE-EQV" "BOOLE-IOR" "BOOLE-NAND" "BOOLE-NOR" "BOOLE-ORC1" "BOOLE-ORC2" "BOOLE-SET" "BOOLE-XOR" "CALL-ARGUMENTS-LIMIT" "CHAR-BITS-LIMIT" "CHAR-CODE-LIMIT" "CHAR-CONTROL-BIT" "CHAR-FONT-LIMIT" "CHAR-HYPER-BIT" "CHAR-META-BIT" "CHAR-SUPER-BIT" "DOUBLE-FLOAT-EPSILON" "DOUBLE-FLOAT-NEGATIVE-EPSILON" "INTERNAL-TIME-UNITS-PER-SECOND" "LAMBDA-LIST-KEYWORDS" "LAMBDA-PARAMETERS-LIMIT" "LEAST-NEGATIVE-DOUBLE-FLOAT" "LEAST-NEGATIVE-LONG-FLOAT" "LEAST-NEGATIVE-SHORT-FLOAT" "LEAST-NEGATIVE-SINGLE-FLOAT" "LEAST-POSITIVE-DOUBLE-FLOAT" "LEAST-POSITIVE-LONG-FLOAT" "LEAST-POSITIVE-SHORT-FLOAT" "LEAST-POSITIVE-SINGLE-FLOAT" "LONG-FLOAT-EPSILON" "LONG-FLOAT-NEGATIVE-EPSILON" "MOST-NEGATIVE-DOUBLE-FLOAT" "MOST-NEGATIVE-FIXNUM" "MOST-NEGATIVE-LONG-FLOAT" "MOST-NEGATIVE-SHORT-FLOAT" "MOST-NEGATIVE-SINGLE-FLOAT" "MOST-POSITIVE-DOUBLE-FLOAT" "MOST-POSITIVE-DOUBLE-FLOAT" "MOST-POSITIVE-FIXNUM" "MOST-POSITIVE-LONG-FLOAT" "MOST-POSITIVE-SHORT-FLOAT" "MOST-POSITIVE-SINGLE-FLOAT" "MULTIPLE-VALUES-LIMIT" "NIL" "OTHERWISE" "PI" "*PRINT-ESCAPE*" "SHORT-FLOAT-EPSILON" "SHORT-FLOAT-NEGATIVE-EPSILON" "SINGLE-FLOAT-EPSILON" "SINGLE-FLOAT-NEGATIVE-EPSILON" "T")))
+
+(CL:DEFPARAMETER CMLSYMBOLS.FNNAMES (QUOTE ("*" "+" "-" "/" "/=" "1+" "1-" "<" "<=" "=" ">" ">=" "ABS" "ACONS" "ACOS" "ACOSH" "ADJOIN" "ADJUST-ARRAY" "ADJUSTABLE-ARRAY-P" "ALPHA-CHAR-P" "ALPHANUMERICP" "APPEND" "APPLY" "APPLYHOOK" "APROPOS" "APROPOS-LIST" "AREF" "ARRAY-DIMENSION" "ARRAY-DIMENSIONS" "ARRAY-ELEMENT-TYPE" "ARRAY-HAS-FILL-POINTER-P" "ARRAY-IN-BOUNDS-P" "ARRAY-RANK" "ARRAY-ROW-MAJOR-INDEX" "ARRAY-TOTAL-SIZE" "ARRAYP" "ASH" "ASIN" "ASINH" "ASSOC" "ASSOC-IF" "ASSOC-IF-NOT" "ATAN" "ATANH" "ATOM" "BIT" "BIT-AND" "BIT-ANDC1" "BIT-ANDC2" "BIT-EQV" "BIT-IOR" "BIT-NAND" "BIT-NOR" "BIT-NOT" "BIT-ORC1" "BIT-ORC2" "BIT-VECTOR-P" "BIT-XOR" "BOOLE" "BOTH-CASE-P" "BOUNDP" "BREAK" "BUTLAST" "BYTE" "BYTE-POSITION" "BYTE-SIZE" "CAR" "CDR" "CAAR" "CADR" "CDAR" "CDDR" "CAAAR" "CAADR" "CADAR" "CADDR" "CDAAR" "CDADR" "CDDAR" "CDDDR" "CAAAAR" "CAAADR" "CAADAR" "CAADDR" "CADAAR" "CADADR" "CADDAR" "CADDDR" "CDAAAR" "CDAADR" "CDADAR" "CDADDR" "CDDAAR" "CDDADR" "CDDDAR" "CDDDDR" "CEILING" "CERROR" "CHAR" "CHAR-BIT" "CHAR-BITS" "CHAR-CODE" "CHAR-DOWNCASE" "CHAR-EQUAL" "CHAR-FONT" "CHAR-GREATERP" "CHAR-INT" "CHAR-LESSP" "CHAR-NAME" "CHAR-NOT-EQUAL" "CHAR-NOT-GREATERP" "CHAR-NOT-LESSP" "CHAR-UPCASE" "CHAR/=" "CHAR<" "CHAR<=" "CHAR=" "CHAR>" "CHAR>=" "CHARACTER" "CHARACTERP" "CIS" "CLEAR-INPUT" "CLEAR-OUTPUT" "CLOSE" "CLRHASH" "CODE-CHAR" "COERCE" "COMMONP" "COMPILE" "COMPILE-FILE" "COMPILED-FUNCTION-P" "COMPLEX" "COMPLEXP" "CONCATENATE" "CONJUGATE" "CONS" "CONSP" "CONSTANTP" "COPY-ALIST" "COPY-LIST" "COPY-READTABLE" "COPY-SEQ" "COPY-SYMBOL" "COPY-TREE" "COS" "COSH" "COUNT" "COUNT-IF" "COUNT-IF-NOT" "DECODE-FLOAT" "DECODE-UNIVERSAL-TIME" "DELETE" "DELETE-DUPLICATES" "DELETE-FILE" "DELETE-IF" "DELETE-IF-NOT" "DENOMINATOR" "DEPOSIT-FIELD" "DESCRIBE" "DIGIT-CHAR" "DIGIT-CHAR-P" "DIRECTORY" "DIRECTORY-NAMESTRING" "DISASSEMBLE" "DOCUMENTATION" "DPB" "DRIBBLE" "ED" "EIGHTH" "ELT" "ENCODE-UNIVERSAL-TIME" "ENDP" "ENOUGH-NAMESTRING" "EQ" "EQL" "EQUAL" "EQUALP" "ERROR" "EVAL" "EVALHOOK" "EVENP" "EVERY" "EXP" "EXPORT" "EXPT" "FBOUNDP" "FCEILING" "FFLOOR" "FIFTH" "FILE-AUTHOR" "FILE-LENGTH" "FILE-NAMESTRING" "FILE-POSITION" "FILE-WRITE-DATE" "FILL" "FILL-POINTER" "FIND" "FIND-ALL-SYMBOLS" "FIND-IF" "FIND-IF-NOT" "FIND-PACKAGE" "FIND-SYMBOL" "FINISH-OUTPUT" "FIRST" "FLOAT" "FLOAT-DIGITS" "FLOAT-PRECISION" "FLOAT-RADIX" "FLOAT-SIGN" "FLOATP" "FLOOR" "FMAKUNBOUND" "FORCE-OUTPUT" "FORMAT" "FOURTH" "FRESH-LINE" "FROUND" "FTRUNCATE" "FUNCALL" "FUNCTIONP" "GCD" "GENSYM" "GENTEMP" "GET" "GET-DECODED-TIME" "GET-DISPATCH-MACRO-CHARACTER" "GET-INTERNAL-REAL-TIME" "GET-INTERNAL-RUN-TIME" "GET-MACRO-CHARACTER" "GET-OUTPUT-STREAM-STRING" "GET-PROPERTIES" "GET-SETF-METHOD" "GET-SETF-METHOD-MULTIPLE-VALUE" "GET-UNIVERSAL-TIME" "GETF" "GETHASH" "GRAPHIC-CHAR-P" "HASH-TABLE-COUNT" "HASH-TABLE-P" "HOST-NAMESTRING" "IDENTITY" "IMAGPART" "IMPORT" "INPUT-STREAM-P" "INSPECT" "INT-CHAR" "INTEGER-DECODE-FLOAT" "INTEGER-LENGTH" "INTEGERP" "INTERN" "INTERSECTION" "ISQRT" "KEYWORDP" "LAST" "LCM" "LDB" "LDB-TEST" "LDIFF" "LENGTH" "LISP-IMPLEMENTATION-TYPE" "LISP-IMPLEMENTATION-VERSION" "LIST" "LIST*" "LIST-ALL-PACKAGES" "LIST-LENGTH" "LISTEN" "LISTP" "LOAD" "LOG" "LOGAND" "LOGANDC1" "LOGANDC2" "LOGBITP" "LOGCOUNT" "LOGEQV" "LOGIOR" "LOGNAND" "LOGNOR" "LOGNOT" "LOGORC1" "LOGORC2" "LOGTEST" "LOGXOR" "LONG-SITE-NAME" "LOWER-CASE-P" "MACHINE-INSTANCE" "MACHINE-TYPE" "MACHINE-VERSION" "MACRO-FUNCTION" "MACROEXPAND" "MACROEXPAND-1" "MAKE-ARRAY" "MAKE-BROADCAST-STREAM" "MAKE-CHAR" "MAKE-CONCATENATED-STREAM" "MAKE-DISPATCH-MACRO-CHARACTER" "MAKE-ECHO-STREAM" "MAKE-HASH-TABLE" "MAKE-LIST" "MAKE-PACKAGE" "MAKE-PATHNAME" "MAKE-RANDOM-STATE" "MAKE-SEQUENCE" "MAKE-STRING" "MAKE-STRING-INPUT-STREAM" "MAKE-STRING-OUTPUT-STREAM" "MAKE-SYMBOL" "MAKE-SYNONYM-STREAM" "MAKE-TWO-WAY-STREAM" "MAKUNBOUND" "MAP" "MAPC" "MAPCAN" "MAPCAR" "MAPCON" "MAPHASH" "MAPL" "MAPLIST" "MASK-FIELD" "MAX" "MEMBER" "MEMBER-IF" "MEMBER-IF-NOT" "MERGE" "MERGE-PATHNAMES" "MIN" "MINUSP" "MISMATCH" "MOD" "NAME-CHAR" "NAMESTRING" "NBUTLAST" "NCONC" "NINTERSECTION" "NINTH" "NOT" "NOTANY" "NOTEVERY" "NRECONC" "NREVERSE" "NSET-DIFFERENCE" "NSET-EXCLUSIVE-OR" "NSTRING-CAPITALIZE" "NSTRING-DOWNCASE" "NSTRING-UPCASE" "NSUBLIS" "NSUBST" "NSUBST-IF" "NSUBST-IF-NOT" "NSUBSTITUTE" "NSUBSTITUTE-IF" "NSUBSTITUTE-IF-NOT" "NTH" "NTHCDR" "NUMERATOR" "NULL" "NUMBERP" "NUNION" "ODDP" "OPEN" "OUTPUT-STREAM-P" "PACKAGE-NAME" "PACKAGE-NICKNAMES" "PACKAGE-SHADOWING-SYMBOLS" "PACKAGE-USE-LIST" "PACKAGE-USED-BY-LIST" "PACKAGEP" "PAIRLIS" "PARSE-INTEGER" "PARSE-NAMESTRING" "PATHNAME" "PATHNAME-DEVICE" "PATHNAME-DIRECTORY" "PATHNAME-HOST" "PATHNAME-NAME" "PATHNAME-TYPE" "PATHNAME-VERSION" "PATHNAMEP" "PEEK-CHAR" "PHASE" "PLUSP" "POSITION" "POSITION-IF" "POSITION-IF-NOT" "PPRINT" "PRIN1" "PRIN1-TO-STRING" "PRINC" "PRINC-TO-STRING" "PRINT" "PROBE-FILE" "PROCLAIM" "PROVIDE" "RANDOM" "RANDOM-STATE-P" "RASSOC" "RASSOC-IF" "RASSOC-IF-NOT" "RATIONAL" "RATIONALIZE" "RATIONALP" "READ" "READ-BYTE" "READ-CHAR" "READ-CHAR-NO-HANG" "READ-DELIMITED-LIST" "READ-FROM-STRING" "READ-LINE" "READ-PRESERVING-WHITESPACE" "READTABLEP" "REALPART" "REDUCE" "REM" "REMHASH" "REMOVE" "REMOVE-DUPLICATES" "REMOVE-IF" "REMOVE-IF-NOT" "REMPROP" "RENAME-FILE" "RENAME-PACKAGE" "REPLACE" "REQUIRE" "REST" "REVAPPEND" "REVERSE" "ROOM" "ROUND" "RPLACA" "RPLACD" "SBIT" "SCALE-FLOAT" "SCHAR" "SEARCH" "SECOND" "SET" "SET-CHAR-BIT" "SET-DIFFERENCE" "SET-DISPATCH-MACRO-CHARACTER" "SET-EXCLUSIVE-OR" "SET-MACRO-CHARACTER" "SET-SYNTAX-FROM-CHAR" "SEVENTH" "SHADOW" "SHADOWING-IMPORT" "SHORT-SITE-NAME" "SIGNUM" "SIMPLE-BIT-VECTOR-P" "SIMPLE-STRING-P" "SIMPLE-VECTOR-P" "SIN" "SINH" "SIXTH" "SLEEP" "SOFTWARE-TYPE" "SOFTWARE-VERSION" "SOME" "SORT" "SPECIAL-FORM-P" "SQRT" "STABLE-SORT" "STANDARD-CHAR-P" "STREAM-ELEMENT-TYPE" "STREAM-EXTERNAL-FORMAT" "STREAMP" "STRING" "STRING-CAPITALIZE" "STRING-CHAR-P" "STRING-DOWNCASE" "STRING-EQUAL" "STRING-GREATERP" "STRING-LEFT-TRIM" "STRING-LESSP" "STRING-NOT-EQUAL" "STRING-NOT-GREATERP" "STRING-NOT-LESSP" "STRING-RIGHT-TRIM" "STRING-TRIM" "STRING-UPCASE" "STRING/=" "STRING<" "STRING<=" "STRING=" "STRING>" "STRING>=" "STRINGP" "SUBLIS" "SUBSEQ" "SUBSETP" "SUBST" "SUBST-IF" "SUBST-IF-NOT" "SUBSTITUTE" "SUBSTITUTE-IF" "SUBSTITUTE-IF-NOT" "SUBTYPEP" "SVREF" "SXHASH" "SYMBOL-FUNCTION" "SYMBOL-NAME" "SYMBOL-PACKAGE" "SYMBOL-PLIST" "SYMBOL-VALUE" "SYMBOLP" "TAILP" "TAN" "TANH" "TENTH" "TERPRI" "THIRD" "TREE-EQUAL" "TRUENAME" "TRUNCATE" "TYPE-OF" "TYPEP" "UNEXPORT" "UNINTERN" "UNION" "UNREAD-CHAR" "UNUSE-PACKAGE" "UPPER-CASE-P" "USE-PACKAGE" "USER-HOMEDIR-PATHNAME" "VALUES" "VALUES-LIST" "VECTOR" "VECTOR-POP" "VECTOR-PUSH" "VECTOR-PUSH-EXTEND" "VECTORP" "WARN" "WRITE" "WRITE-BYTE" "WRITE-CHAR" "WRITE-LINE" "WRITE-STRING" "WRITE-TO-STRING" "Y-OR-N-P" "YES-OR-NO-P" "ZEROP")) (* |;;| "IN-PACKAGE moved to SPLITCLSYMS"))
+
+(CL:DEFPARAMETER CMLSYMBOLS.DECLARATORS (QUOTE ("COMPILATION-SPEED" "DECLARATION" "FTYPE" "FUNCTION" "IGNORE" "INLINE" "NOTINLINE" "OPTIMIZE" "SAFETY" "SPACE" "SPECIAL" "SPEED" "TYPE")))
+
+(CL:DEFPARAMETER CMLSYMBOLS.TYPENAMES (QUOTE ("ARRAY" "ATOM" "BIGNUM" "BIT" "BIT-VECTOR" "CHARACTER" "COMMON" "COMPILED-FUNCTION" "COMPLEX" "CONS" "DOUBLE-FLOAT" "FIXNUM" "FLOAT" "FUNCTION" "HASH-TABLE" "INTEGER" "KEYWORD" "LIST" "LONG-FLOAT" "NIL" "NUMBER" "PACKAGE" "PATHNAME" "RANDOM-STATE" "RATIO" "RATIONAL" "READTABLE" "SATISFIES" "SEQUENCE" "SHORT-FLOAT" "SIMPLE-ARRAY" "SIMPLE-BIT-VECTOR" "SIMPLE-STRING" "SIMPLE-VECTOR" "SIGNED-BYTE" "SINGLE-FLOAT" "STANDARD-CHAR" "STREAM" "STRING" "STRING-CHAR" "SYMBOL" "T" "UNSIGNED-BYTE" "VECTOR")))
+
+(CL:DEFPARAMETER CMLSYMBOLS.MACROS (QUOTE ("AND" "ASSERT" "CASE" "CCASE" "CHECK-TYPE" "COND" "CTYPECASE" "DECF" "DEFCONSTANT" "DEFINE-MODIFY-MACRO" "DEFINE-SETF-METHOD" "DEFMACRO" "DEFPARAMETER" "DEFSETF" "DEFSTRUCT" "DEFTYPE" "DEFUN" "DEFVAR" "DO" "DO*" "DO-ALL-SYMBOLS" "DO-EXTERNAL-SYMBOLS" "DO-SYMBOLS" "DOLIST" "DOTIMES" "ECASE" "ETYPECASE" "INCF" "LOOP" "MULTIPLE-VALUE-BIND" "MULTIPLE-VALUE-LIST" "MULTIPLE-VALUE-SETQ" "OR" "POP" "PROG" "PROG*" "PROG1" "PROG2" "PSETF" "PSETQ" "PUSH" "PUSHNEW" "REMF" "RETURN" "ROTATEF" "SETF" "SHIFTF" "STEP" "TIME" "TRACE" "TYPECASE" "UNLESS" "UNTRACE" "WHEN" "WITH-INPUT-FROM-STRING" "WITH-OPEN-FILE" "WITH-OPEN-STREAM" "WITH-OUTPUT-TO-STRING")) (* |;;| "LOCALLY moved to SPLITCLSYMS"))
+
+(CL:DEFPARAMETER CMLSYMBOLS.SPECIALFORMS (QUOTE ("BLOCK" "CATCH" "COMPILER-LET" "DECLARE" "EVAL-WHEN" "FLET" "FUNCTION" "GO" "IF" "LABELS" "LAMBDA" "LET" "LET*" "MACROLET" "MULTIPLE-VALUE-CALL" "MULTIPLE-VALUE-PROG1" "PROGN" "PROGV" "QUOTE" "RETURN-FROM" "SETQ" "TAGBODY" "THE" "THROW" "UNWIND-PROTECT")))
+
+(CL:DEFPARAMETER CMLSYMBOLS.LAMBDA.LIST.KEYWORDS (QUOTE ("&ALLOW-OTHER-KEYS" "&AUX" "&BODY" "&ENVIRONMENT" "&KEY" "&OPTIONAL" "&REST" "&WHOLE")))
+
+(CL:DEFPARAMETER CMLSYMBOLS.OTHER (QUOTE ("VARIABLE" "STRUCTURE")) "These were exported in LISP-PACKAGE; don't know why they need to be, but what the heck...")
+
+(CL:DEFPARAMETER CMLSYMBOLS.SHARED (QUOTE ("+" "-" "/" "<" "<=" "=" ">" ">=" "&ALLOW-OTHER-KEYS" "&AUX" "&BODY" "&ENVIRONMENT" "&KEY" "&OPTIONAL" "&REST" "&WHOLE" "*APPLYHOOK*" "*BREAK-ON-WARNINGS*" "*DEBUG-IO*" "*DEFAULT-PATHNAME-DEFAULTS*" "*ERROR-OUTPUT*" "*EVALHOOK*" "*FEATURES*" "*LOAD-VERBOSE*" "*MACROEXPAND-HOOK*" "*MODULES*" "*PACKAGE*" "*PRINT-ARRAY*" "*PRINT-BASE*" "*PRINT-CASE*" "*PRINT-CIRCLE*" "*PRINT-ESCAPE*" "*PRINT-GENSYM*" "*PRINT-LENGTH*" "*PRINT-LEVEL*" "*PRINT-PRETTY*" "*PRINT-RADIX*" "*QUERY-IO*" "*RANDOM-STATE*" "*READ-BASE*" "*READ-DEFAULT-FLOAT-FORMAT*" "*READ-SUPPRESS*" "*READTABLE*" "*STANDARD-INPUT*" "*STANDARD-OUTPUT*" "*TERMINAL-IO*" "*TRACE-OUTPUT*" "ABS" "AND" "BIGNUM" "BIT" "BOUNDP" "BYTE" "BYTE-SIZE" "CAAAAR" "CAAADR" "CAAAR" "CAADAR" "CAADDR" "CAADR" "CAAR" "CADAAR" "CADADR" "CADAR" "CADDAR" "CADDDR" "CADDR" "CADR" "CAR" "CASE" "CDAAAR" "CDAADR" "CDAAR" "CDADAR" "CDADDR" "CDADR" "CDAR" "CDDAAR" "CDDADR" "CDDAR" "CDDDAR" "CDDDDR" "CDDDR" "CDDR" "CDR" "CLRHASH" "COERCE" "COMPLEX" "COND" "CONS" "DECLARE" "DEFMACRO" "DPB" "DRIBBLE" "ED" "EQ" "EQL" "EVENP" "EXPORT" "FLOAT" "GET" "GO" "IGNORE" "IMPORT" "INSPECT" "INTEGER" "LAST" "LDB" "LET" "LET*" "LIST" "LIST*" "LOGAND" "LOGNOT" "LOGXOR" "MAX" "MIN" "MINUSP" "NCONC" "NIL" "NOT" "NULL" "ODDP" "OPEN" "OR" "PACKAGE" "PATHNAME" "PROG" "PROG*" "PROG1" "PROG2" "PROGN" "QUOTE" "RANDOM-STATE" "RATIO" "READTABLEP" "REMHASH" "REMPROP" "RETURN" "ROUND" "RPLACA" "RPLACD" "SATISFIES" "SEQUENCE" "SET" "STRING" "STRING-EQUAL" "STREAM" "STREAMP" "T" "TAILP" "THE" "TIME" "TRACE" "TYPE" "TYPEP" "UNTRACE" "WRITE")) (* |;;;| "Symbols shared by the Interlisp and Lisp packages."))
+
+
+
+(* |;;| "Initialization for the COMMON-LISP-package")
+
+
+(CL:DEFPARAMETER NEWCLSYMS (QUOTE ("*BREAK-ON-SIGNALS*" "*COMPILE-FILE-PATHNAME*" "*COMPILE-FILE-TRUENAME*" "*COMPILE-PRINT*" "*COMPILE-VERBOSE*" "*DEBUGGER-HOOK*" "*LOAD-PATHNAME*" "*LOAD-PRINT*" "*LOAD-TRUENAME*" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" "*PRINT-PPRINT-DISPATCH*" "*PRINT-READABLY*" "*PRINT-RIGHT-MARGIN*" "*READ-EVAL*" "ABORT" "AUGMENT-ENVIRONMENT" "BASE-CHARACTER" "BASE-STRING" "BROADCAST-STREAM" "BROADCAST-STREAM-STREAMS" "CELL-ERROR-NAME" "COMPILE-FILE-PATHNAME" "COMPILER-MACRO-FUNCTION" "COMPILER-MACROEXPAND" "COMPILER-MACROEXPAND-1" "COMPLEMENT" "COMPUTE-RESTARTS" "CONCATENATED-STREAM" "CONCATENATED-STREAM-STREAMS" "CONDITION" "CONTINUE" "COPY-PPRINT-DISPATCH" "DECLAIM" "DECLARATION-INFORMATION" "DEFINE-COMPILER-MACRO" "DEFINE-CONDITION" "DEFINE-DECLARATION" "DESTRUCTURING-BIND" "DIVISION-BY-ZERO" "DYNAMIC-EXTENT" "ECHO-STREAM" "ECHO-STREAM-INPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM" "ENCLOSE" "END-OF-FILE" "EXTENDED-CHARACTER" "FDEFINITION" "FILE-ERROR" "FILE-ERROR-PATHNAME" "FILE-STREAM" "FILE-STRING-LENGTH" "FIND-RESTART" "FLOATING-POINT-INEXACT" "FLOATING-POINT-INVALID-OPERATION" "FLOATING-POINT-OVERFLOW" "FLOATING-POINT-UNDERFLOW" "FORMATTER" "FUNCTION-INFORMATION" "FUNCTION-LAMBDA-EXPRESSION" "HANDLER-CASE" "HANDLER-BIND" "HASH-TABLE-REHASH-SIZE" "HASH-TABLE-REHASH-THRESHOLD" "HASH-TABLE-SIZE" "HASH-TABLE-TEST" "IGNORE-ERRORS" "INTERACTIVE-STREAM-P" "INVOKE-DEBUGGER" "INVOKE-RESTART" "INVOKE-RESTART-INTERACTIVELY" "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" "LOAD-LOGICAL-PATHNAME-TRANSLATIONS" "LOAD-TIME-EVAL" "LOAD-TIME-VALUE" "LOGICAL-PATHNAME" "LOGICAL-PATHNAME-TRANSLATIONS" "MAKE-CONDITION" "MAKE-LOAD-FORM" "MAKE-LOAD-FORM-SAVING-SLOTS" "MAP-INTO" "MUFFLE-WARNING" "NTH-VALUE" "OPEN-STREAM-P" "PACKAGE-ERROR" "PARSE-ERROR" "PARSE-MACRO" "PATHNAME-MATCH-P" "PPRINT-DISPATCH" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-FILL" "PPRINT-INDENT" "PPRINT-LINEAR" "PPRINT-LOGICAL-BLOCK" "PPRINT-NEWLINE" "PPRINT-POP" "PPRINT-TAB" "PPRINT-TABULAR" "PRINT-NOT-READABLE" "PRINT-UNREADABLE-OBJECT" "PROGRAM-ERROR" "READER-ERROR" "READTABLE-CASE" "READTABLE-CASE" "REAL" "REALP" "RESTART" "RESTART-BIND" "RESTART-CASE" "SET-PPRINT-DISPATCH" "SIMPLE-BASE-STRING" "SIMPLE-CONDITION-FORMAT-ARGUMENTS" "SIMPLE-CONDITION-FORMAT-STRING" "STORE-VALUE" "STREAM-ERROR-STREAM" "STREAM-EXTERNAL-FORMAT" "STRING-STREAM" "STYLE-WARNING" "SYNONYM-STREAM" "SYNONYM-STREAM-SYMBOL" "TRANSLATE-LOGICAL-PATHNAME" "TRANSLATE-PATHNAME" "TWO-WAY-STREAM" "TWO-WAY-STREAM-INPUT-STREAM" "TWO-WAY-STREAM-OUTPUT-STREAM" "TYPE-ERROR-DATUM" "UNBOUND-SLOT" "UNBOUND-VARIABLE" "UPGRADED-ARRAY-ELEMENT-TYPE" "UPGRADED-COMPLEX-PART-TYPE" "USE-VALUE" "VARIABLE-INFORMATION" "WILD-PATHNAME-P" "WITH-COMPILATION-UNIT" "WITH-CONDITION-RESTARTS" "WITH-HASH-TABLE-ITERATOR" "WITH-PACKAGE-ITERATOR" "WITH-SIMPLE-RESTART" "WITH-STANDARD-IO-SYNTAX")))
+
+(CL:DEFPARAMETER OLDCLSYMS (QUOTE ("COMMON" "COMMONP" "STRING-CHAR" "STRING-CHAR-P" "INT-CHAR" "COMPILER-LET" "CHAR-BIT" "SET-CHAR-BIT" "*MODULES*" "PROVIDE" "REQUIRE" "CHAR-FONT-LIMIT" "CHAR-BITS-LIMIT" "CHAR-BITS" "CHAR-FONT" "MAKE-CHAR" "CHAR-CONTROL-BIT" "CHAR-META-BIT" "CHAR-SUPER-BIT" "CHAR-HYPER-BIT" "*BREAK-ON-WARNINGS*")) "Symbols in LISP and not in COMMON-LISP")
+
+(CL:DEFPARAMETER SPLITCLSYMS (QUOTE ("LOCALLY" "IN-PACKAGE")))
+
+(CL:DEFPARAMETER STRANGECLSYMS (QUOTE (("LISP" "SIMPLE-STRING" "*GENSYM-COUNTER*") ("XCL" "ROW-MAJOR-AREF"))) "Symbols in CL that are predefined in the loadup in another package")
+
+(CL:DEFPARAMETER XCLCLSYMS (QUOTE ("ABORT" "ARITHMETIC-ERROR" "ARITHMETIC-ERROR-OPERANDS" "ARITHMETIC-ERROR-OPERATION" "BROADCAST-STREAM-STREAMS" "CELL-ERROR" "CELL-ERROR-NAME" "CONCATENATED-STREAM-STREAMS" "CONDITION" "CONTROL-ERROR" "DEFINE-CONDITION" "DEFPACKAGE" "DESTRUCTURING-BIND" "DELETE-PACKAGE" "ECHO-STREAM-INPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM" "END-OF-FILE" "HANDLER-BIND" "IGNORE-ERRORS" "MAKE-CONDITION" "OPEN-STREAM-P" "PACKAGE-ERROR" "PACKAGE-ERROR-PACKAGE" "SERIOUS-CONDITION" "SIGNAL" "SIMPLE-CONDITION" "SIMPLE-CONDITION-FORMAT-ARGUMENTS" "SIMPLE-CONDITION-FORMAT-STRING" "SIMPLE-ERROR" "SIMPLE-TYPE-ERROR" "SIMPLE-WARNING" "STORAGE-CONDITION" "STORE-VALUE" "STREAM-ERROR" "STREAM-ERROR-STREAM" "SYNONYM-STREAM-SYMBOL" "TWO-WAY-STREAM-INPUT-STREAM" "TWO-WAY-STREAM-OUTPUT-STREAM" "TYPE-ERROR" "TYPE-ERROR-EXPECTED-TYPE" "UNBOUND-VARIABLE" "UNDEFINED-FUNCTION" "USE-VALUE" "WARNING")))
+
+(CL:DEFUN LITATOM.EXISTS (STRING) (AND (ATOMHASH#PROBES STRING) T))
+
+(CL:DEFVAR LITATOM-PACKAGE-CONVERSION-TABLE (* |;;| "NOTE!  This list is defined BOTH in PACKAGE-STARTUP and the file PACKAGE-CONVERSION-TABLE.  PACKAGE-CONVERSION-TABLE is loaded early in the init  to help TYPE-VARIABLE-FROM-TYPE-NAME do the right thing when packages are off, so that copy of the table is the dominant one.  If you're thinking of changing this table, STOP right now and load PACKAGE-CONVERSION-TABLE so the change will show up in the init - JRB") (* |;;| "And to answer the obvious question: No, we can't put a FILES reference in either of these files.  It would have to be a \"load the other one only when the source for this one is being loaded\" which doesn't exist.") (QUOTE (("CL::" NIL "COMMON-LISP" :INTERNAL) (* |;;| "Minor incantation below which facilitates the sharing of symbols bewtween the LISP and COMMON-LISP packages.") (* |;;| "Note the doubled \"LISP:\"  and \"CL:\" clauses.  NAMESTRING-CONVERSION-CLAUSE matches the first string against the front of the atom's pname, then searches the list of strings for exceptions.  The first \"CL:\" clause causes any atom that isn't in CL only to be homed in CL and shared in LISP; the second clause catches the exceptions that fall through and homes them in LISP only.  Ditto the two \"LISP\" clauses.  Ditto^2 the two XCL clauses.  Many of the XCL entries will be unnecessary as files get remade with the new package environment") (* |;;| "The CL: exceptions should be the same as the NEWCLSYMS list (except for the CL: prefixes); the LISP: exceptions should cover the OLDCLSYMS and SPLITCLSYMS lists similarly.") ("CL:" ("CL:REAL" "CL:BASE-CHARACTER" "CL:EXTENDED-CHARACTER" "CL:READTABLE-CASE" "CL:SIMPLE-STRING" "CL:BASE-STRING" "CL:SIMPLE-BASE-STRING" "CL:BROADCAST-STREAM" "CL:CONCATENATED-STREAM" "CL:ECHO-STREAM" "CL:SYNONYM-STREAM" "CL:STRING-STREAM" "CL:FILE-STREAM" "CL:TWO-WAY-STREAM" "CL:UPGRADED-ARRAY-ELEMENT-TYPE" "CL:UPGRADED-COMPLEX-PART-TYPE" "CL:LOAD-TIME-EVAL" "CL:REALP" "CL:FDEFINITION" "CL:NTH-VALUE" "CL:DESTRUCTURING-BIND" "CL:DEFINE-COMPILER-MACRO" "CL:COMPILER-MACRO-FUNCTION" "CL:COMPILER-MACROEXPAND" "CL:COMPILER-MACROEXPAND-1" "CL:VARIABLE-INFORMATION" "CL:FUNCTION-INFORMATION" "CL:DECLARATION-INFORMATION" "CL:AUGMENT-ENVIRONMENT" "CL:DEFINE-DECLARATION" "CL:PARSE-MACRO" "CL:ENCLOSE" "CL:DECLAIM" "CL:DYNAMIC-EXTENT" "CL:*GENSYM-COUNTER*" "CL:WITH-PACKAGE-ITERATOR" "CL:LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" "CL:LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" "CL:LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" "CL:LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" "CL:LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" "CL:LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" "CL:LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" "CL:LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" "CL:COMPLEMENT" "CL:MAP-INTO" "CL:WITH-HASH-TABLE-ITERATOR" "CL:HASH-TABLE-REHASH-SIZE" "CL:HASH-TABLE-REHASH-THRESHOLD" "CL:HASH-TABLE-SIZE" "CL:HASH-TABLE-TEST" "CL:ROW-MAJOR-AREF" "CL:OPEN-STREAM-P" "CL:BROADCAST-STREAM-STREAMS" "CL:CONCATENATED-STREAM-STREAMS" "CL:ECHO-STREAM-INPUT-STREAM" "CL:ECHO-STREAM-OUTPUT-STREAM" "CL:SYNONYM-STREAM-SYMBOL" "CL:TWO-WAY-STREAM-INPUT-STREAM" "CL:TWO-WAY-STREAM-OUTPUT-STREAM" "CL:INTERACTIVE-STREAM-P" "CL:STREAM-EXTERNAL-FORMAT" "CL:*READ-EVAL*" "CL:READTABLE-CASE" "CL:*PRINT-READABLY*" "CL:WITH-STANDARD-IO-SYNTAX" "CL:PRINT-UNREADABLE-OBJECT" "CL:WILD-PATHNAME-P" "CL:PATHNAME-MATCH-P" "CL:TRANSLATE-PATHNAME" "CL:LOGICAL-PATHNAME" "CL:TRANSLATE-LOGICAL-PATHNAME" "CL:LOGICAL-PATHNAME-TRANSLATIONS" "CL:LOAD-LOGICAL-PATHNAME-TRANSLATIONS" "CL:COMPILE-FILE-PATHNAME" "CL:FILE-STRING-LENGTH" "CL:*LOAD-PRINT*" "CL:*LOAD-PATHNAME*" "CL:*LOAD-TRUENAME*" "CL:MAKE-LOAD-FORM" "CL:MAKE-LOAD-FORM-SAVING-SLOTS" "CL:*COMPILE-VERBOSE" "CL:*COMPILE-PRINT*" "CL:*COMPILE-FILE-PATHNAME*" "CL:*COMPILE-FILE-TRUENAME*" "CL:LOAD-TIME-VALUE" "CL:FUNCTION-LAMBDA-EXPRESSION" "CL:WITH-COMPILATION-UNIT" "CL:IN-PACKAGE" "CL:LOCALLY") ("COMMON-LISP" "LISP") :EXTERNAL) ("CL:" NIL "COMMON-LISP" :EXTERNAL) ("LISP::" NIL "LISP" :INTERNAL) ("LISP:" ("LISP:COMMON" "LISP:COMMONP" "LISP:STRING-CHAR" "LISP:STRING-CHAR-P" "LISP:INT-CHAR" "LISP:COMPILER-LET" "LISP:CHAR-BIT" "LISP:SET-CHAR-BIT" "LISP:*MODULES*" "LISP:PROVIDE" "LISP:REQUIRE" "LISP:CHAR-FONT-LIMIT" "LISP:CHAR-BITS-LIMIT" "LISP:CHAR-BITS" "LISP:CHAR-FONT" "LISP:MAKE-CHAR" "LISP:CHAR-CONTROL-BIT" "LISP:CHAR-META-BIT" "LISP:CHAR-SUPER-BIT" "LISP:CHAR-HYPER-BIT" "LISP:*BREAK-ON-WARNINGS*" "LISP:LOCALLY" "LISP:IN-PACKAGE") ("COMMON-LISP" "LISP") :EXTERNAL) ("LISP:" NIL "LISP" :EXTERNAL) (":" NIL "KEYWORD" :EXTERNAL) ("CONDITIONS::" NIL "CONDITIONS" :INTERNAL) ("CONDITIONS:" ("CONDITIONS:*BREAK-ON-SIGNALS*" "CONDITIONS:COMPUTE-RESTARTS" "CONDITIONS:CONTINUE" "CONDITIONS:DIVISION-BY-ZERO" "CONDITIONS:FILE-ERROR" "CONDITIONS:FILE-ERROR-PATHNAME" "CONDITIONS:FIND-RESTART" "CONDITIONS:FLOATING-POINT-OVERFLOW" "CONDITIONS:FLOATING-POINT-UNDERFLOW" "CONDITIONS:INVOKE-DEBUGGER" "CONDITIONS:INVOKE-RESTART" "CONDITIONS:INVOKE-RESTART-INTERACTIVELY" "CONDITIONS:MUFFLE-WARNING" "CONDITIONS:PROGRAM-ERROR" "CONDITIONS:RESTART" "CONDITIONS:RESTART-BIND" "CONDITIONS:RESTART-CASE" "CONDITIONS:TYPE-ERROR-DATUM" "CONDITIONS:UNBOUND-SLOT" "CONDITIONS:WITH-CONDITION-RESTARTS" "CONDITIONS:WITH-SIMPLE-RESTART") "CONDITIONS" :EXTERNAL) ("CONDITIONS:" NIL ("COMMON-LISP" "CONDITIONS") :EXTERNAL) ("XCL::" NIL "XCL" :INTERNAL) (* |;;| "Similar trick here as for COMMON-LISP vs. LISP above") ("XCL:" ("XCL:ABORT" "XCL:ARITHMETIC-ERROR" "XCL:BROADCAST-STREAM-STREAMS" "XCL:CELL-ERROR" "XCL:CELL-ERROR-NAME" "XCL:CONCATENATED-STREAM-STREAMS" "XCL:CONDITION" "XCL:CONTROL-ERROR" "XCL:DEFINE-CONDITION" "XCL:DEFPACKAGE" "XCL:DELETE-PACKAGE" "XCL:DESTRUCTURING-BIND" "XCL:DIVISION-BY-ZERO" "XCL:ECHO-STREAM-INPUT-STREAM" "XCL:ECHO-STREAM-OUTPUT-STREAM" "XCL:END-OF-FILE" "XCL:FILE-ERROR" "XCL:FLOATING-POINT-OVERFLOW" "XCL:FLOATING-POINT-UNDERFLOW" "XCL:HANDLER-BIND" "XCL:IGNORE-ERRORS" "XCL:MAKE-CONDITION" "XCL:MAKE-VECTOR" "XCL:OPEN-STREAM-P" "XCL:PACKAGE-ERROR" "XCL:PROGRAM-ERROR" "XCL:ROW-MAJOR-AREF" "XCL:SERIOUS-CONDITION" "XCL:SIGNAL" "XCL:SIMPLE-CONDITION" "XCL:SIMPLE-CONDITION-FORMAT-ARGUMENTS" "XCL:SIMPLE-CONDITION-FORMAT-STRING" "XCL:SIMPLE-ERROR" "XCL:SIMPLE-STRING" "XCL:SIMPLE-TYPE-ERROR" "XCL:SIMPLE-WARNING" "XCL:STORAGE-CONDITION" "XCL:STORE-VALUE" "XCL:STREAM-ERROR" "XCL:STREAM-ERROR-STREAM" "XCL:STRING-STREAM-P" "XCL:SYNONYM-STREAM-SYMBOL" "XCL:TWO-WAY-STREAM-INPUT-STREAM" "XCL:TWO-WAY-STREAM-OUTPUT-STREAM" "XCL:TYPE-ERROR" "XCL:UNBOUND-VARIABLE" "XCL:UNDEFINED-FUNCTION" "XCL:USE-VALUE" "XCL:WARNING") "XCL" :EXTERNAL) ("XCL:" NIL ("COMMON-LISP" "XCL") :EXTERNAL) ("SI::" NIL "SI" :INTERNAL) ("SI:" NIL "SI" :EXTERNAL) ("COMPILER::" NIL "COMPILER" :INTERNAL) ("COMPILER:" NIL "COMPILER" :EXTERNAL) ("FASL::" NIL "FASL" :INTERNAL) ("FASL:" NIL "FASL" :EXTERNAL))))
+
+(CL:DEFUN NAMESTRING-CONVERSION-CLAUSE (BASE OFFSET LEN FATP) (* |;;;| "Check whether a given namestring has a prefix that would indicate membership in a package.  If so, return the first clause out of the conversion table that matched.  Otherwise, return NIL.") (DECLARE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:DOLIST (CONVERSION-LIST LITATOM-PACKAGE-CONVERSION-TABLE NIL) (LET* ((PREFIX (CL:FIRST CONVERSION-LIST)) (EXCEPTIONS (CL:SECOND CONVERSION-LIST)) (PREFIX-LENGTH (|ffetch| (STRINGP LENGTH) PREFIX))) (COND ((AND (IGREATERP LEN PREFIX-LENGTH) (\\STRING-EQUALBASE PREFIX BASE OFFSET PREFIX-LENGTH FATP) (NOT (|for| X |in| EXCEPTIONS |suchthat| (\\STRING-EQUALBASE X BASE OFFSET LEN FATP)))) (RETURN CONVERSION-LIST))))))
+
+(CL:DEFUN CONVERT-LITATOM (ATOM) (* |;;| "Conditionally move an INTERLISP litatom into a package based on the naming conventions in LITATOM-PACKAGE-CONVERSION-TABLE.") (LET* ((BASE (|ffetch| (CL:SYMBOL PNAMEBASE) |of| ATOM)) (LEN (|ffetch| (CL:SYMBOL PNAMELENGTH) |of| ATOM)) (FATP (|ffetch| (CL:SYMBOL FATPNAMEP) |of| ATOM)) (CLAUSE (OR (NAMESTRING-CONVERSION-CLAUSE BASE 1 LEN FATP) (CL:RETURN-FROM CONVERT-LITATOM NIL))) (PREFIX (CL:FIRST CLAUSE)) (CL:PACKAGE-NAME (CL:THIRD CLAUSE)) (WHERE (CL:FOURTH CLAUSE)) (PREFIX-LENGTH (|ffetch| (STRINGP LENGTH) PREFIX))) (\\LITATOM.EATCHARS ATOM PREFIX-LENGTH) (* \; "Take off the pseudo-package prefix.  This makes the symbol inaccessible in INTERLISP (because not rehashed).") (COND (CL:PACKAGE-NAME (* \; " Symbol is interned, put it in the package.") (|if| (LISTP CL:PACKAGE-NAME) |then| (* \; "List of packages means symbol is homed in first, shared in others") (INTERN-LITATOM ATOM (CL:FIND-PACKAGE (CAR CL:PACKAGE-NAME)) :WHERE WHERE) (|for| P |in| (CDR CL:PACKAGE-NAME) |bind| PKG |do| (|if| (NULL (SETQ PKG (CL:FIND-PACKAGE P))) |then| (ERROR "Missing package named ~s" P)) (IMPORT ATOM PKG) (|if| (EQ WHERE :EXTERNAL) |then| (EXPORT ATOM PKG))) ATOM |else| (INTERN-LITATOM ATOM (CL:FIND-PACKAGE CL:PACKAGE-NAME) :WHERE WHERE)))) T))
+
+(CL:DEFUN CONCOCT-SYMBOL (STRING) (* |;;| "Create a symbol in the LISP package.  Conflicting symbols must already have been converted and defined by CONVERT-LITATOM.  Given a string, if a symbol by that name exists in INTERLISP (and doesn't conflict) we INTERN-LITATOM it into the LISP package, making that its home.  Otherwise, we create a new one.") (DECLARE (CL:SPECIAL *LISP-PACKAGE* *INTERLISP-PACKAGE* CMLSYMBOLS.SHARED)) (LET (CLSYM) (COND ((CL:MULTIPLE-VALUE-BIND (SYM WHERE) (CL:FIND-SYMBOL STRING *LISP-PACKAGE*) (* |;;| "If a symbol already exists in the LISP package, we assume it's also in the COMMON-LISP package already.") (CL:WHEN (EQ WHERE :INTERNAL) (EXPORT SYM *LISP-PACKAGE*)) (SETQ CLSYM SYM) WHERE) (* \; "The CL symbol already exists.  Make it external.  If the symbol is shared, import it into IL.") (CL:WHEN (CL:MEMBER STRING CMLSYMBOLS.SHARED :TEST (QUOTE STREQUAL)) (IMPORT CLSYM *INTERLISP-PACKAGE*)) (CL:WHEN (AND (NOT (CL:MEMBER STRING OLDCLSYMS :TEST (QUOTE STREQUAL))) CLSYM (* \; "Catches NIL case") (NOT (CL:FIND-SYMBOL STRING *COMMON-LISP-PACKAGE*))) (CL:ERROR "Gotcha! ~s ~s" STRING CLSYM))) (* |;;| "From this point down, the CL symbol doesn't yet exist.") ((CL:MEMBER STRING CMLSYMBOLS.SHARED :TEST (QUOTE STREQUAL)) (* \; "The symbol is shared.  Create it in CL and import it to IL.  NOTE that the symbol should never be found in IL.") (COND ((CL:FIND-SYMBOL STRING *INTERLISP-PACKAGE*) (CL:ERROR "Shared symbol found in IL: ~S" STRING) (* |;;| "(intern-litatom ilsym *lisp-package* :where :external)")) ((CL:MEMBER STRING OLDCLSYMS :TEST (QUOTE STREQUAL)) (* |;;| "Symbol is in LISP and not in CL; intern in LISP and IL") (LET ((SYM (CL:INTERN STRING *LISP-PACKAGE*))) (EXPORT SYM *LISP-PACKAGE*) (IMPORT SYM *INTERLISP-PACKAGE*))) (T (* |;;| "Symbol should be in CL, LISP, and IL, homed in CL") (LET ((SYM (CL:INTERN STRING *COMMON-LISP-PACKAGE*))) (EXPORT SYM *COMMON-LISP-PACKAGE*) (IMPORT SYM *LISP-PACKAGE*) (EXPORT SYM *LISP-PACKAGE*) (IMPORT SYM *INTERLISP-PACKAGE*))))) (T (* \; "Symbol doesn't exist, so just create it in LISP.") (COND ((CL:MEMBER STRING OLDCLSYMS :TEST (QUOTE STREQUAL)) (* |;;| "Symbol is in LISP and not in CL; intern in LISP") (EXPORT (CL:INTERN STRING *LISP-PACKAGE*) *LISP-PACKAGE*)) (T (* |;;| "Symbol should be in CL and LISP, homed in CL") (LET ((SYM (CL:INTERN STRING *COMMON-LISP-PACKAGE*))) (EXPORT SYM *COMMON-LISP-PACKAGE*) (IMPORT SYM *LISP-PACKAGE*) (EXPORT SYM *LISP-PACKAGE*))))))))
+
+(CL:DEFUN TRANSFER-SYMBOL (FROM TO) "Move the function and plist definition cells of a symbol onto another, leaving name and value alone." (CL:SETF (CL:SYMBOL-PLIST TO) (CL:SYMBOL-PLIST FROM)) (CL:SETF (CL:SYMBOL-FUNCTION TO) (CL:SYMBOL-FUNCTION FROM)))
+
+(CL:DEFUN INTERN-LITATOM (ATOM PACKAGE &KEY WHERE) "Tag a litatom with a package.  Add it to the package hashtable.  Handle keywords appropriately.  Return the symbol." (CL:WHEN (AND (LISP::%PACKAGE-EXTERNAL-ONLY PACKAGE) (EQ WHERE :INTERNAL)) (ERROR (CONCAT "Attempting to INTERN-LITATOM " ATOM "internal in external-only package " PACKAGE))) (ADD-SYMBOL (CL:IF (EQ WHERE :INTERNAL) (LISP::%PACKAGE-INTERNAL-SYMBOLS PACKAGE) (LISP::%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)) ATOM) (CL:SETF (CL:SYMBOL-PACKAGE ATOM) PACKAGE) (CL:IF (EQ *KEYWORD-PACKAGE* PACKAGE) (SET ATOM ATOM)) ATOM)
+
+(CL:DEFUN \\LITATOM.EATCHARS (LITATOM N) (LET* ((PNBASE (|fetch| (LITATOM PNAMEBASE) |of| LITATOM)) (LEN (- (|fetch| (PNAMEBASE PNAMELENGTH) |of| PNBASE) N))) (COND ((|fetch| (LITATOM FATPNAMEP) |of| LITATOM) (ERROR (CONCAT "Can't move fat LITATOM |" LITATOM "| into LISP package"))) (T (|for| I |from| 0 |to| LEN |as| J |from| N |do| (\\PUTBASETHIN PNBASE I (\\GETBASETHIN PNBASE J))))) (|replace| (PNAMEBASE PNAMELENGTH) |of| PNBASE |with| LEN)) LITATOM)
+
+(CL:DEFUN PACKAGE-INIT (&OPTIONAL (CONVERT? T)) "Clear, make structures of, initialize & convert symbols to, and enable use of the symbol package system." (PACKAGE-CLEAR) (PACKAGE-MAKE) (PACKAGE-HIERARCHY-INIT CONVERT?) (PACKAGE-ENABLE) T)
+
+(CL:DEFUN PACKAGE-CLEAR NIL "Clear the global package data (used by FIND-PACKAGE) and reset the globals that hold the existing packages." (DECLARE (CL:SPECIAL *PACKAGE-FROM-NAME* *PACKAGE-FROM-INDEX* *PACKAGE* *LISP-PACKAGE* *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*)) (CLRHASH *PACKAGE-FROM-NAME*) (CL:DOTIMES (I (ADD1 *TOTAL-PACKAGES-LIMIT*)) (CL:SETF (CL:AREF *PACKAGE-FROM-INDEX* I) NIL)) (SETQ *PACKAGE* NIL) (SETQ *LISP-PACKAGE* NIL) (SETQ *COMMON-LISP-PACKAGE* NIL) (SETQ *KEYWORD-PACKAGE* NIL) (SETQ *INTERLISP-PACKAGE* NIL) T)
+
+(CL:DEFUN PACKAGE-MAKE NIL (* \; "Edited  8-Apr-92 20:13 by jrb:") (* |;;| "Create, but do not fill with symbols, the base packages that need to exist.  Also enables the package qualifier characters in the readtables and saves the old definitions of \\READ.SYMBOL and \\MKATOM.") (DECLARE (CL:SPECIAL *LISP-PACKAGE* *COMMON-LISP-PACKAGE* *KEYWORD-PACKAGE* *INTERLISP-PACKAGE* *PACKAGE* HASHTABLE-SIZE-LIMIT)) (SETQ *INTERLISP-PACKAGE* (CL:MAKE-PACKAGE "INTERLISP" :USE NIL :NICKNAMES (QUOTE ("IL")) :PREFIX-NAME "IL" :EXTERNAL-ONLY T :EXTERNAL-SYMBOLS HASHTABLE-SIZE-LIMIT)) (SETQ *LISP-PACKAGE* (CL:MAKE-PACKAGE "LISP" :USE NIL :EXTERNAL-SYMBOLS 1173)) (SETQ *COMMON-LISP-PACKAGE* (CL:MAKE-PACKAGE "COMMON-LISP" :USE NIL :NICKNAMES (QUOTE ("CL")) :PREFIX-NAME "CL" :EXTERNAL-SYMBOLS 1173)) (CL:MAKE-PACKAGE "CONDITIONS" :USE "COMMON-LISP" :PREFIX-NAME "CONDITIONS") (CL:MAKE-PACKAGE "XEROX-COMMON-LISP" :USE (QUOTE ("LISP" "CONDITIONS")) :NICKNAMES (QUOTE ("XCL")) :PREFIX-NAME "XCL") (CL:MAKE-PACKAGE "SYSTEM" :USE "LISP" :NICKNAMES (QUOTE ("SYS" "SI")) :PREFIX-NAME "SI") (CL:MAKE-PACKAGE "USER" :USE "LISP") (CL:MAKE-PACKAGE "COMMON-LISP-USER" :USE (QUOTE ("COMMON-LISP" "XCL")) :NICKNAMES (QUOTE ("CL-USER")) :PREFIX-NAME "CL-USER") (SETQ *KEYWORD-PACKAGE* (CL:MAKE-PACKAGE "KEYWORD" :USE NIL :EXTERNAL-ONLY T :EXTERNAL-SYMBOLS 96)) (CL:MAKE-PACKAGE "COMPILER" :USE "LISP") (CL:MAKE-PACKAGE "FASL" :USE "LISP") (CL:MAKE-PACKAGE "XCL-USER" :USE (QUOTE ("LISP" "XCL"))) (MOVD (QUOTE \\READ.SYMBOL) (QUOTE \\OLD.READ.SYMBOL)) (MOVD (QUOTE \\MKATOM) (QUOTE \\OLD.MKATOM)) T)
+
+(CL:DEFUN PACKAGE-HIERARCHY-INIT (&OPTIONAL (CONVERT? NIL)) (* \; "Edited 16-Mar-92 22:48 by jrb:") (* |;;;| "Fill all the initial system packages with their proper symbols, moving litatoms into appropriate places and such.  If convert? is non-nil then symbols whose pnames have fake package qualifiers, like cl:length, will be converted IN PLACE to remove the qualifier.  If conversion takes place you cannot fully disable the package system.") (DECLARE (CL:SPECIAL *INTERLISP-PACKAGE* *KEYWORD-PACKAGE* CMLSYMBOLS.OTHER CMLSYMBOLS.LAMBDA.LIST.KEYWORDS CMLSYMBOLS.SPECIALFORMS CMLSYMBOLS.MACROS CMLSYMBOLS.TYPENAMES CMLSYMBOLS.FNNAMES CMLSYMBOLS.DECLARATORS CMLSYMBOLS.VARS)) (* |;;| "Useful code for turning pagehold off:LET ((*PRINT-LENGTH* 4) (\\#DISPLAYLINES 0)) (DECLARE (LISP:SPECIAL \\#DISPLAYLINES))") (* |;;| "Fill the INTERLISP package with its symbols; snag pseudo-package symbols along the way") (MAPATOMS (CL:FUNCTION (CL:LAMBDA (ATOM) (CL:IF (OR (NULL CONVERT?) (NULL (CONVERT-LITATOM ATOM))) (INTERN-LITATOM ATOM *INTERLISP-PACKAGE* :WHERE :EXTERNAL))))) (* |;;| "Fill the LISP package with its symbols.") (CL:DOLIST (I (APPEND CMLSYMBOLS.VARS CMLSYMBOLS.FNNAMES CMLSYMBOLS.DECLARATORS CMLSYMBOLS.TYPENAMES CMLSYMBOLS.MACROS CMLSYMBOLS.SPECIALFORMS CMLSYMBOLS.LAMBDA.LIST.KEYWORDS CMLSYMBOLS.OTHER)) (CONCOCT-SYMBOL I)) (* |;;| "Handle the few strange CLsymbols (ones that for one reason or another already exist in another package).  STRANGECLSYMS is a list of:") (* |;;| "(<pkg-name> <sym1> ...)") (* |;;| " clauses.") (CL:DOLIST (SL STRANGECLSYMS) (LET ((P (CL:FIND-PACKAGE (CAR SL))) OLDS) (CL:DOLIST (S (CDR SL)) (IF (SETQ OLDS (CL:FIND-SYMBOL S P)) THEN (IMPORT OLDS *COMMON-LISP-PACKAGE*) (EXPORT OLDS *COMMON-LISP-PACKAGE*))))) (* |;;| "And the few symbols that are different in CL and LISP") (CL:DOLIST (SL SPLITCLSYMS) (EXPORT (CL:INTERN SL *COMMON-LISP-PACKAGE*) *COMMON-LISP-PACKAGE*) (EXPORT (CL:INTERN SL *LISP-PACKAGE*) *LISP-PACKAGE*)) (* |;;| "And the symbols that are shared between XCL and CL") (LET ((XCLP (CL:FIND-PACKAGE "XCL")) S) (CL:DOLIST (SL XCLCLSYMS) (IF (SETQ S (CL:FIND-SYMBOL SL XCLP)) THEN (IMPORT S *COMMON-LISP-PACKAGE*) (EXPORT S *COMMON-LISP-PACKAGE*) (CL:SETF (CL:SYMBOL-PACKAGE S) *COMMON-LISP-PACKAGE*) ELSE (SETQ S (CL:INTERN SL *COMMON-LISP-PACKAGE*)) (EXPORT S *COMMON-LISP-PACKAGE*) (IMPORT S XCLP) (EXPORT S XCLP)))) (* |;;| "Finally, hose out the new COMMON-LISP symbols (the old ones are handled by CONCOCT-SYMBOL)") (CL:DOLIST (I NEWCLSYMS) (EXPORT (CL:INTERN I *COMMON-LISP-PACKAGE*) *COMMON-LISP-PACKAGE*)) (* |;;| "Stuff later in the loadup will further populate the COMMON-LISP package (CLOS and CONDITIONS, primarily)") T)
+
+(CL:DEFUN PACKAGE-ENABLE (&OPTIONAL (PACKAGE *INTERLISP-PACKAGE*)) "Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly." (DECLARE (CL:SPECIAL *INTERLISP-PACKAGE* *PACKAGE* *OLD-INTERLISP-READ-ENVIRONMENT* *PER-EXEC-VARIABLES*)) (|replace| REPACKAGE |of| *OLD-INTERLISP-READ-ENVIRONMENT* |with| *INTERLISP-PACKAGE*) (COND ((FIND-READTABLE "LISP") (READTABLEPROP (FIND-READTABLE "LISP") (QUOTE PACKAGECHAR) (CHARCODE ":")))) (COND ((FIND-READTABLE "COMMON-LISP") (READTABLEPROP (FIND-READTABLE "COMMON-LISP") (QUOTE PACKAGECHAR) (CHARCODE ":")))) (COND ((FIND-READTABLE "INTERLISP") (READTABLEPROP (FIND-READTABLE "INTERLISP") (QUOTE PACKAGECHAR) (CHARCODE ":")))) (COND ((FIND-READTABLE "XCL") (READTABLEPROP (FIND-READTABLE "XCL") (QUOTE PACKAGECHAR) (CHARCODE ":")))) (RPAQ? *PER-EXEC-VARIABLES* NIL) (* |;;| "This stuff will eventually be converted to the COMMON-LISP package") (CL:PUSHNEW (QUOTE (*PACKAGE* (COND ((CL:PACKAGEP *PACKAGE*) *PACKAGE*) (T (PROMPTPRINT "Invalid package, reset to LISP") (SETQ *PACKAGE* (CL:FIND-PACKAGE "LISP")))))) *PER-EXEC-VARIABLES* :TEST (QUOTE CL:EQUAL)) (CL:SETF *DEFAULT-MAKEFILE-ENVIRONMENT* (QUOTE (:READTABLE "XCL" :PACKAGE "INTERLISP"))) (MOVD (QUOTE \\NEW.READ.SYMBOL) (QUOTE \\READ.SYMBOL)) (MOVD (QUOTE \\NEW.MKATOM) (QUOTE \\MKATOM)) (CL:SETF *PACKAGE* PACKAGE) (* |;;| " One last bit of detritus which can be removed after we've been running on the new world for awhile: any existing type-variable symbols in either the CL or LISP packages needs to be shared in both packages") (|for| I |from| 1 |to| |\\MaxTypeNumber| |bind| TYPENAME TP |do| (SETQ TYPENAME (\\INDEXATOMPNAME (|fetch| DTDNAME |of| (\\GETDTD I)))) (SETQ TP (CL:SYMBOL-PACKAGE TYPENAME)) (COND ((EQ TP *LISP-PACKAGE*) (IMPORT (TYPE-VARIABLE-FROM-TYPE-NAME TYPENAME) *COMMON-LISP-PACKAGE*)) ((EQ TP *COMMON-LISP-PACKAGE*) (IMPORT (TYPE-VARIABLE-FROM-TYPE-NAME TYPENAME) *LISP-PACKAGE*)))) T)
+
+(CL:DEFUN PACKAGE-DISABLE NIL "Turn off the package system and restore the old definitions of \\\\READ.SYMBOL and \\MKATOM.  After disabling, symbols interned under the package system will not be EQ to symbols of the same name reread." (MOVD (QUOTE \\OLD.READ.SYMBOL) (QUOTE \\READ.SYMBOL)) (MOVD (QUOTE \\OLD.MKATOM) (QUOTE \\MKATOM)) (SETQ *PACKAGE* NIL) (|replace| REPACKAGE |of| *OLD-INTERLISP-READ-ENVIRONMENT* |with| NIL) (READTABLEPROP (FIND-READTABLE "LISP") (QUOTE PACKAGECHAR) 0) (READTABLEPROP (FIND-READTABLE "INTERLISP") (QUOTE PACKAGECHAR) 0) (READTABLEPROP (FIND-READTABLE "XCL") (QUOTE PACKAGECHAR) 0) T)
+
+
+
+(* |;;| "A function to move the \"CL\" nickname between the LISP and COMMON-LISP packages")
+
+
+(CL:DEFUN FLIP-CL (WHERE) (LET ((WHERE-WAS-IT (CL:FIND-PACKAGE "CL"))) (SETQ WHERE-WAS-IT (COND ((EQ WHERE-WAS-IT *COMMON-LISP-PACKAGE*) :COMMON-LISP) ((EQ WHERE-WAS-IT *LISP-PACKAGE*) :LISP) ((NULL WHERE-WAS-IT) :NOWHERE) (T (ERROR "CL nickname in odd package" WHERE-WAS-IT)))) (CL:ECASE WHERE (:LISP (CL:RENAME-PACKAGE *COMMON-LISP-PACKAGE* "COMMON-LISP" NIL NIL) (CL:RENAME-PACKAGE *LISP-PACKAGE* "LISP" (QUOTE ("CL")) "CL")) (:COMMON-LISP (CL:RENAME-PACKAGE *LISP-PACKAGE* "LISP" NIL NIL) (CL:RENAME-PACKAGE *COMMON-LISP-PACKAGE* "COMMON-LISP" (QUOTE ("CL")) "CL")) (:NOWHERE (CL:RENAME-PACKAGE *LISP-PACKAGE* "LISP" NIL NIL) (CL:RENAME-PACKAGE *COMMON-LISP-PACKAGE* "COMMON-LISP" NIL NIL))) WHERE-WAS-IT))
+
+
+
+(* |;;| "A hack for initialization")
+
+
+(CL:DEFUN ID (X) X)
+
+(PUTPROPS PACKAGE-STARTUP FILETYPE CL:COMPILE-FILE)
+
+(PUTPROPS PACKAGE-STARTUP MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "INTERLISP"))
+
+
+
+(* |;;| "Initialize package system, plus functions needed in llpackage at init time")
+
+(DECLARE\: DONTEVAL@LOAD DOCOPY 
+
+(MOVD? (QUOTE EQ) (QUOTE EQL))
+
+(MOVD? (QUOTE LENGTH) (QUOTE CL:LENGTH))
+
+(MOVD? (QUOTE ID) (QUOTE CL:IDENTITY))
+
+(MOVD? (QUOTE ID) (QUOTE REMOVE-COMMENTS))
+
+(PACKAGE-INIT)
+)
+(PUTPROPS PACKAGE-STARTUP COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/CLTL2/PACKAGE-STARTUP.LCOM b/CLTL2/PACKAGE-STARTUP.LCOM
new file mode 100644
index 00000000..c252f825
Binary files /dev/null and b/CLTL2/PACKAGE-STARTUP.LCOM differ
diff --git a/CLTL2/PROFILE b/CLTL2/PROFILE
new file mode 100644
index 00000000..a0269948
--- /dev/null
+++ b/CLTL2/PROFILE
@@ -0,0 +1,117 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
+(IL:FILECREATED " 8-Apr-92 22:04:29" IL:|{DSK}<usr>local>lde>lispcore>sources>PROFILE.;2| 12225  
+
+      IL:|changes| IL:|to:|  (PROFILES "COMMON-LISP") (IL:VARS IL:PROFILECOMS)
+
+      IL:|previous| IL:|date:| "16-May-90 21:15:43" IL:|{DSK}<usr>local>lde>lispcore>sources>PROFILE.;1|
+)
+
+
+; Copyright (c) 1986, 1987, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:PROFILECOMS)
+
+(IL:RPAQQ IL:PROFILECOMS ((IL:* IL:|;;| "The profile type") (IL:DEFINE-TYPES PROFILES) (IL:FUNCTIONS DEFPROFILE) (IL:TYPES PROFILE) (IL:STRUCTURES PROFILE-CLAUSE VARIABLE-DEFINITION) (IL:VARIABLES *PROFILE* *PROFILE-NAME* *PROFILE-VARIABLES* *PROFILES*) (IL:FUNCTIONS FIND-VARIABLE-DEFINITION IN-PROFILE INSTALL-PROFILE MAKE-VARIABLE-DEFINITION PROFILIZE PROFILE-ENTRY-VALUE PROFILE-ENTRY-VALUE-NAME PROFILE-NAME PROFILE-P PROFILE-VALUE-TYPE-CHECK SETF-PROFILE-ENTRY-VALUE SETF-PROFILE-ENTRY-VALUE-NAME SETF-PROFILE-NAME MAKE-PROFILE COPY-PROFILE RESTORE-PROFILE SAVE-PROFILE WITH-PROFILE FIND-PROFILE SETF-FIND-PROFILE LIST-ALL-PROFILES PROFILE-VALUES PROFILE-VARIABLES) (IL:SETFS FIND-PROFILE PROFILE-ENTRY-VALUE PROFILE-ENTRY-VALUE-NAME PROFILE-NAME) (PROFILES "READ-PRINT" "LISP" "INTERLISP" "OLD-INTERLISP-T" "XEROX-COMMON-LISP" "COMMON-LISP") (IL:DECLARE\: IL:DONTCOPY IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE (IL:LOCALVARS . T)) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:PROFILE)))
+
+
+
+(IL:* IL:|;;| "The profile type")
+
+
+(DEF-DEFINE-TYPE PROFILES "interaction profiles")
+
+(DEFDEFINER (DEFPROFILE (:NAME (LAMBDA (WHOLE) (LET ((NAME-CLAUSE (SECOND WHOLE))) (IF (CONSP NAME-CLAUSE) (STRING (CAR NAME-CLAUSE)) (STRING NAME-CLAUSE)))))) PROFILES (NAME-CLAUSE &REST VARIABLE-CLAUSES) "Creates a new named profile. name . clauses or (name (:nicknames n1 n2...)) clauses" (LET ((NAME (IF (CONSP NAME-CLAUSE) (STRING (CAR NAME-CLAUSE)) (STRING NAME-CLAUSE))) (NICKNAMES (AND (CONSP NAME-CLAUSE) (MAPCAR (FUNCTION STRING) (CDADR NAME-CLAUSE))))) (IL:BQUOTE (LET ((PROFILE (MAKE-PROFILE (IL:\\\, NAME) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (CLAUSE) (IL:BQUOTE (QUOTE (IL:\\\, CLAUSE))))) VARIABLE-CLAUSES))))) (INSTALL-PROFILE PROFILE (IL:\\\, NAME) (QUOTE (IL:\\\, NICKNAMES)))))))
+
+(DEFTYPE PROFILE NIL (IL:BQUOTE (SATISFIES PROFILE-P)))
+
+(DEFSTRUCT (PROFILE-CLAUSE (:TYPE LIST) (:CONSTRUCTOR NIL)) VARIABLE NAME TYPE COERCION-FUNCTION NAME-FUNCTION)
+
+(DEFSTRUCT (VARIABLE-DEFINITION (:TYPE LIST) (:CONSTRUCTOR NIL)) VARIABLE TYPE COERCION-FUNCTION NAME-FUNCTION)
+
+(DEFPARAMETER *PROFILE* "XCL" "The default or current profile.")
+
+(DEFPARAMETER *PROFILE-NAME* NIL)
+
+(DEFPARAMETER *PROFILE-VARIABLES* (QUOTE ((*PROFILE-NAME* T IDENTITY IDENTITY) (*EVAL-FUNCTION* (MEMBER IL:EVAL EVAL) IDENTITY IDENTITY) (*EXEC-PROMPT* STRING STRING IDENTITY) (*DEBUGGER-PROMPT* STRING STRING IDENTITY) (*READTABLE* READTABLE IL:FIND-READTABLE IL:READTABLE-NAME) (*READ-BASE* (INTEGER 2 36) IDENTITY IDENTITY) (*READ-SUPPRESS* (MEMBER NIL T) IDENTITY IDENTITY) (*PACKAGE* PACKAGE FIND-PACKAGE PACKAGE-NAME) (*READ-DEFAULT-FLOAT-FORMAT* (MEMBER SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT SHORT-FLOAT) IDENTITY IDENTITY) (*PRINT-ESCAPE* (MEMBER NIL T) IDENTITY IDENTITY) (*PRINT-PRETTY* (MEMBER NIL T) IDENTITY IDENTITY) (*PRINT-CIRCLE* (MEMBER NIL T) IDENTITY IDENTITY) (*PRINT-BASE* (INTEGER 2 36) IDENTITY IDENTITY) (*PRINT-RADIX* (MEMBER NIL T) IDENTITY IDENTITY) (*PRINT-CASE* (MEMBER :DOWNCASE :UPCASE :CAPITALIZE) IDENTITY IDENTITY) (*PRINT-GENSYM* (MEMBER NIL T) IDENTITY IDENTITY) (*PRINT-LEVEL* (OR NULL FIXNUM) IDENTITY IDENTITY) (*PRINT-LENGTH* (OR NULL FIXNUM) IDENTITY IDENTITY) (*PRINT-ARRAY* (MEMBER NIL T) IDENTITY IDENTITY) (*PRINT-STRUCTURE* (MEMBER NIL T) IDENTITY IDENTITY))))
+
+(DEFGLOBALVAR *PROFILES* (MAKE-HASH-TABLE :TEST (QUOTE EQUAL)) "Where profiles live.")
+
+(DEFUN FIND-VARIABLE-DEFINITION (VARIABLE) (DOLIST (ENTRY *PROFILE-VARIABLES* NIL) (IF (EQ VARIABLE (VARIABLE-DEFINITION-VARIABLE ENTRY)) (RETURN ENTRY))))
+
+(DEFUN IN-PROFILE (PROFILE) "Makes profile the current profile and resets *profile*" (SETQ *PROFILE* (PROFILIZE PROFILE)) (RESTORE-PROFILE *PROFILE*))
+
+(DEFUN INSTALL-PROFILE (PROFILE PROFILE-NAME PROFILE-NICKNAMES) (DOLIST (NAME (CONS PROFILE-NAME PROFILE-NICKNAMES)) (IL:* IL:\; "Make the name and all nicknames point at the new profile.") (IF (AND (FIND-PROFILE NAME) (FBOUNDP (QUOTE WARN))) (WARN "Resetting profile ~s." NAME)) (SETF (FIND-PROFILE NAME) PROFILE)))
+
+(DEFUN MAKE-VARIABLE-DEFINITION (CLAUSE &AUX (DEFINITION NIL)) "Add a new profile variable entry based on clauses.  clauses is bounded by a keyword or nil." (DOLIST (DEFAULT (QUOTE (NIL (IL:* IL:\; "variable") IGNORE (IL:* IL:\; "value") T (IL:* IL:\; "type") IDENTITY (IL:* IL:\; "coercion-function") IDENTITY (IL:* IL:\; "name-function"))) (IL:* IL:\; "Defaults for a definition's slots.")) (IL:* IL:\; "Maps on defaults to always fill all the slots.") (IF (EQ DEFAULT (QUOTE IGNORE)) (POP CLAUSE) (IL:* IL:\; "Ignore the value slot") (PUSH (IL:* IL:\; "Push onto the new entry") (IF (NULL CLAUSE) (IL:* IL:\; "If we're at the end of the clause:") DEFAULT (IL:* IL:\; "...use the default.") (POP CLAUSE) (IL:* IL:\; "...otherwise use the next element of the clause.")) DEFINITION))) (SETQ DEFINITION (NREVERSE DEFINITION)) (PUSH DEFINITION (IL:* IL:\; "Flip the push built list.") *PROFILE-VARIABLES*) (IL:* IL:\; "Put the new definition onto the global list of definitions.") DEFINITION)
+
+(DEFUN PROFILIZE (NAME-OR-PROFILE) (ETYPECASE NAME-OR-PROFILE ((OR STRING SYMBOL) (OR (FIND-PROFILE NAME-OR-PROFILE) (ERROR "Not the name of an existing profile ~s" NAME-OR-PROFILE))) (PROFILE NAME-OR-PROFILE)))
+
+(DEFUN PROFILE-ENTRY-VALUE (VARIABLE &OPTIONAL (PROFILE *PROFILE*)) "Returns the value of the variable in the current profile or its binding." (GETF (PROFILIZE PROFILE) VARIABLE (EVAL VARIABLE)))
+
+(DEFUN PROFILE-ENTRY-VALUE-NAME (VARIABLE &OPTIONAL (PROFILE *PROFILE*)) "Get the name of the value in a variable or the name of the current binding." (FUNCALL (VARIABLE-DEFINITION-NAME-FUNCTION (FIND-VARIABLE-DEFINITION VARIABLE)) (GETF (PROFILIZE PROFILE) VARIABLE (EVAL VARIABLE))))
+
+(DEFUN PROFILE-NAME (&OPTIONAL (PROFILE *PROFILE*)) "Returns the name of the profile as a string." (PROFILE-ENTRY-VALUE (QUOTE *PROFILE-NAME*) (PROFILIZE PROFILE)))
+
+(DEFUN PROFILE-P (OBJECT) "Returns true if the object seems to be a profile.  Is true only of profiles, never their names." (AND (CONSP OBJECT) (SYMBOLP (FIRST OBJECT)) (EVENP (LENGTH OBJECT)) T))
+
+(DEFUN PROFILE-VALUE-TYPE-CHECK (DEFINITION VALUE) "Returns correct or corrected value." (LET ((COERCION-FUNCTION (VARIABLE-DEFINITION-COERCION-FUNCTION DEFINITION)) (TYPE (VARIABLE-DEFINITION-TYPE DEFINITION))) (LOOP (IF (TYPEP VALUE TYPE) (IL:* IL:\; "Is it of the right type?") (RETURN VALUE) (IL:* IL:\; "...just return it")) (COND (COERCION-FUNCTION (SETQ VALUE (FUNCALL COERCION-FUNCTION VALUE)) (IL:* IL:\; "Perhaps it was a name, coerce it.") (IF (TYPEP VALUE TYPE) (IL:* IL:\; "Is it NOW of the right type?") (RETURN VALUE) (IL:* IL:\; "...just return it")))) (IL:* IL:|;;| "Otherwise we were given something that can't either use or coerce; complain, fix and retry") (CERROR "Give new value" "Profile slot ~s's value ~s not a(n) ~s" (VARIABLE-DEFINITION-VARIABLE DEFINITION) VALUE TYPE) (FORMAT *QUERY-IO* "Give new value expression (will be evaluated)~%") (SETQ VALUE (EVAL (READ))))))
+
+(DEFUN SETF-PROFILE-ENTRY-VALUE (VARIABLE PROFILE VALUE) (SETQ PROFILE (PROFILIZE PROFILE)) (LET ((TYPE (VARIABLE-DEFINITION-TYPE (FIND-VARIABLE-DEFINITION VARIABLE)))) (ASSERT (TYPEP VALUE TYPE) (VALUE) "Profile slot ~s's value ~s not a(n) ~s" VARIABLE VALUE TYPE) (SETF (GETF PROFILE VARIABLE) VALUE)))
+
+(DEFUN SETF-PROFILE-ENTRY-VALUE-NAME (VARIABLE PROFILE NAME) (SETQ PROFILE (PROFILIZE PROFILE)) (SETF (PROFILE-ENTRY-VALUE VARIABLE PROFILE) (FUNCALL (VARIABLE-DEFINITION-COERCION-FUNCTION (FIND-VARIABLE-DEFINITION VARIABLE)) NAME)))
+
+(DEFUN SETF-PROFILE-NAME (PROFILE NAME) (SETF (PROFILE-ENTRY-VALUE (QUOTE *PROFILE-NAME*) PROFILE) (STRING NAME)))
+
+(DEFUN MAKE-PROFILE (PROFILE-NAME &REST CLAUSES) "Creates a profile with slots described by the clauses.  Clauses is an alist of variables and values, similar to defstruct's." (LET ((PROFILE NIL)) (DOLIST (CLAUSE CLAUSES) (LET* ((VARIABLE (PROFILE-CLAUSE-VARIABLE CLAUSE)) (NAME (PROFILE-CLAUSE-NAME CLAUSE)) (IL:* IL:\; "Name of the value to be used (or the value itself).") (DEFINITION (OR (FIND-VARIABLE-DEFINITION VARIABLE) (MAKE-VARIABLE-DEFINITION CLAUSE)))) (IL:* IL:|;;| "These are pushed on in reverse order so the final prop list format of the profile will be correct.") (PUSH (PROFILE-VALUE-TYPE-CHECK DEFINITION (EVAL NAME)) PROFILE) (PUSH VARIABLE PROFILE))) (CONS (QUOTE *PROFILE-NAME*) (CONS PROFILE-NAME PROFILE))))
+
+(DEFUN COPY-PROFILE (&OPTIONAL (PROFILE *PROFILE*)) "Copies the given profile." (COPY-SEQ (PROFILIZE PROFILE)))
+
+(DEFUN RESTORE-PROFILE (&OPTIONAL (PROFILE *PROFILE*)) "Set profile variables from given profile." (SETQ PROFILE (PROFILIZE PROFILE)) (MAPC (FUNCTION SET) (PROFILE-VARIABLES PROFILE) (PROFILE-VALUES PROFILE)) PROFILE)
+
+(DEFUN SAVE-PROFILE (&OPTIONAL (PROFILE *PROFILE*)) "Save current values of bindings into profile." (IL:FOR X IL:ON (PROFILIZE PROFILE) IL:BY CDDR IL:DO (SETF (CADR X) (EVAL (CAR X)))) PROFILE)
+
+(DEFMACRO WITH-PROFILE (PROFILE-FORM &BODY FORMS) "Bind all the special IO variables to the values in the profile and execute the body forms." (IL:BQUOTE (LET ((*PROFILE* (IL:\\\, PROFILE-FORM))) (SETQ *PROFILE* (PROFILIZE *PROFILE*)) (PROGV (PROFILE-VARIABLES *PROFILE*) (PROFILE-VALUES *PROFILE*) (IL:\\\,@ FORMS)))))
+
+(DEFUN FIND-PROFILE (NAME) (GETHASH (STRING NAME) *PROFILES*))
+
+(DEFUN SETF-FIND-PROFILE (NAME PROFILE) (SETQ NAME (STRING NAME)) (SETQ PROFILE (PROFILIZE PROFILE)) (SETF (GETHASH NAME *PROFILES*) PROFILE) (SETF (PROFILE-NAME PROFILE) NAME) NAME)
+
+(DEFUN LIST-ALL-PROFILES NIL (LET ((PROFILES NIL)) (MAPHASH (FUNCTION (LAMBDA (NAME VALUE) (PUSHNEW VALUE PROFILES :TEST (FUNCTION EQ)) (IL:* IL:\; "Avoid repeats due to nicknames"))) *PROFILES*) (MAPCAR (FUNCTION (LAMBDA (PROFILE) (PROFILE-NAME PROFILE) (IL:* IL:\; "Convert to name strings"))) PROFILES)))
+
+(DEFUN PROFILE-VALUES (PROFILE) (IL:FOR X IL:IN (CDR (PROFILIZE PROFILE)) IL:BY CDDR IL:COLLECT X))
+
+(DEFUN PROFILE-VARIABLES (&OPTIONAL (PROFILE *PROFILE*)) (IL:FOR X IL:IN (PROFILIZE PROFILE) IL:BY CDDR IL:COLLECT X))
+
+(DEFSETF FIND-PROFILE SETF-FIND-PROFILE)
+
+(DEFSETF PROFILE-ENTRY-VALUE SETF-PROFILE-ENTRY-VALUE)
+
+(DEFSETF PROFILE-ENTRY-VALUE-NAME SETF-PROFILE-ENTRY-VALUE-NAME)
+
+(DEFSETF PROFILE-NAME SETF-PROFILE-NAME)
+
+(DEFPROFILE "READ-PRINT" (*READTABLE* "LISP") (*READ-BASE* 10) (*READ-SUPPRESS* NIL) (*PACKAGE* "USER") (*READ-DEFAULT-FLOAT-FORMAT* (QUOTE SINGLE-FLOAT)) (*PRINT-ESCAPE* T) (*PRINT-PRETTY* NIL) (*PRINT-CIRCLE* NIL) (*PRINT-BASE* 10) (*PRINT-RADIX* NIL) (*PRINT-CASE* :UPCASE) (*PRINT-GENSYM* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) (*PRINT-ARRAY* NIL) (*PRINT-STRUCTURE* NIL))
+
+(DEFPROFILE "LISP" (*READTABLE* "LISP") (*PACKAGE* "USER") (*EVAL-FUNCTION* (QUOTE EVAL)) (*EXEC-PROMPT* "> ") (*DEBUGGER-PROMPT* ": "))
+
+(DEFPROFILE ("INTERLISP" (:NICKNAMES "IL")) (*READTABLE* "INTERLISP") (*PACKAGE* "INTERLISP") (*EVAL-FUNCTION* (QUOTE IL:EVAL)) (*EXEC-PROMPT* "_ ") (*DEBUGGER-PROMPT* "_: "))
+
+(DEFPROFILE "OLD-INTERLISP-T" (*READTABLE* "OLD-INTERLISP-T") (*PACKAGE* "INTERLISP") (*EVAL-FUNCTION* (QUOTE IL:EVAL)) (*EXEC-PROMPT* "_ ") (*DEBUGGER-PROMPT* "_: "))
+
+(DEFPROFILE ("XEROX-COMMON-LISP" (:NICKNAMES "XCL")) (*READTABLE* "XCL") (*PACKAGE* "CL-USER") (*EVAL-FUNCTION* (QUOTE EVAL)) (*EXEC-PROMPT* "> ") (*DEBUGGER-PROMPT* ": "))
+
+(DEFPROFILE ("COMMON-LISP" (:NICKNAMES "CL")) (*READTABLE* "LISP") (*PACKAGE* "CL-USER") (*EVAL-FUNCTION* (QUOTE EVAL)) (*EXEC-PROMPT* "> ") (*DEBUGGER-PROMPT* ": "))
+(IL:DECLARE\: IL:DONTCOPY IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE 
+(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
+
+(IL:LOCALVARS . T)
+)
+)
+
+(IL:PUTPROPS IL:PROFILE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL"))
+
+(IL:PUTPROPS IL:PROFILE IL:FILETYPE COMPILE-FILE)
+(IL:PUTPROPS IL:PROFILE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/PROFILE.LCOM b/CLTL2/PROFILE.LCOM
new file mode 100644
index 00000000..a384f4df
Binary files /dev/null and b/CLTL2/PROFILE.LCOM differ
diff --git a/CLTL2/SEDIT-COMMANDS b/CLTL2/SEDIT-COMMANDS
new file mode 100644
index 00000000..a77cd281
--- /dev/null
+++ b/CLTL2/SEDIT-COMMANDS
@@ -0,0 +1,388 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL)))
+(IL:FILECREATED " 8-Apr-92 21:51:21" IL:|{DSK}<usr>local>lde>lispcore>sources>SEDIT-COMMANDS.;2| 100944 
+
+      IL:|changes| IL:|to:|  (IL:FNS CHANGE-PACKAGE) (IL:VARIABLES *POPULAR-PACKAGES*) (IL:VARS IL:SEDIT-COMMANDSCOMS)
+
+      IL:|previous| IL:|date:| "25-Jan-91 14:50:34" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>SEDIT-COMMANDS.;1|)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:SEDIT-COMMANDSCOMS)
+
+(IL:RPAQQ IL:SEDIT-COMMANDSCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-COMMANDS) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-COMMANDS) (IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:VARIABLES COMMAND-TABLE-SPEC *EDIT-FN* *WRAP-SEARCH* *POPULAR-PACKAGES*) (IL:VARS MENU-DESCRIPTION (FIND-CANDIDATE NIL) (SUBSTITUTE-CANDIDATE NIL) (MUTATE-CANDIDATE NIL) (PACKAGE-CANDIDATE NIL) (PRINTBASE-CANDIDATE NIL)) (IL:INITVARS (CONVERT-UPGRADE 100) (WANT-MENU NIL) (MENUS NIL)) (IL:CONSTANTS (WORD-DELIM-CHARS (IL:CHARCODE (IL:SPACE IL:CR IL:TAB - IL:{ IL:} IL:[ IL:] IL:\; < > IL:\.)))) (IL:FUNCTIONS (IL:* IL:|;;| "pseudo-selections") PSEUDO-SELECTION-FROM-SELECTION COMPOSE-PSEUDO-SELECTION DECOMPOSE-PSEUDO-SELECTION SELECTION-FROM-PSEUDO-SELECTION SELECT-PSEUDO-SEGMENT) (IL:* IL:|;;| "user interface to adding new commands") (IL:FUNCTIONS ADD-COMMAND GET-SELECTION REPLACE-SELECTION RESET-COMMANDS DEFAULT-COMMANDS) (IL:VARIABLES DEFAULT-COMMAND-TABLE-SPEC FIRST-ADD-COMMAND FIRST-ADD-COMMAND-MENU-ENTRY) (IL:FUNCTIONS (IL:* IL:|;;| "building help menu") EQUALIZE-STRING-WIDTHS MINIMUM-STRING-WIDTH MAXIMUM-STRING-WIDTH) (IL:FUNCTIONS FIND-AND-DISPLAY-STRUCTURE FIND-AND-DISPLAY-STRUCTURE-BACKWARDS FIND-AND-DISPLAY-SUBSTRUCTURE FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS FIND-NTH-STRUCTURE FIND-NODE-SUBSTRUCTURE FIND-NODE-SUBSTRUCTURE-BACKWARDS FIND-OBJ FIND-SELECTION FIND-SELECTION-BACKWARDS FIND-STRUCTURE FIND-STRUCTURE-BACKWARDS FIND-SUBSTRUCTURE FIND-SUBSTRUCTURE-BACKWARDS GET-USER-STRING SEARCH-OBJ SEARCH-OBJ-BACKWARDS SUBSTITUTE-OBJ SUBSTITUTE-STRUCTURE SUBSTITUTE-SUBSTRUCTURE STRUCTURE-FROM-SELECTION STRUCTURE-FROM-STRING COMMENT-OUT-SELECTION) (IL:FNS ADD-MENU BACKSPACE CHANGE-PACKAGE CHANGE-PRINTBASE CHANGE-QUOTE CONVERT-COMMENT CONVERT-COMMENT-STRUCTURE CONVERT-COMMENT-TAIL CREATE-COMMAND-TABLE DEFAULT-EDIT-FN DELETE-SELECTION DELETE-WORD DO-MUTATION EDIT-SELECTION EVAL-SELECTION EXPAND EXTRACT-CURRENT-SELECTION FIND-COMMENT GET-MENU EDIT-HELP HELPMENU INPUT-DOT INPUT-ESCAPE INPUT-NORMAL-CHAR INPUT-QUOTE INPUT-SQUARE-BRACKET INPUT-STRINGDELIM INPUT-TOKENDELIM INSERT-MULTI-ESCAPE INSERT-SPECIAL-CHARACTER INSPECT-SELECTION JOIN MENU-CLOSEFN MENU-FIND-SELECTEDFN MENU-INIT-STATE MENU-PACKAGE-SELECTEDFN MENU-PRINTBASE-SELECTEDFN MENU-SELECTEDFN MENU-SUBSTITUTE-SELECTEDFN MUTATE QUOTE-CURRENT-SELECTION REDISPLAY REDO SELECTED-FN-NAME SKIP-TO-GAP UNDO UNDO-EXTRACT)))
+
+(IL:PUTPROPS IL:SEDIT-COMMANDS IL:FILETYPE :COMPILE-FILE)
+
+(IL:PUTPROPS IL:SEDIT-COMMANDS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL))))
+(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
+
+(IL:LOCALVARS . T)
+)
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(IL:FILESLOAD IL:SEDIT-DECLS)
+)
+
+(DEFPARAMETER COMMAND-TABLE-SPEC (IL:* IL:|;;;| "each entry in the COMMAND-TABLE-SPEC should be of the form: (<fn> <help menu entry> <normalize?> <key>+) where <fn> is an atom function name or a list whose car is the function name and the rest are the extra arguments (beyond context and charcode), <help menu entry> is a list of strings for the name, key-name, and help-string, <normalize?> is T if the caret should be normalized after this command, and <key>+ is one or more key specifier which can be passed to charcode (if non-list) or whose car is a termtable syntax (if a list).") (QUOTE ((IL:* IL:|;;| "STRUCTURE CONTROL") (INSERT-NULL-LIST NIL T (IL:LEFTPAREN)) (CLOSE-LIST NIL NIL (IL:RIGHTPAREN)) (INPUT-SQUARE-BRACKET NIL NIL (IL:LEFTBRACKET) (IL:RIGHTBRACKET)) (INPUT-TOKENDELIM NIL T (IL:SEPRCHAR)) (INPUT-STRINGDELIM NIL NIL (IL:STRINGDELIM)) (INPUT-ESCAPE NIL NIL (IL:ESCAPE)) (INSERT-MULTI-ESCAPE NIL NIL (IL:MULTIPLE-ESCAPE)) (INSERT-SPECIAL-CHARACTER NIL NIL (IL:PACKAGEDELIM)) (START-COMMENT NIL NIL ";") (INPUT-DOT NIL NIL ".") (INSERT-SPECIAL-CHARACTER NIL NIL "#") ((INPUT-QUOTE QUOTE) NIL NIL "'") ((INPUT-QUOTE IL:BQUOTE) NIL NIL "`") ((INPUT-QUOTE IL:COMMA) NIL NIL ",") ((INPUT-QUOTE COMMA-AT) NIL NIL "@") (IL:* IL:|;;| "EDIT CONTROL") (DELETE-SELECTION NIL T IL:DEL) (BACKSPACE NIL T IL:BS "^A") (DELETE-WORD NIL T "^W") ((VERIFY-STRUCTURE NIL T T) NIL NIL "^L") ((VERIFY-STRUCTURE NIL T NIL) NIL NIL "1,^L") (IL:* IL:|;;| "COMPLETION") ((COMPLETE :ABORT NIL) ("Abort" "M-A" "Complete this edit without installing changes.") NIL "1,A" "1,a" (ABORT)) (NULL ("" "" "") NIL 0) ((COMPLETE :DONE NIL) ("Done" "C-X" "Complete this edit and leave the window open.") NIL "^X" (DONE)) ((COMPLETE :CLOSE) ("Done & Close" "C-M-X" "Complete this edit and close the window.") NIL "1,^X" (EXIT)) ((COMPLETE :DONE T) ("Done & Compile" "C-C" "Complete this edit, compile, and leave the window open.") NIL "^C" (COMPILE)) ((COMPLETE :CLOSE T) ("Done, Compile, & Close" "C-M-C" "Complete this edit, compile, and close the window.") NIL "1,^C") (IL:* IL:|;;| "COMMANDS") (NULL ("" "" "") NIL 0) (UNDO ("Undo" "M-U" "Undo the last change made.") NIL "1,U" "1,u" 516 (UNDO)) (REDO ("Redo" "M-R" "Redo the last change undone.") NIL "1,R" "1,r" 520 (REDO)) (NULL ("" "" "") NIL 0) (FIND-OBJ ("Find" "M-F" "Find the current selection, or prompt for structure to Find.") T "1,F" "1,f" 515 (FIND)) ((FIND-OBJ NIL T) ("Reverse Find" "C-M-F" "Find the current selection, or prompt for structure to Find.") T "1,^F") ((SUBSTITUTE-OBJ NIL NIL T) ("Remove" "C-M-S" "Remove structures from within the current selection.") NIL "1,^S") (SUBSTITUTE-OBJ ("Substitute" "M-S" "Substitute structures within the current selection.") NIL "1,S" "1,s" 547 (SUBSTITUTE)) (SKIP-TO-GAP ("Find Gap" "M-N" "Skip to the next fill in gap.") T "1,N" "1,n" 530) (NULL ("" "" "") NIL 0) (EDIT-HELP ("Arglist" "M-H" "Show the argument list for the selected function.") NIL "1,H" "1,h" 513 (ARGLIST)) (CONVERT-COMMENT ("Convert Comment" "M-;" "Convert the old style comments in the current selection.") NIL "1,;") (COMMENT-OUT-SELECTION NIL NIL "1,^;") (EDIT-SELECTION ("Edit" "M-O" "Edit the definition of the current selection.") NIL "1,O" "1,o" (EDIT)) ((EDIT-SELECTION (:CURRENT)) ("Edit Fast" "C-M-O" "Edit the current definition of the selection.") NIL "1,^O") (EVAL-SELECTION ("Eval" "M-E" "Evaluate the current selection.") NIL "1,E" "1,e" (EVAL)) (EXPAND ("Expand" "M-X" "Replace the current selection with its definition.") NIL "1,X" "1,x" IL:ESC 532 (EXPAND)) (EXTRACT-CURRENT-SELECTION ("Extract" "M-/" "Extract one level of structure: unquote or unlist.") NIL "1,/" (EXTRACT)) (INSPECT-SELECTION ("Inspect" "M-I" "Inspect the current selection.") NIL "1,I" "1,i" (INSPECT)) (JOIN ("Join" "M-J" "Join selected items together.") NIL "1,J" "1,j" (JOIN)) (MUTATE ("Mutate" "M-Z" "Prompt for a function to operate on the current selection.") NIL "1,Z" "1,z") ((PARENTHESIZE-CURRENT-SELECTION NIL) ("Parenthesize" "M-(" "Parenthesize the current selection.") NIL "1,(" "1,71" (PAREN)) ((PARENTHESIZE-CURRENT-SELECTION T) NIL NIL "1,)" "1,60") ((QUOTE-CURRENT-SELECTION QUOTE) ("Quote" "M-'" "Quote the current selection.") NIL "1,'" (QUOTE)) ((QUOTE-CURRENT-SELECTION IL:BQUOTE) NIL NIL "1,`") ((QUOTE-CURRENT-SELECTION IL:COMMA) NIL NIL "1,,") ((QUOTE-CURRENT-SELECTION COMMA-AT) NIL NIL "1,@" "1,62") ((QUOTE-CURRENT-SELECTION COMMA-DOT) NIL NIL "1,.") ((QUOTE-CURRENT-SELECTION FUNCTION) NIL NIL "1,#" "1,63") (NULL ("" "" "") NIL 0) (CHANGE-PRINTBASE ("Set Print-Base" "M-B" "Set the print-base for this edit.") NIL "1,B" "1,b" (SET-PRINT-BASE)) (CHANGE-PACKAGE ("Set Package" "M-P" "Set the package to edit in.") NIL "1,P" "1,p" (SET-PACKAGE)) (ADD-MENU ("Attach Menu" "M-M" "Attach a command menu.") NIL "1,M" "1,m") (IL:* IL:|;;| "RANDOM: tells Meta-Space or Meta-Return to scroll to the selection, using the auto-scroller for free.") (TRUE NIL T "1, " "1,
+"))))
+
+(DEFPARAMETER *EDIT-FN* (QUOTE DEFAULT-EDIT-FN))
+
+(DEFVAR *WRAP-SEARCH* NIL)
+
+(DEFVAR *POPULAR-PACKAGES* (LIST IL:*INTERLISP-PACKAGE* IL:*LISP-PACKAGE* IL:*COMMON-LISP-PACKAGE*) "SEdit warns if the editing package is not on this list and uses nothing on this list")
+
+(IL:RPAQQ MENU-DESCRIPTION ((IL:PROPS IL:FONT (IL:HELVETICA 10 IL:BOLD)) ((IL:GROUP (IL:PROPS IL:FORMAT IL:COLUMN IL:COLUMNSPACE 20 IL:ROWSPACE 3) ((IL:GROUP (IL:PROPS IL:FORMAT IL:TABLE IL:COLUMNSPACE 12) ((IL:PROPS IL:BOX 1) (IL:LABEL EXIT IL:SELECTEDFN MENU-SELECTEDFN) (IL:LABEL DONE IL:SELECTEDFN MENU-SELECTEDFN) (IL:LABEL ABORT IL:SELECTEDFN MENU-SELECTEDFN IL:MAXWIDTH 39)) ((IL:PROPS IL:BOX 1) (IL:LABEL UNDO IL:SELECTEDFN MENU-SELECTEDFN) (IL:LABEL REDO IL:SELECTEDFN MENU-SELECTEDFN) (IL:LABEL ARGLIST IL:SELECTEDFN MENU-SELECTEDFN)))) ((IL:GROUP (IL:PROPS IL:FORMAT IL:TABLE IL:COLUMNSPACE 12) ((IL:PROPS IL:BOX 1) (IL:LABEL PAREN IL:SELECTEDFN MENU-SELECTEDFN) (IL:LABEL QUOTE IL:SELECTEDFN MENU-SELECTEDFN) (IL:LABEL EXTRACT IL:SELECTEDFN MENU-SELECTEDFN)) ((IL:PROPS IL:BOX 1) (IL:LABEL EDIT IL:SELECTEDFN MENU-SELECTEDFN) (IL:LABEL EVAL IL:SELECTEDFN MENU-SELECTEDFN) (IL:LABEL EXPAND IL:SELECTEDFN MENU-SELECTEDFN IL:MAXWIDTH 46)))))) ((IL:LABEL PRINT-BASE IL:SELECTEDFN MENU-PRINTBASE-SELECTEDFN IL:ID PRINTBASE-ITEM IL:LINKS (IL:EDIT PRINTBASE-VALUE-ITEM)) (IL:LABEL "" TYPE IL:NUMBER IL:MAXWIDTH 14 IL:ID PRINTBASE-VALUE-ITEM IL:FONT (IL:GACHA 10)) (IL:LABEL PACKAGE IL:SELECTEDFN MENU-PACKAGE-SELECTEDFN IL:ID PACKAGE-ITEM IL:LINKS (IL:EDIT PACKAGE-NAME-ITEM)) (IL:LABEL "" TYPE IL:EDIT IL:ID PACKAGE-NAME-ITEM IL:FONT (IL:GACHA 10))) ((IL:GROUP (IL:PROPS IL:FORMAT IL:TABLE) ((IL:LABEL FIND\: IL:SELECTEDFN MENU-FIND-SELECTEDFN IL:LINKS (IL:EDIT FINDITEM)) (IL:LABEL "" TYPE IL:EDIT IL:ID FINDITEM IL:FONT (IL:GACHA 10))) ((IL:LABEL SUBSTITUTE\: IL:SELECTEDFN MENU-SUBSTITUTE-SELECTEDFN IL:LINKS (IL:EDIT SUBSTITUTEITEM FINDITEM FINDITEM)) (IL:LABEL "" TYPE IL:EDIT IL:ID SUBSTITUTEITEM IL:FONT (IL:GACHA 10)))))))
+
+(IL:RPAQQ FIND-CANDIDATE NIL)
+
+(IL:RPAQQ SUBSTITUTE-CANDIDATE NIL)
+
+(IL:RPAQQ MUTATE-CANDIDATE NIL)
+
+(IL:RPAQQ PACKAGE-CANDIDATE NIL)
+
+(IL:RPAQQ PRINTBASE-CANDIDATE NIL)
+
+(IL:RPAQ? CONVERT-UPGRADE 100)
+
+(IL:RPAQ? WANT-MENU NIL)
+
+(IL:RPAQ? MENUS NIL)
+(IL:DECLARE\: IL:EVAL@COMPILE 
+
+(IL:RPAQ WORD-DELIM-CHARS (IL:CHARCODE (IL:SPACE IL:CR IL:TAB - IL:{ IL:} IL:[ IL:] IL:\; < > IL:\.)))
+
+
+(IL:CONSTANTS (WORD-DELIM-CHARS (IL:CHARCODE (IL:SPACE IL:CR IL:TAB - IL:{ IL:} IL:[ IL:] IL:\; < > IL:\.))))
+)
+
+(DEFUN PSEUDO-SELECTION-FROM-SELECTION (SEL) (IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers.  It's interpreted as the select-node, select-start, and select-end fields of a selection.") (IL:* IL:|;;;| "This function takes a selection and creates a pseudo selection from it.") (COMPOSE-PSEUDO-SELECTION (IL:FETCH SELECT-NODE IL:OF SEL) (IL:FETCH SELECT-START IL:OF SEL) (OR (IL:FETCH SELECT-END IL:OF SEL) (IL:FETCH SELECT-START IL:OF SEL))))
+
+(DEFUN COMPOSE-PSEUDO-SELECTION (NODE &OPTIONAL START END) (IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers.  It's interpreted as the select-node, select-start, and select-end fields of a selection.") (IL:* IL:|;;;| "This function takes the fields of a pseudo selection and hands back one.") (COND ((LISTP NODE) (LIST (IL:FETCH SUPER-NODE IL:OF (FIRST NODE)) (+ (IL:FETCH SUB-NODE-INDEX IL:OF (FIRST NODE)) (OR START 0)) (+ (IL:FETCH SUB-NODE-INDEX IL:OF (FIRST NODE)) (1- (OR END (LENGTH NODE)))))) ((OR START END) (LIST NODE (OR START END) (OR END START))) (T NODE)))
+
+(DEFUN DECOMPOSE-PSEUDO-SELECTION (PSEL) (IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers.  It's interpreted as the select-node, select-start, and select-end fields of a selection.") (IL:* IL:|;;;| "This function takes a pseudo selection and hands its fields back as values.") (IF (LISTP PSEL) (VALUES (FIRST PSEL) (OR (SECOND PSEL) (THIRD PSEL)) (OR (THIRD PSEL) (SECOND PSEL))) (VALUES PSEL NIL NIL)))
+
+(DEFUN SELECTION-FROM-PSEUDO-SELECTION (PSEL &OPTIONAL SEL) (IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers.  It's interpreted as the select-node, select-start, and select-end fields of a selection.") (IL:* IL:|;;;| "This function takes a pseudo-selection and constructs the corresponding selection.  If you don't hand it a selection structure, it conses one.") (UNLESS SEL (SETF SEL (IL:CREATE EDIT-SELECTION))) (MULTIPLE-VALUE-BIND (NODE START END) (DECOMPOSE-PSEUDO-SELECTION PSEL) (IL:REPLACE SELECT-NODE IL:OF SEL IL:WITH NODE) (IL:REPLACE SELECT-START IL:OF SEL IL:WITH START) (IL:REPLACE SELECT-END IL:OF SEL IL:WITH END) SEL))
+
+(DEFUN SELECT-PSEUDO-SEGMENT (CONTEXT PSEL &OPTIONAL SET-POINT? WHERE) (MULTIPLE-VALUE-BIND (NODE START END) (DECOMPOSE-PSEUDO-SELECTION PSEL) (IF START (SELECT-NODE-SEGMENT CONTEXT NODE START END) (SELECT-NODE CONTEXT NODE SET-POINT? WHERE))))
+
+
+
+(IL:* IL:|;;| "user interface to adding new commands")
+
+
+(DEFUN ADD-COMMAND (KEY-CODE FORM &OPTIONAL SCROLL? KEY-NAME COMMAND-NAME HELP-STRING) (WHEN FIRST-ADD-COMMAND (IL:* IL:|;;| "cache the command-table-spec so the user can undo this!") (SETQ DEFAULT-COMMAND-TABLE-SPEC (COPY-TREE COMMAND-TABLE-SPEC)) (SETQ FIRST-ADD-COMMAND NIL)) (WHEN (AND KEY-NAME COMMAND-NAME FIRST-ADD-COMMAND-MENU-ENTRY) (IL:* IL:|;;| "add another separation line to the help menu.") (NCONC COMMAND-TABLE-SPEC (LIST (LIST (QUOTE NULL) (LIST "-----" "" "") NIL 0))) (SETQ FIRST-ADD-COMMAND-MENU-ENTRY NIL)) (NCONC COMMAND-TABLE-SPEC (LIST (LIST FORM (WHEN (AND KEY-NAME COMMAND-NAME) (LIST KEY-NAME COMMAND-NAME HELP-STRING)) SCROLL? KEY-CODE))) (OR COMMAND-NAME FORM))
+
+(DEFUN GET-SELECTION (CONTEXT) (LET ((SELECTION (IL:FETCH SELECTION IL:OF CONTEXT))) (COND ((OR (NOT (IL:FETCH SELECT-NODE IL:OF SELECTION)) (NOT (EQ (IL:FETCH SELECT-TYPE IL:OF SELECTION) (QUOTE STRUCTURE)))) (VALUES NIL NIL)) ((IL:FETCH SELECT-START IL:OF SELECTION) (VALUES (STRUCTURE-FROM-SELECTION SELECTION) :SUB-LIST)) (T (VALUES (STRUCTURE-FROM-SELECTION SELECTION) T)))))
+
+(DEFUN REPLACE-SELECTION (CONTEXT STRUCTURE SELECTION-TYPE) (UNLESS (OR (EQ SELECTION-TYPE T) (EQ SELECTION-TYPE :SUB-LIST)) (ERROR "Illegal SELECTION-TYPE arg: ~A." SELECTION-TYPE)) (LET* ((SELECTION (IL:FETCH SELECTION IL:OF CONTEXT)) (POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) NEW-NODES) (COND ((OR (NOT (IL:FETCH SELECT-NODE IL:OF SELECTION)) (NOT (EQ (IL:FETCH SELECT-TYPE IL:OF SELECTION) (QUOTE STRUCTURE)))) (ERROR "Invalid SEdit selection.  Can't REPLACE-SELECTION.")) ((EQ SELECTION-TYPE :SUB-LIST) (SETQ NEW-NODES (MAPCAR (FUNCTION (LAMBDA (S) (PARSE-NEW S CONTEXT))) STRUCTURE))) (T (SETQ NEW-NODES (PARSE-NEW STRUCTURE CONTEXT)))) (PENDING-DELETE POINT SELECTION) (INSERT POINT CONTEXT (COPY-LIST NEW-NODES)) (IL:* IL:|;;| "try to select the stuff that was just inserted.") (SELECT-PSEUDO-SEGMENT CONTEXT (COMPOSE-PSEUDO-SELECTION NEW-NODES))))
+
+(DEFUN RESET-COMMANDS NIL (LET ((COMMANDS (CREATE-COMMAND-TABLE COMMAND-TABLE-SPEC))) (IL:REPLACE (EDIT-ENV COMMAND-TABLE) IL:OF LISP-EDIT-ENVIRONMENT IL:WITH (FIRST COMMANDS)) (IL:REPLACE (EDIT-ENV HELP-MENU) IL:OF LISP-EDIT-ENVIRONMENT IL:WITH (SECOND COMMANDS))) T)
+
+(DEFUN DEFAULT-COMMANDS NIL (SETQ COMMAND-TABLE-SPEC (COPY-TREE DEFAULT-COMMAND-TABLE-SPEC)) (SETQ FIRST-ADD-COMMAND-MENU-ENTRY T) (RESET-COMMANDS) T)
+
+(DEFGLOBALVAR DEFAULT-COMMAND-TABLE-SPEC NIL "Used to cache the original command table spec for Reset-Commands")
+
+(DEFGLOBALVAR FIRST-ADD-COMMAND T "Used in Add-Command to know if this is the first new command for help-menu update purposes")
+
+(DEFGLOBALVAR FIRST-ADD-COMMAND-MENU-ENTRY T "Used in Add-Command to signal the first time a new command is added to the middle button menu, so that the user entries can be separated from the default entries")
+
+(DEFUN EQUALIZE-STRING-WIDTHS (STRING-LIST FONT &OPTIONAL PRIN2? (DESIRED-WIDTH (MAXIMUM-STRING-WIDTH STRING-LIST FONT PRIN2?)) (PAD-CHAR #\Space)) (IL:* IL:|;;;| "Increase the width of all the strings in STRING-LIST to DESIRED-WIDTH by padding them on the right with PAD-CHAR.") (DO ((PAD-CHAR-WIDTH (IL:CHARWIDTH (CHAR-CODE PAD-CHAR) FONT)) (STR STRING-LIST (REST STR))) ((NULL STR) STRING-LIST) (SETF (FIRST STR) (CONCATENATE (QUOTE STRING) (FIRST STR) (MAKE-STRING (CEILING (- DESIRED-WIDTH (IL:STRINGWIDTH (FIRST STR) FONT PRIN2?)) PAD-CHAR-WIDTH) :INITIAL-ELEMENT PAD-CHAR)))))
+
+(DEFUN MINIMUM-STRING-WIDTH (STRING-LIST FONT PRIN2?) (APPLY (FUNCTION MIN) (MAPCAR (FUNCTION (LAMBDA (S) (IL:STRINGWIDTH S FONT PRIN2?))) STRING-LIST)))
+
+(DEFUN MAXIMUM-STRING-WIDTH (STRING-LIST FONT PRIN2?) (APPLY (FUNCTION MAX) (MAPCAR (FUNCTION (LAMBDA (S) (IL:STRINGWIDTH S FONT PRIN2?))) STRING-LIST)))
+
+(DEFUN FIND-AND-DISPLAY-STRUCTURE (CONTEXT STR &OPTIONAL SCOPE START WRAP?) (IL:* IL:|;;;| "Find structure and display it by selecting it (point after) and normalizing the selection in the window.  SCOPE defaults to the root structure of the CONTEXT.  The WRAP? flag says to wrap failing searches around and try them again (i.e., ignore start and try again).") (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) (TOP (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT))) (TARGET (FIND-STRUCTURE STR (OR SCOPE TOP) START))) (COND (TARGET (SELECT-NODE CONTEXT TARGET T T) (FORMAT PROMPTWINDOW "~%~S - Found." STR)) ((AND WRAP? START) (FIND-AND-DISPLAY-STRUCTURE CONTEXT STR SCOPE)) (T (FORMAT PROMPTWINDOW "~%~S - Not found." STR)))))
+
+(DEFUN FIND-AND-DISPLAY-STRUCTURE-BACKWARDS (CONTEXT STR &OPTIONAL SCOPE END WRAP?) (IL:* IL:|;;;| "Like find-and-display-structure, but searches backwards") (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) (TOP (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT))) (TARGET (FIND-STRUCTURE-BACKWARDS STR (OR SCOPE TOP) END))) (COND (TARGET (SELECT-NODE CONTEXT TARGET T T) (FORMAT PROMPTWINDOW "~%~S - Found." STR)) ((AND WRAP? END) (FIND-AND-DISPLAY-STRUCTURE-BACKWARDS CONTEXT STR SCOPE)) (T (FORMAT PROMPTWINDOW "~%~S - Not found." STR)))))
+
+(DEFUN FIND-AND-DISPLAY-SUBSTRUCTURE (CONTEXT STR &OPTIONAL SCOPE START WRAP?) (IL:* IL:|;;;| "Find substructure and display it by selecting it (pending delete) and normalizing the selection in the window.  SCOPE defaults to the root structure of the CONTEXT.  The WRAP? flag says to wrap failing searches around and try them again (i.e., ignore start and try again).") (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) (TOP (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT))) (TARGET (FIND-SUBSTRUCTURE STR (OR SCOPE TOP) START))) (COND (TARGET (SELECT-PSEUDO-SEGMENT CONTEXT TARGET) (FORMAT PROMPTWINDOW "~%~{~S ~}- Found." STR)) ((AND WRAP? START) (FIND-AND-DISPLAY-SUBSTRUCTURE CONTEXT STR SCOPE)) (T (FORMAT PROMPTWINDOW "~%~{~S ~}- Not found." STR)))))
+
+(DEFUN FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS (CONTEXT STR &OPTIONAL SCOPE END WRAP?) (IL:* IL:|;;;| "Like find-and-display-substructure but searches backwards") (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) (TOP (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT))) (TARGET (FIND-SUBSTRUCTURE-BACKWARDS STR (OR SCOPE TOP) END))) (COND (TARGET (SELECT-PSEUDO-SEGMENT CONTEXT TARGET) (FORMAT PROMPTWINDOW "~%~{~S ~}- Found." STR)) ((AND WRAP? END) (FIND-AND-DISPLAY-SUBSTRUCTURE CONTEXT STR SCOPE)) (T (FORMAT PROMPTWINDOW "~%~{~S ~}- Not found." STR)))))
+
+(DEFUN FIND-NTH-STRUCTURE (CONTEXT CHARCODE STRUCTURE N) (IL:* IL:|;;;| "Find the Nth occurance of Structure in this edit, always starting from the beginning.  This function is used as an external command to set the selection to a desired structure.  Find, select, and normalize.") (LET ((TOP (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT)))) (DO ((M 1 (+ M 1)) (TARGET (FIND-STRUCTURE STRUCTURE TOP) (FIND-STRUCTURE STRUCTURE TOP (NEXT-NODE TARGET)))) ((OR (NULL TARGET) (= N M)) (AND TARGET (SELECT-NODE CONTEXT TARGET T T))))) T)
+
+(DEFUN FIND-NODE-SUBSTRUCTURE (STR STRLEN NODE &OPTIONAL START END CONTINUATION?) (IL:* IL:|;;;| "STR is a list of structures of length STRLEN.  NODE, together with START and END (which are subnode indices), is taken to indicate a subtree.  We return a pseudo-selection which selects the first sequence of sibling nodes in that subtree whose successive structures match the successive elements of STR.") (IL:* IL:|;;;| "\"First\" here is taken to mean \"first in linearization order\", so we have to do a careful recursion which: (1a) recursively checks the subtree rooted at the START subnode of NODE (default the first), (1b) checks if the START subnode starts a matching sibling sequence, (2a) recursively checks the subtree rooted at the START+1 subnode of NODE,  (2b) checks if the START+1 subnode starts a matching sibling sequence, . . ., (Na) recusively checks the subtree rooted at the END subnode of NODE (default the last), (Nb) checks if the END subnode starts a matching sibling sequence [note that such a sequence could be only 1 node long since END is the right end of the subtree being checked].") (IL:* IL:|;;;| "N.B. It might seem that, to get true linearization order, we should check to see if a node starts a matching sibling sequence before we check its subtree.  But since node structures can not be circular, we know that if a match is found in the subtree  below a node then that node could not have started a matching sequence.") (IL:* IL:|;;;| "The CONTINUATION? flag means that we are continuing a search that has already recursively checked the START subnode, so we skip that particular recursion.  This generally happens when we are working our way up and to the right in some subtree which has already been partially checked.") (SETF START (OR START 1)) (LET* ((SUBNODES (IL:FETCH SUB-NODES IL:OF NODE)) (LASTINDEX (OR END (FIRST SUBNODES)))) (DO ((SUBS (NTHCDR START SUBNODES) (REST SUBS)) (INDEX START (1+ INDEX)) (ENDINDEX (+ START (1- STRLEN)) (1+ ENDINDEX)) (DOSUBS? (NOT CONTINUATION?) T) MATCH) ((OR (NULL SUBS) (AND END (> INDEX END))) NIL) (WHEN (AND DOSUBS? (SETF MATCH (FIND-NODE-SUBSTRUCTURE STR STRLEN (FIRST SUBS)))) (RETURN MATCH)) (UNLESS (OR (> ENDINDEX LASTINDEX) (MISMATCH STR SUBS :END2 STRLEN :TEST (FUNCTION (LAMBDA (S N) (IL:EQUAL S (IL:FETCH STRUCTURE IL:OF N)))))) (RETURN (LIST NODE INDEX ENDINDEX))))))
+
+(DEFUN FIND-NODE-SUBSTRUCTURE-BACKWARDS (STR STRLEN NODE &OPTIONAL START END CONTINUATION?) (IL:* IL:|;;;| "Like find-node-substructure but searches in reverse linearization order.") (LET* ((SUBNODES (IL:FETCH SUB-NODES IL:OF NODE)) (SUBLENGTH (FIRST SUBNODES))) (SETF END (OR END SUBLENGTH)) (DO ((SUBS (NTHCDR (- SUBLENGTH END) (REVERSE (CDR SUBNODES))) (CDR SUBS)) (INDEX END (1- INDEX)) (STARTINDEX (- END (1- STRLEN)) (1- STARTINDEX)) (DOSUBS? (NOT CONTINUATION?) T) MATCH) ((OR (NULL SUBS) (AND START (< INDEX START))) NIL) (WHEN (AND DOSUBS? (SETF MATCH (FIND-NODE-SUBSTRUCTURE-BACKWARDS STR STRLEN (FIRST SUBS)))) (RETURN MATCH)) (UNLESS (OR (< STARTINDEX 1) (MISMATCH STR SUBS :END2 STRLEN :TEST (FUNCTION (LAMBDA (S N) (IL:EQUAL S (IL:FETCH STRUCTURE IL:OF N)))))) (RETURN (LIST NODE STARTINDEX INDEX))))))
+
+(DEFUN FIND-OBJ (CONTEXT &OPTIONAL CHARCODE FIND-STRING BACKWARDS?) (IL:* IL:|;;;| "Find either the passed structure, the selected structure, or a prompted-for structure.  The search direction is forward unless BACKWARDS? is specified.") (CLOSE-OPEN-NODE CONTEXT) (LET ((SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (WRAP? *WRAP-SEARCH*)) (COND ((AND (NULL FIND-STRING) (IL:|fetch| SELECT-NODE IL:|of| SELECTION) (EQ (IL:|fetch| SELECT-TYPE IL:|of| SELECTION) (QUOTE STRUCTURE))) (IL:* IL:|;;| "there is a non-string selection") (IF BACKWARDS? (FIND-SELECTION-BACKWARDS CONTEXT WRAP?) (FIND-SELECTION CONTEXT WRAP?))) (T (IF BACKWARDS? (SEARCH-OBJ-BACKWARDS CONTEXT FIND-STRING WRAP?) (SEARCH-OBJ CONTEXT FIND-STRING WRAP?))))) T)
+
+(DEFUN FIND-SELECTION (CONTEXT &OPTIONAL WRAP?) (IL:* IL:|;;;| "Find the next match of the current selection and display it.") (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) (SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (NODE (IL:|fetch| SELECT-NODE IL:|of| SELECTION)) (START (IL:|fetch| SELECT-START IL:|of| SELECTION))) (IF START (IL:* IL:|;;| "a sibling sequence is selected, look for a matching sequence after it") (FIND-AND-DISPLAY-SUBSTRUCTURE CONTEXT (STRUCTURE-FROM-SELECTION SELECTION) NIL (LIST NODE (1+ START)) WRAP?) (IL:* IL:|;;| "a node is selected, look for a matching node ") (IF (SETF START (NEXT-NODE NODE T)) (IL:* IL:|;;| "start the search with the following node") (FIND-AND-DISPLAY-STRUCTURE CONTEXT (STRUCTURE-FROM-SELECTION SELECTION) NIL START WRAP?) (IL:* IL:|;;| "there are no more nodes, either wrap or give up") (IF WRAP? (FIND-AND-DISPLAY-STRUCTURE CONTEXT (STRUCTURE-FROM-SELECTION SELECTION)) (FORMAT PROMPTWINDOW "~%At end; no more structure to search."))))))
+
+(DEFUN FIND-SELECTION-BACKWARDS (CONTEXT &OPTIONAL WRAP?) (IL:* IL:|;;;| "Find the previous match of the current selection and display it.") (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) (SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (NODE (IL:|fetch| SELECT-NODE IL:|of| SELECTION)) (END (OR (IL:|fetch| SELECT-START IL:|of| SELECTION) (IL:|fetch| SELECT-END IL:|of| SELECTION)))) (IF END (IL:* IL:|;;| "a sibling sequence is selected, look for a matching sequence before it") (FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS CONTEXT (STRUCTURE-FROM-SELECTION SELECTION) NIL (LIST NODE (1- END)) WRAP?) (IL:* IL:|;;| "a node is selected, look for a matching node ") (IF (SETF END (PREV-NODE NODE T)) (IL:* IL:|;;| "start the search with the previous node") (FIND-AND-DISPLAY-STRUCTURE-BACKWARDS CONTEXT (STRUCTURE-FROM-SELECTION SELECTION) NIL END WRAP?) (IL:* IL:|;;| "there are no more nodes, either wrap or give up") (IF WRAP? (FIND-AND-DISPLAY-STRUCTURE-BACKWARDS CONTEXT (STRUCTURE-FROM-SELECTION SELECTION)) (FORMAT PROMPTWINDOW "~%At beginning; no more structure to search."))))))
+
+(DEFUN FIND-STRUCTURE (STR SCOPE &OPTIONAL START) (IL:* IL:|;;;| "Search forward in linearization order for a node whose structure matches STR.  The search is bounded by SCOPE (a pseudo-selection taken to indicate a subtree) and starts at START (a pseudo-selection taken to indicate its left-most node).  START defaults to SCOPE.    The return value is the first node in SCOPE at or after START whose structure is IL:EQUAL to STR.") (IL:* IL:|;;;| "N.B. Since node structures can not be circular, no subnode of a node can have structure matching that node.  Thus looking for a matching node in pre-order is the same as looking for one in linearization order.  So we do a pre-order search here.") (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END) (DECOMPOSE-PSEUDO-SELECTION SCOPE) (MULTIPLE-VALUE-BIND (START-NODE START-START) (DECOMPOSE-PSEUDO-SELECTION START) (WHEN (AND (NULL SCOPE-START) (OR (NULL START-NODE) (AND (NULL START-START) (EQ START-NODE SCOPE-NODE))) (IL:EQUAL STR (IL:FETCH STRUCTURE IL:OF SCOPE-NODE))) (IL:* IL:|;;| "special case: the scope includes its root node, we're starting at the root of the scope, and the root of the scope matches the passed structure.") (RETURN-FROM FIND-STRUCTURE SCOPE-NODE)) (IL:* IL:|;;| "normal case: check all the nodes in the scope subtree in preorder.") (DO* ((MIN-DEPTH (1+ (IL:FETCH DEPTH IL:OF SCOPE-NODE))) (NODE (OR (IF START-START (SUBNODE START-START START-NODE) (UNLESS (EQ START-NODE SCOPE-NODE) START-NODE)) (IF SCOPE-START (SUBNODE SCOPE-START SCOPE-NODE) (NEXT-NODE SCOPE-NODE))) (NEXT-NODE NODE))) ((OR (NULL NODE) (< (IL:FETCH DEPTH IL:OF NODE) MIN-DEPTH) (AND SCOPE-END (EQ (IL:FETCH SUPER-NODE IL:OF NODE) SCOPE-NODE) (> (IL:FETCH SUB-NODE-INDEX IL:OF NODE) SCOPE-END))) NIL) (WHEN (IL:EQUAL STR (IL:FETCH STRUCTURE IL:OF NODE)) (RETURN NODE))))))
+
+(DEFUN FIND-STRUCTURE-BACKWARDS (STR SCOPE &OPTIONAL END) (IL:* IL:|;;;| "like find-structure but searches in reverse linearization order.  Actually we search in postorder rather than reverse linearization order but this works just as well for the same reasons that preorder matches linearization order.") (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END) (DECOMPOSE-PSEUDO-SELECTION SCOPE) (MULTIPLE-VALUE-BIND (END-NODE END-START END-END) (DECOMPOSE-PSEUDO-SELECTION END) (WHEN (AND (NULL SCOPE-START) (OR (NULL END-NODE) (AND (NULL END-START) (EQ END-NODE SCOPE-NODE))) (IL:EQUAL STR (IL:FETCH STRUCTURE IL:OF SCOPE-NODE))) (IL:* IL:|;;| "special case: the scope includes its root node, we're ending at the root of the scope, and the root of the scope matches the passed structure.") (RETURN-FROM FIND-STRUCTURE-BACKWARDS SCOPE-NODE)) (IL:* IL:|;;| "normal case: check all the nodes in the scope subtree in postorder.") (DO* ((MIN-DEPTH (1+ (IL:FETCH DEPTH IL:OF SCOPE-NODE))) (NODE (OR (IF END-END (SUBNODE END-END END-NODE) (UNLESS (EQ END-NODE SCOPE-NODE) END-NODE)) (IF SCOPE-END (SUBNODE SCOPE-END SCOPE-NODE) (PREV-NODE SCOPE-NODE))) (PREV-NODE NODE))) ((OR (NULL NODE) (< (IL:FETCH DEPTH IL:OF NODE) MIN-DEPTH) (AND SCOPE-START (EQ (IL:FETCH SUPER-NODE IL:OF NODE) SCOPE-NODE) (< (IL:FETCH SUB-NODE-INDEX IL:OF NODE) SCOPE-START))) NIL) (WHEN (IL:EQUAL STR (IL:FETCH STRUCTURE IL:OF NODE)) (RETURN NODE))))))
+
+(DEFUN FIND-SUBSTRUCTURE (STR SCOPE &OPTIONAL START) (IL:* IL:|;;;| "Search forward in linearization order for a sequence of nodes whose successive structures match the successive elements of STR.  The search is bounded by SCOPE (a pseudo-selection taken to indicate a subtree) and starts at START (a pseudo-selection taken to indicate the left edge of a subtree).  START defauts to SCOPE.  The return value is a pseudo-selection indicating the sibling sequence of nodes in SCOPE at or to the right of START whose successive node structures are IL:EQUAL to the successive members of STR.") (IL:* IL:|;;;| "N.B. For a sequence of sibling nodes, first in linearization order can not be found by doing a preorder search.  See find-node-substructure for details about the correct search method.") (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END) (DECOMPOSE-PSEUDO-SELECTION SCOPE) (MULTIPLE-VALUE-BIND (START-NODE START-START) (DECOMPOSE-PSEUDO-SELECTION START) (COND ((NULL START-NODE) (IL:* IL:|;;| "just check the entire scope") (FIND-NODE-SUBSTRUCTURE STR (LENGTH STR) SCOPE-NODE SCOPE-START SCOPE-END)) ((EQ START-NODE SCOPE-NODE) (IL:* IL:|;;| "just check a terminal subtree of the scope") (FIND-NODE-SUBSTRUCTURE STR (LENGTH STR) SCOPE-NODE START-START SCOPE-END)) (T (IL:* IL:|;;| "check each node from the start subtree up and to the right in the scope subtree.  We carefully resume the recursion that would have happened if we had started from the root of the subtree.  This means checking remaining structure in super-nodes on our way from the start node back up the subtree.") (DO ((NODE START-NODE SUPER-NODE) (SUPER-NODE (IL:FETCH SUPER-NODE IL:OF START-NODE) (IL:FETCH SUPER-NODE IL:OF NODE)) (NODE-INDEX (IL:FETCH SUB-NODE-INDEX IL:OF START-NODE) (IL:FETCH SUB-NODE-INDEX IL:OF NODE)) (CONTINUATION? NIL T) (START START-START NODE-INDEX) (END NIL (AND (EQ NODE SCOPE-NODE) SCOPE-END)) (STRLEN (LENGTH STR)) MATCH) ((OR (NULL NODE) (SETF MATCH (FIND-NODE-SUBSTRUCTURE STR STRLEN NODE START END CONTINUATION?)) (EQ NODE SCOPE-NODE)) MATCH)))))))
+
+(DEFUN FIND-SUBSTRUCTURE-BACKWARDS (STR SCOPE &OPTIONAL END) (IL:* IL:|;;;| "Like find-substructure but searches in reverse linearization order.") (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END) (DECOMPOSE-PSEUDO-SELECTION SCOPE) (MULTIPLE-VALUE-BIND (END-NODE END-START END-END) (DECOMPOSE-PSEUDO-SELECTION END) (COND ((NULL END-NODE) (IL:* IL:|;;| "just check the entire scope") (FIND-NODE-SUBSTRUCTURE-BACKWARDS STR (LENGTH STR) SCOPE-NODE SCOPE-START SCOPE-END)) ((EQ END-NODE SCOPE-NODE) (IL:* IL:|;;| "just check an initial subtree of the scope") (FIND-NODE-SUBSTRUCTURE-BACKWARDS STR (LENGTH STR) SCOPE-NODE SCOPE-START END-END)) (T (IL:* IL:|;;| "check each node in the initial subtree of scope terminated by the end subtree.  We carefully resume the recursion that would have happened if we had started from the root of the scope subtree.  This means checking remaining structure in super-nodes on our way from the end node back up the subtree.") (DO ((NODE END-NODE SUPER-NODE) (SUPER-NODE (IL:FETCH SUPER-NODE IL:OF END-NODE) (IL:FETCH SUPER-NODE IL:OF NODE)) (NODE-INDEX (IL:FETCH SUB-NODE-INDEX IL:OF END-NODE) (IL:FETCH SUB-NODE-INDEX IL:OF NODE)) (CONTINUATION? NIL T) (END END-END NODE-INDEX) (START NIL (AND (EQ NODE SCOPE-NODE) SCOPE-START)) (STRLEN (LENGTH STR)) MATCH) ((OR (NULL NODE) (SETF MATCH (FIND-NODE-SUBSTRUCTURE-BACKWARDS STR STRLEN NODE START END CONTINUATION?)) (EQ NODE SCOPE-NODE)) MATCH)))))))
+
+(DEFUN GET-USER-STRING (CONTEXT PROMPT DEFAULT) (LET ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))) (IL:TERPRI PROMPTWINDOW) (IL:TTYINPROMPTFORWORD PROMPT DEFAULT NIL PROMPTWINDOW NIL NIL (IL:CHARCODE (IL:CR ^X)))))
+
+(DEFUN SEARCH-OBJ (CONTEXT &OPTIONAL SEARCH-STRING WRAP?) (IL:* IL:|;;;| "Search for the the structure(s) in the string SEARCH-OBJ and display them.  The search starts just after the current point  or selection, if any.") (MULTIPLE-VALUE-BIND (STR STRLEN) (STRUCTURE-FROM-STRING (OR SEARCH-STRING (SETF SEARCH-STRING (GET-USER-STRING CONTEXT "Find: " (OR (IL:|fetch| FIND-CANDIDATE IL:|of| CONTEXT) FIND-CANDIDATE))))) (COND ((< STRLEN 0) (FORMAT (GET-PROMPT-WINDOW CONTEXT) " -- Invalid structure.") (RETURN-FROM SEARCH-OBJ)) ((= STRLEN 0) (FORMAT (GET-PROMPT-WINDOW CONTEXT) "-- aborted.") (RETURN-FROM SEARCH-OBJ))) (IL:* IL:|;;| "update the remembered defaults") (IL:|replace| FIND-CANDIDATE IL:|of| CONTEXT IL:|with| (IL:SETQ FIND-CANDIDATE SEARCH-STRING)) (IL:* IL:|;;| "figure out where to search and where to start") (LET* ((SCOPE (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT))) (START (LET* ((POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) (POINT-TYPE (IL:|fetch| POINT-TYPE IL:|of| POINT)) (POINT-NODE (IL:|fetch| POINT-NODE IL:|of| POINT)) (POINT-INDEX (IL:|fetch| POINT-INDEX IL:|of| POINT)) (SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (SELECT-TYPE (IL:FETCH SELECT-TYPE IL:OF SELECTION)) (SELECT-NODE (IL:|fetch| SELECT-NODE IL:|of| SELECTION)) (SELECT-START (IL:|fetch| SELECT-START IL:|of| SELECTION))) (COND ((TYPEP POINT-NODE (QUOTE EDIT-NODE)) (IF (EQ POINT-TYPE (QUOTE STRUCTURE)) (NEXT-NODE POINT-NODE POINT-INDEX) (NEXT-NODE POINT-NODE T))) ((TYPEP SELECT-NODE (QUOTE EDIT-NODE)) (IF (AND (EQ SELECT-TYPE (QUOTE STRUCTURE)) SELECT-START) (LIST SELECT-NODE (1+ SELECT-START)) (NEXT-NODE SELECT-NODE T))) (T SCOPE))))) (UNLESS (OR WRAP? START) (IL:* IL:|;;| "Nothing left to search, and we're not supposed to wrap") (FORMAT (GET-PROMPT-WINDOW CONTEXT) "~%At end; no more structure to search.") (RETURN-FROM SEARCH-OBJ)) (IL:* IL:|;;| "do the search") (IF (> STRLEN 1) (IL:* IL:|;;| "substructure search") (FIND-AND-DISPLAY-SUBSTRUCTURE CONTEXT STR SCOPE START WRAP?) (IL:* IL:|;;| "structure search") (FIND-AND-DISPLAY-STRUCTURE CONTEXT (FIRST STR) SCOPE START WRAP?)))))
+
+(DEFUN SEARCH-OBJ-BACKWARDS (CONTEXT &OPTIONAL SEARCH-STRING WRAP?) (IL:* IL:|;;;| "Like search-obj but searches backwards.") (MULTIPLE-VALUE-BIND (STR STRLEN) (STRUCTURE-FROM-STRING (OR SEARCH-STRING (SETF SEARCH-STRING (GET-USER-STRING CONTEXT "Find: " (OR (IL:|fetch| FIND-CANDIDATE IL:|of| CONTEXT) FIND-CANDIDATE))))) (COND ((< STRLEN 0) (FORMAT (GET-PROMPT-WINDOW CONTEXT) " -- Invalid structure.") (RETURN-FROM SEARCH-OBJ-BACKWARDS)) ((= STRLEN 0) (FORMAT (GET-PROMPT-WINDOW CONTEXT) "-- aborted.") (RETURN-FROM SEARCH-OBJ-BACKWARDS))) (IL:* IL:|;;| "update the remembered defaults") (IL:|replace| FIND-CANDIDATE IL:|of| CONTEXT IL:|with| (IL:SETQ FIND-CANDIDATE SEARCH-STRING)) (IL:* IL:|;;| "figure out where to search and where to start") (LET* ((SCOPE (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT))) (END (LET* ((POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) (POINT-TYPE (IL:|fetch| POINT-TYPE IL:|of| POINT)) (POINT-NODE (IL:|fetch| POINT-NODE IL:|of| POINT)) (POINT-INDEX (IL:|fetch| POINT-INDEX IL:|of| POINT)) (SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (SELECT-TYPE (IL:FETCH SELECT-TYPE IL:OF SELECTION)) (SELECT-NODE (IL:|fetch| SELECT-NODE IL:|of| SELECTION)) (SELECT-END (OR (IL:|fetch| SELECT-END IL:|of| SELECTION) (IL:|fetch| SELECT-START IL:|of| SELECTION)))) (COND ((TYPEP POINT-NODE (QUOTE EDIT-NODE)) (IF (EQ POINT-TYPE (QUOTE STRUCTURE)) (PREV-NODE POINT-NODE (1+ POINT-INDEX)) (PREV-NODE POINT-NODE T))) ((TYPEP SELECT-NODE (QUOTE EDIT-NODE)) (IF (EQ SELECT-TYPE (QUOTE STRUCTURE)) (LIST SELECT-NODE (1- SELECT-END)) (PREV-NODE SELECT-NODE T))) (T SCOPE))))) (UNLESS (OR WRAP? END) (IL:* IL:|;;| "Nothing left to search, and we're not supposed to wrap") (FORMAT (GET-PROMPT-WINDOW CONTEXT) "~%At beginning; no more structure to search.") (RETURN-FROM SEARCH-OBJ-BACKWARDS)) (IL:* IL:|;;| "do the search") (IF (> STRLEN 1) (IL:* IL:|;;| "substructure search") (FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS CONTEXT STR SCOPE END WRAP?) (IL:* IL:|;;| "structure search") (FIND-AND-DISPLAY-STRUCTURE-BACKWARDS CONTEXT (FIRST STR) SCOPE END WRAP?)))))
+
+(DEFUN SUBSTITUTE-OBJ (CONTEXT &OPTIONAL CHARCODE OLDSTR NEWSTR REMOVE?) (IL:* IL:|;;;| "OLDSTR and NEWSTR are strings.  In the scope of the selection, replace every occurence of structure matching OLDSTR by structure parsed from NEWSTR.  If REMOVE? is specified, just remove structure matching OLD.") (IL:* IL:|;;;| "We preserve the selection as best we can.  Point gets thrown away.") (CLOSE-OPEN-NODE CONTEXT) (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) (SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (SCOPE NIL) (TYPE (IF REMOVE? "delet" "substitut"))) (IL:* IL:\; "hack!!!") (UNLESS (AND (IL:|fetch| SELECT-NODE IL:|of| SELECTION) (EQ (IL:|fetch| SELECT-TYPE IL:|of| SELECTION) (QUOTE STRUCTURE))) (FORMAT PROMPTWINDOW "~%Please select a structure to ~Ae within." TYPE) (RETURN-FROM SUBSTITUTE-OBJ T)) (SETQ SCOPE (PSEUDO-SELECTION-FROM-SELECTION SELECTION)) (MULTIPLE-VALUE-BIND (OLD OLDLEN) (STRUCTURE-FROM-STRING (OR OLDSTR (SETF OLDSTR (GET-USER-STRING CONTEXT (IF REMOVE? "Delete form: " "Replace old form: ") (OR (IL:|fetch| FIND-CANDIDATE IL:|of| CONTEXT) FIND-CANDIDATE))))) (COND ((< OLDLEN 0) (FORMAT PROMPTWINDOW " -- Invalid structure.") (RETURN-FROM SUBSTITUTE-OBJ T)) ((= OLDLEN 0) (FORMAT PROMPTWINDOW "-- aborted.") (RETURN-FROM SUBSTITUTE-OBJ T))) (MULTIPLE-VALUE-BIND (NEW NEWLEN) (IF REMOVE? (VALUES NIL 0) (STRUCTURE-FROM-STRING (OR NEWSTR (SETF NEWSTR (GET-USER-STRING CONTEXT "with new form: " (OR (IL:|fetch| SUBSTITUTE-CANDIDATE IL:|of| CONTEXT) SUBSTITUTE-CANDIDATE)))))) (COND ((< NEWLEN 0) (FORMAT PROMPTWINDOW " -- Invalid structure.") (RETURN-FROM SUBSTITUTE-OBJ T)) ((AND (NOT REMOVE?) (= NEWLEN 0)) (FORMAT PROMPTWINDOW "-- aborted.") (RETURN-FROM SUBSTITUTE-OBJ T))) (IL:* IL:|;;| "update defaults ") (IL:|replace| FIND-CANDIDATE IL:|of| CONTEXT IL:|with| (IL:SETQ FIND-CANDIDATE OLDSTR)) (UNLESS REMOVE? (IL:|replace| SUBSTITUTE-CANDIDATE IL:|of| CONTEXT IL:|with| (IL:SETQ SUBSTITUTE-CANDIDATE NEWSTR))) (IL:* IL:|;;| "do the substitution, report, and reselect.") (MULTIPLE-VALUE-BIND (NEW-SCOPE SUBCOUNT) (IF (> OLDLEN 1) (SUBSTITUTE-SUBSTRUCTURE CONTEXT OLD NEW SCOPE REMOVE?) (SUBSTITUTE-STRUCTURE CONTEXT (FIRST OLD) NEW SCOPE REMOVE?)) (CASE SUBCOUNT (0 (FORMAT PROMPTWINDOW "~%No ~Aions made." TYPE)) (1 (FORMAT PROMPTWINDOW "~%1 ~Aion made." TYPE)) (OTHERWISE (FORMAT PROMPTWINDOW "~%~A ~Aions made." SUBCOUNT TYPE))) (WHEN NEW-SCOPE (SELECT-PSEUDO-SEGMENT CONTEXT NEW-SCOPE)))))) T)
+
+(DEFUN SUBSTITUTE-STRUCTURE (CONTEXT OLD NEW SCOPE &OPTIONAL REMOVE?) (IL:* IL:|;;;| "Inside SCOPE, replace any node with structure OLD by nodes gotten from parsing NEW.  If REMOVE? is given, just delete the old nodes.  Returns two values: the final scope after all substitutions are made, and the number of substitutions/deletions made.") (IL:* IL:|;;;| "The substitution is done as a single undoable operation, and the current selection and point are thrown away.") (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END) (DECOMPOSE-PSEUDO-SELECTION SCOPE) (LET* ((ROOT (IL:FETCH ROOT IL:OF CONTEXT)) (IL:* IL:\; "substituting for root is special") (POINT (IL:FETCH CARET-POINT IL:OF CONTEXT)) (SELECTION (IL:FETCH SELECTION IL:OF CONTEXT)) (NEWLEN (IF REMOVE? 0 (LENGTH NEW))) (DELTA-LENGTH (- NEWLEN 1))) (START-UNDO-BLOCK) (DO* ((TARGET (FIND-STRUCTURE OLD SCOPE) (AND RESUME (FIND-STRUCTURE OLD SCOPE RESUME))) (TARGET-SUPER (AND TARGET (IL:FETCH SUPER-NODE IL:OF TARGET)) (AND TARGET (IL:FETCH SUPER-NODE IL:OF TARGET))) (TARGET-INDEX (AND TARGET (IL:FETCH SUB-NODE-INDEX IL:OF TARGET)) (AND TARGET (IL:FETCH SUB-NODE-INDEX IL:OF TARGET))) (RESUME (AND TARGET (NEXT-NODE TARGET T)) (AND TARGET (NEXT-NODE TARGET T))) (NEW-NODES (AND TARGET (NOT REMOVE?) (MAPCAR (FUNCTION (LAMBDA (S) (PARSE-NEW S CONTEXT))) NEW)) (AND TARGET (NOT REMOVE?) (MAPCAR (FUNCTION (LAMBDA (N) (COPY-NODE N CONTEXT))) NEW-NODES))) (NUMSUBS 0 (1+ NUMSUBS))) ((NULL TARGET) (END-UNDO-BLOCK) (SET-POINT-NOWHERE POINT) (SET-SELECTION-NOWHERE SELECTION) (VALUES SCOPE NUMSUBS)) (IL:* IL:|;;| "replace the target ") (SELECT-NODE CONTEXT TARGET) (COND (REMOVE? (COND ((EQ TARGET-SUPER ROOT) (IL:* IL:|;;| "\"delete\" the root structure by making it nil") (PENDING-DELETE POINT SELECTION) (INSERT-NULL-LIST CONTEXT)) (T (DELETE-SELECTION CONTEXT)))) (T (PENDING-DELETE POINT SELECTION) (INSERT POINT CONTEXT (COPY-LIST NEW-NODES)))) (IL:* IL:|;;| "fix up the scope, if necessary") (COND ((EQ TARGET SCOPE-NODE) (IL:* IL:|;;| "matched the scope, so we're done") (COND (REMOVE? (SETF SCOPE NIL)) ((= NEWLEN 1) (SETF SCOPE (SUBNODE TARGET-INDEX TARGET-SUPER))) (T (IL:* IL:|;;| "replacing the root structure with multiple nodes inserts a new level of list between the root (target-super) and the multiple nodes inserted.  In this case, make the scope node be the new list node instead of the root itself.") (SETF SCOPE (LIST (IF (EQ TARGET-SUPER ROOT) (SUBNODE 1 ROOT) TARGET-SUPER) TARGET-INDEX (+ TARGET-INDEX (1- NEWLEN)))))) (SETF RESUME NIL)) ((AND SCOPE-START (EQ TARGET-SUPER SCOPE-NODE)) (IL:* IL:|;;| "matched a direct subnode of an extended scope") (WHEN (= TARGET-INDEX SCOPE-END) (SETF RESUME NIL)) (SETF (THIRD SCOPE) (INCF SCOPE-END DELTA-LENGTH))))))))
+
+(DEFUN SUBSTITUTE-SUBSTRUCTURE (CONTEXT OLD NEW SCOPE &OPTIONAL REMOVE?) (IL:* IL:|;;;| "Inside SCOPE, replace any sequences of nodes whose structures sequentially match the elements of OLD by nodes gotten from parsing NEW.  If REMOVE? is given, just delete the old sequences.  Returns two values: the final scope after all substitutions are made, and the number of substitutions/deletions made.") (IL:* IL:|;;;| "The substitution is done as a single undoable operation, and the current selection and point are thrown away.") (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END) (DECOMPOSE-PSEUDO-SELECTION SCOPE) (LET* ((POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) (SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (NEWLEN (IF REMOVE? 0 (LENGTH NEW))) (DELTA-LENGTH (- NEWLEN (LENGTH OLD)))) (START-UNDO-BLOCK) (DO* ((TARGET (FIND-SUBSTRUCTURE OLD SCOPE) (AND RESUME (FIND-SUBSTRUCTURE OLD SCOPE RESUME))) (NEW-NODES (AND TARGET (NOT REMOVE?) (MAPCAR (FUNCTION (LAMBDA (S) (PARSE-NEW S CONTEXT))) NEW)) (AND TARGET (NOT REMOVE?) (MAPCAR (FUNCTION (LAMBDA (N) (COPY-NODE N CONTEXT))) NEW-NODES))) (NUMSUBS 0 (1+ NUMSUBS)) RESUME) ((NULL TARGET) (END-UNDO-BLOCK) (SET-POINT-NOWHERE POINT) (SET-SELECTION-NOWHERE SELECTION) (VALUES SCOPE NUMSUBS)) (MULTIPLE-VALUE-BIND (TNODE TSTART TEND) (DECOMPOSE-PSEUDO-SELECTION TARGET) (IL:* IL:|;;| "replace the target ") (SELECT-PSEUDO-SEGMENT CONTEXT TARGET) (COND (REMOVE? (DELETE-SELECTION CONTEXT)) (T (PENDING-DELETE POINT SELECTION) (INSERT POINT CONTEXT (COPY-LIST NEW-NODES)))) (IL:* IL:|;;| "fix up the scope, if necessary, and figure where to resume") (COND ((AND SCOPE-START (EQ TNODE SCOPE-NODE)) (IL:* IL:|;;| "matched direct subnodes of an extended scope") (IF (= TEND SCOPE-END) (SETF RESUME NIL) (SETF RESUME (LIST TNODE (+ TEND 1 DELTA-LENGTH)))) (SETF (THIRD SCOPE) (INCF SCOPE-END DELTA-LENGTH))) (T (SETF RESUME (LIST TNODE (+ TEND 1))))))))))
+
+(DEFUN STRUCTURE-FROM-SELECTION (SELECTION) (IL:* IL:|;;;| "selection must be a structure selection.  Return the structure encompassed by selection, which if the selection is a node is the structure of that node, and if the selection is a segment a list of the structures of the nodes in that segment.") (LET* ((NODE (IL:FETCH SELECT-NODE IL:OF SELECTION)) (START (IL:FETCH SELECT-START IL:OF SELECTION)) (END (OR (IL:FETCH SELECT-END IL:OF SELECTION) START))) (COND (START (LET ((SUBNODES (IL:FETCH SUB-NODES IL:OF NODE))) (WHEN (<= START END (CAR SUBNODES)) (SETF SUBNODES (NTHCDR START SUBNODES)) (DO ((STRUCTURE NIL) (INDEX START (1+ INDEX))) ((> INDEX END) (NREVERSE STRUCTURE)) (PUSH (IL:FETCH STRUCTURE IL:OF (POP SUBNODES)) STRUCTURE))))) (T (IL:FETCH STRUCTURE IL:OF NODE)))))
+
+(DEFUN STRUCTURE-FROM-STRING (STR) (IL:* IL:|;;;| "return all the structures that can be read from string as a list.  return a second value saying how many structures there were.  If an error is encountered, a second value of -1 is returned. ") (COND ((NULL STR) (VALUES NIL 0)) ((STRINGP STR) (WITH-INPUT-FROM-STRING (S STR) (DO ((RESULTS NIL) (EOF (LIST (QUOTE EOF))) (COUNT 0 (1+ COUNT)) VAL) ((NULL (IL:NLSETQ (SETF VAL (READ S NIL EOF)))) (VALUES (NREVERSE RESULTS) -1)) (IF (EQ VAL EOF) (RETURN (VALUES (NREVERSE RESULTS) COUNT)) (PUSH VAL RESULTS))))) (T (VALUES NIL -1))))
+
+(DEFUN COMMENT-OUT-SELECTION (CONTEXT CHARCODE) (IL:* IL:|;;;| "given a sequence of whole structure selections, build a 5 level comment node and replace the nodes with the comment.") (LET* ((SELECTION (IL:FETCH SELECTION IL:OF CONTEXT)) (POINT (IL:FETCH CARET-POINT IL:OF CONTEXT)) (NODE (IL:FETCH SELECT-NODE IL:OF SELECTION)) (START (IL:FETCH SELECT-START IL:OF SELECTION)) (STR (COND ((OR (NULL NODE) (NOT (EQ (IL:FETCH SELECT-TYPE IL:OF SELECTION) (QUOTE STRUCTURE)))) (FORMAT (GET-PROMPT-WINDOW CONTEXT) "~%Select whole structure or structures to comment out.") NIL) (START (WITH-OUTPUT-TO-STRING (S) (IL:BIND BLANK-BEFORE IL:FOR I IL:FROM START IL:TO (OR (IL:FETCH SELECT-END IL:OF SELECTION) START) IL:AS X IL:ON (CDR (IL:NTH (IL:FETCH SUB-NODES IL:OF NODE) START)) IL:DO (IF BLANK-BEFORE (WRITE-CHAR #\Space S) (SETQ BLANK-BEFORE T)) (PRIN1 (IL:FETCH STRUCTURE IL:OF (CAR X)) S)))) (T (FORMAT NIL "~S" (IL:FETCH STRUCTURE IL:OF NODE)))))) (WHEN STR (LET ((NEW-NODE (PARSE-NEW (LIST (QUOTE IL:*) (QUOTE IL:\|) STR) CONTEXT))) (START-UNDO-BLOCK) (DELETE-SELECTION CONTEXT) (INSERT POINT CONTEXT NEW-NODE) (SELECT-NODE CONTEXT NEW-NODE) (IL:REPLACE PENDING-DELETE? IL:OF SELECTION IL:WITH NIL) (END-UNDO-BLOCK)))) T)
+(IL:DEFINEQ
+
+(add-menu
+(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:27 by DCB") (let ((window (il:fetch display-window il:of context)) (promptwindow (get-prompt-window context)) menu) (cond ((il:windowprop window (quote menu)) (il:|printout| promptwindow t "This SEdit already has a menu.")) (t (il:|printout| promptwindow t "Creating menu...") (il:setq menu (get-menu context)) (il:attachwindow menu window nil nil (quote il:localclose)) (il:windowprop menu (quote il:rejectmaincoms) (quote (il:shapew))) (il:windowaddprop window (quote il:reshapefn) (quote il:repositionattachedwindows)) (il:windowprop window (quote menu) menu) (il:terpri promptwindow)))) t)
+)
+
+(backspace
+(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:27 by DCB") (il:* il:|;;;| "implements the backspace key.  if there's a caret, find the appropriate method for the node it's in.  the type methods must take care of any selection as appropriate.  If there's a pending delete selection, consider backspace an undefined operation and punt, unless it's a quoted gap, let quote deal with it.") (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point))) (cond ((il:type? edit-node node) (funcall (il:fetch back-space il:of (il:fetch node-type il:of node)) node context (il:fetch point-index il:of point) (il:fetch point-string il:of point))) (node (let* ((selection node)) (when (and (il:setq node (il:fetch select-node il:of selection)) (eq type-gap (il:fetch node-type il:of node)) (eq type-quote (il:fetch node-type il:of (il:fetch super-node il:of node)))) (backspace-quote (il:fetch super-node il:of node) context t)))))) t)
+)
+
+(CHANGE-PACKAGE
+(IL:LAMBDA (CONTEXT CHARCODE NEW-PACKAGE NEW-PACKAGE-NAME) (IL:* IL:\; "Edited  5-Dec-90 14:19 by woz") (IL:* IL:|;;;| "new.package and new.package.name will be set if coming from the menu.  the menu selectedfn already checked valid package.  otherwise coming from the keyboard, and need to prompt.") (CLOSE-OPEN-NODE CONTEXT) (LET ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) (WINDOW (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT))) (WHEN (NULL NEW-PACKAGE) (IL:TERPRI PROMPTWINDOW) (IL:SETQ NEW-PACKAGE-NAME (IL:U-CASE (IL:TTYINPROMPTFORWORD "New package: " PACKAGE-CANDIDATE NIL PROMPTWINDOW NIL NIL (IL:CHARCODE (IL:CR ^X))))) (IL:* IL:|;;| "if have input then look for package, and if found reset candidate to full package name (user could have typed it abbreviation) of new package.") (IF (IL:STRINGP NEW-PACKAGE-NAME) (IL:SETQ NEW-PACKAGE (FIND-PACKAGE NEW-PACKAGE-NAME))) (IF NEW-PACKAGE (IL:SETQ PACKAGE-CANDIDATE (IL:SETQ NEW-PACKAGE-NAME (PACKAGE-NAME NEW-PACKAGE))))) (COND ((EQ NEW-PACKAGE *PACKAGE*) (FORMAT PROMPTWINDOW "~%Already editing in package ~A." NEW-PACKAGE-NAME)) (NEW-PACKAGE (IL:SETQ *PACKAGE* NEW-PACKAGE) (SAVE-PROFILE (IL:|fetch| PROFILE IL:|of| CONTEXT)) (VERIFY-STRUCTURE CONTEXT NIL NIL NIL T) (WHEN (IL:WINDOWPROP WINDOW (QUOTE MENU)) (IL:FM.CHANGELABEL (QUOTE PACKAGE-NAME-ITEM) NEW-PACKAGE-NAME (IL:WINDOWPROP WINDOW (QUOTE MENU)))) (FORMAT PROMPTWINDOW "~%Now editing in package ~A" NEW-PACKAGE-NAME) (IF (AND (NOT (MEMBER NEW-PACKAGE *POPULAR-PACKAGES*)) (NOT (INTERSECTION *POPULAR-PACKAGES* (PACKAGE-USE-LIST NEW-PACKAGE)))) (FORMAT PROMPTWINDOW " (which uses no popular packages).") (FORMAT PROMPTWINDOW "."))) (NEW-PACKAGE-NAME (IL:|printout| PROMPTWINDOW T "No such package: " NEW-PACKAGE-NAME)) (T (IL:|printout| PROMPTWINDOW "...aborted")))) T)
+)
+
+(CHANGE-PRINTBASE
+  (IL:LAMBDA (CONTEXT CHARCODE NEW-PRINTBASE)       (IL:* IL:\; "Edited  5-Dec-90 14:18 by woz")
+
+(IL:* IL:|;;;| "new.printbase will be set (and valid) if coming from the menu. otherwise, prompt.")
+
+    (CLOSE-OPEN-NODE CONTEXT)
+    (LET ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
+          NEW-PRINTBASE-STRING)
+         (WHEN (NULL NEW-PRINTBASE)
+             (IL:TERPRI PROMPTWINDOW)
+             (IL:SETQ NEW-PRINTBASE-STRING (IL:TTYINPROMPTFORWORD "New print-base: " 
+                                                  PRINTBASE-CANDIDATE NIL PROMPTWINDOW NIL NIL
+                                                  (IL:CHARCODE (IL:CR ^X))))
+             (OR (AND (IL:STRINGP NEW-PRINTBASE-STRING)
+                      (IL:SETQ NEW-PRINTBASE (IL:FIXP (CAR (IL:NLSETQ (IL:READ (IL:OPENSTRINGSTREAM
+                                                                                NEW-PRINTBASE-STRING
+                                                                                'IL:INPUT))))))
+                      (IL:IGREATERP NEW-PRINTBASE 1)
+                      (IL:ILEQ NEW-PRINTBASE 36)
+                      (IL:SETQ PRINTBASE-CANDIDATE NEW-PRINTBASE-STRING))
+                 (IL:SETQ NEW-PRINTBASE NIL)))
+         (COND
+            (NEW-PRINTBASE (IL:SETQ *PRINT-BASE* NEW-PRINTBASE)
+                   (IL:SETQ *PRINT-RADIX* (IL:NEQ *PRINT-BASE* 10))
+                   (SAVE-PROFILE (IL:|fetch| PROFILE IL:|of| CONTEXT))
+                   (VERIFY-STRUCTURE CONTEXT NIL NIL NIL T)
+                   (WHEN (IL:WINDOWPROP (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT)
+                                'MENU)
+                       (LET ((*PRINT-BASE* 10))              (IL:* IL:\; 
+                                                           "make display be in base 10")
+                            (IL:FM.CHANGESTATE 'PRINTBASE-VALUE-ITEM NEW-PRINTBASE
+                                   (IL:WINDOWPROP (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT)
+                                          'MENU)))))
+            (T (IL:|printout| PROMPTWINDOW T "Illegal print-base: " NEW-PRINTBASE-STRING))))
+    T))
+
+(change-quote
+(il:lambda (quote-node context quote-type) (il:* il:\; "Edited  7-Jul-87 09:27 by DCB") (rplaca (il:fetch structure il:of quote-node) (quote-wrapper quote-type)) (il:replace unassigned il:of quote-node il:with (il:listget (il:fetch quote-string il:of (il:fetch environment il:of context)) quote-type)) (note-change quote-node context))
+)
+
+(convert-comment
+(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:27 by DCB") (let* ((promptwindow (get-prompt-window context)) (selection (il:fetch selection il:of context)) (point (il:fetch caret-point il:of context)) (node (il:fetch select-node il:of selection)) (start (il:fetch select-start il:of selection)) (number-of-comments 0) select-end) (cond ((and node (eq (il:fetch select-type il:of selection) (quote structure))) (il:* il:\; "there is a selection to substitute within") (cond (start (il:setq node (subnode start node)) (il:setq select-end (or (il:fetch select-end il:of selection) start))) (t (il:setq select-end (il:fetch sub-node-index il:of node)))) (start-undo-block) (il:bind (next-node il:_ node) (depth il:_ (il:fetch depth il:of node)) new-node il:while (il:setq node (find-comment next-node context depth select-end)) il:do (il:* il:|;;| "move past it so we're not  pointing to a dead node after the substitution") (il:setq next-node (next-node node t)) (when (not (il:fmemb (cadr (il:fetch structure il:of node)) comment-markers)) (il:* il:|;;| "this is an old comment.  convert it") (il:setq new-node (parse-new (convert-comment-structure (il:fetch structure il:of node)) context)) (replace-node context node new-node) (il:add number-of-comments 1)) (il:* il:|;;| "and continue the search")) (end-undo-block) (il:|printout| promptwindow t (if (eq 0 number-of-comments) "No" number-of-comments) (if (eq number-of-comments 1) " comment converted." " comments converted.")) (il:* il:|;;| "finally reset the point ") (when (not (eq 0 number-of-comments)) (set-point-nowhere point) (il:replace pending-delete? il:of selection il:with nil))) (t (il:|printout| promptwindow t "Select structure to convert comments within.")))) t)
+)
+
+(convert-comment-structure
+(il:lambda (expr) (il:* il:\; "Edited 17-Jul-87 09:48 by DCB") (let (2-stars comtail comchar) (cond ((and (il:eqmemb (car expr) il:commentflg) (il:listp (cdr expr)) (not (il:fmemb (cadr expr) (quote (il:e il:declarations\: il:clisp\:)))) (il:listp (il:setq comtail (if (il:setq 2-stars (il:eqmemb (cadr expr) il:commentflg)) (cddr expr) (cdr expr))))) (il:setq comchar (or (car (il:listp il:commentflg)) il:commentflg)) (cond ((and (il:nlistp (cdr comtail)) (il:stringp (car comtail))) (il:* il:\; "already stringified.  now semicolonize") (cond (2-stars (il:push comtail level-3-comment)) ((il:igeq (il:nchars (car comtail)) convert-upgrade) (il:push comtail level-2-comment)) (t (il:push comtail level-1-comment))) (cons comchar comtail)) ((and (il:nlistp (cddr comtail)) (il:stringp (cadr comtail))) (il:* il:\; "could be an edit date") expr) (t (il:* il:|;;| "COMTAIL is where the comment starts, and this is not a funny evaluated comment.") (il:setq comtail (list (il:concatlist (convert-comment-tail comtail (cons))))) (cond (2-stars (il:push comtail level-3-comment)) ((il:igeq (il:nchars (car comtail)) convert-upgrade) (il:push comtail level-2-comment)) (t (il:push comtail level-1-comment))) (cons comchar comtail)))) (t (il:* il:\; "Not convertible") expr))))
+)
+
+(convert-comment-tail
+(il:lambda (tail stream) (il:* il:\; "Edited 17-Jul-87 09:49 by DCB") (il:* il:|;;;| "to remove the dependency on WITH-OUTPUT-TO-STRING, which probably isn't very efficient and isn't available in koto anyway, we instead just accumulate a list of strings, and concatlist them at the end.  STREAM should be a TCONC pointer") (il:while tail il:bind il:x nspaces il:do (il:setq nspaces 1) (cond ((il:nlistp tail) (il:* il:\; "Dotted tail of some super list") (il:tconc stream " . ") (il:setq il:x tail) (il:setq tail nil)) (t (il:setq il:x (car tail)) (il:setq tail (cdr tail)))) (cond ((il:stringp il:x) (il:* il:\; "Turn quote marks into single quotes") (il:lconc stream (list "'" il:x "'"))) ((il:listp il:x) (il:tconc stream "(") (cond ((eq (car il:x) (quote -)) (il:* il:\; "Suppress line break that would occur here:  MAKE IT A BIG DASH") (il:tconc stream (if (cdr il:x) "--- " "---")) (il:pop il:x))) (convert-comment-tail il:x stream) (il:tconc stream ")") (il:selectq (car (il:listp tail)) ((il:\. il:\, il:\; il:?) (il:setq nspaces 0)) nil)) ((eq il:x (quote -)) (il:* il:\; "old style \"force line break\": MAKE IT A BIG DASH") (il:tconc stream "---")) (t (il:tconc stream il:x) (il:selcharq (il:nthcharcode il:x -1) ((il:\. il:\; il:?) (il:setq nspaces 2)) nil))) (cond ((and (il:neq nspaces 0) tail) (il:tconc stream (if (eq nspaces 1) " " "  "))))) (car stream))
+)
+
+(create-command-table
+(il:lambda (description) (il:* il:\; "Edited 13-Jun-88 19:02 by Snow") (il:* il:|;;;| "each entry in the COMMAND-TABLE-SPEC should be of the form: (<fn> <help menu entry> <normalize?> <key>+) where <fn> is an atom function name or a list whose car is the function name and the rest are the extra arguments (beyond context and charcode), <help menu entry> is a list of strings for the name, key-name, and help-string, <normalize?> is T if the caret should be normalized after this command, and <key>+ is one or more key specifier which can be passed to charcode (if non-list) or whose car is a termtable syntax (if a list).") (let ((table (make-hash-table :size 95 :rehash-size 5)) (menu-items nil) (menu-left nil) (menu-right nil) fn entry) (il:|for| command il:|in| description il:|do| (il:* il:|;;| "get fn for this command.  The first thing in COMMAND is either an atom (a simple function name), or a list of the form (<fn-name> <extra-args>*).  Make a \"command form\" for sedit of the form (<fn-name> <normalize?> <extra-args>*)") (setq fn (if (consp (setq entry (first command))) (list* (first entry) (third command) (rest entry)) (list entry (third command)))) (il:* il:|;;| "check for help menu entry:  save left and right columns for tabulating later, and collect the menu items, without the label, but with the selectedfn and the help string.") (when (il:setq entry (second command)) (push (first entry) menu-left) (push (second entry) menu-right) (push (list (il:kwote fn) (third entry)) menu-items)) (il:* il:|;;| "for each of the keys for this command, make a table entry.  if key is a list, use the symbol in it to key on (for syntax and attached menu entries), else treat it as a charcode spec.") (il:|for| key il:|in| (cdddr command) il:|do| (setf (gethash (if (il:listp key) (car key) (charcode key)) table) fn))) (il:* il:|;;| "return list of command table and help menu items") (list table (list menu-items menu-left menu-right))))
+)
+
+(default-edit-fn
+(il:lambda (obj options) (il:* il:\; "Edited  5-Jul-88 15:12 by woz") (ed obj (list* :display :dontwait options)))
+)
+
+(delete-selection
+(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:27 by DCB") (il:* il:|;;| "delete the currently selected nodes, and set the caret point to where they were.  ") (let ((selection (il:fetch selection il:of context))) (and (il:fetch select-node il:of selection) (delete-nodes (il:fetch select-node il:of selection) context (il:fetch select-start il:of selection) (il:fetch select-end il:of selection) (il:fetch caret-point il:of context) (il:fetch select-string il:of selection))) (when (not (and (il:fetch select-node il:of selection) (eq type-gap (il:fetch node-type il:of (il:fetch select-node il:of selection))))) (set-selection-nowhere selection))) t)
+)
+
+(delete-word
+(il:lambda (context) (il:* il:\; "Edited 24-Nov-87 10:02 by DCB") (close-open-node context) (let* ((point (il:fetch caret-point il:of context)) (selection (il:fetch selection il:of context)) (node (il:fetch point-node il:of point)) (end (il:fetch point-index il:of point)) (string (il:fetch point-string il:of point)) start) (il:* il:|;;| "don't do anything if there's no point or a pending delete selection.") (when (and node (or (not (il:fetch select-node il:of selection)) (not (il:fetch pending-delete? il:of selection)))) (il:selectq (il:fetch point-type il:of point) (atom (delete-nodes node context 1 end point string)) (esc-atom (delete-nodes node context 1 end point string)) (string (cond ((eq (il:fetch node-type il:of node) type-comment) (map-comment-index context node end) (cond ((il:igreaterp end 0) (delete-nodes node context (il:idifference (il:add1 end) (il:fetch \\x il:of context)) end point string)) ((null (cdr (il:fetch sub-nodes il:of node))) (delete-nodes node context nil nil point string)))) (t (il:setq start end) (cond ((il:igreaterp start 0) (il:* il:\; "backup over preceding whitespace") (il:while (and (il:neq start 1) (il:fmemb (il:nthcharcode string start) word-delim-chars)) il:do (il:setq start (il:sub1 start))) (il:* il:\; "backup over preceding word") (il:until (or (eq start 0) (il:fmemb (il:nthcharcode string start) word-delim-chars)) il:do (il:setq start (il:sub1 start))) (delete-nodes node context (il:add1 start) end point string)) ((eq 0 (il:nchars string)) (delete-nodes node context nil nil point string)))))) (structure (cond ((il:igreaterp end 0) (delete-nodes node context end nil point string)) ((null (cdr (il:fetch sub-nodes il:of node))) (delete-nodes node context nil nil point string)))) nil) (when (not (and (il:fetch select-node il:of selection) (eq type-gap (il:fetch node-type il:of (il:fetch select-node il:of selection))))) (il:* il:|;;| "cancel the selection unless its pending delete (ctrl-w doesn't do anything) or its a gap, which could have been created by the deletion.") (set-selection-nowhere selection)))) t)
+)
+
+(do-mutation
+(il:lambda (context node mutator) (il:* il:\; "Edited  7-Jul-87 09:27 by DCB") (il:* il:|;;;| "this guy actually applies the mutation and replaces the sedit structure.  should return T if okay, and NIL if error occured durng mutation.") (let ((result (il:nlsetq (funcall mutator (il:fetch structure il:of node))))) (when result (il:* il:|;;| "assume result is not equal to node's Structure.  otherwise, why would mutate have been called?") (replace-node context node (parse-new (car result) context)) (il:* il:\; "return T") t)))
+)
+
+(edit-selection
+(il:lambda (context charcode options) (il:* il:\; "Edited  5-Jul-88 15:53 by woz") (let ((structure (get-selected-structure context))) (cond (structure (cond ((funcall *edit-fn* structure options) (set-selection-nowhere (il:fetch (edit-context selection) il:of context)) (set-point-nowhere (il:fetch (edit-context caret-point) il:of context))))) (t (format (get-prompt-window context) "~%Select name of object to edit.")))) t)
+)
+
+(eval-selection
+(il:lambda (context) (il:* il:\; "Edited 29-Oct-87 15:14 by drc:") (il:* il:|;;;| "evaluate the selected structure in the appropriate process, which should be stored in the EvalInProcess field of the context.  If this field is NIL, then the process went away unexpectedly, so find an exec to eval in.  This is dangerous: FIND.PROCESS 'EXEC IS NOT GUARANTEED!") (let* ((structure (get-selected-structure context)) (structure-copy (copy-tree structure)) (process (il:fetch eval-in-process il:of context)) (promptwindow (get-prompt-window context)) (value (quote il:nobind))) (il:terpri promptwindow) (when (not (il:processp process)) (il:setq process (il:replace eval-in-process il:of context il:with (il:find.process (quote il:mouse))))) (cond ((null structure) (il:|printout| promptwindow t "Invalid selection for evaluation.")) ((il:listp structure) (il:setq value (il:resetform (il:tty.process process) (il:process.eval process (il:bquote (il:ersetq (il:\\\, structure))) t))) (unless (equal structure structure-copy) (il:* il:|;;| "eval (DWIM) changed the structure") (replace-node context (il:fetch select-node il:of (il:fetch selection il:of context)) (parse-new structure context))) (if value (il:setq value (car value)) (il:setq value (quote il:nobind)))) ((il:numberp structure) (il:* il:|;;| "make numbers eval to themselves, since PROCESS.EVALV won't work") (il:setq value structure)) ((il:atom structure) (il:setq value (il:process.evalv process structure)) (when (eq value (quote il:nobind)) (il:|printout| promptwindow t "Unbound atom: " il:|.P2| structure))) (t (il:setq value structure))) (when (il:neq value (quote il:nobind)) (cond ((or (il:atom value) (il:stringp value)) (il:|printout| promptwindow t "Result: " il:|.P2| value)) (t (set-selection-nowhere (il:fetch (edit-context selection) il:of context)) (inspect value))))) t)
+)
+
+(expand
+(il:lambda (context charcode) (il:* il:\; "Edited  7-Jan-88 13:43 by DCB") (il:* il:|;;;| "Replace the current selection with its macro-expansion, if any.") (let* ((promptwindow (get-prompt-window context)) (selection (il:fetch selection il:of context)) (point (il:fetch caret-point il:of context)) (node (il:fetch select-node il:of selection))) (cond ((and node (eq (il:fetch select-type il:of selection) (quote structure)) (null (il:fetch select-start il:of selection))) (let ((structure (il:fetch structure il:of node)) expansion) (when (consp structure) (il:* il:|;;| "we have a whole list structure node selected.  try to expand its definition") (il:|printout| promptwindow t "Looking for expansion...") (il:setq expansion (il:nlsetq (il:editgetd structure))) (cond ((null expansion) (il:|printout| promptwindow t "Error during macro expansion.")) ((not (equal (car expansion) structure)) (il:terpri promptwindow) (replace-node context node (parse-new (car expansion) context))) (t (il:|printout| promptwindow t "No expansion found.")))))) (t (il:|printout| promptwindow t "Can't expand this selection.")))) t)
+)
+
+(extract-current-selection
+(il:lambda (context) (il:* il:\; "Edited 27-Jun-88 15:30 by woz") (close-open-node context) (let* ((promptwindow (get-prompt-window context)) (selection (il:|fetch| selection il:|of| context)) (point (il:|fetch| caret-point il:|of| context)) (node (il:|fetch| select-node il:|of| selection)) subnodes set-selection?) (when (and (null node) (il:setq node (il:|fetch| point-node il:|of| point)) (eq (il:|fetch| point-type il:|of| point) (quote structure))) (il:* il:|;;| "when you've only got a structure point extract from the list pointed within") (set-selection-me selection context node)) (cond ((or (null node) (il:neq (il:|fetch| select-type il:|of| selection) (quote structure)) (il:|fetch| select-start il:|of| selection) (il:|fetch| select-end il:|of| selection)) (il:|printout| promptwindow t "Select structure to extract.")) ((eq 0 (car (il:|fetch| sub-nodes il:|of| node))) (il:* il:\; "nothing to extract") (il:|printout| promptwindow t "Nothing to extract.")) ((eq (il:|fetch| node-type il:|of| node) type-comment) (let ((start 0) (string (third (il:fetch structure il:of node))) structure new-structures) (cond ((il:nlsetq (loop (if (eq :sedit-read-end-flg (multiple-value-setq (structure start) (read-from-string string nil :sedit-read-end-flg :start start))) (return t) (push structure new-structures)))) (setq subnodes (mapcar (function (lambda (s) (parse-new s context))) (nreverse new-structures))) (unless (cdr subnodes) (setq set-selection? (car subnodes))) (pending-delete point selection) (insert point context subnodes)) (t (format promptwindow "~%Unreadable structure in comment.  Can't Extract."))))) (t (il:|replace| point-node il:|of| point il:|with| selection) (il:|replace| point-type il:|of| point il:|with| (quote structure)) (il:setq subnodes (cdr (il:|fetch| sub-nodes il:|of| node))) (unless (cdr subnodes) (setq set-selection? (car subnodes))) (rplacd (il:|fetch| sub-nodes il:|of| node) nil) (start-undo-block) (undo-by undo-extract node subnodes) (il:* il:\; "replace with subnodes") (insert point context (il:copy subnodes)) (end-undo-block))) (when set-selection? (il:* il:|;;| "if only one subnode, leave it selected") (set-selection-me selection context set-selection?) (il:|replace| pending-delete? il:|of| selection il:|with| nil))) (il:* il:|;;| "must return non-NIL if command executed") t)
+)
+
+(find-comment
+(il:lambda (node context min-depth last-subnode) (il:* il:\; "Edited  3-Dec-87 12:54 by DCB") (il:* il:|;;;| "search starting with NODE for a node whose structure begins with a comment char .  move selection and point accordingly. return the node found, else NIL") (when node (il:bind (commentchar il:_ (if (il:listp il:commentflg) (car il:commentflg) il:commentflg)) il:until (or (null node) (il:ilessp (il:fetch depth il:of node) min-depth) (and (eq (il:fetch depth il:of node) min-depth) (il:igreaterp (il:fetch sub-node-index il:of node) last-subnode))) il:do (when (eq commentchar (car (il:fetch structure il:of node))) (return node)) (il:setq node (next-node node)))))
+)
+
+(get-menu
+(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:28 by DCB") (let (menu) (cond ((il:setq menu (il:pop menus)) (il:fm.resetmenu menu)) (t (il:setq menu (il:freemenu menu-description "SEdit Command Menu")) (il:windowaddprop menu (quote il:closefn) (quote menu-closefn)) (il:windowprop menu (quote il:fm.dontreshape) t))) (menu-init-state menu context) menu))
+)
+
+(edit-help
+(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:29 by DCB") (close-open-node context) (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point))) (when (and (il:type? edit-node node) (il:litatom (il:fetch structure il:of node)) (eq (il:fetch point-index point) (il:nchars (il:fetch structure il:of node)))) (il:* il:\; "if at end of this node, change to structure point.") (insert point context nil))) (let* ((fname (selected-fn-name context)) (promptwindow (get-prompt-window context)) args) (if fname (if (il:setq args (il:nlsetq (il:smartarglist fname t))) (cond ((il:ileq (il:stringwidth (il:setq args (cons fname (car args)))) (il:windowprop promptwindow (quote il:width))) (il:* il:\; "will fit in attached window") (il:|printout| promptwindow t args)) (t (il:* il:\; "put in main promptwindow") (il:terpri promptwindow) (il:|printout| il:promptwindow t args))) (il:|printout| promptwindow t "Arguments not available for " fname)) (il:|printout| promptwindow t "Select function you want the arguments for."))) t)
+)
+
+(helpmenu
+(il:lambda (context) (il:* il:\; "Edited 24-May-88 14:20 by woz") (let ((menu (il:fetch help-menu il:of (il:fetch environment il:of context))) (promptwindow (get-prompt-window context)) command) (when (listp menu) (format promptwindow "~%Creating menu, please wait...") (il:* il:|;;| "build the popup menu info.  the lists of menu-items, menu-left strings, and menu-right strings are in the MENU list.  take it apart, then build the menu.  this information was compiled in create-command-table, but the menu gets built when first used (so the font ends up right if the user changed it).") (let* ((font (il:fontcreate il:menufont)) (menu-items (first menu)) (equalized-menu-left (equalize-string-widths (second menu) font)) (menu-right (third menu)) itemwidth items) (il:* il:|;;| "figure out the width of the left column, including the tab, then set the menu width.  Do this by finding the first tab stop after the shortest stringwidth in EQUALIZED-MENU-LEFT.  We know that the widths of each equalized string are within one space width of each other, and since a tab is bigger than a space, we know that this tab stop is the first after all of the strings, allowing tabulation.") (il:* il:|;;| "There is a strange feature of the menu code that starts printing lables at 1 instead of zero, which changes the relative tab stop position.  This shift can cause a tab stop to fall in between the shortest and longest equalized strings.  So we have to see if our chosen tab stop is within one pixel of the longest string, and if so, pad the strings with an extra space to jump them all past that tab stop.") (do* ((left-width (minimum-string-width equalized-menu-left font)) (tab-width (il:stringwidth "        " font)) (tab-column tab-width (+ tab-column tab-width))) ((> tab-column left-width) (il:* il:|;;| "check for the stupid menu case:") (when (= (1- tab-column) (maximum-string-width equalized-menu-left font)) (setq equalized-menu-left (equalize-string-widths equalized-menu-left font nil tab-column)) (incf tab-column tab-width)) (setq itemwidth (+ tab-column (maximum-string-width menu-right font)))) nil) (il:* il:|;;| "construct the menu strings and the menu items.") (do ((left equalized-menu-left (rest left)) (right menu-right (rest right)) (item menu-items (rest item))) ((null item) (setq items (nreverse menu-items))) (push (concatenate (quote string) (first left) (string #\Tab) (first right)) (first item))) (il:replace help-menu il:of (il:fetch environment il:of context) il:with (setq menu (il:create il:menu il:items il:_ items il:itemwidth il:_ itemwidth il:changeoffsetflg il:_ (quote il:y) il:menuoffset il:_ (cons -1 0) il:title il:_ "Commands"))))) (when (setq command (il:menu menu)) (terpri promptwindow) (awake-command-process context command))))
+)
+
+(input-dot
+(il:lambda (context charcode) (il:* il:\; "Edited  7-Jul-87 09:29 by DCB") (il:* il:|;;;| "handle input of a dot.  cases: ") (il:* il:|;;;| "(1) structure selection; might be a quoted gap to be ugraded, otherwise just a node to delete in a list to be dotted.") (il:* il:|;;;| "(2) structure point; in a list to be dotted.") (il:* il:|;;;| "(3) atom point; might be at the beginning of a quote to be ugraded, otherwise just insert the dot.") (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point))) (cond ((il:type? edit-selection node) (let ((selection node)) (il:* il:|;;| "if we're at a structure selection, this is interesting.  otherwise, let the char handler input the dot. ") (when (eq (quote structure) (il:fetch select-type il:of selection)) (cond ((eq type-quote (il:fetch node-type il:of (if (il:fetch select-start il:of selection) (il:fetch select-node il:of selection) (il:fetch super-node il:of (il:fetch select-node il:of selection))))) (il:* il:|;;| "we're in a quote form.  let the quote handler check for a comma-dot") (input-quote context charcode (quote comma-dot)) t) (t (il:* il:|;;| "just at a pending delete selection.  delete it and try to dot the list.") (delete-nodes (il:fetch select-node il:of selection) context (il:fetch select-start il:of selection) (il:fetch select-end il:of selection) point) (dot-this-list context) t))))) ((and node (eq (quote structure) (il:fetch point-type il:of point))) (il:* il:|;;| "normal case of dot input at a structure point in a list") (dot-this-list context) t) ((and node (eq (quote atom) (il:fetch point-type il:of point)) (eq 0 (il:fetch point-index il:of point))) (il:* il:|;;| "at the beginning of an atom.  check if it's a comma quote, otherwise, just input") (let ((super-node (il:fetch super-node il:of node))) (when (and (eq type-quote (il:fetch node-type il:of super-node)) (eq (quote-wrapper (quote il:comma)) (car (il:fetch structure il:of super-node)))) (il:* il:|;;| "we're at the beginning of a COMMA quote atom that wants to be upgraded") (change-quote super-node context (quote comma-dot)) t))))))
+)
+
+(input-escape
+(il:lambda (context) (il:* il:\; "Edited 17-Nov-87 13:35 by DCB") (il:* il:|;;;| "dynamically set this.char.escaped true, so that next time through the loop, it knows it's getting an escaped char") (il:setq this-char-escaped t))
+)
+
+(input-normal-char
+(il:lambda (context char) (il:* il:\; "Edited  7-Jul-87 09:29 by DCB") (cond ((and (il:igreaterp char 255) (il:ilessp char 512)) (il:* il:|;;| "this is a meta-character that wasn't recognized as a command.  don't insert it!") (il:|printout| (get-prompt-window context) t "Unknown command: Meta-" (il:character (il:idifference char 256)))) (t (let ((point (il:fetch (edit-context caret-point) il:of context)) (point-type (type-of-input context))) (il:setq char (il:character char)) (when (il:neq point-type (quote string)) (cond (this-char-escaped (il:* il:|;;| "prepend an escape character") (il:* il:\; "read table specific") (il:setq char (il:concat (il:character (escape-char)) char))) ((and (il:fetch (readtablep il:caseinsensitive) il:of *readtable*) (il:neq point-type (quote esc-atom))) (il:setq char (if (or (eq point-type (quote structure)) (eq *print-case* (quote :upcase))) (il:u-case char) (il:l-case char)))))) (il:selectq point-type (structure (il:* il:|;;| "first mark that we're starting an atom, because the reparser needs to know when inserting in a lambda arglist slot whether or not to reparse it as a list.  THIS IS UGLY, but it works.") (il:replace atom-started il:of context il:with t) (insert point context char) (il:replace atom-started il:of context il:with (il:fetch point-node il:of point)) (il:replace atom-started-undo-pointer il:of context il:with (il:fetch undo-list il:of context))) ((atom esc-atom) (let ((node (il:fetch point-node il:of point)) il:where) (cond ((il:type? edit-node node) (il:setq il:where point)) (t (il:* il:|;;| "the pending-delete case.  the PointNode actually points to a selection framing the material to be replaced") (il:setq node (il:fetch select-node il:of (il:setq il:where node))))) (insert-string node context il:where char point) (set-selection-nowhere (il:fetch selection il:of context)))) (string (insert point context char)) (nil) (il:shouldnt "bad point type"))))) (set-selection-nowhere (il:fetch (edit-context selection) il:of context)))
+)
+
+(input-quote
+(il:lambda (context charcode quote-type) (il:* il:\; "Edited 19-Nov-87 15:28 by DCB") (il:selectq (type-of-input context) (structure (close-open-node context) (cond ((il:fmemb quote-type (quote (comma-at comma-dot))) (il:* il:|;;| "check if we're in a COMMA quote to be upgraded") (let* ((selection (il:fetch selection il:of context)) (node (il:fetch select-node il:of selection)) (super-node)) (when (and node (il:setq super-node (il:fetch super-node il:of node)) (eq type-gap (il:fetch node-type il:of node)) (eq type-quote (il:fetch node-type il:of super-node)) (eq (quote-wrapper (quote il:comma)) (car (il:fetch structure il:of super-node)))) (il:* il:|;;| "we're in the middle of typing in a COMMA quote form that wants to be upgraded") (change-quote super-node context quote-type) t))) (t (insert-quoted-gap context charcode quote-type) t))) (atom (il:* il:|;;| "check if we're at the beginning of an atom to quote.  otherwise, let the quote be inserted normally") (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point)) (super-node (and (il:type? edit-node node) (il:fetch super-node il:of node)))) (cond ((and super-node (eq 0 (il:fetch point-index point))) (cond ((eq quote-type (quote comma-at)) (il:* il:|;;| "this is tricky.  we got an @ at the beginning of an atom.  if it's in a COMMA quote, then upgrade, otherwise insert the @ as part of the atom.") (when (and (eq type-quote (il:fetch node-type il:of super-node)) (eq (quote-wrapper (quote il:comma)) (car (il:fetch structure il:of super-node)))) (change-quote super-node context (quote comma-at)) t)) (t (set-selection-me (il:fetch selection il:of context) context node) (quote-current-selection context charcode quote-type) (set-selection-nowhere (il:fetch selection il:of context)) (set-point point context node) t))) ((and super-node (eq quote-type (quote quote)) (eq 1 (il:fetch point-index point)) (eq (il:charcode \#) (il:chcon1 (il:fetch point-string il:of point)))) (il:* il:|;;| "this is tricky.  We are adding the ' part of #', so we want to function wrap the rest of this string (or gap it if it's empty).") (cond ((eq 1 (il:nchars (il:fetch point-string il:of point))) (il:* il:|;;| "close the node, get rid of it, and replace it with a quoted gap.  Oh yeah, do this undoably by just closing and calling an undoable thing,") (close-open-node context) (set-selection-me (il:fetch selection il:of context) context node) (pending-delete point (il:fetch selection il:of context)) (insert-quoted-gap context nil (quote function)) t) (t (il:* il:|;;| "remove the #, close the node, wrap it with function, and put point at the first character.  Oh yeah, do this undoably.") (start-undo-block) (replace-string node context 1 1 "" point (il:fetch point-string il:of point) (quote atom)) (set-selection-me (il:fetch selection il:of context) context node) (quote-current-selection context nil (quote function)) (set-selection-nowhere (il:fetch selection il:of context)) (set-point point context node nil nil nil (quote atom)) (end-undo-block) t)))))) nil))
+)
+
+(input-square-bracket
+(il:lambda (context charcode) (il:* il:\; "Edited  7-Jul-87 09:29 by DCB") (when (il:neq (type-of-input context) (quote string)) (let ((promptwindow (get-prompt-window context))) (il:|printout| promptwindow t "SEdit can't handle square brackets.  Ignoring rest of input.") (il:flashwindow promptwindow) (il:clearbuf t) t)))
+)
+
+(input-stringdelim
+(il:lambda (context) (il:* il:\; "Edited 17-Nov-87 13:35 by DCB") (cond ((eq (type-of-input context) (quote string)) (il:* il:|;;| "split or close this string") (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point))) (when (il:type? edit-selection node) (il:setq node (il:fetch select-node il:of node))) (when (eq (il:fetch node-type il:of node) type-string) (insert point context nil) (set-selection-nowhere (il:fetch (edit-context selection) il:of context)) t))) (t (il:* il:|;;| "insert a new string") (let ((new-string (il:allocstring 0)) (point (il:fetch (edit-context caret-point) il:of context))) (il:setq new-string (create-simple-node new-string (il:fetch environment il:of context) type-string new-string t (il:fetch default-font il:of (il:fetch environment il:of context)))) (insert point context new-string) (when (not (dead-node? new-string)) (il:replace point-node il:of point il:with new-string) (il:replace point-index il:of point il:with 0) (il:replace point-type il:of point il:with (quote string)) (il:replace point-string il:of point il:with (il:fetch structure il:of new-string)) (set-selection-nowhere (il:fetch (edit-context selection) il:of context)) (il:replace atom-started il:of context il:with new-string) (il:replace atom-started-undo-pointer il:of context il:with (il:fetch undo-list il:of context)))) t)))
+)
+
+(input-tokendelim
+(il:lambda (context charcode) (il:* il:\; "Edited  7-Jul-87 09:29 by DCB") (let ((point (il:fetch caret-point il:of context))) (il:selectq (type-of-input context) (atom (insert point context nil) (set-selection-nowhere (il:fetch (edit-context selection) il:of context))) (structure (when (not (il:fetch pending-delete? il:of (il:fetch selection il:of context))) (il:* il:|;;| "this test so that delims don't do anything on pending delete gaps in particular, to avoid <dot> <space> or <quote> <space> wasting the gap.  i don't think it will hurt the other cases.") (insert point context nil) (set-selection-nowhere (il:fetch (edit-context selection) il:of context)))) ((string esc-atom) (if (and (eq charcode (il:charcode il:cr)) (eq-point-type point type-comment)) (insert point context nil) (insert point context (il:character charcode))) (set-selection-nowhere (il:fetch (edit-context selection) il:of context))) (nil) (il:shouldnt "bad point type"))) t)
+)
+
+(insert-multi-escape
+(il:lambda (context char) (il:* il:\; "Edited  7-Jul-87 09:29 by DCB") (let ((point (il:fetch caret-point il:of context)) (type (type-of-input context)) node il:where) (cond ((eq type (quote structure)) (insert point context (il:allocstring 2 char)) (il:replace point-index il:of point il:with 1) (il:replace point-type il:of point il:with (quote esc-atom))) ((or (eq type (quote atom)) (eq type (quote esc-atom))) (if (il:type? edit-node (il:setq node (il:fetch point-node il:of point))) (if (and (eq type (quote esc-atom)) (eq (il:nthcharcode (il:fetch point-string il:of point) (il:add1 (il:fetch point-index il:of point))) char)) (il:add (il:fetch point-index il:of point) 1) (il:setq il:where point)) (il:setq node (il:fetch select-node il:of (il:setq il:where node)))) (when il:where (insert-string node context il:where (il:allocstring 2 char) point) (il:add (il:fetch point-index il:of point) -1)) (il:replace point-type il:of point il:with (if (eq (il:fetch point-type il:of point) (quote atom)) (quote esc-atom) (quote atom))) (set-selection-nowhere (il:fetch selection il:of context)) t))))
+)
+
+(insert-special-character
+(il:lambda (context char) (il:* il:\; "Edited  7-Jul-87 09:29 by DCB") (il:* il:|;;;| "insert a special character (e.g.  the package delimiter) without escaping it") (let ((point (il:fetch caret-point il:of context)) (string (il:allocstring 1 char))) (il:selectq (type-of-input context) (atom (let ((node (il:fetch point-node il:of point)) il:where) (cond ((il:type? edit-node node) (il:setq il:where point)) (t (il:* il:|;;| "the pending-delete case.  the PointNode actually points to a selection framing the material to be replaced") (il:setq node (il:fetch select-node il:of (il:setq il:where node))))) (insert-string node context il:where string point) (set-selection-nowhere (il:fetch selection il:of context)) t)) (structure (il:* il:|;;| "LET ((new.node (fetch PointNode of point))) (replace AtomStarted of context with new.node) (replace AtomStartedUndoPointer of context with (fetch UndoList of context)) (open.litatom context new.node string) (replace OpenNodeChanged?  of context with T) (adjust.width new.node context (STRINGWIDTH string) (fetch Font of (CAR (fetch LinearForm of new.node)))) (replace PointIndex of point with 1) (replace PointString of point with string) T") (insert point context string) t) nil)))
+)
+
+(inspect-selection
+(il:lambda (context) (il:* il:\; "Edited 17-Nov-87 13:36 by DCB") (let ((structure (get-selected-structure context))) (cond (structure (set-selection-nowhere (il:fetch (edit-context selection) il:of context)) (set-point-nowhere (il:fetch (edit-context caret-point) il:of context)) (il:* il:|;;| "update context") (when (null (il:nlsetq (inspect structure))) (il:|printout| (get-prompt-window context) t "Inspection aborted."))) (t (il:|printout| (get-prompt-window context) t "Select object to inspect.")))) t)
+)
+
+(join
+(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:36 by DCB") (let* ((promptwindow (get-prompt-window context)) (selection (il:fetch selection il:of context)) (point (il:fetch caret-point il:of context)) (node (il:fetch select-node il:of selection)) (start (il:fetch select-start il:of selection)) (end (il:fetch select-end il:of selection)) (comment-level 1) subnodes type new-structure new-node) (close-open-node context) (cond ((not (and node start end (il:neq start end) (eq (il:fetch select-type il:of selection) (quote structure)))) (il:|printout| promptwindow t "Select items to join.")) ((and (il:setq type (il:fetch name il:of (il:fetch node-type il:of (subnode start node)))) (il:fmemb type (il:constant (quote (quote unknown gap root dotlist))))) (il:|printout| promptwindow t "Can't join things of this type.")) (t (il:setq subnodes (il:fetch sub-nodes il:of node)) (pending-delete point selection) (start-undo-block) (il:selectq type ((litatom string) (il:* il:|;;| "for these types, each node must be of the same SEdit type") (il:setq new-structure (il:for index il:from start il:to end il:as subnode il:in (il:nth (cdr subnodes) start) il:collect (when (not (il:fmemb (il:fetch name il:of (il:fetch node-type il:of subnode)) (il:constant (quote (litatom string))))) (il:|printout| promptwindow t "Each item to join must be of the same type.") (return)) (il:fetch structure il:of subnode))) (when new-structure (cond ((il:numberp (car new-structure)) (il:|printout| promptwindow t "Can't join numbers.")) (t (il:setq new-node (parse-new (if (eq type (quote litatom)) (intern (il:concatlist new-structure) (symbol-package (car new-structure))) (il:concatlist new-structure)) context)) (insert point context new-node))))) (comment (il:* il:|;;| "for comments, each node must be of the same SEdit type") (il:setq new-structure (il:for index il:from start il:to end il:as subnode il:in (il:nth (cdr subnodes) start) il:join (when (il:neq (il:fetch name il:of (il:fetch node-type il:of subnode)) (quote comment)) (il:|printout| promptwindow t "Each item to join must be of the same type.") (return)) (il:setq comment-level (il:imax comment-level (il:fetch unassigned il:of subnode))) (cond ((eq index end) (cddr (il:fetch structure il:of subnode))) (t (il:* il:|;;| "add space between comments") (list (caddr (il:fetch structure il:of subnode)) "  "))))) (when new-structure (il:setq new-structure (list (quote il:*) (car (il:nth comment-markers comment-level)) (il:apply* (quote il:concatlist) new-structure))) (il:setq new-node (parse-new new-structure context)) (insert point context new-node))) (progn (il:* il:|;;| "for the rest, the structures must all be listp's") (cond ((il:for index il:from start il:to end il:as subnode il:in (il:nth (cdr subnodes) start) il:thereis (not (il:listp (il:fetch structure il:of subnode)))) (il:|printout| promptwindow t "Each item to join must be of the same type.")) (t (il:setq new-node (subnode start node)) (set-point point context new-node (car (il:fetch sub-nodes il:of new-node)) t (car (last (il:fetch sub-nodes il:of new-node))) (quote structure)) (il:for index il:from (il:add1 start) il:to end il:as subnode il:in (il:nth (cdr subnodes) (il:add1 start)) il:do (il:setq new-structure (cdr (il:fetch sub-nodes il:of subnode))) (delete-nodes subnode context 1 (car (il:fetch sub-nodes il:of subnode))) (insert point context new-structure)) (delete-nodes node context (il:add1 start) end))))) (when new-node (set-selection-me selection context new-node) (il:replace pending-delete? il:of selection il:with nil) (set-point point context new-node nil t nil (quote structure))) (end-undo-block)))) t)
+)
+
+(menu-closefn
+(il:lambda (w) (il:* il:\; "Edited  7-Jul-87 09:36 by DCB") (il:* il:|;;;| "must be called before menu is detached from sedit.") (il:push menus w) (il:windowprop (il:mainwindow w) (quote menu) nil))
+)
+
+(menu-find-selectedfn
+(il:lambda (item window buttons) (il:* il:\; "Edited 17-Jul-87 10:12 by DCB") (let ((find-item (il:listget (il:fm.itemprop item (quote il:links)) (quote il:edit))) (context (il:windowprop (il:mainwindow window) (quote edit-context)))) (cond ((or (il:equal (il:fm.itemprop find-item (quote il:label)) "") (eq (car buttons) (quote il:right))) (il:* il:|;;| "need new stuff to find") (il:fm.edititem find-item window t)) (t (il:* il:|;;| "call find with an extra argument of the stuff to find") (menu-selectedfn item window buttons (quote find) (list (il:fm.itemprop find-item (quote il:label)))) (il:tty.process (il:windowprop (il:mainwindow window) (quote il:process)))))))
+)
+
+(menu-init-state
+(il:lambda (menu context) (il:* il:\; "Edited  7-Jul-87 09:38 by DCB") (il:* il:|;;;| "initialize menu profile entries.  will be called by either under command loop, or under building new window, either case under sedit's profile, so references to *print* variables are okay.") (let* ((package-name (package-name *package*)) (print-base *print-base*) (*print-base* 10)) (il:* il:|;;| "want to display *PRINT-BASE* in print base 10, so must cache and rebind it.") (il:fm.changestate (quote printbase-value-item) print-base menu) (il:fm.itemprop (il:fm.getitem (quote printbase-item) nil menu) (quote printbase) print-base) (il:fm.changelabel (quote package-name-item) package-name menu) (il:fm.itemprop (il:fm.getitem (quote package-item) nil menu) (quote package-name) package-name)))
+)
+
+(menu-package-selectedfn
+(il:lambda (item window buttons) (il:* il:\; "Edited 17-Jul-87 10:13 by DCB") (il:* il:|;;;| "check if the new package name is valid and if so initiate the package change by waking up the comand process to handle the command.  otherwise error and reset the package name in the menu to the name of the current package, which is cached on this item.") (let* ((package-name-item (il:listget (il:fm.itemprop item (quote il:links)) (quote il:edit))) (package-name (il:fm.itemprop package-name-item (quote il:label))) package) (cond ((or (il:equal package-name "") (eq (car buttons) (quote il:right))) (il:fm.edititem package-name-item window t)) ((il:setq package (find-package package-name)) (il:fm.itemprop item (quote package-name) package-name) (menu-selectedfn item window buttons (quote set-package) (list package package-name))) (t (il:|printout| (il:getpromptwindow (il:mainwindow window)) t "No such package: " package-name) (il:fm.changelabel package-name-item (il:fm.itemprop item (quote package-name)) window)))))
+)
+
+(menu-printbase-selectedfn
+(il:lambda (item window buttons) (il:* il:\; "Edited 17-Jul-87 10:13 by DCB") (il:* il:|;;;| "make sure there is a valid printbase value, and if so, change sedits printbase to it.") (let* ((printbase-value-item (il:listget (il:fm.itemprop item (quote il:links)) (quote il:edit))) (print-base (il:fm.itemprop printbase-value-item (quote il:state)))) (cond ((or (null print-base) (eq (car buttons) (quote il:right))) (il:fm.edititem printbase-value-item window t)) ((and (il:igreaterp print-base 1) (il:ileq print-base 36)) (il:fm.itemprop item (quote printbase) print-base) (menu-selectedfn item window buttons (quote set-print-base) (list print-base))) (t (il:|printout| (il:getpromptwindow (il:mainwindow window)) t "Illegal print-base: " print-base) (il:fm.changestate printbase-value-item (il:fm.itemprop item (quote printbase)) window)))))
+)
+
+(menu-selectedfn
+(il:lambda (item window buttons command extra-args) (il:* il:\; "Edited 17-Jul-87 10:13 by DCB") (let ((context (il:windowprop (il:mainwindow window) (quote edit-context)))) (awake-command-process context (il:append (lookup-command (or command (il:fm.itemprop item (quote il:id)) (il:fm.itemprop item (quote il:label))) (il:fetch command-table il:of (il:fetch environment il:of context))) extra-args))))
+)
+
+(menu-substitute-selectedfn
+(il:lambda (item window buttons) (il:* il:\; "Edited 17-Jul-87 09:57 by DCB") (let ((find-item (il:listget (il:fm.itemprop item (quote il:links)) (quote finditem))) (subitem (il:listget (il:fm.itemprop item (quote il:links)) (quote il:edit))) (context (il:windowprop (il:mainwindow window) (quote edit-context)))) (cond ((il:equal (il:fm.itemprop find-item (quote il:label)) "") (il:* il:\; "need new stuff to find") (il:fm.edititem find-item window t)) ((or (il:equal (il:fm.itemprop subitem (quote il:label)) "") (eq (car buttons) (quote il:right))) (il:* il:\; "need new stuff to substitute") (il:fm.edititem subitem window t)) (t (il:* il:\; "call substitute with all the stuff to substitute") (menu-selectedfn item window buttons (quote substitute) (list (il:fm.itemprop find-item (quote il:label)) (il:fm.itemprop subitem (quote il:label)))) (il:tty.process (il:windowprop (il:mainwindow window) (quote il:process)))))))
+)
+
+(mutate
+(il:lambda (context) (il:* il:\; "Edited 11-Apr-88 15:58 by woz") (let* ((promptwindow (get-prompt-window context)) (selection (il:|fetch| selection il:|of| context)) (point (il:|fetch| caret-point il:|of| context)) (node (il:|fetch| select-node il:|of| selection)) mutator-string mutator result) (cond ((and node (eq (il:|fetch| select-type il:|of| selection) (quote structure)) (null (il:|fetch| select-start il:|of| selection))) (il:terpri promptwindow) (il:setq mutator-string (il:ttyinpromptforword "Mutate by function: " mutate-candidate nil promptwindow nil nil (il:charcode (il:cr ^x)))) (cond ((il:stringp mutator-string) (il:setq mutator (il:nlsetq (il:read (il:openstringstream mutator-string (quote il:input))))) (if mutator (if (do-mutation context node (car mutator)) (il:setq mutate-candidate mutator-string) (il:|printout| promptwindow t "Error during mutation.  No changes made.")) (il:|printout| promptwindow t "Invalid function name: " mutator-string))) (t (il:|printout| promptwindow "...aborted")))) (t (il:|printout| promptwindow t "Select whole structure to mutate."))) t))
+)
+
+(quote-current-selection
+(il:lambda (context charcode quote-type) (il:* il:\; "Edited 13-Jan-88 13:26 by DCB") (close-open-node context) (let* ((selection (il:fetch selection il:of context)) (point (il:fetch caret-point il:of context)) (node (il:fetch select-node il:of selection)) (quote-node)) (when (and node (eq (il:fetch select-type il:of selection) (quote structure))) (il:setq quote-node (create-quoted-gap basic-gap context quote-type)) (start-undo-block) (replace-node context node quote-node) (replace-node context (subnode 1 quote-node) node) (note-change quote-node context) (select-node context quote-node) (set-point point context quote-node nil t nil (quote structure)) (end-undo-block))) (il:* il:\; "must return non-NIL if command executed") t)
+)
+
+(REDISPLAY
+  (IL:LAMBDA (CONTEXT)                              (IL:* IL:\; "Edited  5-Dec-90 14:16 by woz")
+
+(IL:* IL:|;;;| "woz: i don't think this function ever gets called!!!")
+
+    (VERIFY-STRUCTURE CONTEXT NIL NIL T)))
+
+(redo
+(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:39 by DCB") (let ((undo-undo-list (il:fetch undo-undo-list il:of context)) (promptwindow (get-prompt-window context))) (cond (undo-undo-list (set-selection-nowhere (il:fetch selection il:of context)) (set-point-nowhere (il:fetch caret-point il:of context)) (undo-event (car undo-undo-list) context) (il:replace undo-undo-list il:of context il:with (cdr undo-undo-list))) (t (il:|printout| promptwindow t "No Undo to Undo")))) t)
+)
+
+(selected-fn-name
+(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:39 by DCB") (close-open-node context) (or (get-selected-structure context) (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point)) structure) (when (il:type? edit-node node) (il:setq structure (il:fetch structure il:of node)) (when (il:listp structure) (il:setq structure (car structure))) (when (il:atom structure) structure)))))
+)
+
+(skip-to-gap
+(il:lambda (context) (il:* il:\; "Edited 23-Nov-87 18:19 by DCB") (let ((selection (il:fetch selection il:of context)) (point (il:fetch caret-point il:of context)) (promptwindow (get-prompt-window context)) node) (cond ((il:setq node (il:fetch select-node il:of selection)) (unless (select-next-gap context node (il:fetch select-start il:of selection)) (il:|printout| promptwindow t "No more blanks to fill in."))) ((il:setq node (il:fetch point-node il:of point)) (unless (select-next-gap context node (if (eq (il:fetch point-type il:of point) (quote structure)) (il:fetch point-index il:of point) 0)) (il:|printout| promptwindow t "No more blanks to fill in."))) (t (il:|printout| promptwindow t "Select point from which to start search for blanks.")))) t)
+)
+
+(undo
+(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:39 by DCB") (close-open-node context) (let ((undo-list (il:fetch undo-list il:of context)) (promptwindow (get-prompt-window context))) (cond (undo-list (il:replace undo-list il:of context il:with (il:fetch undo-undo-list il:of context)) (set-selection-nowhere (il:fetch selection il:of context)) (set-point-nowhere (il:fetch caret-point il:of context)) (undo-event (car undo-list) context) (il:replace undo-undo-list il:of context il:with (il:fetch undo-list il:of context)) (when (null (il:replace undo-list il:of context il:with (cdr undo-list))) (il:replace changed-structure? il:of context il:with nil))) (t (il:|printout| promptwindow t (if (il:fetch undo-undo-list il:of context) "Nothing else to Undo" "Nothing to Undo"))))) t)
+)
+
+(undo-extract
+(il:lambda (context node subnodes) (il:* il:\; "Edited  7-Jul-87 09:39 by DCB") (il:* il:|;;;| "sticks subnodes back into node and revives them.  ") (rplacd (il:fetch sub-nodes il:of node) subnodes) (il:for subnode il:in subnodes il:as index il:from 1 il:do (il:replace super-node il:of subnode il:with node) (il:replace sub-node-index il:of subnode il:with index) (detach-node subnode) (revive-node subnode (il:fetch depth il:of node))) (il:* il:|;;| "used to reparse here.  now if we simply note the change, the format types, format values, and linear forms will be recomputed.") (note-change node context))
+)
+)
+(IL:PUTPROPS IL:SEDIT-COMMANDS IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992
+))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL (46941 100809 (ADD-MENU 46954 . 47617) (BACKSPACE 47619 . 48598) (CHANGE-PACKAGE 
+48600 . 50407) (CHANGE-PRINTBASE 50409 . 52591) (CHANGE-QUOTE 52593 . 52948) (CONVERT-COMMENT 52950 . 
+54710) (CONVERT-COMMENT-STRUCTURE 54712 . 56015) (CONVERT-COMMENT-TAIL 56017 . 57417) (
+CREATE-COMMAND-TABLE 57419 . 59397) (DEFAULT-EDIT-FN 59399 . 59536) (DELETE-SELECTION 59538 . 60220) (
+DELETE-WORD 60222 . 62323) (DO-MUTATION 62325 . 62873) (EDIT-SELECTION 62875 . 63323) (EVAL-SELECTION 
+63325 . 65194) (EXPAND 65196 . 66325) (EXTRACT-CURRENT-SELECTION 66327 . 68695) (FIND-COMMENT 68697 . 
+69391) (GET-MENU 69393 . 69770) (EDIT-HELP 69772 . 70847) (HELPMENU 70849 . 73638) (INPUT-DOT 73640 . 
+75772) (INPUT-ESCAPE 75774 . 76022) (INPUT-NORMAL-CHAR 76024 . 78057) (INPUT-QUOTE 78059 . 81141) (
+INPUT-SQUARE-BRACKET 81143 . 81494) (INPUT-STRINGDELIM 81496 . 82895) (INPUT-TOKENDELIM 82897 . 83877)
+ (INSERT-MULTI-ESCAPE 83879 . 85007) (INSERT-SPECIAL-CHARACTER 85009 . 86269) (INSPECT-SELECTION 86271
+ . 86806) (JOIN 86808 . 90478) (MENU-CLOSEFN 90480 . 90698) (MENU-FIND-SELECTEDFN 90700 . 91400) (
+MENU-INIT-STATE 91402 . 92209) (MENU-PACKAGE-SELECTEDFN 92211 . 93262) (MENU-PRINTBASE-SELECTEDFN 
+93264 . 94140) (MENU-SELECTEDFN 94142 . 94568) (MENU-SUBSTITUTE-SELECTEDFN 94570 . 95530) (MUTATE 
+95532 . 96642) (QUOTE-CURRENT-SELECTION 96644 . 97411) (REDISPLAY 97413 . 97652) (REDO 97654 . 98148) 
+(SELECTED-FN-NAME 98150 . 98595) (SKIP-TO-GAP 98597 . 99374) (UNDO 99376 . 100176) (UNDO-EXTRACT 
+100178 . 100807)))))
+IL:STOP
diff --git a/CLTL2/SEDIT-COMMANDS.DFASL b/CLTL2/SEDIT-COMMANDS.DFASL
new file mode 100644
index 00000000..6c9093e3
Binary files /dev/null and b/CLTL2/SEDIT-COMMANDS.DFASL differ
diff --git a/CLTL2/SEDIT-DECLS.LCOM b/CLTL2/SEDIT-DECLS.LCOM
new file mode 100644
index 00000000..d161ae08
--- /dev/null
+++ b/CLTL2/SEDIT-DECLS.LCOM
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL)))
(IL:FILECREATED "10-Nov-93 09:52:53" ("compiled on " 
IL:|{DSK}<king>export>lispcore>sources>SEDIT-DECLS.;1|) "19-Feb-93 17:03:08" IL:|bcompl'd| IL:|in| 
"Medley 19-Feb-93 ..." IL:|dated| "19-Feb-93 18:20:42")
(IL:FILECREATED "19-Jan-93 11:18:34" IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;3| 50314 
IL:|changes| IL:|to:| (IL:RECORDS BROKEN-ATOM EDIT-CONTEXT EDIT-ENV EDIT-NODE EDIT-NODE-TYPE 
EDIT-POINT EDIT-SELECTION GAP LINE-BLOCK LINE-START LIST-FORMAT OPEN-STRING STRING-ITEM WEAK-LINK) 
IL:|previous| IL:|date:| " 5-Jan-93 02:19:37" IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
(IL:PRETTYCOMPRINT IL:SEDIT-DECLSCOMS)
(IL:RPAQQ IL:SEDIT-DECLSCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-DECLS) (IL:PROP IL:MAKEFILE-ENVIRONMENT 
IL:SEDIT-DECLS) (IL:* IL:|;;;| 
"This file is for declaring things which are shared among sedit files.  This file is loaded at compile time by each sedit file, but the contents of this file are not copied into any of the compiled files.  The RECORDS declarations are here, and they are INITRECORDed and SYSRECORDed in SEDIT-ACCESS.  If you change a record, make sure sedit-access gets remade NEW.  All GLOBALVARS declarations are done here, because they're needed at compile time, but the actual variable declarations are done in the appropriate file.  Constants and Macros are declared here only if they are shared among files; otherwise they can remain in the appropriate file. "
) (IL:RECORDS BROKEN-ATOM EDIT-CONTEXT EDIT-ENV EDIT-NODE EDIT-NODE-TYPE EDIT-POINT EDIT-SELECTION GAP
 LINE-BLOCK LINE-START LIST-FORMAT OPEN-STRING STRING-ITEM WEAK-LINK) (IL:* IL:|;;| 
"interface globalvars") (IL:GLOBALVARS CONVERT-UPGRADE KEEP-WINDOW-REGION CONTEXTS 
LISP-EDIT-ENVIRONMENT LIST-FORMATS-TABLE PRETTY-PRINT-ENV REGIONS) (IL:* IL:|;;| "shared globalvars") 
(IL:GLOBALVARS IL:BOLDFONT IL:CLISPFONT IL:COMMENTFLG IL:COMMENTFONT IL:DEFAULTFONT IL:PROMPTWINDOW 
IL:ITALICFONT ARGS-GAP ATOM-CARET BASIC-GAP BODY-GAP BUTTON-STRING BUTTON-STRING-NODE STRUCTURE-CARET 
CLISP-INDENT-WORDS CLISP-PROGRAM-WORDS COMMAND-TABLE-SPEC LIST-PARSE-INFO TERMINAL-TABLE TEMP-POINT 
TEMP-SELECTION TYPE-CLISP TYPE-COMMENT TYPE-COMMENT-WORD TYPE-DOTLIST TYPE-GAP TYPE-LIST TYPE-LITATOM 
TYPE-QUOTE TYPE-ROOT TYPE-STRING TYPE-UNKNOWN TYPES ARGS-BITMAP BODY-BITMAP GAP-BITMAP) (IL:* IL:|;;| 
"window file globalvars") (IL:GLOBALVARS TITLED-ICON SELECTION-PENDING? PENDING-SELECTION 
INITIAL-SELECTION SCRATCH-SELECTION PENDING-CARET PENDING-LAST-X PENDING-LAST-Y PENDING-TYPE 
PENDING-SHIFT LAST-MOVE-CLOCK BUTTON-STRING-NODE) (IL:* IL:|;;| "command file globalvars") (
IL:GLOBALVARS MENUS MENU-DESCRIPTION MUTATE-CANDIDATE PACKAGE-CANDIDATE PRINTBASE-CANDIDATE 
FIND-CANDIDATE SUBSTITUTE-CANDIDATE) (IL:* IL:|;;| "random constants") (IL:CONSTANTS (EDITOR-NAME 
"SEdit") (IL:MICASPERPT 35.27778) (QUOTE-WRAPPER-LIST (QUOTE (QUOTE QUOTE IL:BQUOTE IL:BQUOTE IL:COMMA
 IL:\\\, COMMA-AT IL:\\\,@ COMMA-DOT IL:\\\,. FUNCTION FUNCTION)))) (IL:* IL:|;;| "random macros") (
IL:MACROS GET-PROMPT-WINDOW EVAL-IN-PROCESS LOOKUP-COMMAND QUOTE-WRAPPER QUOTE-WRAPPER-NAME 
REPAINT-NEW-LINE RESET-CONTROL-VARIABLES SELECT-COMMENT-INDENT SET-COMMENT-POSITIONS 
SET-SELECTION-NOWHERE) (IL:* IL:|;;| "kernel macros") (IL:FUNCTIONS CREATE-WEAK-LINK) (IL:MACROS 
ADVANCE CLOSE-OPEN-NODE DEAD-NODE? END-UNDO-BLOCK ESCAPE-CHAR EQ-POINT-TYPE NEXT-LINEAR SET-LINEAR 
START-UNDO-BLOCK STEP-LINEAR SUBNODE UNDO-BY ZAP-CLISP-TRANSLATION SMASH-USING IL:HALF) (IL:* IL:|;;| 
"the symbols that come from interlisp, divided into those that conflict with CL symbols and those that don't.  The SEDIT package declaration in the makefile-environment for all these files need not actually import any of these symbols, it just makes the functions easier to edit if you do cause then you don't need so many IL: prefixes."
) (IL:VARIABLES *IL-CL-CONFLICTS* *IL-IMPORTS*) (IL:* IL:|;;| "and a little reminder:") (IL:P (
IL:|printout| T T "EXPORTS.ALL must be loaded to compile SEdit" T) (IL:|printout| T T 
"SEDIT-ACCESS must be REMADE NEW if you change a record" T))))
(IL:PUTPROPS IL:SEDIT-DECLS IL:FILETYPE :COMPILE-FILE)
(IL:PUTPROPS IL:SEDIT-DECLS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (
:USE IL:LISP IL:XCL))))
(IL:DATATYPE BROKEN-ATOM (ATOM-CHARS))
(IL:DATATYPE EDIT-CONTEXT (ENVIRONMENT PROFILE EVAL-FN EVAL-IN-PROCESS CONTEXT-LOCK COMPLETION-EVENT 
EDIT-TYPE ICON-TITLE EDIT-OPTIONS COMMENT-WIDTH COMMENT-SEPARATION FIND-CANDIDATE SUBSTITUTE-CANDIDATE
 DISPLAY-WINDOW WINDOW-LEFT WINDOW-BOTTOM WINDOW-RIGHT WINDOW-TOP ROOT ROOT-CHANGED-FN COMPLETION-FN 
CHANGED-STRUCTURE? (DONT-COLLECT-CHANGES? IL:FLAG) CHANGED-NODES OPEN-NODE-CHANGED? OPEN-NODE 
OPEN-NODE-INFO ATOM-STARTED ATOM-STARTED-UNDO-POINTER UNDO-LIST UNDO-UNDO-LIST CARET CARET-POINT 
SELECTION SELECTION-DISPLAYED? (CURRENT-NODE IL:FULLXPOINTER) CURRENT-X (CURRENT-LINE IL:FULLXPOINTER)
 (LAST-LINEARIZED-SUB-NODE-INDEX IL:WORD) (LINEAR-POINTER IL:FULLXPOINTER) (LINEAR-PREV IL:FULLXPOINTER
) LAST-MOUSE-X LAST-MOUSE-Y LAST-MOUSE-TYPE \\X \\Y \\Z \\T FIRST-BLOCK CURRENT-BLOCK MATCHING? BELOW?
 VISIBLE? (REPAINT-START IL:FULLXPOINTER) (REPAINT-LINE IL:FULLXPOINTER) REPAINT-X 
RELINEARIZATION-TIME-STAMP SHIFT-Y SHIFT-DOWN SHIFT-RIGHT) CHANGED-NODES IL:_ (CONS))
(IL:DATATYPE EDIT-ENV (PARSE-INFO PARSE-INFO-UNKNOWN USER-DATA DEFAULT-FONT ITALIC-FONT KEYWORD-FONT 
COMMENT-FONT BROKEN-ATOM-FONT SPACE-WIDTH DEFAULT-LINE-SKIP EM-WIDTH INDENT-BASE INDENT-STEP MAX-WIDTH
 COMMENT-WIDTH-PERCENT INIT-COMMENT-SEPARATION LPAREN-STRING RPAREN-STRING DOT-STRING QUOTE-STRING 
COMMENT-STRING COMMAND-TABLE DEFAULT-CHAR-HANDLER HELP-MENU))
(IL:DATATYPE EDIT-NODE ((NODE-TYPE IL:FULLXPOINTER) FORMAT UNASSIGNED (SUPER-NODE IL:FULLXPOINTER) (
DEPTH IL:WORD) (SUB-NODE-INDEX IL:WORD) STRUCTURE SUB-NODES (LINEAR-THREAD IL:FULLXPOINTER) 
LINEAR-FORM (START-X IL:WORD) (RIGHT-MARGIN IL:WORD) (PREFERRED-WIDTH IL:WORD) (ACTUAL-WIDTH IL:WORD) 
(CHANGED? IL:FLAG) INLINE-WIDTH ACTUAL-LLENGTH FIRST-LINE LAST-LINE) (IL:ACCESSFNS (INLINE? (EQ (
IL:|fetch| FIRST-LINE IL:|of| IL:DATUM) (IL:|fetch| LAST-LINE IL:|of| IL:DATUM)))) FORMAT IL:_ (QUOTE 
NOT-YET-ASSIGNED))
(IL:DATATYPE EDIT-NODE-TYPE (NAME ASSIGN-FORMAT COMPUTE-FORMAT-VALUES LINEARIZE SUB-NODE-CHANGED 
SET-POINT COMPUTE-POINT-POSITION COMPUTE-SELECTION-POSITION SET-SELECTION GROW-SELECTION 
SELECT-SEGMENT INSERT DELETE COPY-STRUCTURE COPY-SELECTION STRINGIFY BACK-SPACE CLOSE-NODE))
(IL:DATATYPE EDIT-POINT ((POINT-NODE IL:FULLXPOINTER) POINT-INDEX POINT-TYPE POINT-X (POINT-LINE 
IL:FULLXPOINTER) POINT-STRING POINT-OFFSET))
(IL:DATATYPE EDIT-SELECTION ((SELECT-NODE IL:FULLXPOINTER) SELECT-START SELECT-END SELECT-TYPE 
DELETE-OK? PENDING-DELETE? SELECT-START-X (SELECT-START-LINE IL:FULLXPOINTER) SELECT-END-X (
SELECT-END-LINE IL:FULLXPOINTER) SELECT-STRING SELECT-START-OFFSET SELECT-END-OFFSET))
(IL:DATATYPE GAP (LINEAR-ITEM))
(IL:DATATYPE LINE-BLOCK ((BLOCK-START IL:FULLXPOINTER) BLOCK-NEW-X BLOCK-WIDTH NEXT-BLOCK BITS? 
BLOCK-X BLOCK-BASE-LINE BLOCK-ASCENT BLOCK-DESCENT))
(IL:DATATYPE LINE-START ((NEXT-LINE IL:FULLXPOINTER) (PREV-LINE IL:FULLXPOINTER) (NODE IL:FULLXPOINTER
) (LINE-ASCENT IL:WORD) (LINE-DESCENT IL:WORD) (LINE-SKIP IL:WORD) (LINE-LENGTH IL:WORD) (INDENT IL:WORD
) YCOORD (CACHE-TIME IL:WORD) CACHED-Y (CACHED-ASCENT IL:WORD) (CACHED-DESCENT IL:WORD)) (IL:ACCESSFNS
 (LINE-HEIGHT (IL:IPLUS (IL:FETCH LINE-SKIP IL:OF IL:DATUM) (IL:FETCH LINE-ASCENT IL:OF IL:DATUM) (
IL:FETCH LINE-DESCENT IL:OF IL:DATUM)))) (IL:ACCESSFNS (BASE-LINE-Y (IL:IDIFFERENCE (IL:ADD1 (IL:FETCH
 YCOORD IL:OF IL:DATUM)) (IL:IPLUS (IL:FETCH LINE-SKIP IL:OF IL:DATUM) (IL:FETCH LINE-ASCENT IL:OF 
IL:DATUM))))) (IL:ACCESSFNS (NEXT-LINE-Y (IL:IDIFFERENCE (IL:FETCH YCOORD IL:OF IL:DATUM) (IL:FETCH 
LINE-HEIGHT IL:OF IL:DATUM)))) (IL:ACCESSFNS (OLD-TOP (IF (EQ (IL:FETCH CACHE-TIME IL:OF IL:DATUM) (
IL:|fetch| RELINEARIZATION-TIME-STAMP IL:|of| CONTEXT)) (IL:SUB1 (IL:IPLUS (IL:FETCH CACHED-Y IL:OF 
IL:DATUM) (IL:FETCH CACHED-ASCENT IL:OF IL:DATUM))) (IL:FETCH YCOORD IL:OF IL:DATUM)))) (IL:ACCESSFNS 
(OLD-BOTTOM (IF (EQ (IL:FETCH CACHE-TIME IL:OF IL:DATUM) (IL:|fetch| RELINEARIZATION-TIME-STAMP IL:|of|
 CONTEXT)) (IL:IDIFFERENCE (IL:FETCH CACHED-Y IL:OF IL:DATUM) (IL:FETCH CACHED-DESCENT IL:OF IL:DATUM)
) (IL:ADD1 (IL:FETCH NEXT-LINE-Y IL:OF IL:DATUM))))))
(IL:DATATYPE LIST-FORMAT (LIST-FORMATS LIST-INLINE? LIST-PFORMAT LIST-MFORMAT LIST-SUBLISTS) (
IL:ACCESSFNS (NON-STANDARD? (NULL (IL:|fetch| LIST-FORMATS IL:|of| IL:DATUM)))) (IL:ACCESSFNS (
SET-FORMAT-LIST (IL:|fetch| LIST-INLINE? IL:|of| IL:DATUM))) (IL:ACCESSFNS (CFVLIST (IL:|fetch| 
LIST-PFORMAT IL:|of| IL:DATUM))) (IL:ACCESSFNS (LINEARIZE-LIST (IL:|fetch| LIST-MFORMAT IL:|of| IL:DATUM
))) LIST-SUBLISTS IL:_ NIL)
(IL:RECORD OPEN-STRING (REAL-LENGTH SUBSTRING . BUFFER-STRING))
(IL:DATATYPE STRING-ITEM (STRING (WIDTH IL:WORD) (FONT IL:FULLXPOINTER) (PRIN-2? IL:FLAG)))
(IL:DATATYPE WEAK-LINK ((DESTINATION IL:FULLXPOINTER)))
(IL:/DECLAREDATATYPE (QUOTE BROKEN-ATOM) (QUOTE (IL:POINTER)) (QUOTE ((BROKEN-ATOM 0 IL:POINTER))) (
QUOTE 2))
(IL:/DECLAREDATATYPE (QUOTE EDIT-CONTEXT) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER
 IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER 
IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:FLAG 
IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER 
IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:FULLXPOINTER IL:WORD IL:FULLXPOINTER 
IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER
 IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:FULLXPOINTER IL:POINTER IL:POINTER 
IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((EDIT-CONTEXT 0 IL:POINTER) (EDIT-CONTEXT 2 IL:POINTER) (
EDIT-CONTEXT 4 IL:POINTER) (EDIT-CONTEXT 6 IL:POINTER) (EDIT-CONTEXT 8 IL:POINTER) (EDIT-CONTEXT 10 
IL:POINTER) (EDIT-CONTEXT 12 IL:POINTER) (EDIT-CONTEXT 14 IL:POINTER) (EDIT-CONTEXT 16 IL:POINTER) (
EDIT-CONTEXT 18 IL:POINTER) (EDIT-CONTEXT 20 IL:POINTER) (EDIT-CONTEXT 22 IL:POINTER) (EDIT-CONTEXT 24
 IL:POINTER) (EDIT-CONTEXT 26 IL:POINTER) (EDIT-CONTEXT 28 IL:POINTER) (EDIT-CONTEXT 30 IL:POINTER) (
EDIT-CONTEXT 32 IL:POINTER) (EDIT-CONTEXT 34 IL:POINTER) (EDIT-CONTEXT 36 IL:POINTER) (EDIT-CONTEXT 38
 IL:POINTER) (EDIT-CONTEXT 40 IL:POINTER) (EDIT-CONTEXT 42 IL:POINTER) (EDIT-CONTEXT 42 (IL:FLAGBITS
 . 0)) (EDIT-CONTEXT 44 IL:POINTER) (EDIT-CONTEXT 46 IL:POINTER) (EDIT-CONTEXT 48 IL:POINTER) (
EDIT-CONTEXT 50 IL:POINTER) (EDIT-CONTEXT 52 IL:POINTER) (EDIT-CONTEXT 54 IL:POINTER) (EDIT-CONTEXT 56
 IL:POINTER) (EDIT-CONTEXT 58 IL:POINTER) (EDIT-CONTEXT 60 IL:POINTER) (EDIT-CONTEXT 62 IL:POINTER) (
EDIT-CONTEXT 64 IL:POINTER) (EDIT-CONTEXT 66 IL:POINTER) (EDIT-CONTEXT 68 IL:FULLXPOINTER) (
EDIT-CONTEXT 70 IL:POINTER) (EDIT-CONTEXT 72 IL:FULLXPOINTER) (EDIT-CONTEXT 74 (IL:BITS . 15)) (
EDIT-CONTEXT 76 IL:FULLXPOINTER) (EDIT-CONTEXT 78 IL:FULLXPOINTER) (EDIT-CONTEXT 80 IL:POINTER) (
EDIT-CONTEXT 82 IL:POINTER) (EDIT-CONTEXT 84 IL:POINTER) (EDIT-CONTEXT 86 IL:POINTER) (EDIT-CONTEXT 88
 IL:POINTER) (EDIT-CONTEXT 90 IL:POINTER) (EDIT-CONTEXT 92 IL:POINTER) (EDIT-CONTEXT 94 IL:POINTER) (
EDIT-CONTEXT 96 IL:POINTER) (EDIT-CONTEXT 98 IL:POINTER) (EDIT-CONTEXT 100 IL:POINTER) (EDIT-CONTEXT 
102 IL:POINTER) (EDIT-CONTEXT 104 IL:FULLXPOINTER) (EDIT-CONTEXT 106 IL:FULLXPOINTER) (EDIT-CONTEXT 
108 IL:POINTER) (EDIT-CONTEXT 110 IL:POINTER) (EDIT-CONTEXT 112 IL:POINTER) (EDIT-CONTEXT 114 IL:POINTER
) (EDIT-CONTEXT 116 IL:POINTER))) (QUOTE 118))
(IL:/DECLAREDATATYPE (QUOTE EDIT-ENV) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER 
IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER 
IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER 
IL:POINTER)) (QUOTE ((EDIT-ENV 0 IL:POINTER) (EDIT-ENV 2 IL:POINTER) (EDIT-ENV 4 IL:POINTER) (EDIT-ENV
 6 IL:POINTER) (EDIT-ENV 8 IL:POINTER) (EDIT-ENV 10 IL:POINTER) (EDIT-ENV 12 IL:POINTER) (EDIT-ENV 14 
IL:POINTER) (EDIT-ENV 16 IL:POINTER) (EDIT-ENV 18 IL:POINTER) (EDIT-ENV 20 IL:POINTER) (EDIT-ENV 22 
IL:POINTER) (EDIT-ENV 24 IL:POINTER) (EDIT-ENV 26 IL:POINTER) (EDIT-ENV 28 IL:POINTER) (EDIT-ENV 30 
IL:POINTER) (EDIT-ENV 32 IL:POINTER) (EDIT-ENV 34 IL:POINTER) (EDIT-ENV 36 IL:POINTER) (EDIT-ENV 38 
IL:POINTER) (EDIT-ENV 40 IL:POINTER) (EDIT-ENV 42 IL:POINTER) (EDIT-ENV 44 IL:POINTER) (EDIT-ENV 46 
IL:POINTER))) (QUOTE 48))
(IL:/DECLAREDATATYPE (QUOTE EDIT-NODE) (QUOTE (IL:FULLXPOINTER IL:POINTER IL:POINTER IL:FULLXPOINTER 
IL:WORD IL:WORD IL:POINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:WORD IL:WORD IL:WORD IL:WORD IL:FLAG
 IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((EDIT-NODE 0 IL:FULLXPOINTER) (EDIT-NODE 2 
IL:POINTER) (EDIT-NODE 4 IL:POINTER) (EDIT-NODE 6 IL:FULLXPOINTER) (EDIT-NODE 8 (IL:BITS . 15)) (
EDIT-NODE 9 (IL:BITS . 15)) (EDIT-NODE 10 IL:POINTER) (EDIT-NODE 12 IL:POINTER) (EDIT-NODE 14 
IL:FULLXPOINTER) (EDIT-NODE 16 IL:POINTER) (EDIT-NODE 18 (IL:BITS . 15)) (EDIT-NODE 19 (IL:BITS . 15))
 (EDIT-NODE 20 (IL:BITS . 15)) (EDIT-NODE 21 (IL:BITS . 15)) (EDIT-NODE 16 (IL:FLAGBITS . 0)) (
EDIT-NODE 22 IL:POINTER) (EDIT-NODE 24 IL:POINTER) (EDIT-NODE 26 IL:POINTER) (EDIT-NODE 28 IL:POINTER)
)) (QUOTE 30))
(IL:/DECLAREDATATYPE (QUOTE EDIT-NODE-TYPE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER 
IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER 
IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((EDIT-NODE-TYPE 0 IL:POINTER) (
EDIT-NODE-TYPE 2 IL:POINTER) (EDIT-NODE-TYPE 4 IL:POINTER) (EDIT-NODE-TYPE 6 IL:POINTER) (
EDIT-NODE-TYPE 8 IL:POINTER) (EDIT-NODE-TYPE 10 IL:POINTER) (EDIT-NODE-TYPE 12 IL:POINTER) (
EDIT-NODE-TYPE 14 IL:POINTER) (EDIT-NODE-TYPE 16 IL:POINTER) (EDIT-NODE-TYPE 18 IL:POINTER) (
EDIT-NODE-TYPE 20 IL:POINTER) (EDIT-NODE-TYPE 22 IL:POINTER) (EDIT-NODE-TYPE 24 IL:POINTER) (
EDIT-NODE-TYPE 26 IL:POINTER) (EDIT-NODE-TYPE 28 IL:POINTER) (EDIT-NODE-TYPE 30 IL:POINTER) (
EDIT-NODE-TYPE 32 IL:POINTER) (EDIT-NODE-TYPE 34 IL:POINTER))) (QUOTE 36))
(IL:/DECLAREDATATYPE (QUOTE EDIT-POINT) (QUOTE (IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER 
IL:FULLXPOINTER IL:POINTER IL:POINTER)) (QUOTE ((EDIT-POINT 0 IL:FULLXPOINTER) (EDIT-POINT 2 IL:POINTER
) (EDIT-POINT 4 IL:POINTER) (EDIT-POINT 6 IL:POINTER) (EDIT-POINT 8 IL:FULLXPOINTER) (EDIT-POINT 10 
IL:POINTER) (EDIT-POINT 12 IL:POINTER))) (QUOTE 14))
(IL:/DECLAREDATATYPE (QUOTE EDIT-SELECTION) (QUOTE (IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER 
IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:POINTER 
IL:POINTER)) (QUOTE ((EDIT-SELECTION 0 IL:FULLXPOINTER) (EDIT-SELECTION 2 IL:POINTER) (EDIT-SELECTION 
4 IL:POINTER) (EDIT-SELECTION 6 IL:POINTER) (EDIT-SELECTION 8 IL:POINTER) (EDIT-SELECTION 10 IL:POINTER
) (EDIT-SELECTION 12 IL:POINTER) (EDIT-SELECTION 14 IL:FULLXPOINTER) (EDIT-SELECTION 16 IL:POINTER) (
EDIT-SELECTION 18 IL:FULLXPOINTER) (EDIT-SELECTION 20 IL:POINTER) (EDIT-SELECTION 22 IL:POINTER) (
EDIT-SELECTION 24 IL:POINTER))) (QUOTE 26))
(IL:/DECLAREDATATYPE (QUOTE GAP) (QUOTE (IL:POINTER)) (QUOTE ((GAP 0 IL:POINTER))) (QUOTE 2))
(IL:/DECLAREDATATYPE (QUOTE LINE-BLOCK) (QUOTE (IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER 
IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((LINE-BLOCK 0 IL:FULLXPOINTER) (
LINE-BLOCK 2 IL:POINTER) (LINE-BLOCK 4 IL:POINTER) (LINE-BLOCK 6 IL:POINTER) (LINE-BLOCK 8 IL:POINTER)
 (LINE-BLOCK 10 IL:POINTER) (LINE-BLOCK 12 IL:POINTER) (LINE-BLOCK 14 IL:POINTER) (LINE-BLOCK 16 
IL:POINTER))) (QUOTE 18))
(IL:/DECLAREDATATYPE (QUOTE LINE-START) (QUOTE (IL:FULLXPOINTER IL:FULLXPOINTER IL:FULLXPOINTER IL:WORD
 IL:WORD IL:WORD IL:WORD IL:WORD IL:POINTER IL:WORD IL:POINTER IL:WORD IL:WORD)) (QUOTE ((LINE-START 0
 IL:FULLXPOINTER) (LINE-START 2 IL:FULLXPOINTER) (LINE-START 4 IL:FULLXPOINTER) (LINE-START 6 (IL:BITS
 . 15)) (LINE-START 7 (IL:BITS . 15)) (LINE-START 8 (IL:BITS . 15)) (LINE-START 9 (IL:BITS . 15)) (
LINE-START 10 (IL:BITS . 15)) (LINE-START 12 IL:POINTER) (LINE-START 11 (IL:BITS . 15)) (LINE-START 14
 IL:POINTER) (LINE-START 16 (IL:BITS . 15)) (LINE-START 17 (IL:BITS . 15)))) (QUOTE 18))
(IL:/DECLAREDATATYPE (QUOTE LIST-FORMAT) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER
)) (QUOTE ((LIST-FORMAT 0 IL:POINTER) (LIST-FORMAT 2 IL:POINTER) (LIST-FORMAT 4 IL:POINTER) (
LIST-FORMAT 6 IL:POINTER) (LIST-FORMAT 8 IL:POINTER))) (QUOTE 10))
(IL:/DECLAREDATATYPE (QUOTE STRING-ITEM) (QUOTE (IL:POINTER IL:WORD IL:FULLXPOINTER IL:FLAG)) (QUOTE (
(STRING-ITEM 0 IL:POINTER) (STRING-ITEM 2 (IL:BITS . 15)) (STRING-ITEM 4 IL:FULLXPOINTER) (STRING-ITEM
 3 (IL:FLAGBITS . 0)))) (QUOTE 6))
(IL:/DECLAREDATATYPE (QUOTE WEAK-LINK) (QUOTE (IL:FULLXPOINTER)) (QUOTE ((WEAK-LINK 0 IL:FULLXPOINTER)
)) (QUOTE 2))
(IL:RPAQ EDITOR-NAME "SEdit")
(IL:RPAQQ IL:MICASPERPT 35.27778)
(IL:RPAQQ QUOTE-WRAPPER-LIST (QUOTE QUOTE IL:BQUOTE IL:BQUOTE IL:COMMA IL:\\\, COMMA-AT IL:\\\,@ 
COMMA-DOT IL:\\\,. FUNCTION FUNCTION))
(IL:CONSTANTS (EDITOR-NAME "SEdit") (IL:MICASPERPT 35.27778) (QUOTE-WRAPPER-LIST (QUOTE (QUOTE QUOTE 
IL:BQUOTE IL:BQUOTE IL:COMMA IL:\\\, COMMA-AT IL:\\\,@ COMMA-DOT IL:\\\,. FUNCTION FUNCTION))))
(IL:PUTPROPS GET-PROMPT-WINDOW IL:MACRO ((CONTEXT) (IL:GETPROMPTWINDOW (IL:|fetch| DISPLAY-WINDOW 
IL:|of| CONTEXT))))
(IL:PUTPROPS EVAL-IN-PROCESS IL:MACRO (NIL (LET* ((PROCESS (IF (EQ (IL:PROCESSPROP (IL:THIS.PROCESS) (
QUOTE IL:NAME)) (QUOTE IL:MOUSE)) (IL:TTY.PROCESS) (IL:THIS.PROCESS))) (PROCFORM (IL:PROCESSPROP 
PROCESS (QUOTE IL:FORM)))) (COND ((EQ (CAR PROCFORM) (QUOTE SEDIT1)) (IL:|fetch| (EDIT-CONTEXT 
EVAL-IN-PROCESS) IL:|of| (CADADR PROCFORM))) (T PROCESS)))))
(IL:PUTPROPS LOOKUP-COMMAND IL:MACRO ((CHAR TABLE) (GETHASH CHAR TABLE)))
(IL:PUTPROPS QUOTE-WRAPPER IL:MACRO (TYPE (COND ((AND (IL:LISTP (CAR TYPE)) (EQ (CAAR TYPE) (QUOTE 
QUOTE))) (IF (IL:LISTP (CADAR TYPE)) (IL:KWOTE (IL:|for| W IL:|in| (CADAR TYPE) IL:|collect| (IL:LISTGET
 QUOTE-WRAPPER-LIST W))) (IL:KWOTE (IL:LISTGET QUOTE-WRAPPER-LIST (CADAR TYPE))))) (T (IL:BQUOTE (
IL:LISTGET QUOTE-WRAPPER-LIST (IL:\\\, (CAR TYPE))))))))
(IL:PUTPROPS QUOTE-WRAPPER-NAME IL:MACRO ((TYPE) (IL:LISTGET (IL:CONSTANT (IL:REVERSE 
QUOTE-WRAPPER-LIST)) TYPE)))
(IL:PUTPROPS REPAINT-NEW-LINE IL:MACRO (IL:OPENLAMBDA (LINE) (WHEN (IL:ILESSP (IL:|fetch| NEXT-LINE-Y 
IL:|of| (CAR LINE)) (IL:|fetch| WINDOW-TOP IL:|of| CONTEXT)) (REPAINT CONTEXT (IL:|fetch| INDENT IL:|of|
 (CAR LINE)) (IL:|fetch| BASE-LINE-Y IL:|of| (CAR LINE)) (CDR LINE) (IL:|fetch| LINEAR-POINTER IL:|of|
 CONTEXT)) (WHEN (IL:ILESSP (IL:|fetch| NEXT-LINE-Y IL:|of| (CAR LINE)) (IL:|fetch| WINDOW-BOTTOM 
IL:|of| CONTEXT)) (IL:|replace| BELOW? IL:|of| CONTEXT IL:|with| T)))))
(IL:PUTPROPS RESET-CONTROL-VARIABLES IL:MACRO ((CONTEXT) (WHEN (COMPILING-POST-KOTO) (IL:SETQ 
*PACKAGE* (IL:FETCH PACKAGE IL:OF CONTEXT)) (IL:SETQ *PRINT-ARRAY* NIL) (IL:SETQ *PRINT-BASE* (IL:FETCH
 PRINT-BASE IL:OF CONTEXT)) (IL:SETQ *PRINT-CASE* (IL:FETCH PRINT-CASE IL:OF CONTEXT)) (IL:SETQ 
*PRINT-ESCAPE* T) (IL:SETQ *PRINT-GENSYM* T) (IL:SETQ *PRINT-RADIX* NIL))))
(IL:PUTPROPS SELECT-COMMENT-INDENT IL:MACRO ((KEY LEVEL-1-INDENT LEVEL-2-INDENT LEVEL-3-INDENT) (
IL:SELECTQ KEY (1 LEVEL-1-INDENT) (2 LEVEL-2-INDENT) ((3 4 5) LEVEL-3-INDENT) (IL:SHOULDNT 
"unexpected comment level"))))
(IL:PUTPROPS SET-COMMENT-POSITIONS IL:MACRO ((COMMENT-START-X COMMENT-INDENT FORM-INDENT PAREN-WIDTH 
NODE CONTEXT) (COND ((IL:IGEQ (IL:IPLUS FORM-INDENT (IL:|fetch| COMMENT-WIDTH IL:|of| CONTEXT)) (
IL:|fetch| RIGHT-MARGIN IL:|of| NODE)) (IL:SETQ COMMENT-START-X (IL:IPLUS (IL:|fetch| START-X IL:|of| 
NODE) PAREN-WIDTH)) (IL:SETQ COMMENT-INDENT COMMENT-START-X)) (T (IL:SETQ COMMENT-START-X (
IL:IDIFFERENCE (IL:|fetch| RIGHT-MARGIN IL:|of| NODE) (IL:|fetch| COMMENT-WIDTH IL:|of| CONTEXT))) (
IL:SETQ COMMENT-INDENT (IL:IPLUS COMMENT-START-X (IL:|fetch| COMMENT-SEPARATION IL:|of| CONTEXT)))))))
(IL:PUTPROPS SET-SELECTION-NOWHERE IL:MACRO ((SELECTION) (IL:|replace| SELECT-NODE IL:|of| SELECTION 
IL:|with| NIL)))
(DEFMACRO CREATE-WEAK-LINK (DEST) (IL:BQUOTE (IL:|create| WEAK-LINK DESTINATION IL:_ (IL:\\\, DEST))))
(IL:PUTPROPS ADVANCE IL:MACRO ((WIDTH) (IL:|add| (IL:|fetch| CURRENT-X IL:|of| CONTEXT) WIDTH)))
(IL:PUTPROPS CLOSE-OPEN-NODE IL:MACRO ((CONTEXT) (WHEN (IL:|fetch| OPEN-NODE-CHANGED? IL:|of| CONTEXT)
 (CLOSE-NODE CONTEXT))))
(IL:PUTPROPS DEAD-NODE? IL:MACRO ((NODE) (EQ 0 (IL:|fetch| DEPTH IL:|of| NODE))))
(IL:PUTPROPS END-UNDO-BLOCK IL:MACRO (NIL (COLLECT-UNDO-BLOCK CONTEXT)))
(IL:PUTPROPS ESCAPE-CHAR IL:MACRO ((READ-TABLE) (IL:|fetch| (READTABLEP IL:ESCAPECHAR) IL:|of| (OR 
READ-TABLE *READTABLE*))))
(IL:PUTPROPS EQ-POINT-TYPE IL:MACRO ((POINT TYPE) (LET ((POINTNODE (IL:|fetch| POINT-NODE IL:|of| 
POINT))) (IF (IL:|type?| EDIT-SELECTION POINTNODE) (EQ (IL:|fetch| NODE-TYPE IL:|of| (IL:|fetch| 
SELECT-NODE IL:|of| POINTNODE)) TYPE) (EQ (IL:|fetch| NODE-TYPE IL:|of| POINTNODE) TYPE)))))
(IL:PUTPROPS NEXT-LINEAR IL:MACRO ((CONTEXT ITEM) (AND (IL:LISTP (IL:|fetch| LINEAR-POINTER IL:|of| 
CONTEXT)) (EQ (CAR (IL:|fetch| LINEAR-POINTER IL:|of| CONTEXT)) ITEM))))
(IL:PUTPROPS SET-LINEAR IL:MACRO (IL:OPENLAMBDA (CONTEXT NEW-LPTR) (IL:|replace| LINEAR-POINTER IL:|of|
 CONTEXT IL:|with| NEW-LPTR) (IF (IL:LISTP (IL:|fetch| LINEAR-PREV IL:|of| CONTEXT)) (RPLACD (IL:|fetch|
 LINEAR-PREV IL:|of| CONTEXT) NEW-LPTR) (IL:|replace| LINEAR-FORM IL:|of| (IL:|fetch| LINEAR-PREV 
IL:|of| CONTEXT) IL:|with| NEW-LPTR))))
(IL:PUTPROPS START-UNDO-BLOCK IL:MACRO (NIL (IL:|push| (IL:|fetch| UNDO-LIST IL:|of| CONTEXT) NIL)))
(IL:PUTPROPS STEP-LINEAR IL:MACRO ((CONTEXT) (IL:|replace| LINEAR-POINTER IL:|of| CONTEXT IL:|with| (
CDR (IL:|replace| LINEAR-PREV IL:|of| CONTEXT IL:|with| (IL:|fetch| LINEAR-POINTER IL:|of| CONTEXT))))
))
(IL:PUTPROPS SUBNODE IL:MACRO (X (IF (EQ (CAR X) 1) (LIST (QUOTE CADR) (LIST (QUOTE IL:FETCH) (QUOTE 
SUB-NODES) (CADR X))) (LIST (QUOTE CADR) (LIST (QUOTE IL:NTH) (LIST (QUOTE IL:FETCH) (QUOTE SUB-NODES)
 (CADR X)) (CAR X))))))
(IL:PUTPROPS UNDO-BY IL:MACRO (INFO (LIST (QUOTE IL:PUSH) (QUOTE (IL:|fetch| UNDO-LIST IL:|of| CONTEXT
)) (LIST* (QUOTE LIST) (IL:KWOTE (CAR INFO)) (CDR INFO)))))
(IL:PUTPROPS ZAP-CLISP-TRANSLATION IL:MACRO ((X) (AND IL:CLISPARRAY (IL:PUTHASH X NIL IL:CLISPARRAY)))
)
(IL:PUTPROPS SMASH-USING IL:MACRO (X (IL:|bind| (SRC IL:_ (IF (IL:ATOM (CADDR X)) (CADDR X) (QUOTE 
$$SOURCE))) DEST (DESCR IL:_ (IL:GETDESCRIPTORS (CAR X))) IL:|first| (IL:SETQ DEST (LIST (QUOTE 
IL:REPLACEFIELDVAL) (LIST (QUOTE QUOTE) (CAR DESCR)) (CADR X) (LIST (QUOTE IL:FETCHFIELD) (LIST (QUOTE
 QUOTE) (CAR DESCR)) SRC))) (IL:SETQ DESCR (CDR DESCR)) IL:|while| DESCR IL:|do| (IL:SETQ DEST (LIST (
QUOTE IL:FREPLACEFIELDVAL) (LIST (QUOTE QUOTE) (CAR DESCR)) DEST (LIST (QUOTE IL:FETCHFIELD) (LIST (
QUOTE QUOTE) (CAR DESCR)) SRC))) (IL:SETQ DESCR (CDR DESCR)) IL:|finally| (WHEN (NOT (IL:ATOM (CADDR X
))) (IL:SETQ DEST (LIST (QUOTE LET) (LIST (LIST (QUOTE $$SOURCE) (CADDR X))) DEST))) (RETURN DEST))))
(IL:PUTPROPS IL:HALF IL:MACRO ((IL:X) (IL:LRSH IL:X 1)))
(DEFPARAMETER *IL-CL-CONFLICTS* (QUOTE (IL:*PRINT-STRUCTURE* IL:* IL:APPEND IL:APPLY IL:ASSOC IL:ATOM 
IL:BLOCK IL:CHARACTER IL:EQUAL IL:ERROR IL:FLOATP IL:FORMAT IL:FUNCTION IL:GETHASH IL:IF IL:LAMBDA 
IL:LENGTH IL:LISTP IL:MAPCAR IL:NTH IL:NUMBER IL:NUMBERP IL:PRIN1 IL:READ IL:REVERSE IL:SETQ IL:SPACE 
IL:STRINGP IL:TERPRI)))
(DEFPARAMETER *IL-IMPORTS* (QUOTE (IL:\" IL:$$ITERATE IL:$$LST1 IL:$$OUT IL:\( IL:*DISPLAY-EDITOR* IL:\,
 IL:\. IL:.P2 IL:/DECLAREDATATYPE IL:\; IL:|;;| IL:|;;;| IL:? IL:ACCESSFNS IL:ADD.PROCESS IL:ADD1 
IL:ADDSPELL IL:ADDSPELLFLG IL:ADDTOVAR IL:ALIST IL:ALISTS IL:ALLOCSTRING IL:APPLY* IL:ASCENT IL:ATM 
IL:ATTACHWINDOW IL:AWAIT.EVENT IL:BASE IL:BITBLT IL:BITMAPHEIGHT IL:BITMAPS IL:BITMAPWIDTH IL:BITS 
IL:BKSYSBUF IL:BLACKSHADE IL:BLTSHADE IL:BOLD IL:BOLDFONT IL:BOTTOM IL:BOX IL:BQUOTE IL:BS 
IL:BUTTONEVENTFN IL:BUTTONS IL:C IL:CASEINSENSITIVE IL:CCODEP IL:CHANGENAME IL:CHANGEOFFSETFLG 
IL:CHARCODE IL:CHARDELETE IL:CHARWIDTH IL:CHCON1 IL:CLEARBUF IL:CLEARW IL:CLISP\: IL:CLISPARRAY 
IL:CLISPFONT IL:CLISPTRAN IL:CLISPWORD IL:CLOCK IL:CLOSEFN IL:CLOSEW IL:COLUMN IL:COLUMNSPACE IL:COMMA
 IL:COMMENTFLG IL:COMMENTFONT IL:COMS IL:COMTAIL IL:CONCAT IL:CONCATLIST IL:CONSTANT IL:CONSTANTS 
IL:CONTROL IL:COPY IL:COPYALL IL:COPYRIGHT IL:COPYTERMTABLE IL:CR IL:CREATE IL:CREATE.EVENT 
IL:CREATE.MONITORLOCK IL:CREATEREGION IL:CREATEW IL:CTRL IL:CTRLV IL:CURSORCREATE IL:DATATYPE IL:DATE 
IL:DATUM IL:DECLARATIONS\: IL:DECLARE\: IL:DEFAULTFONT IL:DEFINEQ IL:DEL IL:DESCENT IL:DOCOPY 
IL:DOEVAL@COMPILE IL:DON\'T IL:DONTCOPY IL:DONTEVAL@LOAD IL:DONTWAIT IL:DOWINDOWCOM IL:DREMOVE 
IL:DREVERSE IL:DSP IL:DSPCLIPPINGREGION IL:DSPFONT IL:DSPLINEFEED IL:DSPRIGHTMARGIN IL:DSPXOFFSET 
IL:DSPXPOSITION IL:DSPYOFFSET IL:|Definition-for-EDITDATE| IL:|Definition-for-EDITE| 
IL:|Definition-for-EDITL| IL:E IL:ECHOMODE IL:EDIT IL:EDITCHANGES IL:EDITFERROR IL:EDITGETD 
IL:EDITMACROS IL:EDITMODE IL:ENVIRONMENT IL:EOL IL:EQMEMB IL:ERSETQ IL:ESC IL:ESCAPE IL:ESCAPECHAR 
IL:EVAL@COMPILE IL:EVALV IL:EXPANDFN IL:EXPANDREGIONFN IL:EXPANDW IL:EXPR IL:EXTENT IL:FCHARACTER 
IL:FETCHFIELD IL:FILECREATED IL:FILEMAP IL:FILEPKGFLG IL:FILES IL:FILESLOAD IL:FILETYPE IL:FIND.PROCESS
 IL:FIXEDITDATE IL:FIXP IL:FIXR IL:FLAG IL:FLAGBITS IL:FLASHWINDOW IL:FLENGTH IL:FM.CHANGELABEL 
IL:FM.CHANGESTATE IL:FM.DONTRESHAPE IL:FM.EDITITEM IL:FM.GETITEM IL:FM.ITEMPROP IL:FM.RESETMENU IL:FMEMB
 IL:FN IL:FNS IL:FONT IL:FONTCREATE IL:FONTPROP IL:FORM IL:FORWORD IL:FREEMENU IL:FREPLACEFIELDVAL 
IL:FULLXPOINTER IL:FUNCTIONS IL:GACHA IL:GETD IL:GETDEF IL:GETDESCRIPTORS IL:GETPROMPTWINDOW IL:GETPROP
 IL:GETPROPLIST IL:GETREGION IL:GETSYNTAX IL:GLOBALVARS IL:GROUP IL:HALF IL:HEIGHT IL:HEIGHTIFWINDOW 
IL:HELVETICA IL:ICON IL:ICONWINDOW IL:ID IL:IDIFFERENCE IL:IFWORD IL:IGEQ IL:IGREATERP IL:ILEQ IL:ILESSP
 IL:IMAX IL:IMIN IL:IMINUS IL:IN/SCROLL/BAR? IL:INNERESCQUOTE IL:INFOHOOK IL:INITRECORDS IL:INITVARS 
IL:INPUT IL:INSIDEP IL:INTERPRESS IL:INVERT IL:IPLUS IL:IQUOTIENT IL:ITALICFONT IL:ITEM IL:ITEMS 
IL:ITEMWIDTH IL:ITIMES IL:KEYACTION IL:KEYACTIONTABLE IL:KEYBOARDSTREAM IL:KEYDOWNP IL:KWOTE IL:L 
IL:L-CASE IL:LABEL IL:LASTMOUSESTATE IL:LASTMOUSEX IL:LASTMOUSEY IL:LCONC IL:LEFT IL:LEFTBRACKET 
IL:LEFTPAREN IL:LEQ IL:LINEDELETE IL:LINKS IL:LISTGET IL:LISTPUT IL:LITATOM IL:LOCALCLOSE IL:LOCALVARS
 IL:LRSH IL:MACRO IL:MACROS IL:MAINWINDOW IL:MAKEFILE-ENVIRONMENT IL:MARKASCHANGED IL:MARKASCHANGEDFNS
 IL:MASK IL:MAXWIDTH IL:MEMB IL:MENU IL:MENUFONT IL:MENUOFFSET IL:MESS IL:MICASPERPT IL:MIDDLE 
IL:MKSTRING IL:MOUSE IL:MOUSECONFIRM IL:MOUSESTATE IL:MOVE IL:MOVETO IL:MULTESCAPECHAR 
IL:MULTIPLE-ESCAPE IL:NAME IL:NCHARS IL:NCONC1 IL:NEQ IL:NILL IL:NLAMBDA IL:NLISTP IL:NLSETQ IL:NOBIND
 IL:NONE IL:NOTIFY.EVENT IL:NTHCHARCODE IL:OBTAIN.MONITORLOCK IL:OFFST IL:OPENLAMBDA IL:OPENSTRINGSTREAM
 IL:OPENWP IL:P IL:PACKAGEDELIM IL:PAINT IL:POINTER IL:PRETTYCOMPRINT IL:PRIN2 IL:PROCESS 
IL:PROCESS.APPLY IL:PROCESS.EVAL IL:PROCESS.EVALV IL:PROCESSP IL:PROCESSPROP IL:PROCTYPEAHEAD 
IL:PROMPTFORWORD IL:PROMPTWINDOW IL:PROP IL:PROPLST IL:PROPS IL:PUTD IL:PUTDEF IL:PUTHASH IL:PUTPROP 
IL:PUTPROPS IL:QUOTIENT IL:READCODE IL:READP IL:READSA IL:RECORD IL:RECORDS IL:RECORDTRAN IL:REDISPLAYW
 IL:REGION IL:REJECTMAINCOMS IL:RELEASE.MONITORLOCK IL:RELMOVETO IL:REPAINTFN IL:REPLACEFIELDVAL 
IL:REPOSITIONATTACHEDWINDOWS IL:RESETLST IL:RESETSAVE IL:RESETVAR IL:RESHAPEFN IL:RESTARTABLE IL:RETFROM
 IL:RETYPE IL:RIGHT IL:RIGHTBRACKET IL:RIGHTBUTTONFN IL:RIGHTPAREN IL:ROWSPACE IL:RPAQ IL:RPAQ? IL:RPAQQ
 IL:RPLCHARCODE IL:RPLNODE2 IL:RPLSTRING IL:SCROLL.HANDLER IL:SCROLLBYREPAINTFN IL:SCROLLEXTENTUSE 
IL:SCROLLFN IL:SCROLLW IL:SELCHARQ IL:SELECTEDFN IL:SELECTQ IL:SEPRCHAR IL:SETFS IL:SETINTERRUPT 
IL:SETPROPLIST IL:SETSYNTAX IL:SETTERMTABLE IL:SHAPEW IL:SHIFT IL:SHIFTDOWNP IL:SHOULDNT IL:SHRINKFN 
IL:SMALLP IL:SMARTARGLIST IL:SP IL:SPECVARS IL:SPELLFILE IL:STATE IL:STKPOS IL:STREQUAL IL:STRINGDELIM
 IL:STRINGWIDTH IL:STRPOS IL:SUB1 IL:SUBSTRING IL:SYSRECORDS IL:SYSTEMRECLST IL:TAB IL:TABLE IL:TAIL 
IL:TCONC IL:TEDIT.INSERT IL:TEDIT.PARALOOKS IL:THIS.PROCESS IL:TIMES IL:TITLE IL:TITLEDICON 
IL:TITLEDICONW IL:TITLEREG IL:TOP IL:TOTOPW IL:TTY.PROCESS IL:TTY.PROCESSP IL:TTY/EDITDATE IL:TTY/EDITE
 IL:TTY/EDITL IL:TTY\: IL:TTYDISPLAYSTREAM IL:TTYEXITFN IL:TYPENAME IL:U-CASE IL:UNTILMOUSESTATE IL:UP
 IL:USEDFREE IL:VARIABLES IL:VARS IL:VARTYPE IL:WAIT.FOR.TTY IL:WHITESHADE IL:WIDTH IL:WINDOW 
IL:WINDOWADDPROP IL:WINDOWENTRYFN IL:WINDOWPROP IL:WINDOWREGION IL:WITH.MONITOR IL:WORD IL:WORDDELETE 
IL:WXOFFSET IL:WYOFFSET IL:X IL:Y IL:[ IL:\\\, IL:\\\,. IL:\\\,@ IL:\\ADDBASE IL:\\BACKGROUND IL:\\BLT
 IL:\\BLTCHAR IL:\\CARET.CREATE IL:\\CARET.DOWN IL:\\CARET.FLASH? IL:\\DEFAULTKEYACTION IL:\\DTEST 
IL:\\GETBASE IL:\\GETSYSBUF IL:\\KEYBOARD.STREAM IL:\\LINEBUF.OFD IL:\\PUTBASE IL:\\SAVEVMBACKGROUND 
IL:\\SYNCODE IL:] IL:^ IL:_ IL:ADD IL:ALWAYS IL:AS IL:BIND IL:BY IL:CHANGE IL:|changes| IL:COLLECT 
IL:COUNT IL:CREATE IL:|date:| IL:DO IL:EACHTIME IL:ELSE IL:ELSEIF IL:FETCH IL:FFETCH IL:FINALLY IL:FIRST
 IL:FOR IL:FREPLACE IL:FROM WHEN IL:IN IL:INSTRING IL:JOIN IL:LARGEST IL:NEVER IL:OF IL:OLD IL:ON 
IL:OUTOF IL:POP IL:|previous| IL:|printout| IL:PUSH IL:PUSHNEW IL:REPEATUNTIL IL:REPEATWHILE IL:REPLACE
 IL:SMALLEST IL:SUM IL:THEN IL:THEREIS IL:TO IL:|to:| IL:TYPE? IL:UNLESS IL:UNTIL IL:USING IL:WHEN 
IL:WHERE IL:WHILE IL:WITH IL:{ IL:})))
(IL:|printout| T T "EXPORTS.ALL must be loaded to compile SEdit" T)
(IL:|printout| T T "SEDIT-ACCESS must be REMADE NEW if you change a record" T)
(IL:PUTPROPS IL:SEDIT-DECLS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 1993))
NIL
\ No newline at end of file
diff --git a/CLTL2/SEDIT-EXPORTS b/CLTL2/SEDIT-EXPORTS
new file mode 100644
index 00000000..04cf0282
--- /dev/null
+++ b/CLTL2/SEDIT-EXPORTS
@@ -0,0 +1,60 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL)))
+(IL:FILECREATED " 8-Apr-92 21:50:30" IL:|{DSK}<usr>local>lde>lispcore>sources>SEDIT-EXPORTS.;2| 2475   
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:SEDIT-EXPORTSCOMS)
+
+      IL:|previous| IL:|date:| "17-May-90 11:01:36" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>SEDIT-EXPORTS.;1|)
+
+
+; Copyright (c) 1987, 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:SEDIT-EXPORTSCOMS)
+
+(IL:RPAQQ IL:SEDIT-EXPORTSCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-EXPORTS) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-EXPORTS) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:* IL:|;;| "REGION MANAGER") (IL:P (EXPORT (QUOTE (GET-WINDOW-REGION SAVE-WINDOW-REGION))) (EXPORT (QUOTE (KEEP-WINDOW-REGION)))) (IL:* IL:|;;| "PROGRAMMERS INTERFACE") (IL:P (EXPORT (QUOTE (SEDIT RESET ADD-COMMAND RESET-COMMANDS DEFAULT-COMMANDS GET-PROMPT-WINDOW GET-SELECTION REPLACE-SELECTION))) (EXPORT (QUOTE (*GETDEF-FN* *FETCH-DEFINITION-ERROR-BREAK-FLAG* *GETDEF-ERROR-FN* *EDIT-FN* *COMPILE-FN*)))) (IL:* IL:|;;| "OPTIONS") (IL:P (EXPORT (QUOTE (*CLEAR-LINEAR-ON-COMPLETION* *WRAP-SEARCH* *WRAP-PARENS* *POPULAR-PACKAGES* CONVERT-UPGRADE)))) (IL:* IL:|;;| "FORMATTING STUFF ") (IL:P (EXPORT (QUOTE (GET-FORMAT RESET-FORMATS DEF-LIST-FORMAT))) (EXPORT (QUOTE (*INDENT-ALIST*))))))
+
+(IL:PUTPROPS IL:SEDIT-EXPORTS IL:FILETYPE :COMPILE-FILE)
+
+(IL:PUTPROPS IL:SEDIT-EXPORTS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL))))
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(IL:FILESLOAD IL:SEDIT-DECLS)
+)
+
+
+
+(IL:* IL:|;;| "REGION MANAGER")
+
+
+(EXPORT (QUOTE (GET-WINDOW-REGION SAVE-WINDOW-REGION)))
+
+(EXPORT (QUOTE (KEEP-WINDOW-REGION)))
+
+
+
+(IL:* IL:|;;| "PROGRAMMERS INTERFACE")
+
+
+(EXPORT (QUOTE (SEDIT RESET ADD-COMMAND RESET-COMMANDS DEFAULT-COMMANDS GET-PROMPT-WINDOW GET-SELECTION REPLACE-SELECTION)))
+
+(EXPORT (QUOTE (*GETDEF-FN* *FETCH-DEFINITION-ERROR-BREAK-FLAG* *GETDEF-ERROR-FN* *EDIT-FN* *COMPILE-FN*)))
+
+
+
+(IL:* IL:|;;| "OPTIONS")
+
+
+(EXPORT (QUOTE (*CLEAR-LINEAR-ON-COMPLETION* *WRAP-SEARCH* *WRAP-PARENS* *POPULAR-PACKAGES* CONVERT-UPGRADE)))
+
+
+
+(IL:* IL:|;;| "FORMATTING STUFF ")
+
+
+(EXPORT (QUOTE (GET-FORMAT RESET-FORMATS DEF-LIST-FORMAT)))
+
+(EXPORT (QUOTE (*INDENT-ALIST*)))
+(IL:PUTPROPS IL:SEDIT-EXPORTS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/SEDIT-EXPORTS.DFASL b/CLTL2/SEDIT-EXPORTS.DFASL
new file mode 100644
index 00000000..b3222f15
Binary files /dev/null and b/CLTL2/SEDIT-EXPORTS.DFASL differ
diff --git a/CLTL2/SEDIT-LIST-FORMATS b/CLTL2/SEDIT-LIST-FORMATS
new file mode 100644
index 00000000..2ca28944
--- /dev/null
+++ b/CLTL2/SEDIT-LIST-FORMATS
@@ -0,0 +1,230 @@
+(DEFINE-FILE-INFO PACKAGE "SEDIT" READTABLE "XCL" BASE 10)
+(IL:FILECREATED "24-Mar-92 14:06:32" IL:|{DSK}<usr>local>lde>lispcore>sources>SEDIT-LIST-FORMATS.;2| 8527   
+
+      IL:|changes| IL:|to:|  (IL:SEDIT-FORMATS CL:LOCALLY) (IL:VARS IL:SEDIT-LIST-FORMATSCOMS)
+
+      IL:|previous| IL:|date:| "17-May-90 11:08:07" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>SEDIT-LIST-FORMATS.;1|)
+
+
+; Copyright (c) 1987, 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:SEDIT-LIST-FORMATSCOMS)
+
+(IL:RPAQQ IL:SEDIT-LIST-FORMATSCOMS ((IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:SEDIT-LIST-FORMATS) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-INDENT)) (IL:SEDIT-FORMATS RETURN-FROM THROW BLOCK (IL:* IL:|;;| "some handy formats under names we don't expect to find as CAR of form") :DEFAULT :DATA :BINDING :BINDING-LIST :LAMBDA-LIST :FBINDING :FBINDING-LIST :COND-CLAUSE :CASE-CLAUSE :HORIZONTAL :HORIZONTAL-NOBREAK :VERTICAL :VERTICAL-NOBREAK :KEYWORD-ARGS :KEYWORD-ARGS-NOBREAK :SQUASHED :DEDIT) (IL:SEDIT-FORMATS (IL:* IL:|;;| "special forms & macros") AND CASE CATCH CCASE CERROR COMPILER-LET COND CTYPECASE DECLARE DEFCOMMAND DEFCONSTANT DEFDEFINER DEFUN DEFINE-SPECIAL-FORM DEFINLINE DEFGLOBALVAR DEFGLOBALPARAMETER DEF-LIST-FORMAT DEFMACRO DEFOPTIMIZER DEFPACKAGE DEFPARAMETER DEFSETF DEFSTRUCT DEFTYPE DEFVAR DESTRUCTURING-BIND DO DO* DOLIST DOTIMES DO-ALL-SYMBOLS DO-EXTERNAL-SYMBOLS DO-INTERNAL-SYMBOLS DO-LOCAL-SYMBOLS DO-SYMBOLS ECASE ERROR ETYPECASE EVAL-WHEN FLET FORMAT IF IGNORE-ERRORS LABELS LAMBDA IL:LAMBDA LET LET* LOCALLY CL:LOCALLY LIST LIST* MACROLET MULTIPLE-VALUE-BIND MULTIPLE-VALUE-SETQ IL:NLAMBDA IL:OPENLAMBDA OR IL:P PROCEED-CASE PROG PROG* PROGN PROGV RESTART-CASE IL:SELCHARQ IL:SELECTQ TAGBODY THE TYPECASE UNDOABLY UNLESS UNWIND-PROTECT WHEN WITH-INPUT-FROM-STRING WITH-OUTPUT-TO-STRING WITH-OPEN-FILE WITH-OPEN-STREAM IL:WITH.MONITOR IL:WITH.FAST.MONITOR IL:WITH.SPY)))
+
+(IL:PUTPROPS IL:SEDIT-LIST-FORMATS IL:FILETYPE :COMPILE-FILE)
+
+(IL:PUTPROPS IL:SEDIT-LIST-FORMATS IL:MAKEFILE-ENVIRONMENT NIL)
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(IL:FILESLOAD IL:SEDIT-INDENT)
+)
+
+(DEF-LIST-FORMAT RETURN-FROM CATCH)
+
+(DEF-LIST-FORMAT THROW CATCH)
+
+(DEF-LIST-FORMAT BLOCK CATCH)
+
+(DEF-LIST-FORMAT :DEFAULT "Used for lists whose CAR has no specified format." :INDENT :HORIZONTAL-ATOM :INLINE T)
+
+(DEF-LIST-FORMAT :DATA "Used for quoted (not backquoted) lists." :INDENT :DATA :ARGS (:RECURSIVE) :INLINE T)
+
+(DEF-LIST-FORMAT :BINDING :INDENT :BINDING :INLINE T)
+
+(DEF-LIST-FORMAT :BINDING-LIST :INDENT :BINDING-LIST :ARGS (:BINDING) :INLINE NIL)
+
+(DEF-LIST-FORMAT :LAMBDA-LIST :INDENT :LAMBDA-LIST :ARGS (:BINDING) :INLINE T)
+
+(DEF-LIST-FORMAT :FBINDING :INDENT (:NOBREAK 1) :ARGS (NIL :LAMBDA-LIST NIL) :SUBLISTS (2))
+
+(DEF-LIST-FORMAT :FBINDING-LIST :INDENT :BINDING-LIST :ARGS (:FBINDING))
+
+(DEF-LIST-FORMAT :COND-CLAUSE :INDENT :COND-CLAUSE :INLINE T)
+
+(DEF-LIST-FORMAT :CASE-CLAUSE :INDENT :COND-CLAUSE :ARGS (:DATA NIL) :SUBLISTS (1) :INLINE T)
+
+(DEF-LIST-FORMAT :HORIZONTAL :INDENT :HORIZONTAL :INLINE T)
+
+(DEF-LIST-FORMAT :HORIZONTAL-NOBREAK :INDENT :HORIZONTAL :INLINE T :MISER :NEVER)
+
+(DEF-LIST-FORMAT :VERTICAL :INDENT :VERTICAL :INLINE T)
+
+(DEF-LIST-FORMAT :VERTICAL-NOBREAK :INDENT :VERTICAL :INLINE T :MISER :NEVER)
+
+(DEF-LIST-FORMAT :KEYWORD-ARGS :INDENT :KEYWORD-ARG :INLINE T)
+
+(DEF-LIST-FORMAT :KEYWORD-ARGS-NOBREAK :INDENT :KEYWORD-ARG :INLINE T :MISER :NEVER)
+
+(DEF-LIST-FORMAT :SQUASHED :INDENT :SQUASH :INLINE T)
+
+(DEF-LIST-FORMAT :DEDIT :SQUASHED)
+
+(DEF-LIST-FORMAT AND :INDENT :VERTICAL :MISER :NEVER :INLINE T)
+
+(DEF-LIST-FORMAT CASE :INDENT (1) :ARGS (NIL NIL :CASE-CLAUSE) :SUBLISTS T)
+
+(DEF-LIST-FORMAT CATCH :INDENT (1) :ARGS (:KEYWORD NIL) :INLINE T)
+
+(DEF-LIST-FORMAT CCASE CASE)
+
+(DEF-LIST-FORMAT CERROR FORMAT)
+
+(DEF-LIST-FORMAT COMPILER-LET LET)
+
+(DEF-LIST-FORMAT COND :INDENT :VERTICAL :ARGS (NIL :COND-CLAUSE) :SUBLISTS T)
+
+(DEF-LIST-FORMAT CTYPECASE TYPECASE)
+
+(DEF-LIST-FORMAT DECLARE :INDENT :VERTICAL :ARGS (:KEYWORD :HORIZONTAL) :SUBLISTS T)
+
+(DEF-LIST-FORMAT DEFCOMMAND DEFUN)
+
+(DEF-LIST-FORMAT DEFCONSTANT DEFVAR)
+
+(DEF-LIST-FORMAT DEFDEFINER :INDENT ((2) 1) :ARGS (:KEYWORD :CASE-CLAUSE NIL :LAMBDA-LIST NIL))
+
+(DEF-LIST-FORMAT DEFUN :INDENT ((2)) :ARGS (:KEYWORD NIL :LAMBDA-LIST NIL) :SUBLISTS (3))
+
+(DEF-LIST-FORMAT DEFINE-SPECIAL-FORM DEFUN)
+
+(DEF-LIST-FORMAT DEFINLINE DEFUN)
+
+(DEF-LIST-FORMAT DEFGLOBALVAR DEFVAR)
+
+(DEF-LIST-FORMAT DEFGLOBALPARAMETER DEFVAR)
+
+(DEF-LIST-FORMAT DEF-LIST-FORMAT :INDENT (1) :ARGS (:KEYWORD NIL) :INLINE T)
+
+(DEF-LIST-FORMAT DEFMACRO DEFUN)
+
+(DEF-LIST-FORMAT DEFOPTIMIZER (IL:* IL:|;;;| "note: this loses in the case where OPT-NAME is specified in DEFOPTIMIZER form because we can't handle optional arguments at this level.  we could go through the pain of writing a custom indent spec...") DEFUN)
+
+(DEF-LIST-FORMAT DEFPACKAGE :INDENT (1) :ARGS (:KEYWORD NIL :CASE-CLAUSE) :INLINE NIL)
+
+(DEF-LIST-FORMAT DEFPARAMETER DEFVAR)
+
+(DEF-LIST-FORMAT DEFSETF :INDENT ((3)) :ARGS (:KEYWORD NIL :LAMBDA-LIST :BINDING NIL) :SUBLISTS (3 4))
+
+(DEF-LIST-FORMAT DEFSTRUCT :INDENT (1) :ARGS (:KEYWORD NIL))
+
+(DEF-LIST-FORMAT DEFTYPE DEFMACRO)
+
+(DEF-LIST-FORMAT DEFVAR :INDENT (1) :ARGS (:KEYWORD NIL) :INLINE T)
+
+(DEF-LIST-FORMAT DESTRUCTURING-BIND :INDENT (1 1) :ARGS (:KEYWORD :LAMBDA-LIST NIL) :INLINE NIL)
+
+(DEF-LIST-FORMAT DO :INDENT (:TAGBODY 2) :ARGS (:KEYWORD :BINDING-LIST :COND-CLAUSE NIL) :SUBLISTS (2 3))
+
+(DEF-LIST-FORMAT DO* DO)
+
+(DEF-LIST-FORMAT DOLIST :INDENT (:TAGBODY :STEP 1) :ARGS (:KEYWORD :BINDING NIL) :SUBLISTS (2))
+
+(DEF-LIST-FORMAT DOTIMES DOLIST)
+
+(DEF-LIST-FORMAT DO-ALL-SYMBOLS DOLIST)
+
+(DEF-LIST-FORMAT DO-EXTERNAL-SYMBOLS DOLIST)
+
+(DEF-LIST-FORMAT DO-INTERNAL-SYMBOLS DOLIST)
+
+(DEF-LIST-FORMAT DO-LOCAL-SYMBOLS DOLIST)
+
+(DEF-LIST-FORMAT DO-SYMBOLS DOLIST)
+
+(DEF-LIST-FORMAT ECASE CASE)
+
+(DEF-LIST-FORMAT ERROR FORMAT)
+
+(DEF-LIST-FORMAT ETYPECASE TYPECASE)
+
+(DEF-LIST-FORMAT EVAL-WHEN :INDENT (1) :SUBLISTS (2))
+
+(DEF-LIST-FORMAT FLET :INDENT (1) :ARGS (:KEYWORD :FBINDING-LIST NIL) :SUBLISTS (2))
+
+(DEF-LIST-FORMAT FORMAT :INDENT :HORIZONTAL :INLINE T)
+
+(DEF-LIST-FORMAT IF :INDENT (2) :INLINE T)
+
+(DEF-LIST-FORMAT IGNORE-ERRORS UNDOABLY)
+
+(DEF-LIST-FORMAT LABELS FLET)
+
+(DEF-LIST-FORMAT LAMBDA :INDENT (1) :ARGS (:KEYWORD :LAMBDA-LIST NIL) :INLINE T :SUBLISTS (2))
+
+(DEF-LIST-FORMAT IL:LAMBDA LAMBDA)
+
+(DEF-LIST-FORMAT LET :INDENT (1) :ARGS (:KEYWORD :BINDING-LIST NIL) :SUBLISTS (2) :MISER :NEVER)
+
+(DEF-LIST-FORMAT LET* LET)
+
+(DEF-LIST-FORMAT LOCALLY :INDENT (0) :ARGS (:KEYWORD NIL) :SUBLISTS T)
+
+(DEF-LIST-FORMAT CL:LOCALLY :INDENT (0) :ARGS (:KEYWORD NIL) :SUBLISTS T)
+
+(DEF-LIST-FORMAT LIST :INDENT :HORIZONTAL :INLINE T)
+
+(DEF-LIST-FORMAT LIST* LIST)
+
+(DEF-LIST-FORMAT MACROLET FLET)
+
+(DEF-LIST-FORMAT MULTIPLE-VALUE-BIND :INDENT (1 1) :ARGS (:KEYWORD :DATA NIL) :SUBLISTS (2))
+
+(DEF-LIST-FORMAT MULTIPLE-VALUE-SETQ :INDENT (1) :ARGS (NIL :DATA NIL) :SUBLISTS (2))
+
+(DEF-LIST-FORMAT IL:NLAMBDA LAMBDA)
+
+(DEF-LIST-FORMAT IL:OPENLAMBDA LAMBDA)
+
+(DEF-LIST-FORMAT OR AND)
+
+(DEF-LIST-FORMAT IL:P PROGN)
+
+(DEF-LIST-FORMAT PROCEED-CASE :INDENT (1) :ARGS (NIL :FBINDING))
+
+(DEF-LIST-FORMAT PROG :INDENT (:TAGBODY :STEP 1) :ARGS (:KEYWORD :BINDING-LIST NIL) :SUBLISTS (2))
+
+(DEF-LIST-FORMAT PROG* PROG)
+
+(DEF-LIST-FORMAT PROGN :INDENT :VERTICAL :INLINE NIL)
+
+(DEF-LIST-FORMAT PROGV :INDENT (1 1) :ARGS (:KEYWORD :DATA NIL) :SUBLISTS (2))
+
+(DEF-LIST-FORMAT RESTART-CASE :INDENT (1) :ARGS (NIL :FBINDING))
+
+(DEF-LIST-FORMAT IL:SELCHARQ IL:SELECTQ)
+
+(DEF-LIST-FORMAT IL:SELECTQ :INDENT (1) :ARGS (:KEYWORD NIL :CASE-CLAUSE) :LAST NIL)
+
+(DEF-LIST-FORMAT TAGBODY :INDENT (:TAGBODY :STEP 0) :ARGS (:KEYWORD NIL))
+
+(DEF-LIST-FORMAT THE :INDENT (1) :ARGS (:KEYWORD NIL) :INLINE T)
+
+(DEF-LIST-FORMAT TYPECASE CASE)
+
+(DEF-LIST-FORMAT UNDOABLY :INDENT :VERTICAL :INLINE NIL :ARGS (:KEYWORD NIL))
+
+(DEF-LIST-FORMAT UNLESS :INDENT (1))
+
+(DEF-LIST-FORMAT UNWIND-PROTECT :INDENT (:BREAK 1))
+
+(DEF-LIST-FORMAT WHEN UNLESS)
+
+(DEF-LIST-FORMAT WITH-INPUT-FROM-STRING WITH-OPEN-STREAM)
+
+(DEF-LIST-FORMAT WITH-OUTPUT-TO-STRING WITH-OPEN-STREAM)
+
+(DEF-LIST-FORMAT WITH-OPEN-FILE WITH-OPEN-STREAM)
+
+(DEF-LIST-FORMAT WITH-OPEN-STREAM :INDENT (1) :ARGS (NIL :KEYWORD-ARGS NIL) :SUBLISTS (2))
+
+(DEF-LIST-FORMAT IL:WITH.MONITOR :INDENT (1))
+
+(DEF-LIST-FORMAT IL:WITH.FAST.MONITOR IL:WITH.MONITOR)
+
+(DEF-LIST-FORMAT IL:WITH.SPY IL:WITH.MONITOR)
+(IL:PUTPROPS IL:SEDIT-LIST-FORMATS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/SEDIT-LIST-FORMATS.DFASL b/CLTL2/SEDIT-LIST-FORMATS.DFASL
new file mode 100644
index 00000000..e354d85a
Binary files /dev/null and b/CLTL2/SEDIT-LIST-FORMATS.DFASL differ
diff --git a/CLTL2/SEDIT-TOPLEVEL b/CLTL2/SEDIT-TOPLEVEL
new file mode 100644
index 00000000..452277e7
--- /dev/null
+++ b/CLTL2/SEDIT-TOPLEVEL
@@ -0,0 +1,433 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "SEDIT" (USE "LISP" "XCL")))
+(IL:FILECREATED " 6-Jan-92 15:22:46" IL:|{DSK}<usr>local>lde>lispcore>sources>SEDIT-TOPLEVEL.;2| 34203  
+
+      IL:|changes| IL:|to:|  (IL:FNS COMPLETION) (IL:VARS IL:SEDIT-TOPLEVELCOMS) (IL:FUNCTIONS FIX-EDITDATE)
+
+      IL:|previous| IL:|date:| "10-Jul-91 19:11:12" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>SEDIT-TOPLEVEL.;1|)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:SEDIT-TOPLEVELCOMS)
+
+(IL:RPAQQ IL:SEDIT-TOPLEVELCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-TOPLEVEL) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-TOPLEVEL) (IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:INITVARS CONTEXTS REGIONS) (IL:VARS (IL:*DISPLAY-EDITOR* (QUOTE SEDIT))) (IL:FNS SEDIT RESET GET-WINDOW-REGION SAVE-WINDOW-REGION) (IL:FNS GET-CONTEXT DISINTEGRATE-CONTEXT AWAKE-COMMAND-PROCESS AWAKE-ME MARKASCHANGEDFN NEW-FUNCTION-BODY) (IL:FUNCTIONS QUERY-THROW-AWAY-CHANGES SET-OPTIONS SET-PROPS START-PROCESS) (IL:COMS (IL:* IL:|;;| "THESE CAN ALL BE NUKED WITH THE NEW EDIT INTERFACE AND A DETACHED TTY/EDITOR (WOZ 1/25/91)") (IL:PROP (IL:|Definition-for-EDITL| IL:|Definition-for-EDITE| IL:|Definition-for-EDITDATE|) SEDIT) (IL:FNS SEDITE SEDITL FN-CHANGED PROP-CHANGED PROPLST-CHANGED VAR-CHANGED ALIST-COMPLETION COMPLETION PROPS-COMPLETION TTYFN LOCATE-NODE-FROM-EDITCHAIN) (IL:* IL:|;;| "SEdit's hack way of fixing edit dates") (IL:FUNCTIONS FIX-EDITDATE) (IL:* IL:|;;| "Mess around with the tty editor's TTY: command by defining a hook and then making TTY: a macro which calls the hook.") (IL:FUNCTIONS SMART-TTYFN) (IL:P (PUSHNEW (QUOTE (IL:TTY\: NIL (IL:E (SMART-TTYFN) T))) IL:EDITMACROS :TEST (FUNCTION IL:EQUAL)))) (IL:FNS PRETTY-PRINT MAP-FONT) (IL:* IL:|;;| "these guys allow you to print and read structures with broken atoms and gaps.  just a convenience for the loser who forgets to get them out of his code.") (IL:FUNCTIONS MAKE-BROKEN-ATOM PRINT-BROKEN-ATOM MAKE-GAP PRINT-GAP) (IL:P (IL:DEFPRINT (QUOTE BROKEN-ATOM) (QUOTE PRINT-BROKEN-ATOM)) (IL:DEFPRINT (QUOTE GAP) (QUOTE PRINT-GAP)))))
+
+(IL:PUTPROPS IL:SEDIT-TOPLEVEL IL:FILETYPE :COMPILE-FILE)
+
+(IL:PUTPROPS IL:SEDIT-TOPLEVEL IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "SEDIT" (:USE "LISP" "XCL"))))
+(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
+
+(IL:LOCALVARS . T)
+)
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(IL:FILESLOAD IL:SEDIT-DECLS)
+)
+
+(IL:RPAQ? CONTEXTS NIL)
+
+(IL:RPAQ? REGIONS NIL)
+
+(IL:RPAQQ IL:*DISPLAY-EDITOR* SEDIT)
+(IL:DEFINEQ
+
+(SEDIT
+  (IL:LAMBDA (STRUCTURE PROPS OPTIONS)              (IL:* IL:\; "Edited 25-Jan-91 13:51 by woz")
+    (OR STRUCTURE (IL:SETQ STRUCTURE BASIC-GAP))
+    (LET* ((NAME (IL:LISTGET PROPS :NAME))
+           (TYPE (OR (IL:LISTGET PROPS :TYPE)
+                     :EXPRESSION))
+           (CONTEXT (GET-CONTEXT STRUCTURE NAME TYPE))
+           (WINDOW (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT)))
+          (SET-PROPS CONTEXT PROPS)
+          (SET-OPTIONS CONTEXT OPTIONS)
+          (COND
+             ((NULL WINDOW)
+
+              (IL:* IL:|;;| "this is a new context, needs to be setup from scratch")
+
+              (START-PROCESS CONTEXT NAME)
+              CONTEXT)
+             ((AND (IL:OPENWP WINDOW)
+                   (IL:PROCESSP (IL:WINDOWPROP WINDOW 'IL:PROCESS)))
+
+              (IL:* IL:|;;| "open and active")
+
+              (IL:TOTOPW WINDOW)
+              (WHEN (OR (NOT (EQ T (IL:|fetch| (EDIT-CONTEXT CHANGED-STRUCTURE?) IL:|of|
+                                                                                     CONTEXT)))
+                        (QUERY-THROW-AWAY-CHANGES NAME OPTIONS))
+
+                  (IL:* IL:|;;| 
+"there are no changes on this edit, or user said throw away changes, so we will restart this edit.")
+
+                  (IL:|replace| CHANGED-STRUCTURE? IL:|of| CONTEXT IL:|with| STRUCTURE)
+                  (IL:RESTART.PROCESS (IL:WINDOWPROP WINDOW 'IL:PROCESS))
+                  CONTEXT))
+             ((IL:OPENWP (IL:WINDOWPROP WINDOW 'IL:ICONWINDOW))
+
+              (IL:* IL:|;;| "shrunk")
+
+              (IL:|replace| CHANGED-STRUCTURE? IL:|of| CONTEXT IL:|with| STRUCTURE)
+              (IL:EXPANDW WINDOW)
+              CONTEXT)
+             (T 
+                (IL:* IL:|;;| "found a dead context.  get rid of it and try again.")
+
+                (DISINTEGRATE-CONTEXT CONTEXT)
+                (SEDIT STRUCTURE PROPS OPTIONS))))))
+
+(reset
+(il:lambda nil (il:* il:\; "Edited 10-Jul-87 08:35 by DCB") (cond (contexts (il:error "Can't reset SEdit while there are open SEdit windows")) (t (create-environments) (reset-formats) t)))
+)
+
+(get-window-region
+(il:lambda (context reason name type) (il:* il:\; "Edited 19-Nov-87 10:18 by DCB") (il:* il:|;;;| "called to get a region for this sedit window.  should return the region for the sedit including the prompt window.  context is being built and needs a window.  the context will have at least the name (IconTitle) and type (EditType) of the object being edited, and can be used as desired to map between contexts and windows.  If reason is :CREATE, then this function must return a region.  If :EXPAND, then this algorithm returns a region from the stack only if SEDIT.KEEP.WINDOW.REGION is nil, otherwise it returns NIL, telling the window system not to reshape on expansion.") (when (or (eq reason :create) (not keep-window-region)) (or (il:pop regions) (progn (il:|printout| il:promptwindow t "Select region for SEdit window.") (il:getregion 30 20)))))
+)
+
+(SAVE-WINDOW-REGION
+  (IL:LAMBDA (CONTEXT REASON NAME TYPE REGION)      (IL:* IL:\; "Edited 23-Nov-87 17:46 by DCB")
+
+(IL:* IL:|;;;| "Release this sedit windows region to be used again.  If we're shrinking, KEEP-WINDOW-REGION determines whether to release the region or not.  If an icon is being closed, don't release the region because it was handled appropriately when the window as shrunk.   remember, we're maintaining regions including the prompt window height, so use WINDOWREGION to get the whole region.")
+
+    (WHEN (OR (EQ REASON :CLOSE)
+              (AND (EQ REASON :SHRINK)
+                   (NOT KEEP-WINDOW-REGION)))
+        (IL:|push| REGIONS (OR REGION (IL:WINDOWREGION (IL:|fetch| DISPLAY-WINDOW
+                                                              IL:|of| CONTEXT)))))))
+)
+(IL:DEFINEQ
+
+(GET-CONTEXT
+  (IL:LAMBDA (STRUCTURE NAME TYPE SEARCH-ONLY?)     (IL:* IL:\; "Edited  5-Dec-90 13:00 by woz")
+
+(IL:* IL:|;;;| "we've been asked to get the edit context for a new edit.  if a context matching this description (same name and same type, or  EQ structure) already exists, we'll return it rather than creating a new one.  Also, if SEARCH-ONLY? is true then don't create a new one, just return NIL if not found.")
+
+    (IL:|bind| WINDOW IL:|for| CONTEXT IL:|in| CONTEXTS
+       IL:|when| (OR (AND NAME (EQUAL NAME (IL:|fetch| ICON-TITLE IL:|of| CONTEXT))
+                              (EQ TYPE (IL:|fetch| EDIT-TYPE IL:|of| CONTEXT)))
+                         (AND STRUCTURE (IL:|type?| EDIT-NODE (IL:|fetch| ROOT IL:|of|
+                                                                                       CONTEXT))
+                              (EQ STRUCTURE (IL:|fetch| STRUCTURE
+                                               IL:|of| (SUBNODE 1 (IL:|fetch| ROOT
+                                                                         IL:|of| CONTEXT))))))
+       IL:|do| 
+
+             (IL:* IL:|;;| "we found a context that matches,  return it.")
+
+             (RETURN CONTEXT)
+       IL:|finally| 
+
+             (IL:* IL:|;;| 
+           "this is a new editing task, so make an appropriate context and get it started")
+
+             (IF SEARCH-ONLY?
+                 (RETURN NIL)
+                 (LET ((CONTEXT (IL:|create| EDIT-CONTEXT
+                                       COMPLETION-EVENT IL:_ (IL:CREATE.EVENT (IL:CONCAT EDITOR-NAME
+                                                                                     NAME))
+                                       ROOT IL:_ STRUCTURE
+                                       ICON-TITLE IL:_ NAME
+                                       EDIT-TYPE IL:_ TYPE)))
+                      (PUSH CONTEXT CONTEXTS)
+                      (RETURN CONTEXT))))))
+
+(DISINTEGRATE-CONTEXT
+  (IL:LAMBDA (CONTEXT)                              (IL:* IL:\; "Edited  5-Dec-90 17:45 by woz")
+
+(IL:* IL:|;;;| "terminate this edit context.  we mark it as dead, remove it from the active edits list, smash the connections between the context and the window")
+
+    (WHEN CONTEXT
+        (IL:NOTIFY.EVENT (IL:|fetch| COMPLETION-EVENT IL:|of| CONTEXT))
+        (IL:|replace| CONTEXT-LOCK IL:|of| CONTEXT IL:|with| 'DEAD)
+        (IL:WINDOWPROP (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT)
+               'EDIT-CONTEXT NIL)
+        (IL:|replace| DISPLAY-WINDOW IL:|of| CONTEXT IL:|with| NIL)
+        (IL:SETQ CONTEXTS (IL:DREMOVE CONTEXT CONTEXTS)))))
+
+(AWAKE-COMMAND-PROCESS
+  (IL:LAMBDA (CONTEXT COMMAND)                      (IL:* IL:\; "Edited  5-Dec-90 16:52 by woz")
+
+    (IL:* IL:|;;| "if this context has a process associated with it, and the process is currently stuck waiting for input, unstick it so that it can look around and (presumably) notice some important change in its environment.  This is also called when someone in another process, such as a command menu or a window menu operation, wants to tell the command process to execute the command.  Note that under a few circumstances this function will be called by a running command in the sedit process.  For example, the complete-and-close command calls il:closew which calls sedit's closefn which tries to wake up the sedit to let it know the window was closed.  In this case, awake-command-porcess will result in a no-op because sedit has a command running, and therefore cannot be woken up.  COMMAND is a command form which will be used as the value returned from GETKEY in SEDIT1.  COMMAND should be of the form (<fn> <normalize?> <extra args>), so that <fn> will be applied to the context, the charcode invokeing the command (NIL in this case), and the extra args.  After the command runs the window will scroll to normalize the caret if <normalize?> is T.  If COMMAND is NIL then the SEdit will just update the window.")
+
+    (LET ((PROCESS (IL:WINDOWPROP (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT)
+                          'IL:PROCESS)))
+         (WHEN (IL:PROCESSP PROCESS)
+             (IL:PROCESS.APPLY PROCESS 'AWAKE-ME (LIST COMMAND))))))
+
+(awake-me
+(il:lambda (result) (il:* il:\; "Edited  7-Jul-87 12:59 by DCB") (il:* il:|;;| "this rather ugly little function checks to see if it's being called under getkey (presumably by PROCESS.APPLY from awake.command.process) and if so forces the getkey to return result") (let ((stack-frame (il:stkpos (quote getkey)))) (when stack-frame (il:retfrom stack-frame result t))))
+)
+
+(MARKASCHANGEDFN
+  (IL:LAMBDA (NAME TYPE REASON)                     (IL:* IL:\; "Edited  3-Apr-91 15:42 by jds")
+
+(IL:* IL:|;;;| "When a managed object is changed, we must check if we have an open edit on it.  If so, calling SEdit again, with the fresh definition, will  force the update.  This is fairly tricky, though.  Markaschanged is called as a result of editing a managed definition, so this markaschangedfn could be running in the sedit process under the completion-fn half way through completion.  IDEALLY in this case we could say \"i know it changed, i just changed it!\" and ignore this call.  BUT FOR NOW (1/14/91) since the manager can change the definition on completion (editdates, for one), we have to notify SEdit.  Since calling editdef will restart the sedit process, the completion-fn will not finish, so do the verify-structure here.")
+
+    (LET* ((FORM (IL:PROCESSPROP (IL:THIS.PROCESS)
+                        'IL:FORM))
+           CONTEXT)
+          (COND
+             ((AND (EQ (CAR FORM)
+                       'SEDIT1)
+                   (IL:|type?| EDIT-CONTEXT (SETQ CONTEXT (CADADR FORM)))
+                   (EQ NAME (IL:|fetch| ICON-TITLE IL:|of| CONTEXT))
+                   (EQ TYPE (IL:|fetch| EDIT-TYPE IL:|of| CONTEXT)))
+
+              (IL:* IL:|;;| "we're running under the edit that is completing")
+
+              (UNLESS *IGNORE-CHANGES-ON-COMPLETION*
+                  (VERIFY-STRUCTURE CONTEXT NIL (IL:GETDEF NAME TYPE NIL '(IL:EDIT IL:NOCOPY)))))
+             ((GET-CONTEXT NIL NAME TYPE T)
+
+              (IL:* IL:|;;| "found a matching context elsewhere")
+
+              (IL:EDITDEF NAME TYPE NIL NIL '(:DONTWAIT)))))))
+
+(new-function-body
+(il:lambda (dummy-body) (il:* il:\; "Edited  7-Jul-87 12:59 by DCB") (if (il:neq (il:editmode) (quote sedit)) (il:copy dummy-body) (list (quote il:lambda) args-gap body-gap)))
+)
+)
+
+(DEFUN QUERY-THROW-AWAY-CHANGES (NAME OPTIONS) (IL:* IL:|;;;| "this gets called when sedit is restarting because it got called again, but the structure doesn't match and changes have been made.  should we throw away the changes and restart with the new structure, or not restart and keep the changes?  ask the user.") (IF (IL:EQMEMB :DISPLAY OPTIONS) (IL:MENU (IL:|create| IL:MENU IL:ITEMS IL:_ (QUOTE (("Throw away changes and restart with new structure" T) ("Keep changes and don't restart with new structure" NIL))) IL:TITLE IL:_ (FORMAT NIL "An edit session with changes already exists for ~S" NAME))) (IF (EQ (QUOTE IL:Y) (IL:ASKUSER NIL NIL (FORMAT NIL "An edit session with changes already exists for ~S.  Throw away changes and restart with new structure? " NAME))) T)))
+
+(DEFUN SET-OPTIONS (CONTEXT OPTIONS) (IL:* IL:|;;;| "set up the OPTIONS provided in the call to SEDIT for this context.  Most of these options do not require immediate action.  Rather, they control how some command or interaction will work later, so we just store the option list in the context.  Most of these options are really edit-interface options, not sedit options.  We stash them so that when the *edit-fn* is called under M-O, it will be handed the same options that this edit was started with") (IL:REPLACE (EDIT-CONTEXT EDIT-OPTIONS) IL:OF CONTEXT IL:WITH (IF (LISTP OPTIONS) OPTIONS (LIST OPTIONS))))
+
+(DEFUN SET-PROPS (CONTEXT PROPS) (IL:* IL:|;;;| "go through the PROPS list supplied in the call to SEDIT and store the info in the context.  The :NAME and :TYPE props are already handled, because get-context uses this information to find an appropriate context.  Grab the current values of the variables that determine reading and printing, and save them in a profile in the context, so that later changes to the globals don't affect existing contexts. ") (IL:REPLACE (EDIT-CONTEXT COMPLETION-FN) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS :COMPLETION-FN) (FUNCTION NULL))) (IL:REPLACE (EDIT-CONTEXT ROOT-CHANGED-FN) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS :ROOT-CHANGED-FN) (FUNCTION NULL))) (IL:REPLACE (EDIT-CONTEXT ENVIRONMENT) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS :ENVIRONMENT) LISP-EDIT-ENVIRONMENT)) (IL:REPLACE (EDIT-CONTEXT PROFILE) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS :PROFILE) (SAVE-PROFILE (COPY-PROFILE "READ-PRINT")))) (IL:REPLACE (EDIT-CONTEXT EVAL-IN-PROCESS) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS :EVAL-IN-PROCESS) (EVAL-IN-PROCESS))) (IL:REPLACE (EDIT-CONTEXT EVAL-FN) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS :EVAL-FN) (XCL::PROFILE-ENTRY-VALUE (QUOTE *EVAL-FUNCTION*)))) (WHEN (IL:LISTGET PROPS :SELECT-STRUCTURE) (IL:REPLACE (EDIT-CONTEXT FIND-CANDIDATE) IL:OF CONTEXT IL:WITH (CONS (IL:LISTGET PROPS :SELECT-STRUCTURE) (OR (IL:LISTGET PROPS :SELECT-INSTANCE) 1)))))
+
+(DEFUN START-PROCESS (CONTEXT) (IL:* IL:|;;;| "the context is ready.  start the sedit process.  the rest of the initialization will happen in the sedit process, and the completion-event will be notified (by SEDIT1) when the sedit is initialized.") (LET ((NAME (IL:FETCH (EDIT-CONTEXT ICON-TITLE) IL:OF CONTEXT)) (EVENT (IL:|fetch| (EDIT-CONTEXT COMPLETION-EVENT) IL:|of| CONTEXT))) (IL:ADD.PROCESS (LIST (QUOTE SEDIT1) (IL:KWOTE CONTEXT)) (QUOTE IL:NAME) (IF NAME (IL:CONCAT EDITOR-NAME " " NAME) EDITOR-NAME)) (IL:|until| (EQ EVENT (IL:AWAIT.EVENT EVENT)))))
+
+
+
+(IL:* IL:|;;| 
+"THESE CAN ALL BE NUKED WITH THE NEW EDIT INTERFACE AND A DETACHED TTY/EDITOR (WOZ 1/25/91)")
+
+
+(IL:PUTPROPS SEDIT IL:|Definition-for-EDITL| SEDITL)
+
+(IL:PUTPROPS SEDIT IL:|Definition-for-EDITE| SEDITE)
+
+(IL:PUTPROPS SEDIT IL:|Definition-for-EDITDATE| IL:TTY/EDITDATE)
+(IL:DEFINEQ
+
+(SEDITE
+  (IL:LAMBDA (EXPR COMS ATOM TYPE IFCHANGEDFN OPTIONS)
+                                                        (IL:* IL:\; "Edited 10-Jul-91 19:04 by jds")
+
+(IL:* IL:|;;;| "Convert call to EDITE into sedit format (structure props options).  The completion-fn is determined based on TYPE, since the file manager isn't very consistent about IL:PROPLST and IL:ALIST.  Since EDITE is supposed to wait for completion, create a completion event which is notified by the completion-fn.  Also, if the top cons is changed, try to smash the completed structure into EXPR to provide eqness.")
+
+(IL:* IL:|;;;| "IDEALLY: this whole mess wouldn't exist- if il:putdef could handle il:proplst, etc, then completion could simply call putdef, not special case as it does here.")
+
+    (LET* ((EVENT (IL:CREATE.EVENT "SEDITE Completion"))
+           (NEW-EXPR)
+           (COMPLETION-FN
+            (OR (AND IL:FILEPKGFLG
+                     (IL:SELECTQ TYPE
+                           (IL:PROPLST (LET ((OLD-PROPS (IL:APPEND (IL:GETPROPLIST ATOM))))
+                                            #'(LAMBDA (CONTEXT STRUCTURE CHANGED?)
+                                                     (FUNCALL #'PROPS-COMPLETION CONTEXT STRUCTURE 
+                                                            CHANGED? ATOM IFCHANGEDFN OLD-PROPS)
+                                                     (SETQ NEW-EXPR STRUCTURE)
+                                                     (IL:NOTIFY.EVENT EVENT))))
+                           (IL:VARS (WHEN (IL:EQMEMB 'IL:ALIST (IL:GETPROP ATOM 'IL:VARTYPE))
+                                        (LET ((OLD-VAL (IL:MAPCAR (IL:FUNCTION CAR)
+                                                              (IL:EVALV ATOM))))
+                                             #'(LAMBDA (CONTEXT STRUCTURE CHANGED?)
+                                                      (FUNCALL #'ALIST-COMPLETION CONTEXT STRUCTURE 
+                                                             CHANGED? ATOM IFCHANGEDFN OLD-VAL)
+                                                      (SETQ NEW-EXPR STRUCTURE)
+                                                      (IL:NOTIFY.EVENT EVENT)))))
+                           NIL))
+                (AND ATOM TYPE #'(LAMBDA (CONTEXT STRUCTURE CHANGED?)
+                                        (FUNCALL #'COMPLETION CONTEXT STRUCTURE CHANGED? ATOM TYPE 
+                                               IFCHANGEDFN)
+                                        (SETQ NEW-EXPR STRUCTURE)
+                                        (IL:NOTIFY.EVENT EVENT)))
+                #'(LAMBDA (CONTEXT STRUCTURE CHANGED?)
+                         (SETQ NEW-EXPR STRUCTURE)
+                         (IL:NOTIFY.EVENT EVENT))))
+           (ROOT-CHANGED-FN (IL:SELECTQ TYPE
+                                  (IL:PROPLST (LIST (IL:FUNCTION PROPLST-CHANGED)
+                                                    ATOM))
+                                  (IL:VARS (LIST (IL:FUNCTION VAR-CHANGED)
+                                                 ATOM))
+                                  (IL:FNS (LIST (IL:FUNCTION FN-CHANGED)
+                                                ATOM))
+                                  NIL)))
+          (COND
+             (COMS (IL:TTY/EDITE EXPR COMS ATOM TYPE IFCHANGEDFN OPTIONS))
+             (T (WHEN (AND IL:FILEPKGFLG (OR IL:CLISPARRAY (PROGN (IL:CLISPTRAN (CONS)
+                                                                         (CONS))
+                                                                  IL:CLISPARRAY)))
+                    (IL:SELECTQ TYPE
+                          (IL:PROPLST (IL:|for| X IL:|in| (IL:GETPROPLIST ATOM)
+                                         IL:|unless| (OR (IL:NLISTP X)
+                                                             (IL:GETHASH X IL:CLISPARRAY))
+                                         IL:|do| (IL:PUTHASH X (CONS (CAR X)
+                                                                         (CDR X))
+                                                            IL:CLISPARRAY)))
+                          (IL:VARS (WHEN (IL:EQMEMB 'IL:ALIST (IL:GETPROP ATOM 'IL:VARTYPE))
+                                       (IL:|for| X IL:|in| (IL:EVALV ATOM)
+                                          IL:|unless| (OR (IL:NLISTP X)
+                                                              (IL:GETHASH X IL:CLISPARRAY))
+                                          IL:|do| (IL:PUTHASH X (CONS (CAR X)
+                                                                          (CDR X))
+                                                             IL:CLISPARRAY))))
+                          NIL))
+                (SEDIT EXPR (LIST :NAME ATOM :TYPE TYPE :COMPLETION-FN COMPLETION-FN 
+                                      :ROOT-CHANGED-FN ROOT-CHANGED-FN)
+                       OPTIONS)
+                (UNLESS (IL:EQMEMB :DONTWAIT OPTIONS)
+                    (IL:|until| (EQ EVENT (IL:AWAIT.EVENT EVENT))))
+
+                (IL:* IL:|;;| "EDITE is for side effects (but we return the correct structure anyway.  If the user replaced the top cons, smash the new structure into it.  Have to copy the new structure in this case because, if the user wrapped the top cons, smashing into it will result in a circular list.  Additionally, if there is an sedit root-changed-fn, assume the caller handled the root change then, and eqness is not necessary.")
+
+                (IF (OR (EQ NEW-EXPR EXPR)
+                        ROOT-CHANGED-FN
+                        (NOT (CONSP EXPR))
+                        (NOT (CONSP NEW-EXPR)))
+                    NEW-EXPR
+                    (IL:RPLNODE2 EXPR (COPY-TREE NEW-EXPR))))))))
+
+(SEDITL
+  (IL:LAMBDA (EDITEXPR EDITCOMS ATOM MESSAGE EDITCHANGES)
+                                                        (IL:* IL:\; "Edited 25-Jan-91 13:45 by woz")
+    (DECLARE (SPECIAL TYPE))
+
+(IL:* IL:|;;;| "this is SEdit's definition for  EDITL.  if there are no COMS (normal case) we start an interactive SEdit.  otherwise, we run the TTY editor to execute the coms, and arrange to start an SEdit if it stops for input.")
+
+    (COND
+       (EDITCOMS 
+
+              (IL:* IL:|;;| "used to push stuff on il:editmacros, now we bind il:ttyeditfn")
+
+              (IL:* IL:|;;| "(il:resetvar il:editmacros (cons '(il:tty\\: nil (il:e (ttyfn il:atm type) t)) il:editmacros) (il:tty/editl editexpr editcoms atom message editchanges))")
+
+              (LET ((IL:TTYEDITFN #'(LAMBDA NIL (TTYFN ATOM TYPE))))
+                   (DECLARE (SPECIAL IL:TTYEDITFN))
+                   (IL:TTY/EDITL EDITEXPR EDITCOMS ATOM MESSAGE EDITCHANGES)))
+       (T (SEDIT (CAR EDITEXPR)
+                 (LIST :NAME ATOM :TYPE (AND (BOUNDP 'TYPE)
+                                             TYPE)))
+          EDITEXPR))))
+
+(fn-changed
+(il:lambda (structure atom) (il:* il:\; "Edited  7-Jul-87 12:59 by DCB") (cond ((not (il:ccodep (il:getd atom))) (il:putd atom structure)) ((il:listp (il:getprop atom (quote il:expr))) (il:putprop atom (quote il:expr) structure)) (t (il:shouldnt "where did this come from?"))))
+)
+
+(prop-changed
+(il:lambda (structure atom) (il:* il:\; "Edited  7-Jul-87 12:59 by DCB") (il:putprop atom (quote il:expr) structure))
+)
+
+(proplst-changed
+(il:lambda (structure atom) (il:* il:\; "Edited  7-Jul-87 12:59 by DCB") (il:setproplist atom structure))
+)
+
+(var-changed
+(il:lambda (structure atom) (il:* il:\; "Edited  7-Jul-87 12:59 by DCB") (set atom structure)))
+
+(alist-completion
+(il:lambda (context structure changed? atom ifchangedfn old-keys) (il:* il:\; "Edited 18-Jan-88 15:43 by woz") (when (eq changed? t) (il:* il:|;;| "don't do anything if changed is NIL or :ABORT ") (let (found-change old-value) (il:for x il:in old-keys il:unless (il:assoc x structure) il:do (il:markaschanged (list atom x) (quote il:alists) nil) (il:setq found-change t)) (il:for x il:in structure il:when (and (il:listp x) (not (and il:clisparray (il:setq old-value (il:gethash x il:clisparray)) (eq (car x) (car old-value)) (eq (cdr x) (cdr old-value))))) il:do (il:puthash x nil il:clisparray) (il:markaschanged (list atom (car x)) (quote il:alists) nil) (il:setq found-change t)) (when (not found-change) (completion context structure changed? atom (quote il:alists) ifchangedfn)))))
+)
+
+(COMPLETION
+(IL:LAMBDA (CONTEXT STRUCTURE CHANGED? ATOM TYPE IFCHANGEDFN) (IL:* IL:\; "Edited  3-Jan-92 14:11 by jrb:") (IF (OR (NOT CHANGED?) (EQ CHANGED? :ABORT)) NIL (PROGN (FIX-EDITDATE CONTEXT STRUCTURE TYPE) (COND ((EQ TYPE (QUOTE IL:FNS)) (IL:PUTDEF ATOM TYPE STRUCTURE) (IL:* IL:|;;| "(if  (CCODEP (GETD atom)) then (if (NEQ structure (GETPROP atom (QUOTE EXPR))) then (SHOULDNT 'where did this come from?') else (if (OR (EQ DFNFLG (QUOTE PROP)) (EQ DFNFLG (QUOTE ALLPROP))) then (SETQ message ' NOT unsaved.') else (UNSAVEDEF atom) (SETQ message ' unsaved.')) (if (OPENWP (fetch DisplayWindow of context)) then (printout (get.prompt.window context) atom message) else (* ;  'window was closed.  msg in promptwindow.') (printout PROMPTWINDOW T atom message))) else (if (NEQ structure (GETD atom)) then (if (NULL (GETD atom)) then (PUTD atom structure) else (SHOULDNT 'where did this come from?'))))")) (IFCHANGEDFN (IL:* IL:|;;| "this is a bit wrong:  the doc for edite says the ifchangedfn gets called with the last arg NIL if the editor is aborted.  But we don't call the ifchangedfn at all if the user did an abort command.  The idea is that ABORT is implemented as \"don't install even if changes we're made\"") (FUNCALL IFCHANGEDFN ATOM STRUCTURE TYPE T)) ((IL:NEQ TYPE (QUOTE IL:PROPLST)) (IL:MARKASCHANGED ATOM TYPE))))) (WHEN (AND (IL:LITATOM ATOM) IL:ADDSPELLFLG) (IL:ADDSPELL ATOM)))
+)
+
+(props-completion
+(il:lambda (context structure changed? atom ifchangedfn oldprops) (il:* il:\; "Edited 20-Apr-88 11:39 by woz") (when (eq changed? t) (il:* il:|;;| "don't do anything if changed? is NIL or :ABORT") (il:bind old-value found-one il:for new-prop il:on (il:getproplist atom) il:by (cddr new-prop) il:unless (il:for old-prop il:on oldprops il:by (cddr old-prop) il:when (eq (car old-prop) (car new-prop)) il:do (return (and (eq (cadr old-prop) (cadr new-prop)) (or (il:nlistp (cadr old-prop)) (and il:clisparray (il:setq old-value (il:gethash (cadr new-prop) il:clisparray)) (eq (caadr new-prop) (car old-value)) (eq (cdadr new-prop) (cdr old-value)) (or (il:puthash (cadr new-prop) nil il:clisparray) t)))))) il:do (il:markaschanged (list atom (car new-prop)) (quote il:props) nil) (il:setq found-one t))))
+)
+
+(TTYFN
+  (IL:LAMBDA (ATM TYPE)                             (IL:* IL:\; "Edited 21-Jan-91 12:02 by woz")
+    (DECLARE (SPECIAL IL:L IL:EDITCHANGES))
+
+    (IL:* IL:|;;| "this is a replacement for the TTY editor's TTY: command, which starts an SEdit process to do interactive editing for a while.  it uses the TTY editor's edit chain to determine the initial selection in the structure, and scrolls the window to make sure the selection's visible.  it then waits until the user signals that they've done enough editing (usually by closing or shrinking the window)")
+
+    (LET* ((EDIT-CHANGES IL:EDITCHANGES)
+           (EVENT (IL:CREATE.EVENT "SEdit TTYFN Completion"))
+           (COMPLETION-FN #'(LAMBDA (CONTEXT STRUCTURE CHANGED?)
+                                   (WHEN (EQ CHANGED? T)
+                                       (RPLACA (CDR EDIT-CHANGES)
+                                              T))
+                                   (IL:NOTIFY.EVENT EVENT)))
+           (CONTEXT (SEDIT (CAR (LAST IL:L))
+                           (LIST :NAME ATM :TYPE TYPE :COMPLETION-FN COMPLETION-FN)))
+           NODE)
+          (IL:WITH.MONITOR (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT)
+              (WHEN (IL:SETQ NODE (LOCATE-NODE-FROM-EDITCHAIN IL:L (IL:|fetch| ROOT
+                                                                          IL:|of| CONTEXT)))
+                  (SELECTION-DOWN CONTEXT)
+                  (SELECT-NODE CONTEXT NODE)
+                  (SET-POINT-NOWHERE (IL:|fetch| CARET-POINT IL:|of| CONTEXT))
+                  (NORMALIZE-SELECTION CONTEXT)
+                  (SELECTION-UP CONTEXT)))
+
+          (IL:* IL:|;;| "let the user do their editing, then signal completion, before we return")
+
+          (IL:|until| (EQ EVENT (IL:AWAIT.EVENT EVENT))))))
+
+(locate-node-from-editchain
+(il:lambda (chain root) (il:* il:\; "Edited 17-Nov-87 11:27 by DCB") (il:* il:|;;;| "when SEdit is called under the TTY editor, it gets an edit chain to determine the initial selection.  this process finds the node that editchain refers to (or returns NIL if no such node exists)") (if (null chain) root (il:for subnode il:in (cdr (il:fetch sub-nodes il:of (locate-node-from-editchain (cdr chain) root))) il:thereis (eq (il:fetch structure il:of subnode) (car chain)))))
+)
+)
+
+
+
+(IL:* IL:|;;| "SEdit's hack way of fixing edit dates")
+
+
+(DEFUN FIX-EDITDATE (CONTEXT STRUCTURE TYPE) (IL:* IL:\; "Edited  3-Jan-92 14:24 by jrb:") (IL:* IL:|;;| "If we can find an :EDITDATE-OFFSET, look for an editdate comment at that offset, and smash or insert one appropriately") (LET ((OFFSET (COND ((EQ TYPE (QUOTE FNS)) 2) ((GET TYPE :DEFINED-BY) (GET (CAR STRUCTURE) :EDITDATE-OFFSET)))) NEWDATESTRING) (WHEN (AND IL:INITIALS OFFSET) (SETQ NEWDATESTRING (IL:CONCAT "Edited " (IL:DATE (IL:DATEFORMAT IL:NO.SECONDS)) " by " IL:INITIALS)) (IF (IL:EDITDATE? (NTH OFFSET STRUCTURE)) (LET ((EDITDATE-NODE (SUBNODE (1+ OFFSET) (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT))))) (REPLACE-NODE CONTEXT EDITDATE-NODE (PARSE-NEW (IL:BQUOTE (IL:* IL:\; (IL:\\\, NEWDATESTRING))) CONTEXT))) (LET ((POINT (IL:CREATE EDIT-POINT POINT-NODE IL:_ (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT)) POINT-INDEX IL:_ OFFSET POINT-TYPE IL:_ (QUOTE STRUCTURE)))) (INSERT POINT CONTEXT (PARSE-NEW (IL:BQUOTE (IL:* IL:\; (IL:\\\, NEWDATESTRING))) CONTEXT)))) (IL:* IL:|;;| "This looks bogus, BUT: we just changed the structure in mid-editor-shutdown, so we need to tell SEdit that we really didn't mean it, sort of...") (THROW-AWAY-CHANGES CONTEXT))))
+
+
+
+(IL:* IL:|;;| 
+"Mess around with the tty editor's TTY: command by defining a hook and then making TTY: a macro which calls the hook."
+)
+
+
+(DEFUN SMART-TTYFN NIL (IL:* IL:|;;;| "This is a replacement for the TTY editor's TTY: command, which is supposed to start up a TTY editor.  We first check to see if we're ") (DECLARE (SPECIAL IL:L IL:TTYEDITFN)) (IF (AND (BOUNDP (QUOTE IL:TTYEDITFN)) IL:TTYEDITFN) (FUNCALL IL:TTYEDITFN) (IL:EDITL0 IL:L NIL (QUOTE IL:TTY\:) (QUOTE IL:TTY\:))))
+
+(PUSHNEW (QUOTE (IL:TTY\: NIL (IL:E (SMART-TTYFN) T))) IL:EDITMACROS :TEST (FUNCTION IL:EQUAL))
+(IL:DEFINEQ
+
+(pretty-print
+(il:lambda (structure stream right-margin) (il:* il:\; "Edited  7-Jul-87 12:59 by DCB") (il:* il:|;;;| "with just a little hacking, SEdit can be used to prettyprint functions onto TEdit streams.  we make up a slightly weird context, and run the parser and linearizer each once.  stream is actually the textobj of the tedit stream.  note that right.margin is in micas (since that's the unit that interpress font widths are expressed in)") (or (boundp (quote pretty-print-env)) (create-pretty-print-env)) (let ((context (il:create edit-context display-window il:_ stream environment il:_ pretty-print-env current-x il:_ 0 comment-width il:_ (il:fixr (il:times 200 il:micasperpt)) comment-separation il:_ (il:fixr (il:times 30 il:micasperpt)))) (root (il:create edit-node node-type il:_ type-root sub-nodes il:_ (list 0) start-x il:_ 0 depth il:_ 0))) (il:replace current-node il:of context il:with root) (parse structure context) (compute-all-formats context nil) (linearize (subnode 1 root) context (il:fixr right-margin))))
+)
+
+(map-font
+(il:lambda (font env) (il:* il:\; "Edited 17-Nov-87 10:43 by DCB") (il:* il:|;;| "this is called when using the prettyprint environment, under output.string.  we have to map the font into something acceptable to TEDIT.INSERT (since interpress fonts confuse it)") (cond ((eq font (il:fetch default-font il:of env)) il:defaultfont) ((eq font (il:fetch keyword-font il:of env)) il:clispfont) ((eq font (il:fetch italic-font il:of env)) il:italicfont) ((eq font (il:fetch comment-font il:of env)) il:commentfont) ((eq font (il:fetch broken-atom-font il:of env)) il:boldfont) (t (il:shouldnt "unexpected font!"))))
+)
+)
+
+
+
+(IL:* IL:|;;| 
+"these guys allow you to print and read structures with broken atoms and gaps.  just a convenience for the loser who forgets to get them out of his code."
+)
+
+
+(DEFUN MAKE-BROKEN-ATOM (STRING) (IL:|create| BROKEN-ATOM ATOM-CHARS IL:_ STRING))
+
+(DEFUN PRINT-BROKEN-ATOM (BROKEN-ATOM STREAM X) (FORMAT STREAM "#.(~S ~S)" (QUOTE MAKE-BROKEN-ATOM) (IL:|fetch| ATOM-CHARS IL:|of| BROKEN-ATOM)) T)
+
+(DEFUN MAKE-GAP (ITEM) (IL:|create| GAP LINEAR-ITEM IL:_ ITEM))
+
+(DEFUN PRINT-GAP (GAP STREAM X) (FORMAT STREAM "#.(~S '~S)" (QUOTE MAKE-GAP) (IL:|fetch| LINEAR-ITEM IL:|of| GAP)) T)
+
+(IL:DEFPRINT (QUOTE BROKEN-ATOM) (QUOTE PRINT-BROKEN-ATOM))
+
+(IL:DEFPRINT (QUOTE GAP) (QUOTE PRINT-GAP))
+(IL:PUTPROPS IL:SEDIT-TOPLEVEL IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992
+))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL (2620 6532 (SEDIT 2633 . 4619) (RESET 4621 . 4822) (GET-WINDOW-REGION 4824 . 5701) (
+SAVE-WINDOW-REGION 5703 . 6530)) (6533 13194 (GET-CONTEXT 6546 . 8566) (DISINTEGRATE-CONTEXT 8568 . 
+9294) (AWAKE-COMMAND-PROCESS 9296 . 10889) (AWAKE-ME 10891 . 11274) (MARKASCHANGEDFN 11276 . 12990) (
+NEW-FUNCTION-BODY 12992 . 13192)) (16859 29863 (SEDITE 16872 . 22639) (SEDITL 22641 . 23786) (
+FN-CHANGED 23788 . 24083) (PROP-CHANGED 24085 . 24222) (PROPLST-CHANGED 24224 . 24352) (VAR-CHANGED 
+24354 . 24466) (ALIST-COMPLETION 24468 . 25279) (COMPLETION 25281 . 26688) (PROPS-COMPLETION 26690 . 
+27515) (TTYFN 27517 . 29355) (LOCATE-NODE-FROM-EDITCHAIN 29357 . 29861)) (31680 33365 (PRETTY-PRINT 
+31693 . 32736) (MAP-FONT 32738 . 33363)))))
+IL:STOP
diff --git a/CLTL2/SEDIT-TOPLEVEL.DFASL b/CLTL2/SEDIT-TOPLEVEL.DFASL
new file mode 100644
index 00000000..5e992199
Binary files /dev/null and b/CLTL2/SEDIT-TOPLEVEL.DFASL differ
diff --git a/CLTL2/TIME b/CLTL2/TIME
new file mode 100644
index 00000000..02792028
--- /dev/null
+++ b/CLTL2/TIME
@@ -0,0 +1,84 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
+(IL:FILECREATED "22-May-91 09:08:00" IL:|{DSK}<new>sources>lispcore>sources>TIME.;2| 11273  
+
+      IL:|previous| IL:|date:| "17-May-90 15:51:58" IL:|{DSK}<new>sources>lispcore>sources>TIME.;1|
+)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:TIMECOMS)
+
+(IL:RPAQQ IL:TIMECOMS ((IL:STRUCTURES STATS-OBJECT) (IL:FUNCTIONS %COPY-TIME-STATS %STATS-OBJECT-DIFFERENCE) (IL:FUNCTIONS %GET-TIMING-INFO TIME-CALL TIME) (IL:FUNCTIONS %CAPTURE-COUNTERS-BEFORE %CAPTURE-COUNTERS-AFTER TIME-FORMAT %PRINT-TIMING-ITEM %PRINT-TIMING-INFO) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %CAPTURE-BEFORE-STATS %CAPTURE-AFTER-STATS %MOVE-FIXP-FIELD)) (IL:SPECIAL-FORMS TIME) (IL:COMMANDS "TIME") (IL:* IL:|;;| "Interlisp Timeall function") (IL:FNS IL:TIMEALL) (IL:* IL:|;;| "file package stuff") (IL:PROP IL:FILETYPE TIME) (IL:PROP IL:MAKEFILE-ENVIRONMENT TIME) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T)) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML IL:TIMEALL) (IL:LAMA)))))
+
+(DEFSTRUCT (STATS-OBJECT (:TYPE LIST) (:COPIER NIL) (:PREDICATE NIL)) (ELAPSED-TIME (IL:CLOCK 0)) (TIME-BLOCK (IL:|create| IL:MISCSTATS)) (DATA-COUNTERS (MAKE-ARRAY (1+ IL:|\\MaxTypeNumber|) :ELEMENT-TYPE (QUOTE (SIGNED-BYTE 32)) :INITIAL-ELEMENT 0)) DATATYPES)
+
+(DEFUN %COPY-TIME-STATS (REFERENCE-BLOCK DESTINATION-BLOCK) (IL:* IL:|;;| "Copies various fields from one miscstats block to another. Both reference-block and destination-block should be unboxed hunks (made by (IL:create IL:miscstats)), but IL:\\\\miscstats is also a valid value for reference-block") (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:SWAPWAITTIME) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:GCTIME) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:PAGEFAULTS) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:SWAPWRITES) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:TOTALTIME) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:DISKIOTIME) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:NETIOTIME) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:DISKOPS) DESTINATION-BLOCK REFERENCE-BLOCK) DESTINATION-BLOCK)
+
+(DEFUN %STATS-OBJECT-DIFFERENCE (BEFORE AFTER) (IL:* IL:|;;| "puts the differences between the stat-object after and  stat-object before back into after.") (LET ((BEFORE-DATA-COUNTERS (STATS-OBJECT-DATA-COUNTERS BEFORE)) (BEFORE-TIME-BLOCK (STATS-OBJECT-TIME-BLOCK BEFORE)) (AFTER-DATA-COUNTERS (STATS-OBJECT-DATA-COUNTERS AFTER)) (AFTER-TIME-BLOCK (STATS-OBJECT-TIME-BLOCK AFTER))) (DOTIMES (I (LENGTH BEFORE-DATA-COUNTERS)) (DECF (AREF AFTER-DATA-COUNTERS I) (AREF BEFORE-DATA-COUNTERS I))) (DECF (STATS-OBJECT-ELAPSED-TIME AFTER) (STATS-OBJECT-ELAPSED-TIME BEFORE)) (DECF (IL:|fetch| (IL:MISCSTATS IL:SWAPWAITTIME) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:SWAPWAITTIME) IL:|of| BEFORE-TIME-BLOCK)) (DECF (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| BEFORE-TIME-BLOCK)) (DECF (IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| BEFORE-TIME-BLOCK)) (DECF (IL:|fetch| (IL:MISCSTATS IL:PAGEFAULTS) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:PAGEFAULTS) IL:|of| BEFORE-TIME-BLOCK)) (DECF (IL:|fetch| (IL:MISCSTATS IL:SWAPWRITES) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:SWAPWRITES) IL:|of| BEFORE-TIME-BLOCK)) (DECF (IL:|fetch| (IL:MISCSTATS IL:DISKOPS) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:DISKOPS) IL:|of| BEFORE-TIME-BLOCK)) AFTER))
+
+(DEFUN %GET-TIMING-INFO (TIMED-FUNCTION TIME-BEFORE TIME-AFTER &OPTIONAL (REPEAT 1)) (IL:* IL:|;;| "Side-effects TIME-BEFORE and TIME-AFTER. Returns the value (or values of TIMED-FUNCTION, and the timing-info in TIME-AFTER.") (LET ((VALUES NIL)) (%CAPTURE-BEFORE-STATS TIME-BEFORE) (DOTIMES (I (1- REPEAT)) (FUNCALL TIMED-FUNCTION)) (SETQ VALUES (MULTIPLE-VALUE-LIST (FUNCALL TIMED-FUNCTION))) (%CAPTURE-AFTER-STATS TIME-AFTER) (%STATS-OBJECT-DIFFERENCE TIME-BEFORE TIME-AFTER) (VALUES-LIST VALUES)))
+
+(DEFUN TIME-CALL (TIMED-FUNCTION &KEY (OUTPUT *TRACE-OUTPUT*) (TIMED-FORM NIL TIMED-FORM-P) (DATA-TYPES (IL:DATATYPES)) (REPEAT 1)) (LET ((VALUES NIL) (TIME-BEFORE (MAKE-STATS-OBJECT)) (TIME-AFTER (MAKE-STATS-OBJECT)) (TIME-DO-NOTHING (MAKE-STATS-OBJECT))) (IL:* IL:|;;| "Calibrate") (%GET-TIMING-INFO (FUNCTION (LAMBDA NIL NIL)) TIME-BEFORE TIME-DO-NOTHING) (SETQ VALUES (MULTIPLE-VALUE-LIST (%GET-TIMING-INFO TIMED-FUNCTION TIME-BEFORE TIME-AFTER REPEAT))) (%STATS-OBJECT-DIFFERENCE TIME-DO-NOTHING TIME-AFTER) (IF TIMED-FORM-P (TIME-FORMAT OUTPUT "Timing for ~[~;~:;~:* ~D x~]:~20T ~S~&" REPEAT TIMED-FORM)) (%PRINT-TIMING-ITEM OUTPUT "Elapsed time" (STATS-OBJECT-ELAPSED-TIME TIME-AFTER) T T) (%PRINT-TIMING-INFO OUTPUT TIME-AFTER DATA-TYPES) (VALUES-LIST VALUES)))
+
+(DEFMACRO TIME (TIMED-FORM &REST KEYWORDS) (IL:BQUOTE (TIME-CALL (FUNCTION (LAMBDA NIL (IL:\\\, TIMED-FORM))) :TIMED-FORM (QUOTE (IL:\\\, TIMED-FORM)) (IL:\\\,@ KEYWORDS))))
+
+(DEFUN %CAPTURE-COUNTERS-BEFORE (VECTOR) (IL:* IL:|;;| "Record box count for all known datatypes before timing. Note, IL:BOXCOUNT may create fixp's, so count down, so the FIXP count is recorded last") (DO ((I (1- (LENGTH VECTOR)) (1- I))) ((< I 0) VECTOR) (SETF (AREF VECTOR I) (IL:BOXCOUNT I))))
+
+(DEFUN %CAPTURE-COUNTERS-AFTER (VECTOR) (IL:* IL:|;;| "Record box count for all known datatypes after  timing. Note, IL:BOXCOUNT may create fixp's, so count up, so the FIXP count is recorded first") (DOTIMES (I (LENGTH VECTOR) VECTOR) (SETF (AREF VECTOR I) (IL:BOXCOUNT I))))
+
+(DEFUN TIME-FORMAT (STREAM FORMAT-STRING &REST ARGS) (IF (EQ STREAM :EXEC) (APPLY (QUOTE XCL:EXEC-FORMAT) FORMAT-STRING ARGS) (APPLY (QUOTE FORMAT) STREAM FORMAT-STRING ARGS)))
+
+(DEFUN %PRINT-TIMING-ITEM (STREAM STRING NUM TIME-P ALWAYS-P) (IF (OR ALWAYS-P (> NUM 0)) (IF TIME-P (TIME-FORMAT STREAM "~&~A ~20,5T= ~9,3F seconds~&" STRING (MAX 0 (/ NUM 1000.0))) (TIME-FORMAT STREAM "~&~A ~20,5T= ~9D~&" STRING NUM))))
+
+(DEFUN %PRINT-TIMING-INFO (STREAM STATS-OBJECT DATA-TYPES) (LET ((TIME-BLOCK (STATS-OBJECT-TIME-BLOCK STATS-OBJECT)) (DATA-TYPE-INFO (LET ((DATA-COUNTER (STATS-OBJECT-DATA-COUNTERS STATS-OBJECT)) (RESULT NIL) (RESULT-TAIL NIL) CNT TYPE-NAME) (DOTIMES (I (MIN (LENGTH DATA-COUNTER) (1+ IL:|\\MaxTypeNumber|)) RESULT) (SETQ CNT (AREF DATA-COUNTER I)) (WHEN (> CNT 0) (SETQ TYPE-NAME (IL:\\TYPENAMEFROMNUMBER I)) (IF (MEMBER TYPE-NAME DATA-TYPES :TEST (FUNCTION EQ)) (IF RESULT (RPLACD RESULT-TAIL (SETQ RESULT-TAIL (LIST (LIST CNT TYPE-NAME)))) (SETQ RESULT (SETQ RESULT-TAIL (LIST (LIST CNT TYPE-NAME))))))))))) (%PRINT-TIMING-ITEM STREAM "SWAP time" (IL:|fetch| (IL:MISCSTATS IL:SWAPWAITTIME) IL:|of| TIME-BLOCK) T) (%PRINT-TIMING-ITEM STREAM "reclaim time" (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| TIME-BLOCK) T) (%PRINT-TIMING-ITEM STREAM "Disk i/o time" (IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| TIME-BLOCK) T) (%PRINT-TIMING-ITEM STREAM "net compute time" (- (STATS-OBJECT-ELAPSED-TIME STATS-OBJECT) (IL:|fetch| (IL:MISCSTATS IL:SWAPWAITTIME) IL:|of| TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:NETIOTIME) IL:|of| TIME-BLOCK)) T) (%PRINT-TIMING-ITEM STREAM "Page faults" (IL:|fetch| (IL:MISCSTATS IL:PAGEFAULTS) IL:|of| TIME-BLOCK)) (%PRINT-TIMING-ITEM STREAM "Swap writes" (IL:|fetch| (IL:MISCSTATS IL:SWAPWRITES) IL:|of| TIME-BLOCK)) (%PRINT-TIMING-ITEM STREAM "Disk operations" (IL:|fetch| (IL:MISCSTATS IL:DISKOPS) IL:|of| TIME-BLOCK)) (IF DATA-TYPE-INFO (TIME-FORMAT STREAM "~&Storage allocated:~%~{~{~D ~A~}~^, ~}~&" DATA-TYPE-INFO)) (TIME-FORMAT STREAM "~%")))
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFMACRO %CAPTURE-BEFORE-STATS (STATS-OBJECT) (IL:* IL:|;;| "Capture machine state before timeing an evaluation. Note that ordering is important") (IL:BQUOTE (LET ((%$$STATS-OBJECT (IL:\\\, STATS-OBJECT))) (%CAPTURE-COUNTERS-BEFORE (STATS-OBJECT-DATA-COUNTERS %$$STATS-OBJECT)) (%COPY-TIME-STATS IL:\\MISCSTATS (STATS-OBJECT-TIME-BLOCK %$$STATS-OBJECT)) (IL:CLOCK0 (STATS-OBJECT-ELAPSED-TIME %$$STATS-OBJECT)))))
+
+(DEFMACRO %CAPTURE-AFTER-STATS (STATS-OBJECT) (IL:BQUOTE (LET ((%$$STATS-OBJECT (IL:\\\, STATS-OBJECT))) (IL:CLOCK0 (STATS-OBJECT-ELAPSED-TIME %$$STATS-OBJECT)) (%COPY-TIME-STATS IL:\\MISCSTATS (STATS-OBJECT-TIME-BLOCK %$$STATS-OBJECT)) (%CAPTURE-COUNTERS-AFTER (STATS-OBJECT-DATA-COUNTERS %$$STATS-OBJECT)))))
+
+(DEFMACRO %MOVE-FIXP-FIELD (FIELD-NAME DEST SOURCE) (IL:BQUOTE (IL:\\BLT (IL:LOCF (IL:FETCH (IL:\\\, FIELD-NAME) IL:OF (IL:\\\, DEST))) (IL:LOCF (IL:FETCH (IL:\\\, FIELD-NAME) IL:OF (IL:\\\, SOURCE))) 2)))
+)
+
+(XCL:DEFINE-SPECIAL-FORM TIME (TIMED-FORM &KEY (DATA-TYPES (QUOTE (IL:DATATYPES))) (REPEAT 1) (OUTPUT (QUOTE *TRACE-OUTPUT*)) &ENVIRONMENT ENV &AUX *EVALHOOK* *APPLYHOOK*) (TIME-CALL (FUNCTION (LAMBDA NIL (EVAL TIMED-FORM ENV))) :TIMED-FORM TIMED-FORM :DATA-TYPES (EVAL DATA-TYPES ENV) :REPEAT (EVAL REPEAT ENV) :OUTPUT (EVAL OUTPUT ENV)))
+
+(XCL:DEFCOMMAND "TIME" (FORM &KEY (REPEAT 1) &ENVIRONMENT ENV) "Time evaluation of form, output here" (TIME-CALL (FUNCTION (LAMBDA NIL (EVAL FORM ENV))) :OUTPUT :EXEC :REPEAT (EVAL REPEAT ENV)))
+
+
+
+(IL:* IL:|;;| "Interlisp Timeall function")
+
+(IL:DEFINEQ
+
+(IL:TIMEALL
+(IL:NLAMBDA (IL:TIMEFORM IL:NUMBEROFTIMES IL:TIMEWHAT IL:INTERPFLG) (IL:* IL:\; "Edited 29-Jan-87 18:48 by jop") (IL:* IL:|;;| "collects and prints stats on TIMEFORM.  TIMEWHAT indicates what to collect stats on: if T, all of the system times are collected;  if NIL, the system times plus all data allocations are kept;  if a list, it should be a list of DATATYPES (or numbers) .  ") (LET ((IL:DATATYPES (COND ((NULL IL:TIMEWHAT) (IL:DATATYPES)) ((EQ IL:TIMEWHAT T) NIL) (T (IL:|for| IL:X IL:|inside| IL:TIMEWHAT IL:|bind| IL:NAME IL:|join| (COND ((IL:SETQ IL:NAME (IL:DATATYPEP IL:X)) (CONS IL:NAME)) ((EQ IL:X (QUOTE TIME)) NIL) (T (IL:|printout| T IL:X " is not a datatype." T) NIL)))))) IL:VALUE) (OR (IL:NUMBERP IL:NUMBEROFTIMES) (IL:SETQ IL:NUMBEROFTIMES 1)) (LET ((IL:STRF T) (IL:LCFIL NIL)) (DECLARE (IL:SPECVARS IL:STRF IL:LCFIL)) (IL:COMPILE1 (QUOTE IL:TIMEDUMMYFUNCTION) (IL:BQUOTE (IL:LAMBDA NIL (IL:\\\, IL:TIMEFORM)))) (TIME-CALL (QUOTE IL:TIMEDUMMYFUNCTION) :OUTPUT (IL:GETSTREAM NIL (QUOTE IL:OUTPUT)) :TIMED-FORM IL:TIMEFORM :DATA-TYPES IL:DATATYPES :REPEAT IL:NUMBEROFTIMES))))
+)
+)
+
+
+
+(IL:* IL:|;;| "file package stuff")
+
+
+(IL:PUTPROPS TIME IL:FILETYPE COMPILE-FILE)
+
+(IL:PUTPROPS TIME IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY 
+(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
+
+(IL:LOCALVARS . T)
+)
+)
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA)
+
+(IL:ADDTOVAR IL:NLAML IL:TIMEALL)
+
+(IL:ADDTOVAR IL:LAMA)
+)
+(IL:PUTPROPS TIME IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL (9569 10697 (IL:TIMEALL 9582 . 10695)))))
+IL:STOP
diff --git a/CLTL2/TIME.LCOM b/CLTL2/TIME.LCOM
new file mode 100644
index 00000000..2c63de1b
Binary files /dev/null and b/CLTL2/TIME.LCOM differ
diff --git a/CLTL2/TTYIN b/CLTL2/TTYIN
new file mode 100644
index 00000000..9f5d6a51
--- /dev/null
+++ b/CLTL2/TTYIN
@@ -0,0 +1,5952 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "18-Oct-93 16:53:42" "{Pele:mv:envos}<LispCore>Sources>CLTL2>TTYIN.;2" 328555 
+
+      previous date%: " 3-Sep-91 18:20:56" "{Pele:mv:envos}<LispCore>Sources>CLTL2>TTYIN.;1")
+
+
+(* ; "
+Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT TTYINCOMS)
+
+(RPAQQ TTYINCOMS
+       [(COMS                                                (* ; "Main TTYIN editor")
+              (FNS TTYIN TTYIN.SETUP TTYIN.CLEANUP TTYIN1 TTYIN1RESTART TTYIN.FINISH TTYIN.BALANCE 
+                   ADDCHAR TTMAKECOMPLEXCHAR ADDNAKEDCHAR TTADDTAB ADJUSTLINE ADJUSTLINE.AND.RESTORE
+                   AT.END.OF.SCREEN AT.END.OF.TEXT AUTOCR? BACKSKREAD BACKWARD.DELETE.TO BREAKLINE 
+                   BUFTAILP CHECK.MARGIN CLEAR.LINE? CURRENT.WORD DELETE.TO.END DELETELINE DELETETO 
+                   DELETETO1 DO.EDIT.COMMAND DO.EDIT.PP TTDOTABS EDITCOLUMN EDITNUMBERP 
+                   END.DELETE.MODE ENDREAD? FIND.LINE FIND.LINE.BREAK FIND.MATCHING.QUOTE 
+                   FIND.NEXT.WORD FIND.NON.SPACE FIND.START.OF.WORD FORWARD.DELETE.TO 
+                   GO.TO.ADDRESSING GO.TO.FREELINE GO.TO.RELATIVE INIT.CURSOR INSERT.NODE INSERTLINE
+                   KILL.LINES KILLSEGMENT L-CASECODE MOVE.BACK.TO MOVE.FORWARD.TO MOVE.TO.LINE 
+                   MOVE.TO.NEXT.LINE MOVE.TO.START.OF.WORD MOVE.TO.WHEREVER NTH.COLUMN.OF 
+                   NTH.RELATIVE.COLUMN.OF OVERFLOW? OVERFLOWLINE? PREVLINE PREVWORD PROPERTAILP 
+                   READFROMBUF RENUMBER.LINES RESTORE.CURSOR RESTOREBUF RETYPE.BUFFER SAVE.CURSOR 
+                   SCANBACK SCANFORWARD SCRATCHCONS SEGMENT.LENGTH SEGMENT.BIT.LENGTH SETLASTC 
+                   SETTAIL? SHOW.MATCHING.PAREN SKIP/ZAP START.NEW.LINE START.OF.PARAGRAPH? 
+                   TTADJUSTWORD TTBIN TTBITWIDTH TTCRLF TTCRLF.ACCOUNT TTDELETECHAR TTDELETELINE 
+                   TTDELETEWORD TTECHO.TO.FILE TTGIVEHELP TTGIVEHELP1 TTGIVEHELP2 TTLASTLINE 
+                   TTLOADBUF TTNEXTLINE TTNEXTNODE TTNLEFT TTNTH TTNTHLINE TTPRIN1 TTPRINSPACE 
+                   TTPRIN1COMMENT TTPRIN2 TTPROMPTCHAR TTRUBOUT TTUNREADBUF TTWAITFORINPUT 
+                   TTYINSTRING TYPE.BUFFER U-CASECODE U/L-CASE))
+        (COMS                                                (* ; "Internal reading.  These functions all expect caller to have bound *READTABLE* correctly (not bound in TTYIN for who-line transparency)")
+              (FNS TTRATOM TTREADLIST TTSKIPSEPR TTSKREAD TTYIN.READ))
+        (COMS                                                (* ; "Escape completion and friends")
+              (FNS FIND.MATCHING.WORD TTCOMPLETEWORD WORD.MATCHES.BUFFER TTYIN.SHOW.?ALTERNATIVES))
+        (COMS                                                (* ; "? and ?= handler")
+              (FNS DO?CMD TTYIN.PRINTARGS TTYIN.READ?=ARGS DO?CMD.ERRORHANDLER))
+        (COMS                                                (* ; "Display handling")
+              (FNS BEEP BITBLT.DELETE BITBLT.ERASE BITBLT.INSERT DO.CRLF DO.DELETE.LINES 
+                   DO.INSERT.LINE DO.LF ERASE.TO.END.OF.LINE ERASE.TO.END.OF.PAGE INSERT.TEXT 
+                   TTDELSECTION TTADJUSTWIDTH TTINSERTSECTION TTSETCURSOR))
+        [COMS                                                (* ; "TTYINBUFFERSTREAM")
+              (FNS TTYINBUFFERDEVICE TTYINBUFFERSTREAM TTYINBUFFERBIN TTYINBUFFERPEEK 
+                   TTYINBUFFERREADP TTYINBUFFEREOFP TTYINBUFFERBACKPTR TTYINWORDRDTBL)
+              (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (TTYINBUFFERDEVICE (TTYINBUFFERDEVICE))
+                                                    (TTYINWORDRDTBL (TTYINWORDRDTBL]
+        (COMS                                                (* ; "Mouse handling")
+              (FNS DO.MOUSE DO.SHIFTED.SELECTION COPY.SEGMENT DELETE.LONG.SEGMENT 
+                   DELETE.LONG.SEGMENT1 INVERT.LONG.SEGMENT INVERT.SEGMENT BRACKET.CURRENT.WORD 
+                   TTBEFOREPOS TTNEXTPOS TTRACKMOUSE))
+        (COMS 
+              (* ;; "Auxiliary fns.  These are outside the TTYIN block, and are provided to aid the outside world in special interfaces to TTYIN")
+
+              (FNS SETREADFN TTYINENTRYFN TTYINREADP TTYINREAD TTYINFIX CHARMACRO? TTYINMETA 
+                   TTYIN.LASTINPUT)
+              (FNS TTYINEDIT SIMPLETEXTEDIT SET.TTYINEDIT.WINDOW TTYIN.PPTOFILE)
+              (COMS                                          (* ; 
+                                                         "New, correct way of getting scratch file")
+                    (FNS MAKE-TTSCRATCHFILE)
+                    (RESOURCES TTSCRATCHFILE))
+              (COMS                                          (* ; 
+                                                           "Obsolete, but maybe someone calls it")
+                    (FNS TTYIN.SCRATCHFILE \TTYIN.RPEOF)
+                    (INITVARS (TTYINEDIT.SCRATCH)))
+              (INITVARS (TTYINEDITWINDOW)
+                     (TTYINEDITPROMPT T)
+                     (TTYINAUTOCLOSEFLG)
+                     (TTYINPRINTFN)
+                     (TTYIN?=FN)))
+        [COMS                                                (* ; "Kludge of the week")
+              (FNS TTYINPROMPTFORWORD)
+              (INITVARS (TTYIN.USE.EXACT.CHARS))
+              (DECLARE%: DONTEVAL@LOAD DOCOPY                (* ; 
+                    "This is so that you can (MOVD 'TTYINPROMPTFORWORD 'PROMPTFORWORD) and not die")
+                     (P (MOVD? 'PROMPTFORWORD 'NON-TTYIN-PROMPTFORWORD NIL T]
+        (DECLARE%: DOEVAL@COMPILE DONTCOPY (COMS * TTCOMPILETIME))
+        (INITVARS (DORADO.RESTORE.BUF.CODES '(194))
+               (TTYIN.RESTORE.BUF.CODES '(516 530))
+               (TTYINBUFFER)
+               (?ACTIVATEFLG T)
+               (EDITPREFIXCHAR)
+               (SHOWPARENFLG T)
+               (TTYINBSFLG T)
+               (\TTYIN.LAST.FONT)
+               (\TTYIN.LAST.COMMENTFONT)
+               (TTYINFILLDEFAULT T)
+               (TTYINCOMPLETEFLG T)
+               (TTYINUSERFN)
+               (TYPEAHEADFLG T)
+               (null "")
+               (DEFAULTPROMPT "** ")
+               (TTYJUSTLENGTH -1)
+               (\INSIDE.TTYIN)
+               (TTYINERRORSETFLG)
+               (TTYINRAISEFLG T)
+               (TTYINAUTOFILLMARGIN 8)
+               (TTYINFIXLIMIT 50)
+               (TTYINDEBUGFLG)
+               (HISTSTR1 "from file:")
+               (TTYINCOMMENTCHAR)
+               (\RESTOREBUFCODES))
+        (P (MOVD? 'NILL 'GUESTUSER?)
+           (MOVD? 'FIXSPELL 'FIXSPELL!!)
+           (MOVD? 'HELPSYS 'XHELPSYS)
+           [PUTDQ? SPRINTT (LAMBDA (X)
+                                  (PRIN1 X]
+           (MOVD? 'NILL 'WINDOWWORLD)
+           (MOVD? 'LISPXFIX 'NONTTYINLISPXFIX))
+        (ADDVARS (TTYINREADMACROS)
+               (TTYINRESPONSES)
+               (LISPXCOMS (STOP . OK))
+               (\SYSTEMCACHEVARS \RESTOREBUFCODES))
+        (PROP VARTYPE TTYINREADMACROS)
+        [DECLARE%: DONTEVAL@LOAD DOCOPY (P (COND ((CCODEP 'TTYIN)
+                                                  (CHANGENAME 'PROMPTCHAR 'LISPXREADP 'TTYINREADP)
+                                                  (SETREADFN)
+                                                  (MOVD 'TTYINFIX 'LISPXFIX]
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML CHARMACRO?)
+                                                                             (LAMA])
+
+
+
+(* ; "Main TTYIN editor")
+
+(DEFINEQ
+
+(TTYIN
+  [LAMBDA (PROMPT SPLST HELP OPTIONS ECHOTOFILE TABS UNREADBUF RDTBL)
+                                                             (* ; "Edited 24-May-91 10:39 by jds")
+    (DECLARE (SPECVARS SPLST HELP OPTIONS ECHOTOFILE TABS UNREADBUF RDTBL))
+
+(* ;;; "TTYIN is a general input function.  See TTYIN.DOC for details on the arguments and use of this fn.  TTYIN was designed and implemented by Bill van Melle in the late 1970's at Stanford. ")
+
+(* ;;; "The bulk of the code here was oriented toward smart use on display terminals from remote machines, and then hacked to get it to work in windows in Interlisp-D. As such, there are a large number of fairly obsolete crocks in the code.")
+
+(* ;;; "The most important terminal at the time was  the datamedia.  If on a dm, TTYIN puts the terminal in binary mode so it can read the 200q bit supplied by the EDIT key.  Most of the cursor-moving commands from TVEDIT are available or slightly modified, and a few extra are supplied as well.")
+
+(* ;;; "The text being typed in is represented as a list of character codes, with a data structure on top of it which partitions it by line.  Thus, you can view the text as one string, or broken into lines, depending on the function desired.  \BUFFER is the pointer to the start of the buffer, \ENDBUFFER points one past the end.  TTYIN saves up cons cells between calls and reuses them;  \ENDBUFFER points to this list of free cells.  TTYINBUFFER is the master record, which keeps assorted global information about where the cursor is, and saves some state info from one call to the next, enabling the restore previous buffer command.  One of the fields points to the LINE records which describe the two-dimensional structure of the input.  Each record points to the region of the buffer containing the text for one line, and has fields indicating the first and last columns, and a pointer to the next line record.  \ARROW always points to the current LINE record --- \CURSOR points to where in the buffer the cursor appears.  --- This representation is not terribly space-efficient for large buffers, but it is easily manipulated, and fast.  If there is a particularly long input, there will be many cons cells tied up in TTYINBUFFER, so a good thing to do when trying to free up space is reset TTYINBUFFER to NIL to force its regeneration from scratch.")
+
+    (RESETLST
+        (PROG ((\INSIDE.TTYIN T)
+               (\AUTOFILL TTYINFILLDEFAULT)
+               (\DSP (TTYDISPLAYSTREAM))
+               (\FIRSTTIME T)
+               (\INITCRLFS 0)
+               (\RAISEINPUT (OR TTYINRAISEFLG (fetch RAISEFLG of \PRIMTERMTABLE)))
+               (\TTYINSTATE TTYINBUFFER)
+               (TYPEAHEAD TYPEAHEADFLG)
+               \ARROW \BMARG \BUFFER \CHARHEIGHT \CHARWIDTH \COMMAND \COMMENTFONT \CURSOR \CURSORCOL
+               \CURSORROW \DELETING \DESCENT \DONTCOMPLETE \ENDBUFFER \FILLINGBUFFER \FIRSTLINE \FIX
+               \FONT \HOMECOL \HOMEROW \INITPOS \LAST.DELETION \LASTAIL \LASTAILCOL \LASTAILROW 
+               \LASTCHAR \LISPXREADING \LMARG \LOC.ROW.0 \NOFIXSPELL \NOVALUE \PFW.FIRSTTIME \PROMPT1
+               \PROMPT2 \PROMPTFORWORD \RDTBLSA \READING \REPEAT \RMARG \STRINGVALUE \TEXTURE 
+               \TTPAGELENGTH \TTYINBUFFERSTREAM VALUE)
+              (SETQ TTYINBUFFER)                             (* ; 
+                  "Global resource.  Any ttyin calls while we are running need to create their own")
+              [OR (LISTP \TTYINSTATE)
+                  (SETQ \TTYINSTATE (create TTYINBUFFER
+                                           FIRSTLINE _ (create LINE
+                                                              START _ (CONS 0)
+                                                              ROW _ 0]
+              [COND
+                 ((AND SPLST (NLISTP SPLST))
+                  (SETQ SPLST (CONS SPLST]
+              (for OP inside OPTIONS do (SELECTQ OP
+                                                        ((NOFIXSPELL MUSTAPPROVE CRCOMPLETE) 
+                                                             (SETQ \NOFIXSPELL (SETQ \DONTCOMPLETE OP
+                                                                                )))
+                                                        (\NOVALUE (SETQ \NOVALUE OP))
+                                                        (STRING (SETQ \STRINGVALUE OP))
+                                                        (COMMAND (SETQ \COMMAND OP))
+                                                        (REPEAT (SETQ \REPEAT OP))
+                                                        (NORAISE (SETQ \RAISEINPUT))
+                                                        (RAISE (SETQ \RAISEINPUT T))
+                                                        (TEXT (SETQ \REPEAT (SETQ \NOVALUE
+                                                                             (SETQ \AUTOFILL OP)))
+                                                              (SETQ \RAISEINPUT))
+                                                        (FIX (SETQ \FIX OP))
+                                                        (READ (SETQ \READING (SETQ \AUTOFILL OP)))
+                                                        (LISPXREAD [SETQ TYPEAHEAD (SETQ 
+                                                                                    \LISPXREADING
+                                                                                    (SETQ \READING
+                                                                                     (SETQ \AUTOFILL
+                                                                                      OP]
+                                                                   (SETQ \RAISEINPUT
+                                                                    (fetch RAISEFLG of 
+                                                                                       \PRIMTERMTABLE
+                                                                           )))
+                                                        (EVALQT 
+                                                             (* ; 
+             "like LISPXREAD, but with added proviso about checking for EVALQT right-bracket hacks")
+                                                                [SETQ TYPEAHEAD (SETQ \LISPXREADING
+                                                                                 (SETQ \READING
+                                                                                  (SETQ \AUTOFILL OP]
+                                                                (SETQ \RAISEINPUT
+                                                                 (fetch RAISEFLG of 
+                                                                                       \PRIMTERMTABLE
+                                                                        )))
+                                                        (TYPEAHEAD (SETQ TYPEAHEAD OP))
+                                                        (FILLBUFFER (SETQ \FILLINGBUFFER OP))
+                                                        (NOPROMPT (SETQ \FIRSTTIME OP))
+                                                        ((PROMPTFORWORD PROMPTFORWORD-SPACE) 
+                                                             (* ; "For faking PROMPTFORWORD")
+                                                             (SETQ \PROMPTFORWORD (SETQ \STRINGVALUE
+                                                                                   OP))
+                                                             (SETQ \PFW.FIRSTTIME UNREADBUF)
+                                                             (* ; 
+                   "Flag that says to erase the line if user types something other than <bs>, etc.")
+                                                             (SETQ \RAISEINPUT NIL))
+                                                        NIL))
+              [SETQ \RDTBLSA (fetch READSA of (SETQ RDTBL (COND
+                                                                     ((AND (NOT \READING)
+                                                                           (NULL RDTBL))
+                                                             (* ; 
+                                                  "Use the word table, rather than a Lispish table")
+                                                                      (\DTEST TTYINWORDRDTBL
+                                                                             'READTABLEP))
+                                                                     (T (\GTREADTABLE RDTBL]
+              (TTYIN.SETUP)                              (* ; 
+                   "Setup window, including fonts.  Didn't do this til now since it uses \READING.")
+              [COND
+                 ((EQ PROMPT T)
+                  (SETQ \PROMPT1 (SETQ \PROMPT2)))
+                 (T [COND
+                       ((NOT PROMPT)
+                        (SETQ PROMPT DEFAULTPROMPT))
+                       [(LISTP PROMPT)
+                        (COND
+                           ((NLISTP (CDR PROMPT))            (* ; 
+                                       "User has already supplied us with a dotted pair of prompts")
+                            (SETQ \PROMPT1 (CAR PROMPT))
+                            (SETQ \PROMPT2 (CDR PROMPT)))
+                           (T (SETQ PROMPT (SUBSTRING PROMPT 2 -2]
+                       ((AND (NOT (STRINGP PROMPT))
+                             (NOT (LITATOM PROMPT)))
+                        (SETQ PROMPT (MKSTRING PROMPT]
+                    (COND
+                       ((NLISTP PROMPT)                      (* ; "Now create 2 prompts out of one")
+                        (SETQ \PROMPT1 PROMPT)
+                        (SETQ \PROMPT2 (COND
+                                          ((OR \LISPXREADING \PROMPTFORWORD)
+                                                             (* ; 
+                                          "Don't use a secondary prompt for LISPX or PROMPTFORWORD")
+                                           NIL)
+                                          ((AND \REPEAT (< (NCHARS PROMPT)
+                                                           12))
+                                                             (* ; 
+                                              "Okay to use this short prompt as a secondary prompt")
+                                           PROMPT)
+                                          (T '|...|]
+              (COND
+                 ((NOT SPLST)
+                  (SETQ \DONTCOMPLETE T)))
+              (COND
+                 (\READING (SETQ \REPEAT)))
+              (COND
+                 ((NOT TYPEAHEAD)
+                  (CLEARBUF T)))
+          LP  (SETQ VALUE (NLSETQ (TTYIN1)))
+              (COND
+                 ((NOT VALUE)                                (* ; "NLSETQ aborted.  Try again.")
+                  (COND
+                     ((OR (NOT TTYINERRORSETFLG)
+                          \LISPXREADING)                     (* ; 
+                                      "LISPXREAD is not errorset-protected, so why should this be?")
+                      (COND
+                         (\CURSORCOL                         (* ; 
+                                "If this is NIL, then we haven't initialized enough to go anywhere")
+                                (GO.TO.FREELINE)))
+                      (RESTOREMOD)
+                      (COND
+                         ((NEQ \BUFFER \ENDBUFFER)
+                          (replace (TTYINBUFFER OLDTAIL) of \TTYINSTATE with \ENDBUFFER))
+                         )
+                      (ERROR!)))
+                  (GO LP)))
+              (COND
+                 ((AND (NEQ \BUFFER \ENDBUFFER)
+                       (> (add (fetch (TTYINBUFFER STORAGECOUNTER) of \TTYINSTATE)
+                                 1)
+                          10))                               (* ; 
+                                  "Release some storage, since it seems to accumulate and fragment")
+                  (replace (TTYINBUFFER STORAGECOUNTER) of \TTYINSTATE with 0)
+                  (FRPLACD \ENDBUFFER)))
+              (SETQ VALUE (CAR VALUE))
+              (POSITION T 0)
+              [COND
+                 ((AND CTRLUFLG (NEQ VALUE T))               (* ; "user typed ^U to edit input")
+                  (SETQ CTRLUFLG)
+                  (PROG ((\INSIDE.TTYIN))
+                        (COND
+                           ((OR (LITATOM VALUE)
+                                (GUESTUSER?))                (* ; "guests may not edit")
+                            )
+                           ((LISTP VALUE)
+                            (EDITE VALUE))
+                           (T (SETQ VALUE (CAR (EDITE (LIST VALUE)
+                                                      '(REPACK]
+              (COND
+                 ((AND TTYINMAILFLG (NEQ \READING 'EVALQT))  (* ; "Note time of last user input")
+                  (MWNOTE)))
+              (RETURN VALUE)))])
+
+(TTYIN.SETUP
+  [LAMBDA NIL                                              (* ; "Edited 19-Jan-88 01:51 by bvm")
+                                                             (* ; 
+                                                           "Disable buttons so we can do selection")
+    [LET ((WINDOW (WFROMDS \DSP T)))
+         (COND
+            (WINDOW (replace (TTYINBUFFER TTOLDRIGHTFN) of \TTYINSTATE
+                       with (WINDOWPROP WINDOW 'RIGHTBUTTONFN 'TOTOPW))
+                   (replace (TTYINBUFFER TTOLDBUTTONFN) of \TTYINSTATE
+                      with (WINDOWPROP WINDOW 'BUTTONEVENTFN 'TOTOPW))
+                   (replace (TTYINBUFFER TTOLDENTRYFN) of \TTYINSTATE
+                      with (WINDOWPROP WINDOW 'WINDOWENTRYFN 'TTYINENTRYFN))
+                   (replace (TTYINBUFFER TTYINWINDOW) of \TTYINSTATE with WINDOW)
+                   (WINDOWPROP WINDOW 'TTYINSTATE (fetch (TTYINBUFFER TTYINWINDOWSTATE)
+                                                     of \TTYINSTATE))
+                   (RESETSAVE NIL (LIST (FUNCTION TTYIN.CLEANUP)
+                                          \TTYINSTATE]
+    (COND
+       ((OR (IMAGESTREAMTYPEP \DSP 'TEXT)
+            (FMEMB (DSPDESTINATION NIL \DSP)
+                   \SCREENBITMAPS))
+        (SETQ \CHARWIDTH (CHARWIDTH (CHARCODE A)
+                                \DSP))
+        (SETQ \FONT (DSPFONT NIL \DSP))
+        (if (EQ \FONT \TTYIN.LAST.FONT)
+            then (SETQ \COMMENTFONT \TTYIN.LAST.COMMENTFONT)
+          elseif \READING
+            then                                         (* ; "Want a %"comment%" font for ?=")
+                  [SETQ \COMMENTFONT (SETQ \TTYIN.LAST.COMMENTFONT (FONTCOPY
+                                                                    \FONT
+                                                                    'WEIGHT
+                                                                    (SELECTQ (FONTPROP \FONT
+                                                                                    'WEIGHT)
+                                                                        (BOLD 'MEDIUM)
+                                                                        'BOLD]
+                  (SETQ \TTYIN.LAST.FONT \FONT)
+          else (SETQ \COMMENTFONT \FONT))
+        (SETQ \CHARHEIGHT (MAX (FONTHEIGHT \FONT)
+                               (FONTHEIGHT \COMMENTFONT)))
+        (SETQ \DESCENT (FONTPROP \FONT 'DESCENT))            (* ; 
+                                                "How many pixels below the baseline this font goes")
+        (SETQ \TEXTURE (DSPTEXTURE NIL \DSP))
+        (SETQ \TTPAGELENGTH (PAGEHEIGHT NIL \DSP))
+        (SETQ \LMARG (DSPLEFTMARGIN NIL \DSP))             (* ; "bit pos of left margin")
+        (SETQ \RMARG (DSPRIGHTMARGIN NIL \DSP))            (* ; 
+                                                           "bit pos of right margin, dsp relative")
+        (SETQ \INITPOS (DSPXPOSITION NIL \DSP])
+
+(TTYIN.CLEANUP
+  [LAMBDA (\TTYINSTATE)                                      (* ; "Edited 24-May-91 10:39 by jds")
+    (PROG ((WINDOW (fetch (TTYINBUFFER TTYINWINDOW) of \TTYINSTATE)))
+          (COND
+             (WINDOW (WINDOWPROP WINDOW 'RIGHTBUTTONFN (fetch (TTYINBUFFER TTOLDRIGHTFN)
+                                                          of \TTYINSTATE))
+                    (WINDOWPROP WINDOW 'BUTTONEVENTFN (fetch (TTYINBUFFER TTOLDBUTTONFN)
+                                                         of \TTYINSTATE))
+                    (WINDOWPROP WINDOW 'WINDOWENTRYFN (fetch (TTYINBUFFER TTOLDENTRYFN)
+                                                         of \TTYINSTATE))
+                    (WINDOWPROP WINDOW 'TTYINSTATE NIL)))
+          (SETQ TTYINBUFFER \TTYINSTATE])
+
+(TTYIN1
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 10:33 by jds")
+
+(* ;;; "The main moby subfn of TTYIN.  Is errorset protected in caller")
+
+    (PROG ((DRIBFL (DRIBBLEFILE))
+           CHAR MATCHED RESULT STARTOFWORD X TMP WASEDITCHAR SNX)
+          (COND
+             ((SETQ CHAR (fetch (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD))
+                                                             (* ; "Handle peeked char")
+              [COND
+                 ((AND (OR (NULL \PROMPT1)
+                           (EQ \FIRSTTIME 'NOPROMPT))
+                       (OR T (fetch (LINEBUFFER PEEKEDECHOFLG) of \LINEBUF.OFD))
+                       (>= CHAR (CHARCODE SPACE)))
+
+                  (* ;; "Want to avoid echoing peeked char twice.  Only feasible to do so if we were called with no prompt, implying that there is some hope that the preceding char on the line is the peeked char")
+
+                  (SETQ X (FCHARWIDTH CHAR \FONT))
+                  (DSPBACKUP X \DSP)
+                  (SETQ \INITPOS (- \INITPOS X]
+              (replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with NIL)))
+          (SETQ \LASTAIL)
+      RESTART
+      PROMPT0
+          (TTYIN1RESTART)
+          (COND
+             ((NOT \FIRSTTIME)                               (* ; "Space over to where we started")
+              (GO.TO.ADDRESSING \INITPOS 0)))
+          (SETQ RESULT NIL)
+      PROMPT1
+          (INIT.CURSOR \INITPOS)
+          (COND
+             [(AND (EQ \FIRSTTIME 'NOPROMPT)
+                   \PROMPT1)                                 (* ; 
+                                                  "Prompting has already happened;  account for it")
+              (COND
+                 ((< (SETQ X (- \INITPOS (STRINGWIDTH \PROMPT1 \FONT)))
+                     \LMARG)
+
+                  (* ;; "Caller is confused;  prompt couldn't have fit.  Typically happens when LISPXREAD is called by other than LISPX")
+
+                  (SETQ \PROMPT1))
+                 (T (SETQ \INITPOS X]
+             (T (TTPROMPTCHAR \ARROW)))
+          (replace (LINE FIRSTCOL) of \ARROW with (replace (LINE LASTCOL)
+                                                                 of \ARROW with \CURSORCOL))
+          [COND
+             ([OR (NLISTP TABS)
+                  (NOT (SMALLP (CAR TABS]
+              (SETQ TABS))
+             ((NOT (> (ITIMES (SUB1 (CAR TABS))
+                             \CHARWIDTH)
+                      \CURSORCOL))
+
+              (* ;; "Caller specified first tabstop as the position of the first char;  we don't treat that as a tabstop, so peel it off")
+
+              (SETQ TABS (CDR TABS]
+          (COND
+             [UNREADBUF                                      (* ; 
+                                                           "something to preload buffer with")
+              (COND
+                 ((FIXP UNREADBUF)
+                  (SETQ CHAR UNREADBUF)                      (* ; 
+                   "interpret number as character code of something to type ahead, usually altmode")
+                  (SETQ UNREADBUF NIL)
+                  (GO SELECTCHAR))
+                 (T (WITH-RESOURCES (TTSCRATCHFILE)
+                           (TTLOADBUF (PROG1 (COND
+                                                    ((EQMEMB 'PRETTY OPTIONS)
+
+                                                     (* ;; 
+                         "We were told to pretty-print the FIXed form, so have to use a temp file.")
+
+                                                     (* ;; 
+                                           "Pass TTLOADBUF a list (<HISTSTR1> (file start . end)).")
+
+                                                     (LIST HISTSTR1
+                                                           (TTYIN.PPTOFILE
+                                                            (COND
+                                                               ((EQ (CAR (SETQ X (LAST UNREADBUF)))
+                                                                    HISTSTR0)
+                                                             (* ; 
+                                                           "knock off the terminating <cr> marker")
+                                                                (LDIFF UNREADBUF X))
+                                                               (T UNREADBUF))
+                                                            'PRETTY RDTBL TTSCRATCHFILE)))
+                                                    (T       (* ; 
+                                        "Not pretty printing; just pass TTLOADBUF the form to FIX.")
+                                                       UNREADBUF))
+                                              (SETQ UNREADBUF NIL)
+                                              (SETFILEPTR TTSCRATCHFILE 0))]
+             (\FIRSTTIME 
+
+                    (* ;; "(for FORM in AFTERPROMPTCHARFORMS bind REFRESH when (EVAL FORM) do (SETQ REFRESH T) (* User forms to do after prompt is printed but before we do anything more.  If one returns T, means it altered the display) finally (COND (REFRESH (SETQ \FIRSTTIME) (GO PROMPT1))))")
+))
+          (SETQ \FIRSTTIME)
+          (COND
+             (CHAR (GO SELECTCHAR)))
+      CHAR
+          (AND CHAR (SETQ \LASTCHAR CHAR))
+          (SETQ CHAR (TTBIN))
+      SELECTCHAR
+          [COND
+             ([AND (SETQ X (FASSOC CHAR TTYINREADMACROS))
+                   (OR [NLISTP (SETQ X (CDR (SETQ TMP X]
+                       (AND (COND
+                               ((EQ (CAR X)
+                                    T)
+                                (EMPTY.BUFFER))
+                               ((LISTP (CAR X))
+                                (EVAL (CAR X)))
+                               (T                            (* ; 
+                                             "Old style macros that worked only at start of buffer")
+                                  (SETQ X TMP)
+                                  (EMPTY.BUFFER)))
+                            (OR (NLISTP (SETQ X (CDR X)))
+                                (SETQ X (EVAL X]
+
+              (* ;; "Simple read macros: if you type the char on a blank line, and the macro returns something, use it as the value of the READ (or whatever)")
+
+              (COND
+                 [(FIXP X)                                   (* ; 
+                                             "Special: means pretend this CHARACTER code was typed")
+                  (SELECTQ X
+                      (0                                     (* ; "No action")
+                         (GO CHAR))
+                      (-1                                    (* ; 
+                                      "Means refresh line, because terminal control was taken away")
+                          (SETQ CHAR NIL)
+                          (GO PROMPT1))
+                      (COND
+                         ((METACHARP (SETQ CHAR X))
+                          [COND
+                             ((EQ (NONMETACHARBITS X)
+                                  0)                         (* ; "another way to get edit prefix")
+                              (SETQ CHAR (METACHAR (TTBIN T]
+                          T]
+                 ((EMPTY.BUFFER)                             (* ; 
+                                             "For now I'm not handling funny results in the middle")
+                  (SETQ RESULT (OR (LISTP X)
+                                   (LIST X)))
+                  (GO DOCRLF]
+          (COND
+             ((NOT (METACHARP CHAR))
+              (SETQ WASEDITCHAR NIL))
+             ([NOT (SETQ CHAR (DO.EDIT.COMMAND (NONMETACHARBITS CHAR]
+              (GO CHAR))
+             (T                                              (* ; 
+                                             "Fall thru if edit char gave us something to chomp on")
+                (SETQ WASEDITCHAR T)))
+          [COND
+             ((SELECTC (fetch TERMCLASS of (\SYNCODE \PRIMTERMSA CHAR))
+                  (CHARDELETE.TC (TTDELETECHAR)
+                                 T)
+                  (LINEDELETE.TC (TTDELETELINE)
+                                 T)
+                  (WORDDELETE.TC (TTDELETEWORD)
+                                 T)
+                  (RETYPE.TC                                 (* ; "^R retype")
+                             (SETQ \PFW.FIRSTTIME NIL)
+                             [RETYPE.BUFFER (COND
+                                                   ((OR (ON.FIRST.LINE)
+                                                        (NOT (EMPTY.LINE)))
+                                                    \ARROW)
+                                                   (T        (* ; 
+                                              "If sitting on empty line, refresh the previous line")
+                                                      (PREVLINE \ARROW 1]
+                             (COND
+                                ((EQ CHAR (SETQ CHAR (TTBIN)))
+                                                             (* ; 
+                                                           "two ^R's means retype whole buffer")
+                                 (OR DISPLAYTERMFLG (TTCRLF))
+                                                             (* ; 
+                                                           "set off full retype by double line")
+                                 (RETYPE.BUFFER \FIRSTLINE T))
+                                (T (GO SELECTCHAR)))
+                             T)
+                  NIL)                                     (* ; 
+                          "Did some routine editing command.  This cancels promptforword kill mode")
+              (SETQ \PFW.FIRSTTIME NIL))
+             ((PROGN (SETQ SNX (\SYNCODE \RDTBLSA CHAR))
+                     (AND \FILLINGBUFFER (EQ (fetch WAKEUP of SNX)
+                                             IMMEDIATE.RMW)
+                          (AT.END.OF.TEXT \CURSOR)))     (* ; 
+                                                           "Immediate read macro--return now")
+              (GO DOCRLF))
+             (T (if \PFW.FIRSTTIME
+                    then                                 (* ; "The only non-meta characters that accept the input are cr, space and the hard-wired editing commands (which we have mostly covered already)")
+                          (SELCHARQ CHAR
+                               ((CR SPACE ^X ^A BS RUBOUT ^Q ^U ^W))
+                               (PROGN                        (* ; 
+                 "Kill the entire input (could be more than one line if long input or long prompt)")
+                                      (MOVE.TO.LINE \FIRSTLINE)
+                                      (DELETE.TO.END)))
+                          (SETQ \PFW.FIRSTTIME NIL))
+                (COND
+                   ((AND (fetch STOPATOM of SNX)
+                         (NOT \DONTCOMPLETE))                (* ; "End of atom, try completion")
+                    (TTCOMPLETEWORD T)))
+                (SELECTC SNX
+                    ((LIST RIGHTPAREN.RC RIGHTBRACKET.RC) 
+
+                                 (* ;; "Right paren/bracket.  See if it terminates read.  Note that \READING is implicitly true here, since there are no parens in the word rdtbl")
+
+                         (SETQ STARTOFWORD \CURSOR)
+                         (ADDCHAR CHAR)
+                         (COND
+                            ((ENDREAD?)
+                             (GO DOCRLF))
+                            ((AND SHOWPARENFLG T (NOT (TYPEAHEAD?)))
+                                                             (* ; 
+                                         "prime conditions for hack to show which paren it matched")
+                             (SHOW.MATCHING.PAREN STARTOFWORD))))
+                    (SELECTC CHAR
+                        ((CHARCODE ESCAPE) 
+                             [COND
+                                (SPLST                       (* ; 
+                                                           "try to complete from spelling list")
+                                       (OR (TTCOMPLETEWORD)
+                                           (BEEP)))
+                                [(AND TTYINCOMPLETEFLG \LISPXREADING)
+
+                                 (* ;; "always try to complete")
+
+                                 (COND
+                                    ((SETQ STARTOFWORD (CURRENT.WORD))
+                                     (SETQ MATCHED (FIND.MATCHING.WORD USERWORDS STARTOFWORD)))
+                                    ((NEQ TTYINCOMPLETEFLG 0)
+
+                                     (* ;; "naked escape stands for LASTWORD.  ")
+
+                                     (SETQ MATCHED (LIST LASTWORD))
+                                     LASTWORD))
+                                 (SETQ CHAR DIDESCAPECODE)   (* ; "Kludge used by ?  routine below")
+                                 (COND
+                                    (MATCHED (OR (TTCOMPLETEWORD NIL NIL MATCHED
+                                                        (OR STARTOFWORD \CURSOR))
+                                                 (BEEP)))
+                                    (T (BEEP]
+                                (T                           (* ; "no special significance")
+                                   (ADDNAKEDCHAR (CHARCODE ESCAPE])
+                        ((CHARCODE (%" *)) 
+                             (ADDCHAR CHAR)
+                             (TTDOTABS TABS))
+                        ((CHARCODE TAB) 
+                             (OR (TTDOTABS TABS)
+                                 (TTADDTAB)))
+                        ((CHARCODE SPACE) 
+                             (if (AND (EQ \PROMPTFORWORD 'PROMPTFORWORD-SPACE)
+                                          (AT.END.OF.TEXT \CURSOR))
+                                 then                    (* ; "Space completes")
+                                       (GO DOCRLF))
+                             (OR (AUTOCR?)
+                                 (ADDCHAR CHAR)))
+                        ((CHARCODE ?)                        (* ; "supply alternative completions")
+                             (TTYIN.SHOW.?ALTERNATIVES))
+                        ((CHARCODE CR)                       (* ; "terminate line")
+                             [COND
+                                ((NOT WASEDITCHAR)           (* ; "i.e.  not edit-CR")
+                                                             (* ; "Check for ?  and ?= macros")
+                                 (PROG ((START (fetch (LINE START) of \ARROW))
+                                        TAIL)
+                                       (COND
+                                          ((EQ \CURSOR START)
+                                           (RETURN)))
+                                       (SETQ TAIL (NLEFT START 1 \CURSOR))
+                                                             (* ; "Look at last char on line")
+                                       (SELCHARQ (CAR TAIL)
+                                            (? (COND
+                                                  ((AND (DEFINEDP 'XHELPSYS)
+                                                        [OR (EQ TAIL START)
+                                                            (BREAK.OR.SEPRP (FIRSTCHAR (NLEFT START 1
+                                                                                              TAIL]
+                                                        (DO?CMD '? TAIL))
+                                                   (GO CHAR))))
+                                            (= (COND
+                                                  ((AND (NEQ TAIL START)
+                                                        (EQ (CAR (SETQ TAIL (NLEFT START 1 TAIL)))
+                                                            (CHARCODE ?))
+                                                        [OR (EQ TAIL START)
+                                                            (BREAK.OR.SEPRP (FIRSTCHAR (NLEFT START 1
+                                                                                              TAIL]
+                                                        (DO?CMD '?= TAIL))
+                                                   (GO CHAR))))
+                                            NIL))
+                                 (COND
+                                    ((NOT (AT.END.OF.TEXT \CURSOR))
+                                     (COND
+                                        ((OR \REPEAT \READING)
+                                                             (* ; 
+                                                           "Insert a <cr> and continue reading")
+                                         (BREAKLINE EOLCHARCODE)
+                                         (GO CHAR))
+                                        (T                   (* ; 
+                                           "<cr> typed here would terminate, so unread what's left")
+                                           (TTUNREADBUF]
+                             (COND
+                                [(NOT (AT.END.OF.BUF))
+                                 (COND
+                                    ((ON.LAST.LINE)
+                                     (SETQ \CURSOR \ENDBUFFER))
+                                    ((AND \READING (NOT \PROMPT2)
+                                          (AT.END.OF.TEXT (fetch (LINE END) of \ARROW)))
+
+                                 (* ;; "Really the same condition as previous clause: there are lines after this one, but they're blank, so it looks like we're on the last line")
+
+                                     (MOVE.FORWARD.TO (fetch (LINE END) of \ARROW))
+                                                             (* ; 
+                         "have to make the extra stuff go away so the finishing routines are happy")
+                                     (DELETE.TO.END))
+                                    (T (DO.EDIT.COMMAND (CHARCODE CR))
+                                                             (* ; 
+                                                "CR on other than last line just means go down one")
+                                       (GO CHAR]
+                                ((OR (NOT \DONTCOMPLETE)
+                                     (EQ \DONTCOMPLETE 'CRCOMPLETE))
+                                 (TTCOMPLETEWORD T)))
+                             (COND
+                                ((COND
+                                    (\READING (TTSKREAD \BUFFER))
+                                    [\REPEAT (AND (ON.FIRST.LINE)
+                                                  (OR (EQ (CAR \BUFFER)
+                                                          TTYINCOMMENTCHAR)
+                                                      (AND \COMMAND (EQ (FIND.NEXT.WORD
+                                                                         (FIND.NON.SPACE \BUFFER)
+                                                                         )
+                                                                        \ENDBUFFER]
+                                    (T T))                   (* ; 
+      "Terminating conditions: no REPEAT, or first line is a comment or has a single command on it")
+                                 (SETQ CTRLVFLG (SETQ RESULT))
+                                 (SETQ CHAR (CHARCODE EOL))  (* ; 
+                                                           "Lisp likes to treat cr as (choke) EOL")
+                                 (GO DOCRLF))
+                                (T (START.NEW.LINE EOLCHARCODE))))
+                        ((CHARCODE ^X)                       (* ; "Maybe exit")
+                             (COND
+                                ((COND
+                                    (\READING                (* ; 
+                       "return if parens balance.  If already at end, add enough parens to balance")
+                                           (TTYIN.BALANCE T (AT.END.OF.TEXT \CURSOR)))
+                                    (T                       (* ; 
+                                                           "Taking string input, etc--finish now")
+                                       (MOVE.TO.WHEREVER \ENDBUFFER)
+                                       T))
+                                 (SETQ CHAR (CHARCODE EOL))
+                                 (GO DOCRLF))))
+                        ((CHARCODE ^V) 
+                             (COND
+                                ((NEQ \REPEAT 'TEXT)         (* ; "Means enter control char")
+                                 (SETQ CHAR (TTBIN))
+                                 (ADDNAKEDCHAR (if (EQ CHAR (CHARCODE ?))
+                                                       then 
+                                                             (* ; 
+                                                           "This is the only way to get a rubout")
+                                                             (SETQ CHAR (CHARCODE RUBOUT))
+                                                     elseif (>= CHAR (CHARCODE @))
+                                                       then 
+                                                             (* ; 
+                                                 "Change alphabetics to corresponding control char")
+                                                             (SETQ CHAR (LOGAND CHAR 31))
+                                                     else 
+                                                             (* ; "take exact char")
+                                                           CHAR)))
+                                ((AT.END.OF.BUF)             (* ; 
+                                                   "terminate multiline input and set special flag")
+                                 (SETQ CTRLVFLG T)
+                                 (TTBOUT ^ V)
+                                 (GO DOCRLF))
+                                (T (BEEP))))
+                        ((CHARCODE ^Z)                       (* ; "^Z terminates multiline input")
+                             (COND
+                                ((AND \REPEAT (AT.END.OF.BUF))
+                                 (TTBOUT ^ Z)
+                                 (SETQ CTRLVFLG)
+                                 (GO DOCRLF))
+                                (\READING (ADDNAKEDCHAR CHAR))
+                                (T (BEEP))))
+                        ((CHARCODE ^Y)                       (* ; "^Y invokes user exec")
+                             (COND
+                                ((AND \READING (NOT WASEDITCHAR))
+                                                             (* ; "let ^Y read macro work instead")
+                                 (ADDNAKEDCHAR CHAR))
+                                ((GUESTUSER?)
+                                 (BEEP))
+                                (T (SETTAIL?)
+                                   (SAVE.CURSOR)
+                                   (GO.TO.FREELINE)
+                                   (COND
+                                      (DRIBFL                (* ; "Make typescript understandable")
+                                             (AND \PROMPT1 (PRIN1 \PROMPT1 DRIBFL))
+                                             (PRINT '^Y DRIBFL)))
+                                   (PRIN1 "lisp:
+" T)
+                                   (COND
+                                      (TTYINMAILFLG (MWNOTE)))
+                                   (RESTOREMOD)
+                                   (PROG ((\INSIDE.TTYIN))
+                                         (USEREXEC '__))
+                                   (GO RETYPEBUFFER))))
+                        (0                                   (* ; "ignore NULL"))
+                        ((CHARCODE (^A BS RUBOUT)) 
+                             (TTDELETECHAR))
+                        ((CHARCODE (^Q ^U))                  (* ; "^Q delete line;  ^U on tops20")
+                             (TTDELETELINE))
+                        ((CHARCODE ^W)                       (* ; "^W delete last word")
+                             (TTDELETEWORD))
+                        (COND
+                           ([MEMB CHAR (OR \RESTOREBUFCODES (SETQ \RESTOREBUFCODES
+                                                             (APPEND (AND (EQ (MACHINETYPE)
+                                                                              'DORADO)
+                                                                          DORADO.RESTORE.BUF.CODES)
+                                                                    TTYIN.RESTORE.BUF.CODES]
+
+                            (* ;; "One of the characters we interpret as %"restore last buffer%".  Recomputed after exit in case we change machine.  The dorado code is a perfectly good charset 0 code, so don't usually want to usurp it.")
+
+                            (RESTOREBUF))
+                           [(> CHAR 32)                      (* ; "not a control char")
+                            (ADDCHAR (COND
+                                            (\RAISEINPUT (U-CASECODE CHAR))
+                                            (T CHAR]
+                           (T (ADDNAKEDCHAR CHAR]
+          (GO CHAR)
+      RETYPEBUFFER
+          (RETYPE.BUFFER \FIRSTLINE T T)
+          (GO CHAR)
+      DOCRLF
+          
+
+     (* ;; "Come here when it is time to terminate line")
+
+          (COND
+             ((EQ (SETQ RESULT (TTYIN.FINISH CHAR DRIBFL RESULT))
+                  'ABORT)                                    (* ; "Aborted, try again")
+              (SETQ CHAR NIL)
+              (GO PROMPT0))
+             (T (RETURN RESULT])
+
+(TTYIN1RESTART
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 10:39 by jds")
+    (\RESETLINE)                                             (* ; 
+                 "clear some terminal-related stuff, including the info about where to hold scroll")
+    (\SETEOFPTR \LINEBUF.OFD 0)                              (* ; "Clear the line buffer")
+    (SETQ \ARROW (SETQ \FIRSTLINE (fetch (TTYINBUFFER FIRSTLINE) of \TTYINSTATE)))
+    [replace (LINE END) of \ARROW with (SETQ \CURSOR (SETQ \BUFFER (SETQ \ENDBUFFER
+                                                                                (fetch
+                                                                                 (LINE START)
+                                                                                   of \ARROW]
+    [PROG ((MORELINES (fetch (LINE NEXTLINE) of \ARROW)))
+          (COND
+             (MORELINES                                      (* ; 
+                                                           "Return old line records to cons pool")
+                    (replace (LINE NEXTLINE) of \ARROW with NIL)
+                    (KILL.LINES MORELINES]
+    (SETQ \DELETING])
+
+(TTYIN.FINISH
+  [LAMBDA (FINALCHAR DRIBFL RESULT)                          (* ; "Edited 24-May-91 10:39 by jds")
+    (PROG ((*READTABLE* RDTBL)
+           WORD X ORIGBUFFER)
+          (COND
+             ((NOT \PROMPTFORWORD)                           (* ; 
+                                        "Go to new line.  Fake promptforword mode doesn't do this.")
+              (TTCRLF)
+              (CLEAR.LINE? T)))
+          [COND
+             ((EQ FINALCHAR (CHARCODE EOL))
+              (bind TAIL (START _ (fetch (LINE START) of \ARROW))
+                 while (AND (NEQ START \ENDBUFFER)
+                                (EQ (CAR (SETQ TAIL (TTNLEFT \ENDBUFFER 1 START)))
+                                    (CHARCODE SPACE))
+                                (NEQ (\SYNCODE \RDTBLSA (FIRSTCHAR (TTNLEFT TAIL 1 START)))
+                                     ESCAPE.RC)) do 
+
+                                 (* ;; "Strip blanks, e.g., resulting from escape completion, so that Lispx does not do its silly ...  thing.  Be careful not to strip a quoted space")
+
+                                                       (SETQ \ENDBUFFER TAIL]
+          (COND
+             (DRIBFL                                         (* ; "print answer on typescript file")
+                    (TTECHO.TO.FILE DRIBFL T)))
+          (for X inside ECHOTOFILE do (TTECHO.TO.FILE X))
+          (COND
+             [(EMPTY.BUFFER)                                 (* ; 
+                                      "blank line.  RESULT is NIL unless set above by a read macro")
+              (COND
+                 ((OR RESULT (EQ FINALCHAR (CHARCODE EOL)))
+                  (SETLASTC (CHARCODE EOL))
+                  (RETURN RESULT]
+             ((EQ (CAR \BUFFER)
+                  TTYINCOMMENTCHAR)                          (* ; "comment")
+              (RETURN 'ABORT))
+             ((AND (EQ (CDR \BUFFER)
+                       \ENDBUFFER)
+                   (EQ (CAR \BUFFER)
+                       (CHARCODE ?))
+                   (OR HELP (AND \NOVALUE \REPEAT)))         (* ; "a bare ?")
+              (TTGIVEHELP (OR HELP "Terminate text with control-Z."))
+              (RETURN 'ABORT))
+             (T                                              (* ; 
+                                                          "Save last buffer position for posterity")
+                (replace (TTYINBUFFER OLDTAIL) of \TTYINSTATE with \ENDBUFFER)))
+          (SETQ ORIGBUFFER \BUFFER)
+          [COND
+             [\READING (SETQ RESULT (COND
+                                       (\FILLINGBUFFER (TTYIN.READ FINALCHAR T \LINEBUF.OFD))
+                                       (T (TTYIN.READ FINALCHAR NIL (TTYIN.SCRATCHFILE]
+             ((AND HELP (FIND.MATCHING.WORD '(? HELP)
+                               \BUFFER \ENDBUFFER))
+              (TTGIVEHELP HELP)                          (* ; "help handled; now restart ")
+              (RETURN 'ABORT))
+             ((AND \STRINGVALUE (NOT \COMMAND))              (* ; 
+                                          "Return input as string, no other special interpretation")
+              (SETQ RESULT (TTYINSTRING ORIGBUFFER)))
+             (T
+              (SETQ WORD (TTRATOM))
+              [for RESPONSE in TTYINRESPONSES when (AND (EQMEMB WORD (CAR RESPONSE))
+                                                                    (OR (EQ \BUFFER \ENDBUFFER)
+                                                                        (CADDR RESPONSE)))
+                 do 
+
+                       (* ;; "Process global user option.  RESPONSE is a triple (commands response-form rest-of-line-arg);  if user gives one of the commands, the response form is evaluated with \COMMAND set to the command and LINE set to the remainder of the line;  the third component says how to compute LINE: as a STRING or as a LIST;  if NIL, means there should be nothing else on the line.  If the response form returns the atom IGNORE, the input is not considered to be a special response and the normal computation proceeds;  otherwise it is assumed the response has been processed, and we return to the original TTYIN prompt for more input.  Response-form may be an atom, in which case it is APPLYed to \COMMAND and LINE.")
+
+                       (COND
+                          ((NEQ [PROG [(\COMMAND WORD)
+                                       (\BUFFER \BUFFER)
+                                       (LINE (COND
+                                                ((EQ \BUFFER \ENDBUFFER)
+                                                 NIL)
+                                                ((EQ (CADDR RESPONSE)
+                                                     'STRING)
+                                                 (TTYINSTRING \BUFFER))
+                                                (T (TTREADLIST]
+                                      (DECLARE (SPECVARS \COMMAND \BUFFER LINE))
+                                      (RETURN (COND
+                                                 ((LITATOM (CADR RESPONSE))
+                                                  (APPLY* (CADR RESPONSE)
+                                                         \COMMAND LINE))
+                                                 (T (EVAL (CADR RESPONSE]
+                                'IGNORE)
+                           (RETFROM 'TTYIN.FINISH 'ABORT))
+                          (T 
+                             (* ;; "That response was ignored.  We could quit the iteration now, but continue in case there is another entry with the same command.  I.e.  user can 'redefine' special responses this way, but still let the old definition happen if the input looks wrong")
+]
+              [SETQ WORD (COND
+                            ((TTADJUSTWORD WORD))
+                            ((AND (NULL WORD)
+                                  (NULL SPLST))              (* ; 
+                                                      "NIL is acceptable response, so don't abort!")
+                             NIL)
+                            (T (RETURN 'ABORT]
+              [SETQ RESULT (COND
+                              [(EQ \BUFFER \ENDBUFFER)
+                               (COND
+                                  (\COMMAND (LIST WORD))
+                                  (\NOVALUE T)
+                                  (T (LIST WORD]
+                              (\STRINGVALUE                  (* ; 
+           "return (command . string).  Note that if \command is false, we handled it much earlier")
+                                     (CONS WORD (TTYINSTRING \BUFFER)))
+                              (\NOVALUE (COND
+                                           (\COMMAND (CONS WORD T))
+                                           (T T)))
+                              (T (SETQ RESULT (TTREADLIST))
+                                 (COND
+                                    ((OR \COMMAND (NULL SPLST))
+                                                             (* ; 
+                                                   "only check first word typed, or nothing at all")
+                                     (CONS WORD RESULT))
+                                    (T (for TL on RESULT
+                                          do [RPLACA TL (COND
+                                                               ((TTADJUSTWORD (CAR TL)))
+                                                               ((AND (NULL (CAR TL))
+                                                                     (NULL \FIX))
+                                                             (* ; 
+                                                      "NIL is acceptable response, so don't abort!")
+                                                                NIL)
+                                                               (T (RETURN 'ABORT]
+                                          finally (RETURN (CONS WORD RESULT]
+              (SETLASTC FINALCHAR)
+              (PROGN
+
+               (* ;; "All this nonsense is just to convince prettyprint to keep the indentation down to a reasonable amount")
+
+               (PROGN
+                (PROGN
+                 (PROGN
+                  (PROGN
+                   (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN
+                                                                                          NIL]
+
+     (* ;; "We have now processed the line, with the relevant value being RESULT...")
+
+          [COND
+             ((AND TTYINUSERFN (LISTP RESULT))
+              (COND
+                 ((EQ (SETQ X (APPLY* TTYINUSERFN RESULT))
+                      T)                                     (* ; 
+                                                  "Special response has been processed;  try again")
+                  (RETURN 'ABORT))
+                 (X                                          (* ; "this is what we should return")
+                    (RETURN X]
+          (SETQ \CURRENTDISPLAYLINE 0)                       (* ; "get scrolling right (again)")
+                                                             (* ; "see system \CLOSELINE")
+          (RETURN RESULT])
+
+(TTYIN.BALANCE
+  [LAMBDA (ERRORFLG ADDPARENS)                               (* ; "Edited 17-Jan-88 16:36 by bvm:")
+    (LET ((X (TTSKREAD \BUFFER NIL ADDPARENS)))
+         (PROG1 (COND
+                   [(OR (EQ X \ENDBUFFER)
+                        (AND (LISTP X)
+                             (EQ (\SYNCODE \RDTBLSA (FIRSTCHAR X))
+                                 RIGHTBRACKET.RC)
+                             (AT.END.OF.TEXT (CDR X]
+                   ((FIXP X)                                 (* ; 
+                                                    "Number of parens you'd have to add to balance")
+                    (MOVE.TO.WHEREVER \ENDBUFFER)
+                    (RPTQ X (ADDCHAR (CHARCODE ")")))
+                    (SETQ X NIL)
+                    T)
+                   (T (COND
+                         ((AND ERRORFLG (EQ \CURSOR (OR X \ENDBUFFER)))
+                                                             (* ; "Only beep if cursor won't move")
+                          (BEEP)))
+                      NIL))
+             (MOVE.TO.WHEREVER (OR X \ENDBUFFER)))])
+
+(ADDCHAR
+  [LAMBDA (CHAR)
+    (DECLARE (USEDFREE \CURSORCOL \ARROW \RMARG \CURSOR \AUTOFILL))
+                                                             (* ; "Edited 24-May-91 11:09 by jds")
+
+(* ;;; "Add CHAR to buffer and print it, advancing cursor position appropriately")
+
+    (LET ([WIDTH (COND
+                    ((COMPLEXCHARP CHAR)
+                     (fetch (COMPLEXCHAR CPXWIDTH) of CHAR))
+                    (T (TTBITWIDTH CHAR]
+          (ENDP (AT.END.OF.LINE)))
+         (END.DELETE.MODE)
+         (OVERFLOW? WIDTH)
+         (COND
+            ((NOT ENDP)                                      (* ; 
+                                                       "Inserting in middle of line, so make space")
+             (TTINSERTSECTION WIDTH)))
+         (COND
+            ((COMPLEXCHARP CHAR)
+             (for PC in (fetch (COMPLEXCHAR CPXPRINTCHARS) of CHAR)
+                do (TTBOUT PC)))
+            (T (TTBOUT CHAR)))
+         (INSERT.NODE \CURSOR)
+         (FRPLACA \CURSOR CHAR)
+         (SETQ \CURSOR (CDR \CURSOR))
+         (add \CURSORCOL WIDTH)
+         [COND
+            (ENDP (replace (LINE END) of \ARROW with \CURSOR)
+                  (replace (LINE LASTCOL) of \ARROW with \CURSORCOL)
+                                                             (* ; 
+                                      "If we just advanced past the last column, do autofill stuff")
+                  (OVERFLOW? 0))
+            (T                                               (* ; 
+                                              "Check to see if line got shoved beyond right margin")
+               (LET ((OVFL (IDIFFERENCE (add (fetch (LINE LASTCOL) of \ARROW)
+                                               WIDTH)
+                                  \RMARG)))
+                    (COND
+                       ((OR (IGREATERP OVFL 0)
+                            (AND (EQ OVFL 0)
+                                 \AUTOFILL))
+                        (ADJUSTLINE (AND \AUTOFILL T))
+                        (MOVE.TO.WHEREVER \CURSOR]
+         NIL])
+
+(TTMAKECOMPLEXCHAR
+  [LAMBDA (REALCHAR PRINTCHARS)                              (* bvm%: "16-Apr-85 16:50")
+    (LET ((WIDTH 0)
+          (NC 0))
+         (for C in PRINTCHARS do (add WIDTH (TTBITWIDTH C))
+                                            (add NC 1))
+         (create COMPLEXCHAR
+                CPXREALCHAR _ REALCHAR
+                CPXWIDTH _ WIDTH
+                CPXNCHARS _ NC
+                CPXPRINTCHARS _ PRINTCHARS])
+
+(ADDNAKEDCHAR
+  [LAMBDA (CHAR NOAUTOFILL)                                  (* bvm%: "17-Apr-85 19:46")
+
+(* ;;; "Adds CHAR with no special processing, e.g.  most control chars (except cr and lf, which I can't figure out yet) go thru ok.")
+
+    (COND
+       ((AND (IGREATERP CHAR 32)
+             (NEQ CHAR 127))
+        (ADDCHAR CHAR))
+       (T (SELCHARQ CHAR
+               (CR                                           (* ; "CR can be attempted if at end")
+                   (COND
+                      ((AT.END.OF.BUF)
+                       (START.NEW.LINE EOLCHARCODE))
+                      (T (BEEP))))
+               (SPACE (OR (AND (NOT NOAUTOFILL)
+                               (AUTOCR?))
+                          (ADDCHAR (CHARCODE SPACE))))
+               (ESCAPE                                       (* ; "Altmode will echo as $")
+                       [ADDCHAR (TTMAKECOMPLEXCHAR CHAR (LIST (CHARCODE $])
+               (TAB (TTADDTAB))
+               (ADDCHAR (TTMAKECOMPLEXCHAR CHAR (LIST (CHARCODE ^)
+                                                              (COND
+                                                                 ((EQ CHAR (CHARCODE DEL))
+                                                             (* ; "DELETE is represented as ^?")
+                                                                  (CHARCODE ?))
+                                                                 (T (LOGOR CHAR 64])
+
+(TTADDTAB
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 10:33 by jds")
+
+    (* ;; "Represent <tab> in buffer as a tab with 128 bit on, followed by the appropriate number of spaces, each with 256 bit on.  Tab is always self-inserting, i.e.  it never overwrites anything (except itself, as above)")
+
+    (ADDCHAR (TTMAKECOMPLEXCHAR (CHARCODE TAB)
+                        (from (LOGAND (IQUOTIENT (IDIFFERENCE \CURSORCOL (fetch (LINE 
+                                                                                             FIRSTCOL
+                                                                                              )
+                                                                                of \ARROW))
+                                                 \CHARWIDTH)
+                                         7) to 7 collect (CHARCODE SPACE])
+
+(ADJUSTLINE
+  [LAMBDA (JUSTIFYING LINE)                                  (* ; "Edited 24-May-91 10:33 by jds")
+
+    (* ;; "Handles patching up lines that are too long or short.  Assures that the current line, ARROW, is correct with regard to overflows.  If JUSTIFYING is true, it is a number specifying how many lines to 'justify' , by which we mean moving text around so that each line has as many words as possible for the linelength, but does not overflow.  We don't do anything very fancy with that, like take care of deleting extra spaces.")
+
+    (PROG ((IDEALLENGTH (- [COND
+                              ((> TTYJUSTLENGTH 0)
+                               (IMIN \RMARG (TIMES TTYJUSTLENGTH \CHARWIDTH)))
+                              (T                             (* ; "Relative to right margin")
+                                 (IMAX (- \RMARG (TIMES (- TTYJUSTLENGTH)
+                                                        \CHARWIDTH))
+                                       (+ (LRSH (- \RMARG \LMARG)
+                                                1)
+                                          \LMARG]
+                           \LMARG))
+           BREAK LASTCOL NEWENDLINE NEXTLINE OLDENDLINE OVFL START USECR ROW %#BITS)
+          (OR LINE (SETQ LINE \ARROW))
+          (SETQ ROW (fetch (LINE ROW) of LINE))
+      LP  (SETQ NEXTLINE (fetch (LINE NEXTLINE) of LINE))
+          (SETQ OVFL (OVERFLOWLINE? LINE))
+          (SETQ %#BITS (- \RMARG (fetch (LINE LASTCOL) of LINE)))
+          (SETQ USECR (SETQ BREAK NIL))
+          (SETQ START (fetch (LINE START) of LINE))
+          (COND
+             ((< %#BITS 0)
+
+              (* ;; "Too much on line;  need to break it somewhere, preferably at a space if permissible.  If justifying, try to break at the appropriate length")
+
+              (COND
+                 ([OR (AND JUSTIFYING (< (+ (fetch (LINE FIRSTCOL) of LINE)
+                                            IDEALLENGTH)
+                                         \RMARG)
+                           (SETQ BREAK (FIND.LINE.BREAK START (NTH.RELATIVE.COLUMN.OF LINE 
+                                                                         IDEALLENGTH)
+                                              T)))
+                      (PROGN (SETQ NEWENDLINE (NTH.COLUMN.OF LINE \RMARG))
+                             (AND (OR JUSTIFYING \AUTOFILL)
+                                  (SETQ BREAK (FIND.LINE.BREAK START NEWENDLINE T]
+                  (SETQ USECR T))
+                 (T (SETQ BREAK NEWENDLINE)))
+              (GO DOBREAK))
+             [(AND OVFL (NEQ %#BITS 0)
+                   (NEQ (SETQ NEWENDLINE (NTH.RELATIVE.COLUMN.OF NEXTLINE %#BITS))
+                        (fetch (LINE START) of NEXTLINE)))
+
+              (* ;; "Line is too short, but is an overflow line, so text MUST be moved to fill the gap;  alternatively, if we are justifying, we could break the line sooner")
+
+              (* ;; "NEWENDLINE = where the line should end, based on linelength")
+
+              (COND
+                 ([OR (EQ (fetch (LINE END) of LINE)
+                          NEWENDLINE)
+                      (AND (OR \AUTOFILL JUSTIFYING)
+                           (SETQ BREAK (FIND.LINE.BREAK (fetch (LINE END) of LINE)
+                                              NEWENDLINE JUSTIFYING))
+                           (SETQ NEWENDLINE BREAK))
+                      (NOT JUSTIFYING)
+                      (NOT (SETQ BREAK (FIND.LINE.BREAK START (fetch (LINE END) of LINE)
+                                              T]
+                  (GO DOJOIN))
+                 (T (SETQ USECR T)
+                    (GO DOBREAK]
+             ((NOT JUSTIFYING)
+              (RETURN))
+             [(OR OVFL (AND (NEQ JUSTIFYING T)
+                            (> (- (fetch (LINE LASTCOL) of LINE)
+                                  (fetch (LINE FIRSTCOL) of LINE))
+                               IDEALLENGTH)))                (* ; "line is longer than we'd like")
+              (COND
+                 ((SETQ BREAK (FIND.LINE.BREAK START (NTH.RELATIVE.COLUMN.OF LINE IDEALLENGTH
+                                                                )
+                                     T))
+                  (SETQ USECR T)
+                  (GO DOBREAK]
+             [[AND (NOT (EMPTY.LINE LINE))
+                   (NOT (START.OF.PARAGRAPH? NEXTLINE))
+                   (OR (NEQ JUSTIFYING T)
+                       (EQ (CAR (fetch (LINE END) of LINE))
+                           (CHARCODE SPACE]
+
+              (* ;; "Don't move up text from next line if it is blank or starts with tab -- treat those as paragraph breaks")
+
+              (* ;; "Note that we are guaranteed at this point that LINE is not an overflow line, so (fetch END of LINE) points at a space or cr")
+
+              (COND
+                 ((OR (EQ [SETQ BREAK (NTH.RELATIVE.COLUMN.OF
+                                       NEXTLINE
+                                       (SUB1 (IMIN (- (+ IDEALLENGTH (fetch (LINE FIRSTCOL)
+                                                                        of LINE))
+                                                      (fetch (LINE LASTCOL) of LINE))
+                                                   %#BITS]
+                          (fetch (LINE END) of NEXTLINE))
+                      (SETQ BREAK (FIND.LINE.BREAK (fetch (LINE START) of NEXTLINE)
+                                         BREAK T)))
+                  (SETQ NEWENDLINE BREAK)                    (* ; 
+                                           "At least one more word from next line will fit up here")
+                  (GO DOJOIN))
+                 (T                                          (* ; 
+                              "No text movement, but if line ended in a real <cr>, make it a space")
+                    (FRPLACA (fetch (LINE END) of LINE)
+                           (CHARCODE SPACE]
+             ((EQ JUSTIFYING T)                              (* ; "If this line is fine, quit")
+              ))
+          (SETQ LINE NEXTLINE)
+          (GO BOTTOM)
+      DOJOIN
+          
+
+     (* ;; "Move text from next line up to this one.  NEWENDLINE is where line should end when done.  BREAK=NEWENDLINE if this new end line is a pseudo-cr break")
+
+          (COND
+             ((EQ (SETQ OLDENDLINE (fetch (LINE END) of LINE))
+                  NEWENDLINE)
+              (SETQ %#BITS 0))
+             (T (GO.TO.RELATIVE (fetch (LINE LASTCOL) of LINE)
+                       ROW)
+                (SETQ %#BITS (SEGMENT.BIT.LENGTH OLDENDLINE NEWENDLINE))
+                                                             (* ; 
+                                                           "# chars to delete from next line")
+                [COND
+                   ((NOT OVFL)                               (* ; 
+                                          "Joining toa non-overflow line: turn its cr into a space")
+                    (FRPLACA OLDENDLINE (CHARCODE SPACE))
+                    (while (AND (NEQ (CDR OLDENDLINE)
+                                         NEWENDLINE)
+                                    (EQ (CADR OLDENDLINE)
+                                        (CHARCODE SPACE))) do 
+                                                             (* ; 
+                                                           "strip leading spaces from next line")
+                                                                 (KILLSEGMENT OLDENDLINE
+                                                                        (CDR OLDENDLINE)))
+                    (COND
+                       ((EQ (CAR (NLEFT (fetch (LINE START) of LINE)
+                                        1 OLDENDLINE))
+                            (CHARCODE %.))                   (* ; 
+                                                           "LINE ends in period, so space twice")
+                        (FRPLACA (INSERT.NODE OLDENDLINE)
+                               (CHARCODE SPACE]
+                (TYPE.BUFFER OLDENDLINE NEWENDLINE)
+                (replace (LINE END) of LINE with NEWENDLINE)
+                (replace (LINE LASTCOL) of LINE with \CURSORCOL)))
+          (GO.TO.RELATIVE 'LINE NEXTLINE)
+          (replace (LINE START) of NEXTLINE
+             with (COND
+                         (BREAK (FRPLACA BREAK (CHARCODE SPACE))
+                                                             (* ; 
+                                                   "In case BREAK was at the CR turn it into space")
+                                (COND
+                                   (OVFL (add %#BITS (TTBITWIDTH (CHARCODE SPACE)))
+                                                             (* ; "will delete space also")
+                                         ))
+                                (CDR NEWENDLINE))
+                         (T NEWENDLINE)))
+          (COND
+             ((EQ (fetch (LINE END) of NEXTLINE)
+                  NEWENDLINE)
+              (DELETELINE NEXTLINE T)                    (* ; "Nothing left here, so kill it")
+              [COND
+                 (JUSTIFYING                                 (* ; 
+                                                           "maybe we can move from next line, too")
+                        (COND
+                           ((AND (NEQ JUSTIFYING T)
+                                 (NEQ (SUB1VAR JUSTIFYING)
+                                      0))
+                            (GO LP))
+                           (T (RETURN]
+              (SETQ LINE (fetch (LINE NEXTLINE) of LINE)))
+             (T (TTDELSECTION %#BITS)
+                (replace (LINE LASTCOL) of NEXTLINE with (- (fetch (LINE LASTCOL)
+                                                                           of NEXTLINE)
+                                                                        %#BITS))
+                (SETQ LINE NEXTLINE)))
+          (GO BOTTOM)
+      DOBREAK
+          
+
+     (* ;; "Break line at BREAK, moving excess down to next line or a new line.  USECR is true if break is to act like a cr;  otherwise we are breaking a too-long line at the right margin, so there is no end of line place holder")
+
+          [replace (LINE LASTCOL) of LINE with (SETQ LASTCOL
+                                                            (+ (SEGMENT.BIT.LENGTH
+                                                                (fetch (LINE START) of LINE)
+                                                                BREAK)
+                                                               (fetch (LINE FIRSTCOL)
+                                                                  of LINE]
+                                                             (* ; "Column where break will occur")
+          [SETQ %#BITS (SEGMENT.BIT.LENGTH BREAK (SETQ OLDENDLINE (fetch (LINE END)
+                                                                         of LINE]
+                                                             (* ; "length of segment being moved")
+          (COND
+             ((NEQ LASTCOL \RMARG)
+              (GO.TO.RELATIVE LASTCOL ROW)               (* ; 
+           "Go wipe out what was there.  Don't need to do this if the break is right at the margin")
+              (ERASE.TO.END.OF.LINE)))
+          (replace END of LINE with BREAK)
+          [COND
+             (USECR                                          (* ; 
+                                                       "we have counted one char too many above...")
+                    [SETQ %#BITS (- %#BITS (TTBITWIDTH (CHARCODE SPACE]
+                    (SETQ BREAK (CDR BREAK]
+          (COND
+             [[AND NEXTLINE (OR OVFL (AND (OR (SMALLP JUSTIFYING)
+                                              (AND (EQ (CAR OLDENDLINE)
+                                                       (CHARCODE SPACE))
+                                                   (< (+ (fetch LASTCOL of NEXTLINE)
+                                                         %#BITS)
+                                                      \RMARG)))
+                                          (NOT (START.OF.PARAGRAPH? NEXTLINE]
+
+              (* ;; "Insert the text on the next line, rather than starting new line, if justifying, overflow (forced), or the text will fit, i.e.  not cause anything to be bumped off the next line")
+
+              (GO.TO.RELATIVE 'LINE (SETQ LINE NEXTLINE))
+              (COND
+                 ((NOT OVFL)
+
+                  (* ;; "Turn the terminating <cr> into ordinary space;  this space also needs to be inserted and counted, of course")
+
+                  (add %#BITS (TTBITWIDTH (CHARCODE SPACE)))
+                  (SETQ OLDENDLINE (CDR (FRPLACA OLDENDLINE (CHARCODE SPACE]
+             (T (SETQ LINE (INSERTLINE LINE))
+                (replace END of LINE with OLDENDLINE)))
+          (replace START of LINE with BREAK)
+          (INSERT.TEXT BREAK OLDENDLINE (fetch END of LINE))
+          (add (fetch LASTCOL of LINE)
+                 %#BITS)
+      BOTTOM
+          (COND
+             (LINE (ADD1VAR ROW)
+                   (COND
+                      ((AND JUSTIFYING (NEQ JUSTIFYING T)
+                            (EQ (SUB1VAR JUSTIFYING)
+                                0))
+                       (SETQ JUSTIFYING NIL)))
+                   (GO LP])
+
+(ADJUSTLINE.AND.RESTORE
+  [LAMBDA (JUSTIFYING)                                       (* ; "Edited 24-May-91 10:33 by jds")
+    (SAVE.CURSOR)
+    (ADJUSTLINE JUSTIFYING)
+    (COND
+       ((IGREATERP \HOMECOL (fetch (LINE LASTCOL) of \ARROW))
+                                                             (* ; "Oops, cursor must have moved")
+        (MOVE.TO.WHEREVER \CURSOR))
+       (T (RESTORE.CURSOR])
+
+(AT.END.OF.SCREEN
+  [LAMBDA NIL                                              (* bvm%: "11-Apr-85 14:58")
+    (OR (AT.END.OF.LINE)
+        (IGREATERP (IPLUS \CURSORCOL (SEGMENT.LENGTH \CURSOR (TTNEXTCHAR \CURSOR))
+                          \CHARWIDTH)
+               \RMARG])
+
+(AT.END.OF.TEXT
+  [LAMBDA (BUF)                                              (* bvm%: "11-Apr-85 15:00")
+
+    (* ;; "Checks that this is the last printing char in buffer.  Fancier than just checking that BUF = ENDBUFFER, since that would mess up if user deletes a line and decides to terminate on previous line")
+
+    (for (X _ BUF) by (TTNEXTCHAR X) until (EQ X \ENDBUFFER)
+       always (SPACEP (FIRSTCHAR X])
+
+(AUTOCR?
+  [LAMBDA NIL                                              (* bvm%: "16-Apr-85 18:57")
+
+    (* ;; "Terminates line if near edge of screen and in autofill mode")
+
+    (COND
+       ((AND \AUTOFILL (IGREATERP (IPLUS \CURSORCOL TTYINAUTOFILLMARGIN)
+                              \RMARG))
+        [COND
+           ((AT.END.OF.LINE)
+            (START.NEW.LINE (CHARCODE SPACE)))
+           (T (BREAKLINE (CHARCODE SPACE]
+        T])
+
+(BACKSKREAD
+  [LAMBDA (BUF NOTIFQUOTED)                                  (* ; "Edited  8-Feb-88 12:45 by bvm:")
+
+    (* ;; "Returns buffer position of start of list containing cursor position BUF, or start of buffer.  If NOTIFQUOTED is true, then returns NIL if the paren/bracket at BUF is quoted with the escape char or is inside a string.  Strategy: start at beginning of buffer and TTSKREAD forward (much easier);  if read ends at BUF, we win;  if ends before BUF, then resume reading there (we skipped an internal list);  otherwise if read did not end, BUF must be inside a list, so scan ahead for start of an inner list, and repeat")
+
+    (PROG ((B \BUFFER)
+           (INNERMOSTLIST \BUFFER)
+           ESCAPED BRACKETFLG X)
+      LP  [COND
+             ((EQ B BUF)                                     (* ; "No list in buffer at all")
+              (RETURN (AND (OR (NOT NOTIFQUOTED)
+                               (NOT ESCAPED))
+                           INNERMOSTLIST]
+          [SELECTC (\SYNCODE \RDTBLSA (FIRSTCHAR B))
+              ((LIST LEFTPAREN.RC LEFTBRACKET.RC)            (* ; 
+                                      "open paren or bracket.  Try scanning this new internal list")
+                   [COND
+                      (ESCAPED                               (* ; "Inside a multiple escape"))
+                      ((EQ (SETQ X (TTSKREAD (CDR B)
+                                          BUF))
+                           BUF)
+                       (RETURN (OR BRACKETFLG B)))
+                      (X                                     (* ; 
+                                                           "Skip over internal list just scanned")
+                         (SETQ B X))
+                      (T 
+                         (* ;; "The TTSKREAD failed, so BUF must be at least this deeply nested.  Save pointer here in case we abort inside a string or such")
+
+                         (SETQ INNERMOSTLIST B)
+                         (COND
+                            ((AND (EQ (CAR B)
+                                      (CHARCODE %[))
+                                  (EQ (CAR BUF)
+                                      (CHARCODE %])))
+
+                             (* ;; "Brackets may match;  save position of this open bracket.  Otherwise we'll return the innermost list, rather than the start of the bracket expression")
+
+                             (SETQ BRACKETFLG B])
+              (ESCAPE.RC                                     (* ; "  to quote the next char")
+                         [COND
+                            ((EQ (CDR B)
+                                 BUF)
+
+                             (* ;; "The char at BUF is quoted.  This is why TTSKREAD failed here.  Just return the list we're now inside")
+
+                             (RETURN (AND (NOT NOTIFQUOTED)
+                                          INNERMOSTLIST)))
+                            (T                               (* ; "skip over escape char")
+                               (SETQ B (CDR B])
+              (STRINGDELIM.RC                                (* ; "double-quote")
+                   [COND
+                      ([AND (NOT ESCAPED)
+                            (NOT (SETQ B (FIND.MATCHING.QUOTE (CDR B)
+                                                BUF]         (* ; 
+                                                           "Termination analogous to previous case")
+                       (RETURN (AND (NOT NOTIFQUOTED)
+                                    INNERMOSTLIST])
+              (MULTIPLE-ESCAPE.RC 
+                   (SETQ ESCAPED (NOT ESCAPED)))
+              (OTHER.RC NIL)
+              (PROGN (COND
+                        ((AND (EQ (CAR B)
+                                  (CHARCODE ;))
+                              (READTABLEPROP RDTBL 'COMMONLISP))
+                                                             (* ; "Handle semicolon special")
+                         (COND
+                            ([do (SETQ B (CDR B))
+                                    (COND
+                                       ((EQ B BUF)
+                                        (RETURN T))
+                                       ((EQ (FIRSTCHAR B)
+                                            (CHARCODE EOL))
+                                        (RETURN]             (* ; "Done inside a comment")
+                             (RETURN (AND (NOT NOTIFQUOTED)
+                                          INNERMOSTLIST]
+          (SETQ B (CDR B))
+          (GO LP])
+
+(BACKWARD.DELETE.TO
+  [LAMBDA (BUF)                                              (* bvm%: "19-MAR-81 11:55")
+    (FORWARD.DELETE.TO (PROG1 \CURSOR (MOVE.BACK.TO BUF])
+
+(BREAKLINE
+  [LAMBDA (USECR STAY)
+    (DECLARE (USEDFREE \CURSOR \ARROW \CURSORCOL \CURSOR))
+                                                             (* ; "Edited 24-May-91 10:33 by jds")
+
+(* ;;; "Break current line at \CURSOR position, inserting a suitable <cr> if USECR is given.  If STAY is true, \CURSOR does not move;  otherwise cursor moves to first position of new line.")
+
+    (PROG ((OLDLINE \ARROW)
+           (OLDEND (fetch (LINE END) of \ARROW)))
+          (replace (LINE END) of \ARROW with \CURSOR)
+                                                             (* ; 
+                                                       "terminate current line at \CURSOR position")
+          (replace (LINE LASTCOL) of \ARROW with \CURSORCOL)
+          (ERASE.TO.END.OF.LINE)
+          (COND
+             (STAY (SAVE.CURSOR)))
+          (SETQ \ARROW (INSERTLINE \ARROW USECR))
+          (COND
+             ((NOT STAY)
+              (SAVE.CURSOR)))
+          (replace (LINE END) of \ARROW with OLDEND)
+          [COND
+             [(EQ \CURSOR OLDEND)                            (* ; 
+                                        "cr was inserted at end of line.  Maybe this never happens")
+              (replace (LINE END) of \ARROW with (SETQ \CURSOR (CDR OLDEND]
+             (T (TYPE.BUFFER (SETQ \CURSOR (fetch (LINE START) of \ARROW))
+                       OLDEND)                               (* ; 
+                                                           "Restore to screen what we erased above")
+                (replace (LINE LASTCOL) of \ARROW with \CURSORCOL)
+                (COND
+                   ((OVERFLOWLINE? \ARROW)
+
+                    (* ;; "the previous line overflowed, but when we inserted a cr we added more space on the line, so go fix it up")
+
+                    (ADJUSTLINE]
+          [COND
+             (STAY                                           (* ; 
+                                                        "Oh well, undo what we did to poor \CURSOR")
+                   (SETQ \CURSOR (fetch (LINE END) of (SETQ \ARROW OLDLINE]
+          (RESTORE.CURSOR])
+
+(BUFTAILP
+  [LAMBDA (TAIL START END)                                   (* bvm%: "23-JUN-81 15:48")
+    (do (COND
+               ((EQ TAIL START)
+                (RETURN TAIL))
+               ((OR (NOT START)
+                    (EQ START END))
+                (RETURN)))
+           (SETQ START (CDR START])
+
+(CHECK.MARGIN
+  [LAMBDA (BUF LINE)                                         (* ; "Edited 24-May-91 10:33 by jds")
+
+(* ;;; "If BUF is the pseudo-cr at the end of this LINE, then back it up one, since you can't let the cursor sit on it")
+
+    (COND
+       ((AND (EQ (fetch (LINE END) of LINE)
+                 BUF)
+             (OR (EQ (fetch (LINE LASTCOL) of LINE)
+                     \RMARG)
+                 (EQ (fetch (LINE START) of (fetch (LINE NEXTLINE) of LINE))
+                     BUF)))
+        (TTNLEFT BUF 1 (fetch (LINE START) of LINE)))
+       (T BUF])
+
+(CLEAR.LINE?
+  [LAMBDA (FLG)                                              (* lmm "20-Nov-86 00:27")
+                                                             (* ; "If FLG true, erase lots")
+    (COND
+       (FLG (ERASE.TO.END.OF.PAGE))
+       (T (ERASE.TO.END.OF.LINE])
+
+(CURRENT.WORD
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 10:34 by jds")
+
+    (* ;; "Used by word-completion routines.  Returns position in buffer of the start of the current word, or NIL if no word is in progress, or \COMMAND is true and this is not the first word, or the line is a comment.  Definition of 'word' here is different from that of WORDSEPRP since we want only words with respect to the reader, not with respect to text")
+
+    (COND
+       ((AND (NOT (AT.START.OF.LINE))
+             (NEQ (CAR (fetch (LINE START) of \ARROW))
+                  TTYINCOMMENTCHAR))
+        (for (X _ (fetch (LINE START) of \ARROW)) by (TTNEXTCHAR X)
+           until (EQ X \CURSOR) bind (NEW _ T)
+                                          SNX
+           do                                            (* ; 
+                                                      "NEW is true after we scan a break character")
+                 (SETQ SNX (\SYNCODE \RDTBLSA (FIRSTCHAR X)))
+                 (COND
+                    ((COND
+                        (NEW                                 (* ; 
+                                        "Most ANY funny character at start of word considered sepr")
+                             (SELECTC SNX
+                                 ((LIST OTHER.RC ESCAPE.RC MULTIPLE-ESCAPE.RC) 
+                                                             (* ; "Looks like good start of word")
+                                      NIL)
+                                 T))
+                        (T                                   (* ; 
+                                        "If in middle of word, only 'terminating macros' stop word")
+                           (fetch STOPATOM of SNX)))
+                     (SETQ NEW T))
+                    (NEW                                     (* ; 
+                                                        "This is the start of a new word;  note it")
+                         (COND
+                            ((AND $$VAL \COMMAND)            (* ; "Means this is second word")
+                             (RETURN)))
+                         (SETQ $$VAL X)
+                         (SETQ NEW NIL))) finally (RETURN (AND (NOT NEW)
+                                                                     $$VAL])
+
+(DELETE.TO.END
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 10:34 by jds")
+
+(* ;;; "Kills buffer from \CURSOR onward")
+
+    (SETTAIL? T)
+    (COND
+       (DISPLAYTERMFLG (ERASE.TO.END.OF.PAGE)))
+    (COND
+       ((fetch (LINE NEXTLINE) of \ARROW)            (* ; 
+                                       "There are lines after this, so return them to garbage heap")
+        (KILL.LINES (fetch (LINE NEXTLINE) of \ARROW))
+        (replace (LINE NEXTLINE) of \ARROW with NIL)))
+    (replace (LINE END) of \ARROW with (SETQ \ENDBUFFER \CURSOR))
+    (replace (LINE LASTCOL) of \ARROW with \CURSORCOL])
+
+(DELETELINE
+  [LAMBDA (LINE EMPTYLINE?)                                  (* ; "Edited 24-May-91 10:34 by jds")
+
+    (* ;; "Deletes this LINE from buffer and screen;  assumes cursor is currently positioned somewhere on the line.  EMPTYLINE?  is true on calls from ADJUSTLINE where the line is naked and hence no text in the buffer needs to be killed.")
+
+    (PROG ((NEXTLINE (fetch (LINE NEXTLINE) of LINE))
+           OLDSTART NEWSTART PREVLINE)
+          [COND
+             ((AND (EQ LINE \ARROW)
+                   (ON.FIRST.LINE))
+              (COND
+                 ((NOT NEXTLINE)                             (* ; "Can't delete the only line")
+                  (RETURN (BEEP)))
+                 ((NEQ \PROMPT1 \PROMPT2)                    (* ; 
+                        "tricky to delete first line, since the correct prompt should be displayed")
+                  (MOVE.BACK.TO \BUFFER)
+                  (RETURN (FORWARD.DELETE.TO (fetch (LINE END) of \ARROW]
+          (COND
+             (DISPLAYTERMFLG (DO.DELETE.LINES 1)))
+          (RENUMBER.LINES NEXTLINE (fetch (LINE ROW) of LINE))
+          (replace (LINE NEXTLINE) of (SETQ PREVLINE (PREVLINE LINE 1)) with NEXTLINE
+                 )
+          [COND
+             ((NOT NEXTLINE)                                 (* ; 
+                                      "deleting last line: need to worry about \ENDBUFFER and such")
+              (SETQ \ENDBUFFER (fetch (LINE END) of PREVLINE)))
+             (T (replace (LINE NEXTLINE) of LINE with NIL)
+                                                             (* ; 
+                                                           "in preparation for KILL.LINES below")
+                (COND
+                   ((NOT EMPTYLINE?)
+                    (KILLSEGMENT (SETQ OLDSTART (fetch (LINE START) of LINE))
+                           (SETQ NEWSTART (fetch (LINE START) of NEXTLINE)))
+                                                             (* ; 
+                                      "flush anything on the line.  PREVLINE pointers remain valid")
+                    (COND
+                       ((EQ (fetch (LINE END) of NEXTLINE)
+                            NEWSTART)
+                        (replace (LINE END) of NEXTLINE with OLDSTART)))
+                    (replace (LINE START) of NEXTLINE with OLDSTART]
+          (KILL.LINES LINE)                              (* ; "return to heap")
+          (COND
+             ((EQ \ARROW LINE)                               (* ; 
+                                               "if this is our home position, adjust appropriately")
+              (SETQ \ARROW (SETQ LINE (OR NEXTLINE PREVLINE)))
+              (SETQ \CURSOR (fetch (LINE START) of LINE))
+              (GO.TO.RELATIVE 'LINE LINE])
+
+(DELETETO
+  [LAMBDA (TAIL)                                             (* ; "Edited 24-May-91 10:34 by jds")
+    (SETTAIL?)
+    (COND
+       ((NEQ \CURSOR \ENDBUFFER)                             (* ; 
+                                                      "On other terminals also when Cursor capable")
+        (BACKWARD.DELETE.TO TAIL))
+       (T [COND
+             [(NOT DISPLAYTERMFLG)
+              (COND
+                 ((NOT \DELETING)                            (* ; "prefix deletions with backslash")
+                  (COND
+                     ((NOT TTYINBSFLG)                       (* ; 
+                                                      "unless we are going to physically backspace")
+                      (TTBOUT \)))
+                  (SETQ \DELETING 0)))
+              (DELETETO1 TAIL)
+              (COND
+                 ((EQ TAIL \BUFFER)
+                  (END.DELETE.MODE]
+             (T (PROG ((N (SEGMENT.BIT.LENGTH TAIL \ENDBUFFER)))
+                                                             (* ; 
+                                                           "need to kill the previous N chars")
+
+                 (* ;; "(COND ((CAPABILITY?  ERASE.TO.END T) (* Ah, all we need do is go back N and erase to end) (DO.BACK N) (ERASE.TO.END.OF.LINE)) (T (* laborious technique for glass ttys: go back and wipe out each char one at a time) (FRPTQ N (PROGN (DO.BACK 1) (* back up) (TTBOUT SPACE) (* overwrite with space) (DO.BACK 1) (* and back up again)))))")
+
+                      (DSPBACKUP N \DSP)
+                      (SETQ \CURSORCOL (IDIFFERENCE \CURSORCOL N]
+          (replace (LINE END) of \ARROW with (SETQ \CURSOR (SETQ \ENDBUFFER TAIL)))
+          (replace (LINE LASTCOL) of \ARROW with \CURSORCOL])
+
+(DELETETO1
+  [LAMBDA (TAIL)                                             (* ; "Edited 24-May-91 11:09 by jds")
+
+(* ;;; "Not used in Interlisp-D")
+
+    (* ;; "on non-DMs: delete chars until we reach TAIL;  since we echo deleted chars in reverse order, this is most easily done recursively")
+
+    [COND
+       ((NEQ (CDR TAIL)
+             \ENDBUFFER)
+        (DELETETO1 (CDR TAIL]
+    (for CH inside (COND
+                              ((COMPLEXCHARP (CAR TAIL))
+                               (fetch (COMPLEXCHAR CPXPRINTCHARS) of (CAR TAIL)))
+                              (T (CAR TAIL))) do (SELECTQ TTYINBSFLG
+                                                         (NIL (TTBOUT CH))
+                                                         (LF 
+
+                                 (* ;; "physically backspace, crossing out character.  LF means we will do a LF when ENDELETE happens.  If we don't LF, then best not to cross out chars")
+
+                                                             (TTBOUT BS \ BS)
+                                                             (ADD1VAR \DELETING))
+                                                         (TTBOUT BS)))
+                                                             (* ; "echo deleted char")
+    (SETQ \CURSORCOL (SUB1 \CURSORCOL])
+
+(DO.EDIT.COMMAND
+  [LAMBDA (CHAR EDITARG)                                     (* ; "Edited 24-May-91 10:40 by jds")
+
+(* ;;; "Handles the various edit commands, which mostly move the cursor around in the buffer, or kill pieces of it.  CHAR is the character stripped of its editbit.  EDITARG is the argument, if any (not set by type-in, but by program asking for a particular edit function).  If this routine returns something, it means process it like ordinary character (this is how we can invoke non-editbit routines)")
+
+    (PROG (EDITMINUS L X LASTSKIP)
+          [COND
+             ((NOT EDITARG)
+              (SETQ EDITARG 1))
+             ((MINUSP EDITARG)
+              (SETQ EDITMINUS T)
+              (SETQ EDITARG (IMINUS EDITARG]
+      LP  [SELCHARQ (SETQ CHAR (U-CASECODE CHAR))
+               (CR 
+                   (* ;; "<edit>CR on empty buffer means get back last buffer;  in the middle of a buffer it is the same as normal CR, but also ends insert mode")
+
+                   [COND
+                      ((EMPTY.BUFFER)
+                       (RESTOREBUF))
+                      ((ON.LAST.LINE)
+                       (RETURN CHAR))
+                      (T (MOVE.TO.LINE (TTNEXTLINE \ARROW EDITARG])
+               ((SPACE >)                                    (* ; "move right")
+                    [COND
+                       (EDITMINUS (SETQ CHAR (CHARCODE DEL)) (* ; "backward space is delete")
+                              (GO NOMINUS))
+                       ((AT.END.OF.BUF)
+                        (BEEP))
+                       ((AT.END.OF.SCREEN)
+                        (MOVE.TO.NEXT.LINE))
+                       (T (MOVE.FORWARD.TO (TTNTH \CURSOR EDITARG])
+               ((DEL ^A BS <)                                (* ; "back up")
+                    [COND
+                       (EDITMINUS (SETQ CHAR (CHARCODE SPACE))
+                                                             (* ; "backward delete is space")
+                              (GO NOMINUS))
+                       ((AT.START.OF.BUF)
+                        (BEEP))
+                       ((AT.START.OF.LINE)
+                        (MOVE.TO.LINE (SETQ X (PREVLINE \ARROW 1))
+                               (fetch (LINE END) of X)))
+                       (T (MOVE.BACK.TO (TTNLEFT \CURSOR EDITARG])
+               (%(                                           (* ; "backs up one word")
+                   [COND
+                      (EDITMINUS (SETQ CHAR (CHARCODE %)))
+                             (GO NOMINUS))
+                      (T (MOVE.BACK.TO (PREVWORD \CURSOR EDITARG])
+               (%)                                           (* ; "moves ahead one word")
+                   [COND
+                      (EDITMINUS (SETQ CHAR (CHARCODE %())
+                             (GO NOMINUS))
+                      ((AT.END.OF.SCREEN)
+                       (BEEP))
+                      (T (MOVE.FORWARD.TO (FIND.NEXT.WORD \CURSOR EDITARG])
+               (TAB                                          (* ; "go to end of line")
+                    (MOVE.TO.LINE (SETQ X (TTNEXTLINE \ARROW (SUB1VAR EDITARG)))
+                           (fetch (LINE END) of X)))
+               (^L                                           (* ; "go to start of line")
+                   (MOVE.TO.LINE (PREVLINE \ARROW (SUB1VAR EDITARG))))
+               ({                                            (* ; 
+                                                      "{ goes to start of buffer, like infinite FF")
+                  (MOVE.TO.LINE \FIRSTLINE))
+               (}                                            (* ; 
+                                                       "} goes to end of buffer, like infinite TAB")
+                  (MOVE.TO.LINE (SETQ X (TTLASTLINE))
+                         (fetch (LINE END) of X)))
+               (LF                                           (* ; "moves down")
+                   [COND
+                      (EDITMINUS (SETQ CHAR (CHARCODE ^))
+                             (GO NOMINUS))
+                      [(ON.LAST.LINE)
+                       (COND
+                          ((EMPTY.BUFFER)                    (* ; 
+                                    "Treat this the same as regular linefeed, i.e.  restore buffer")
+                           (RETURN (CHARCODE LF)))
+                          (T (BEEP]
+                      (T (MOVE.TO.LINE (SETQ X (TTNEXTLINE \ARROW EDITARG))
+                                (NTH.COLUMN.OF X (EDITCOLUMN])
+               (^                                            (* ; "moves up")
+                  [COND
+                     (EDITMINUS (SETQ CHAR (CHARCODE LF))
+                            (GO NOMINUS))
+                     ((ON.FIRST.LINE)
+                      (BEEP))
+                     (T (MOVE.TO.LINE (SETQ X (PREVLINE \ARROW (IMIN (IPLUS \LOC.ROW.0 
+                                                                                    \CURSORROW)
+                                                                             EDITARG)))
+                               (NTH.COLUMN.OF X (EDITCOLUMN])
+               (K                                            (* ; "kills one char")
+                  [COND
+                     ((AT.END.OF.LINE)
+                      (BEEP))
+                     (T (FORWARD.DELETE.TO (TTNTH \CURSOR EDITARG])
+               ((S Z B)                                      (* ; "various skip or zap commands")
+                    (SKIP/ZAP CHAR (TTBIN T)
+                           EDITARG EDITMINUS))
+               (A                                            (* ; "repeat last S or Z")
+                  (COND
+                     ((SETQ LASTSKIP (fetch (TTYINBUFFER LASTSKIP) of \TTYINSTATE))
+                      (SKIP/ZAP LASTSKIP (fetch (TTYINBUFFER LASTSKIPCHAR) of \TTYINSTATE
+                                                    )
+                             EDITARG EDITMINUS))
+                     (T (BEEP))))
+               (L                                            (* ; "lowercase word")
+                  (U/L-CASE EDITARG))
+               (U                                            (* ; "uppercase word")
+                  (U/L-CASE EDITARG T))
+               (C                                            (* ; "capitalize word")
+                  (U/L-CASE EDITARG 1))
+               (G                                            (* ; 
+                                                           "grab a copy of Nth previous line")
+                  (COND
+                     ((OR (ON.FIRST.LINE)
+                          (NOT (AT.END.OF.LINE))
+                          (EQ (SETQ X (NTH.COLUMN.OF (SETQ L (PREVLINE \ARROW EDITARG))
+                                             \CURSORCOL))
+                              (fetch (LINE END) of L)))
+                                                             (* ; "nothing to copy")
+                      (BEEP))
+                     (T (READFROMBUF X (fetch (LINE END) of L)
+                               T))))
+               (%]                                           (* ; 
+                                                           "Move to end of current expression")
+                   [COND
+                      ((AT.END.OF.BUF)
+                       (BEEP))
+                      (T (MOVE.TO.WHEREVER (OR (TTSKREAD (TTNEXTCHAR \CURSOR))
+                                                   \ENDBUFFER])
+               (%[                                           (* ; 
+                                                         "Move to start of current list expression")
+                   [COND
+                      ((AT.START.OF.BUF)
+                       (BEEP))
+                      (T (MOVE.TO.WHEREVER (BACKSKREAD \CURSOR])
+               (^W                                           (* ; 
+                                                           "delete back to start of current word")
+                   (TTDELETEWORD EDITARG))
+               (D                                            (* ; "Delete forward to end of word")
+                  (COND
+                     ((AT.END.OF.LINE)
+                      (BEEP))
+                     (T (COND
+                           ((AND (NEQ (SETQ X (FIND.NEXT.WORD \CURSOR EDITARG T))
+                                      (fetch (LINE END) of \ARROW))
+                                 (NOT (AT.START.OF.LINE))
+                                 [NOT (WORDSEPRP (FIRSTCHAR (TTNLEFT \CURSOR 1]
+                                 [SPACEP (FIRSTCHAR (SETQ L (TTNLEFT X 1 \CURSOR]
+                                 (NEQ L \CURSOR))
+
+                            (* ;; "Don't want to delete all the way to start of new word, since we'd like a little space in between.  Simulating EMACS would probably be easier if we just made FIND.NEXT.WORD stop at the intervening spaces rather than at the end")
+
+                            (SETQ X L)))
+                        (FORWARD.DELETE.TO X))))
+               ((^Q ^U)                                      (* ; 
+                                                           "Delete line;  ^U for tops20 folk")
+                    (COND
+                       ((EQ EDITARG 1000)
+                        (DELETE.TO.END))
+                       (T (DELETELINE \ARROW))))
+               (^Y                                           (* ; "gets userexec")
+                   (COND
+                      ((AND (EQ EDITARG 1000)
+                            (NEQ \CURSOR \ENDBUFFER))
+                       (TTUNREADBUF)                     (* ; 
+                                                   "Stuff what's ahead of cursor into input buffer")
+                       ))
+                   (RETURN CHAR))
+               (F                                            (* ; "accept tvedit's $$F to finish")
+                  (COND
+                     [(EQ EDITARG 1000)
+                      (MOVE.TO.WHEREVER \ENDBUFFER)
+                      (COND
+                         ((NEQ \CURSOR \ENDBUFFER)           (* ; "This is because the cursor mover refuses to put me in column 80 of a line, due to certain anomalies")
+                          (add \CURSORCOL (SEGMENT.BIT.LENGTH \CURSOR \ENDBUFFER))
+                          (SETQ \CURSOR \ENDBUFFER)
+                          (OVERFLOW? 0)))
+                      (RETURN (COND
+                                 (\REPEAT                    (* ; "End with ^Z")
+                                        (CHARCODE ^Z))
+                                 (\READING 
+
+                                        (* ;; "End read with ']' ;  of course, this doesn't always 'finish' , but it's simple enough to remember what this is")
+
+                                        (CHARCODE %]))
+                                 (T (CHARCODE CR]
+                     (T (BEEP))))
+               (J                                            (* ; "Justify/fill line")
+                  (ADJUSTLINE.AND.RESTORE EDITARG))
+               (-                                            (* ; "minus sign negates arg")
+                  (SETQ EDITARG 0)
+                  (SETQ EDITMINUS T)
+                  (GO DONUMBERS))
+               (ESCAPE                                       (* ; "ESCAPE may modify next command")
+                       [COND
+                          ((AND (EQ EDITARG 1000)
+                                (EQ EDITPREFIXCHAR (CHARCODE ESCAPE)))
+
+                           (* ;; "3 escapes in a row is the way to type a regular Escape when Escape is the edit prefix.  Better ways might be forthcoming")
+
+                           (RETURN (CHARCODE ESCAPE]
+                       (SETQ EDITARG 1000)                   (* ; 
+                                                  "1000 is an adequate infinity for these purposes")
+                       (SETQ EDITMINUS)
+                       (SETQ CHAR (TTBIN T))
+                       (GO LP))
+               ((N ^R)                                       (* ; 
+                                                         "refresh n lines, or whole buffer for $$N")
+                    [COND
+                       ((EQ EDITARG 1000)
+                        (RETYPE.BUFFER \FIRSTLINE T))
+                       (EDITMINUS (RETYPE.BUFFER (PREVLINE \ARROW EDITARG)
+                                         \ARROW))
+                       (T (RETYPE.BUFFER \ARROW (TTNEXTLINE \ARROW EDITARG])
+               (T 
+                  (* ;; "transpose chars.  If at end of line, do preceding two, else do the ones before and after the cursor.")
+
+                  [SETQ L (TTNLEFT \CURSOR (SETQ X (COND
+                                                          ((AT.END.OF.LINE)
+                                                           2)
+                                                          (T 1]
+                                                             (* ; "start of swap")
+                  [COND
+                     ((OR (EQ L \CURSOR)
+                          (COMPLEXCHARP (CAR L))
+                          (AND (EQ X 2)
+                               (EQ (CDR L)
+                                   \CURSOR))
+                          (COMPLEXCHARP (CADR L)))           (* ; 
+         "Complain if not enough chars to swap, or one of them is a funny multiple char (I'm lazy)")
+                      (BEEP))
+                     (T [GO.TO.RELATIVE (IDIFFERENCE \CURSORCOL (SEGMENT.BIT.LENGTH
+                                                                     L
+                                                                     (NTH L (ADD1 X]
+                                                             (* ; "Back up to start of segment")
+                        [FRPLACA L (PROG1 (CADR L)
+                                       (FRPLACA (CDR L)
+                                              (CAR L)))]     (* ; "Do the swap in the buffer")
+                        (TYPE.BUFFER L (CDDR L))         (* ; "Fix the display")
+                        (COND
+                           ((EQ X 1)                         (* ; 
+                                                        "Were between two chars, so get back there")
+                            (GO.TO.RELATIVE (IDIFFERENCE \CURSORCOL (TTBITWIDTH
+                                                                         (FIRSTCHAR (CDR L])
+               (O                                            (* ; 
+                                                       "Open line, i.e.  insert <cr> but stay here")
+                  (BREAKLINE EOLCHARCODE T))
+               (_ 
+                  (* ;; "Special hack: says to add the word before the cursor to USERWORDS, so I can use altmode completion on it")
+
+                  (COND
+                     [(AND TTYINCOMPLETEFLG (SETQ X (CURRENT.WORD))
+                           [SETQ X (PROG ((\BUFFER X))
+                                         (RETURN (TTRATOM]
+                           (LITATOM X))
+                      (COND
+                         ((EQ EDITARG 0)                     (* ; 
+                            "Means to remove! I don't know if there's an 'official' way to do this")
+                          (DREMOVE X USERWORDS))
+                         (T (ADDSPELL X 0]
+                     (T (BEEP))))
+               (P (DO.EDIT.PP))
+               (COND
+                  ((SETQ CHAR (EDITNUMBERP CHAR))
+                   (SETQ EDITARG CHAR)
+                   (GO DONUMBERS))
+                  (T (BEEP]
+          (SETQ \LASTCHAR CHAR)
+          (RETURN)
+      NOMINUS
+          (SETQ EDITMINUS)
+          (GO LP)
+      DONUMBERS
+          
+
+     (* ;; "scanning a numeric arg.  EDITARG is its magnitude;  EDITMINUS set if negative.  <edit>escape is treated as 1000, which is probably big enough.  Doesn't matter if any of the next chars has edit bit on, since once we start a number, any other digits must be part of it, since numbers aren't themselves commands")
+
+          (COND
+             ([SETQ X (EDITNUMBERP (SETQ CHAR (TTBIN T]
+              [SETQ EDITARG (COND
+                               ((IGREATERP EDITARG 100)      (* ; 
+                                           "Limit numeric args to 1000 so small number stuff works")
+                                1000)
+                               (T (IPLUS (ITIMES EDITARG 10)
+                                         X]
+              (GO DONUMBERS)))
+          (COND
+             ((AND EDITMINUS (EQ EDITARG 0))                 (* ; 
+                                                    "Happens if we get a '-' followed by no number")
+              (SETQ EDITARG 1)))
+          (GO LP])
+
+(DO.EDIT.PP
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 10:34 by jds")
+    (COND
+       ((NOT \READING)                                       (* ; 
+                                                           "Nothing to prettyprint--just redisplay")
+        (RETYPE.BUFFER \FIRSTLINE T))
+       (T                                                    (* ; 
+                 "Read what we have, supplying closing parens if suitable, and then prettyprint it")
+          (WITH-RESOURCES (TTSCRATCHFILE)
+                 (PROG ((*READTABLE* RDTBL)
+                        (\BUFFER \BUFFER)
+                        LEFTOVER EXPRS)
+                       [COND
+                          ((TTYIN.BALANCE NIL T)       (* ; "Input is now perfectly balanced")
+                           )
+                          ((NEQ \CURSOR \ENDBUFFER)          (* ; "There was extra stuff at end")
+                           (SETQ LEFTOVER (COPY.SEGMENT \CURSOR \ENDBUFFER))
+                           (SETQ \ENDBUFFER \CURSOR))
+                          (T                                 (* ; "Didn't balance, so punt")
+                             (RETURN (BEEP]
+                       (SETQ \CURSOR \BUFFER)
+                       [COND
+                          ((NEQ (TTSKIPSEPR)
+                                \ENDBUFFER)
+                           (SETQ EXPRS (TTYIN.READ 0 NIL TTSCRATCHFILE]
+                       (MOVE.TO.LINE \FIRSTLINE)
+                       (ERASE.TO.END.OF.PAGE)
+                       (TTYIN1RESTART)
+                       (replace (LINE FIRSTCOL) of \ARROW with (replace (LINE LASTCOL
+                                                                                              )
+                                                                              of \ARROW
+                                                                              with \CURSORCOL))
+                       [COND
+                          (EXPRS (TTLOADBUF (LIST HISTSTR1 (TTYIN.PPTOFILE EXPRS NIL NIL
+                                                                      TTSCRATCHFILE]
+                       (SETFILEPTR TTSCRATCHFILE 0)          (* ; "Leave it nice for next customer")
+                       (COND
+                          (LEFTOVER                          (* ; 
+                                       "Display the stuff that follows the normal read termination")
+                                 (BREAKLINE (CHARCODE EOL))
+                                 (READFROMBUF LEFTOVER])
+
+(TTDOTABS
+  [LAMBDA (TABS)                                             (* bvm%: "16-Apr-85 17:35")
+
+(* ;;; "Tab to next tabstop in TABS, if any.  Represent pseudotabs as a complex space.  Return T if anything done")
+
+    (COND
+       ((AND TABS (AT.END.OF.BUF))
+        (for TB in TABS bind SPACES when (AND (SMALLP TB)
+                                                              (IGREATERP (SETQ SPACES
+                                                                          (IDIFFERENCE (ITIMES TB 
+                                                                                           \CHARWIDTH
+                                                                                              )
+                                                                                 \CURSORCOL))
+                                                                     \CHARWIDTH))
+           do                                            (* ; 
+                                                           "Make pseudo-tab and echo as spaces")
+                 [ADDCHAR (TTMAKECOMPLEXCHAR (CHARCODE SPACE)
+                                     (to (IQUOTIENT SPACES \CHARWIDTH) collect (CHARCODE
+                                                                                        SPACE]
+                 (RETURN T])
+
+(EDITCOLUMN
+  [LAMBDA NIL                                              (* bvm%: "24-AUG-81 23:17")
+
+    (* ;; "If last edit command moved up/down, then return the same column we were using then;  else use current cursor column, and record it as the 'goal' column for any future such commands")
+
+    (OR (SELCHARQ \LASTCHAR
+             ((LF ^) 
+                  \HOMECOL)
+             NIL)
+        (SETQ \HOMECOL \CURSORCOL])
+
+(EDITNUMBERP
+  [LAMBDA (CHAR)                                             (* bvm%: "11-MAR-81 22:05")
+    (AND [NOT (MINUSP (SETQ CHAR (IDIFFERENCE CHAR (CONSTANT (CHCON1 0]
+         (NOT (IGREATERP CHAR 9))
+         CHAR])
+
+(END.DELETE.MODE
+  [LAMBDA NIL                                              (* bvm%: "19-MAR-81 11:59")
+    (COND
+       (\DELETING (SELECTQ TTYINBSFLG
+                      (NIL (TTBOUT \))
+                      (LF (COND
+                             ((IGREATERP \DELETING 1)        (* ; 
+                                                    "if more than one char x'd out, lf to new line")
+                              (DO.LF))))
+                      NIL)
+              (SETQ \DELETING NIL])
+
+(ENDREAD?
+  [LAMBDA NIL                                              (* bvm%: "10-Apr-86 14:21")
+
+    (* ;; "Return true if the paren/bracket just typed terminates the input.  It does if the right paren (or even one earlier in buffer) is in excess, i.e unbalanced, or just balances and this is the only list on the line, or we are doing a LISPX input and the input is in EVALQT form, with no space after the first atom")
+
+    (LET
+     (X)
+     (AND
+      (AT.END.OF.TEXT \CURSOR)
+      (SETQ X (TTSKREAD \BUFFER))
+      (OR
+       (NEQ X \ENDBUFFER)
+       (AND
+        [SELCHARQ (CAR (SETQ X (FIND.NON.SPACE \BUFFER)))
+             ((%( %[)                                        (* ; 
+                                                           "OK, line started with paren/bracket")
+                  T)
+             (AND
+              (EQ \READING 'EVALQT)
+              (NEQ \PROMPT1 '*)
+              (while (NEQ X \ENDBUFFER) bind ESCAPED
+                 do 
+
+                       (* ;; "Skip over this first atom, to see if input is in EVALQT form.  Prompt check is so we don't do this in the editor")
+
+                       (SELECTC (\SYNCODE \RDTBLSA (FIRSTCHAR X))
+                           (SEPRCHAR.RC                      (* ; 
+                                                          "Space, etc: probably wants more on line")
+                                        (OR ESCAPED (RETURN NIL)))
+                           ((LIST LEFTPAREN.RC LEFTBRACKET.RC) 
+                                                             (* ; "Open paren/bracket: looks good")
+                                [OR ESCAPED
+                                    (RETURN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN 
+                                                             (* ; "Prettyprint sucks again!")
+                                                                                             T])
+                           (ESCAPE.RC                        (* ; "Skip over escape char")
+                                      (SETQ X (CDR X)))
+                           (MULTIPLE-ESCAPE.RC               (* ; "Multiple escape")
+                                (SETQ ESCAPED (NOT ESCAPED)))
+                           NIL)
+                       (SETQ X (TTNEXTCHAR X]
+        (EQ (CDR (TTSKREAD (CDR X)))
+            \CURSOR])
+
+(FIND.LINE
+  [LAMBDA (BUF)
+    (DECLARE (USEDFREE \FIRSTLINE))                      (* ; "Edited 24-May-91 10:34 by jds")
+
+(* ;;; "Returns the buffer LINE on which BUF, a cursor position, occurs")
+
+    (for (LINE _ (PROGN \FIRSTLINE)) do (COND
+                                                   [(EQ BUF (fetch (LINE END) of LINE))
+                                                             (* ; 
+                                          "Check this separately so next BUFTAILP doesn't catch it")
+                                                    (RETURN (COND
+                                                               ((OVERFLOWLINE? LINE)
+                                                                (fetch (LINE NEXTLINE)
+                                                                   of LINE))
+                                                               (T LINE]
+                                                   ((BUFTAILP BUF (fetch (LINE START)
+                                                                         of LINE)
+                                                           (fetch (LINE END) of LINE))
+                                                    (RETURN LINE)))
+                                               (OR (SETQ LINE (fetch (LINE NEXTLINE) of
+                                                                                         LINE))
+                                                   (SHOULDNT])
+
+(FIND.LINE.BREAK
+  [LAMBDA (START END USELAST)                                (* bvm%: "20-FEB-82 22:35")
+
+(* ;;; "Locates a place between START and END where line can be broken.  If USELAST is true, returns last such place, else first")
+
+    (while (NEQ START END) do [COND
+                                         ((EQ (CAR START)
+                                              (CHARCODE SPACE))
+                                          (COND
+                                             (USELAST (SETQ $$VAL START))
+                                             (T (RETURN START]
+                                     (SETQ START (TTNEXTCHAR START])
+
+(FIND.MATCHING.QUOTE
+  [LAMBDA (BUF END)                                          (* bvm%: "16-Apr-86 15:07")
+
+(* ;;; "Searches BUF until END for a closing double-quote")
+
+    (while (NEQ BUF END) do (SELECTC (\SYNCODE \RDTBLSA (FIRSTCHAR BUF))
+                                        (STRINGDELIM.RC 
+                                             (RETURN BUF))
+                                        (ESCAPE.RC           (* ; "'%%' quotes next char")
+                                                   (COND
+                                                      ((EQ (SETQ BUF (CDR BUF))
+                                                           END)
+                                                       (RETURN))))
+                                        NIL)
+                                   (SETQ BUF (CDR BUF])
+
+(FIND.NEXT.WORD
+  [LAMBDA (BUFTAIL N BACKUPFLG)                              (* ; "Edited 24-May-91 10:34 by jds")
+
+(* ;;; "Return start of Nth word after BUFTAIL, or end of line if none.  BACKUPFLG means if you cross a paren getting to the Nth word, return the paren rather than the word (used for smart word-delete)")
+
+    (PROG ((END (fetch (LINE END) of \ARROW)))
+          (COND
+             ((EQ BUFTAIL END)
+              (RETURN END)))
+          (SETQ BUFTAIL (CDR BUFTAIL))
+      LP  [COND
+             ((EQ BUFTAIL END)
+              (RETURN END))
+             ((WORDSEPRP (FIRSTCHAR BUFTAIL))                (* ; 
+                                   "Found a space.  Now scan for first non-space, and return there")
+              [COND
+                 (BACKUPFLG (SETQ BUFTAIL (SETQ BACKUPFLG (FIND.START.OF.WORD BUFTAIL END]
+              (while (AND (NEQ BUFTAIL END)
+                              (WORDSEPRP (FIRSTCHAR BUFTAIL))) do (SETQ BUFTAIL (TTNEXTCHAR
+                                                                                     BUFTAIL)))
+              (COND
+                 ((OR (NOT N)
+                      (EQ (SUB1VAR N)
+                          0)
+                      (EQ BUFTAIL END))
+                  (RETURN (OR BACKUPFLG BUFTAIL]
+          (SETQ BUFTAIL (TTNEXTCHAR BUFTAIL))
+          (GO LP])
+
+(FIND.NON.SPACE
+  [LAMBDA (BUF END)                                          (* bvm%: "11-Apr-85 15:07")
+    (OR END (SETQ END \ENDBUFFER))
+    (while (AND (NEQ BUF END)
+                    (SPACEP (FIRSTCHAR BUF))) do (SETQ BUF (TTNEXTCHAR BUF)))
+    BUF])
+
+(FIND.START.OF.WORD
+  [LAMBDA (BUF END)                                          (* bvm%: "11-Apr-85 15:07")
+
+(* ;;; "Returns position of first word, i.e.  non-space, in BUF before END")
+
+    (OR END (SETQ END \ENDBUFFER))
+    (while (AND (NEQ BUF END)
+                    (WORDSEPRP (FIRSTCHAR BUF))) do (SETQ BUF (TTNEXTCHAR BUF)))
+    BUF])
+
+(FORWARD.DELETE.TO
+  [LAMBDA (BUFTAIL)                                          (* ; "Edited 24-May-91 10:34 by jds")
+
+(* ;;; "Delete from \CURSOR to BUFTAIL.  Cursor does not move")
+
+    [COND
+       ((EQ BUFTAIL \CURSOR)                                 (* ; "Nothing to do")
+        )
+       ((EQ BUFTAIL \ENDBUFFER)                              (* ; "deleting to end is simple")
+        (ERASE.TO.END.OF.LINE)
+        (replace (LINE END) of \ARROW with (SETQ \ENDBUFFER \CURSOR))
+        (replace (LINE LASTCOL) of \ARROW with \CURSORCOL))
+       (T (PROG ((DELETEDWIDTH (SEGMENT.BIT.LENGTH \CURSOR BUFTAIL))
+                 L)
+                (COND
+                   ((EQ BUFTAIL (fetch (LINE END) of \ARROW))
+                                                             (* ; 
+                           "End pointer is about to disappear into free list, so move it back here")
+                    (replace (LINE END) of \ARROW with \CURSOR)
+                    [COND
+                       ((EQ (fetch (LINE START) of (SETQ L (fetch (LINE NEXTLINE)
+                                                                      of \ARROW)))
+                            BUFTAIL)
+                        (replace (LINE START) of L with \CURSOR)
+                        (COND
+                           ((EQ (fetch (LINE END) of L)
+                                BUFTAIL)
+                            (replace (LINE END) of L with \CURSOR]
+                    (ERASE.TO.END.OF.LINE))
+                   (T (TTDELSECTION DELETEDWIDTH)))
+                (KILLSEGMENT \CURSOR BUFTAIL)
+                (replace (LINE LASTCOL) of \ARROW with (IDIFFERENCE (fetch
+                                                                                 (LINE LASTCOL)
+                                                                                   of \ARROW)
+                                                                          DELETEDWIDTH))
+                (COND
+                   ((OVERFLOWLINE? \ARROW)
+                    (ADJUSTLINE.AND.RESTORE]
+    \CURSOR])
+
+(GO.TO.ADDRESSING
+  [LAMBDA (COL ROW)                                          (* bvm%: "20-Mar-84 14:50")
+                                                             (* ; 
+           "Regardless of where we are now, go to logical position COL,ROW using cursor addressing")
+    (PROG ((ABSROW (IPLUS \LOC.ROW.0 ROW)))
+          (TTSETCURSOR COL ABSROW)
+
+     (* ;; "Used to prohibit going above top, but that is ugly.  Better to go up there and be clipped out of existence by the display code.  Formerly: (COND ((ILESSP ABSROW 0) (* trying to go beyond top of screen;  ideally we should scroll, but for now just forbid it) (SETQ ROW (IDIFFERENCE ROW ABSROW)) 0) ((NOT (ILESSP ABSROW \TTPAGELENGTH)) (* This shouldn't happen at all until we can scroll!) (SETQ ROW (IPLUS (IDIFFERENCE ROW ABSROW) \TTPAGELENGTH -1)) (SUB1 \TTPAGELENGTH)) (T ABSROW))")
+
+          (SETQ \CURSORROW ROW)
+          (SETQ \CURSORCOL COL])
+
+(GO.TO.FREELINE
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 10:34 by jds")
+
+(* ;;; "Moves cursor to the first free line after the buffer, and clears it")
+
+    (GO.TO.RELATIVE NIL (fetch (LINE ROW) of (TTLASTLINE)))
+                                                             (* ; 
+                                                         "Put the cursor on the last row of buffer")
+    (TTCRLF)                                             (* ; "And down one more")
+    (ERASE.TO.END.OF.PAGE])
+
+(GO.TO.RELATIVE
+  [LAMBDA (COL ROW)                                          (* ; "Edited 24-May-91 10:34 by jds")
+
+(* ;;; "Moves cursor to indicated row/col.  ROW arg may be omitted if the movement is on the same row.  If COL=LINE then ROW is interpreted as a LINE record, and destination is the start of that line")
+
+    (COND
+       ((EQ COL 'LINE)
+        (SETQ COL (fetch (LINE FIRSTCOL) of ROW))
+        (SETQ ROW (fetch (LINE ROW) of ROW)))
+       ((NOT COL)
+        (SETQ COL \CURSORCOL))
+       ((NOT ROW)
+        (SETQ ROW \CURSORROW)))
+    (MOVETO COL (+ (TIMES (SUB1 (- \TTPAGELENGTH (+ \LOC.ROW.0 ROW)))
+                          \CHARHEIGHT)
+                   \BMARG)
+           \DSP)
+    (SETQ \CURSORROW ROW)
+    (SETQ \CURSORCOL COL])
+
+(INIT.CURSOR
+  [LAMBDA (COL)                                              (* ; "Edited 18-Jan-88 15:12 by bvm")
+
+(* ;;; "Initializes cursor accounting;  in Interlisp-10, this assumed/forced the cursor to be in column COL of the bottom row of the screen")
+
+    (PROG ((YBOT (fetch (REGION BOTTOM) of (DSPCLIPPINGREGION NIL \DSP)))
+           INITY)
+          (SETQ INITY (- (DSPYPOSITION NIL \DSP)
+                         YBOT))
+          (SETQ \LOC.ROW.0 (- \TTPAGELENGTH (IQUOTIENT INITY \CHARHEIGHT)
+                              1))
+
+     (* ;; "\LOC.ROW.0 is the number of the 'line' of the first line of text, counting from the top of the window.  Instead, we really should count from the bottom and fix everyone who cares")
+
+          (SETQ \BMARG (+ YBOT (IREMAINDER INITY \CHARHEIGHT)))
+          (SETQ \CURSORROW 0)
+          (SETQ \CURSORCOL COL])
+
+(INSERT.NODE
+  [LAMBDA (BUF)                                              (* bvm%: "20-FEB-82 22:34")
+
+(* ;;; "Effectively does (ATTACH garbage BUF), but reuses from the garbage heap")
+
+    (COND
+       ((EQ BUF \ENDBUFFER)                                  (* ; 
+                                                           "Already at end, just push pointer")
+        (SETQ \ENDBUFFER (TTNEXTNODE \ENDBUFFER)))
+       (T (FRPLACD BUF (FRPLNODE2 (SCRATCHCONS)
+                              BUF])
+
+(INSERTLINE
+  [LAMBDA (OLDLINE USECR)                                    (* ; "Edited 24-May-91 10:34 by jds")
+
+    (* ;; "Inserts a new line between OLDLINE and the next line, whose START is the END of LINE;  caller must fill in END if line is non-empty (defaults to start);  USECR, if supplied, is the <cr> char to end the previous line with")
+
+    (PROG ((OLDEND (fetch (LINE END) of OLDLINE))
+           (ROW (ADD1 (fetch (LINE ROW) of OLDLINE)))
+           X NEWLINE)
+          [COND
+             (USECR (INSERT.NODE OLDEND)
+                    (FRPLACA OLDEND USECR)
+                    (SETQ OLDEND (CDR OLDEND]
+          (TTCRLF)
+          (COND
+             ((NEQ OLDEND \ENDBUFFER)                        (* ; 
+                                                       "Not last line, so insert a line on screen.")
+              (DO.INSERT.LINE 1)))
+          (TTPROMPTCHAR)
+          [replace (LINE NEXTLINE) of OLDLINE
+             with (SETQ NEWLINE (create LINE
+                                           START _ OLDEND
+                                           END _ OLDEND
+                                           FIRSTCOL _ (SETQ X \CURSORCOL)
+                                           LASTCOL _ X
+                                           ROW _ ROW
+                                           NEXTLINE _ (fetch (LINE NEXTLINE) of OLDLINE]
+          (RENUMBER.LINES NEWLINE ROW)
+          (RETURN NEWLINE])
+
+(KILL.LINES
+  [LAMBDA (FIRSTLINE)                                        (* bvm%: " 2-JUN-82 15:46")
+
+(* ;;; "Returns line records from FIRSTLINE onward to the heap")
+
+    [PROG NIL
+      LP  (COND
+             (FIRSTLINE (SETQ FIRSTLINE (CDR (FRPLACA FIRSTLINE 0)))
+                                                             (* ; 
+                                                     "Remove some of the circularity in the buffer")
+                    (GO LP]
+    (FRPLACD (FLAST \ENDBUFFER)
+           FIRSTLINE])
+
+(KILLSEGMENT
+  [LAMBDA (START END)                                        (* ; "Edited 24-May-91 10:40 by jds")
+
+(* ;;; "Removes segment from START up to, but not including END.  When done, START contains the contents of former cell END.  I.e.  any pointer to START is still valid;  any pointer to END should be reset to START.")
+
+    (COND
+       ((EQ END \ENDBUFFER)
+        (SETQ \ENDBUFFER START))
+       (T (replace (TTYINBUFFER OLDTAIL) of \TTYINSTATE with (SETQ \LASTAIL))
+                                                             (* ; 
+                                                 "kill last buffer markers, as they may be trashed")
+          (FRPLNODE START (CAR END)
+                 (PROG1 (CDR END)
+                     (FRPLACD END (CDR \ENDBUFFER))          (* ; 
+                                                           "Cell at END will point to free list")
+                     (FRPLACD \ENDBUFFER (CDR START))        (* ; 
+                                                       "And this segment now is start of free list")
+                     )])
+
+(L-CASECODE
+  [LAMBDA (CHAR)                                             (* lmm "16-Nov-86 13:24")
+    (LISP:CHAR-INT (LISP:CHAR-DOWNCASE (LISP:INT-CHAR CHAR])
+
+(MOVE.BACK.TO
+  [LAMBDA (BUFTAIL)                                          (* bvm%: " 1-JUN-82 18:10")
+    (GO.TO.RELATIVE (IDIFFERENCE \CURSORCOL (SEGMENT.BIT.LENGTH BUFTAIL \CURSOR)))
+    (SETQ \CURSOR BUFTAIL])
+
+(MOVE.FORWARD.TO
+  [LAMBDA (BUFTAIL)                                          (* bvm%: " 1-JUN-82 18:03")
+    [GO.TO.RELATIVE (IPLUS \CURSORCOL (SEGMENT.BIT.LENGTH \CURSOR (SETQ BUFTAIL
+                                                                           (CHECK.MARGIN BUFTAIL
+                                                                                  \ARROW]
+    (SETQ \CURSOR BUFTAIL])
+
+(MOVE.TO.LINE
+  [LAMBDA (NEWLINE BUFTAIL)                                  (* ; "Edited 24-May-91 10:35 by jds")
+
+(* ;;; "Moves to indicated line at indicate buffer position (default is START), resetting \ARROW etc appropriately.")
+
+    (PROG ((RELATIVE.POSITION 0))
+          [COND
+             [BUFTAIL (SETQ RELATIVE.POSITION (SEGMENT.BIT.LENGTH (fetch (LINE START)
+                                                                         of NEWLINE)
+                                                     (SETQ BUFTAIL (CHECK.MARGIN BUFTAIL NEWLINE]
+             (T (SETQ BUFTAIL (fetch (LINE START) of NEWLINE]
+          (GO.TO.RELATIVE (IPLUS (fetch (LINE FIRSTCOL) of NEWLINE)
+                                     RELATIVE.POSITION)
+                 (fetch (LINE ROW) of NEWLINE))
+          (SETQ \CURSOR BUFTAIL)
+          (RETURN (SETQ \ARROW NEWLINE])
+
+(MOVE.TO.NEXT.LINE
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 10:35 by jds")
+    (GO.TO.RELATIVE 'LINE (SETQ \ARROW (fetch (LINE NEXTLINE) of \ARROW)))
+    (SETQ \CURSOR (fetch (LINE START) of \ARROW])
+
+(MOVE.TO.START.OF.WORD
+  [LAMBDA NIL                                              (* bvm%: "20-FEB-82 22:34")
+    [COND
+       ((AT.END.OF.LINE)
+        (MOVE.BACK.TO (PREVWORD \CURSOR)))
+       ((SELCHARQ (CAR \CURSOR)
+             ((%( %[) 
+                  NIL)
+             T)
+
+        (* ;; "Do nothing if sitting under an open paren/bracket, since otherwise the PREVWORD below will go to the previous word, rather than selecting the 'word' which begins with the paren;  in all other cases the PREVWORD will do the right thing: if under the word, goes to its start (ignoring parens), or if under a space goes to the start of the word before the space")
+
+        (MOVE.BACK.TO (PREVWORD (TTNEXTCHAR \CURSOR]
+    NIL])
+
+(MOVE.TO.WHEREVER
+  [LAMBDA (BUF)                                              (* bvm%: "24-Feb-80 00:28")
+
+(* ;;; "Moves to BUF, wherever it may be.")
+
+    (MOVE.TO.LINE (FIND.LINE BUF)
+           BUF])
+
+(NTH.COLUMN.OF
+  [LAMBDA (LINE N)                                           (* ; "Edited 24-May-91 10:35 by jds")
+
+(* ;;; 
+"Returns buffer tail of LINE record which best approximates the Nth printing column of that line")
+
+    (NTH.RELATIVE.COLUMN.OF LINE (IDIFFERENCE N (fetch (LINE FIRSTCOL) of LINE])
+
+(NTH.RELATIVE.COLUMN.OF
+  [LAMBDA (LINE N)                                           (* ; "Edited 24-May-91 11:10 by jds")
+
+    (* ;; "Returns buffer tail in LINE which represents the Nth printing character on the line.  Returns start or end of buffer if out of range.  If the nth char is a pad char, returns the start of the pad char sequence")
+
+    (COND
+       ((NOT (IGREATERP N 0))
+        (fetch (LINE START) of LINE))
+       (T (for WIDTH CH (BUF _ (fetch (LINE START) of LINE))
+                 (END _ (fetch (LINE END) of LINE))
+             do [COND
+                       ((EQ BUF END)                         (* ; "Ran off the end, so quit")
+                        (RETURN END))
+                       (T (COND
+                             ([ILESSP N (SETQ WIDTH (COND
+                                                       ((COMPLEXCHARP (SETQ CH (CAR BUF)))
+                                                        (fetch (COMPLEXCHAR CPXWIDTH)
+                                                           of CH))
+                                                       (T (TTBITWIDTH CH]
+                              (RETURN BUF)))
+                          (SETQ N (IDIFFERENCE N WIDTH]
+                   (SETQ BUF (CDR BUF])
+
+(OVERFLOW?
+  [LAMBDA (WIDTH)                                            (* ; "Edited 24-May-91 10:35 by jds")
+
+    (* ;; "If typing WIDTH more chars would cause this line to overflow, starts new line (or simply goes to next line when N=0)")
+
+    (COND
+       ((NOT (ILESSP (IPLUS \CURSORCOL WIDTH)
+                    \RMARG))
+        (COND
+           [(AT.END.OF.LINE)
+            (PROG ((OLDLINE \ARROW))
+                  (START.NEW.LINE)
+                  (COND
+                     ((AND \AUTOFILL DISPLAYTERMFLG)         (* ; 
+            "Hit the margin in the middle of a word.  Try to move that word intact to the new line")
+                      (ADJUSTLINE 1 OLDLINE)
+                      (GO.TO.RELATIVE (fetch (LINE LASTCOL) of \ARROW)
+                             (fetch (LINE ROW) of \ARROW]
+           ((EQ WIDTH 0)
+            (MOVE.TO.NEXT.LINE))
+           (T (BREAKLINE])
+
+(OVERFLOWLINE?
+  [LAMBDA (LINE)                                             (* ; "Edited 24-May-91 10:35 by jds")
+
+(* ;;; "True if LINE overflows into next line, rather than ending in a cr")
+
+    (EQ (fetch (LINE END) of LINE)
+        (fetch (LINE START) of (fetch (LINE NEXTLINE) of LINE])
+
+(PREVLINE
+  [LAMBDA (LINE N)                                           (* ; "Edited 24-May-91 10:35 by jds")
+
+(* ;;; "Backs up N lines in buffer before LINE, as far as start of buffer.  i.e.  an NLEFT on line records.")
+
+    (PROG ((X \FIRSTLINE)
+           (L \FIRSTLINE))
+      LP                                                     (* ; "Advance X by N chars")
+          (COND
+             ((EQ N 0)
+              (GO LP1))
+             ((OR (EQ X LINE)
+                  (NULL X))                                  (* ; 
+                                            "The NULL case should never happen, but better be safe")
+              (RETURN L)))
+          (SETQ X (fetch (LINE NEXTLINE) of X))
+          (SUB1VAR N)
+          (GO LP)
+      LP1                                                    (* ; 
+            "Now advance X and L in parallel until X reaches LINE, at which point L is N before it")
+          (COND
+             ((OR (EQ X LINE)
+                  (NULL X))
+              (RETURN L)))
+          (SETQ X (fetch (LINE NEXTLINE) of X))
+          (SETQ L (fetch (LINE NEXTLINE) of L))
+          (GO LP1])
+
+(PREVWORD
+  [LAMBDA (BUF N START)                                      (* ; "Edited 24-May-91 10:35 by jds")
+    (OR START (SETQ START (fetch (LINE START) of \ARROW)))
+    (for (X _ START)
+           (NEW _ T)
+           (%#HITS _ 0) by (TTNEXTCHAR X) until (EQ X BUF)
+       do 
+
+             (* ;; 
+           "Return start of the Nth word in line before BUF, or beginning of line if no such word")
+
+             (COND
+                ((WORDSEPRP (FIRSTCHAR X))                   (* ; "Space between words")
+                 (SETQ NEW T))
+                (NEW (SETQ $$VAL X)                          (* ; "Start of new word")
+                     (SETQ NEW NIL)
+                     (ADD1VAR %#HITS))) finally (RETURN (COND
+                                                               ((OR (NOT N)
+                                                                    (EQ N 1)
+                                                                    (EQ %#HITS 0))
+                                                                (OR $$VAL START))
+                                                               ((ILESSP (SETQ N (IDIFFERENCE %#HITS N
+                                                                                       ))
+                                                                       0)
+                                                             (* ; 
+                                                           "N was greater than #words in buffer")
+                                                                START)
+                                                               ((EQ N 0)
+                                                                (FIND.START.OF.WORD START))
+                                                               (T (FIND.NEXT.WORD (
+                                                                                 FIND.START.OF.WORD
+                                                                                       START)
+                                                                         N])
+
+(PROPERTAILP
+  [LAMBDA (X Y)                                              (* bvm%: " 4-Aug-78 12:03")
+
+(* ;;; "true if X is a PROPER tail of Y")
+
+    (AND X (NEQ X Y)
+         (BUFTAILP X Y])
+
+(READFROMBUF
+  [LAMBDA (START END COPYFLG)                                (* ; "Edited 24-May-91 11:10 by jds")
+
+    (* ;; "Unreads the chars in the buffer from START to END.  The cells are returned to the free pool as they are used to reduce the storage demands on large unreads.  Multichar sequences in buffer are unread as just their 'real' characters")
+
+    (PROG (FIXUP CH)
+          [COND
+             ([AND (NOT (AT.END.OF.LINE))
+                   (for (BUF _ START) by (CDR BUF) until (EQ BUF END)
+                      thereis (EQ (CAR BUF)
+                                      (CHARCODE EOL]
+
+              (* ;; "An insertion that contains a cr.  This will look awful if we have to keep shoving text in front of us, so break the line first, then unbreak it at end")
+
+              (BREAKLINE (CHARCODE SPACE)
+                     (SETQ FIXUP T]
+          (until (EQ START END) do [COND
+                                              ((COMPLEXCHARP (SETQ CH (CAR START)))
+                                               (SETQ CH (fetch (COMPLEXCHAR CPXREALCHAR)
+                                                           of CH]
+                                          (COND
+                                             ((NEQ CH EOLCHARCODE)
+                                              (ADDNAKEDCHAR CH T))
+                                             ((NOT (AT.END.OF.LINE))
+                                                             (* ; "Insert EOL in middle of line")
+                                              (BREAKLINE EOLCHARCODE))
+                                             ((OR (NEQ (CDR START)
+                                                       END)
+                                                  (NOT (AT.END.OF.TEXT \CURSOR)))
+                                                             (* ; 
+                                    "EOL.  Start new line.  Ignore it if this is a terminating eol")
+                                              (START.NEW.LINE EOLCHARCODE)))
+                                          (SETQ START (CDR START)))
+          (COND
+             (FIXUP                                          (* ; "Kill the cr we inserted")
+                    (MOVE.TO.WHEREVER (PROG1 \CURSOR
+                                              (DELETE.LONG.SEGMENT1 \ARROW \CURSOR
+                                                     (fetch (LINE NEXTLINE) of \ARROW)
+                                                     (TTNEXTCHAR \CURSOR)))])
+
+(RENUMBER.LINES
+  [LAMBDA (LINE ROW)                                         (* ; "Edited 24-May-91 10:35 by jds")
+
+(* ;;; "Renumbers lines from LINE onward, giving LINE the value ROW")
+
+    (while LINE do (replace (LINE ROW) of LINE with ROW)
+                          (ADD1VAR ROW)
+                          (SETQ LINE (fetch (LINE NEXTLINE) of LINE])
+
+(RESTORE.CURSOR
+  [LAMBDA NIL                                              (* lmm "20-Nov-86 00:27")
+    (GO.TO.RELATIVE \HOMECOL \HOMEROW])
+
+(RESTOREBUF
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 10:41 by jds")
+
+    (* ;; "recover previous buffer, which extends to either our current LASTAIL, if user has done deletions on this line, or previous LASTAIL, stored in the front of the buffer.  If neither, then recover last thing zapped with the mouse")
+
+    (PROG (TAIL)
+          (COND
+             ([AND (AT.END.OF.BUF)
+                   (SETQ TAIL (OR (AND \LASTAIL (IGEQ \LASTAILROW (fetch (LINE ROW) of \ARROW
+                                                                         ))
+                                       (OR (IGREATERP \LASTAILCOL \CURSORCOL)
+                                           (IGREATERP \LASTAILROW (fetch (LINE ROW) of \ARROW
+                                                                         )))
+                                       (PROPERTAILP \LASTAIL \ENDBUFFER))
+                                  (PROPERTAILP (fetch (TTYINBUFFER OLDTAIL) of 
+                                                                                          \TTYINSTATE
+                                                          )
+                                         \ENDBUFFER]
+              (END.DELETE.MODE)
+              (READFROMBUF [CONS (CAR \ENDBUFFER)
+                                     (PROG1 (CDR \ENDBUFFER) (* ; 
+                                            "now detach buffer from here to TAIL to avoid conflict")
+                                         (FRPLNODE \ENDBUFFER 0 (CDR TAIL)))]
+                     TAIL)
+              (SETQ \LASTAIL \ENDBUFFER)
+              (SETQ \LASTAILCOL \CURSORCOL)
+              (SETQ \LASTAILROW (fetch (LINE ROW) of \ARROW))
+              (replace (TTYINBUFFER OLDTAIL) of \TTYINSTATE with NIL))
+             (\LAST.DELETION (READFROMBUF \LAST.DELETION NIL T)
+                    (ADJUSTLINE.AND.RESTORE T))
+             (T                                              (* ; 
+                                  "Can't find where buffer ended;  perhaps we have written past it")
+                (BEEP])
+
+(RETYPE.BUFFER
+  [LAMBDA (LINE LASTLINE FROM.HERE)                          (* ; "Edited 24-May-91 10:35 by jds")
+
+    (* ;; "Refreshes buffer starting with LINE for one line, or going to LASTLINE, where LASTLINE=T means end of buffer.  Moves cursor to start of LINE (based on where we think we might be now) unless FROM.HERE is set.  FROM.HERE is set when retyping whole buffer with the current cursor position defined as 0,0;  in this case, the cursor is restored on completion to wherever it was last saved, rather than its current position")
+
+    (PROG* ((ROW (fetch (LINE ROW) of LINE))
+            (COL0 (if (EQ ROW 0)
+                      then \INITPOS
+                    else \LMARG))
+            L)
+           (SETQ \DELETING)
+           (BINARY.MODE)
+           [COND
+              (FROM.HERE (INIT.CURSOR COL0))
+              (T (SAVE.CURSOR)
+                 (PROGN                                      (* ; 
+                                                           "position cursor at start of line")
+                        (CANCEL.MODES)                       (* ; 
+                                 "in case an funny terminal setting occurred, say because of noise")
+                        (if (EQ ROW 0)
+                            then                         (* ; 
+                             "If reprinting from the top, restore \LOC.ROW.0 to its original value")
+                                  (SETQ \LOC.ROW.0 (- \LOC.ROW.0 \INITCRLFS)))
+                        (GO.TO.ADDRESSING COL0 ROW]
+       LP  (TTPROMPTCHAR LINE)
+           (TYPE.BUFFER (fetch (LINE START) of LINE)
+                  (fetch (LINE END) of LINE))
+           (COND
+              ((AND LASTLINE (SETQ L (fetch (LINE NEXTLINE) of LINE))
+                    (NEQ L LASTLINE))
+               (SETQ LINE L)
+               (TTCRLF)
+               (ADD1VAR ROW)
+               (GO LP)))
+           (COND
+              ((EQ LASTLINE T)                               (* ; 
+                                                    "kill any text that might be below bottom line")
+               (ERASE.TO.END.OF.PAGE)))
+           (RESTORE.CURSOR])
+
+(SAVE.CURSOR
+  [LAMBDA NIL                                              (* bvm%: "11-MAR-81 21:40")
+    (SETQ \HOMEROW \CURSORROW)
+    (SETQ \HOMECOL \CURSORCOL])
+
+(SCANBACK
+  [LAMBDA (CHAR BUF N START)                                 (* ; "Edited 24-May-91 10:35 by jds")
+
+(* ;;; "Searches back for Nth previous occurrence of CHAR in buffer before BUF, returning NIL if there are no occurrences.  Scan terminates at START, default is start of line;  default N is 1;  if there are fewer than N occurrences, returns the earliest one it can")
+
+    (for [X _ (OR START (SETQ START (fetch (LINE START) of \ARROW]
+           (%#HITS _ 0) by (TTNEXTCHAR X) until (EQ X BUF)
+       do (COND
+                 ((EQ (U-CASECODE (FIRSTCHAR X))
+                      CHAR)
+                  (SETQ $$VAL X)
+                  (ADD1VAR %#HITS)))
+       finally (RETURN (COND
+                              ((OR (NOT N)
+                                   (EQ N 1)
+                                   (EQ %#HITS 0)
+                                   (EQ %#HITS 1))
+                               $$VAL)
+                              (T                             (* ; 
+                            "There are #HITS occurrences of CHAR, and we want the Nth from the end")
+                                 (SCANFORWARD CHAR START (ADD1 (IMAX (IDIFFERENCE %#HITS N)
+                                                                         0))
+                                        BUF])
+
+(SCANFORWARD
+  [LAMBDA (CHAR BUF N END)                                   (* ; "Edited 24-May-91 10:35 by jds")
+
+(* ;;; "Finds Nth occurrence of CHAR in BUF before END.  Default END is end of current line;  default N is 1;  CHAR should be uppercase if a letter")
+
+    (OR N (SETQ N 1))
+    (OR END (SETQ END (fetch (LINE END) of \ARROW)))
+    (while (NEQ BUF END) do [COND
+                                       ((EQ (U-CASECODE (FIRSTCHAR BUF))
+                                            CHAR)
+                                        (COND
+                                           ((EQ (SUB1VAR N)
+                                                0)
+                                            (RETURN BUF))
+                                           (T (SETQ $$VAL BUF]
+                                   (SETQ BUF (TTNEXTCHAR BUF])
+
+(SCRATCHCONS
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 10:41 by jds")
+
+(* ;;; 
+"Returns a garbage cons from the heap at the end of the buffer, or a fresh cons if none available")
+
+    (replace (TTYINBUFFER OLDTAIL) of \TTYINSTATE with (SETQ \LASTAIL))
+                                                             (* ; 
+                                                "Wipe out last buffer ptrs, as this may trash them")
+    (PROG1 (OR (CDR \ENDBUFFER)
+               (CONS))
+        (FRPLACD \ENDBUFFER (CDDR \ENDBUFFER)))])
+
+(SEGMENT.LENGTH
+  [LAMBDA (START END)                                        (* ; "Edited 24-May-91 11:11 by jds")
+
+(* ;;; "Returns number of print positions in buffer from START to END")
+
+    (PROG ((N 0))
+      LP  (COND
+             ((EQ START END)
+              (RETURN N)))
+          (add N (COND
+                        ((COMPLEXCHARP (CAR START))
+                         (fetch (COMPLEXCHAR CPXNCHARS) of (CAR START)))
+                        (T 1)))
+          (SETQ START (CDR START))
+          (GO LP])
+
+(SEGMENT.BIT.LENGTH
+  [LAMBDA (START END)                                        (* ; "Edited 24-May-91 11:11 by jds")
+
+(* ;;; "Returns number of print positions in bits in buffer from START to END")
+
+    (PROG ((N 0))
+      LP  (COND
+             ((EQ START END)
+              (RETURN N)))
+          [add N (COND
+                        ((COMPLEXCHARP (CAR START))
+                         (fetch (COMPLEXCHAR CPXWIDTH) of (CAR START)))
+                        (T (FCHARWIDTH (CAR START)
+                                  \FONT]
+          (SETQ START (CDR START))
+          (GO LP])
+
+(SETLASTC
+  [LAMBDA (CHAR)                                             (* bvm%: "10-APR-81 23:28")
+
+    (* ;; "Makes CHAR be LASTC for T.  This is a kludge;  I should be interfacing better with \LINEBUF.OFD at a more fundamental level.")
+
+    (\BOUT \LINEBUF.OFD CHAR])
+
+(SETTAIL?
+  [LAMBDA (EVEN.IF.NOT.THERE)                                (* ; "Edited 24-May-91 10:35 by jds")
+
+    (* ;; "If \ENDBUFFER is farther than we've been before, save this position on LASTAIL.  If EVEN.IF.NOT.THERE is set, do this even if cursor is not currently at the end")
+
+    (COND
+       ([AND (NOT \DELETING)
+             (NOT (EMPTY.BUFFER))
+             (OR EVEN.IF.NOT.THERE (EQ \CURSOR \ENDBUFFER))
+             (OR (NOT \LASTAIL)
+                 (OR (ILESSP \LASTAILROW (fetch (LINE ROW) of \ARROW))
+                     (AND (ILESSP \LASTAILCOL \CURSORCOL)
+                          (ILEQ \LASTAILROW (fetch (LINE ROW) of \ARROW]
+        (SETQ \LASTAIL \ENDBUFFER)
+        (SETQ \LASTAILCOL \CURSORCOL)
+        (SETQ \LASTAILROW (fetch (LINE ROW) of \ARROW])
+
+(SHOW.MATCHING.PAREN
+  [LAMBDA (BUF)                                              (* ; "Edited 24-May-91 10:36 by jds")
+
+(* ;;; "Indicates parenthesis nesting by briefly moving the cursor to the paren that matches the paren at BUF, if that position is still on the screen.  The cursor stays there for SHOWPARENFLG seconds, or until there is input from the user.  Assumes terminal has cursor addressability")
+
+    (PROG ((MATCHING (BACKSKREAD BUF T))
+           LINE ROW COL)                                     (* ; 
+       "MATCHING is the buffer position that matches BUF, or NIL if this paren was quoted somehow.")
+          (OR MATCHING (RETURN))
+          (SETQ LINE (FIND.LINE MATCHING))               (* ; 
+                                                           "The buffer LINE on which it appears")
+          (COND
+             ((< (+ (SETQ ROW (fetch (LINE ROW) of LINE))
+                    \LOC.ROW.0)
+                 0)                                          (* ; "Not on screen, so forget it")
+              (RETURN)))
+          (SETQ COL (+ (SEGMENT.BIT.LENGTH (fetch (LINE START) of LINE)
+                              MATCHING)
+                       (fetch (LINE FIRSTCOL) of LINE)))
+                                                             (* ; "The absolute column position")
+          (COND
+             ((TYPEAHEAD?)
+
+              (* ;; "After all this computation, there is now input waiting, so don't do anything.  Didn't do this earlier, since the SIBE itself takes time, and is likely to fail when done immediately after reading the closing paren")
+
+              (RETURN)))
+          (SAVE.CURSOR)
+          (GO.TO.ADDRESSING COL ROW)                     (* ; 
+                                                     "Go to absolute coordinates of matching paren")
+          (TTWAITFORINPUT (COND
+                                 ((FIXP SHOWPARENFLG)
+                                  (TIMES SHOWPARENFLG 1000))
+                                 (T 1000)))                  (* ; "Wait a while to let user see it")
+          (\CHECKCARET \DSP)                                 (* ; 
+                                                           "Tell background we moved the cursor")
+          (RESTORE.CURSOR)                               (* ; 
+                                                           "Put cursor back where it belongs")
+      ])
+
+(SKIP/ZAP
+  [LAMBDA (CMD CHAR N MINUS)                             (* ; "Edited 24-May-91 10:41 by jds")
+
+    (* ;; "Performs <edit>S or <edit>Z, i.e.  skip or zap to character.  CMD is S, Z, B, or -Z (latter two are backward versions of the first two);  CHAR is the target character, N is a repeat arg and MINUS is its sign.  Last such operation is saved on LASTSKIP so that <edit>A can repeat it")
+
+    (SETQ CHAR (U-CASECODE CHAR))                        (* ; "Ignore case differences")
+    [COND
+       (MINUS                                                (* ; "invert command")
+              (SETQ CMD (SELECTC CMD
+                            ((CHARCODE S) 
+                                 (CHARCODE B))
+                            ((CHARCODE B) 
+                                 (CHARCODE S))
+                            ((CHARCODE Z) 
+                                 (IMINUS (CHARCODE Z)))
+                            ((IMINUS (CHARCODE Z)) 
+                                 (CHARCODE Z))
+                            (SHOULDNT]
+    (COND
+       ([SETQ N (SELECTC CMD
+                    ((CHARCODE B) 
+                         (SCANBACK CHAR \CURSOR N))
+                    ((IMINUS (CHARCODE Z)) 
+                         (SCANBACK CHAR (TTNLEFT \CURSOR 1)
+                                N))
+                    (AND (NOT (AT.END.OF.LINE))
+                         (SCANFORWARD CHAR (TTNEXTCHAR \CURSOR)
+                                N]
+        (SELECTC CMD
+            ((CHARCODE S)                                    (* ; "S")
+                 (MOVE.FORWARD.TO N))
+            ((CHARCODE Z)                                    (* ; "Z")
+                 (FORWARD.DELETE.TO N))
+            ((CHARCODE B)                                    (* ; "B")
+                 (MOVE.BACK.TO N))
+            ((IMINUS (CHARCODE Z))                           (* ; "-Z")
+                 [FORWARD.DELETE.TO (PROG1 (COND
+                                                  ((AT.END.OF.LINE)
+                                                   \CURSOR)
+                                                  (T (TTNEXTCHAR \CURSOR)))
+                                            (MOVE.BACK.TO (TTNEXTCHAR N)))])
+            (SHOULDNT)))
+       (T (BEEP)))
+    (replace (TTYINBUFFER LASTSKIP) of \TTYINSTATE with CMD)
+    (replace (TTYINBUFFER LASTSKIPCHAR) of \TTYINSTATE with CHAR])
+
+(START.NEW.LINE
+  [LAMBDA (USECR)                                            (* ; "Edited 24-May-91 10:36 by jds")
+
+(* ;;; "Handles moving to new line.  USECR, if set, is the <cr> character that should terminate current line")
+
+    (SETQ \CURSOR (fetch (LINE START) of (SETQ \ARROW (INSERTLINE \ARROW USECR])
+
+(START.OF.PARAGRAPH?
+  [LAMBDA (LINE)                                             (* ; "Edited 24-May-91 11:11 by jds")
+    (OR (EQ (fetch (LINE END) of LINE)
+            (SETQ LINE (fetch (LINE START) of LINE)))
+        (AND (COMPLEXCHARP (CAR LINE))
+             (EQ (fetch (COMPLEXCHAR CPXREALCHAR) of (CAR LINE))
+                 (CHARCODE TAB])
+
+(TTADJUSTWORD
+  [LAMBDA (WORD)                                             (* ; "Edited 20-Jan-88 12:33 by bvm")
+
+(* ;;; "Returns WORD, possibly corrected, according to the spelling list, if any.  Returns NIL if FIX was specified and the word fails.")
+
+    (LET (X)
+         (COND
+            ((OR (NULL SPLST)
+                 (FMEMB WORD '(%( %) %[ %] %" %,))
+                 (FMEMB WORD SPLST))
+             WORD)
+            ((AND WORD (SETQ X (FASSOC WORD SPLST)))         (* ; 
+                                                   "Is synonym.  FASSOC assumes car of atom is NIL")
+             (CDR X))
+            ([AND SPLST (LITATOM WORD)
+                  (NEQ \NOFIXSPELL 'NOFIXSPELL)
+                  (SETQ X (FIXSPELL WORD 70 SPLST (AND \NOFIXSPELL T]
+                                                             (* ; "respelled okay")
+             X)
+            (\FIX (TTPRIN1 WORD)
+                  (TTPRIN1 '?)
+                  (COND
+                     (HELP (TTGIVEHELP HELP))
+                     (T (TTPRIN1 "  please try again.")))
+                  (TTCRLF)
+                  NIL)
+            (T WORD])
+
+(TTBIN
+  [LAMBDA (NOMETA)                                           (* ; "Edited 18-Jan-88 15:13 by bvm")
+
+(* ;;; "Read the next char from terminal, return its character code.  Sets \EDITBIT true or false according to whether char is meta.  If NOMETA is true, the meta bit is discarded")
+
+    (PROG ((CHAR (TTWAITFORINPUT NIL T)))
+          [COND
+             ((EQ CHAR EDITPREFIXCHAR)                       (* ; "edit prefix")
+              (SETQ CHAR (\GETKEY))
+              [COND
+                 ((EQ CHAR EDITPREFIXCHAR)                   (* ; 
+                                                           "Two edits in a row = Edit-Escape")
+                  (SETQ CHAR (CHARCODE ESCAPE]
+              (SETQ CHAR (METACHAR CHAR]
+          [COND
+             ((AND NOMETA (METACHARP CHAR))                  (* ; 
+                          "Had meta key down, remove bit.  This is useful for inside Edit commands")
+              (SETQ CHAR (NONMETACHARBITS CHAR]
+          (\CHECKCARET \DSP)                                 (* ; 
+                                                  "Turn off the caret, since we will probably move")
+          (RETURN CHAR])
+
+(TTBITWIDTH
+  [LAMBDA (CHAR)                                             (* ; "Edited 17-Jan-88 16:04 by bvm:")
+    (FCHARWIDTH CHAR \FONT])
+
+(TTCRLF
+  [LAMBDA NIL                                              (* lmm "16-Nov-86 04:13")
+
+(* ;;; "Prints a crlf, updating cursor appropriately")
+
+    (DO.CRLF)
+    (TTCRLF.ACCOUNT])
+
+(TTCRLF.ACCOUNT
+  [LAMBDA NIL                                              (* ; "Edited 18-Jan-88 15:41 by bvm")
+    (SETQ \CURSORROW (ADD1 \CURSORROW))
+    [COND
+       ((EQ (+ \LOC.ROW.0 \CURSORROW)
+            \TTPAGELENGTH)                                   (* ; 
+                                         "This crlf glitched the screen, so row 0 has moved up one")
+        (SETQ \LOC.ROW.0 (SUB1 \LOC.ROW.0))                  (* ; 
+                                 "We are also now guaranteed to be on the bottom row of the window")
+        (SETQ \BMARG (DSPYPOSITION NIL \DSP]
+    (SETQ \CURSORCOL \LMARG])
+
+(TTDELETECHAR
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 10:36 by jds")
+    (COND
+       ((AT.START.OF.BUF)
+        (BEEP))
+       [(AT.END.OF.LINE)
+        (COND
+           [(AT.START.OF.LINE)                               (* ; 
+                                                      "empty line: need to delete to previous line")
+            (PROG ((PREV (PREVLINE \ARROW 1))
+                   DODELETE)
+                  (SETQ DODELETE (OVERFLOWLINE? PREV))
+                  (DELETELINE \ARROW)                    (* ; "get rid of this line")
+                  (MOVE.TO.LINE PREV (fetch (LINE END) of PREV))
+                                                             (* ; "go to end of previous line")
+                  (COND
+                     (DODELETE                               (* ; 
+                                   "We were on overflow line, so have to delete the last char, too")
+                            (DELETETO (TTNLEFT \CURSOR 1]
+           (T (DELETETO (TTNLEFT \CURSOR 1]
+       (T (TTRUBOUT])
+
+(TTDELETELINE
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 10:36 by jds")
+    (COND
+       ((EMPTY.BUFFER)
+        (BEEP))
+       [(EMPTY.LINE)                                         (* ; 
+                                                       "Empty line: delete previous line if at end")
+        (COND
+           ((AT.END.OF.BUF)
+            (MOVE.TO.LINE (PREVLINE \ARROW 1))
+            (COND
+               ((NOT DISPLAYTERMFLG)
+                (TTBOUT _)
+                (DO.CRLF)))
+            (DELETE.TO.END))
+           (T (BEEP]
+       (T (SETTAIL? T)
+          (COND
+             ((NOT DISPLAYTERMFLG)
+              (TTBOUT %# %#)                                 (* ; 
+                                      "On non-display just print ## and return to initial position")
+              [replace (LINE END) of \ARROW with (SETQ \CURSOR (SETQ \ENDBUFFER
+                                                                            (fetch (LINE START)
+                                                                               of \ARROW]
+              (replace (LINE LASTCOL) of \ARROW with (fetch (LINE FIRSTCOL)
+                                                                    of \ARROW))
+              (RETYPE.BUFFER \ARROW))
+             ((AT.END.OF.LINE)                               (* ; 
+        "kill back to start of line.  This can work on glass tty, too, whereas next clause doesn't")
+              (DELETETO (fetch (LINE START) of \ARROW)))
+             (T                                              (* ; 
+                                   "We're inside line, so go back to start and then zap whole line")
+                (MOVE.BACK.TO (fetch (LINE START) of \ARROW))
+                (FORWARD.DELETE.TO (fetch (LINE END) of \ARROW])
+
+(TTDELETEWORD
+  [LAMBDA (N)                                                (* ; "Edited 24-May-91 10:36 by jds")
+    (COND
+       ((AT.START.OF.BUF)
+        (BEEP))
+       (T (LET ((TAIL (PREVWORD \CURSOR N))
+                PREVL START)
+               (SETTAIL?)
+               (COND
+                  ((EQ TAIL \CURSOR)
+                   (DELETE.LONG.SEGMENT1 (SETQ PREVL (PREVLINE \ARROW 1))
+                          (SETQ START (PREVWORD \CURSOR N (fetch (LINE START) of PREVL)))
+                          \ARROW \CURSOR)
+                   (MOVE.TO.WHEREVER START))
+                  (T (BACKWARD.DELETE.TO TAIL])
+
+(TTECHO.TO.FILE
+  [LAMBDA (FILE DRIBBLING)                                   (* ; "Edited 24-May-91 11:11 by jds")
+
+(* ;;; "Echos input to FILE.  If DRIBBLING is true, the prompts are also echoed")
+
+    (for (STREAM _ (GETSTREAM FILE 'OUTPUT))
+           (LINE _ \FIRSTLINE)
+           (FIRSTIME _ T)
+           X CH END do (COND
+                              ([AND DRIBBLING (SETQ X (COND
+                                                         (FIRSTIME 
+                                                             (* ; "Print the first prompt")
+                                                                (SETQ FIRSTIME NIL)
+                                                                (AND \PROMPT1
+                                                                     (NOT (EQMEMB 'NOPROMPT OPTIONS))
+                                                                     \PROMPT1))
+                                                         (T \PROMPT2]
+                               (PRIN1 X FILE)))
+                          (SETQ END (fetch (LINE END) of LINE))
+                          (SETQ X (fetch (LINE START) of LINE))
+                          (until (EQ X END) do [COND
+                                                          ([NOT (COMPLEXCHARP (SETQ CH (CAR X]
+                                                           (BOUTCCODE STREAM CH))
+                                                          [(EQ (fetch (COMPLEXCHAR CPXREALCHAR)
+                                                                  of CH)
+                                                               (CHARCODE SPACE))
+
+                                               (* ;; "pseudo-tab kludge: instead of printing the 'real' character, ignore it and print only its padding spaces")
+
+                                                           (FRPTQ (fetch (COMPLEXCHAR CPXNCHARS)
+                                                                     of CH)
+                                                                  (BOUTCCODE STREAM (CHARCODE SPACE]
+                                                          (T (BOUTCCODE STREAM (fetch
+                                                                                (COMPLEXCHAR 
+                                                                                       CPXREALCHAR)
+                                                                                  of CH]
+                                                      (SETQ X (TTNEXTCHAR X)))
+                          (SETQ LINE (fetch (LINE NEXTLINE) of LINE))
+                          (COND
+                             ((AND (OR DRIBBLING (NEQ (fetch (LINE START) of LINE)
+                                                      END))
+                                   (NOT \PROMPTFORWORD))
+
+                              (* ;; "Don't terpri on overflow line, since user didn't;  except always do it to dribblefile, since that's what's on the screen.  Promptforword-style input doesn't have terminating cr.")
+
+                              (TERPRI FILE)))
+       repeatwhile (AND LINE (OR (EQ END \ENDBUFFER)
+                                     (PROGN                  (* ; 
+               "Avoid echoing the terminating empty line, except when it is an empty overflow line")
+                                            (NEQ (fetch (LINE START) of LINE)
+                                                 \ENDBUFFER])
+
+(TTGIVEHELP
+  [LAMBDA (HELPKEY)                                          (* ; "Edited 19-Jan-88 19:09 by bvm")
+    (PROG ((*STANDARD-OUTPUT* \DSP))
+          (TERPRI)
+          (COND
+             ((EQ HELPKEY T)
+              (TTGIVEHELP1))
+             [(LISTP HELPKEY)
+              (COND
+                 ((EQ (CAR HELPKEY)
+                      T)                                     (* ; 
+                                                          "List SPLST first, then subsequent blurb")
+                  (TTGIVEHELP1 T)
+                  (PRIN1 '% )
+                  (TTGIVEHELP2 (CDR HELPKEY)
+                         T))
+                 ((EQ (CDR HELPKEY)
+                      T)                                     (* ; "Similar, but blurb first")
+                  (TTGIVEHELP2 (CAR HELPKEY)
+                         T)
+                  [COND
+                     ((NEQ (POSITION)
+                           0)
+                      (PRIN1 '% ]
+                  (TTGIVEHELP1 T T))
+                 (T (TTGIVEHELP2 HELPKEY]
+             (T (TTGIVEHELP2 HELPKEY)))
+          (COND
+             ((NEQ (POSITION)
+                   0)
+              (TERPRI)))
+          (TERPRI)
+          (RETURN T])
+
+(TTGIVEHELP1
+  [LAMBDA (NO.OTHER NO.INTRO)                                (* bvm%: "11-MAR-81 21:36")
+    (COND
+       (SPLST (OR NO.INTRO (PRIN1 "Please select from among "))
+              (for X on SPLST unless (OR (EQ X SPELLSTR1)
+                                                     (EQ X SPELLSTR2))
+                 do (PRIN1 (INPART (CAR X)))
+                       (AND (CDR X)
+                            (PRIN1 ", ")))
+              (COND
+                 ((NOT NO.OTHER)
+                  (OR \FIX (PRIN1 ", or other"))
+                  (TERPRI])
+
+(TTGIVEHELP2
+  [LAMBDA (HELPKEY MIXED)                                    (* bvm%: " 8-Aug-80 00:14")
+    (COND
+       [[OR (LITATOM HELPKEY)
+            (AND (STRINGP HELPKEY)
+                 (NOT (STRPOS '%  HELPKEY]                   (* ; 
+                                                       "Atom or spaceless string is a hashfile key")
+        (COND
+           ((NOT (DISPLAYHELP HELPKEY))
+            (OR MIXED (PRIN1 "Sorry, no help available."]
+       (T (SPRINTT HELPKEY (COND
+                              (MIXED                         (* ; "no extra space")
+                                     0)
+                              (T 4))
+                 4 0])
+
+(TTLASTLINE
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 10:36 by jds")
+
+(* ;;; "Returns last LINE record in buffer")
+
+    (PROG ((LINE \FIRSTLINE)
+           L)
+      LP  (COND
+             ((SETQ L (fetch (LINE NEXTLINE) of LINE))
+              (SETQ LINE L)
+              (GO LP)))
+          (RETURN LINE])
+
+(TTLOADBUF
+  [LAMBDA (BUF)                                              (* ; "Edited  8-Feb-88 12:54 by bvm:")
+
+    (* ;; "BUF is a list, a la READBUF, which is loaded into our character buffer, using DCHCON to convert the s-expressions therein to char codes.  If we are READING, then uses PRIN2 pnames, i.e.  includes escape chars and such stuff.  Alternatively, BUF may be a string, in which case its contents are also loaded into the buffer, a la BKSYSBUF, and the setting of \READING is irrelevant")
+
+    (COND
+       [(EQ (CAR (LISTP BUF))
+            HISTSTR1)                                        (* ; 
+                                         "read from file.  BUF is (<histstr1> (file start  . end))")
+        (SETQ BUF (CADR BUF))
+        (SETFILEPTR (CAR BUF)
+               (CADR BUF))
+        (bind CHAR NEXTCH (STREAM _ (GETSTREAM (CAR BUF)
+                                               'INPUT))
+               (END _ (CDDR BUF)) while (< (GETFILEPTR STREAM)
+                                               END)
+           do                                            (* ; "Read another character.  Unfortunately, we have to go by file pointer to determine end, since stream could have ns chars in it")
+                 (COND
+                    ((NEQ (SETQ CHAR (BINCCODE STREAM))
+                          (CHARCODE CR))
+                     (ADDNAKEDCHAR CHAR T))
+                    (T                                       (* ; "eat up lf after the cr")
+                       (COND
+                          ([OR (>= (GETFILEPTR STREAM)
+                                   END)
+                               (PROGN (SETQ NEXTCH (BINCCODE STREAM))
+                                      (AND (EQ NEXTCH (CHARCODE LF))
+                                           (>= (GETFILEPTR STREAM)
+                                               END]          (* ; "Ignore final CR")
+                           (RETURN)))
+                       (ADDNAKEDCHAR CHAR)
+                       (COND
+                          ((NEQ NEXTCH (CHARCODE LF))
+                           (ADDNAKEDCHAR NEXTCH]
+       (T (PROG (START END)
+                [COND
+                   ((AND (LISTP BUF)
+                         (SETQ START (FMEMB HISTSTR0 BUF)))  (* ; 
+                                         "HISTSTR0 is a marker used by lispx to denote end of line")
+                    (FRPLACD (NLEFT BUF 1 START]
+                (SETQ START (DCHCON BUF (CDR \ENDBUFFER)
+                                   (AND (LISTP BUF)
+                                        \READING)
+                                   RDTBL))                   (* ; 
+              "Use our own buffer as a scratchlist for DCHCON as long as it's lying around anyway.")
+                [COND
+                   ((LISTP BUF)                              (* ; 
+                                                "Remove the surrounding parens from the outer list")
+                    (SETQ END (NLEFT (SETQ START (CDR START))
+                                     1]
+
+           (* ;; "now detach the result from our buffer to avoid conflict of interest.  If DCHCON found our scratchlist inadequate, START will not be a tail of \ENDBUFFER so the NLEFT below comes out NIL, which is also fine")
+
+                (FRPLACD (NLEFT \ENDBUFFER 1 START))         (* ; "Now unread the CHCON list.")
+                (READFROMBUF START END])
+
+(TTNEXTLINE
+  [LAMBDA (LINE N)                                           (* ; "Edited 24-May-91 10:36 by jds")
+    (bind L while (AND (NEQ N 0)
+                               (SETQ L (fetch (LINE NEXTLINE) of LINE)))
+       do (SETQ LINE L)
+             (SUB1VAR N) finally (RETURN LINE])
+
+(TTNEXTNODE
+  [LAMBDA (BUF)                                              (* bvm%: " 2-JUN-82 15:44")
+
+(* ;;; "Returns cdr of BUF, tacking on a new cons if the cdr was NIL")
+
+    (OR (CDR BUF)
+        (CDR (FRPLACD BUF (CONS 0])
+
+(TTNLEFT
+  [LAMBDA (BUF N START)                                      (* ; "Edited 24-May-91 10:36 by jds")
+
+(* ;;; "Backs up N real characters in this line before BUF as far as START, default being the current start of the line.  Assumes BUF is a tail of line and N is small")
+
+    (OR START (SETQ START (fetch (LINE START) of \ARROW)))
+    (PROG ((X START)
+           (B START))
+      LP                                                     (* ; "Advance X by N chars")
+          (COND
+             ((EQ N 0)
+              (GO LP1))
+             ((OR (EQ X BUF)
+                  (NULL X))                                  (* ; 
+                                            "The NULL case should never happen, but better be safe")
+              (RETURN B)))
+          (SETQ X (TTNEXTCHAR X))
+          (SUB1VAR N)
+          (GO LP)
+      LP1                                                    (* ; 
+             "Now advance X and B in parallel until X reaches BUF, at which point B is N before it")
+          (COND
+             ((OR (EQ X BUF)
+                  (NULL X))
+              (RETURN B)))
+          (SETQ X (TTNEXTCHAR X))
+          (SETQ B (TTNEXTCHAR B))
+          (GO LP1])
+
+(TTNTH
+  [LAMBDA (BUF N)                                            (* ; "Edited 24-May-91 10:36 by jds")
+
+(* ;;; "Advances N real characters in BUF as far as the end of the line")
+
+    (bind (END _ (fetch (LINE END) of \ARROW)) while (AND (NEQ N 0)
+                                                                          (NEQ BUF END))
+       do (SETQ BUF (TTNEXTCHAR BUF))
+             (SUB1VAR N) finally (RETURN BUF])
+
+(TTNTHLINE
+  [LAMBDA (N)
+    (DECLARE (USEDFREE \FIRSTLINE))                      (* ; "Edited 24-May-91 10:36 by jds")
+    (for (LINE _ \FIRSTLINE) do (COND
+                                           ((ILEQ N 0)
+                                            (RETURN LINE))
+                                           (T (SETQ N (SUB1 N))
+                                              (SETQ LINE (OR (fetch (LINE NEXTLINE) of LINE)
+                                                             (RETURN LINE])
+
+(TTPRIN1
+  [LAMBDA (STR DOWNCASE INITP)                               (* ; "Edited 20-Jan-88 10:52 by bvm")
+
+(* ;;; "PRIN1 of STR, atom or string, directly to the terminal, bypassing any dribble file.  Returns the number of crlfs it did.")
+
+    (if (AND DOWNCASE (NOT (U-CASEP STR)))
+        then (SETQ DOWNCASE NIL))
+    (PROG ((CRLFCOUNT 0)
+           CH WIDTH)
+          (if (OR INITP (EQ \CURSORCOL \LMARG))
+              then                                       (* ; "If starting at left margin, we might as well start printing.  This handles the otherwise unpleasant case of STR being wider than the window")
+                    (GO ONE.AT.A.TIME))
+
+     (* ;; "See if we have space first")
+
+          (COND
+             ((>= [+ \CURSORCOL (SETQ WIDTH (for I from 1 while (SETQ CH (NTHCHARCODE
+                                                                                      STR I))
+                                               sum (if (EQ CH (CHARCODE CR))
+                                                           then 
+                                                             (* ; 
+                                     "I don't know how to handle strings with cr in them.  Punt...")
+                                                                 (GO ONE.AT.A.TIME))
+                                                     (CHARWIDTH (if DOWNCASE
+                                                                    then (L-CASECODE CH)
+                                                                  else CH)
+                                                            \DSP]
+                  \RMARG)                                    (* ; 
+                                                           "We would go past the right margin")
+              (if (> WIDTH (- \RMARG \LMARG))
+                  then                                   (* ; 
+                                           "It wouldn't fit even at the left, so go start printing")
+                        (GO ONE.AT.A.TIME))
+              (add CRLFCOUNT 1)
+              (TTCRLF)))
+          (for I from 1 while (SETQ CH (NTHCHARCODE STR I))
+             do (TTBOUT (if DOWNCASE
+                                then (L-CASECODE CH)
+                              else CH)))
+          (add \CURSORCOL WIDTH)
+          (GO DONE)
+      ONE.AT.A.TIME
+          
+
+     (* ;; "Print chars one at a time.  This handles initial prompts, as well as strings that are wider than the window.")
+
+          (for I from 1 while (SETQ CH (NTHCHARCODE STR I))
+             do (if (EQ CH (CHARCODE CR))
+                        then (TTCRLF)
+                              (add CRLFCOUNT 1)
+                      else (if (> (add \CURSORCOL (CHARWIDTH (SETQ CH
+                                                                          (if DOWNCASE
+                                                                              then (L-CASECODE
+                                                                                        CH)
+                                                                            else CH))
+                                                                     \DSP))
+                                          \RMARG)
+                                   then                  (* ; "Out of space")
+                                         (TTCRLF)
+                                         (add CRLFCOUNT 1)
+                                         (add \CURSORCOL (CHARWIDTH CH \DSP)))
+                            (TTBOUT CH)))
+      DONE
+          (RETURN CRLFCOUNT])
+
+(TTPRINSPACE
+  [LAMBDA (N)                                                (* ; "Edited 18-Jan-88 23:57 by bvm:")
+    (OR N (SETQ N 1))
+    (if (>= (+ \CURSORCOL N)
+                \RMARG)
+        then (TTCRLF)
+      else (RPTQ N (TTBOUT SPACE))
+            (add \CURSORCOL (TIMES N (CHARWIDTH (CHARCODE SPACE)
+                                                \DSP])
+
+(TTPRIN1COMMENT
+  [LAMBDA (STR DOWNCASE)                                     (* ; "Edited 16-Jan-88 16:55 by bvm:")
+
+    (* ;; "TTPRIN1 of STR in the comment, rather than default, font.")
+
+    (DSPFONT (PROG1 (DSPFONT \COMMENTFONT T)
+                    (TTPRIN1 STR DOWNCASE))
+           T])
+
+(TTPRIN2
+  [LAMBDA (EXPR CARLVL CDRLVL)                               (* ; "Edited 16-Jan-88 18:01 by bvm:")
+    (LISP:TYPECASE EXPR
+        (LISTP 
+           (OR CARLVL (SETQ CARLVL 10))
+           (OR CDRLVL (SETQ CDRLVL 10))
+           [LET (FIRST WRAPPER)
+                (COND
+                   ((<= CARLVL 0)
+                    (TTPRIN1 '%#))
+                   ((AND (LITATOM (SETQ FIRST (CAR EXPR)))
+                         (SETQ WRAPPER (GET FIRST 'PRETTYWRAPPER))
+                         (LISTP (CDR EXPR))
+                         (NULL (CDDR EXPR))
+                         (SETQ WRAPPER (LISP:FUNCALL WRAPPER EXPR)))
+                                                             (* ; "This handles quote and friends")
+                    (TTPRIN1 WRAPPER)
+                    (TTPRIN2 (CADR EXPR)
+                           CARLVL CDRLVL))
+                   (T (TTPRIN1 '%()
+                      [do (TTPRIN2 (CAR EXPR)
+                                     (SUB1 CARLVL)
+                                     (SUB1 CDRLVL))
+                             (COND
+                                ((NLISTP (SETQ EXPR (CDR EXPR)))
+                                 (COND
+                                    (EXPR (TTPRIN1 " . ")
+                                          (TTPRIN2 EXPR)))
+                                 (RETURN))
+                                (T (TTPRIN1 '% )
+                                   (COND
+                                      ((<= (SETQ CDRLVL (SUB1 CDRLVL))
+                                           0)
+                                       (TTPRIN1 "...")
+                                       (RETURN]
+                      (TTPRIN1 '%)])
+        (T (TTPRIN1 (MKSTRING EXPR T *READTABLE*))))])
+
+(TTPROMPTCHAR
+  [LAMBDA (LINE)                                             (* ; "Edited 20-Jan-88 11:33 by bvm")
+
+(* ;;; "Prints the prompt for indicated LINE")
+
+    (CLEAR.LINE?)
+    (LET ((PROMPT (COND
+                     ((EQ LINE \FIRSTLINE)
+                      \PROMPT1)
+                     (T \PROMPT2)))
+          CRLFS)
+         (COND
+            (PROMPT (SETQ CRLFS (TTPRIN1 PROMPT NIL T))
+                   (if (EQ LINE \FIRSTLINE)
+                       then 
+
+                             (* ;; "If the prompt took more than one line, account for being down a bit farther (normally CRLFS is 0), but insist that \cursorrow is still zero (it was bumped by crlf).  (I don't know what to do if an internal prompt is wider).  But then")
+
+                             (add \LOC.ROW.0 (SETQ \INITCRLFS CRLFS))
+                             (SETQ \CURSORROW 0])
+
+(TTRUBOUT
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 10:36 by jds")
+
+(* ;;; "Delete the previous character -- this is the interpretation of DELETE while inserting")
+
+    (COND
+       ((NOT (AT.START.OF.LINE))
+        (BACKWARD.DELETE.TO (TTNLEFT \CURSOR 1)))
+       ((AT.START.OF.BUF)
+        (BEEP))
+       (T 
+          (* ;; "At start of line, backspace deletes previous cr or char at end of previous overflow line, so have to compute more here")
+
+          (LET ((PREVL (PREVLINE \ARROW 1))
+                START)
+               (DELETE.LONG.SEGMENT1 PREVL (SETQ START (TTNLEFT \CURSOR 1 (fetch
+                                                                                   (LINE START)
+                                                                                     of PREVL)))
+                      \ARROW \CURSOR)
+               (MOVE.TO.WHEREVER START])
+
+(TTUNREADBUF
+  [LAMBDA NIL
+    (DECLARE (USEDFREE \CURSOR \ENDBUFFER))              (* bvm%: "11-Apr-85 15:13")
+
+(* ;;; "Takes contents of buffer from \CURSOR onward and 'unreads' it, i.e.  erases it and simulates terminal input, a la BKSYSBUF")
+
+    (for (X _ \CURSOR) by (TTNEXTCHAR X) until (EQ X \ENDBUFFER)
+       do (BKSYSCHARCODE (FIRSTCHAR X)))
+    (DELETE.TO.END])
+
+(TTWAITFORINPUT
+  [LAMBDA (MSECS RETKEYFLG)                                  (* ; "Edited 19-Jan-88 01:00 by bvm")
+
+    (* ;; "Waits for mouse or keystroke.  If MSECS is non-NIL, waits a maximum of that many milliseconds.  If RETKEYFLG is true, returns the input (if there is some), otherwise just T without reading input.  Mouse buttons are returned as funny codes")
+
+    (PROG ((TIMER (AND MSECS (SETUPTIMER MSECS)))
+           (REG (DSPCLIPPINGREGION NIL \DSP))
+           W X Y FN ABSY NEWMARG)
+      LP  [COND
+             ((\SYSBUFP)
+              (RETURN (COND
+                         (RETKEYFLG (\GETKEY))
+                         (T T]
+          (WAIT.FOR.TTY)
+          (GETMOUSESTATE)
+          [COND
+             ((AND (LASTMOUSESTATE (OR RED YELLOW BLUE))
+                   (>= (SETQ X (LASTMOUSEX \DSP))
+                       0)
+                   (< X (fetch (REGION WIDTH) of REG))
+                   (>= (SETQ Y (- (SETQ ABSY (LASTMOUSEY \DSP))
+                                  (fetch (REGION BOTTOM) of REG)))
+                       0)
+                   (< Y (+ (fetch (REGION HEIGHT) of REG)
+                           \CHARHEIGHT))
+                   (SETQ W (WHICHW LASTMOUSEX LASTMOUSEY))
+                   (EQ (WINDOWPROP W 'DSP)
+                       \DSP))                                (* ; "Bugged inside this window")
+
+              (* ;; "The IPLUS is a grotesque kludge to include the title bar.  Problem is that REG needs to be the clipping region, not the window region, because we get mouse coordinates in DSP terms, not window terms.  Damn Dedit typein buffer")
+
+              (* ;; "The WHICHW test is so that we don't fight the scrollbar handler, or anyone else who happens to be on top of this window.  Really should have monitorlock on mouse")
+
+              (COND
+                 [(AND (NOT (EMPTY.BUFFER))
+                       (< ABSY (+ \BMARG (TIMES (- \TTPAGELENGTH \LOC.ROW.0)
+                                                \CHARHEIGHT)))
+                       (< Y (fetch (REGION HEIGHT) of REG))
+                       (>= Y (- (ITIMES (- \TTPAGELENGTH (+ \LOC.ROW.0 (fetch (LINE ROW)
+                                                                          of (TTLASTLINE))
+                                                            1))
+                                       \CHARHEIGHT)
+                                4)))
+
+                  (* ;; "Pointing inside text region.  The second ILESSP is in case the text region overflows the window, we still want title bar to be for menu")
+
+                  (COND
+                     ((NOT RETKEYFLG)
+                      (RETURN T))
+                     (T (DO.MOUSE)
+                        (SETQ \PFW.FIRSTTIME NIL)
+                        (GO LP]
+                 ([AND \WINDOWWORLD (SETQ FN (COND
+                                                ((LASTMOUSESTATE (ONLY BLUE))
+                                                 (OR (fetch (TTYINBUFFER TTOLDRIGHTFN)
+                                                        of \TTYINSTATE)
+                                                     (FUNCTION DOWINDOWCOM)))
+                                                (T (fetch (TTYINBUFFER TTOLDBUTTONFN)
+                                                      of \TTYINSTATE]
+                                                             (* ; 
+                                "Pointing in our window, but outside text--do regular button stuff")
+                  (\PROTECTED.APPLY FN (WHICHW))
+                  (COND
+                     ((NEQ \RMARG (SETQ NEWMARG (DSPRIGHTMARGIN NIL \DSP)))
+                                                             (* ; "Window was reshaped")
+                      (COND
+                         ((> \RMARG (SETQ \RMARG NEWMARG))   (* ; "Window got narrower, so reprint")
+                          (DO.EDIT.PP)))
+                      (SETQ REG (DSPCLIPPINGREGION NIL \DSP]
+          (COND
+             ((AND TIMER (TIMEREXPIRED? TIMER))
+              (RETURN NIL)))
+          (\TTYBACKGROUND)
+          (GO LP])
+
+(TTYINSTRING
+  [LAMBDA (BUF TAIL)                                         (* ; "Edited 27-Jan-88 16:00 by bvm")
+
+(* ;;; "Returns a string consisting of the 'real' chars in buffer from BUF to TAIL or end of buffer.  If BUF = TAIL returns a null string")
+
+    (OR TAIL (SETQ TAIL \ENDBUFFER))
+    (LET ((NC 0)
+          FATP RESULT)
+         (for (X _ BUF) by (TTNEXTCHAR X) until (EQ X TAIL)
+            do                                           (* ; 
+                                                    "First scan to see how long string needs to be")
+                  (COND
+                     ((\FATCHARCODEP (FIRSTCHAR X))
+                      (SETQ FATP T)))
+                  (add NC 1))
+         (SETQ RESULT (ALLOCSTRING NC NIL NIL FATP))
+         (for (X _ BUF) by (TTNEXTCHAR X) until (EQ X TAIL) as I from 1
+            do (RPLCHARCODE RESULT I (FIRSTCHAR X)))
+         RESULT])
+
+(TYPE.BUFFER
+  [LAMBDA (START END)                                        (* ; "Edited 24-May-91 11:12 by jds")
+
+(* ;;; "Types buffer from START to END, returning number of chars typed.  Assumes no CR's")
+
+    (bind ($$VAL _ 0)
+           WIDTH CH while (NEQ START END) do [SETQ WIDTH (COND
+                                                                    ((COMPLEXCHARP (SETQ CH
+                                                                                    (CAR START)))
+                                                                     (for PC
+                                                                        in (fetch
+                                                                                (COMPLEXCHAR 
+                                                                                       CPXPRINTCHARS)
+                                                                                  of CH)
+                                                                        do (TTBOUT PC))
+                                                                     (fetch (COMPLEXCHAR CPXWIDTH
+                                                                                       ) of
+                                                                                         CH))
+                                                                    (T (TTBOUT CH)
+                                                                       (TTBITWIDTH CH]
+                                                    (add \CURSORCOL WIDTH)
+                                                    (add $$VAL WIDTH)
+                                                    (SETQ START (CDR START])
+
+(U-CASECODE
+  [LAMBDA (CHAR)                                             (* lmm "16-Nov-86 13:24")
+    (LISP:CHAR-INT (LISP:CHAR-UPCASE (LISP:INT-CHAR CHAR])
+
+(U/L-CASE
+  [LAMBDA (N CAPFLG)
+    (DECLARE (USEDFREE \CURSOR \ARROW))                  (* ; "Edited 24-May-91 10:37 by jds")
+
+(* ;;; "UPPER or lower-case N words.  CAPFLG=T for uppercase;  CAPFLG=1 for just capitalization")
+
+    (COND
+       ((AND (EQ N 1000)
+             (AT.END.OF.LINE))
+
+        (* ;; "$U or $L at end of line means do it to the whole line.  This handles the common situation where you have typed several words in the wrong case and want to fix them without backing up to the beginning")
+
+        (MOVE.BACK.TO (fetch (LINE START) of \ARROW)))
+       (T (MOVE.TO.START.OF.WORD)))                      (* ; "Go to start of current word")
+    (PROG ((NEXTWD (CHECK.MARGIN (FIND.NEXT.WORD \CURSOR N)))
+           NEEDADJUST OLDLENGTH)
+          (SETQ OLDLENGTH (SEGMENT.BIT.LENGTH \CURSOR NEXTWD))
+                                                             (* ; "Notice how long it is now")
+          (for (BUF _ (PROGN \CURSOR))
+                 CHAR until (EQ BUF NEXTWD) do [COND
+                                                          ((AND [NOT (COMPLEXCHARP (SETQ CHAR
+                                                                                    (CAR BUF]
+                                                                (>= CHAR (CHARCODE A)))
+                                                           (RPLACA BUF (COND
+                                                                          (CAPFLG (COND
+                                                                                     ((EQ CAPFLG 1)
+                                                             (* ; "only raise first char of word")
+                                                                                      (SETQ CAPFLG 
+                                                                                       NIL)))
+                                                                                 (U-CASECODE
+                                                                                  CHAR))
+                                                                          (T (L-CASECODE CHAR]
+                                                      (SETQ BUF (TTNEXTCHAR BUF)))
+          (SETQ NEEDADJUST (TTADJUSTWIDTH (- (SEGMENT.BIT.LENGTH \CURSOR NEXTWD)
+                                                 OLDLENGTH)
+                                  NEXTWD))
+          (TYPE.BUFFER \CURSOR (SETQ \CURSOR NEXTWD))
+          (COND
+             (NEEDADJUST (ADJUSTLINE.AND.RESTORE])
+)
+
+
+
+(* ; 
+"Internal reading.  These functions all expect caller to have bound *READTABLE* correctly (not bound in TTYIN for who-line transparency)"
+)
+
+(DEFINEQ
+
+(TTRATOM
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 11:18 by jds")
+
+(* ;;; "Reads next atom from BUFFER, advancing it suitably")
+
+    (COND
+       ((EQ (TTSKIPSEPR)
+            \ENDBUFFER)
+        null)
+       (T (LET ((STRM (TTYINBUFFERSTREAM \BUFFER)))
+               (PROG1 (RATOM STRM)
+                   (SETQ \BUFFER (fetch (TTYINBUFFERSTREAM TTYINPUT) of STRM)))])
+
+(TTREADLIST
+  [LAMBDA NIL                                              (* ; "Edited 16-Jan-88 18:01 by bvm:")
+
+(* ;;; "Read a list of elements.  OPENCHAR is the character that started the list (paren or bracket) or NIL if none.")
+
+    (LET ((STRM (TTYINBUFFERSTREAM \BUFFER \ENDBUFFER)))
+         (while (SKIPSEPRS STRM) collect (READ STRM])
+
+(TTSKIPSEPR
+  [LAMBDA (END)                                              (* bvm%: "11-Apr-85 15:13")
+
+(* ;;; "Skip \BUFFER over any separator chars, returning new value")
+
+    (while (AND (NEQ \BUFFER \ENDBUFFER)
+                    (NEQ \BUFFER END)
+                    (SPACEP (FIRSTCHAR \BUFFER))) do (SETQ \BUFFER (TTNEXTCHAR \BUFFER)))
+    \BUFFER])
+
+(TTSKREAD
+  [LAMBDA (BUF END PARENCOUNT)                               (* ; "Edited  8-Feb-88 12:46 by bvm:")
+
+    (* ;; "Simulates READLINE starting at BUF, returning tail of BUF where the read would terminate, or NIL if the read does not terminate before END (default \ENDBUFFER).  If PARENCOUNT is true and the read does not terminate on account of unmatched parens, then returns the excess paren count instead of NIL.")
+
+    (OR END (SETQ END \ENDBUFFER))
+    (bind X while (NEQ BUF END)
+       do [SELECTC (\SYNCODE \RDTBLSA (FIRSTCHAR BUF))
+                  ((LIST LEFTPAREN.RC LEFTBRACKET.RC)        (* ; "open paren/bracket")
+                       (SETQ X (CAR BUF))
+                       (COND
+                          ((NOT (SETQ BUF (TTSKREAD (CDR BUF)
+                                                 END PARENCOUNT)))
+                                                             (* ; 
+                                                           "Failed to match string quotes, etc")
+                           (RETURN NIL))
+                          ((EQ BUF END)                      (* ; 
+                           "Everything after the paren worked out ok, but we have no closing paren")
+                           (RETURN (AND PARENCOUNT 1)))
+                          ((FIXP BUF)                        (* ; "Unmatched parens")
+                           (RETURN (ADD1 BUF)))
+                          ((AND (EQ (CAR BUF)
+                                    (CHARCODE %]))
+                                (NEQ X (CHARCODE %[)))       (* ; 
+                                                           "left paren terminated by right bracket")
+                           (RETURN BUF))))
+                  ((LIST RIGHTPAREN.RC RIGHTBRACKET.RC)      (* ; "closing paren/bracket")
+                       (RETURN BUF))
+                  (STRINGDELIM.RC 
+                       (COND
+                          ((NOT (SETQ BUF (FIND.MATCHING.QUOTE (CDR BUF)
+                                                 END)))
+                           (RETURN NIL))))
+                  (ESCAPE.RC                                 (* ; "  skip over without looking")
+                             (COND
+                                ((EQ (SETQ BUF (CDR BUF))
+                                     END)                    (* ; "Last char was escape")
+                                 (RETURN NIL))))
+                  (MULTIPLE-ESCAPE.RC                        (* ; 
+                  "Look for matching multiple escape, respecting only single escapes along the way")
+                       (OR (while (NEQ (SETQ BUF (CDR BUF))
+                                           END) do (SELECTC (\SYNCODE \RDTBLSA (FIRSTCHAR BUF))
+                                                           (ESCAPE.RC (COND
+                                                                         ((EQ (SETQ BUF (CDR BUF))
+                                                                              END)
+                                                                          (RETURN))))
+                                                           (MULTIPLE-ESCAPE.RC 
+                                                                (RETURN BUF))
+                                                           NIL))
+                           (RETURN NIL)))
+                  (OTHER.RC NIL)
+                  (PROGN                                     (* ; 
+                            "Some sort of macro.  Most we don't care about, but semicolon is nasty")
+                         (COND
+                            ((AND (EQ (FIRSTCHAR BUF)
+                                      (CHARCODE ;))
+                                  (READTABLEPROP RDTBL 'COMMONLISP))
+                                                             (* ; "Skip ahead to end of line")
+                             (COND
+                                ([do (COND
+                                            ((EQ (SETQ BUF (CDR BUF))
+                                                 END)
+                                             (RETURN T))
+                                            ((EQ (FIRSTCHAR BUF)
+                                                 (CHARCODE EOL))
+                                             (RETURN]        (* ; 
+                                 "Ended inside this comment, so not complete -- just as if escaped")
+                                 (RETURN NIL]
+             (SETQ BUF (CDR BUF)) finally (RETURN BUF])
+
+(TTYIN.READ
+  [LAMBDA (FINALCHAR DONTREAD STREAM)                        (* ; "Edited 16-Jan-88 17:58 by bvm:")
+
+(* ;;; "Process buffer for reading.  FINALCHAR is what prompted us to terminate the call to TTYIN and is not in the buffer.  If DONTREAD is true, then STREAM is the line buffer and we are acting as \FILLBUFFER -- otherwise, STREAM is our own scratch stream, with an eof fn that returns right paren;  we read the buffer and return a list of expressions")
+
+    (LET (LASTC BUTLASTC)
+         (while (NEQ \BUFFER \ENDBUFFER) do (SETQ BUTLASTC LASTC) 
+                                                             (* ; "Fill the buffer")
+                                                   (BOUTCCODE STREAM (SETQ LASTC (FIRSTCHAR \BUFFER))
+                                                          )
+                                                   (SETQ \BUFFER (TTNEXTCHAR \BUFFER)))
+         (COND
+            ((AND DONTREAD (SELCHARQ FINALCHAR
+                                (EOL (SELECTC (\SYNCODE \RDTBLSA LASTC)
+                                         ((LIST RIGHTPAREN.RC RIGHTBRACKET.RC) 
+                                              (COND
+                                                 ((OR (NULL BUTLASTC)
+                                                      (EQ (\SYNCODE \RDTBLSA BUTLASTC)
+                                                          ESCAPE.RC))
+                                                             (* ; 
+                     "If it ended in a quoted right paren, then it's just like any other character")
+                                                  T)
+                                                 ((EQ (\SYNCODE \RDTBLSA (CHARCODE %]))
+                                                      RIGHTBRACKET.RC)
+
+                                     (* ;; "Line ended in paren.  Change to right bracket so READLINE doesn't get confused.  Only do this if ] really is right bracket!")
+
+                                                  (\SETFILEPTR STREAM (IDIFFERENCE (\GETFILEPTR
+                                                                                    STREAM)
+                                                                             (STREAMBYTESPERCHAR
+                                                                              STREAM)))
+                                                  (BOUTCCODE STREAM (CHARCODE %]))
+                                                  NIL)))
+                                         T))
+                                ((%) %]) 
+                                     NIL)
+                                T))                          (* ; 
+   "Print FINALCHAR unless terminator was EOL and line already ended in a closing paren or bracket")
+             (BOUTCCODE STREAM FINALCHAR)))
+         (\SETEOFPTR STREAM (\GETFILEPTR STREAM))
+         (\SETFILEPTR STREAM 0)
+         (COND
+            (DONTREAD                                        (* ; 
+                                   "STREAM = \LINEBUF.OFD and caller will take care of reading buf")
+                   (AND (EQ STREAM \LINEBUF.OFD)
+                        (replace (LINEBUFFER LINEBUFSTATE) of STREAM with READING.LBS))
+                   T)
+            (T                                               (* ; 
+                                                           "Read from buffer until it's empty")
+               (PROG1 (bind TERM while [AND (SKIPSEPRS STREAM)
+                                                    (SETQ TERM (NLSETQ (READ STREAM]
+                         collect (CAR TERM))
+                   (\SETFILEPTR STREAM 0)                    (* ; 
+                                      "Now clear the stream so nobody reads extra garbage after us")
+                   (\SETEOFPTR STREAM 0))])
+)
+
+
+
+(* ; "Escape completion and friends")
+
+(DEFINEQ
+
+(FIND.MATCHING.WORD
+  [LAMBDA (WORDS START BUFTAIL)                              (* lmm "14-Nov-86 17:09")
+
+    (* ;; "Find the first word in spelling list WORDS which matches the characters in the buffer from START to BUFTAIL (or current cursor position), and return the corresponding tail of WORDS")
+
+    (OR BUFTAIL (SETQ BUFTAIL \CURSOR))
+    (find TAIL on WORDS suchthat (WORD.MATCHES.BUFFER (INPART (CAR TAIL))
+                                                    START BUFTAIL])
+
+(TTCOMPLETEWORD
+  [LAMBDA (CAUTIOUS MUST.BE.UNIQUE FIRSTMATCH START)         (* ; "Edited 20-Jan-88 12:32 by bvm")
+
+    (* ;; "Tries to complete the current word from members of SPLST.  Does nothing if no word in progress, or this is a comment line.  Returns true if some completion done.  If CAUTIOUS, only complete if can do so uniquely and caller permits fixspell;  if MUST.BE.UNIQUE set, only do unique completion.  FIRSTMATCH, if supplied, is the first match in SPLST, and START the start of the current word being worked on")
+
+    (LET
+     ((UNIQUE T)
+      TAIL FIRSTMATCHCHARS SUFFIXCHARS LASTCHAR NEXTCHAR I WORD CH)
+     (COND
+        ([AND [OR START (SETQ START (COND
+                                       ((AT.START.OF.BUF)    (* ; 
+                                   "Empty buffer.  Allow altmode completion on one-word splst here")
+                                        (AND (NOT CAUTIOUS)
+                                             \BUFFER))
+                                       (T (CURRENT.WORD]
+              (OR FIRSTMATCH (SETQ FIRSTMATCH (FIND.MATCHING.WORD SPLST START]
+
+         (* ;; "Completion may be possible.  (CAR FIRSTMATCH) is the first match in SPLST;  START is buffer tail where current word starts;  NEXTCHAR is the relative position of cursor in current word, i.e. #chars in word + 1;  LASTCHAR is the last char position in common among all words which match.  Both NEXTCHAR and LASTCHAR are in terms of the actual characters of the symbol, rather than its printed representation, so as to ignore questions of how the words might be escaped.")
+
+         [SETQ NEXTCHAR (ADD1 (for (TAIL _ START) by (TTNEXTCHAR TAIL)
+                                 until (EQ TAIL \CURSOR)
+                                 sum (SELECTC (\SYNCODE \RDTBLSA (FIRSTCHAR TAIL))
+                                             (MULTIPLE-ESCAPE.RC 
+                                                             (* ; "ignore")
+                                                  0)
+                                             (ESCAPE.RC      (* ; 
+                                                       "Ignore the escape, but count the next char")
+                                                        (if (EQ (SETQ TAIL (TTNEXTCHAR TAIL))
+                                                                    \CURSOR)
+                                                            then 
+                                                             (* ; 
+                                           "Shouldn't happen--FIND.MATCHING.WORD would have failed")
+                                                                  (RETURN $$VAL)
+                                                          else 1))
+                                             1]
+         [SETQ LASTCHAR (NCHARS (SETQ FIRSTMATCH (INPART (CAR (SETQ TAIL FIRSTMATCH]
+         (COND
+            ((OR CAUTIOUS (EQ (SUB1 NEXTCHAR)
+                              LASTCHAR))
+
+             (* ;; "The latter case happens if the current word is exactly MATCH.  In this case, if there are any other matches they are with words containing MATCH as initial substring, and thus no further completion is possible")
+
+             (SETQ MUST.BE.UNIQUE T)))
+
+         (* ;; "Now run through all other possible matches with the current word, reducing LASTCHAR to indicate the largest segment in common.")
+
+         (while (SETQ TAIL (FIND.MATCHING.WORD (CDR TAIL)
+                                      START))
+            do (COND
+                      (MUST.BE.UNIQUE (RETURN)))
+                  (SETQ UNIQUE NIL)                        (* ; "No longer a unique match")
+                  (SETQ WORD (INPART (CAR TAIL)))
+                  [COND
+                     ([find old I from NEXTCHAR to LASTCHAR as REFERENCE
+                         in (OR SUFFIXCHARS (SETQ SUFFIXCHARS (FNTH (SETQ FIRSTMATCHCHARS
+                                                                         (CHCON FIRSTMATCH))
+                                                                        NEXTCHAR)))
+                         suchthat (AND (NEQ (SETQ CH (NTHCHARCODE WORD I))
+                                                REFERENCE)
+                                           (NOT (AND CH (EQ (LOGXOR CH 32)
+                                                            REFERENCE)
+                                                     (IGEQ CH (CHARCODE A))
+                                                     (ILEQ CH (CHARCODE z]
+                      (COND
+                         ((EQ I NEXTCHAR)                    (* ; "Tails are completely different, i.e., we have found two words that match the prefix so far, but they have no further characters in common, so give up")
+                          (RETURN))
+                         (T                                  (* ; 
+                                                          "reset LASTCHAR to last common character")
+                            (SETQ LASTCHAR (SUB1 I]
+            finally
+
+            (* ;; "chars from NEXTCHAR to LASTCHAR are uniquely determined by prefix so far")
+
+            [PROG ((BUF START)
+                   (OLDLENGTH 0)
+                   RETYPEBUF RETYPETARGET RETYPELENGTH J NEEDADJUST ESCAPED)
+                  (END.DELETE.MODE)
+                  [SETQ FIRSTMATCHCHARS (if (NOT (LITATOM FIRSTMATCH))
+                                            then         (* ; "Don't bother with prin2 stuff")
+                                                  (CHCON FIRSTMATCH)
+                                          else           (* ; "We want to get the case and escaping right for completion, but we don't know how to handle packages yet, so get a pname unlikely to have a package")
+                                                (LET ((*PACKAGE* (OR (LISP:SYMBOL-PACKAGE FIRSTMATCH)
+                                                                     *PACKAGE*)))
+                                                     (CHCON FIRSTMATCH T]
+                  (SETQ I 1)
+                  (until (EQ I NEXTCHAR)
+                     do 
+
+                           (* ;; 
+               "Scan old part of string (part user has typed already) to make sure case is correct")
+
+                           (SETQ CH (CAR FIRSTMATCHCHARS))
+                           (if RETYPEBUF
+                               then (add RETYPELENGTH 1)
+                             elseif (OR (NEQ CH (CAR BUF))
+                                            (EQ BUF \CURSOR))
+                               then                      (* ; "The real spelling is different from what's in buf, so we'll want to fix it.  The (eq buf \\cursor) test is just in case somehow the buffer has fewer chars than target, but the first n are identical.  (Can you think of an example??)")
+                                     (SETQ RETYPEBUF BUF)
+                                     (SETQ RETYPETARGET FIRSTMATCHCHARS)
+                                     (SETQ RETYPELENGTH 1))
+                           (if (NOT (if ESCAPED
+                                            then         (* ; "Previous char was escape")
+                                                  (SETQ ESCAPED NIL)
+                                          else (OR (FIXP CH)
+                                                       (HELP CH))
+                                                (SELECTC (\SYNCODE \RDTBLSA CH)
+                                                    (ESCAPE.RC (SETQ ESCAPED T))
+                                                    (MULTIPLE-ESCAPE.RC 
+                                                         T)
+                                                    NIL)))
+                               then                      (* ; "Count real chars as they go by")
+                                     (add I 1))
+                           (SETQ FIRSTMATCHCHARS (CDR FIRSTMATCHCHARS))
+                           (SETQ BUF (CDR BUF)))
+                  [if RETYPEBUF
+                      then                               (* ; 
+                                "We found a difference, so smash old contents and retype as needed")
+                            [if (EQ (SETQ BUF RETYPEBUF)
+                                        \CURSOR)
+                                then                     (* ; "RETYPEBUF = \CURSOR when the word we want to type has MORE characters than buffer does, yet the characters in buffer match identically.  I don't think this can happen.")
+                                      (HELP "More chars in match than source?")
+                              else (for old J from 1 to RETYPELENGTH
+                                          until (EQ BUF \CURSOR)
+                                          do             (* ; "Replace existing buf chars until we either get to the current cursor position or we have used up the scanned chars of the match")
+                                                (add OLDLENGTH (TTBITWIDTH (CAR BUF))) 
+                                                             (* ; 
+                                            "OLDLENGTH computes old distance from RETYPEBUF to BUF")
+                                                (RPLACA BUF (CAR RETYPETARGET))
+                                                (SETQ BUF (CDR BUF))
+                                                (SETQ RETYPETARGET (CDR RETYPETARGET)))
+                                    [GO.TO.RELATIVE (- \CURSORCOL (+ OLDLENGTH
+                                                                         (PROGN 
+                                                             (* ; 
+  "If the new word is shorter than old, we haven't yet counted the bits from old BUF to the cursor")
+                                                                                (SEGMENT.BIT.LENGTH
+                                                                                 BUF \CURSOR] 
+                                                             (* ; "Go to start of changes")
+                                    (SETQ NEEDADJUST (TTADJUSTWIDTH (- (SEGMENT.BIT.LENGTH
+                                                                            RETYPEBUF BUF)
+                                                                           OLDLENGTH)
+                                                            BUF))
+                                    (TYPE.BUFFER RETYPEBUF BUF) 
+                                                             (* ; "Retype with new contents.")
+                                    (COND
+                                       (NEEDADJUST (ADJUSTLINE.AND.RESTORE)))
+                                    (if (NEQ BUF \CURSOR)
+                                        then 
+
+                                 (* ;; "There are more chars in buf than target, so have to delete (this can happen if buffer contains escape characters not deemed necessary in the print name).  We could optimize movement by overtyping some of FIRSTMATCHCHARS instead of doing ADDCHAR's below, but the logic gets way messier than is seemly")
+
+                                              (FORWARD.DELETE.TO (PROG1 \CURSOR (
+                                                                                   MOVE.TO.WHEREVER
+                                                                                     BUF]
+                            (until (EQ RETYPETARGET FIRSTMATCHCHARS)
+                               do                        (* ; "The match has more characters than the buffer, e.g., when there were mixed-case chars needing escaping, so add the rest of target that we've already scanned.")
+                                     (ADDCHAR (pop RETYPETARGET]
+
+             (* ;; 
+           "Now do second half, the completion part: add new chars from NEXTCHAR thru LASTCHAR")
+
+                  (if UNIQUE
+                      then                               (* ; 
+                                  "Just add all the chars, including a possible final vertical bar")
+                            (while FIRSTMATCHCHARS do (ADDCHAR (pop FIRSTMATCHCHARS))
+                                   )
+                            [COND
+                               ((NOT CAUTIOUS)               (* ; "delimit as well")
+                                (ADDCHAR (CHARCODE SPACE))
+                                (COND
+                                   ((AND (NEQ NEXTCHAR 1)
+                                         (MEMB SPELLSTR1 (OR SPLST USERWORDS)))
+
+                                 (* ;; "Spelling list maintenance: user completed on this word, so move to front of spelling list, assuming this is a real spelling list.  Don't do it in the trivial case of filling in the entire word uniquely (as when doing LASTWORD)")
+
+                                    (MOVETOP FIRSTMATCH (OR SPLST USERWORDS]
+                    else (until (> I LASTCHAR)
+                                do (ADDCHAR (SETQ CH (pop FIRSTMATCHCHARS)))
+                                      (if (NOT (if ESCAPED
+                                                       then 
+                                                             (* ; "Previous char was escape")
+                                                             (SETQ ESCAPED NIL)
+                                                     else (SELECTC (\SYNCODE \RDTBLSA CH)
+                                                                  (ESCAPE.RC (SETQ ESCAPED T))
+                                                                  (MULTIPLE-ESCAPE.RC 
+                                                                       T)
+                                                                  NIL)))
+                                          then           (* ; "Count real chars as they go by")
+                                                (add I 1]
+            (RETURN (OR (AND UNIQUE FIRSTMATCH)
+                        T])
+
+(WORD.MATCHES.BUFFER
+  [LAMBDA (WORD START BUFTAIL)                               (* ; "Edited 17-Jan-88 18:07 by bvm:")
+
+(* ;;; "True if WORD matches case-insensitively chars in buffer from START to BUFTAIL")
+
+    (for (I _ 0) as (BTAIL _ START) by (TTNEXTCHAR BTAIL) bind CHAR BUFCH
+       until (EQ BTAIL BUFTAIL)
+       always (OR (SELECTC (\SYNCODE \RDTBLSA (SETQ BUFCH (FIRSTCHAR BTAIL)))
+                          (ESCAPE.RC                         (* ; "Skip to next character")
+                                     (if (EQ (SETQ BTAIL (TTNEXTCHAR BTAIL))
+                                                 BUFTAIL)
+                                         then            (* ; 
+                                           "Last character was escape.  How can we match anything?")
+                                               (RETURN NIL))
+                                     (SETQ BUFCH (FIRSTCHAR BTAIL))
+                                     NIL)
+                          (MULTIPLE-ESCAPE.RC                (* ; "Just ignore multiple escape--it doesn't affect single escape, and so what if we match some things that aren't quite the right case?")
+                               T)
+                          NIL)
+                      [EQ BUFCH (SETQ CHAR (NTHCHARCODE WORD (add I 1]
+                      (AND CHAR (EQ (LOGXOR CHAR 32)
+                                    BUFCH)
+                           (IGEQ CHAR (CHARCODE A))
+                           (ILEQ CHAR (CHARCODE z])
+
+(TTYIN.SHOW.?ALTERNATIVES
+  [LAMBDA NIL                                              (* ; "Edited  8-Feb-88 12:47 by bvm:")
+
+    (* ;; "Called when ? is typed, to indicate alternative completions of current word")
+
+    (LET (X MATCHED STARTOFWORD DOWNCASE)
+         (COND
+            ((OR (PROGN                                      (* ; 
+                                                           "Global flag controls all of this")
+                        (NOT ?ACTIVATEFLG))
+                 (LISP:UNLESS (EQ \LASTCHAR DIDESCAPECODE)   (* ; "If the immediately preceding typein was not an attempt at escape completion, don't answer ? if there's no spelling list or we're not at the end of the input")
+                     (OR (NOT SPLST)
+                         (NOT (AT.END.OF.BUF))))
+                 [PROGN                                      (* ; 
+                                                           "There needs to be a word in progress")
+                        (NOT (SETQ STARTOFWORD (CURRENT.WORD]
+                 (PROGN                                      (* ; 
+                                             "If previous char is ?, let it alone (allows ?? etc).")
+                        (EQ (SETQ X (CAR (NLEFT STARTOFWORD 1 \ENDBUFFER)))
+                            (CHARCODE ?)))
+                 (SELECTC (\SYNCODE \RDTBLSA X)
+                     ((LIST MULTIPLE-ESCAPE.RC ESCAPE.RC)    (* ; "Preceded by an escape character.  This isn't quite right, since the escape could be escaped, but it's close")
+                          T)
+                     NIL)
+                 (PROGN (FRPLACA \ENDBUFFER (CHARCODE ?))    (* ; "This is pretty random--i.e., if we decide to do something, first stick a ? beyond the end of the buffer")
+                        NIL))
+
+             (* ;; "All sorts of cases where we want to just treat the ? as a normal character")
+
+             (ADDCHAR (CHARCODE ?)))
+            [(NOT (SETQ MATCHED (FIND.MATCHING.WORD (OR SPLST USERWORDS)
+                                       STARTOFWORD)))
+             (BEEP)                                      (* ; 
+                                                 "No match.  Ring the bell, but accept the ? as is")
+             (OR (EQ \LASTCHAR DIDESCAPECODE)
+                 (ADDCHAR (CHARCODE ?]
+            ((TTCOMPLETEWORD NIL T MATCHED STARTOFWORD))
+            (T                                               (* ; "There was more than one completion, so display them (if there was a unique one, TTCOMPLETEWORD filled it in)")
+               (SAVE.CURSOR)
+               (GO.TO.FREELINE)
+               (if (AND (NEQ *PRINT-CASE* :UPCASE)
+                            (READTABLEPROP RDTBL 'CASEINSENSITIVE))
+                   then                                  (* ; 
+                          "Normally would print things in lower case, so try to do that here, too.")
+                         (SETQ DOWNCASE T))
+               (TTPRIN1COMMENT "one of ")
+               [do (TTPRIN1 (INPART (CAR MATCHED))
+                              DOWNCASE)
+                      (COND
+                         ((SETQ MATCHED (FIND.MATCHING.WORD (CDR MATCHED)
+                                               STARTOFWORD))
+                          (TTPRIN1COMMENT ", "))
+                         (T (RETURN]
+               (RESTORE.CURSOR])
+)
+
+
+
+(* ; "? and ?= handler")
+
+(DEFINEQ
+
+(DO?CMD
+  [LAMBDA (CMD \?TAIL)
+    (DECLARE (SPECVARS \?TAIL \?PARAMS \BUFFER \STARTED))(* ; "Edited  8-Feb-88 12:47 by bvm:")
+
+(* ;;; "Handles 'read macros' ?  and ?=.  CMD is one of those.  Returns NIL if thinks it isn't.  Saves current cursor location for later restoration")
+
+    (\CARET.DOWN)
+    (PROG ((*READTABLE* RDTBL)
+           (\BUFFER \BUFFER)
+           (\?PARAMS null)
+           (\STARTED NIL)
+           (START (BACKSKREAD \CURSOR))
+           STUFF FN FNSTART FNEND SPTAIL SAVE)
+          [HANDLER-BIND ((LISP:ERROR (FUNCTION DO?CMD.ERRORHANDLER)))
+                                                             (* ; "This handler is in case there is an error while reading the symbol we're trying to get information about.")
+                 (SELECTC (\SYNCODE \RDTBLSA (FIRSTCHAR START))
+                     ((LIST LEFTPAREN.RC LEFTBRACKET.RC) 
+                          (COND
+                             ([AND (EQ (SCANFORWARD (CAR START)
+                                              (SETQ FNSTART \BUFFER))
+                                       START)
+                                   (PROGN                    (* ; "START is the first paren in buffer, so check and see if there's an atom before it, and that the atom is not an exec command")
+                                          (SETQ FN (TTRATOM))
+                                          (SETQ FNEND \BUFFER)
+                                          (AND (EQ (TTSKIPSEPR)
+                                                   START)
+                                               (NOT (GETHASH FN *EXEC-COMMAND-TABLE*]
+                                                             (* ; 
+                                      "This is first list on line, preceded by FN in evalqt format")
+                              )
+                             (T (SETQ FNSTART (SETQ \BUFFER (CDR START)))
+                                                             (* ; "EVAL form: read fn")
+                                (COND
+                                   ((EQ (SETQ FN (TTRATOM))
+                                        CMD)                 (* ; "Hasn't typed the fn name yet!")
+                                    (RETURN)))
+                                (SETQ FNEND \BUFFER))))
+                     (PROGN                                  (* ; 
+                                                           "Not inside a list now, so no macro")
+                            (RETURN)))
+
+                 (* ;; 
+              "Have to do it this way so that specials get set above to prepare for deletion of ?=")
+
+                 (SAVE.CURSOR)
+                 (COND
+                    ((EQ CMD '?)                             (* ; "Want verbose description of fn")
+                     (XHELPSYS FN))
+                    (T (GO.TO.FREELINE)
+                       (SETQ \STARTED T)                     (* ; 
+                                                          "Tells error handler we've begun to work")
+                       [COND
+                          ((EQ \BUFFER START)                (* ; "Apply format, skip over paren")
+                           (SETQ \BUFFER (CDR START]
+                       (COND
+                          ([OR (NOT TTYIN?=FN)
+                               (NOT (SETQ STUFF (LISP:FUNCALL TTYIN?=FN FN]
+                                                             (* ; 
+                                                        "Default: get the arglist and interpret it")
+                           (if [NULL (SETQ STUFF (NLSETQ (SMARTARGLIST FN T (SETQ SPTAIL
+                                                                                 (CONS FN]
+                               then                      (* ; 
+                                             "Error occurred getting args, probably not a function")
+                                     (TTPRIN1COMMENT "Couldn't find args for ")
+                                     (TTPRIN2 FN)
+                                     (SETQ SPTAIL NIL)
+                             else (COND
+                                         ((NEQ FN (SETQ FN (CAR SPTAIL)))
+                                                             (* ; 
+        "Fn was spelling corrected, so There was an extra crlf involved in printing the correction")
+                                          (TTCRLF.ACCOUNT))
+                                         (T (SETQ SPTAIL NIL)))
+                                   (TTYIN.PRINTARGS FN (CAR STUFF)
+                                          T)))
+                          ((EQ (CAR (LISTP STUFF))
+                               'ARGS)
+                           (TTYIN.PRINTARGS FN (CDR STUFF)
+                                  T))
+                          ((LISTP STUFF)
+                           (TTPRIN2 STUFF))
+                          ((NEQ STUFF T)
+                           (TTPRIN1 STUFF]
+          (SELECTQ CMD
+              (?                                             (* ; "now delete the ?")
+                 (TTRUBOUT))
+              (?= (RESTORE.CURSOR)
+                  (BACKWARD.DELETE.TO \?TAIL)
+                  (COND
+                     (SPTAIL 
+
+                            (* ;; "Fn was spelling corrected, so replace it.  There was also an extra crlf involved in printing the correction")
+
+                            (SETQ SAVE \CURSOR)
+                            (MOVE.TO.WHEREVER FNEND)
+                            (BACKWARD.DELETE.TO FNSTART)
+                            (READFROMBUF (CHCON FN T *READTABLE*))
+                            (MOVE.TO.WHEREVER SAVE))))
+              NIL)
+          (RETURN T])
+
+(TTYIN.PRINTARGS
+  [LAMBDA (FN ARGS ACTUALS ARGTYPE)                          (* ; "Edited 19-Jan-88 01:37 by bvm")
+
+    (* ;; "Prints args to fn, matching up with ACTUALS, if supplied.  Do this in a way that lets us keep track of where we are.")
+
+    (PROG ((EQUALS " = ")
+           (SPACE " ")
+           NEXTARG KEY TYPE REMARGS DOWNCASE)
+          (\CARET.DOWN)
+          (TTPRIN1 "(")
+          (TTPRIN2 FN)
+          (if (AND ARGS (NEQ *PRINT-CASE* :UPCASE)
+                       (READTABLEPROP *READTABLE* 'CASEINSENSITIVE))
+              then                                       (* ; 
+                          "Normally would print things in lower case, so try to do that here, too.")
+                    (SETQ DOWNCASE T))
+          [COND
+             [(LISTP ARGS)                                   (* ; 
+                                                           "Something interesting to print here")
+              [COND
+                 ((LISP:CHARACTERP (CAR ARGS))               (* ; "Forget about actuals")
+                  (SETQ ACTUALS NIL))
+                 ((COND
+                     ((EQ ACTUALS T)                         (* ; "Means to compute the actuals")
+                      (SETQ ACTUALS (TTYIN.READ?=ARGS)))
+                     (T ACTUALS))                            (* ; 
+                                                         "We have some actuals to match up to args")
+                  (COND
+                     ((CDR ACTUALS)                          (* ; 
+                       "More than one actual, so let's put each one on its own line for legibility")
+                      (TTCRLF))
+                     (T                                      (* ; "Start on the same line")
+                        (TTPRINSPACE)))
+                  (while ACTUALS
+                     do
+
+                     (* ;; "This loop will somehow print all the actual args from the user's input")
+
+                     (COND
+                        ((NULL ARGS)                         (* ; "More actuals than allowed")
+                         (TTPRIN1COMMENT "+ ... "))
+                        ((NLISTP ARGS)                       (* ; 
+                                      "Last arg is a %"&rest%" arg, but indicated as a dotted tail")
+                         (TTPRIN1COMMENT " . ")
+                         (TTPRIN1COMMENT ARGS DOWNCASE)
+                         (SETQ ARGS NIL)
+                         (RETURN))
+                        ((LISP:CHARACTERP (SETQ NEXTARG (CAR ARGS)))
+                                                             (* ; "We've gotten to the part where it's reduced to a syntax description.  I don't plan to match actuals to that.")
+                         (SETQ ACTUALS NIL)
+                         (RETURN))
+                        (T                                   (* ; 
+                                                     "Some argument name or lambda keyword to show")
+                           (SETQ ARGS (CDR ARGS))
+                           (TTPRIN1COMMENT NEXTARG DOWNCASE)
+                           (SELECTQ NEXTARG
+                               (&OPTIONAL                    (* ; 
+                                                "We've printed &optional, now print the first name")
+                                          (TTPRINSPACE)
+                                          (TTPRIN1COMMENT (pop ARGS)
+                                                 DOWNCASE))
+                               ((&REST &BODY)                (* ; 
+                                                           "This will consume all remaining args")
+                                    (TTPRINSPACE)
+                                    (TTPRIN1COMMENT (pop ARGS)
+                                           DOWNCASE)
+                                    (RETURN))
+                               (&KEY                         (* ; 
+                                                           "Parse actuals into keyword pairs")
+                                     (LET ((ALLOW-OTHER-KEYS (MEMB '&ALLOW-OTHER-KEYS ARGS))
+                                           USEDKEYS KEY)
+                                          (while ACTUALS
+                                             do (TTCRLF)
+                                                   (SETQ KEY (pop ACTUALS))
+                                                   (if (OR ALLOW-OTHER-KEYS (MEMB KEY ARGS)
+                                                               (EQ KEY :ALLOW-OTHER-KEYS))
+                                                       then 
+                                                             (* ; "Good keyword")
+                                                             (TTPRIN2 KEY)
+                                                             (push USEDKEYS KEY)
+                                                     else 
+                                                             (* ; 
+                                                           "Something random--indicate skepticism")
+                                                           (TTPRIN1COMMENT "[")
+                                                           (TTPRIN2 KEY 2 4)
+                                                           (TTPRIN1COMMENT "]"))
+                                                   (TTPRIN1COMMENT EQUALS)
+                                                   (if ACTUALS
+                                                       then (TTPRIN2 (pop ACTUALS)
+                                                                       2 4)))
+                                          (if (SETQ ARGS (LISP:SET-DIFFERENCE ARGS USEDKEYS))
+                                              then       (* ; "there is more to print")
+                                                    (TTCRLF))
+                                          (RETURN)))
+                               (&ALLOW-OTHER-KEYS 
+                                    (TTCRLF)
+                                    (GO $$ITERATE))
+                               NIL)))
+                     (TTPRIN1COMMENT EQUALS)
+                     (TTPRIN2 (CAR ACTUALS)
+                            2 4)
+                     (SETQ ACTUALS (CDR ACTUALS))
+                     (TTCRLF))
+
+                  (* ;; "At this point, if there are any ACTUALS left, it means we had a &REST or dotted tail.  Just print everything that's left")
+
+                  (if ACTUALS
+                      then (TTPRIN1COMMENT EQUALS)
+                            (do (TTPRIN2 (pop ACTUALS)
+                                           2 4)
+                                   (if ACTUALS
+                                       then (TTPRINSPACE)
+                                     else                (* ; "Finished")
+                                           (RETURN)))
+                            (if ARGS
+                                then                     (* ; "More to say yet")
+                                      (TTCRLF]
+
+              (* ;; "We've now printed all the actuals.  Are there any more args to print?")
+
+              (while ARGS bind (DOSPACE _ T)
+                 do (if (NLISTP ARGS)
+                            then (TTPRIN1COMMENT " . ")
+                                  (TTPRIN1COMMENT ARGS DOWNCASE)
+                                  (RETURN))
+                       (SETQ NEXTARG (pop ARGS))
+                       (SETQ DOSPACE (if (LISP:CHARACTERP NEXTARG)
+                                         then            (* ; 
+                    "Funny syntax description.  Nicer if we handle spacing better than the default")
+                                               (CASE NEXTARG
+                                                   ((#\) #\] #\} #\*) 
+                                                             (* ; 
+                                                          "Don't space before these (but do after)")
+)
+                                                   (T (if (AND DOSPACE (NEQ \CURSORCOL \LMARG))
+                                                          then (TTPRINSPACE))))
+                                               (CASE NEXTARG
+                                                   ((#\( #\)) 
+                                                             (* ; 
+                              "Parens are part of written syntax, so they come out in regular font")
+                                                      (TTPRIN1 NEXTARG))
+                                                   (T        (* ; "Others are comment")
+                                                      (TTPRIN1COMMENT NEXTARG)))
+                                               (CASE NEXTARG
+                                                   ((#\( #\[ #\{) 
+                                                             (* ; "Don't space after these")
+                                                      NIL)
+                                                   (T T))
+                                       else (if (AND DOSPACE (NEQ \CURSORCOL \LMARG))
+                                                    then (TTPRINSPACE))
+                                             (if (LISP:KEYWORDP NEXTARG)
+                                                 then    (* ; 
+                                                         "Nice to print colon in front of keywords")
+                                                       (TTPRIN1COMMENT ":"))
+                                             (TTPRIN1COMMENT NEXTARG DOWNCASE]
+             ((NOT (NULL ARGS))                              (* ; 
+                                                           "Atomic arglist--some sort of nospread")
+              (TTPRIN1COMMENT " ...")
+              (if (NEQ ARGS 'U)
+                  then                                   (* ; "The canonical nospread has arglist U, which is hopelessly uninformative, so don't even bother printing it")
+                        (TTPRIN1COMMENT ARGS)
+                        (TTPRIN1COMMENT "..."]
+          (TTPRIN1 ")")
+          (COND
+             ((SETQ TYPE (SELECTQ (OR ARGTYPE (ARGTYPE FN))
+                             (1 'NL)
+                             (3 'NL*)
+                             NIL))                         (* ; "indicate arg type")
+              (TTPRIN1COMMENT (CONCAT " {" TYPE "}"])
+
+(TTYIN.READ?=ARGS
+  [LAMBDA NIL                                              (* ; "Edited 17-Jan-88 15:20 by bvm:")
+
+    (* ;; "Read the actual args for ?= from current input.  Assumes \BUFFER has been positioned at start of args and \?TAIL at ?=.  Caches args in special var \?PARAMS so that repeated calls do not recompute.")
+
+    (COND
+       [(EQ \?PARAMS null)
+        (SETQ \?PARAMS (AND (NEQ (TTSKIPSEPR \?TAIL)
+                                 \?TAIL)
+                            (WITH-RESOURCES (TTSCRATCHFILE)
+                                   (LET ((\BUFFER \BUFFER)
+                                         (\ENDBUFFER \?TAIL))
+                                        (TTYIN.READ NIL NIL TTSCRATCHFILE]
+       (T (LISTP \?PARAMS])
+
+(DO?CMD.ERRORHANDLER
+  [LAMBDA (CONDITION)                                        (* ; "Edited 19-Jan-88 20:16 by bvm")
+
+    (* ;; "Called by a condition handler underneath ?= handler -- display the condition and abort")
+
+    (if (NOT \STARTED)
+        then                                             (* ; "Cursor still after the ?=")
+              (SAVE.CURSOR)
+              (GO.TO.FREELINE))
+    (TTPRIN1COMMENT (MKSTRING CONDITION))
+    (RESTORE.CURSOR)
+    (BACKWARD.DELETE.TO \?TAIL)                          (* ; 
+  "Finally, go back and erase the ?=, then return T from DO?CMD to indicate that we did something.")
+    (RETFROM (FUNCTION DO?CMD)
+           T])
+)
+
+
+
+(* ; "Display handling")
+
+(DEFINEQ
+
+(BEEP
+  [LAMBDA (DS)                                               (* bvm%: "27-JUL-83 23:20")
+    (RESETFORM (VIDEOCOLOR (NOT (VIDEOCOLOR)))
+           (DISMISS 200])
+
+(BITBLT.DELETE
+  [LAMBDA (X Y WIDTH)                                        (* ; "Edited 18-Jan-88 15:16 by bvm")
+    (PROG ((MOVEDWIDTH (- \RMARG X WIDTH)))                  (* ; 
+                                          "First move everything from the right over to cursor pos")
+          (BITBLT \DSP (+ X WIDTH)
+                 Y \DSP X Y MOVEDWIDTH \CHARHEIGHT 'INPUT 'REPLACE)
+
+     (* ;; "then delete the last WIDTH positions on the line.  May be unnecessary if they were already blank, might want to check LASTCOL")
+
+          (BITBLT.ERASE (+ X MOVEDWIDTH)
+                 Y WIDTH \CHARHEIGHT])
+
+(BITBLT.ERASE
+  [LAMBDA (LEFT BOTTOM WIDTH HEIGHT)                         (* ; "Edited 18-Jan-88 15:18 by bvm")
+    (BLTSHADE \TEXTURE \DSP LEFT BOTTOM WIDTH HEIGHT 'REPLACE])
+
+(BITBLT.INSERT
+  [LAMBDA (X Y WIDTH)                                        (* ; "Edited 18-Jan-88 15:18 by bvm")
+    (BITBLT \DSP X Y \DSP (+ X WIDTH)
+           Y
+           (- \RMARG X WIDTH)
+           \CHARHEIGHT
+           'INPUT
+           'REPLACE)
+    (BITBLT.ERASE X Y WIDTH \CHARHEIGHT])
+
+(DO.CRLF
+  [LAMBDA NIL                                              (* ; "Edited 18-Jan-88 15:19 by bvm")
+    (SETQ \CURRENTDISPLAYLINE 0)                             (* ; "Avoid stop scroll nonsense")
+    (DSPLINEFEED (- \CHARHEIGHT)
+           \DSP)
+    (\DSPPRINTCR/LF (CHARCODE CR)
+           \DSP])
+
+(DO.DELETE.LINES
+  [LAMBDA (%#LINES)                                          (* ; "Edited 19-Jan-88 16:35 by bvm")
+    (PROG ((TOTALHEIGHT (+ (- (DSPYPOSITION NIL \DSP)
+                              \BMARG)
+                           \CHARHEIGHT))
+           (WIDTH (- \RMARG \LMARG))
+           (BOTTOM (- \BMARG \DESCENT))
+           (DELHEIGHT (TIMES %#LINES \CHARHEIGHT)))
+
+     (* ;; "TOTALHEIGHT is distance from top of current line to bottom of window.  DELHEIGHT is height of lines being removed.")
+
+          [COND
+             ((> DELHEIGHT TOTALHEIGHT)                      (* ; 
+                                                           "Delete everything from here down")
+              (SETQ DELHEIGHT TOTALHEIGHT))
+             (T (BITBLT \DSP \LMARG BOTTOM \DSP \LMARG (+ BOTTOM DELHEIGHT)
+                       WIDTH
+                       (- TOTALHEIGHT DELHEIGHT)
+                       'INPUT
+                       'REPLACE]
+          (BITBLT.ERASE \LMARG BOTTOM WIDTH DELHEIGHT])
+
+(DO.INSERT.LINE
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 10:37 by jds")
+
+(* ;;; "Inserts a new line on screen in front of current cursor row.  The trickiness here is that unless there are some blank lines at the bottom of the screen, we actually have to scroll upwards before we can insert downwards, lest we lose the bottom line.  Leaves cursor at start of new blank line.")
+
+    (PROG ((DY (- (DSPYPOSITION NIL \DSP)
+                  \DESCENT))
+           (WIDTH (- \RMARG \LMARG)))
+          [COND
+             ((EQ (+ \LOC.ROW.0 (fetch (LINE ROW) of (TTLASTLINE))
+                     1)
+                  \TTPAGELENGTH)                             (* ; 
+                                         "Bottom line is occupied, so scroll stuff above us upward")
+              (add DY \CHARHEIGHT)
+              (MOVETO (DSPXPOSITION NIL \DSP)
+                     (+ DY \DESCENT)
+                     \DSP)
+              (BITBLT \DSP \LMARG DY \DSP \LMARG (+ DY \CHARHEIGHT)
+                     WIDTH
+                     (- (fetch (REGION TOP) of (DSPCLIPPINGREGION NIL \DSP))
+                        (+ DY \CHARHEIGHT))
+                     'INPUT
+                     'REPLACE)
+              (SETQ \LOC.ROW.0 (SUB1 \LOC.ROW.0))            (* ; 
+                                                           "Top line of buffer has moved up one")
+              )
+             (T                                              (* ; 
+                                               "Shove everything at or below current line down one")
+                (BITBLT \DSP \LMARG (+ \BMARG \CHARHEIGHT)
+                       \DSP \LMARG \BMARG WIDTH (- DY \BMARG)
+                       'INPUT
+                       'REPLACE]                             (* ; "and clear this line")
+          (BITBLT.ERASE \LMARG DY WIDTH \CHARHEIGHT])
+
+(DO.LF
+  [LAMBDA NIL                                              (* ; "Edited 18-Jan-88 15:26 by bvm")
+    (\DSPPRINTCR/LF (CHARCODE LF)
+           \DSP])
+
+(ERASE.TO.END.OF.LINE
+  [LAMBDA NIL                                              (* ; "Edited 18-Jan-88 15:27 by bvm")
+    (LET ((X (DSPXPOSITION NIL \DSP)))
+         (BITBLT.ERASE X (- (DSPYPOSITION NIL \DSP)
+                                \DESCENT)
+                (- \RMARG X)
+                \CHARHEIGHT])
+
+(ERASE.TO.END.OF.PAGE
+  [LAMBDA NIL                                              (* ; "Edited 18-Jan-88 22:41 by bvm:")
+
+(* ;;; "Erases from current cursor position to end of page.")
+
+    (ERASE.TO.END.OF.LINE)
+    (LET ((BELOW (- (DSPYPOSITION NIL \DSP)
+                    \BMARG)))
+
+         (* ;; "Y-descent is the bottom of current line.  \BMARG-descent is bottom of window.  Is there anything there?")
+
+         (COND
+            ((> BELOW 0)
+             (BITBLT.ERASE \LMARG (- \BMARG \DESCENT)
+                    (- \RMARG \LMARG)
+                    BELOW])
+
+(INSERT.TEXT
+  [LAMBDA (START END ENDOFLINE)                              (* bvm%: " 4-JUN-82 13:43")
+
+(* ;;; "Inserts on screen the contents of buffer from START to END.  Text from END to ENDOFLINE is the remainder of the line, in case it's more economical to just retype the line than do the insertion")
+
+    (COND
+       ((EQ END ENDOFLINE)
+        (TYPE.BUFFER START ENDOFLINE))
+       (T (TTINSERTSECTION (SEGMENT.BIT.LENGTH START END))
+          (TYPE.BUFFER START END])
+
+(TTDELSECTION
+  [LAMBDA (WIDTH)                                            (* ; "Edited 18-Jan-88 15:28 by bvm")
+
+(* ;;; "Deletes WIDTH bits at current pos")
+
+    (BITBLT.DELETE (DSPXPOSITION NIL \DSP)
+           (- (DSPYPOSITION NIL \DSP)
+              \DESCENT)
+           WIDTH])
+
+(TTADJUSTWIDTH
+  [LAMBDA (DELTA END)                                        (* ; "Edited 24-May-91 10:37 by jds")
+
+    (* ;; "Expand or shrink line at current cursorpos by DELTA.  END, if supplied, is the end of the section being adjusted;  if it is the end of the current line, then it is assumed that expansion is cheap.  Returns true if anything was done")
+
+    (COND
+       ((NEQ DELTA 0)
+        (COND
+           ((ILESSP DELTA 0)                                 (* ; "Line has shrunk")
+            (TTDELSECTION (IMINUS DELTA)))
+           ((NEQ END (fetch (LINE END) of \ARROW))   (* ; 
+                                        "Line has expanded, so need to spread it if not at the end")
+            (TTINSERTSECTION DELTA)))
+        (add (fetch (LINE LASTCOL) of \ARROW)
+               DELTA)
+        T])
+
+(TTINSERTSECTION
+  [LAMBDA (WIDTH)                                            (* ; "Edited 18-Jan-88 15:29 by bvm")
+
+(* ;;; "Inserts WIDTH character positions, leaving cursor at start of insertion")
+
+    (BITBLT.INSERT (DSPXPOSITION NIL \DSP)
+           (- (DSPYPOSITION NIL \DSP)
+              \DESCENT)
+           WIDTH])
+
+(TTSETCURSOR
+  [LAMBDA (COL ROW)                                          (* ; "Edited 18-Jan-88 15:29 by bvm")
+
+(* ;;; "Sets cursor to absolute screen position COL,ROW")
+
+    (MOVETO COL (+ (TIMES (- \TTPAGELENGTH ROW 1)
+                          \CHARHEIGHT)
+                   \BMARG)
+           \DSP])
+)
+
+
+
+(* ; "TTYINBUFFERSTREAM")
+
+(DEFINEQ
+
+(TTYINBUFFERDEVICE
+  [LAMBDA NIL                                              (* bvm%: "11-Apr-86 11:43")
+
+(* ;;; "Defines a device for streams that read from the ttyin buffer.  Modeled after the null device except for the interesting parts")
+
+    (create FDEV
+           DEVICENAME _ 'TTYIN
+           RANDOMACCESSP _ NIL
+           NODIRECTORIES _ T
+           CLOSEFILE _ (FUNCTION NILL)
+           DELETEFILE _ (FUNCTION NILL)
+           OPENFILE _ (FUNCTION \NULL.OPENFILE)
+           REOPENFILE _ (FUNCTION \NULL.OPENFILE)
+           BIN _ (FUNCTION TTYINBUFFERBIN)
+           BOUT _ (FUNCTION NILL)
+           PEEKBIN _ (FUNCTION TTYINBUFFERPEEK)
+           READP _ (FUNCTION TTYINBUFFERREADP)
+           BACKFILEPTR _ (FUNCTION TTYINBUFFERBACKPTR)
+           EOFP _ (FUNCTION TTYINBUFFEREOFP)
+           RENAMEFILE _ (FUNCTION NILL)
+           GETFILENAME _ (FUNCTION NILL)
+           EVENTFN _ (FUNCTION NILL)
+           BLOCKIN _ (FUNCTION \EOF.ACTION)
+           BLOCKOUT _ (FUNCTION NILL)
+           GENERATEFILES _ (FUNCTION \NULLFILEGENERATOR)
+           GETFILEPTR _ (FUNCTION ZERO)
+           GETEOFPTR _ (FUNCTION ZERO)
+           SETFILEPTR _ (FUNCTION NILL)
+           GETFILEINFO _ (FUNCTION NILL)
+           SETFILEINFO _ (FUNCTION NILL)
+           SETEOFPTR _ (FUNCTION NILL])
+
+(TTYINBUFFERSTREAM
+  [LAMBDA (BUF END EOFACTION)                                (* ; "Edited 24-May-91 11:19 by jds")
+    (LET [(STRM (OR \TTYINBUFFERSTREAM (SETQ \TTYINBUFFERSTREAM (create STREAM
+                                                                       DEVICE _ TTYINBUFFERDEVICE
+                                                                       ACCESS _ 'INPUT]
+         (replace (TTYINBUFFERSTREAM TTYINPUT) of STRM with BUF)
+         (replace (TTYINBUFFERSTREAM TTYEOF) of STRM with (OR END \ENDBUFFER))
+         (replace (TTYINBUFFERSTREAM TTYEOFACTION) of STRM with EOFACTION)
+         (replace (TTYINBUFFERSTREAM TTYORIGINPUT) of STRM with BUF)
+         STRM])
+
+(TTYINBUFFERBIN
+  [LAMBDA (STRM)                                             (* ; "Edited 24-May-91 11:19 by jds")
+    (LET ((BUF (fetch (TTYINBUFFERSTREAM TTYINPUT) of STRM)))
+         (COND
+            ((EQ BUF (fetch (TTYINBUFFERSTREAM TTYEOF) of STRM))
+                                                             (* ; "Eof")
+             (\EOF.ACTION STRM))
+            (T (PROG1 (FIRSTCHAR BUF)
+                   (replace (TTYINBUFFERSTREAM TTYINPUT) of STRM with (CDR BUF)))])
+
+(TTYINBUFFERPEEK
+  [LAMBDA (STREAM NOERRORFLG)                                (* ; "Edited 24-May-91 11:19 by jds")
+    (LET ((BUF (fetch (TTYINBUFFERSTREAM TTYINPUT) of STREAM)))
+         (COND
+            ((EQ BUF (fetch (TTYINBUFFERSTREAM TTYEOF) of STREAM))
+                                                             (* ; "Eof")
+             (AND (NOT NOERRORFLG)
+                  (\EOF.ACTION STREAM)))
+            (T (FIRSTCHAR BUF])
+
+(TTYINBUFFERREADP
+  [LAMBDA (STRM)                                             (* ; "Edited 24-May-91 11:19 by jds")
+    (NEQ (fetch (TTYINBUFFERSTREAM TTYINPUT) of STRM)
+         (fetch (TTYINBUFFERSTREAM TTYEOF) of STRM])
+
+(TTYINBUFFEREOFP
+  [LAMBDA (STRM)                                             (* ; "Edited 24-May-91 11:19 by jds")
+    (EQ (fetch (TTYINBUFFERSTREAM TTYINPUT) of STRM)
+        (fetch (TTYINBUFFERSTREAM TTYEOF) of STRM])
+
+(TTYINBUFFERBACKPTR
+  [LAMBDA (STRM)                                             (* ; "Edited 24-May-91 11:19 by jds")
+
+(* ;;; "Back up STRM one.  Needed because of top-level READ.  What a kludge")
+
+    (replace (TTYINBUFFERSTREAM TTYINPUT) of STRM
+       with (OR (NLEFT (fetch (TTYINBUFFERSTREAM TTYORIGINPUT) of STRM)
+                           1
+                           (fetch (TTYINBUFFERSTREAM TTYINPUT) of STRM))
+                    (fetch (TTYINBUFFERSTREAM TTYINPUT) of STRM])
+
+(TTYINWORDRDTBL
+  [LAMBDA NIL                                              (* ; "Edited 20-Jan-88 22:01 by bvm")
+
+(* ;;; "Makes a table in which normal Lisp syntax characters are just break characters.  Additionally, comma is a break")
+
+    (LET [(TBL (COPYREADTABLE 'ORIG))
+          (BREAKS (CHARCODE (%( %) %[ %] %" %,]
+         (SETSEPR (CHARCODE (SPACE TAB CR))
+                NIL TBL)
+         (SETSEPR BREAKS 1 TBL)                              (* ; 
+                       "Have to disable their regular meanings before making them pure break chars")
+         (SETBRK BREAKS NIL TBL)
+         (SETSYNTAX (CHARCODE %%)
+                'OTHER TBL)                                  (* ; "No escape char")
+         (READTABLEPROP TBL 'NAME "TtyinText")
+         TBL])
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(RPAQ TTYINBUFFERDEVICE (TTYINBUFFERDEVICE))
+
+(RPAQ TTYINWORDRDTBL (TTYINWORDRDTBL))
+)
+
+
+
+(* ; "Mouse handling")
+
+(DEFINEQ
+
+(DO.MOUSE
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 11:07 by jds")
+
+    (* ;; "Called when mouse is clicked down inside of our region;  performs it as an edit command, returning T, or returns NIL if it is not a legal mouse call.  The commands that actually change something display their intent while the button is down and are not actually executed until button is released.")
+
+    (COND
+       ((OR (KEYDOWNP 'LSHIFT)
+            (KEYDOWNP 'RSHIFT)
+            (KEYDOWNP 'CTRL)
+            (KEYDOWNP 'MOVE)
+            (KEYDOWNP 'COPY))
+        (DO.SHIFTED.SELECTION))
+       [(LASTMOUSESTATE (ONLY RED))                          (* ; "Position cursor")
+        (bind ROW/COL while (SETQ ROW/COL (TTRACKMOUSE ROW/COL))
+           when (LISTP ROW/COL) do (\CHECKCARET \DSP)
+                                          (MOVE.TO.LINE (CAR ROW/COL)
+                                                 (CDR ROW/COL]
+       [(LASTMOUSESTATE (ONLY YELLOW))                       (* ; "Position cursor by word")
+        (bind NEWPOS BUF COL LINE while (SETQ NEWPOS (TTRACKMOUSE NEWPOS))
+           when (LISTP NEWPOS) do (\CHECKCARET \DSP)
+                                         [SETQ BUF (BRACKET.CURRENT.WORD (SETQ LINE
+                                                                              (fetch (MOUSEPOS
+                                                                                          ROWPOS)
+                                                                                 of NEWPOS))
+                                                          (SETQ COL (fetch (MOUSEPOS COLPOS)
+                                                                       of NEWPOS]
+                                         (MOVE.TO.LINE LINE (COND
+                                                                   ((> (SEGMENT.BIT.LENGTH
+                                                                        (CAR BUF)
+                                                                        COL)
+                                                                       (SEGMENT.BIT.LENGTH
+                                                                        COL
+                                                                        (CDR BUF)))
+                                                                    (CDR BUF))
+                                                                   (T (CAR BUF]
+       ((LASTMOUSESTATE (ONLY BLUE))                         (* ; 
+                                                           "zap from cursor to mouse location.")
+        (DO.SHIFTED.SELECTION 'DELETE])
+
+(DO.SHIFTED.SELECTION
+  [LAMBDA (INITMODE)                                         (* ; "Edited 24-May-91 11:07 by jds")
+    (bind START END SAVE EXTENDING MODE NEWSTART NEWEND COL NEWROW NEWMODE BUF NEWPOS WORDLEVEL 
+           ENDLINE while (OR [SETQ NEWMODE (COND
+                                                  ((KEYDOWNP 'MOVE)
+                                                   'MOVE)
+                                                  ((KEYDOWNP 'COPY)
+                                                   'COPY)
+                                                  [(OR (KEYDOWNP 'LSHIFT)
+                                                       (KEYDOWNP 'RSHIFT))
+                                                   (COND
+                                                      ((KEYDOWNP 'CTRL)
+                                                       'MOVE)
+                                                      (T 'COPY]
+                                                  ((KEYDOWNP 'CTRL)
+                                                   'DELETE]
+                                 (LASTMOUSESTATE (NOT UP)))
+       do (SETQ NEWPOS (TTRACKMOUSE NEWPOS))
+             (\TTYBACKGROUND)                                (* ; "Flash caret")
+             (COND
+                [(LASTMOUSESTATE (OR RED YELLOW))            (* ; "Start new selection")
+                 (COND
+                    [(AND (LISTP NEWPOS)
+                          (NEQ (SETQ COL (fetch (MOUSEPOS COLPOS) of NEWPOS))
+                               \ENDBUFFER))                  (* ; "There is a selection")
+                     (SETQ NEWSTART (create MOUSEPOS using NEWPOS))
+                     (SETQ NEWROW (fetch (MOUSEPOS ROWPOS) of NEWPOS))
+                     (COND
+                        ((OR (LASTMOUSESTATE (ONLY RED))
+                             (EQ COL (fetch (LINE END) of NEWROW)))
+                                                             (* ; "Selection extends to next char")
+                         (SETQ NEWEND (TTNEXTPOS NEWROW COL))
+                         (SETQ WORDLEVEL NIL))
+                        (T                                   (* ; "Selection is current 'word'")
+                           (SETQ BUF (BRACKET.CURRENT.WORD NEWROW (fetch (MOUSEPOS COLPOS)
+                                                                         of NEWSTART)))
+                           (replace (MOUSEPOS COLPOS) of NEWSTART with (CAR BUF))
+                                                             (* ; "Start of previous word")
+                           (SETQ NEWEND (create MOUSEPOS
+                                               ROWPOS _ NEWROW
+                                               COLPOS _ (CDR BUF)))
+                           (SETQ WORDLEVEL T]
+                    (T (SETQ NEWSTART NIL)))
+                 (COND
+                    ((OR (NEQPOS START NEWSTART)
+                         (NEQPOS END NEWEND)
+                         (NEQ MODE NEWMODE))
+                     (COND
+                        (START                               (* ; "turn off old selection")
+                               (INVERT.LONG.SEGMENT START END MODE)))
+                     (COND
+                        ((SETQ START NEWSTART)
+                         (INVERT.LONG.SEGMENT START (SETQ END NEWEND)
+                                (SETQ MODE NEWMODE]
+                [(LASTMOUSESTATE (ONLY BLUE))                (* ; "Extend selection")
+                 [COND
+                    ((NOT START)                             (* ; 
+                                                           "No selection, extend from cursor")
+                     [SETQ NEWSTART (SETQ NEWEND (SETQ START
+                                                  (SETQ END (create MOUSEPOS
+                                                                   ROWPOS _ \ARROW
+                                                                   COLPOS _ \CURSOR]
+                     (SETQ WORDLEVEL (SETQ EXTENDING NIL))
+                     (COND
+                        (INITMODE (SETQ MODE INITMODE)       (* ; "E.g.  in DO.MOUSE on BLUE")
+                               (SETQ INITMODE))
+                        (T (SETQ MODE NEWMODE]
+                 (SETQ NEWROW (fetch (MOUSEPOS ROWPOS) of NEWPOS))
+                 (COND
+                    [(NLISTP NEWPOS)                         (* ; 
+                                                     "No selection;  cancel any existing extension")
+                     (COND
+                        (EXTENDING (COND
+                                      ((NEQPOS START NEWSTART)
+                                       (INVERT.LONG.SEGMENT NEWSTART START MODE)
+                                       (SETQ NEWSTART START))
+                                      ((NEQPOS END NEWEND)
+                                       (INVERT.LONG.SEGMENT END NEWEND MODE)
+                                       (SETQ NEWEND END)))
+                               (SETQ EXTENDING NIL]
+                    (T (COND
+                          ((TTBEFOREPOS NEWPOS START)    (* ; 
+                                                          "Extending to left of original selection")
+                           (COND
+                              ((AND EXTENDING (NEQPOS END NEWEND))
+                                                             (* ; 
+                                                           "We were extending to right, so switch")
+                               (INVERT.LONG.SEGMENT END NEWEND MODE)
+                               (SETQ NEWEND END)))
+                           (INVERT.LONG.SEGMENT NEWSTART (SETQ NEWSTART (create MOUSEPOS
+                                                                               using NEWPOS))
+                                  MODE))
+                          (T                                 (* ; "Extending to right")
+                             (COND
+                                ((AND EXTENDING (NEQPOS START NEWSTART))
+                                                             (* ; 
+                                                           "We were extending to left, so switch")
+                                 (INVERT.LONG.SEGMENT START NEWSTART MODE)
+                                 (SETQ NEWSTART START)))
+                             (INVERT.LONG.SEGMENT NEWEND (SETQ NEWEND (TTNEXTPOS
+                                                                           NEWROW
+                                                                           (fetch (MOUSEPOS
+                                                                                       COLPOS)
+                                                                              of NEWPOS)))
+                                    MODE)))
+                       (SETQ EXTENDING T]
+                (EXTENDING                                   (* ; 
+                                                    "End of extension, make NEWSTART/END permanent")
+                       (SETQ START NEWSTART)
+                       (SETQ END NEWEND)
+                       (SETQ EXTENDING NIL)))
+       finally (COND
+                      (START                                 (* ; "There is a selection, so do it")
+                             (\CHECKCARET \DSP)
+                             (PROG ((STARTBUF (fetch (MOUSEPOS COLPOS) of START))
+                                    (ENDBUF (fetch (MOUSEPOS COLPOS) of END)))
+                                   (COND
+                                      [(EQ MODE 'COPY)
+                                       (INVERT.LONG.SEGMENT START END MODE)
+                                                             (* ; "Take it as typein")
+                                       (COND
+                                          ((BEFOREBUF STARTBUF \CURSOR ENDBUF)
+                                                             (* ; 
+                                     "Can't just unread, because structure will change as we do so")
+                                           (READFROMBUF (COPY.SEGMENT STARTBUF ENDBUF)))
+                                          (T (READFROMBUF STARTBUF ENDBUF T]
+                                      ((AND (EQ MODE 'MOVE)
+                                            (BEFOREBUF STARTBUF \CURSOR ENDBUF))
+                                                             (* ; 
+                                         "Action overlaps cursor, so effect is just to move cursor")
+                                       (INVERT.LONG.SEGMENT START END MODE)
+                                       (MOVE.TO.LINE (fetch (MOUSEPOS ROWPOS) of END)
+                                              ENDBUF))
+                                      (T 
+
+                                 (* ;; "Delete or move selection, insert it as typein at cursor for the latter.  We save away the selection in \LAST.DELETION to be restored later if desired")
+
+                                         (SETQ SAVE (COND
+                                                       ((BEFOREBUF STARTBUF \CURSOR ENDBUF)
+                                                             (* ; 
+                                                     "The delete will move \CURSOR into trash heap")
+                                                        STARTBUF)
+                                                       (T \CURSOR)))
+                                         (SETQ \LAST.DELETION (SETQ BUF (COPY.SEGMENT STARTBUF 
+                                                                               ENDBUF)))
+                                                             (* ; "Save selection")
+                                         (DELETE.LONG.SEGMENT START END)
+                                         (MOVE.TO.WHEREVER SAVE)
+                                                             (* ; 
+                                                    "Come back to where cursor is (may have moved)")
+                                         (AND (EQ MODE 'MOVE)
+                                              (READFROMBUF BUF NIL T])
+
+(COPY.SEGMENT
+  [LAMBDA (START END)                                        (* bvm%: " 4-DEC-81 17:04")
+    (for (TAIL _ START) by (CDR TAIL) until (EQ TAIL END) collect (CAR TAIL])
+
+(DELETE.LONG.SEGMENT
+  [LAMBDA (START END)                                        (* ; "Edited 24-May-91 11:07 by jds")
+    (DELETE.LONG.SEGMENT1 (fetch (MOUSEPOS ROWPOS) of START)
+           (fetch (MOUSEPOS COLPOS) of START)
+           (fetch (MOUSEPOS ROWPOS) of END)
+           (fetch (MOUSEPOS COLPOS) of END])
+
+(DELETE.LONG.SEGMENT1
+  [LAMBDA (STARTLINE STARTCOL ENDLINE ENDCOL)                (* ; "Edited 24-May-91 10:38 by jds")
+    (PROG (FIRSTLINE NEXTLINE NROWS)
+          (COND
+             ((EQ (SETQ NROWS (IDIFFERENCE (fetch (LINE ROW) of ENDLINE)
+                                     (fetch (LINE ROW) of STARTLINE)))
+                  0)                                         (* ; "All on one line")
+              (MOVE.TO.LINE STARTLINE STARTCOL)
+              (FORWARD.DELETE.TO ENDCOL))
+             (T (MOVE.TO.LINE (SETQ FIRSTLINE (fetch (LINE NEXTLINE) of STARTLINE)))
+                (DO.DELETE.LINES NROWS)                  (* ; "Delete excess lines")
+                (SETQ NEXTLINE (fetch (LINE NEXTLINE) of ENDLINE))
+                (replace (LINE NEXTLINE) of STARTLINE with NEXTLINE)
+                (RENUMBER.LINES NEXTLINE (ADD1 (fetch (LINE ROW) of STARTLINE)))
+                [add (fetch (LINE LASTCOL) of STARTLINE)
+                       (IDIFFERENCE (SEGMENT.BIT.LENGTH ENDCOL (fetch (LINE END) of
+                                                                                         ENDLINE))
+                              (SEGMENT.BIT.LENGTH STARTCOL (fetch (LINE END) of STARTLINE
+                                                                      ]
+                (replace (LINE END) of STARTLINE with (fetch (LINE END) of 
+                                                                                              ENDLINE
+                                                                         ))
+                (COND
+                   ((EQ ENDCOL (fetch (LINE END) of STARTLINE))
+                    (replace (LINE END) of STARTLINE with STARTCOL)))
+                (KILLSEGMENT STARTCOL ENDCOL)
+                (replace (LINE NEXTLINE) of ENDLINE with NIL)
+                (KILL.LINES FIRSTLINE)
+                (MOVE.TO.LINE STARTLINE STARTCOL)
+                (ERASE.TO.END.OF.LINE)
+                (COND
+                   ((ILESSP (fetch (LINE LASTCOL) of STARTLINE)
+                           \RMARG)
+                    (TYPE.BUFFER STARTCOL (fetch (LINE END) of STARTLINE)))
+                   (T (TYPE.BUFFER STARTCOL (NTH.COLUMN.OF STARTLINE \RMARG))
+                      (ADJUSTLINE NIL STARTLINE])
+
+(INVERT.LONG.SEGMENT
+  [LAMBDA (START END MODE)                                   (* ; "Edited 24-May-91 11:07 by jds")
+    (COND
+       ((NOT (EQPOS START END))
+        (OR (TTBEFOREPOS START END)
+            (swap START END))
+        (PROG ((COL (fetch (MOUSEPOS COLPOS) of START))
+               (ROW (fetch (MOUSEPOS ROWPOS) of START)))
+              (while (NEQ ROW (fetch (MOUSEPOS ROWPOS) of END))
+                 do (INVERT.SEGMENT COL (fetch (LINE START) of (fetch
+                                                                                (LINE NEXTLINE)
+                                                                                  of ROW))
+                               ROW MODE T)
+                       (SETQ ROW (fetch (LINE NEXTLINE) of ROW))
+                       (SETQ COL (fetch (LINE START) of ROW)))
+              (INVERT.SEGMENT COL (fetch (MOUSEPOS COLPOS) of END)
+                     ROW MODE T])
+
+(INVERT.SEGMENT
+  [LAMBDA (START END LINE MODE NOSWAP)
+    (DECLARE (USEDFREE \ARROW \CHARWIDTH \LOC.ROW.0 \CHARHEIGHT \BMARG \LMARG))
+                                                             (* ; "Edited 24-May-91 10:38 by jds")
+    (COND
+       ((NEQ START END)
+        (OR LINE (SETQ LINE \ARROW))
+        (OR MODE (SETQ MODE 'DELETE))
+        (OR NOSWAP (BEFOREBUF START END (fetch (LINE END) of LINE))
+            (swap START END))
+        (PROG ((LEFT (+ (fetch (LINE FIRSTCOL) of LINE)
+                        (SEGMENT.BIT.LENGTH (fetch (LINE START) of LINE)
+                               START)))
+               (BOTTOM (+ (ITIMES (- \TTPAGELENGTH \LOC.ROW.0 (fetch (LINE ROW) of LINE)
+                                     1)
+                                 \CHARHEIGHT)
+                          \BMARG
+                          (- \DESCENT)))
+               (WIDTH (SEGMENT.BIT.LENGTH START END)))
+              (BLTSHADE (COND
+                           ((NEQ MODE 'COPY)
+                            BLACKSHADE)
+                           (T DOTSHADE))
+                     \DSP LEFT BOTTOM WIDTH (COND
+                                               ((NEQ MODE 'COPY)
+                                                \CHARHEIGHT)
+                                               (T 2))
+                     'INVERT)
+              (COND
+                 ((EQ MODE 'MOVE)
+                  (BLTSHADE DOTSHADE \DSP LEFT BOTTOM WIDTH 2 'INVERT])
+
+(BRACKET.CURRENT.WORD
+  [LAMBDA (LINE COL)                                         (* ; "Edited 24-May-91 10:38 by jds")
+
+(* ;;; "Return dotted pair of columns indicating start and end of 'word' containing buffer position COL of LINE")
+
+    (PROG ((INSPACES T)
+           (ENDLINE (fetch (LINE END) of LINE))
+           (WSTART (fetch (LINE START) of LINE))
+           FIRSTCOL LASTCOL)
+          (for (BUF _ WSTART) by (TTNEXTCHAR BUF) until (EQ BUF ENDLINE)
+             do [COND
+                       ([NEQ INSPACES (SETQ INSPACES (WORDSEPRP (FIRSTCHAR BUF]
+                                                             (* ; "Change of state")
+                        (COND
+                           (FIRSTCOL                         (* ; "Done")
+                                  (RETURN (SETQ LASTCOL BUF)))
+                           (T                                (* ; 
+                                                        "Still looking for COL, note start of word")
+                              (SETQ WSTART BUF]
+                   (COND
+                      ((EQ BUF COL)
+                       (SETQ FIRSTCOL WSTART))) finally  (* ; "Got to end before word ended")
+                                                      (SETQ LASTCOL ENDLINE)
+                                                      (OR FIRSTCOL (SETQ FIRSTCOL LASTCOL)))
+          (OR (BEFOREBUF FIRSTCOL COL LASTCOL)
+              (HELP))
+          (RETURN (CONS FIRSTCOL LASTCOL])
+
+(TTBEFOREPOS
+  [LAMBDA (X Y)                                              (* ; "Edited 24-May-91 11:08 by jds")
+    (COND
+       [(EQ (fetch (MOUSEPOS ROWPOS) of X)
+            (fetch (MOUSEPOS ROWPOS) of Y))
+        (AND (NEQ (fetch (MOUSEPOS COLPOS) of X)
+                  (fetch (MOUSEPOS COLPOS) of Y))
+             (BEFOREBUF (fetch (MOUSEPOS COLPOS) of X)
+                    (fetch (MOUSEPOS COLPOS) of Y)
+                    (fetch (LINE END) of (fetch (MOUSEPOS ROWPOS) of X]
+       (T (ILESSP (fetch (LINE ROW) of (fetch (MOUSEPOS ROWPOS) of X))
+                 (fetch (LINE ROW) of (fetch (MOUSEPOS ROWPOS) of Y])
+
+(TTNEXTPOS
+  [LAMBDA (LINE COL)                                         (* ; "Edited 24-May-91 10:38 by jds")
+
+(* ;;; "Makes a MOUSEPOS out of the position, if any, immediately after COL of LINE")
+
+    (COND
+       ((AND (EQ COL (fetch (LINE END) of LINE))
+             (NEQ COL \ENDBUFFER))
+        (create MOUSEPOS
+               ROWPOS _ (SETQ LINE (fetch (LINE NEXTLINE) of LINE))
+               COLPOS _ (fetch (LINE START) of LINE)))
+       (T (create MOUSEPOS
+                 ROWPOS _ LINE
+                 COLPOS _ (COND
+                             ((EQ COL \ENDBUFFER)
+                              COL)
+                             (T (TTNEXTCHAR COL])
+
+(TTRACKMOUSE
+  [LAMBDA (OLDROW/COL)                                       (* ; "Edited 24-May-91 11:14 by jds")
+    (DECLARE (USEDFREE \TTPAGELENGTH \LOC.ROW.0 \BMARG \CHARHEIGHT \LMARG \RMARG \FONT))
+
+    (* ;; "Follows the mouse, returning whenever its row/col changes or the user lets up the mouse buttons.  Converts mouse coordinates into a dotted pair (LINE  . BUFPOS) indicating what char is being pointed at, or T if outside range of text.  Returns NIL when user lets go.  OLDROW/COL is the previous value of this routine, which we may smash.")
+
+    (PROG (OLDX OLDY ROW COL OLDROW OLDCOL CURSORPOS)
+          [COND
+             ((LISTP OLDROW/COL)
+              (SETQ OLDROW (CAR OLDROW/COL))
+              (SETQ OLDCOL (CDR OLDROW/COL]
+      LP  (COND
+             ((MOUSESTATE UP)                                (* ; "everything up")
+              (RETURN)))
+          (SETQ CURSORPOS (CURSORPOSITION NIL \DSP CURSORPOS))
+          [COND
+             ((OR (NEQ (CAR CURSORPOS)
+                       OLDX)
+                  (NEQ (CDR CURSORPOS)
+                       OLDY))                                (* ; "Cursor moved")
+              (SETQ ROW (- \TTPAGELENGTH \LOC.ROW.0 (IQUOTIENT (- (SETQ OLDY (CDR CURSORPOS))
+                                                                  \BMARG)
+                                                           \CHARHEIGHT)
+                           1))
+              (SETQ OLDX (CAR CURSORPOS))
+              (COND
+                 [(AND (>= OLDX \LMARG)
+                       (< OLDX \RMARG)
+                       (>= ROW 0))
+                  (SETQ ROW (TTNTHLINE ROW))
+                  (SETQ COL (- OLDX (fetch (LINE FIRSTCOL) of ROW)))
+                  (SETQ COL (bind WIDTH CH (BUF _ (fetch (LINE START) of ROW))
+                                   (END _ (fetch (LINE END) of ROW))
+                               while (NEQ BUF END) do 
+                                                             (* ; 
+                  "Scan row for the specific character we're pointing at by adding widths as we go")
+                                                             [SETQ WIDTH (COND
+                                                                            ((COMPLEXCHARP
+                                                                              (SETQ CH (CAR BUF)))
+                                                                             (fetch (COMPLEXCHAR
+                                                                                         CPXWIDTH)
+                                                                                of CH))
+                                                                            (T (FCHARWIDTH CH \FONT]
+                                                             (COND
+                                                                ((< COL (LRSH WIDTH 1))
+                                                                 (RETURN BUF)))
+                                                             (SETQ COL (- COL WIDTH))
+                                                             (SETQ BUF (TTNEXTCHAR BUF))
+                               finally (RETURN BUF)))
+                  (COND
+                     ((OR (NEQ ROW OLDROW)
+                          (NEQ COL OLDCOL))                  (* ; "We moved")
+                      (RETURN (COND
+                                 ((LISTP OLDROW/COL)
+                                  (FRPLNODE OLDROW/COL ROW COL))
+                                 (T (CONS ROW COL]
+                 (T (COND
+                       ((NEQ OLDROW/COL T)
+                        (RETURN T]
+          (\TTYBACKGROUND)
+          (GO LP])
+)
+
+
+
+(* ;; 
+"Auxiliary fns.  These are outside the TTYIN block, and are provided to aid the outside world in special interfaces to TTYIN"
+)
+
+(DEFINEQ
+
+(SETREADFN
+  [LAMBDA (FLG)                                              (* bvm%: "10-MAR-83 21:46")
+    (/SETATOMVAL 'LISPXREADFN (COND
+                                 ((AND (NEQ FLG 'READ)
+                                       (OR FLG TTYINBSFLG (DISPLAYTERMP))
+                                       (FGETD 'TTYINREAD)
+                                       (DISPLAYSTARTEDP))
+                                  'TTYINREAD)
+                                 (T 'READ])
+
+(TTYINENTRYFN
+  [LAMBDA (WINDOW)                                           (* bvm%: "24-Aug-84 16:31")
+    (COND
+       ((LASTMOUSESTATE (ONLY RIGHT))
+        (PROG [(STATE (WINDOWPROP WINDOW 'TTYINSTATE]
+              (APPLY* (OR (AND STATE (fetch (TTYINWINDOWSTATE TTOLDRIGHTFN) of STATE))
+                          (FUNCTION DOWINDOWCOM))
+                     WINDOW)))
+       (T (GIVE.TTY.PROCESS WINDOW])
+
+(TTYINREADP
+  [LAMBDA (FLG)                                              (* ; "Edited 14-Apr-87 00:25 by bvm:")
+
+(* ;;; "Intended to replace LISPXREADP.  Does the right thing when READBUF has just a <cr> in it")
+
+    (COND
+       (READBUF (OR (NEQ (CAR READBUF)
+                         HISTSTR0)
+                    FLG))
+       ((NOT (LINEBUFFER-EOFP \LINEBUF.OFD))
+        (OR FLG (NEQ (PEEKBINCCODE \LINEBUF.OFD)
+                     (CHARCODE EOL])
+
+(TTYINREAD
+  [LAMBDA (FILE RDTBL)                                       (* ; "Edited 10-Dec-87 17:57 by raf")
+    (COND
+       ([OR (AND TTYINDEBUGFLG \INSIDE.TTYIN)
+            (NOT (DISPLAYSTREAMP (GETSTREAM T 'OUTPUT]       (* ; 
+                                                 "If debugging and TTYIN breaks, don't want to die")
+        (READ FILE RDTBL))
+       (T (PROG (X)
+                (RETURN (COND
+                           ((OR (LINEBUFFER-SKIPSEPRS \LINEBUF.OFD RDTBL)
+                                (EQ (SETQ X (TTYIN LISPXID NIL NIL '(EVALQT FILLBUFFER 
+                                                                                   NOPROMPT)
+                                                   NIL NIL NIL RDTBL))
+                                    T))                      (* ; 
+                              "Don't call TTYIN if there's something significant already in buffer")
+
+                            (* ;; "SKIPSEPRS used to be (do (COND ((EOFP \LINEBUF.OFD) (* Nothing in buffer) (RETURN)) ((NEQ (PEEKBINCCODE \LINEBUF.OFD) (CHARCODE EOL)) (* significant stuff) (RETURN T)) (T (BINCCODE \LINEBUF.OFD))))")
+
+                            (READ \LINEBUF.OFD RDTBL))
+                           (T                                (* ; "indicate null input")
+                              (SETQ READBUF (NCONC1 (CDR X)
+                                                   HISTSTR0))
+                              (CAR X])
+
+(TTYINFIX
+  [LAMBDA (INPUT COMS)                                       (* ; "Edited 20-Jan-88 12:13 by bvm")
+    (LET (TAIL)
+         (COND
+            ([OR COMS (NEQ LISPXREADFN 'TTYINREAD)
+                 (>= (COUNT INPUT)
+                     TTYINFIXLIMIT)
+                 (CDR (SETQ TAIL (MEMB HISTSTR0 INPUT]
+             (NONTTYINLISPXFIX INPUT COMS))
+            (T (TTYIN LISPXID NIL NIL (COND
+                                                 ((for X
+                                                     in [COND
+                                                               ((EQ TAIL (CDR INPUT))
+                                                                (CAR INPUT))
+                                                               (T (OR (LISTP (CADR INPUT))
+                                                                      (CDR INPUT]
+                                                     thereis (LISTP X))
+                                                             (* ; "Something worth prettyprinting")
+                                                  '(PRETTY EVALQT))
+                                                 (T 'EVALQT))
+                      NIL NIL INPUT T])
+
+(CHARMACRO?
+  [NLAMBDA (MACRO)
+    (DECLARE (USEDFREE \READING LISPXID))                (* bvm%: "19-MAR-81 12:15")
+
+(* ;;; "For use in a TTYINREADMACRO.  If we are reading inside the editor, clear the output buffer and return MACRO")
+
+    (COND
+       ((AND (EQ \READING 'EVALQT)
+             (EQ LISPXID '*))
+        (COND
+           ((LISTP MACRO)                                    (* ; 
+                                                       "a list of edit commands;  we'd better copy")
+            (APPEND MACRO))
+           (T MACRO])
+
+(TTYINMETA
+  [LAMBDA (FLG)                                              (* bvm%: " 2-May-85 14:27")
+    (METASHIFT FLG])
+
+(TTYIN.LASTINPUT
+  [LAMBDA NIL                                              (* ; "Edited 24-May-91 10:44 by jds")
+    (PROG [(BUF (AND (LISTP TTYINBUFFER)
+                     (fetch (TTYINBUFFER OLDTAIL) of TTYINBUFFER]
+          (RETURN (AND BUF (TTYINSTRING (fetch (LINE START) of (fetch (TTYINBUFFER
+                                                                                       FIRSTLINE)
+                                                                              of TTYINBUFFER))
+                                  BUF])
+)
+(DEFINEQ
+
+(TTYINEDIT
+  [LAMBDA (EXPRS WINDOW PRINTFN PROMPT RDTBL)                (* ; "Edited 19-Jan-88 17:13 by bvm")
+    (OR PRINTFN (SETQ PRINTFN TTYINPRINTFN))
+    (RESETLST
+        (SET.TTYINEDIT.WINDOW WINDOW)
+        (RESETSAVE (CURSOR T))                               (* ; 
+                                                        "Make sure we have something to point with")
+        (WITH-RESOURCES (TTSCRATCHFILE)
+               (PROG1 (TTYIN (OR PROMPT TTYINEDITPROMPT)
+                             NIL NIL 'LISPXREAD NIL NIL
+                             [COND
+                                ([OR (EQ PRINTFN T)
+                                     (AND (NULL PRINTFN)
+                                          (NULL (CDR EXPRS))
+                                          (STRINGP (CAR EXPRS]
+                                                             (* ; "Don't prettyprint it")
+                                 EXPRS)
+                                (T (LIST HISTSTR1 (LET* ((\DSP (GETSTREAM WINDOW))
+                                                         (\INITPOS (DSPXPOSITION NIL \DSP))
+                                                         (\RMARG (DSPRIGHTMARGIN NIL \DSP))
+                                                         (\PROMPT1 (OR PROMPT TTYINEDITPROMPT)))
+                                                             (* ; 
+                        "Set up these vars for TTYIN.PPTOFILE to understand the environment better")
+                                                        (if (EQ \PROMPT1 T)
+                                                            then (SETQ \PROMPT1 NIL))
+                                                        (TTYIN.PPTOFILE EXPRS PRINTFN RDTBL 
+                                                               TTSCRATCHFILE]
+                             RDTBL)
+                   (COND
+                      ((AND TTYINAUTOCLOSEFLG WINDOW)
+                       (CLOSEW WINDOW)))
+                   (SETFILEPTR TTSCRATCHFILE 0))))])
+
+(SIMPLETEXTEDIT
+  [LAMBDA (FILE WINDOW)                                      (* ; "Edited 17-Jan-88 15:29 by bvm:")
+    (RESETLST
+        [WITH-RESOURCES (TTSCRATCHFILE)
+               (LET (INSTREAM MAINOUTPUT)
+                    (SET.TTYINEDIT.WINDOW WINDOW)
+                    (COND
+                       ([TTYIN TTYINEDITPROMPT NIL NIL '(TEXT NOVALUE)
+                               TTSCRATCHFILE NIL (COND
+                                                      (FILE  (* ; "User specified a file to edit")
+                                                            [RESETSAVE NIL
+                                                                   (LIST 'CLOSEF
+                                                                         (SETQ INSTREAM
+                                                                          (OPENSTREAM FILE
+                                                                                 'INPUT]
+                                                            `(,HISTSTR1 (,INSTREAM
+                                                                         0
+                                                                         ,@(GETEOFPTR INSTREAM]
+                        (repeatuntil [AND [SETQ MAINOUTPUT (COND
+                                                                  (INSTREAM
+                                                             (* ; 
+                                                           "Default output to new version of input")
+                                                                   (PROG1 (PACKFILENAME.STRING
+                                                                           'VERSION NIL
+                                                                           'BODY INSTREAM)
+                                                                          (SETQ INSTREAM)))
+                                                                  [(TTYIN "Output file: " NIL 
+                                                                     "Name of file for edited output"
+                                                                          '(NORAISE STRING]
+                                                                  ((LISP:Y-OR-N-P "Abort edit? ")
+                                                             (* ; 
+                                                          "Really didn't want to write it anywhere")
+                                                                   (RETURN NIL]
+                                              (NLSETQ (SETQ MAINOUTPUT (OPENSTREAM MAINOUTPUT
+                                                                              'OUTPUT]
+                           finally                       (* ; 
+                                                       "Copy from scratch file to real output file")
+                                 (COPYBYTES TTSCRATCHFILE MAINOUTPUT 0 (GETFILEPTR TTSCRATCHFILE))
+                                 (SETFILEPTR TTSCRATCHFILE 0) 
+                                                             (* ; 
+                                                           "Leave scratch file in good shape")
+                                 (RETURN (CLOSEF MAINOUTPUT])])
+
+(SET.TTYINEDIT.WINDOW
+  [LAMBDA (WINDOW)                                           (* lmm "14-Nov-86 17:04")
+
+    (* ;; "Changes output to WINDOW, or the TTYIN edit window, returning the resulting WINDOW, or NIL if there is no window change.  Caller must have RESETLST")
+
+    (COND
+       ((EQ WINDOW T)                                        (* ; "Use current window")
+        NIL)
+       (T [OR WINDOW (SETQ WINDOW (OR TTYINEDITWINDOW (SETQ TTYINEDITWINDOW (CREATEW NIL 
+                                                                                   "Edit Work Area"]
+          (CLEARW WINDOW)
+          [PROG [(OFFSET (IREMAINDER (WINDOWPROP WINDOW 'HEIGHT)
+                                (IMINUS (DSPLINEFEED NIL WINDOW]
+                (COND
+                   ((NEQ OFFSET 0)
+
+                    (* ;; "Window is not an integral number of lines, so start down a little, so that bottom line will be correctly aligned (we count from bottom of screen)")
+
+                    (RELMOVETO 0 (IMINUS OFFSET)
+                           WINDOW]
+          (RESETSAVE (TTYDISPLAYSTREAM WINDOW))
+          WINDOW])
+
+(TTYIN.PPTOFILE
+  [LAMBDA (EXPRS PRINTFN RDTBL STREAM)                       (* ; "Edited 19-Jan-88 17:19 by bvm")
+
+(* ;;; "Prettyprint each of EXPRS to a scratch file, returning (scratchfile start  . end), as TTYIN would like.  If STREAM is supplied, it is a scratch stream")
+
+    (LET ([*STANDARD-OUTPUT* (OR STREAM (OPENSTREAM '{NODIRCORE} 'BOTH]
+          (*READTABLE* (\GTREADTABLE RDTBL T))
+          (*PRINT-ARRAY* T)
+          (*PRINT-STRUCTURE* T)
+          (FONTCHANGEFLG NIL))
+         (DECLARE (LISP:SPECIAL FONTCHANGEFLG))          (* ; "The others already are")
+         (SETFILEPTR *STANDARD-OUTPUT* 0)
+         (LINELENGTH (- (IQUOTIENT (- \RMARG \INITPOS)
+                               (CHARWIDTH (CHARCODE X)
+                                      \DSP))
+                        (if \PROMPT1
+                            then (NCHARS \PROMPT1)
+                          else 0))
+                *STANDARD-OUTPUT*)                           (* ; 
+      "Prettyprint to a linelength that accounts for available space, excluding margins and prompt")
+         (COND
+            ((AND PRINTFN (NEQ PRINTFN 'PRETTY))
+             (LISP:FUNCALL (COND
+                              ((EQ PRINTFN T)
+                               'PRINT)
+                              (T PRINTFN))
+                    EXPRS *STANDARD-OUTPUT*))
+            ((AND (CDR EXPRS)
+                  (NLISTP (CAR EXPRS)))                      (* ; 
+                                "Be careful not to separate exec command or apply fn from its args")
+             (PRIN2 (CAR EXPRS)
+                    *STANDARD-OUTPUT*)
+             (SPACES 1 *STANDARD-OUTPUT*)
+             (PRINTDEF (CDR EXPRS)
+                    (POSITION)
+                    T T NIL *STANDARD-OUTPUT*))
+            (T (PRINTDEF EXPRS NIL T T NIL *STANDARD-OUTPUT*)))
+         (CONS *STANDARD-OUTPUT* (CONS 0 (GETFILEPTR *STANDARD-OUTPUT*])
+)
+
+
+
+(* ; "New, correct way of getting scratch file")
+
+(DEFINEQ
+
+(MAKE-TTSCRATCHFILE
+  [LAMBDA NIL                                              (* ; "Edited 17-Jan-88 15:16 by bvm:")
+    (OPENSTREAM '{NODIRCORE} 'BOTH])
+)
+(DECLARE%: EVAL@COMPILE 
+
+[PUTDEF 'TTSCRATCHFILE 'RESOURCES '(NEW (MAKE-TTSCRATCHFILE]
+)
+
+
+
+(* ; "Obsolete, but maybe someone calls it")
+
+(DEFINEQ
+
+(TTYIN.SCRATCHFILE
+  [LAMBDA NIL
+    (DECLARE (GLOBALVARS TTYINEDIT.SCRATCH))             (* lmm "14-Nov-86 17:05")
+    [COND
+       ([OR (NOT TTYINEDIT.SCRATCH)
+            (NOT (OPENP TTYINEDIT.SCRATCH 'BOTH]
+        (SETQ TTYINEDIT.SCRATCH (OPENSTREAM '{NODIRCORE} 'BOTH 'OLD/NEW NIL
+                                       (CONSTANT (LIST (LIST 'ENDOFSTREAMOP (FUNCTION \TTYIN.RPEOF]
+    (SETFILEPTR TTYINEDIT.SCRATCH 0)
+    TTYINEDIT.SCRATCH])
+
+(\TTYIN.RPEOF
+  [LAMBDA (STREAM)                                           (* lmm "14-Nov-86 17:06")
+                                                             (* ; 
+             "End of stream op for ttyin scratch file -- supplies as many closing parens as needed")
+    (CHARCODE ")"])
+)
+
+(RPAQ? TTYINEDIT.SCRATCH )
+
+(RPAQ? TTYINEDITWINDOW )
+
+(RPAQ? TTYINEDITPROMPT T)
+
+(RPAQ? TTYINAUTOCLOSEFLG )
+
+(RPAQ? TTYINPRINTFN )
+
+(RPAQ? TTYIN?=FN )
+
+
+
+(* ; "Kludge of the week")
+
+(DEFINEQ
+
+(TTYINPROMPTFORWORD
+  [LAMBDA (PROMPT.STR CANDIDATE.STR GENERATE?LIST.FN ECHO.CHANNEL DONTECHOTYPEIN.FLG URGENCY.OPTION 
+                 TERMINCHARS.LST KEYBD.CHANNEL)              (* ; "Edited  8-Feb-88 14:26 by bvm:")
+
+    (* ;; "Attempt at a plug-compatible replacement for common cases of PROMPTFORWORD -- lets you use your mouse and other editing commands.")
+
+    (LET ((TYPE 'PROMPTFORWORD))                             (* ; 
+                                                           "Default uses space or cr to terminate")
+         (if [OR DONTECHOTYPEIN.FLG KEYBD.CHANNEL
+                     [if (NULL TERMINCHARS.LST)
+                         then (SETQ TYPE 'PROMPTFORWORD-SPACE) 
+                                                             (* ; "Default is CR SPACE")
+                               NIL
+                       else (for C in TERMINCHARS.LST
+                                   do (SELCHARQ C
+                                               (SPACE (SETQ TYPE 'PROMPTFORWORD-SPACE))
+                                               ((CR ^X)      (* ; "ok, ttyin uses these by default")
+                                                    )
+                                               (if TTYIN.USE.EXACT.CHARS
+                                                   then  (* ; "A terminator we can't handle")
+                                                         (RETURN T]
+                     (AND ECHO.CHANNEL (NOT (DISPLAYSTREAMP (SETQ ECHO.CHANNEL (GETSTREAM
+                                                                                ECHO.CHANNEL
+                                                                                'OUTPUT]
+             then                                        (* ; "Sorry, can't help")
+                   (NON-TTYIN-PROMPTFORWORD PROMPT.STR CANDIDATE.STR GENERATE?LIST.FN ECHO.CHANNEL 
+                          DONTECHOTYPEIN.FLG URGENCY.OPTION TERMINCHARS.LST KEYBD.CHANNEL)
+           else (RESETLST
+                        [if (AND (EQ URGENCY.OPTION 'TTY)
+                                     (NOT (TTY.PROCESSP)))
+                            then                         (* ; "Caller wants to grab tty")
+                                  (RESETSAVE (TTY.PROCESS (THIS.PROCESS]
+                        (if (AND ECHO.CHANNEL (NEQ ECHO.CHANNEL (TTYDISPLAYSTREAM)))
+                            then (RESETSAVE (TTYDISPLAYSTREAM ECHO.CHANNEL)))
+                        (TTYIN (COND
+                                      ((NOT PROMPT.STR)
+                                       T)
+                                      ((EQ (NTHCHARCODE PROMPT.STR -1)
+                                           (CHARCODE SPACE))
+                                       PROMPT.STR)
+                                      (T                     (* ; 
+                                                           "Promptforword spaces after prompt")
+                                         (CONCAT PROMPT.STR " ")))
+                               NIL
+                               (STRINGP GENERATE?LIST.FN)
+                               TYPE NIL NIL (if (FIXP CANDIDATE.STR)
+                                                    then (* ; 
+               "Coerce integer to string, or otherwise ttyin will interpret it as a character code")
+                                                          (MKSTRING CANDIDATE.STR)
+                                                  else CANDIDATE.STR)))])
+)
+
+(RPAQ? TTYIN.USE.EXACT.CHARS )
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(MOVD? 'PROMPTFORWORD 'NON-TTYIN-PROMPTFORWORD NIL T)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY 
+
+(RPAQQ TTCOMPILETIME
+       [(VARS TTYINBLOCKS)
+        (LOCALVARS . T)
+        (SPECVARS HELP RDTBL SPLST TABS OPTIONS ECHOTOFILE \ARROW \AUTOFILL \BMARG \BUFFER 
+               \CHARHEIGHT \CHARWIDTH \COMMAND \CURSOR \CURSORCOL \CURSORROW \DELETING \DESCENT 
+               \ENDBUFFER \FIRSTLINE \FIX \HOMECOL \HOMEROW \INITPOS \LASTAIL \LASTCHAR \LMARG 
+               \LOC.ROW.0 \NOFIXSPELL \PROMPT1 \PROMPT2 \READING \REPEAT \RMARG \INSIDE.TTYIN 
+               \TTYINSTATE \TTPAGELENGTH \RAISEINPUT \FIRSTTIME \DONTCOMPLETE \NOVALUE \STRINGVALUE 
+               \LISPXREADING \FILLINGBUFFER \RDTBLSA \LAST.DELETION \FONT \TEXTURE \LASTAILROW 
+               \LASTAILCOL \TTYINBUFFERSTREAM \PROMPTFORWORD \PFW.FIRSTTIME \DSP \INITCRLFS 
+               \COMMENTFONT)
+        (GLOBALVARS ?ACTIVATEFLG CTRLUFLG CTRLVFLG EDITPREFIXCHAR EOLCHARCODE HISTSTR0 HISTSTR1 
+               SPELLSTR1 LASTMOUSEBUTTONS LASTWORD LISPXREADFN SHOWPARENFLG SPELLSTR1 SPELLSTR2 
+               TTYINAUTOCLOSEFLG TTYINBSFLG TTYINBUFFER TTYINCOMMENTCHAR TTYINCOMPLETEFLG 
+               TTYINEDITPROMPT TTYINEDITWINDOW TTYINERRORSETFLG TTYINRAISEFLG TTYINREADMACROS 
+               TTYINRESPONSES TTYINUSERFN TTYJUSTLENGTH TYPEAHEADFLG USERWORDS null 
+               TTYINAUTOFILLMARGIN TTYINPRINTFN TTYIN?=FN TTYINFIXLIMIT TTYINDEBUGFLG 
+               DORADO.RESTORE.BUF.CODES TTYIN.RESTORE.BUF.CODES \RESTOREBUFCODES)
+        (MACROS * TTYINMACROS)
+        (RECORDS LINE TTYINBUFFER TTYINWINDOWSTATE MOUSEPOS COMPLEXCHAR TTYINBUFFERSTREAM)
+        (VARS DMCHARCODES TTSUPPORTFNS)
+        (ADDVARS (DONTCOMPILEFNS DELETETO1))
+        (CONSTANTS (DISPLAYTERMFLG T)
+               (TTYINMAILFLG)
+               (DIDESCAPECODE 283)
+               DOTSHADE)
+        (VARS TTNILFNS)
+        (MACROS * TTNILFNS)
+        (DECLARE%: DONTEVAL@COMPILE (TEMPLATES TTBOUT TTBOUTN)
+               DONTEVAL@LOAD EVAL@COMPILE (VARS (DONTCOMPILEFNS (UNION (UNION TTYINMACROS 
+                                                                              TTSUPPORTFNS)
+                                                                       DONTCOMPILEFNS])
+
+(RPAQQ TTYINBLOCKS
+       ((TTYIN TTYIN TTBIN TTCRLF TTCRLF.ACCOUNT SCANFORWARD TTNLEFT TTNTH TTPRIN1 TTPROMPTCHAR 
+               TTRATOM TTREAD TTREADLIST TTSKIPSEPR TTSKREAD TTYINSTRING ADDCHAR ADDNAKEDCHAR AUTOCR?
+               BACKWARD.DELETE.TO BEEP BUFTAILP CLEAR.LINE? CREATE.LINE DELETE.TO.END DELETETO 
+               DELETETO1 DELNCHARS TTECHO.TO.FILE END.DELETE.MODE ENDREAD? AT.END.OF.TEXT 
+               FIND.START.OF.WORD TTADJUSTWORD FORWARD.DELETE.TO GO.TO.RELATIVE GO.TO.ADDRESSING 
+               GO.TO.FREELINE INIT.CURSOR INSERT.CHAR.IN.BUF ADDCHARS.INSERTING INSERT.NODE TTRUBOUT
+               KILL.LINES KILLSEGMENT MOVE.BACK.TO MOVE.FORWARD.TO MOVE.TO.NEXT.LINE START.NEW.LINE 
+               TTNEXTCHAR TTNEXTNODE OVERFLOW? PROPERTAILP RESTORE.CURSOR SAVE.CURSOR SCRATCHCONS 
+               SETLASTC SETTAIL? SPACE/PARENP DO.EDIT.COMMAND ADDSILENTCHAR TTADDTAB AT.END.OF.SCREEN
+               SCANBACK BACKSKREAD BREAKLINE SEGMENT.LENGTH CHECK.MARGIN TTCOMPLETEWORD 
+               FIND.MATCHING.WORD NTHCHARCODE DELETELINE DO?CMD TTDOTABS EDITCOLUMN FIND.LINE 
+               FIND.LINE.BREAK ADJUSTLINE START.OF.PARAGRAPH? ADJUSTLINE.AND.RESTORE TTGIVEHELP 
+               TTGIVEHELP1 TTGIVEHELP2 INSERTLINE TTLASTLINE TTLOADBUF MOVE.TO.LINE 
+               MOVE.TO.START.OF.WORD MOVE.TO.WHEREVER TTNEXTLINE FIND.MATCHING.QUOTE FIND.NEXT.WORD 
+               NTH.COLUMN.OF NTH.RELATIVE.COLUMN.OF OVERFLOWLINE? PREVLINE PREVWORD READFROMBUF 
+               RENUMBER.LINES RESTOREBUF RETYPE.BUFFER SHOW.MATCHING.PAREN SKIP/ZAP SLEEP 
+               CURRENT.WORD TYPE.BUFFER U/L-CASE TTUNREADBUF DO.BACK DO.DELETE.LINES DO.DOWN 
+               DO.FORWARD DO.INSERT.LINE DO.UP ERASE.SCREEN ERASE.TO.END.OF.LINE ERASE.TO.END.OF.PAGE
+               INSERT.TEXT INSERTNCHARS TTSETCURSOR
+               (LOCALFREEVARS ARROW AUTOFILL BUFFER COMMAND CURSOR DELETING EDITBIT ENDBUFFER INITPOS
+                      INSERTING NOFIXSPELL READING REPEAT)
+               (SPECVARS CTRLO!)
+               (LINKFNS . T)
+               (NOLINKFNS DISPLAYHELP DISPLAYTERMP EDITE ERROR! FIXSPELL!! GRIPE GUESTUSER? MAILWATCH
+                      MWNOTE SETBACKSPACE SHOULDNT SMARTARGLIST SPRINTT STKEVAL STRPOS USEREXEC 
+                      XHELPSYS)
+               (BLKLIBRARY NLEFT))
+        (NIL TTYINREAD (LOCALVARS . T)
+               (LINKFNS TTYIN))
+        (NIL DISPLAYTERMP SETREADFN TTECHOMODE TTED TTYINPEEKC TTYINREADP TTYINREADPREP CHARMACRO?
+               (LOCALVARS . T))))
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(SPECVARS HELP RDTBL SPLST TABS OPTIONS ECHOTOFILE \ARROW \AUTOFILL \BMARG \BUFFER \CHARHEIGHT 
+       \CHARWIDTH \COMMAND \CURSOR \CURSORCOL \CURSORROW \DELETING \DESCENT \ENDBUFFER \FIRSTLINE 
+       \FIX \HOMECOL \HOMEROW \INITPOS \LASTAIL \LASTCHAR \LMARG \LOC.ROW.0 \NOFIXSPELL \PROMPT1 
+       \PROMPT2 \READING \REPEAT \RMARG \INSIDE.TTYIN \TTYINSTATE \TTPAGELENGTH \RAISEINPUT 
+       \FIRSTTIME \DONTCOMPLETE \NOVALUE \STRINGVALUE \LISPXREADING \FILLINGBUFFER \RDTBLSA 
+       \LAST.DELETION \FONT \TEXTURE \LASTAILROW \LASTAILCOL \TTYINBUFFERSTREAM \PROMPTFORWORD 
+       \PFW.FIRSTTIME \DSP \INITCRLFS \COMMENTFONT)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS ?ACTIVATEFLG CTRLUFLG CTRLVFLG EDITPREFIXCHAR EOLCHARCODE HISTSTR0 HISTSTR1 SPELLSTR1 
+       LASTMOUSEBUTTONS LASTWORD LISPXREADFN SHOWPARENFLG SPELLSTR1 SPELLSTR2 TTYINAUTOCLOSEFLG 
+       TTYINBSFLG TTYINBUFFER TTYINCOMMENTCHAR TTYINCOMPLETEFLG TTYINEDITPROMPT TTYINEDITWINDOW 
+       TTYINERRORSETFLG TTYINRAISEFLG TTYINREADMACROS TTYINRESPONSES TTYINUSERFN TTYJUSTLENGTH 
+       TYPEAHEADFLG USERWORDS null TTYINAUTOFILLMARGIN TTYINPRINTFN TTYIN?=FN TTYINFIXLIMIT 
+       TTYINDEBUGFLG DORADO.RESTORE.BUF.CODES TTYIN.RESTORE.BUF.CODES \RESTOREBUFCODES)
+)
+
+(RPAQQ TTYINMACROS (TYPEAHEAD? AT.END.OF.BUF AT.END.OF.LINE AT.START.OF.BUF AT.START.OF.LINE 
+                              BEFOREBUF BREAK.OR.SEPRP DISPLAYTERMP EMPTY.BUFFER EMPTY.LINE EQPOS 
+                              NEQPOS INPART ON.FIRST.LINE ON.LAST.LINE METACHARP NONMETACHARBITS 
+                              METACHAR COMPLEXCHARP STREAMBYTESPERCHAR SPACEP TTBOUT TTNEXTCHAR 
+                              BOUTCCODE PEEKBINCCODE BINCCODE WORDSEPRP FCHARWIDTH FIRSTCHAR))
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS TYPEAHEAD? MACRO (NIL (\SYSBUFP)))
+
+(PUTPROPS AT.END.OF.BUF MACRO (NIL (EQ \CURSOR \ENDBUFFER)))
+
+(PUTPROPS AT.END.OF.LINE MACRO (NIL (EQ (fetch END of \ARROW)
+                                                  \CURSOR)))
+
+(PUTPROPS AT.START.OF.BUF MACRO (NIL (EQ \CURSOR \BUFFER)))
+
+(PUTPROPS AT.START.OF.LINE MACRO (NIL (EQ (fetch START of \ARROW)
+                                                    \CURSOR)))
+
+(PUTPROPS BEFOREBUF MACRO ((THIS THAT END)
+                                   (BUFTAILP THAT THIS END)))
+
+(PUTPROPS BREAK.OR.SEPRP MACRO ((C)
+                                        (fetch STOPATOM of (\SYNCODE \RDTBLSA C))))
+
+(PUTPROPS DISPLAYTERMP ALTOMACRO (NIL T))
+
+(PUTPROPS EMPTY.BUFFER MACRO (NIL (EQ \BUFFER \ENDBUFFER)))
+
+(PUTPROPS EMPTY.LINE MACRO [X (SUBST (OR (CAR X)
+                                                 '\ARROW)
+                                             '\ARROW
+                                             '(EQ (fetch START of \ARROW)
+                                                  (fetch END of \ARROW])
+
+(PUTPROPS EQPOS MACRO [(X Y)
+                               (AND (EQ (fetch COLPOS of X)
+                                        (fetch COLPOS of Y))
+                                    (EQ (fetch ROWPOS of X)
+                                        (fetch ROWPOS of Y])
+
+(PUTPROPS NEQPOS MACRO ((X Y)
+                                (NOT (EQPOS X Y))))
+
+(PUTPROPS INPART MACRO (OPENLAMBDA (X)
+                                      (COND
+                                         ((LISTP X)
+                                          (CAR X))
+                                         (T X))))
+
+(PUTPROPS ON.FIRST.LINE MACRO (NIL (EQ \FIRSTLINE \ARROW)))
+
+(PUTPROPS ON.LAST.LINE MACRO (NIL (EQ (fetch END of \ARROW)
+                                                \ENDBUFFER)))
+
+(PUTPROPS METACHARP MACRO ((C)
+                                   (EQ (LRSH C 8)
+                                       1)))
+
+(PUTPROPS NONMETACHARBITS MACRO ((C)
+                                         (LOGAND C 255)))
+
+(PUTPROPS METACHAR MACRO ((C)
+                                  (LOGOR C 256)))
+
+(PUTPROPS COMPLEXCHARP MACRO (= . LISTP))
+
+(PUTPROPS STREAMBYTESPERCHAR MACRO ((STREAM)
+                                            (COND
+                                               ((\RUNCODED STREAM)
+                                                1)
+                                               (T 2))))
+
+(PUTPROPS SPACEP MACRO [(CHAR)
+                                (FMEMB CHAR (CHARCODE (SPACE TAB CR])
+
+(PUTPROPS TTBOUT MACRO [X (CONS 'PROGN (for ARG in X
+                                                  collect
+                                                  (LIST 'BLTCHAR (OR (FIXP ARG)
+                                                                     (CDR (ASSOC ARG DMCHARCODES))
+                                                                     (AND (EQ (NCHARS ARG)
+                                                                              1)
+                                                                          (CHCON1 ARG))
+                                                                     ARG)
+                                                        '(TTYDISPLAYSTREAM])
+
+(PUTPROPS TTNEXTCHAR MACRO (= . CDR))
+
+(PUTPROPS BOUTCCODE MACRO (OPENLAMBDA (STREAM CHAR)
+                                         (PRINTCCODE CHAR STREAM)))
+
+(PUTPROPS PEEKBINCCODE MACRO (= . PEEKCCODE))
+
+(PUTPROPS BINCCODE MACRO (= . READCCODE))
+
+(PUTPROPS WORDSEPRP DMACRO [OPENLAMBDA (X)
+                                          (OR (EQ (\SYNCODE \PRIMTERMSA X)
+                                                  WORDSEPR.TC)
+                                              (fetch STOPATOM of (\SYNCODE \RDTBLSA X])
+
+(PUTPROPS FCHARWIDTH MACRO (= . CHARWIDTH))
+
+(PUTPROPS FIRSTCHAR MACRO ((BUF)
+                                   ([LAMBDA (CH)
+                                      (DECLARE (LOCALVARS CH))
+                                      (COND
+                                         ((COMPLEXCHARP CH)
+                                          (fetch CPXREALCHAR of CH))
+                                         (T CH]
+                                    (CAR BUF))))
+)
+(DECLARE%: EVAL@COMPILE
+
+(RECORD LINE (START END FIRSTCOL LASTCOL ROW . NEXTLINE))
+
+(RECORD TTYINBUFFER (FIRSTLINE OLDTAIL LASTSKIP LASTSKIPCHAR STORAGECOUNTER TTYINWINDOW
+                                                                                  . TTYINWINDOWSTATE)
+                        (SUBRECORD TTYINWINDOWSTATE)
+                        STORAGECOUNTER _ 0)
+
+(RECORD TTYINWINDOWSTATE (TTOLDBUTTONFN TTOLDRIGHTFN TTOLDENTRYFN))
+
+(RECORD MOUSEPOS (ROWPOS . COLPOS))
+
+(RECORD COMPLEXCHAR (CPXREALCHAR CPXWIDTH CPXNCHARS . CPXPRINTCHARS))
+
+(ACCESSFNS TTYINBUFFERSTREAM ((TTYINPUT (fetch (STREAM F1) of DATUM)
+                                         (replace (STREAM F1) of DATUM with NEWVALUE))
+                                  (TTYEOF (fetch (STREAM F2) of DATUM)
+                                         (replace (STREAM F2) of DATUM with NEWVALUE))
+                                  (TTYEOFACTION (fetch (STREAM F3) of DATUM)
+                                         (replace (STREAM F3) of DATUM with NEWVALUE))
+                                  (TTYORIGINPUT (fetch (STREAM F4) of DATUM)
+                                         (replace (STREAM F4) of DATUM with NEWVALUE))))
+)
+
+(RPAQQ DMCHARCODES
+       ((HOME . 2)
+        (BELL . 7)
+        (DELCH . 8)
+        (BS . 8)
+        (DOWN . 10)
+        (INSERT.LINE . 10)
+        (LF . 10)
+        (ADDR . 12)
+        (CR . 13)
+        (BLINKON . 14)
+        (INSERT/DELETE . 16)
+        (DLE . 16)
+        (ERASE.TO.END . 23)
+        (CANCEL . 24)
+        (UP . 26)
+        (DELETE.LINE . 26)
+        (ESC . 27)
+        (FORWARD . 28)
+        (ROLL . 29)
+        (ERASE . 30)
+        (CLEAR . 30)
+        (US . 31)
+        (SPACE . 32)))
+
+(RPAQQ TTSUPPORTFNS NIL)
+
+(ADDTOVAR DONTCOMPILEFNS DELETETO1)
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ DISPLAYTERMFLG T)
+
+(RPAQQ TTYINMAILFLG NIL)
+
+(RPAQQ DIDESCAPECODE 283)
+
+(RPAQQ DOTSHADE 13260)
+
+
+(CONSTANTS (DISPLAYTERMFLG T)
+       (TTYINMAILFLG)
+       (DIDESCAPECODE 283)
+       DOTSHADE)
+)
+
+(RPAQQ TTNILFNS (BINARY.MODE RESTOREMOD CANCEL.MODES GUESTUSER?))
+
+(RPAQQ TTNILFNS (BINARY.MODE RESTOREMOD CANCEL.MODES GUESTUSER?))
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS BINARY.MODE MACRO (NIL NIL))
+
+(PUTPROPS RESTOREMOD MACRO (NIL NIL))
+
+(PUTPROPS CANCEL.MODES MACRO (NIL NIL))
+
+(PUTPROPS GUESTUSER? MACRO (NIL NIL))
+)
+(DECLARE%: DONTEVAL@COMPILE 
+
+[SETTEMPLATE 'TTBOUT '(CALL |..| (IF [OR (LISTP EXPR)
+                                             (AND (NTHCHAR EXPR 2)
+                                                  (NOT (ASSOC EXPR DMCHARCODES]
+                                        EVAL NIL]
+
+[SETTEMPLATE 'TTBOUTN '(MACRO (X . Y)
+                              (FRPTQ X (TTBOUT . Y]
+DONTEVAL@LOAD EVAL@COMPILE 
+
+(RPAQ DONTCOMPILEFNS (UNION (UNION TTYINMACROS TTSUPPORTFNS)
+                                DONTCOMPILEFNS))
+)
+)
+
+(RPAQ? DORADO.RESTORE.BUF.CODES '(194))
+
+(RPAQ? TTYIN.RESTORE.BUF.CODES '(516 530))
+
+(RPAQ? TTYINBUFFER )
+
+(RPAQ? ?ACTIVATEFLG T)
+
+(RPAQ? EDITPREFIXCHAR )
+
+(RPAQ? SHOWPARENFLG T)
+
+(RPAQ? TTYINBSFLG T)
+
+(RPAQ? \TTYIN.LAST.FONT )
+
+(RPAQ? \TTYIN.LAST.COMMENTFONT )
+
+(RPAQ? TTYINFILLDEFAULT T)
+
+(RPAQ? TTYINCOMPLETEFLG T)
+
+(RPAQ? TTYINUSERFN )
+
+(RPAQ? TYPEAHEADFLG T)
+
+(RPAQ? null "")
+
+(RPAQ? DEFAULTPROMPT "** ")
+
+(RPAQ? TTYJUSTLENGTH -1)
+
+(RPAQ? \INSIDE.TTYIN )
+
+(RPAQ? TTYINERRORSETFLG )
+
+(RPAQ? TTYINRAISEFLG T)
+
+(RPAQ? TTYINAUTOFILLMARGIN 8)
+
+(RPAQ? TTYINFIXLIMIT 50)
+
+(RPAQ? TTYINDEBUGFLG )
+
+(RPAQ? HISTSTR1 "from file:")
+
+(RPAQ? TTYINCOMMENTCHAR )
+
+(RPAQ? \RESTOREBUFCODES )
+
+(MOVD? 'NILL 'GUESTUSER?)
+
+(MOVD? 'FIXSPELL 'FIXSPELL!!)
+
+(MOVD? 'HELPSYS 'XHELPSYS)
+
+[PUTDQ? SPRINTT (LAMBDA (X)
+                  (PRIN1 X]
+
+(MOVD? 'NILL 'WINDOWWORLD)
+
+(MOVD? 'LISPXFIX 'NONTTYINLISPXFIX)
+
+(ADDTOVAR TTYINREADMACROS )
+
+(ADDTOVAR TTYINRESPONSES )
+
+(ADDTOVAR LISPXCOMS (STOP . OK))
+
+(ADDTOVAR \SYSTEMCACHEVARS \RESTOREBUFCODES)
+
+(PUTPROPS TTYINREADMACROS VARTYPE ALIST)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+[COND
+   ((CCODEP 'TTYIN)
+    (CHANGENAME 'PROMPTCHAR 'LISPXREADP 'TTYINREADP)
+    (SETREADFN)
+    (MOVD 'TTYINFIX 'LISPXFIX]
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML CHARMACRO?)
+
+(ADDTOVAR LAMA )
+)
+(PUTPROPS TTYIN COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 
+1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (7688 206645 (TTYIN 7698 . 20933) (TTYIN.SETUP 20935 . 24020) (TTYIN.CLEANUP 24022 . 
+24852) (TTYIN1 24854 . 51330) (TTYIN1RESTART 51332 . 52598) (TTYIN.FINISH 52600 . 62027) (
+TTYIN.BALANCE 62029 . 63158) (ADDCHAR 63160 . 65344) (TTMAKECOMPLEXCHAR 65346 . 65820) (ADDNAKEDCHAR 
+65822 . 67329) (TTADDTAB 67331 . 68266) (ADJUSTLINE 68268 . 82139) (ADJUSTLINE.AND.RESTORE 82141 . 
+82579) (AT.END.OF.SCREEN 82581 . 82869) (AT.END.OF.TEXT 82871 . 83310) (AUTOCR? 83312 . 83770) (
+BACKSKREAD 83772 . 88355) (BACKWARD.DELETE.TO 88357 . 88539) (BREAKLINE 88541 . 90804) (BUFTAILP 90806
+ . 91124) (CHECK.MARGIN 91126 . 91749) (CLEAR.LINE? 91751 . 92043) (CURRENT.WORD 92045 . 94451) (
+DELETE.TO.END 94453 . 95174) (DELETELINE 95176 . 98135) (DELETETO 98137 . 99959) (DELETETO1 99961 . 
+101306) (DO.EDIT.COMMAND 101308 . 118627) (DO.EDIT.PP 118629 . 121296) (TTDOTABS 121298 . 122667) (
+EDITCOLUMN 122669 . 123111) (EDITNUMBERP 123113 . 123344) (END.DELETE.MODE 123346 . 123868) (ENDREAD? 
+123870 . 126290) (FIND.LINE 126292 . 127828) (FIND.LINE.BREAK 127830 . 128500) (FIND.MATCHING.QUOTE 
+128502 . 129348) (FIND.NEXT.WORD 129350 . 130729) (FIND.NON.SPACE 130731 . 131004) (FIND.START.OF.WORD
+ 131006 . 131369) (FORWARD.DELETE.TO 131371 . 133593) (GO.TO.ADDRESSING 133595 . 134535) (
+GO.TO.FREELINE 134537 . 135120) (GO.TO.RELATIVE 135122 . 135902) (INIT.CURSOR 135904 . 136790) (
+INSERT.NODE 136792 . 137313) (INSERTLINE 137315 . 138819) (KILL.LINES 138821 . 139360) (KILLSEGMENT 
+139362 . 140485) (L-CASECODE 140487 . 140654) (MOVE.BACK.TO 140656 . 140885) (MOVE.FORWARD.TO 140887
+ . 141307) (MOVE.TO.LINE 141309 . 142224) (MOVE.TO.NEXT.LINE 142226 . 142496) (MOVE.TO.START.OF.WORD 
+142498 . 143254) (MOVE.TO.WHEREVER 143256 . 143479) (NTH.COLUMN.OF 143481 . 143812) (
+NTH.RELATIVE.COLUMN.OF 143814 . 145114) (OVERFLOW? 145116 . 146064) (OVERFLOWLINE? 146066 . 146392) (
+PREVLINE 146394 . 147574) (PREVWORD 147576 . 149719) (PROPERTAILP 149721 . 149928) (READFROMBUF 149930
+ . 152519) (RENUMBER.LINES 152521 . 152914) (RESTORE.CURSOR 152916 . 153070) (RESTOREBUF 153072 . 
+155260) (RETYPE.BUFFER 155262 . 157525) (SAVE.CURSOR 157527 . 157699) (SCANBACK 157701 . 159059) (
+SCANFORWARD 159061 . 159929) (SCRATCHCONS 159931 . 160533) (SEGMENT.LENGTH 160535 . 161071) (
+SEGMENT.BIT.LENGTH 161073 . 161680) (SETLASTC 161682 . 161963) (SETTAIL? 161965 . 162781) (
+SHOW.MATCHING.PAREN 162783 . 165283) (SKIP/ZAP 165285 . 167764) (START.NEW.LINE 167766 . 168098) (
+START.OF.PARAGRAPH? 168100 . 168481) (TTADJUSTWORD 168483 . 169657) (TTBIN 169659 . 170863) (
+TTBITWIDTH 170865 . 171013) (TTCRLF 171015 . 171222) (TTCRLF.ACCOUNT 171224 . 171863) (TTDELETECHAR 
+171865 . 173009) (TTDELETELINE 173011 . 174959) (TTDELETEWORD 174961 . 175629) (TTECHO.TO.FILE 175631
+ . 179181) (TTGIVEHELP 179183 . 180445) (TTGIVEHELP1 180447 . 181029) (TTGIVEHELP2 181031 . 181724) (
+TTLASTLINE 181726 . 182094) (TTLOADBUF 182096 . 185579) (TTNEXTLINE 185581 . 185901) (TTNEXTNODE 
+185903 . 186142) (TTNLEFT 186144 . 187371) (TTNTH 187373 . 187832) (TTNTHLINE 187834 . 188366) (
+TTPRIN1 188368 . 192170) (TTPRINSPACE 192172 . 192564) (TTPRIN1COMMENT 192566 . 192874) (TTPRIN2 
+192876 . 194682) (TTPROMPTCHAR 194684 . 195591) (TTRUBOUT 195593 . 196556) (TTUNREADBUF 196558 . 
+196969) (TTWAITFORINPUT 196971 . 201156) (TTYINSTRING 201158 . 202120) (TYPE.BUFFER 202122 . 203874) (
+U-CASECODE 203876 . 204041) (U/L-CASE 204043 . 206643)) (206800 216513 (TTRATOM 206810 . 207254) (
+TTREADLIST 207256 . 207623) (TTSKIPSEPR 207625 . 207999) (TTSKREAD 208001 . 212627) (TTYIN.READ 212629
+ . 216511)) (216560 236535 (FIND.MATCHING.WORD 216570 . 217082) (TTCOMPLETEWORD 217084 . 231485) (
+WORD.MATCHES.BUFFER 231487 . 233050) (TTYIN.SHOW.?ALTERNATIVES 233052 . 236533)) (236569 254820 (
+DO?CMD 236579 . 242425) (TTYIN.PRINTARGS 242427 . 253325) (TTYIN.READ?=ARGS 253327 . 254096) (
+DO?CMD.ERRORHANDLER 254098 . 254818)) (254854 262898 (BEEP 254864 . 255039) (BITBLT.DELETE 255041 . 
+255671) (BITBLT.ERASE 255673 . 255857) (BITBLT.INSERT 255859 . 256169) (DO.CRLF 256171 . 256488) (
+DO.DELETE.LINES 256490 . 257519) (DO.INSERT.LINE 257521 . 259461) (DO.LF 259463 . 259628) (
+ERASE.TO.END.OF.LINE 259630 . 259958) (ERASE.TO.END.OF.PAGE 259960 . 260556) (INSERT.TEXT 260558 . 
+261062) (TTDELSECTION 261064 . 261366) (TTADJUSTWIDTH 261368 . 262232) (TTINSERTSECTION 262234 . 
+262577) (TTSETCURSOR 262579 . 262896)) (262933 267914 (TTYINBUFFERDEVICE 262943 . 264261) (
+TTYINBUFFERSTREAM 264263 . 265025) (TTYINBUFFERBIN 265027 . 265563) (TTYINBUFFERPEEK 265565 . 266043) 
+(TTYINBUFFERREADP 266045 . 266300) (TTYINBUFFEREOFP 266302 . 266554) (TTYINBUFFERBACKPTR 266556 . 
+267108) (TTYINWORDRDTBL 267110 . 267912)) (268075 293646 (DO.MOUSE 268085 . 270842) (
+DO.SHIFTED.SELECTION 270844 . 281295) (COPY.SEGMENT 281297 . 281501) (DELETE.LONG.SEGMENT 281503 . 
+281862) (DELETE.LONG.SEGMENT1 281864 . 284344) (INVERT.LONG.SEGMENT 284346 . 285375) (INVERT.SEGMENT 
+285377 . 286888) (BRACKET.CURRENT.WORD 286890 . 288424) (TTBEFOREPOS 288426 . 289156) (TTNEXTPOS 
+289158 . 289866) (TTRACKMOUSE 289868 . 293644)) (293790 299185 (SETREADFN 293800 . 294278) (
+TTYINENTRYFN 294280 . 294705) (TTYINREADP 294707 . 295172) (TTYINREAD 295174 . 296666) (TTYINFIX 
+296668 . 297909) (CHARMACRO? 297911 . 298477) (TTYINMETA 298479 . 298607) (TTYIN.LASTINPUT 298609 . 
+299183)) (299186 307668 (TTYINEDIT 299196 . 301257) (SIMPLETEXTEDIT 301259 . 304570) (
+SET.TTYINEDIT.WINDOW 304572 . 305712) (TTYIN.PPTOFILE 305714 . 307666)) (307726 307902 (
+MAKE-TTSCRATCHFILE 307736 . 307900)) (308049 308830 (TTYIN.SCRATCHFILE 308059 . 308522) (\TTYIN.RPEOF 
+308524 . 308828)) (309042 312640 (TTYINPROMPTFORWORD 309052 . 312638)))))
+STOP
diff --git a/CLTL2/TTYIN.LCOM b/CLTL2/TTYIN.LCOM
new file mode 100644
index 00000000..753aabe7
Binary files /dev/null and b/CLTL2/TTYIN.LCOM differ
diff --git a/CLTL2/WRAPPERS b/CLTL2/WRAPPERS
new file mode 100644
index 00000000..52f68b6a
--- /dev/null
+++ b/CLTL2/WRAPPERS
@@ -0,0 +1,483 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "SI")
+(IL:FILECREATED "12-Oct-93 22:28:39" "{Pele:mv:envos}<LispCore>Sources>CLTL2>WRAPPERS.;1" 27409  
+
+      IL:|changes| IL:|to:|  (IL:FUNCTIONS HAS-CALLS)
+
+      IL:|previous| IL:|date:| " 5-Oct-92 23:22:18" 
+IL:|{DSK}<mo>usr>users>sybalsky>cltl2>sources>WRAPPERS.;1|)
+
+
+; Copyright (c) 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:WRAPPERSCOMS)
+
+(IL:RPAQQ IL:WRAPPERSCOMS
+          ((IL:FUNCTIONS COMPILED-FUNCTION-ARGLIST COMPILED-FUNCTION-DEBUGGING-INFO 
+                  COMPILED-FUNCTION-INTERLISP? FUNCTION-WRAPPER-INFO CLEAN-UP-CL-ARGLIST 
+                  GET-STORED-ARGLIST NAMED-FUNCTION-WRAPPER-INFO PARSE-CL-ARGLIST)
+           (IL:FUNCTIONS HAS-CALLS CHANGE-CALLS CHANGE-CALLS-IN-CCODE CHANGE-CALLS-IN-LAMBDA 
+                  ADD-CHANGED-CALL %WITH-CHANGED-CALLS RESTORE-CALLS)
+           
+
+(IL:* IL:|;;;| "Support for function name mapping")
+
+           (IL:FUNCTIONS XCL::NAME-OF-EXECUTABLE XCL::COMMON-LISP-MAPPER)
+           (IL:VARIABLES XCL::*FUNCTION-NAME-MAPPERS*)
+           (IL:FNS IL:VIRGINFN CONSTRUCT-MIDDLE-MAN)
+           (IL:PROP IL:PROPTYPE IL:NAMESCHANGED)
+           
+           (IL:* IL:|;;| "Arrange for the proper compiler and package/readtable.")
+
+           (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                  IL:WRAPPERS)
+           (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:FILES (IL:LOADCOMP)
+                                                              IL:ACODE))
+           (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS
+                  (IL:ADDVARS (IL:NLAMA)
+                         (IL:NLAML)
+                         (IL:LAMA CONSTRUCT-MIDDLE-MAN)))))
+
+(DEFUN COMPILED-FUNCTION-ARGLIST (FN &KEY INTERLISP?)
+   (LET ((DEBUGGING-INFO (COMPILED-FUNCTION-DEBUGGING-INFO FN)))
+        (COND
+           (DEBUGGING-INFO                                   (IL:* IL:\; 
+                                                     "Oh, good.  Its argument list is easy to get.")
+                  (IF INTERLISP?
+                      (IL:|for| X IL:|in| (CAR DEBUGGING-INFO)
+                         IL:|join| (COND
+                                          ((STRINGP X)
+                                           (LIST (IL:MKATOM X)))
+                                          ((EQ X '&OPTIONAL)
+                                           NIL)
+                                          (T (LIST X))))
+                      (COPY-TREE (CAR DEBUGGING-INFO))))
+           (T                                                (IL:* IL:\; 
+                                                           "Rats.  We have to go to some trouble.")
+              (IL:\\CCODEARGLIST (IL:|fetch| (IL:COMPILED-CLOSURE IL:FNHEADER) IL:|of| FN))))
+        ))
+
+(DEFUN COMPILED-FUNCTION-DEBUGGING-INFO (FN)
+
+(IL:* IL:|;;;| "Given a compiled-function object, extract the debugging-info list from it.  If it's ByteCompiled, it won't have such a list and we should return NIL.  We can tell if there is such a list by the length allowed for the local name table.  If there's a multiple of a quadword there, it's a name table.  Otherwise, it should be exactly one cell long and contain a pointer to the debugging-info list.")
+
+   (LET* ((FNHEADER (IL:|fetch| (IL:COMPILED-CLOSURE IL:FNHEADER) IL:|of| FN))
+          (START-PC (IF (IL:|fetch| (IL:FNHEADER IL:NATIVE) IL:|of| FNHEADER)
+                        (- (IL:|fetch| (IL:FNHEADER IL:STARTPC) IL:|of| FNHEADER)
+                           4)
+                        (IL:|fetch| (IL:FNHEADER IL:STARTPC) IL:|of| FNHEADER)))
+          (NAME-TABLE-WORDS (LET ((SIZE (IL:|fetch| (IL:FNHEADER IL:NTSIZE) IL:|of| FNHEADER)
+                                        ))
+                                 (IF (ZEROP SIZE)
+                                     IL:WORDSPERQUAD
+                                     (* SIZE 2))))
+          (PAST-NAME-TABLE-IN-WORDS (+ (IL:|fetch| (IL:FNHEADER IL:OVERHEADWORDS) IL:|of|
+                                                                                      FN)
+                                       NAME-TABLE-WORDS)))
+         (AND (= (- START-PC (* IL:BYTESPERWORD PAST-NAME-TABLE-IN-WORDS))
+                 IL:BYTESPERCELL)
+
+              (IL:* IL:|;;| "It's got a debugging-info list.")
+
+              (IL:\\GETBASEPTR FNHEADER PAST-NAME-TABLE-IN-WORDS))))
+
+(DEFUN COMPILED-FUNCTION-INTERLISP? (FN)
+
+(IL:* IL:|;;;| 
+"Given a compiled-function, return true if and only if the function is an Interlisp one.")
+
+   (LET ((DEBUGGING-INFO (COMPILED-FUNCTION-DEBUGGING-INFO FN)))
+        (OR (MEMBER (IL:ARGTYPE FN)
+                   '(1 3))                                   (IL:* IL:\; 
+                                                           "NLambda's are always Interlisp")
+            (NULL DEBUGGING-INFO)                            (IL:* IL:\; 
+                                                           "ByteCompiled code is always Interlisp.")
+            (GETF (CDR DEBUGGING-INFO)
+                  :INTERLISP)                                (IL:* IL:\; 
+                                        "PavCompiled Interlisp code should have this marker in it.")
+            )))
+
+(DEFUN FUNCTION-WRAPPER-INFO (WRAPPED-FN FN-TO-CALL)
+   (LET* ((NAME (AND (SYMBOLP WRAPPED-FN)
+                     WRAPPED-FN))
+          (DEFN (IF NAME
+                    (IL:GETD NAME)
+                    WRAPPED-FN)))
+         (NAMED-FUNCTION-WRAPPER-INFO NAME DEFN FN-TO-CALL)))
+
+(DEFUN CLEAN-UP-CL-ARGLIST (ARG-LIST)
+   (IL:|bind| (STATE IL:_ :REQUIRED) IL:|for| PARAM IL:|in| ARG-LIST
+      IL:|collect| (COND
+                          ((MEMBER PARAM '(&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS))
+                           (SETQ STATE PARAM)
+                           PARAM)
+                          ((CONSP PARAM)
+                           (CASE STATE
+                               (&OPTIONAL (FIRST PARAM))
+                               (&KEY (IF (CONSP (FIRST PARAM))
+                                         (FIRST (FIRST PARAM))
+                                         (INTERN (STRING (FIRST PARAM))
+                                                "KEYWORD")))
+                               (OTHERWISE 
+                                  (WARN "Illegal form in argument-list: ~S" PARAM)
+                                  'USER::%LOSE%)))
+                          ((EQ STATE '&KEY)
+                           (INTERN (STRING PARAM)
+                                  "KEYWORD"))
+                          (T PARAM))))
+
+(DEFUN GET-STORED-ARGLIST (NAME)
+
+(IL:* IL:|;;;| "The IL:ARGNAMES property is either the argument list itself or a list of the form (NIL arglist-1 . arglist-2) where arglist-1 is semantically void and arglist-2 is interesting.  Since NIL is not a legal argument list, we can tell the cases apart.  Ugh.")
+
+   (LET ((ARGNAMES (GET NAME 'IL:ARGNAMES)))
+        (AND ARGNAMES (COND
+                         ((ATOM ARGNAMES)
+                          (ERROR "Illegal ARGNAMES property for ~S" NAME))
+                         ((NULL (CAR ARGNAMES))              (IL:* IL:\; "It's the fancy case.")
+                          (CDDR ARGNAMES))
+                         (T                                  (IL:* IL:\; "It's the simple case.")
+                            ARGNAMES)))))
+
+(DEFUN NAMED-FUNCTION-WRAPPER-INFO (NAME DEFN FN-TO-CALL)
+   (LET
+    ((STORED-ARGLIST (AND NAME (GET-STORED-ARGLIST NAME))))
+    (ETYPECASE DEFN
+        (NULL                                                (IL:* IL:\; 
+                                                           "It's an undefined function.")
+           (ASSERT (NOT (NULL NAME))
+                  NIL "Null definition passed to SI::FUNCTION-WRAPPER-INFO")
+           (VALUES 'LAMBDA '(&REST XCL:ARGLIST)
+                  `(ERROR 'UNDEFINED-FUNCTION :NAME (CONS ',NAME XCL:ARGLIST))))
+        (CONS                                                (IL:* IL:\; 
+                                                           "It's an interpreted function.")
+           (ECASE (CAR DEFN)
+               ((IL:LAMBDA) 
+                  (ETYPECASE (CADR DEFN)
+                      (LIST                                  (IL:* IL:\; "Lambda spread")
+                         (VALUES 'IL:LAMBDA (OR STORED-ARGLIST (CADR DEFN))
+                                `(FUNCALL ',FN-TO-CALL ,@(OR STORED-ARGLIST (CADR DEFN)))))
+                      (SYMBOL                                (IL:* IL:\; "Lambda no-spread")
+                         (VALUES
+                          'IL:LAMBDA
+                          (OR STORED-ARGLIST (CADR DEFN))
+                          `(APPLY ',FN-TO-CALL
+                                  ,(IF (CONSP STORED-ARGLIST)
+                                       `(LIST ,@STORED-ARGLIST)
+                                       `(IL:FOR $FWI$ IL:TO ,(OR STORED-ARGLIST (CADR DEFN))
+                                           IL:COLLECT (IL:ARG ,(OR STORED-ARGLIST (CADR DEFN))
+                                                                 $FWI$))))))))
+               ((IL:NLAMBDA) 
+                  (ETYPECASE (CADR DEFN)
+                      (LIST                                  (IL:* IL:\; "NLambda spread")
+                         (VALUES 'IL:NLAMBDA (OR STORED-ARGLIST (CADR DEFN))
+                                `(FUNCALL ',FN-TO-CALL ,@(OR STORED-ARGLIST (CADR DEFN)))))
+                      (SYMBOL                                (IL:* IL:\; "NLambda no-spread")
+                         (VALUES 'IL:NLAMBDA (OR STORED-ARGLIST (CADR DEFN))
+                                `(FUNCALL ',FN-TO-CALL ,(IF (CONSP STORED-ARGLIST)
+                                                            `(LIST ,@STORED-ARGLIST)
+                                                            (OR STORED-ARGLIST (CADR DEFN))))))))
+               ((LAMBDA) (VALUES 'LAMBDA (CLEAN-UP-CL-ARGLIST (CADR DEFN))
+                                `(APPLY ',FN-TO-CALL XCL:ARGLIST)))))
+        (COMPILED-FUNCTION                                   (IL:* IL:\; "It's compiled.")
+           (IF (NOT (COMPILED-FUNCTION-INTERLISP? DEFN)) (IL:* IL:\; "Common Lisp function.")
+               (VALUES 'LAMBDA (COMPILED-FUNCTION-ARGLIST DEFN)
+                      `(APPLY ',FN-TO-CALL XCL:ARGLIST))
+               (ECASE (IL:ARGTYPE DEFN)
+                   (0                                        (IL:* IL:\; "Lambda spread function.")
+                      (LET ((ARGLIST (OR STORED-ARGLIST (COMPILED-FUNCTION-ARGLIST DEFN 
+                                                               :INTERLISP? T))))
+                           (VALUES 'IL:LAMBDA ARGLIST `(FUNCALL ',FN-TO-CALL ,@ARGLIST))))
+                   (1                                        (IL:* IL:\; "NLambda spread function.")
+                      (LET ((ARGLIST (OR STORED-ARGLIST (COMPILED-FUNCTION-ARGLIST DEFN 
+                                                               :INTERLISP? T))))
+                           (VALUES 'IL:NLAMBDA ARGLIST `(FUNCALL ',FN-TO-CALL ,@ARGLIST))))
+                   (2                                        (IL:* IL:\; 
+                                                           "Lambda no-spread function.")
+                      (IF (SYMBOLP STORED-ARGLIST)
+                          (VALUES 'IL:LAMBDA 'IL:U
+                                 `(APPLY ',FN-TO-CALL (IL:FOR $FWI$
+                                                         IL:TO ,(OR STORED-ARGLIST 'IL:U)
+                                                         IL:COLLECT
+                                                         (IL:ARG ,(OR STORED-ARGLIST 'IL:U)
+                                                                $FWI$))))
+                          (VALUES 'IL:LAMBDA STORED-ARGLIST `(FUNCALL ',FN-TO-CALL ,@STORED-ARGLIST)))
+)
+                   (3                                        (IL:* IL:\; 
+                                                           "NLambda no-spread function.")
+
+                      (IL:* IL:|;;| "Its arglist may be a symbol, or NIL, or IL:U.  COMPILED-FUNCTION-ARGLIST will return a symbol in this case.")
+
+                      (LET ((ARGLIST (OR (AND (IL:NEQ STORED-ARGLIST 'IL:U)
+                                              STORED-ARGLIST)
+                                         (COMPILED-FUNCTION-ARGLIST DEFN :INTERLISP? T))))
+                           (COND
+                              ((SYMBOLP ARGLIST)
+                               (VALUES 'IL:NLAMBDA ARGLIST `(APPLY ',FN-TO-CALL (IL:MKLIST
+                                                                                 ,ARGLIST))))
+                              (T (VALUES 'IL:NLAMBDA ARGLIST `(FUNCALL ',FN-TO-CALL ,ARGLIST))))))))))
+    ))
+
+(DEFUN PARSE-CL-ARGLIST (ARG-LIST)
+   (LET ((REQUIRED NIL)
+         (OPTIONAL NIL)
+         (REST NIL)
+         (KEY NIL)
+         (KEY-APPEARED? NIL)
+         (ALLOW-OTHER-KEYS NIL)
+         (STATE :REQUIRED))
+        (IL:|for| PARAM IL:|in| ARG-LIST
+           IL:|do| (IF (MEMBER PARAM '(&OPTIONAL &KEY &REST))
+                           (SETQ STATE PARAM)
+                           (CASE STATE
+                               (:REQUIRED (PUSH PARAM REQUIRED))
+                               (&OPTIONAL (PUSH PARAM OPTIONAL))
+                               (&REST (SETQ REST PARAM))
+                               (&KEY (IF (EQ PARAM '&ALLOW-OTHER-KEYS)
+                                         (SETQ ALLOW-OTHER-KEYS T)
+                                         (PUSH PARAM KEY)))))
+                 (WHEN (EQ PARAM '&KEY)
+                       (SETQ KEY-APPEARED? T)))
+        (VALUES (REVERSE REQUIRED)
+               (REVERSE OPTIONAL)
+               REST
+               (REVERSE KEY)
+               KEY-APPEARED? ALLOW-OTHER-KEYS)))
+
+(DEFUN HAS-CALLS (CALLER CALLEE)
+
+   (IL:* IL:|;;| "Tell if CALLEE is called by CALLER at all.")
+
+   (IL:* IL:|;;| "[JDS 3-10-93:  Used to use CALLS to find callee list; changed to CALLSCCODE, because CALLS isn't always loaded.]")
+
+   (LET ((REAL-CALLER (OR (GET CALLER 'IL:ADVISED)
+                          (GET CALLER 'IL:BROKEN)
+                          CALLER)))
+        (OR (CONSP (IL:GETD REAL-CALLER))
+            (FIND CALLEE (CADR (IL:CALLSCCODE REAL-CALLER))
+                  :TEST
+                  'EQ))))
+
+(DEFUN CHANGE-CALLS (FROM TO FN &OPTIONAL FIXER)
+
+(IL:* IL:|;;;| "Side-effect the definition of FN to change all calls to FROM into calls to TO.  Also save enough information that SI::RESTORE-CALLS can fix up the definition again.")
+
+   (LET* ((REAL-FN-SYMBOL (OR (GET FN 'IL:ADVISED)
+                              (GET FN 'IL:BROKEN)
+                              FN))
+          (REAL-FN-DEFN (IL:GETD REAL-FN-SYMBOL)))
+         (TYPECASE REAL-FN-DEFN
+             (CONS                                           (IL:* IL:\; 
+                                                           "The function is interpreted.")
+                (WHEN (NULL (GET FN 'IL:NAMESCHANGED))       (IL:* IL:\; "The first time we change calls, get a copy so as to avoid sharing structure with the DEFUN form.  Ugh.")
+                    (IL:PUTD REAL-FN-SYMBOL (SETQ REAL-FN-DEFN (COPY-TREE REAL-FN-DEFN))))
+                (CHANGE-CALLS-IN-LAMBDA FROM TO REAL-FN-DEFN))
+             (IL:COMPILED-CLOSURE (CHANGE-CALLS-IN-CCODE FROM TO REAL-FN-DEFN))
+             (OTHERWISE (ERROR "SI::CHANGE-CALLS called on a non-function: ~S" FN))))
+
+   (IL:* IL:|;;| "If there's an opposite entry already in the info, just remove it.  We assume that we're being called from the same fellow that called us before and that we want to simply undo that other call.")
+
+   (UNLESS (EQ FIXER 'RESTORE-CALLS)
+       (FLET ((MATCHING (ENTRY)
+                     (AND (EQ (FIRST ENTRY)
+                              TO)
+                          (EQ (SECOND ENTRY)
+                              FROM))))
+             (LET ((CURRENT-INFO (GET FN 'IL:NAMESCHANGED)))
+                  (IF (SOME #'MATCHING CURRENT-INFO)
+                      (IF (NULL (CDR CURRENT-INFO))
+                          (REMPROP FN 'IL:NAMESCHANGED)
+                          (SETF (GET FN 'IL:NAMESCHANGED)
+                                (DELETE-IF #'MATCHING CURRENT-INFO)))
+                      (PUSH (LIST FROM TO FIXER)
+                            (GET FN 'IL:NAMESCHANGED))))))
+   NIL)
+
+(DEFUN CHANGE-CALLS-IN-CCODE (FROM TO CCODE)
+
+   (IL:* IL:|;;| "Change the calls in a compiled-code object??")
+
+   (IL:FOR REFMAP IL:IN (CDR (IL:CHANGECCODE FROM FROM CCODE))
+      IL:DO (LET ((BASE (IL:FETCH (IL:REFMAP IL:CODEARRAY) IL:OF REFMAP)))
+                     (IL:FOR LOC IL:IN (IL:FETCH (IL:REFMAP IL:DEFLOCS) IL:OF REFMAP)
+                        IL:DO (IL:CODEBASESETATOM BASE LOC (IL:NEW-SYMBOL-CODE TO (
+                                                                                    IL:\\ATOMDEFINDEX
+                                                                                       TO)))))))
+
+(DEFUN CHANGE-CALLS-IN-LAMBDA (FROM TO LAMBDA-FORM)
+
+(IL:* IL:|;;;| "Wrap all of the right parts of the given LAMBDA-FORM in the proper %WITH-CHANGED-CALLS forms changing calls to FROM into calls to TO.  Actually side-effect the LAMBDA-FORM to make this change.")
+
+   (ECASE (CAR LAMBDA-FORM)
+       ((IL:LAMBDA IL:NLAMBDA) (SETF (CDDR LAMBDA-FORM)
+                                     (ADD-CHANGED-CALL FROM TO (CDDR LAMBDA-FORM))))
+       ((LAMBDA)                                             (IL:* IL:\; "For Common Lisp functions, we have to be careful to wrap up the init-forms for any &OPTIONAL, &KEY, and &AUX parameters.")
+          (LET ((STATE :REQUIRED))
+               (IL:|for| PARAM IL:|in| (SECOND LAMBDA-FORM)
+                  IL:|do| (COND
+                                 ((CONSP PARAM)
+                                  (WHEN (AND (CONSP (CDR PARAM))
+                                             (MEMBER STATE '(&OPTIONAL &KEY &AUX)
+                                                    :TEST
+                                                    'EQ))
+                                      (SETF (SECOND PARAM)
+                                            (CAR (ADD-CHANGED-CALL FROM TO (LIST (SECOND PARAM)))
+                                                 ))))
+                                 ((MEMBER PARAM '(&OPTIONAL &REST &KEY &AUX)
+                                         :TEST
+                                         'EQ)
+                                  (SETQ STATE PARAM))))
+               (SETF (CDDR LAMBDA-FORM)
+                     (ADD-CHANGED-CALL FROM TO (CDDR LAMBDA-FORM))))))
+   NIL)
+
+(DEFUN ADD-CHANGED-CALL (FROM TO BODY)
+
+(IL:* IL:|;;;| "BODY is a list of forms in which calls to FROM should be changed into calls to TO.  If the BODY contains a single form that is a call to the macro SI::%WITH-CHANGED-CALLS, then we just side-effect that form to add another (FROM . TO) pair.  Otherwise, we wrap up the BODY in a new call to SI::%WITH-CHANGED-CALLS.  In either case, we return a list of the SI::%WITH-CHANGED-CALLS form.")
+
+(IL:* IL:|;;;| "Actually, I lied.  If it's already a SI::%WITH-CHANGED-CALLS form, and the pair (TO . FROM) is in the list of changes, then we simply remove it from the list.  If the list is now empty, then we remove the SI::%WITH-CHANGED-CALLS form entirely and actually return the former body of the macro-call.")
+
+(IL:* IL:|;;;| "The effect of this is that you can undo previous additions simply by exchanging the FROM and TO arguments to this function.")
+
+   (COND
+      ((AND (NULL (REST BODY))
+            (EQ (CAR (FIRST BODY))
+                '%WITH-CHANGED-CALLS))
+
+       (IL:* IL:|;;| "It's already a call to %WITH-CHANGED-CALLS.")
+
+       (LET ((WCC-FORM (FIRST BODY)))
+            (COND
+               ((MEMBER (CONS TO FROM)
+                       (SECOND WCC-FORM)
+                       :TEST
+                       'EQUAL)
+
+                (IL:* IL:|;;| "We're undoing a previous call to ADD-CHANGED-CALL.")
+
+                (COND
+                   ((NULL (REST (SECOND WCC-FORM)))          (IL:* IL:\; 
+                                            "There won't be anything left, so return the old body.")
+                    (CDDR WCC-FORM))
+                   (T                                        (IL:* IL:\; 
+                   "Oh, well, there'll still be something there.  Just remove the particular pair.")
+                      (SETF (SECOND WCC-FORM)
+                            (DELETE (CONS TO FROM)
+                                   (SECOND WCC-FORM)
+                                   :TEST
+                                   'EQUAL))
+                      (LIST WCC-FORM))))
+               (T (PUSH (CONS FROM TO)
+                        (SECOND WCC-FORM))
+                  (LIST WCC-FORM)))))
+      (T 
+         (IL:* IL:|;;| "It's not already a %WITH-CHANGED-CALLS form, so make it into one.")
+
+         `((%WITH-CHANGED-CALLS (,(CONS FROM TO))
+                  ,@BODY)))))
+
+(DEFMACRO %WITH-CHANGED-CALLS (A-LIST &BODY BODY)
+   `(MACROLET ,(IL:FOR PAIR IL:IN A-LIST
+                  IL:COLLECT `(,(CAR PAIR)
+                                   (&REST ARGS)
+                                   (CONS ',(CDR PAIR)
+                                         ARGS)))
+           ,@BODY))
+
+(DEFUN RESTORE-CALLS (FN)
+   (IL:|for| ENTRY IL:|in| (GET FN 'IL:NAMESCHANGED)
+      IL:|do| (DESTRUCTURING-BIND (FROM TO FIXER)
+                         ENTRY
+                         (CHANGE-CALLS TO FROM FN 'RESTORE-CALLS)
+                         (FUNCALL FIXER FROM TO FN)))
+   (AND (REMPROP FN 'IL:NAMESCHANGED)
+        T))
+
+
+
+(IL:* IL:|;;;| "Support for function name mapping")
+
+
+(DEFUN XCL::NAME-OF-EXECUTABLE (XCL::FN-NAME)            (IL:* IL:\; 
+                                                           "Edited  8-Jan-92 13:28 by jrb:")
+
+   (IL:* IL:|;;| "*FUNCTION-NAME-MAPPERS* is a list of functions that get called to attempt to map FN-NAME to a symbol where the executable for FN-NAME resides under Medley.  Currently there is only one, named COMMON-LISP-MAPPER, which handles symbols naming functions and macros and (SETF FOO) forms.")
+
+   (DO ((XCL::FNS XCL::*FUNCTION-NAME-MAPPERS* (CDR XCL::FNS))
+        (XCL::RESULT)
+        (XCL::NO-IN-FN))
+       ((NULL XCL::FNS)
+        NIL)
+     (MULTIPLE-VALUE-SETQ (XCL::RESULT XCL::NO-IN-FN)
+            (FUNCALL (CAR XCL::FNS)
+                   XCL::FN-NAME))
+     (WHEN XCL::RESULT
+         (UNLESS (EQ XCL::RESULT XCL::FN-NAME)
+             (SETF (GET XCL::RESULT 'TRUE-NAME)
+                   XCL::FN-NAME))
+         (RETURN-FROM XCL::NAME-OF-EXECUTABLE (VALUES XCL::RESULT XCL::NO-IN-FN)))))
+
+(DEFUN XCL::COMMON-LISP-MAPPER (XCL::FN-NAME)            (IL:* IL:\; 
+                                                           "Edited  5-Oct-92 22:50 by jrb:")
+
+   (IL:* IL:|;;| "Recognizes standard Common Lisp names of executable things and returns the symbol where their executable should reside; the second value is true when it's impossible to selectively break/trace/advise (i.e. (FOO :IN :BAR))")
+
+   (LET (XCL::RESULT)
+        (COND
+           ((SYMBOLP XCL::FN-NAME)
+            (IF (AND (SETQ XCL::RESULT (MACRO-FUNCTION XCL::FN-NAME))
+                     (SYMBOLP XCL::RESULT)
+
+                     (IL:* IL:|;;| "These two symbols can be returned by MACRO-FUNCTION if FN-NAME is an Interlisp CLISP word or an NLAMBDA of some sort")
+
+                     (NOT (EQ XCL::RESULT 'IL:CLISPEXPANSION))
+                     (NOT (EQ XCL::RESULT 'IL:\\INTERLISP-NLAMBDA-MACRO)))
+                (VALUES XCL::RESULT T)
+                XCL::FN-NAME))
+           ((CL::SETF-NAME-P XCL::FN-NAME)
+            (OR (GET (SECOND XCL::FN-NAME)
+                     :SETF-DEFUN)
+                (XCL::DEFUN-SETF-NAME (SECOND XCL::FN-NAME)))))))
+
+(DEFVAR XCL::*FUNCTION-NAME-MAPPERS* '(XCL::COMMON-LISP-MAPPER))
+(IL:DEFINEQ
+
+(IL:VIRGINFN
+(IL:LAMBDA (IL:FN IL:MAKE-VIRGIN?) (IL:* IL:\; "Edited 17-Dec-91 20:23 by jrb:") (LET* ((IL:EXECUTABLE-NAME (XCL::NAME-OF-EXECUTABLE IL:FN)) (IL:BROKEN-DEFN (IL:GETPROP IL:EXECUTABLE-NAME (QUOTE IL:BROKEN))) (IL:ADVISED-DEFN (IL:GETPROP IL:EXECUTABLE-NAME (QUOTE IL:ADVISED))) (IL:CHANGED-NAMES (IL:GETPROP IL:EXECUTABLE-NAME (QUOTE IL:NAMESCHANGED))) (IL:EXPR-DEFN (IL:GETPROP IL:EXECUTABLE-NAME (QUOTE IL:EXPR))) IL:REAL-DEFN) (IL:|if| IL:MAKE-VIRGIN? IL:|then| (IL:* IL:|;;| "We're supposed to return the function to its virgin state, without any breaks, advice, or changed names.") (IL:|if| IL:BROKEN-DEFN IL:|then| (XCL:UNBREAK-FUNCTION IL:FN) (FORMAT *TERMINAL-IO* "~S unbroken.~%" IL:FN)) (IL:|if| IL:ADVISED-DEFN IL:|then| (IL:APPLY (QUOTE IL:UNADVISE) (LIST IL:FN)) (FORMAT *TERMINAL-IO* "~S unadvised.~%" IL:FN)) (IL:|if| IL:CHANGED-NAMES IL:|then| (RESTORE-CALLS IL:EXECUTABLE-NAME) (FORMAT *TERMINAL-IO* "Names restored in ~S.~%" IL:FN)) (IL:SETQ IL:REAL-DEFN (IL:GETD IL:EXECUTABLE-NAME)) (IL:|if| (AND (NOT (IL:EXPRP IL:REAL-DEFN)) (NOT (NULL IL:EXPR-DEFN))) IL:|then| (IL:SETQ IL:REAL-DEFN IL:EXPR-DEFN)) IL:REAL-DEFN IL:|else| (IL:* IL:|;;| "We're not supposed to change the state of the function with respect to breaking, advising or changed names.  We're just supposed to return the real, core definition.") (IL:SETQ IL:REAL-DEFN (IL:GETD (OR IL:ADVISED-DEFN IL:BROKEN-DEFN IL:EXECUTABLE-NAME))) (IL:|if| (OR (IL:NLISTP IL:REAL-DEFN) (IL:NLISTP (CDR IL:REAL-DEFN))) IL:|then| (OR IL:EXPR-DEFN IL:REAL-DEFN) IL:|else| (IL:|if| IL:CHANGED-NAMES IL:|then| (IL:SETQ IL:REAL-DEFN (IL:COPY IL:REAL-DEFN)) (IL:|for| IL:X IL:|in| IL:CHANGED-NAMES IL:|do| (XCL:DESTRUCTURING-BIND (IL:FROM IL:TO) IL:X (CHANGE-CALLS-IN-LAMBDA IL:TO IL:FROM IL:REAL-DEFN)))) IL:REAL-DEFN))))
+)
+
+(construct-middle-man
+  (lambda (object-fn in-fn)
+         (block construct-middle-man (let ((*print-case* :upcase))
+                                          (intern (format nil "~A in ~A::~A" object-fn
+                                                         (package-name (symbol-package in-fn))
+                                                         in-fn)
+                                                 (symbol-package object-fn))))))
+)
+
+(IL:PUTPROPS IL:NAMESCHANGED IL:PROPTYPE IGNORE)
+
+
+
+(IL:* IL:|;;| "Arrange for the proper compiler and package/readtable.")
+
+
+(IL:PUTPROPS IL:WRAPPERS IL:FILETYPE :FAKE-COMPILE-FILE)
+
+(IL:PUTPROPS IL:WRAPPERS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "SI"))
+(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY 
+
+(IL:FILESLOAD (IL:LOADCOMP)
+       IL:ACODE)
+)
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA )
+
+(IL:ADDTOVAR IL:NLAML )
+
+(IL:ADDTOVAR IL:LAMA CONSTRUCT-MIDDLE-MAN)
+)
+(IL:PUTPROPS IL:WRAPPERS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 1991 1992 1993))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL (24442 26706 (IL:VIRGINFN 24455 . 26255) (CONSTRUCT-MIDDLE-MAN 26257 . 26704)))))
+IL:STOP
diff --git a/CLTL2/WRAPPERS.LCOM b/CLTL2/WRAPPERS.LCOM
new file mode 100644
index 00000000..9464c171
Binary files /dev/null and b/CLTL2/WRAPPERS.LCOM differ
diff --git a/CLTL2/XCL-EXTRAS b/CLTL2/XCL-EXTRAS
new file mode 100644
index 00000000..d4a6c69a
--- /dev/null
+++ b/CLTL2/XCL-EXTRAS
@@ -0,0 +1,296 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
+(IL:FILECREATED "18-Oct-93 17:14:46" "{Pele:mv:envos}<LispCore>Sources>CLTL2>XCL-EXTRAS.;2" 15281  
+
+      IL:|previous| IL:|date:| " 3-Sep-91 18:24:26" 
+"{Pele:mv:envos}<LispCore>Sources>CLTL2>XCL-EXTRAS.;1")
+
+
+; Copyright (c) 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:XCL-EXTRASCOMS)
+
+(IL:RPAQQ IL:XCL-EXTRASCOMS
+          (
+           (IL:* IL:|;;| " Finess the define-file-info problem")
+
+           (IL:DEFINE-TYPES FILE-ENVIRONMENTS)
+           (IL:FUNCTIONS DEFINE-FILE-ENVIRONMENT)
+           
+           (IL:* IL:|;;| "Macro for writing macros ")
+
+           (IL:FUNCTIONS ONCE-ONLY)
+           
+           (IL:* IL:|;;| "CL veneer on IL record module")
+
+           (IL:FUNCTIONS RECORD-FETCH SETF-FETCH RECORD-FFETCH SETF-FFETCH RECORD-CREATE)
+           (IL:SETFS RECORD-FETCH RECORD-FFETCH)
+           
+           (IL:* IL:|;;| "An alternate version of the above")
+
+           (IL:FUNCTIONS DEFINE-RECORD)
+           (IL:FUNCTIONS RECORD-ACCESS-MACRO SETF-RECORD-ACCESS-MACRO RECORD-PREDICATE-MACRO 
+                  RECORD-CONSTRUCTOR-MACRO)
+           (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                  IL:XCL-EXTRAS)))
+
+
+
+(IL:* IL:|;;| " Finess the define-file-info problem")
+
+
+(DEF-DEFINE-TYPE FILE-ENVIRONMENTS "File info")
+
+(DEFDEFINER DEFINE-FILE-ENVIRONMENT FILE-ENVIRONMENTS (FILE &KEY READTABLE PACKAGE BASE COMPILER)
+   (LET ((ROOTNAME (INTERN (STRING FILE)
+                          (FIND-PACKAGE "INTERLISP"))))
+        `(EVAL-WHEN (EVAL LOAD)
+                ,@(IF (OR READTABLE PACKAGE BASE)
+                      `((SETF (GET ',ROOTNAME 'IL:MAKEFILE-ENVIRONMENT)
+                              '(,@(IF READTABLE
+                                      `(:READTABLE ,READTABLE))
+                                ,@(IF PACKAGE
+                                      `(:PACKAGE ,PACKAGE))
+                                ,@(IF BASE
+                                      `(:BASE ,BASE))))))
+                ,@(IF COMPILER
+                      `((SETF (GET ',ROOTNAME 'IL:FILETYPE)
+                              ',COMPILER))))))
+
+
+
+(IL:* IL:|;;| "Macro for writing macros ")
+
+
+(DEFMACRO ONCE-ONLY (VARS &BODY BODY)
+
+(IL:* IL:|;;;| "ONCE-ONLY assures that the forms given as vars are evaluated in the proper order, once only. Used in the body of macro definitions. Taken from Zeta Lisp.")
+
+   (LET* ((GENSYM-VAR (GENSYM))
+          (RUN-TIME-VARS (GENSYM))
+          (RUN-TIME-VALS (GENSYM))
+          (EXPAND-TIME-VAL-FORMS (MAPCAR #'(LAMBDA (VAR)
+                                                  `(IF (OR (SYMBOLP ,VAR)
+                                                           (CONSTANTP ,VAR))
+                                                       ,VAR
+                                                       (LET ((,GENSYM-VAR (GENSYM)))
+                                                            (PUSH ,GENSYM-VAR ,RUN-TIME-VARS)
+                                                            (PUSH ,VAR ,RUN-TIME-VALS)
+                                                            ,GENSYM-VAR)))
+                                        VARS)))
+         `(,'LET* (,RUN-TIME-VARS ,RUN-TIME-VALS
+                         (WRAPPED-BODY (,'LET ,(WITH-COLLECTION (DO ((VAR VARS (CDR VAR))
+                                                                     (EXPAND-TIME-VAL-FORM
+                                                                      EXPAND-TIME-VAL-FORMS
+                                                                      (CDR EXPAND-TIME-VAL-FORM)))
+                                                                    ((NULL VAR))
+                                                                  (COLLECT (LIST (CAR VAR)
+                                                                                 (CAR 
+                                                                                 EXPAND-TIME-VAL-FORM
+                                                                                      )))))
+                                              ,@BODY)))
+                 `(,'LET ,(WITH-COLLECTION (DO ((RUN-TIME-VAR (REVERSE ,RUN-TIME-VARS)
+                                                       (CDR RUN-TIME-VAR))
+                                                (RUN-TIME-VAL (REVERSE ,RUN-TIME-VALS)
+                                                       (CDR RUN-TIME-VAL)))
+                                               ((NULL RUN-TIME-VAR))
+                                             (COLLECT (LIST (CAR RUN-TIME-VAR)
+                                                            (CAR RUN-TIME-VAL)))))
+                         ,WRAPPED-BODY))))
+
+
+
+(IL:* IL:|;;| "CL veneer on IL record module")
+
+
+(DEFMACRO RECORD-FETCH (RECORD FIELD OBJECT)
+   (LET ((IL-RECORD (INTERN (STRING RECORD)
+                           IL:*INTERLISP-PACKAGE*))
+         (IL-FIELD (INTERN (STRING FIELD)
+                          IL:*INTERLISP-PACKAGE*)))
+        `(IL:|fetch| (,IL-RECORD ,IL-FIELD) IL:|of| ,OBJECT)))
+
+(DEFMACRO SETF-FETCH (RECORD FIELD OBJECT NEW-VALUE)
+   (LET ((IL-RECORD (INTERN (STRING RECORD)
+                           IL:*INTERLISP-PACKAGE*))
+         (IL-FIELD (INTERN (STRING FIELD)
+                          IL:*INTERLISP-PACKAGE*)))
+        `(IL:|replace| (,IL-RECORD ,IL-FIELD) IL:|of| ,OBJECT IL:|with| ,NEW-VALUE)))
+
+(DEFMACRO RECORD-FFETCH (RECORD FIELD OBJECT)
+   (LET ((IL-RECORD (INTERN (STRING RECORD)
+                           IL:*INTERLISP-PACKAGE*))
+         (IL-FIELD (INTERN (STRING FIELD)
+                          IL:*INTERLISP-PACKAGE*)))
+        `(IL:|ffetch| (,IL-RECORD ,IL-FIELD) IL:|of| ,OBJECT)))
+
+(DEFMACRO SETF-FFETCH (RECORD FIELD OBJECT NEW-VALUE)
+   (LET ((IL-RECORD (INTERN (STRING RECORD)
+                           IL:*INTERLISP-PACKAGE*))
+         (IL-FIELD (INTERN (STRING FIELD)
+                          IL:*INTERLISP-PACKAGE*)))
+        `(IL:|freplace| (,IL-RECORD ,IL-FIELD) IL:|of| ,OBJECT IL:|with| ,NEW-VALUE)))
+
+(DEFMACRO RECORD-CREATE (RECORD &REST KEYWORD-PAIRS)
+   (LET ((IL-RECORD (INTERN (STRING RECORD)
+                           IL:*INTERLISP-PACKAGE*)))
+        `(IL:|create| ,IL-RECORD
+                ,@(WITH-COLLECTION (DO ((KEYWORD KEYWORD-PAIRS (CDDR KEYWORD))
+                                        (VALUE (CDR KEYWORD-PAIRS)
+                                               (CDDR VALUE))
+                                        KEYWORD-SYMBOL)
+                                       ((NULL KEYWORD))
+                                     (SETQ KEYWORD-SYMBOL (INTERN (STRING (CAR KEYWORD))
+                                                                 IL:*INTERLISP-PACKAGE*))
+                                     (COLLECT KEYWORD-SYMBOL)
+                                     (IF (NOT (MEMBER KEYWORD-SYMBOL '(IL:USING IL:COPYING
+                                                                         IL:REUSING IL:SMASHING
+                                                                       )
+                                                     :TEST
+                                                     #'EQ))
+                                         (COLLECT 'IL:_))
+                                     (COLLECT (CAR VALUE)))))))
+
+(DEFSETF RECORD-FETCH SETF-FETCH)
+
+(DEFSETF RECORD-FFETCH SETF-FFETCH)
+
+
+
+(IL:* IL:|;;| "An alternate version of the above")
+
+
+(DEFDEFINER DEFINE-RECORD IL:STRUCTURES (RECORD-NAME INTERLISP-RECORD-NAME &KEY (CONC-NAME NIL 
+                                                                                          CONC-NAME-P
+                                                                                           )
+                                                   (CONSTRUCTOR NIL CONSTRUCTOR-P)
+                                                   (PREDICATE NIL PREDICATE-P)
+                                                   (FAST-ACCESSORS NIL)
+                                                   (PACKAGE *PACKAGE*))
+   (IF (NOT (PACKAGEP PACKAGE))
+       (SETQ PACKAGE (FIND-PACKAGE PACKAGE)))
+   (SETQ CONC-NAME (IF CONC-NAME-P
+                       (IF CONC-NAME
+                           (STRING CONC-NAME)
+                           "")
+                       (CONCATENATE 'STRING (STRING RECORD-NAME)
+                              "-")))
+   (LET
+    ((DECLARATION (IL:RECLOOK INTERLISP-RECORD-NAME))
+     (FIELD-NAMES (IL:RECORDFIELDNAMES INTERLISP-RECORD-NAME)))
+    (IF (NULL DECLARATION)
+        (ERROR "Record ~s not yet defined." INTERLISP-RECORD-NAME))
+    `(EVAL-WHEN
+      (COMPILE LOAD EVAL)
+      ,@(MAPCAN #'(LAMBDA (FIELD-NAME)
+                         (WHEN FIELD-NAME
+                             (LET ((NEW-NAME (INTERN (CONCATENATE 'STRING CONC-NAME (STRING 
+                                                                                           FIELD-NAME
+                                                                                           ))
+                                                    PACKAGE)))
+                                  `((SETF (MACRO-FUNCTION ',NEW-NAME)
+                                          'RECORD-ACCESS-MACRO)
+                                    (LISP::SET-SHARED-SETF-INVERSE ',NEW-NAME 
+                                           'SETF-RECORD-ACCESS-MACRO)
+                                    (SETF (GET ',NEW-NAME :SLOT-INFO)
+                                          ',`((,INTERLISP-RECORD-NAME ,FIELD-NAME)
+                                              ,FAST-ACCESSORS))))))
+               FIELD-NAMES)
+      ,@(LET ((NEW-NAME (IF PREDICATE-P
+                            PREDICATE
+                            (INTERN (CONCATENATE 'STRING (STRING RECORD-NAME)
+                                           "-P")
+                                   PACKAGE))))
+             (WHEN (AND NEW-NAME (OR (EQ (CAR DECLARATION)
+                                         'IL:DATATYPE)
+                                     (FIND-IF #'(LAMBDA (CLAUSE)
+                                                       (AND (CONSP CLAUSE)
+                                                            (OR (EQ (CAR CLAUSE)
+                                                                    'IL:TYPE?)
+                                                                (EQ (CAR CLAUSE)
+                                                                    'IL:|type?|))))
+                                            DECLARATION)))
+                 `((SETF (MACRO-FUNCTION ',NEW-NAME)
+                         'RECORD-PREDICATE-MACRO)
+                   (SETF (GET ',NEW-NAME :TYPE-INFO)
+                         ',INTERLISP-RECORD-NAME))))
+      ,@(LET ((NEW-NAME (IF CONSTRUCTOR-P
+                            CONSTRUCTOR
+                            (INTERN (CONCATENATE 'STRING "MAKE-" (STRING RECORD-NAME))
+                                   PACKAGE))))
+             (WHEN (AND NEW-NAME (OR (NOT (MEMBER (CAR DECLARATION)
+                                                 '(IL:BLOCKRECORD IL:ACCESSFNS IL:ATOMRECORD)
+                                                 :TEST
+                                                 #'EQ))
+                                     (FIND-IF #'(LAMBDA (CLAUSE)
+                                                       (IF (CONSP CLAUSE)
+                                                           (OR (EQ (CAR CLAUSE)
+                                                                   'IL:CREATE)
+                                                               (EQ (CAR CLAUSE)
+                                                                   'IL:|create|))
+                                                           (EQ CLAUSE INTERLISP-RECORD-NAME)))
+                                            (CDDR DECLARATION))))
+                 `((SETF (MACRO-FUNCTION ',NEW-NAME)
+                         'RECORD-CONSTRUCTOR-MACRO)
+                   (SETF (GET ',NEW-NAME :FIELD-INFO)
+                         '(,INTERLISP-RECORD-NAME ,FIELD-NAMES))))))))
+
+(DEFUN RECORD-ACCESS-MACRO (FORM &OPTIONAL ENV)
+   (DECLARE (IGNORE ENV))
+   (DESTRUCTURING-BIND (SPECIFIER FAST-ACCESSOR-P)
+          (OR (GET (CAR FORM)
+                   :SLOT-INFO)
+              (ERROR "No slot information cached."))
+          (IF FAST-ACCESSOR-P
+              `(IL:|ffetch| ,SPECIFIER IL:|of| ,(SECOND FORM))
+              `(IL:|fetch| ,SPECIFIER IL:|of| ,(SECOND FORM)))))
+
+(LISP::DEFINE-SHARED-SETF-MACRO SETF-RECORD-ACCESS-MACRO ACCESSOR (DATUM) (NEW-VALUE)
+   (DESTRUCTURING-BIND (SPECIFIER FAST-ACCESSOR-P)
+          (OR (GET ACCESSOR :SLOT-INFO)
+              (ERROR "No slot information cached."))
+          (IF FAST-ACCESSOR-P
+              `(IL:|freplace| ,SPECIFIER IL:|of| ,DATUM IL:|with| ,NEW-VALUE)
+              `(IL:|replace| ,SPECIFIER IL:|of| ,DATUM IL:|with| ,NEW-VALUE))))
+
+(DEFUN RECORD-PREDICATE-MACRO (FORM &OPTIONAL ENV)
+   (DECLARE (IGNORE ENV))
+   `(IL:|type?| ,(OR (GET (CAR FORM)
+                              :TYPE-INFO)
+                         (ERROR "No type information cached."))
+           ,(SECOND FORM)))
+
+(DEFUN RECORD-CONSTRUCTOR-MACRO (FORM &OPTIONAL ENV)
+   (DECLARE (IGNORE ENV))
+   (DESTRUCTURING-BIND (TYPE FIELD-NAMES)
+          (OR (GET (CAR FORM)
+                   :FIELD-INFO)
+              (ERROR "No field information cached."))
+          `(IL:|create| ,TYPE
+                  ,@(WITH-COLLECTION (DO* ((KEYWORD (CDR FORM)
+                                                  (CDDR KEYWORD))
+                                           (KEYWORD-SYMBOL (CAR KEYWORD)
+                                                  (CAR KEYWORD))
+                                           (VALUE (CADR KEYWORD)
+                                                  (CADR KEYWORD))
+                                           RESERVED-WORD)
+                                          ((NULL KEYWORD))
+                                        (SETQ RESERVED-WORD
+                                              (CAR (MEMBER KEYWORD-SYMBOL
+                                                          '(IL:USING IL:COPYING IL:REUSING
+                                                              IL:SMASHING)
+                                                          :TEST
+                                                          'STRING=)))
+                                        (COLLECT (OR RESERVED-WORD (CAR (MEMBER KEYWORD-SYMBOL 
+                                                                               FIELD-NAMES :TEST
+                                                                               'STRING=))))
+                                        (IF (NOT RESERVED-WORD)
+                                            (COLLECT 'IL:_))
+                                        (COLLECT VALUE))))))
+
+(IL:PUTPROPS IL:XCL-EXTRAS IL:FILETYPE :COMPILE-FILE)
+
+(IL:PUTPROPS IL:XCL-EXTRAS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL"))
+(IL:PUTPROPS IL:XCL-EXTRAS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 1991 1993))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/XCL-EXTRAS.DFASL b/CLTL2/XCL-EXTRAS.DFASL
new file mode 100644
index 00000000..19a5a741
Binary files /dev/null and b/CLTL2/XCL-EXTRAS.DFASL differ
diff --git a/CLTL2/XCL-PACKAGE b/CLTL2/XCL-PACKAGE
new file mode 100644
index 00000000..7da2c735
--- /dev/null
+++ b/CLTL2/XCL-PACKAGE
@@ -0,0 +1,321 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE (DEFPACKAGE "XCL" (USE)))
+(IL:FILECREATED "31-Mar-92 09:32:35" IL:{DSK}<usr>local>lde>lispcore>sources>XCL-PACKAGE.;6 21638  
+
+      IL:changes IL:to%:  (IL:VARS IL:XCL-PACKAGECOMS)
+
+      IL:previous IL:date%: "17-Mar-92 22:08:22" IL:{DSK}<usr>local>lde>lispcore>sources>XCL-PACKAGE.;4
+)
+
+
+(IL:* ; "
+Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(IL:PRETTYCOMPRINT IL:XCL-PACKAGECOMS)
+
+(IL:RPAQQ IL:XCL-PACKAGECOMS 
+          (
+
+(IL:* IL:;;; "Setting up the XCL package.")
+
+           (IL:FUNCTIONS LISP::DEFECT-FROM-IL-TO-XCL LISP::CHECK-ALL)
+           (IL:VARIABLES LISP::FUTURE-CITIZENS-OF-XCL)
+           [IL:DECLARE%: IL:DONTEVAL@LOAD IL:DOCOPY
+                  (IL:P 
+                        (IL:* IL:;; "New exports from XCL should go in the EXPORT clause here")
+
+                        
+                        (IL:* IL:;; "Symbols imported from COMMON-LISP are strings below")
+
+                        (DEFPACKAGE "XEROX-COMMON-LISP" (:USE "LISP" "CONDITIONS")
+                               (:NICKNAMES "XCL")
+                               (:PREFIX-NAME "XCL")
+                               (:IMPORT-FROM "COMMON-LISP" "DEFPACKAGE" "SIMPLE-WARNING" 
+                                      "TWO-WAY-STREAM-INPUT-STREAM" "SIMPLE-ERROR" "WARNING" 
+                                      "ECHO-STREAM-INPUT-STREAM" "SIMPLE-CONDITION" 
+                                      "STORAGE-CONDITION" "CONTROL-ERROR" "UNBOUND-VARIABLE" 
+                                      "STREAM-ERROR" "ROW-MAJOR-AREF" "SIMPLE-TYPE-ERROR" 
+                                      "ECHO-STREAM-OUTPUT-STREAM" "FLOATING-POINT-OVERFLOW" "SIGNAL"
+                                      "OPEN-STREAM-P" "BROADCAST-STREAM-STREAMS" "PACKAGE-ERROR" 
+                                      "STRING-STREAM-P" "DESTRUCTURING-BIND" "END-OF-FILE" 
+                                      "FLOATING-POINT-UNDERFLOW" "ABORT" "SYNONYM-STREAM-P" 
+                                      "SYNONYM-STREAM-SYMBOL" "PROGRAM-ERROR" 
+                                      "CONCATENATED-STREAM-STREAMS" "TWO-WAY-STREAM-OUTPUT-STREAM" 
+                                      "TYPE-ERROR" "ARITHMETIC-ERROR" "CELL-ERROR" "FILE-ERROR" 
+                                      "SERIOUS-CONDITION" "DIVISION-BY-ZERO" "UNDEFINED-FUNCTION" 
+                                      "SIMPLE-STRING" "CONDITION" "DELETE-PACKAGE" "MAKE-VECTOR")
+                               (:IMPORT-FROM "LISP" "SIMPLE-STRING")
+                               (:EXPORT "*BREAK-ON-SIGNALS*" "*CURRENT-CONDITION*" 
+                                      "*DEBUGGER-PROMPT*" "*DEFAULT-PROFILE*" "*EVAL-FUNCTION*" 
+                                      "*EXEC-PROMPT*" "*LONG-SITE-NAME*" "*PRINT-STRUCTURE*" 
+                                      "*PROFILE*" "*SHORT-SITE-NAME*" "*TRACE-IO*" "*TRACE-LENGTH*" 
+                                      "*TRACE-LEVEL*" "*TRACE-VERBOSE*" "ADVISE-FUNCTION" 
+                                      "ADVISED-FUNCTIONS" "ARGLIST" "ARITHMETIC-ERROR" 
+                                      "ARITHMETIC-ERROR-OPERANDS" "ARITHMETIC-ERROR-OPERATION" 
+                                      "ARRAY-SPACE-FULL" "ASSERTION-FAILED" 
+                                      "ASSERTION-FAILED-FORMAT-ARGUMENTS" 
+                                      "ASSERTION-FAILED-FORMAT-STRING" "ATTEMPT-TO-CHANGE-CONSTANT" 
+                                      "ATTEMPT-TO-CHANGE-CONSTANT-NAME" "ATTEMPT-TO-RPLAC-NIL" 
+                                      "ATTEMPT-TO-RPLAC-NIL-NAME" "BAD-PROCEED-CASE" 
+                                      "BAD-PROCEED-CASE-NAME" "BROADCAST-STREAM-P" 
+                                      "BROADCAST-STREAM-STREAMS" "COLLECT" "COMPILE-DEFINER" 
+                                      "COMPILE-FORM" "COMPUTE-RESTARTS" "CONCATENATED-STREAM-P" 
+                                      "CONCATENATED-STREAM-STREAMS" "CONTINUE" "CONTROL-E-INTERRUPT"
+                                      "CONTROL-E-INTERRUPT-FUNCTION" "COPY-PROFILE" 
+                                      "CREATE-TRACE-WINDOW" "DATA-TYPES-EXHAUSTED" "DEFADVICE" 
+                                      "DEFINE-FILE-ENVIRONMENT" "DEFINE-RECORD" "DEFINER" 
+                                      "DEFPROFILE" "DELETED-PACKAGE-P" "DEVICE-ERROR" 
+                                      "DEVICE-ERROR-DEVICE" "DIVISION-BY-ZERO" "DO-INTERNAL-SYMBOLS"
+                                      "ECHO-STREAM-INPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM" 
+                                      "ECHO-STREAM-P" "ESCAPE-COLONS-PROCEED" "EXPORT-CONFLICT" 
+                                      "EXPORT-CONFLICT-EXPORTED-SYMBOLS" "EXPORT-CONFLICT-PACAKGES" 
+                                      "EXPORT-MISSING" "EXPORT-MISSING-SYMBOLS" "FALSE" 
+                                      "FILE-ENVIRONMENTS" "FILE-ERROR" "FILE-ERROR-PATHNAME" 
+                                      "FILE-NOT-FOUND" "FILE-NOT-FOUND-PATHNAME" "FILE-WONT-OPEN" 
+                                      "FILE-WONT-OPEN-PATHNAME" "FIND-PROFILE" "FIND-RESTART" 
+                                      "FLOATING-OVERFLOW" "FLOATING-OVERFLOW-OPERANDS" 
+                                      "FLOATING-OVERFLOW-OPERATION" "FLOATING-POINT-OVERFLOW" 
+                                      "FLOATING-POINT-UNDERFLOW" "FLOATING-UNDERFLOW" 
+                                      "FLOATING-UNDERFLOW-OPERANDS" "FLOATING-UNDERFLOW-OPERATION" 
+                                      "FOLLOW-SYNONYM-STREAMS" "FS-ERROR" "FS-PROTECTION-VIOLATION" 
+                                      "FS-RESOURCES-EXCEEDED" "HANDLER-CASE" "HASH-TABLE-FULL" 
+                                      "HASH-TABLE-FULL-TABLE" "IMPORT-CONFLICT" "IMPORT-PROCEED" 
+                                      "INNER" "INVALID-PATHNAME" "INVALID-PATHNAME-PATHNAME" 
+                                      "INVOKE-DEBUGGER" "INVOKE-RESTART" 
+                                      "INVOKE-RESTART-INTERACTIVELY" "LIST-ALL-PROFILES" 
+                                      "MAKE-EXTERNAL-PROCEED" "MAKE-INTERNAL-PROCEED" "MAKE-PROFILE"
+                                      "MISSING-EXTERNAL-SYMBOL" "MISSING-EXTERNAL-SYMBOL-NAME" 
+                                      "MISSING-EXTERNAL-SYMBOL-PACKAGE" "MISSING-PACKAGE" 
+                                      "MISSING-PACKAGE-EXTERNAL" "MISSING-PACKAGE-PACKAGE-NAME" 
+                                      "MISSING-PACKAGE-SYMBOL-NAME" "MUFFLE-WARNING" "NAMED-PROGN" 
+                                      "NEW-PACKAGE-PROCEED" "ONCE-ONLY" "OPEN-STREAM-P" "PACK" 
+                                      "PACK*" "PACKAGE-ERROR" "PACKAGE-ERROR-PACKAGE" 
+                                      "PACKAGE-PREFIX" "PATHNAME-ERROR" "PATHNAME-ERROR-PATHNAME" 
+                                      "PKG-GOTO" "PREFER-CLSYM-PROCEED" "PREFER-ILSYM-PROCEED" 
+                                      "PROFILE-NAME" "PROFILE-P" "PROFILES" "PROGRAM-ERROR" 
+                                      "READ-CONFLICT" "READ-CONFLICT-NAME" "READ-CONFLICT-PACKAGES" 
+                                      "READVISE-FUNCTION" "REBREAK-FUNCTION" "RECORD-CREATE" 
+                                      "RECORD-FETCH" "RECORD-FFETCH" "REINSTALL-ADVICE" "RESTART" 
+                                      "RESTART-BIND" "RESTART-CASE" "RESTART-NAME" "RESTORE-PROFILE"
+                                      "RETURN-CLSYM-PROCEED" "RETURN-ILSYM-PROCEED" "ROW-MAJOR-AREF"
+                                      "SAVE-PROFILE" "SET-DEFAULT-EXEC-TYPE" "SET-EXEC-TYPE" 
+                                      "SHADOW-USE-CONFLICTS-PROCEED" "SHADOWING-IMPORT-PROCEED" 
+                                      "SIMPLE-DEVICE-ERROR" "SIMPLE-DEVICE-ERROR-DEVICE" 
+                                      "SIMPLE-DEVICE-ERROR-MESSAGE" "SIMPLE-STRING" 
+                                      "SIMPLE-TYPE-ERROR" "SIMPLE-TYPE-ERROR-CULPRIT" 
+                                      "SIMPLE-TYPE-ERROR-EXPECTED-TYPE" "STORAGE-EXHAUSTED" 
+                                      "STREAM-NOT-OPEN" "STREAM-NOT-OPEN-STREAM" "STRING-STREAM-P" 
+                                      "SYMBOL-COLON-ERROR" "SYMBOL-CONFLICT" 
+                                      "SYMBOL-CONFLICT-SYMBOLS" "SYMBOL-HT-FULL" 
+                                      "SYMBOL-NAME-TOO-LONG" "SYMBOL-NAME-TOO-LONG-STREAM" 
+                                      "SYNONYM-STREAM-P" "SYNONYM-STREAM-SYMBOL" "TRACE-FUNCTION" 
+                                      "TWO-WAY-STREAM-INPUT-STREAM" "TWO-WAY-STREAM-OUTPUT-STREAM" 
+                                      "TWO-WAY-STREAM-P" "TYPE-ERROR" "TYPE-ERROR-DATUM" 
+                                      "TYPE-ERROR-EXPECTED-TYPE" "TYPE-MISMATCH" 
+                                      "TYPE-MISMATCH-EXPECTED-TYPE" "TYPE-MISMATCH-MESSAGE" 
+                                      "TYPE-MISMATCH-VALUE" "UGLY-SYMBOL-PROCEED" "UNADVISE-FUNCTION"
+                                      "UNBREAK-FUNCTION" "UNINTERN-CONFLICT" 
+                                      "UNINTERN-CONFLICT-SYMBOL" "UNINTERN-PROCEED" 
+                                      "UNINTERN-USEE-PROCEED" "UNINTERN-USER-PROCEED" "USE-CONFLICT"
+                                      "USE-CONFLICT-USED-PACKAGE" "WITH-COLLECTION" "WITH-PROFILE" 
+                                      "WITH-SIMPLE-RESTART"))
+                        (IL:MAPC LISP::FUTURE-CITIZENS-OF-XCL 'LISP::DEFECT-FROM-IL-TO-XCL)
+                        (LISP::CHECK-ALL)
+                        
+                        (IL:* IL:;; 
+                      "Handle a few random symbols that need to be shared with COMMON-LISP")
+
+                        (IL:for IL:S IL:in '(DEFPACKAGE DELETE-PACKAGE)
+                               IL:do
+                               (IMPORT IL:S IL:*COMMON-LISP-PACKAGE*)
+                               (EXPORT IL:S IL:*COMMON-LISP-PACKAGE*]
+           
+           (IL:* IL:;; "Arrange for the proper makefile environment")
+
+           (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                  IL:XCL-PACKAGE)))
+
+
+
+(IL:* IL:;;; "Setting up the XCL package.")
+
+
+(DEFUN LISP::DEFECT-FROM-IL-TO-XCL (LISP::NAME)
+   (CL::NATURALIZE LISP::NAME (FIND-PACKAGE 'LISP::IL)
+          (FIND-PACKAGE 'LISP::XCL)))
+
+(DEFUN LISP::CHECK-ALL ()                       (IL:* IL:; "Edited 17-Mar-92 22:07 by jrb:")
+   (LET ((LISP::XCLP (FIND-PACKAGE "XCL"))
+         LISP::TOO-MANY?)
+        (DOLIST (LISP::X LISP::FUTURE-CITIZENS-OF-XCL T)
+
+            (IL:* IL:;; 
+          "This test is bogus now, as lots of symbols in XCL are homed in COMMON-LISP")
+
+            (IL:* IL:;; "(LET* ((S (INTERN X XCLP)) (P (SYMBOL-PACKAGE S))) (IF (NOT (EQ P XCLP)) (FORMAT T %"~S ~S~%%%%%" S P)))")
+
+            [LET [(LISP::SL (MAPCAN [IL:FUNCTION (LAMBDA (PACKAGE)
+                                                        (MULTIPLE-VALUE-BIND (SYMBOL LISP::WHERE)
+                                                               (FIND-SYMBOL LISP::X PACKAGE)
+                                                               (AND SYMBOL (EQ LISP::WHERE :EXTERNAL)
+                                                                    (LIST SYMBOL]
+                                   '("IL" "XCL" "CL"]
+                 (IF (NOT (CASE (LENGTH LISP::SL)
+                              (2 (EQ (FIRST LISP::SL)
+                                     (SECOND LISP::SL)))
+                              (3 (AND (EQ (FIRST LISP::SL)
+                                          (SECOND LISP::SL))
+                                      (EQ (SECOND LISP::SL)
+                                          (THIRD LISP::SL))))
+                              (T T)))
+                     (PROGN (SETQ LISP::TOO-MANY? T)
+                            (PRINT LISP::SL)))])
+        (AND LISP::TOO-MANY? (ERROR "Multiple versions of the above symbols exist~%%"))))
+
+(DEFPARAMETER LISP::FUTURE-CITIZENS-OF-XCL
+   '(
+     (IL:* IL:;; "new definers")
+
+     "DEFCOMMAND" "DEFDEFINER" "DEFGLOBALPARAMETER" "DEFGLOBALVAR" "DEFINE-CONDITION" 
+     "DEFINE-PROCEED-FUNCTION" "DEFINLINE" "DEFOPTIMIZER" "DEFPACKAGE" "DEF-DEFINE-TYPE" 
+     "*DEFINITION-HASH-TABLE*" 
+
+     (IL:* IL:;; "for UNDO")
+
+     "DEFINE-UNDOABLE-MODIFY-MACRO" "UNDOABLY" "UNDOABLY-SETF" "DEFINE-SPECIAL-FORM" 
+
+     (IL:* IL:;; "for the EXEC")
+
+     "*CURRENT-EVENT*" "EXEC-ID" "*PER-EXEC-VARIABLES*" "*EXEC-MAKE-UNDOABLE-P*" "EXEC-FORMAT" 
+     "EXEC-EVAL" "EXEC" "ADD-EXEC" "EXEC-VALUE-OF" 
+
+     (IL:* IL:;; "for the debugger")
+
+     "DEBUGGER" "PRINT-BACKTRACE" "*DEBUGGER-MENU-ITEMS*" "ENTER-DEBUGGER-P" 
+     "*DEBUGGER-ENTRY-POINTS*" "HELP" "UNBREAK" "BREAK-FUNCTION" "*TRACE-DEPTH*" 
+
+     (IL:* IL:;; "others in alphabetical order")
+
+     "&CONTEXT" "*CLTL2-PEDANTIC*" "*DEFAULT-PUSH-EXTENSION-SIZE*" "*PREFERRED-READING-SYMBOLS*" 
+     "*TOTAL-PACKAGES-LIMIT*" "ABORT" "ARRAY-NEEDS-INDIRECTION-P" "ASET" "BIT-ARRAY-P" "CATCH-ABORT"
+     "CELL-ERROR" "CELL-ERROR-NAME" "COMPUTE-PROCEED-CASES" "CONDITION" "CONDITION-BIND" 
+     "CONDITION-CASE" "CONDITION-HANDLER" "CONDITION-REPORTER" "CONTROL-ERROR" "COPY-ARRAY" "DEBUG" 
+     "DEFAULT-PROCEED-REPORT" "DEFAULT-PROCEED-TEST" "DELETE-PACKAGE" "DESTRUCTURING-BIND" 
+     "DESTRUCTURING-SETQ" "DISPLACED-ARRAY-P" "DO-LOCAL-SYMBOLS" "END-OF-FILE" "END-OF-FILE-STREAM" 
+     "EQUAL-DIMENSIONS-P" "EXTENDABLE-ARRAY-P" "FILL-ARRAY" "FILL-VECTOR" "FIND-PROCEED-CASE" 
+     "GLOBAL" "GLOBALIZE" "HANDLER-BIND" "IGNORE-ERRORS" "ILLEGAL-GO" "ILLEGAL-GO-TAG" 
+     "ILLEGAL-RETURN" "ILLEGAL-RETURN-TAG" "ILLEGAL-THROW" "ILLEGAL-THROW-TAG" "INVOKE-PROCEED-CASE"
+     "MAKE-CONDITION" "MAKE-VECTOR" "OPTIMIZERS" "PARSE-BODY" "PROCEED" "PROCEED-CASE" 
+     "PROCEED-CASE-NAME" "READ-ERROR" "READ-ERROR-STREAM" "READ-ONLY-ARRAY-P" "REMOVE-COMMENTS" 
+     "SERIOUS-CONDITION" "SHADOWING-USE-PACKAGE" "SIGNAL" "SIMPLE-ARRAY-P" "SIMPLE-BREAK" 
+     "SIMPLE-BREAK-FORMAT-ARGUMENTS" "SIMPLE-BREAK-FORMAT-STRING" "SIMPLE-CONDITION" 
+     "SIMPLE-CONDITION-FORMAT-ARGUMENTS" "SIMPLE-CONDITION-FORMAT-STRING" "SIMPLE-ERROR" 
+     "SIMPLE-ERROR-FORMAT-ARGUMENTS" "SIMPLE-ERROR-FORMAT-STRING" "SIMPLE-WARNING" 
+     "SIMPLE-WARNING-FORMAT-ARGUMENTS" "SIMPLE-WARNING-FORMAT-STRING" "STACK-OVERFLOW" 
+     "STORAGE-CONDITION" "STORE-VALUE" "STREAM-ERROR" "STREAM-ERROR-STREAM" "STRING-ARRAY-P" "TRUE" 
+     "UNBOUND-VARIABLE" "UNBOUND-VARIABLE-NAME" "UNDEFINED-FUNCTION" "UNDEFINED-FUNCTION-NAME" 
+     "USE-VALUE" "VECTOR-LENGTH" "WALK-FORM" "WALK-FORM-INTERNAL" "WALK-TEMPLATE" "WARNING")
+   "A list of names retroactively placed in XCL; do not add to it.")
+(IL:DECLARE%: IL:DONTEVAL@LOAD IL:DOCOPY 
+
+
+(IL:* IL:;; "New exports from XCL should go in the EXPORT clause here")
+
+
+
+(IL:* IL:;; "Symbols imported from COMMON-LISP are strings below")
+
+
+(DEFPACKAGE "XEROX-COMMON-LISP" (:USE "LISP" "CONDITIONS")
+       (:NICKNAMES "XCL")
+       (:PREFIX-NAME "XCL")
+       (:IMPORT-FROM "COMMON-LISP" "DEFPACKAGE" "SIMPLE-WARNING" "TWO-WAY-STREAM-INPUT-STREAM" 
+              "SIMPLE-ERROR" "WARNING" "ECHO-STREAM-INPUT-STREAM" "SIMPLE-CONDITION" 
+              "STORAGE-CONDITION" "CONTROL-ERROR" "UNBOUND-VARIABLE" "STREAM-ERROR" "ROW-MAJOR-AREF"
+              "SIMPLE-TYPE-ERROR" "ECHO-STREAM-OUTPUT-STREAM" "FLOATING-POINT-OVERFLOW" "SIGNAL" 
+              "OPEN-STREAM-P" "BROADCAST-STREAM-STREAMS" "PACKAGE-ERROR" "STRING-STREAM-P" 
+              "DESTRUCTURING-BIND" "END-OF-FILE" "FLOATING-POINT-UNDERFLOW" "ABORT" 
+              "SYNONYM-STREAM-P" "SYNONYM-STREAM-SYMBOL" "PROGRAM-ERROR" 
+              "CONCATENATED-STREAM-STREAMS" "TWO-WAY-STREAM-OUTPUT-STREAM" "TYPE-ERROR" 
+              "ARITHMETIC-ERROR" "CELL-ERROR" "FILE-ERROR" "SERIOUS-CONDITION" "DIVISION-BY-ZERO" 
+              "UNDEFINED-FUNCTION" "SIMPLE-STRING" "CONDITION" "DELETE-PACKAGE" "MAKE-VECTOR")
+       (:IMPORT-FROM "LISP" "SIMPLE-STRING")
+       (:EXPORT "*BREAK-ON-SIGNALS*" "*CURRENT-CONDITION*" "*DEBUGGER-PROMPT*" "*DEFAULT-PROFILE*" 
+              "*EVAL-FUNCTION*" "*EXEC-PROMPT*" "*LONG-SITE-NAME*" "*PRINT-STRUCTURE*" "*PROFILE*" 
+              "*SHORT-SITE-NAME*" "*TRACE-IO*" "*TRACE-LENGTH*" "*TRACE-LEVEL*" "*TRACE-VERBOSE*" 
+              "ADVISE-FUNCTION" "ADVISED-FUNCTIONS" "ARGLIST" "ARITHMETIC-ERROR" 
+              "ARITHMETIC-ERROR-OPERANDS" "ARITHMETIC-ERROR-OPERATION" "ARRAY-SPACE-FULL" 
+              "ASSERTION-FAILED" "ASSERTION-FAILED-FORMAT-ARGUMENTS" "ASSERTION-FAILED-FORMAT-STRING"
+              "ATTEMPT-TO-CHANGE-CONSTANT" "ATTEMPT-TO-CHANGE-CONSTANT-NAME" "ATTEMPT-TO-RPLAC-NIL" 
+              "ATTEMPT-TO-RPLAC-NIL-NAME" "BAD-PROCEED-CASE" "BAD-PROCEED-CASE-NAME" 
+              "BROADCAST-STREAM-P" "BROADCAST-STREAM-STREAMS" "COLLECT" "COMPILE-DEFINER" 
+              "COMPILE-FORM" "COMPUTE-RESTARTS" "CONCATENATED-STREAM-P" "CONCATENATED-STREAM-STREAMS"
+              "CONTINUE" "CONTROL-E-INTERRUPT" "CONTROL-E-INTERRUPT-FUNCTION" "COPY-PROFILE" 
+              "CREATE-TRACE-WINDOW" "DATA-TYPES-EXHAUSTED" "DEFADVICE" "DEFINE-FILE-ENVIRONMENT" 
+              "DEFINE-RECORD" "DEFINER" "DEFPROFILE" "DELETED-PACKAGE-P" "DEVICE-ERROR" 
+              "DEVICE-ERROR-DEVICE" "DIVISION-BY-ZERO" "DO-INTERNAL-SYMBOLS" 
+              "ECHO-STREAM-INPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM" "ECHO-STREAM-P" 
+              "ESCAPE-COLONS-PROCEED" "EXPORT-CONFLICT" "EXPORT-CONFLICT-EXPORTED-SYMBOLS" 
+              "EXPORT-CONFLICT-PACAKGES" "EXPORT-MISSING" "EXPORT-MISSING-SYMBOLS" "FALSE" 
+              "FILE-ENVIRONMENTS" "FILE-ERROR" "FILE-ERROR-PATHNAME" "FILE-NOT-FOUND" 
+              "FILE-NOT-FOUND-PATHNAME" "FILE-WONT-OPEN" "FILE-WONT-OPEN-PATHNAME" "FIND-PROFILE" 
+              "FIND-RESTART" "FLOATING-OVERFLOW" "FLOATING-OVERFLOW-OPERANDS" 
+              "FLOATING-OVERFLOW-OPERATION" "FLOATING-POINT-OVERFLOW" "FLOATING-POINT-UNDERFLOW" 
+              "FLOATING-UNDERFLOW" "FLOATING-UNDERFLOW-OPERANDS" "FLOATING-UNDERFLOW-OPERATION" 
+              "FOLLOW-SYNONYM-STREAMS" "FS-ERROR" "FS-PROTECTION-VIOLATION" "FS-RESOURCES-EXCEEDED" 
+              "HANDLER-CASE" "HASH-TABLE-FULL" "HASH-TABLE-FULL-TABLE" "IMPORT-CONFLICT" 
+              "IMPORT-PROCEED" "INNER" "INVALID-PATHNAME" "INVALID-PATHNAME-PATHNAME" 
+              "INVOKE-DEBUGGER" "INVOKE-RESTART" "INVOKE-RESTART-INTERACTIVELY" "LIST-ALL-PROFILES" 
+              "MAKE-EXTERNAL-PROCEED" "MAKE-INTERNAL-PROCEED" "MAKE-PROFILE" 
+              "MISSING-EXTERNAL-SYMBOL" "MISSING-EXTERNAL-SYMBOL-NAME" 
+              "MISSING-EXTERNAL-SYMBOL-PACKAGE" "MISSING-PACKAGE" "MISSING-PACKAGE-EXTERNAL" 
+              "MISSING-PACKAGE-PACKAGE-NAME" "MISSING-PACKAGE-SYMBOL-NAME" "MUFFLE-WARNING" 
+              "NAMED-PROGN" "NEW-PACKAGE-PROCEED" "ONCE-ONLY" "OPEN-STREAM-P" "PACK" "PACK*" 
+              "PACKAGE-ERROR" "PACKAGE-ERROR-PACKAGE" "PACKAGE-PREFIX" "PATHNAME-ERROR" 
+              "PATHNAME-ERROR-PATHNAME" "PKG-GOTO" "PREFER-CLSYM-PROCEED" "PREFER-ILSYM-PROCEED" 
+              "PROFILE-NAME" "PROFILE-P" "PROFILES" "PROGRAM-ERROR" "READ-CONFLICT" 
+              "READ-CONFLICT-NAME" "READ-CONFLICT-PACKAGES" "READVISE-FUNCTION" "REBREAK-FUNCTION" 
+              "RECORD-CREATE" "RECORD-FETCH" "RECORD-FFETCH" "REINSTALL-ADVICE" "RESTART" 
+              "RESTART-BIND" "RESTART-CASE" "RESTART-NAME" "RESTORE-PROFILE" "RETURN-CLSYM-PROCEED" 
+              "RETURN-ILSYM-PROCEED" "ROW-MAJOR-AREF" "SAVE-PROFILE" "SET-DEFAULT-EXEC-TYPE" 
+              "SET-EXEC-TYPE" "SHADOW-USE-CONFLICTS-PROCEED" "SHADOWING-IMPORT-PROCEED" 
+              "SIMPLE-DEVICE-ERROR" "SIMPLE-DEVICE-ERROR-DEVICE" "SIMPLE-DEVICE-ERROR-MESSAGE" 
+              "SIMPLE-STRING" "SIMPLE-TYPE-ERROR" "SIMPLE-TYPE-ERROR-CULPRIT" 
+              "SIMPLE-TYPE-ERROR-EXPECTED-TYPE" "STORAGE-EXHAUSTED" "STREAM-NOT-OPEN" 
+              "STREAM-NOT-OPEN-STREAM" "STRING-STREAM-P" "SYMBOL-COLON-ERROR" "SYMBOL-CONFLICT" 
+              "SYMBOL-CONFLICT-SYMBOLS" "SYMBOL-HT-FULL" "SYMBOL-NAME-TOO-LONG" 
+              "SYMBOL-NAME-TOO-LONG-STREAM" "SYNONYM-STREAM-P" "SYNONYM-STREAM-SYMBOL" 
+              "TRACE-FUNCTION" "TWO-WAY-STREAM-INPUT-STREAM" "TWO-WAY-STREAM-OUTPUT-STREAM" 
+              "TWO-WAY-STREAM-P" "TYPE-ERROR" "TYPE-ERROR-DATUM" "TYPE-ERROR-EXPECTED-TYPE" 
+              "TYPE-MISMATCH" "TYPE-MISMATCH-EXPECTED-TYPE" "TYPE-MISMATCH-MESSAGE" 
+              "TYPE-MISMATCH-VALUE" "UGLY-SYMBOL-PROCEED" "UNADVISE-FUNCTION" "UNBREAK-FUNCTION" 
+              "UNINTERN-CONFLICT" "UNINTERN-CONFLICT-SYMBOL" "UNINTERN-PROCEED" 
+              "UNINTERN-USEE-PROCEED" "UNINTERN-USER-PROCEED" "USE-CONFLICT" 
+              "USE-CONFLICT-USED-PACKAGE" "WITH-COLLECTION" "WITH-PROFILE" "WITH-SIMPLE-RESTART"))
+
+(IL:MAPC LISP::FUTURE-CITIZENS-OF-XCL 'LISP::DEFECT-FROM-IL-TO-XCL)
+
+(LISP::CHECK-ALL)
+
+
+(IL:* IL:;; "Handle a few random symbols that need to be shared with COMMON-LISP")
+
+
+(IL:for IL:S IL:in '(DEFPACKAGE DELETE-PACKAGE) IL:do (IMPORT IL:S 
+                                                                         IL:*COMMON-LISP-PACKAGE*)
+                                                              (EXPORT IL:S IL:*COMMON-LISP-PACKAGE*))
+)
+
+
+
+(IL:* IL:;; "Arrange for the proper makefile environment")
+
+
+(IL:PUTPROPS IL:XCL-PACKAGE IL:FILETYPE IL:COMPILE-FILE)
+
+(IL:PUTPROPS IL:XCL-PACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE
+                                                               (DEFPACKAGE "XCL" (:USE))))
+(IL:PUTPROPS IL:XCL-PACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992))
+(IL:DECLARE%: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/XCL-PACKAGE.LCOM b/CLTL2/XCL-PACKAGE.LCOM
new file mode 100644
index 00000000..fcd48af3
--- /dev/null
+++ b/CLTL2/XCL-PACKAGE.LCOM
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE (DEFPACKAGE "XCL" (USE)))
(IL:FILECREATED "22-Nov-93 16:28:36" ("compiled on " 
IL:{DSK}<king>export>lispcore>sources>CLTL2>XCL-PACKAGE.;1) "11-Nov-93 16:58:33" IL:bcompl'd IL:in 
"Medley 11-Nov-93 ..." IL:dated "11-Nov-93 17:07:44")
(IL:FILECREATED "31-Mar-92 09:32:35" IL:{DSK}<usr>local>lde>lispcore>sources>XCL-PACKAGE.;6 21638 
IL:changes IL:to%: (IL:VARS IL:XCL-PACKAGECOMS) IL:previous IL:date%: "17-Mar-92 22:08:22" 
IL:{DSK}<usr>local>lde>lispcore>sources>XCL-PACKAGE.;4)
(IL:PRETTYCOMPRINT IL:XCL-PACKAGECOMS)
(IL:RPAQQ IL:XCL-PACKAGECOMS ((IL:* IL:;;; "Setting up the XCL package.") (IL:FUNCTIONS 
CL::DEFECT-FROM-IL-TO-XCL CL::CHECK-ALL) (IL:VARIABLES CL::FUTURE-CITIZENS-OF-XCL) (IL:DECLARE%: 
IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:* IL:;; 
"New exports from XCL should go in the EXPORT clause here") (IL:* IL:;; 
"Symbols imported from COMMON-LISP are strings below") (DEFPACKAGE "XEROX-COMMON-LISP" (:USE "LISP" 
"CONDITIONS") (:NICKNAMES "XCL") (:PREFIX-NAME "XCL") (:IMPORT-FROM "COMMON-LISP" "DEFPACKAGE" 
"SIMPLE-WARNING" "TWO-WAY-STREAM-INPUT-STREAM" "SIMPLE-ERROR" "WARNING" "ECHO-STREAM-INPUT-STREAM" 
"SIMPLE-CONDITION" "STORAGE-CONDITION" "CONTROL-ERROR" "UNBOUND-VARIABLE" "STREAM-ERROR" 
"ROW-MAJOR-AREF" "SIMPLE-TYPE-ERROR" "ECHO-STREAM-OUTPUT-STREAM" "FLOATING-POINT-OVERFLOW" "SIGNAL" 
"OPEN-STREAM-P" "BROADCAST-STREAM-STREAMS" "PACKAGE-ERROR" "STRING-STREAM-P" "DESTRUCTURING-BIND" 
"END-OF-FILE" "FLOATING-POINT-UNDERFLOW" "ABORT" "SYNONYM-STREAM-P" "SYNONYM-STREAM-SYMBOL" 
"PROGRAM-ERROR" "CONCATENATED-STREAM-STREAMS" "TWO-WAY-STREAM-OUTPUT-STREAM" "TYPE-ERROR" 
"ARITHMETIC-ERROR" "CELL-ERROR" "FILE-ERROR" "SERIOUS-CONDITION" "DIVISION-BY-ZERO" 
"UNDEFINED-FUNCTION" "SIMPLE-STRING" "CONDITION" "DELETE-PACKAGE" "MAKE-VECTOR") (:IMPORT-FROM "LISP" 
"SIMPLE-STRING") (:EXPORT "*BREAK-ON-SIGNALS*" "*CURRENT-CONDITION*" "*DEBUGGER-PROMPT*" 
"*DEFAULT-PROFILE*" "*EVAL-FUNCTION*" "*EXEC-PROMPT*" "*LONG-SITE-NAME*" "*PRINT-STRUCTURE*" 
"*PROFILE*" "*SHORT-SITE-NAME*" "*TRACE-IO*" "*TRACE-LENGTH*" "*TRACE-LEVEL*" "*TRACE-VERBOSE*" 
"ADVISE-FUNCTION" "ADVISED-FUNCTIONS" "ARGLIST" "ARITHMETIC-ERROR" "ARITHMETIC-ERROR-OPERANDS" 
"ARITHMETIC-ERROR-OPERATION" "ARRAY-SPACE-FULL" "ASSERTION-FAILED" "ASSERTION-FAILED-FORMAT-ARGUMENTS"
 "ASSERTION-FAILED-FORMAT-STRING" "ATTEMPT-TO-CHANGE-CONSTANT" "ATTEMPT-TO-CHANGE-CONSTANT-NAME" 
"ATTEMPT-TO-RPLAC-NIL" "ATTEMPT-TO-RPLAC-NIL-NAME" "BAD-PROCEED-CASE" "BAD-PROCEED-CASE-NAME" 
"BROADCAST-STREAM-P" "BROADCAST-STREAM-STREAMS" "COLLECT" "COMPILE-DEFINER" "COMPILE-FORM" 
"COMPUTE-RESTARTS" "CONCATENATED-STREAM-P" "CONCATENATED-STREAM-STREAMS" "CONTINUE" 
"CONTROL-E-INTERRUPT" "CONTROL-E-INTERRUPT-FUNCTION" "COPY-PROFILE" "CREATE-TRACE-WINDOW" 
"DATA-TYPES-EXHAUSTED" "DEFADVICE" "DEFINE-FILE-ENVIRONMENT" "DEFINE-RECORD" "DEFINER" "DEFPROFILE" 
"DELETED-PACKAGE-P" "DEVICE-ERROR" "DEVICE-ERROR-DEVICE" "DIVISION-BY-ZERO" "DO-INTERNAL-SYMBOLS" 
"ECHO-STREAM-INPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM" "ECHO-STREAM-P" "ESCAPE-COLONS-PROCEED" 
"EXPORT-CONFLICT" "EXPORT-CONFLICT-EXPORTED-SYMBOLS" "EXPORT-CONFLICT-PACAKGES" "EXPORT-MISSING" 
"EXPORT-MISSING-SYMBOLS" "FALSE" "FILE-ENVIRONMENTS" "FILE-ERROR" "FILE-ERROR-PATHNAME" 
"FILE-NOT-FOUND" "FILE-NOT-FOUND-PATHNAME" "FILE-WONT-OPEN" "FILE-WONT-OPEN-PATHNAME" "FIND-PROFILE" 
"FIND-RESTART" "FLOATING-OVERFLOW" "FLOATING-OVERFLOW-OPERANDS" "FLOATING-OVERFLOW-OPERATION" 
"FLOATING-POINT-OVERFLOW" "FLOATING-POINT-UNDERFLOW" "FLOATING-UNDERFLOW" 
"FLOATING-UNDERFLOW-OPERANDS" "FLOATING-UNDERFLOW-OPERATION" "FOLLOW-SYNONYM-STREAMS" "FS-ERROR" 
"FS-PROTECTION-VIOLATION" "FS-RESOURCES-EXCEEDED" "HANDLER-CASE" "HASH-TABLE-FULL" 
"HASH-TABLE-FULL-TABLE" "IMPORT-CONFLICT" "IMPORT-PROCEED" "INNER" "INVALID-PATHNAME" 
"INVALID-PATHNAME-PATHNAME" "INVOKE-DEBUGGER" "INVOKE-RESTART" "INVOKE-RESTART-INTERACTIVELY" 
"LIST-ALL-PROFILES" "MAKE-EXTERNAL-PROCEED" "MAKE-INTERNAL-PROCEED" "MAKE-PROFILE" 
"MISSING-EXTERNAL-SYMBOL" "MISSING-EXTERNAL-SYMBOL-NAME" "MISSING-EXTERNAL-SYMBOL-PACKAGE" 
"MISSING-PACKAGE" "MISSING-PACKAGE-EXTERNAL" "MISSING-PACKAGE-PACKAGE-NAME" 
"MISSING-PACKAGE-SYMBOL-NAME" "MUFFLE-WARNING" "NAMED-PROGN" "NEW-PACKAGE-PROCEED" "ONCE-ONLY" 
"OPEN-STREAM-P" "PACK" "PACK*" "PACKAGE-ERROR" "PACKAGE-ERROR-PACKAGE" "PACKAGE-PREFIX" 
"PATHNAME-ERROR" "PATHNAME-ERROR-PATHNAME" "PKG-GOTO" "PREFER-CLSYM-PROCEED" "PREFER-ILSYM-PROCEED" 
"PROFILE-NAME" "PROFILE-P" "PROFILES" "PROGRAM-ERROR" "READ-CONFLICT" "READ-CONFLICT-NAME" 
"READ-CONFLICT-PACKAGES" "READVISE-FUNCTION" "REBREAK-FUNCTION" "RECORD-CREATE" "RECORD-FETCH" 
"RECORD-FFETCH" "REINSTALL-ADVICE" "RESTART" "RESTART-BIND" "RESTART-CASE" "RESTART-NAME" 
"RESTORE-PROFILE" "RETURN-CLSYM-PROCEED" "RETURN-ILSYM-PROCEED" "ROW-MAJOR-AREF" "SAVE-PROFILE" 
"SET-DEFAULT-EXEC-TYPE" "SET-EXEC-TYPE" "SHADOW-USE-CONFLICTS-PROCEED" "SHADOWING-IMPORT-PROCEED" 
"SIMPLE-DEVICE-ERROR" "SIMPLE-DEVICE-ERROR-DEVICE" "SIMPLE-DEVICE-ERROR-MESSAGE" "SIMPLE-STRING" 
"SIMPLE-TYPE-ERROR" "SIMPLE-TYPE-ERROR-CULPRIT" "SIMPLE-TYPE-ERROR-EXPECTED-TYPE" "STORAGE-EXHAUSTED" 
"STREAM-NOT-OPEN" "STREAM-NOT-OPEN-STREAM" "STRING-STREAM-P" "SYMBOL-COLON-ERROR" "SYMBOL-CONFLICT" 
"SYMBOL-CONFLICT-SYMBOLS" "SYMBOL-HT-FULL" "SYMBOL-NAME-TOO-LONG" "SYMBOL-NAME-TOO-LONG-STREAM" 
"SYNONYM-STREAM-P" "SYNONYM-STREAM-SYMBOL" "TRACE-FUNCTION" "TWO-WAY-STREAM-INPUT-STREAM" 
"TWO-WAY-STREAM-OUTPUT-STREAM" "TWO-WAY-STREAM-P" "TYPE-ERROR" "TYPE-ERROR-DATUM" 
"TYPE-ERROR-EXPECTED-TYPE" "TYPE-MISMATCH" "TYPE-MISMATCH-EXPECTED-TYPE" "TYPE-MISMATCH-MESSAGE" 
"TYPE-MISMATCH-VALUE" "UGLY-SYMBOL-PROCEED" "UNADVISE-FUNCTION" "UNBREAK-FUNCTION" "UNINTERN-CONFLICT"
 "UNINTERN-CONFLICT-SYMBOL" "UNINTERN-PROCEED" "UNINTERN-USEE-PROCEED" "UNINTERN-USER-PROCEED" 
"USE-CONFLICT" "USE-CONFLICT-USED-PACKAGE" "WITH-COLLECTION" "WITH-PROFILE" "WITH-SIMPLE-RESTART")) (
IL:MAPC CL::FUTURE-CITIZENS-OF-XCL (QUOTE CL::DEFECT-FROM-IL-TO-XCL)) (CL::CHECK-ALL) (IL:* IL:;; 
"Handle a few random symbols that need to be shared with COMMON-LISP") (IL:for IL:S IL:in (QUOTE (
DEFPACKAGE DELETE-PACKAGE)) IL:do (IMPORT IL:S IL:*COMMON-LISP-PACKAGE*) (EXPORT IL:S 
IL:*COMMON-LISP-PACKAGE*)))) (IL:* IL:;; "Arrange for the proper makefile environment") (IL:PROP (
IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:XCL-PACKAGE)))
(DEFUN CL::DEFECT-FROM-IL-TO-XCL (CL::NAME) (CL::NATURALIZE CL::NAME (FIND-PACKAGE (QUOTE CL::IL)) (
FIND-PACKAGE (QUOTE CL::XCL))))
(DEFUN CL::CHECK-ALL NIL (IL:* IL:; "Edited 17-Mar-92 22:07 by jrb:") (LET ((CL::XCLP (FIND-PACKAGE 
"XCL")) CL::TOO-MANY?) (DOLIST (CL::X CL::FUTURE-CITIZENS-OF-XCL T) (IL:* IL:;; 
"This test is bogus now, as lots of symbols in XCL are homed in COMMON-LISP") (IL:* IL:;; 
"(LET* ((S (INTERN X XCLP)) (P (SYMBOL-PACKAGE S))) (IF (NOT (EQ P XCLP)) (FORMAT T %"~S ~S~%%%%%" S P)))"
) (LET ((CL::SL (MAPCAN (IL:FUNCTION (LAMBDA (PACKAGE) (MULTIPLE-VALUE-BIND (SYMBOL CL::WHERE) (
FIND-SYMBOL CL::X PACKAGE) (AND SYMBOL (EQ CL::WHERE :EXTERNAL) (LIST SYMBOL))))) (QUOTE ("IL" "XCL" 
"CL"))))) (IF (NOT (CASE (LENGTH CL::SL) (2 (EQ (FIRST CL::SL) (SECOND CL::SL))) (3 (AND (EQ (FIRST 
CL::SL) (SECOND CL::SL)) (EQ (SECOND CL::SL) (THIRD CL::SL)))) (T T))) (PROGN (SETQ CL::TOO-MANY? T) (
PRINT CL::SL))))) (AND CL::TOO-MANY? (ERROR "Multiple versions of the above symbols exist~%%"))))
(DEFPARAMETER CL::FUTURE-CITIZENS-OF-XCL (QUOTE ((IL:* IL:;; "new definers") "DEFCOMMAND" "DEFDEFINER"
 "DEFGLOBALPARAMETER" "DEFGLOBALVAR" "DEFINE-CONDITION" "DEFINE-PROCEED-FUNCTION" "DEFINLINE" 
"DEFOPTIMIZER" "DEFPACKAGE" "DEF-DEFINE-TYPE" "*DEFINITION-HASH-TABLE*" (IL:* IL:;; "for UNDO") 
"DEFINE-UNDOABLE-MODIFY-MACRO" "UNDOABLY" "UNDOABLY-SETF" "DEFINE-SPECIAL-FORM" (IL:* IL:;; 
"for the EXEC") "*CURRENT-EVENT*" "EXEC-ID" "*PER-EXEC-VARIABLES*" "*EXEC-MAKE-UNDOABLE-P*" 
"EXEC-FORMAT" "EXEC-EVAL" "EXEC" "ADD-EXEC" "EXEC-VALUE-OF" (IL:* IL:;; "for the debugger") "DEBUGGER"
 "PRINT-BACKTRACE" "*DEBUGGER-MENU-ITEMS*" "ENTER-DEBUGGER-P" "*DEBUGGER-ENTRY-POINTS*" "HELP" 
"UNBREAK" "BREAK-FUNCTION" "*TRACE-DEPTH*" (IL:* IL:;; "others in alphabetical order") "&CONTEXT" 
"*CLTL2-PEDANTIC*" "*DEFAULT-PUSH-EXTENSION-SIZE*" "*PREFERRED-READING-SYMBOLS*" 
"*TOTAL-PACKAGES-LIMIT*" "ABORT" "ARRAY-NEEDS-INDIRECTION-P" "ASET" "BIT-ARRAY-P" "CATCH-ABORT" 
"CELL-ERROR" "CELL-ERROR-NAME" "COMPUTE-PROCEED-CASES" "CONDITION" "CONDITION-BIND" "CONDITION-CASE" 
"CONDITION-HANDLER" "CONDITION-REPORTER" "CONTROL-ERROR" "COPY-ARRAY" "DEBUG" "DEFAULT-PROCEED-REPORT"
 "DEFAULT-PROCEED-TEST" "DELETE-PACKAGE" "DESTRUCTURING-BIND" "DESTRUCTURING-SETQ" "DISPLACED-ARRAY-P"
 "DO-LOCAL-SYMBOLS" "END-OF-FILE" "END-OF-FILE-STREAM" "EQUAL-DIMENSIONS-P" "EXTENDABLE-ARRAY-P" 
"FILL-ARRAY" "FILL-VECTOR" "FIND-PROCEED-CASE" "GLOBAL" "GLOBALIZE" "HANDLER-BIND" "IGNORE-ERRORS" 
"ILLEGAL-GO" "ILLEGAL-GO-TAG" "ILLEGAL-RETURN" "ILLEGAL-RETURN-TAG" "ILLEGAL-THROW" 
"ILLEGAL-THROW-TAG" "INVOKE-PROCEED-CASE" "MAKE-CONDITION" "MAKE-VECTOR" "OPTIMIZERS" "PARSE-BODY" 
"PROCEED" "PROCEED-CASE" "PROCEED-CASE-NAME" "READ-ERROR" "READ-ERROR-STREAM" "READ-ONLY-ARRAY-P" 
"REMOVE-COMMENTS" "SERIOUS-CONDITION" "SHADOWING-USE-PACKAGE" "SIGNAL" "SIMPLE-ARRAY-P" "SIMPLE-BREAK"
 "SIMPLE-BREAK-FORMAT-ARGUMENTS" "SIMPLE-BREAK-FORMAT-STRING" "SIMPLE-CONDITION" 
"SIMPLE-CONDITION-FORMAT-ARGUMENTS" "SIMPLE-CONDITION-FORMAT-STRING" "SIMPLE-ERROR" 
"SIMPLE-ERROR-FORMAT-ARGUMENTS" "SIMPLE-ERROR-FORMAT-STRING" "SIMPLE-WARNING" 
"SIMPLE-WARNING-FORMAT-ARGUMENTS" "SIMPLE-WARNING-FORMAT-STRING" "STACK-OVERFLOW" "STORAGE-CONDITION" 
"STORE-VALUE" "STREAM-ERROR" "STREAM-ERROR-STREAM" "STRING-ARRAY-P" "TRUE" "UNBOUND-VARIABLE" 
"UNBOUND-VARIABLE-NAME" "UNDEFINED-FUNCTION" "UNDEFINED-FUNCTION-NAME" "USE-VALUE" "VECTOR-LENGTH" 
"WALK-FORM" "WALK-FORM-INTERNAL" "WALK-TEMPLATE" "WARNING")) 
"A list of names retroactively placed in XCL; do not add to it.")
(DEFPACKAGE "XEROX-COMMON-LISP" (:USE "LISP" "CONDITIONS") (:NICKNAMES "XCL") (:PREFIX-NAME "XCL") (
:IMPORT-FROM "COMMON-LISP" "DEFPACKAGE" "SIMPLE-WARNING" "TWO-WAY-STREAM-INPUT-STREAM" "SIMPLE-ERROR" 
"WARNING" "ECHO-STREAM-INPUT-STREAM" "SIMPLE-CONDITION" "STORAGE-CONDITION" "CONTROL-ERROR" 
"UNBOUND-VARIABLE" "STREAM-ERROR" "ROW-MAJOR-AREF" "SIMPLE-TYPE-ERROR" "ECHO-STREAM-OUTPUT-STREAM" 
"FLOATING-POINT-OVERFLOW" "SIGNAL" "OPEN-STREAM-P" "BROADCAST-STREAM-STREAMS" "PACKAGE-ERROR" 
"STRING-STREAM-P" "DESTRUCTURING-BIND" "END-OF-FILE" "FLOATING-POINT-UNDERFLOW" "ABORT" 
"SYNONYM-STREAM-P" "SYNONYM-STREAM-SYMBOL" "PROGRAM-ERROR" "CONCATENATED-STREAM-STREAMS" 
"TWO-WAY-STREAM-OUTPUT-STREAM" "TYPE-ERROR" "ARITHMETIC-ERROR" "CELL-ERROR" "FILE-ERROR" 
"SERIOUS-CONDITION" "DIVISION-BY-ZERO" "UNDEFINED-FUNCTION" "SIMPLE-STRING" "CONDITION" 
"DELETE-PACKAGE" "MAKE-VECTOR") (:IMPORT-FROM "LISP" "SIMPLE-STRING") (:EXPORT "*BREAK-ON-SIGNALS*" 
"*CURRENT-CONDITION*" "*DEBUGGER-PROMPT*" "*DEFAULT-PROFILE*" "*EVAL-FUNCTION*" "*EXEC-PROMPT*" 
"*LONG-SITE-NAME*" "*PRINT-STRUCTURE*" "*PROFILE*" "*SHORT-SITE-NAME*" "*TRACE-IO*" "*TRACE-LENGTH*" 
"*TRACE-LEVEL*" "*TRACE-VERBOSE*" "ADVISE-FUNCTION" "ADVISED-FUNCTIONS" "ARGLIST" "ARITHMETIC-ERROR" 
"ARITHMETIC-ERROR-OPERANDS" "ARITHMETIC-ERROR-OPERATION" "ARRAY-SPACE-FULL" "ASSERTION-FAILED" 
"ASSERTION-FAILED-FORMAT-ARGUMENTS" "ASSERTION-FAILED-FORMAT-STRING" "ATTEMPT-TO-CHANGE-CONSTANT" 
"ATTEMPT-TO-CHANGE-CONSTANT-NAME" "ATTEMPT-TO-RPLAC-NIL" "ATTEMPT-TO-RPLAC-NIL-NAME" 
"BAD-PROCEED-CASE" "BAD-PROCEED-CASE-NAME" "BROADCAST-STREAM-P" "BROADCAST-STREAM-STREAMS" "COLLECT" 
"COMPILE-DEFINER" "COMPILE-FORM" "COMPUTE-RESTARTS" "CONCATENATED-STREAM-P" 
"CONCATENATED-STREAM-STREAMS" "CONTINUE" "CONTROL-E-INTERRUPT" "CONTROL-E-INTERRUPT-FUNCTION" 
"COPY-PROFILE" "CREATE-TRACE-WINDOW" "DATA-TYPES-EXHAUSTED" "DEFADVICE" "DEFINE-FILE-ENVIRONMENT" 
"DEFINE-RECORD" "DEFINER" "DEFPROFILE" "DELETED-PACKAGE-P" "DEVICE-ERROR" "DEVICE-ERROR-DEVICE" 
"DIVISION-BY-ZERO" "DO-INTERNAL-SYMBOLS" "ECHO-STREAM-INPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM" 
"ECHO-STREAM-P" "ESCAPE-COLONS-PROCEED" "EXPORT-CONFLICT" "EXPORT-CONFLICT-EXPORTED-SYMBOLS" 
"EXPORT-CONFLICT-PACAKGES" "EXPORT-MISSING" "EXPORT-MISSING-SYMBOLS" "FALSE" "FILE-ENVIRONMENTS" 
"FILE-ERROR" "FILE-ERROR-PATHNAME" "FILE-NOT-FOUND" "FILE-NOT-FOUND-PATHNAME" "FILE-WONT-OPEN" 
"FILE-WONT-OPEN-PATHNAME" "FIND-PROFILE" "FIND-RESTART" "FLOATING-OVERFLOW" 
"FLOATING-OVERFLOW-OPERANDS" "FLOATING-OVERFLOW-OPERATION" "FLOATING-POINT-OVERFLOW" 
"FLOATING-POINT-UNDERFLOW" "FLOATING-UNDERFLOW" "FLOATING-UNDERFLOW-OPERANDS" 
"FLOATING-UNDERFLOW-OPERATION" "FOLLOW-SYNONYM-STREAMS" "FS-ERROR" "FS-PROTECTION-VIOLATION" 
"FS-RESOURCES-EXCEEDED" "HANDLER-CASE" "HASH-TABLE-FULL" "HASH-TABLE-FULL-TABLE" "IMPORT-CONFLICT" 
"IMPORT-PROCEED" "INNER" "INVALID-PATHNAME" "INVALID-PATHNAME-PATHNAME" "INVOKE-DEBUGGER" 
"INVOKE-RESTART" "INVOKE-RESTART-INTERACTIVELY" "LIST-ALL-PROFILES" "MAKE-EXTERNAL-PROCEED" 
"MAKE-INTERNAL-PROCEED" "MAKE-PROFILE" "MISSING-EXTERNAL-SYMBOL" "MISSING-EXTERNAL-SYMBOL-NAME" 
"MISSING-EXTERNAL-SYMBOL-PACKAGE" "MISSING-PACKAGE" "MISSING-PACKAGE-EXTERNAL" 
"MISSING-PACKAGE-PACKAGE-NAME" "MISSING-PACKAGE-SYMBOL-NAME" "MUFFLE-WARNING" "NAMED-PROGN" 
"NEW-PACKAGE-PROCEED" "ONCE-ONLY" "OPEN-STREAM-P" "PACK" "PACK*" "PACKAGE-ERROR" 
"PACKAGE-ERROR-PACKAGE" "PACKAGE-PREFIX" "PATHNAME-ERROR" "PATHNAME-ERROR-PATHNAME" "PKG-GOTO" 
"PREFER-CLSYM-PROCEED" "PREFER-ILSYM-PROCEED" "PROFILE-NAME" "PROFILE-P" "PROFILES" "PROGRAM-ERROR" 
"READ-CONFLICT" "READ-CONFLICT-NAME" "READ-CONFLICT-PACKAGES" "READVISE-FUNCTION" "REBREAK-FUNCTION" 
"RECORD-CREATE" "RECORD-FETCH" "RECORD-FFETCH" "REINSTALL-ADVICE" "RESTART" "RESTART-BIND" 
"RESTART-CASE" "RESTART-NAME" "RESTORE-PROFILE" "RETURN-CLSYM-PROCEED" "RETURN-ILSYM-PROCEED" 
"ROW-MAJOR-AREF" "SAVE-PROFILE" "SET-DEFAULT-EXEC-TYPE" "SET-EXEC-TYPE" "SHADOW-USE-CONFLICTS-PROCEED"
 "SHADOWING-IMPORT-PROCEED" "SIMPLE-DEVICE-ERROR" "SIMPLE-DEVICE-ERROR-DEVICE" 
"SIMPLE-DEVICE-ERROR-MESSAGE" "SIMPLE-STRING" "SIMPLE-TYPE-ERROR" "SIMPLE-TYPE-ERROR-CULPRIT" 
"SIMPLE-TYPE-ERROR-EXPECTED-TYPE" "STORAGE-EXHAUSTED" "STREAM-NOT-OPEN" "STREAM-NOT-OPEN-STREAM" 
"STRING-STREAM-P" "SYMBOL-COLON-ERROR" "SYMBOL-CONFLICT" "SYMBOL-CONFLICT-SYMBOLS" "SYMBOL-HT-FULL" 
"SYMBOL-NAME-TOO-LONG" "SYMBOL-NAME-TOO-LONG-STREAM" "SYNONYM-STREAM-P" "SYNONYM-STREAM-SYMBOL" 
"TRACE-FUNCTION" "TWO-WAY-STREAM-INPUT-STREAM" "TWO-WAY-STREAM-OUTPUT-STREAM" "TWO-WAY-STREAM-P" 
"TYPE-ERROR" "TYPE-ERROR-DATUM" "TYPE-ERROR-EXPECTED-TYPE" "TYPE-MISMATCH" 
"TYPE-MISMATCH-EXPECTED-TYPE" "TYPE-MISMATCH-MESSAGE" "TYPE-MISMATCH-VALUE" "UGLY-SYMBOL-PROCEED" 
"UNADVISE-FUNCTION" "UNBREAK-FUNCTION" "UNINTERN-CONFLICT" "UNINTERN-CONFLICT-SYMBOL" 
"UNINTERN-PROCEED" "UNINTERN-USEE-PROCEED" "UNINTERN-USER-PROCEED" "USE-CONFLICT" 
"USE-CONFLICT-USED-PACKAGE" "WITH-COLLECTION" "WITH-PROFILE" "WITH-SIMPLE-RESTART"))
(IL:MAPC CL::FUTURE-CITIZENS-OF-XCL (QUOTE CL::DEFECT-FROM-IL-TO-XCL))
(CL::CHECK-ALL)
(IL:for IL:S IL:in (QUOTE (DEFPACKAGE DELETE-PACKAGE)) IL:do (IMPORT IL:S IL:*COMMON-LISP-PACKAGE*) (
EXPORT IL:S IL:*COMMON-LISP-PACKAGE*))
(IL:PUTPROPS IL:XCL-PACKAGE IL:FILETYPE IL:COMPILE-FILE)
(IL:PUTPROPS IL:XCL-PACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE (DEFPACKAGE "XCL"
 (:USE))))
(IL:PUTPROPS IL:XCL-PACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992))
NIL
\ No newline at end of file
diff --git a/CLTL2/XCLC-ALPHA b/CLTL2/XCLC-ALPHA
new file mode 100644
index 00000000..64f8d07b
--- /dev/null
+++ b/CLTL2/XCLC-ALPHA
@@ -0,0 +1,146 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL")))
+(IL:FILECREATED " 4-Feb-92 10:34:19" IL:|{DSK}<usr>local>lde>lispcore>sources>XCLC-ALPHA.;3| 51540  
+
+      IL:|changes| IL:|to:|  (IL:FUNCTIONS ALPHA-EVAL-WHEN PROCESS-DECLARATIONS PROCESS-IL-DECLARATIONS CHECK-ARG ALPHA-FORM ALPHA-FUNCTION ALPHA-GO ALPHA-LAMBDA-LIST ALPHA-RETURN-FROM ALPHA-SETQ CONVERT-TO-CL-LAMBDA)
+
+      IL:|previous| IL:|date:| " 4-Jan-92 12:31:05" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>XCLC-ALPHA.;2|)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:XCLC-ALPHACOMS)
+
+(IL:RPAQQ IL:XCLC-ALPHACOMS ((IL:* IL:|;;;| "Alphatization") (IL:FUNCTIONS BINDING-CONTOUR PROCESS-DECLARATIONS PROCESS-IL-DECLARATIONS UPDATE-ENVIRONMENT) (IL:FUNCTIONS BIND-PARAMETER CHECK-ARG) (IL:FUNCTIONS BINDING-TO-LAMBDA) (IL:VARIABLES *BLOCK-STACK* *TAGBODY-STACK*) (IL:FUNCTIONS ALPHA-ARGUMENT-FORM ALPHA-ATOM ALPHA-BLOCK ALPHA-CATCH ALPHA-COMBINATION ALPHA-COMPILER-LET ALPHA-EVAL-WHEN ALPHA-FLET ALPHA-FORM ALPHA-FUNCTION ALPHA-FUNCTIONAL-FORM ALPHA-GO ALPHA-IF ALPHA-IL-FUNCTION ALPHA-LABELS ALPHA-LAMBDA ALPHA-LAMBDA-LIST ALPHA-LET ALPHA-LET* ALPHA-LITERAL ALPHA-MACROLET ALPHA-MV-CALL ALPHA-MV-PROG1 ALPHA-PROGN ALPHA-PROGV ALPHA-RETURN-FROM ALPHA-SETQ ALPHA-TAGBODY ALPHA-THROW ALPHA-UNWIND-PROTECT) (IL:FUNCTIONS CONVERT-TO-CL-LAMBDA COMPLETELY-EXPAND EXPAND-OPENLAMBDA-CALL) (IL:* IL:|;;| "Alphatization testing") (IL:VARIABLES *INDENT-INCREMENT* *NODE-HASH* *NODE-NUMBER*) (IL:FUNCTIONS TEST-ALPHA TEST-ALPHA-2 PARSE-DEFUN PRINT-TREE PRINT-NODE) (IL:VARIABLES CONTEXT-TEST-FORM) (IL:FUNCTIONS CTXT) (IL:* IL:|;;| "Arrange to use the correct compiler.") (IL:PROP IL:FILETYPE IL:XCLC-ALPHA) (IL:* IL:|;;| "Arrange for the correct makefile environment") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-ALPHA)))
+
+
+
+(IL:* IL:|;;;| "Alphatization")
+
+
+(DEFMACRO BINDING-CONTOUR (DECLARATIONS &BODY BODY) (IL:* IL:|;;;| "Called around the alphatization of a binding form, this sets up bindings of the various special variables used to communicate information between declarations and code.  The given declarations are then processed inside the bindings before going on to the body.") (IL:BQUOTE (LET ((*NEW-SPECIALS* NIL) (*NEW-GLOBALS* NIL) (*NEW-INLINES* NIL) (*NEW-NOTINLINES* NIL) (IL:SPECVARS IL:SPECVARS) (IL:LOCALVARS IL:LOCALVARS) (IL:GLOBALVARS IL:GLOBALVARS)) (DECLARE (SPECIAL *NEW-SPECIALS* *NEW-GLOBALS* *NEW-INLINES* *NEW-NOTINLINES* IL:SPECVARS IL:LOCALVARS IL:GLOBALVARS)) (PROCESS-DECLARATIONS (IL:\\\, DECLARATIONS)) (IL:\\\,@ BODY))))
+
+(DEFUN PROCESS-DECLARATIONS (DECLS) (IL:* IL:\; "Edited 31-Jan-92 12:46 by jrb:") (IL:* IL:|;;;| "Step through the given declarations, storing the information found therein into various special variables.") (DECLARE (SPECIAL *NEW-SPECIALS* *NEW-GLOBALS* *NEW-INLINES* *NEW-NOTINLINES* IL:SPECVARS IL:LOCALVARS IL:GLOBALVARS)) (FLET ((CHECK-VAR-1 (VAR) (COND ((SYMBOLP VAR) VAR) (T (COMPILER-CERROR "Use the symbol %LOSE% instead." "The value ~S, appearing in a declaration, is not a symbol" VAR) (QUOTE %LOSE%)))) (CHECK-FNAME-1 (FN) (COND ((OR (SYMBOLP FN) (CL::SETF-NAME-P FN)) FN) (T (COMPILER-CERROR "Use the symbol %LOSE% instead." "The value ~S, appearing in a declaration, is not a symbol" FN) (QUOTE %LOSE%))))) (MACROLET ((CHECK-VAR (VAR) (IL:BQUOTE (SETQ (IL:\\\, VAR) (CHECK-VAR-1 (IL:\\\, VAR))))) (CHECK-FNAME (FN) (IL:BQUOTE (SETQ (IL:\\\, FN) (CHECK-FNAME-1 (IL:\\\, FN)))))) (DOLIST (DECL DECLS) (DOLIST (SPEC (CDR DECL)) (IF (ATOM SPEC) (COMPILER-CERROR "Ignore it." "A non-list, ~S, was found where a declaration specification was expected." SPEC) (CASE (CAR SPEC) ((SPECIAL) (DOLIST (VAR (CDR SPEC)) (CHECK-VAR VAR) (PUSH VAR *NEW-SPECIALS*))) ((IL:SPECVARS) (COND ((CONSP (CDR SPEC)) (UNLESS (EQ IL:SPECVARS T) (SETQ IL:SPECVARS (UNION IL:SPECVARS (CDR SPEC))))) ((EQ (CDR SPEC) T) (SETQ IL:SPECVARS T) (SETQ IL:LOCALVARS IL:SYSLOCALVARS)) (T (COMPILER-CERROR "Ignore it" "Illegal SPECVARS declaration: ~S" SPEC)))) ((IL:LOCALVARS) (COND ((CONSP (CDR SPEC)) (UNLESS (EQ IL:LOCALVARS T) (SETQ IL:LOCALVARS (UNION IL:LOCALVARS (CDR SPEC))))) ((EQ (CDR SPEC) T) (SETQ IL:LOCALVARS T) (SETQ IL:SPECVARS IL:SYSSPECVARS)) (T (COMPILER-CERROR "Ignore it" "Illegal LOCALVARS declaration: ~S" SPEC)))) ((GLOBAL) (DOLIST (VAR (CDR SPEC)) (CHECK-VAR VAR) (PUSH VAR *NEW-GLOBALS*))) ((IL:GLOBALVARS) (IF (CONSP (CDR SPEC)) (SETQ IL:GLOBALVARS (UNION IL:GLOBALVARS (CDR SPEC))) (COMPILER-CERROR "Ignore it" "Illegal GLOBALVARS declaration: ~S" SPEC))) ((TYPE FTYPE FUNCTION) (IL:* IL:\; "We don't handle type declarations yet.") NIL) ((INLINE) (IL:* IL:|;;| "We don't observe these for (SETF FOO) yet; we just record them for future use") (DOLIST (VAR (CDR SPEC)) (CHECK-FNAME VAR) (PUSH VAR *NEW-INLINES*))) ((NOTINLINE) (IL:* IL:|;;| "We don't observe these for (SETF FOO) yet; we just record them for future use") (DOLIST (VAR (CDR SPEC)) (CHECK-FNAME VAR) (PUSH VAR *NEW-NOTINLINES*))) ((IGNORE OPTIMIZE) (IL:* IL:\; "We don't handle IGNORE or OPTIMIZE declarations yet.") NIL) ((DECLARATION) (IL:* IL:\; "Add new declaration specifiers right away so that they can be used in later declarations in the same cluster.  It's a picky point, but who cares?") (ENV-ADD-DECLS *ENVIRONMENT* (CDR SPEC))) ((IL:USEDFREE) (IL:* IL:\; "Ignored Interlisp declarations") NIL) (OTHERWISE (UNLESS (OR (EQ (CAR SPEC) T) (IL:TYPE-EXPANDER (CAR SPEC)) (XCL::DECL-SPECIFIER-P (CAR SPEC)) (ENV-DECL-P *ENVIRONMENT* (CAR SPEC))) (COMPILER-CERROR "Ignore it." "Unknown declaration specifier in DECLARE: ~S." (CAR SPEC)))))))))))
+
+(DEFUN PROCESS-IL-DECLARATIONS (SPECS) (IL:* IL:\; "Edited 31-Jan-92 12:48 by jrb:") (IL:* IL:|;;;| " Stroring theInterlisp's declare information found in executable position.") (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:GLOBALVARS)) (DOLIST (SPEC SPECS T) (IF (ATOM SPEC) (COMPILER-CERROR "Ignore it." "A non-list, ~S, was found where a declaration specification was expected." SPEC) (CASE (CAR SPEC) ((IL:SPECVARS) (COND ((CONSP (CDR SPEC)) (UNLESS (EQ IL:SPECVARS T) (SETQ IL:SPECVARS (UNION IL:SPECVARS (CDR SPEC))))) ((EQ (CDR SPEC) T) (SETQ IL:SPECVARS T) (SETQ IL:LOCALVARS IL:SYSLOCALVARS)) (T (COMPILER-CERROR "Ignore it" "Illegal SPECVARS declaration: ~S" SPEC)))) ((IL:LOCALVARS) (COND ((CONSP (CDR SPEC)) (UNLESS (EQ IL:LOCALVARS T) (SETQ IL:LOCALVARS (UNION IL:LOCALVARS (CDR SPEC))))) ((EQ (CDR SPEC) T) (SETQ IL:LOCALVARS T) (SETQ IL:SPECVARS IL:SYSSPECVARS)) (T (COMPILER-CERROR "Ignore it" "Illegal LOCALVARS declaration: ~S" SPEC)))) ((IL:GLOBALVARS) (IF (CONSP (CDR SPEC)) (SETQ IL:GLOBALVARS (UNION IL:GLOBALVARS (CDR SPEC))) (COMPILER-CERROR "Ignore it" "Illegal GLOBALVARS declaration: ~S" SPEC))) ((IL:USEDFREE) (IL:* IL:\; "Ignored Interlisp declarations") NIL) (OTHERWISE (RETURN-FROM PROCESS-IL-DECLARATIONS NIL))))))
+
+(DEFUN UPDATE-ENVIRONMENT (ENV) (IL:* IL:|;;;| "Store the information in a BINDING-CONTOUR's special variables into the given environment.") (DECLARE (SPECIAL *NEW-SPECIALS* *NEW-GLOBALS* *NEW-INLINES* *NEW-NOTINLINES*)) (WHEN *NEW-SPECIALS* (ENV-DECLARE-SPECIALS ENV *NEW-SPECIALS*)) (WHEN *NEW-GLOBALS* (ENV-DECLARE-GLOBALS ENV *NEW-GLOBALS*)) (WHEN *NEW-INLINES* (ENV-ALLOW-INLINES ENV *NEW-INLINES*)) (WHEN *NEW-NOTINLINES* (ENV-DISALLOW-INLINES ENV *NEW-NOTINLINES*)))
+
+(DEFUN BIND-PARAMETER (VAR BINDER ENV) (ECASE (RESOLVE-VARIABLE-BINDING ENV VAR) (:SPECIAL (DELETEF VAR *NEW-SPECIALS*) (ENV-DECLARE-A-SPECIAL ENV VAR) (MAKE-VARIABLE :SCOPE :SPECIAL :KIND :VARIABLE :NAME VAR :BINDER BINDER)) (:LEXICAL (LET ((STRUCT (MAKE-VARIABLE :SCOPE :LEXICAL :KIND :VARIABLE :NAME (SYMBOL-NAME VAR) :BINDER BINDER))) (ENV-BIND-VARIABLE ENV VAR STRUCT) STRUCT))))
+
+(DEFUN CHECK-ARG (VAR) (IL:* IL:\; "Edited 31-Jan-92 12:41 by jrb:") (IL:* IL:|;;;| "Make sure that VAR is a legal parameter in a lambda-list.") (COND ((NOT (SYMBOLP VAR)) (COMPILER-CERROR "Ignore it." "The parameter ~S is not a symbol." VAR) NIL) ((KEYWORDP VAR) (COMPILER-CERROR "Ignore it." "The parameter ~S is a keyword and may not be bound." VAR) NIL) (T T)))
+
+(DEFUN BINDING-TO-LAMBDA (BINDING) (IL:* IL:|;;;| "Convert a binding from an FLET or LABELS into the appropriate LAMBDA form, wrapping a BLOCK around the bodies of the functions.") (DESTRUCTURING-BIND (NAME ARG-LIST &BODY BODY) BINDING (MULTIPLE-VALUE-BIND (FORMS DECLS) (PARSE-BODY BODY *ENVIRONMENT* T) (IL:BQUOTE (LAMBDA (IL:\\\, ARG-LIST) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\,@ FORMS)))))))
+
+(DEFVAR *BLOCK-STACK* NIL (IL:* IL:|;;;| "Association list of block names to block structures; rebound at several points within the alphatizer."))
+
+(DEFVAR *TAGBODY-STACK* NIL "Association list from TAGBODY tags to the TAGBODY structure containing the tag; rebound at several points in the alphatizer")
+
+(DEFUN ALPHA-ARGUMENT-FORM (FORM) (LET ((*CONTEXT* *ARGUMENT-CONTEXT*)) (ALPHA-FORM FORM)))
+
+(DEFUN ALPHA-ATOM (FORM) (IL:* IL:|;;;| "The form is atomic.  If it's a symbol, do the appropriate look-ups.  Otherwise, it must be a literal.") (IF (OR (NOT (SYMBOLP FORM)) (EQ FORM T) (EQ FORM NIL)) (ALPHA-LITERAL FORM) (RESOLVE-VARIABLE-REFERENCE *ENVIRONMENT* FORM)))
+
+(DEFUN ALPHA-BLOCK (NAME BODY) (LET* ((NEW-BLOCK (MAKE-BLOCK :NAME NAME :CONTEXT *CONTEXT*)) (*BLOCK-STACK* (CONS (CONS NAME NEW-BLOCK) *BLOCK-STACK*))) (SETF (BLOCK-STMT NEW-BLOCK) (ALPHA-PROGN BODY)) NEW-BLOCK))
+
+(DEFUN ALPHA-CATCH (TAG FORMS) (MAKE-CATCH :TAG (ALPHA-ARGUMENT-FORM TAG) :STMT (ALPHA-PROGN FORMS)))
+
+(DEFUN ALPHA-COMBINATION (FN ARGS) (DECLARE (SPECIAL IL:NLAMA IL:NLAML)) (COND (IL:* IL:|;;| "Calls to FUNCALL are expanded into CALL nodes where the FN is the first argument to FUNCALL, more or less.") ((AND (EQ FN (QUOTE FUNCALL)) (NOT (ENV-INLINE-DISALLOWED *ENVIRONMENT* FN))) (MULTIPLE-VALUE-BIND (REAL-FN NOT-INLINE?) (ALPHA-FUNCTIONAL-FORM (FIRST ARGS)) (MAKE-CALL :FN REAL-FN :ARGS (MAPCAR (FUNCTION ALPHA-ARGUMENT-FORM) (REST ARGS)) :NOT-INLINE NOT-INLINE?))) (IL:* IL:|;;| "Calls on IL:OPENLAMBDA's involve lots of hairy processing.") ((AND (CONSP FN) (EQ (FIRST FN) (QUOTE IL:OPENLAMBDA))) (ALPHA-FORM (EXPAND-OPENLAMBDA-CALL FN ARGS))) (IL:* IL:|;;| "Lexical functions and non-symbol functions can't be NLambda's.") ((OR (NOT (SYMBOLP FN)) (ENV-FBOUNDP *ENVIRONMENT* FN)) (MAKE-CALL :FN (ALPHA-FUNCTION FN *CONTEXT*) :ARGS (MAPCAR (FUNCTION ALPHA-ARGUMENT-FORM) ARGS) :NOT-INLINE (AND (SYMBOLP FN) (ENV-INLINE-DISALLOWED *ENVIRONMENT* FN)))) ((OR (EQ 3 (IL:ARGTYPE FN)) (MEMBER FN IL:NLAMA :TEST (QUOTE EQ))) (IL:* IL:\; "It's an NLambda no-spread.  Funcall it on a single literal argument, the CDR of the form.") (MAKE-CALL :FN (ALPHA-FUNCTION FN) :ARGS (ALPHA-LITERAL ARGS) :NOT-INLINE (ENV-INLINE-DISALLOWED *ENVIRONMENT* FN))) ((OR (EQ 1 (IL:ARGTYPE FN)) (MEMBER FN IL:NLAML :TEST (QUOTE EQ))) (IL:* IL:\; "It's an NLambda spread.  Funcall it on the quoted versions of its arguments.") (MAKE-CALL :FN (ALPHA-FUNCTION FN) :ARGS (MAPCAR (FUNCTION ALPHA-LITERAL) ARGS) :NOT-INLINE (ENV-INLINE-DISALLOWED *ENVIRONMENT* FN))) (T (MAKE-CALL :FN (ALPHA-FUNCTION FN *CONTEXT*) :ARGS (MAPCAR (FUNCTION ALPHA-ARGUMENT-FORM) ARGS) :NOT-INLINE (ENV-INLINE-DISALLOWED *ENVIRONMENT* FN)))))
+
+(DEFUN ALPHA-COMPILER-LET (BINDINGS BODY) (LET ((VARS NIL) (VALS NIL)) (IL:|for| BINDING IL:|in| BINDINGS IL:|do| (COND ((CONSP BINDING) (PUSH (CAR BINDING) VARS) (PUSH (EVAL (CADR BINDING)) VALS)) (T (PUSH BINDING VARS) (PUSH NIL VALS)))) (PROGV VARS VALS (ALPHA-PROGN BODY))))
+
+(DEFUN ALPHA-EVAL-WHEN (TIMES FORMS) (IL:* IL:\; "Edited 27-Jan-92 17:02 by jrb:") (IL:* IL:|;;;| "If the times contain COMPILE, we evaluate the forms.  If the times include LOAD, we prognify the forms.  If LOAD isn't mentioned, this turns into NIL.") (WHEN (OR (MEMBER (QUOTE COMPILE) TIMES :TEST (FUNCTION EQ)) (MEMBER (QUOTE IL:COMPILE) TIMES :TEST (FUNCTION EQ)) (AND (MEMBER :COMPILE-TOPLEVEL TIMES :TEST (FUNCTION EQ)) (CONTEXT-TOP-LEVEL-P *CONTEXT*))) (MAPC (FUNCTION EVAL) FORMS)) (IF (OR (MEMBER (QUOTE LOAD) TIMES :TEST (FUNCTION EQ)) (MEMBER (QUOTE IL:LOAD) TIMES :TEST (FUNCTION EQ)) (IL:* IL:|;;| "(AND (CONTEXT-TOP-LEVEL-P *CONTEXT*) ??)") (MEMBER :LOAD-TOPLEVEL TIMES :TEST (FUNCTION EQ))) (ALPHA-PROGN FORMS) *LITERALLY-NIL*))
+
+(DEFUN ALPHA-FLET (BINDINGS BODY) (IL:* IL:|;;;| "An FLET is alphatized as a LABELS node. The only difference is that the new variables for the function bindings are inserted after alphatizing the defined functions and body, whereas in a LABELS you add them to the environment before alphatizing the children.") (LET ((*ENVIRONMENT* (MAKE-CHILD-ENV *ENVIRONMENT*))) (MULTIPLE-VALUE-BIND (FORMS DECLS) (PARSE-BODY BODY *ENVIRONMENT* NIL) (BINDING-CONTOUR DECLS (UPDATE-ENVIRONMENT *ENVIRONMENT*) (LET ((NEW-LABELS (MAKE-LABELS)) NAMES) (SETQ NAMES (WITH-COLLECTION (SETF (LABELS-FUNS NEW-LABELS) (MAPCAR (FUNCTION (LAMBDA (BINDING) (IL:* IL:|;;| "Added hair below for the case of ((setf foo))") (LET* ((BINDING-NAME (CAR BINDING)) (SETF? (CL::SETF-NAME-P BINDING-NAME)) (BINDING-NAME-STRING (IF SETF? (CONCATENATE (QUOTE STRING) "Local SETF for " (SYMBOL-NAME (SECOND BINDING-NAME))) (SYMBOL-NAME BINDING-NAME)))) (UNLESS (OR SETF? (CHECK-ARG BINDING-NAME)) (SETQ BINDING (CONS (QUOTE %LOSE%) (CDR BINDING)))) (COLLECT BINDING-NAME) (CONS (MAKE-VARIABLE :NAME BINDING-NAME-STRING :SCOPE :LEXICAL :KIND :FUNCTION :BINDER NEW-LABELS) (ALPHA-LAMBDA (BINDING-TO-LAMBDA BINDING) :NAME (IL:* IL:|;;| "Really want name to be \"Foo in Bar\"") BINDING-NAME-STRING))))) BINDINGS)))) (IL:* IL:|;;| "Having alphatized the function bindings, put them in the environment for alphatization of the body.") (IL:|for| NAME IL:|in| NAMES IL:|as| FN-PAIR IL:|in| (LABELS-FUNS NEW-LABELS) IL:|do| (ENV-BIND-FUNCTION *ENVIRONMENT* NAME :FUNCTION (CAR FN-PAIR))) (IL:* IL:|;;| "Now we can alphatize the body.") (SETF (LABELS-BODY NEW-LABELS (ALPHA-PROGN FORMS))) NEW-LABELS)))))
+
+(DEFUN ALPHA-FORM (FORM) (IL:* IL:\; "Edited 31-Jan-92 12:42 by jrb:") (IL:* IL:|;;;| "FORM is a random exectuable form.  Dispatch to the appropriate alphatization routine.") (IL:* IL:|;;;| "NOTE NOTE NOTE:::  If anything is added to this CASE statement, be sure to add it also to the list in COMPLETELY-EXPAND.") (IF (ATOM FORM) (ALPHA-ATOM FORM) (CASE (CAR FORM) ((BLOCK) (ALPHA-BLOCK (SECOND FORM) (CDDR FORM))) ((CATCH) (ALPHA-CATCH (SECOND FORM) (CDDR FORM))) ((COMPILER-LET) (ALPHA-COMPILER-LET (SECOND FORM) (CDDR FORM))) ((DECLARE) (OR (PROCESS-IL-DECLARATIONS (CDR FORM)) (COMPILER-CERROR "Replace the declaration with NIL" "DECLARE found in executable position: ~S" FORM)) *LITERALLY-NIL*) ((EVAL-WHEN) (ALPHA-EVAL-WHEN (SECOND FORM) (CDDR FORM))) ((FLET) (ALPHA-FLET (SECOND FORM) (CDDR FORM))) ((IL:FUNCTION) (ALPHA-IL-FUNCTION (SECOND FORM) (THIRD FORM))) ((FUNCTION) (ALPHA-FUNCTION (SECOND FORM))) ((GO) (ALPHA-GO (SECOND FORM))) ((IF) (ALPHA-IF (SECOND FORM) (THIRD FORM) (FOURTH FORM))) ((LABELS) (IL:* IL:\; "Rely on the macro expansion for now.") (RETURN-FROM ALPHA-FORM (ALPHA-LABELS (SECOND FORM) (CDDR FORM))) (RETURN-FROM ALPHA-FORM (ALPHA-FORM (OPTIMIZE-AND-MACROEXPAND-1 FORM)))) ((LET) (ALPHA-LET (SECOND FORM) (CDDR FORM))) ((LET*) (ALPHA-LET* (SECOND FORM) (CDDR FORM))) ((MACROLET SI::%MACROLET) (ALPHA-MACROLET (SECOND FORM) (CDDR FORM))) ((MULTIPLE-VALUE-CALL) (ALPHA-MV-CALL (SECOND FORM) (CDDR FORM))) ((MULTIPLE-VALUE-PROG1) (ALPHA-MV-PROG1 (CDR FORM))) ((PROGN) (ALPHA-PROGN (CDR FORM))) ((PROGV) (IL:* IL:\; "Rely on the macro expansion for now.") (RETURN-FROM ALPHA-FORM (DESTRUCTURING-BIND (VARS-EXPR VALS-EXPR . BODY) (CDR FORM) (ALPHA-FORM (IL:BQUOTE (IL:\\DO.PROGV (IL:\\\, VARS-EXPR) (IL:\\\, VALS-EXPR) (FUNCTION (LAMBDA NIL (IL:\\\,@ BODY)))))))) (ALPHA-PROGV (SECOND FORM) (THIRD FORM) (CDDDR FORM))) ((QUOTE) (ALPHA-LITERAL (SECOND FORM))) ((RETURN-FROM) (ALPHA-RETURN-FROM (SECOND FORM) (THIRD FORM))) ((SETQ IL:SETQ) (ALPHA-SETQ (CAR FORM) (REST FORM))) ((TAGBODY) (ALPHA-TAGBODY (CDR FORM))) ((THE) (IL:* IL:\; "Ignore the THE construct for now.") (ALPHA-FORM (THIRD FORM))) ((THROW) (ALPHA-THROW (SECOND FORM) (THIRD FORM))) ((UNWIND-PROTECT) (ALPHA-UNWIND-PROTECT (SECOND FORM) (CDDR FORM))) (OTHERWISE (MULTIPLE-VALUE-BIND (NEW-FORM CHANGED-P) (OPTIMIZE-AND-MACROEXPAND-1 FORM) (IF (NULL CHANGED-P) (ALPHA-COMBINATION (CAR FORM) (CDR FORM)) (ALPHA-FORM NEW-FORM)))))))
+
+(DEFUN ALPHA-FUNCTION (FORM &OPTIONAL (CONTEXT (OR (CONTEXT-APPLIED-CONTEXT *CONTEXT*) *NULL-CONTEXT*))) (IL:* IL:\; "Edited 31-Jan-92 12:49 by jrb:") (IL:* IL:|;;;| "If it's a symbol, then turn this into either the FLET/LABELS-bound VARIABLE structure or a structure for the global symbol.  Otherwise, it must be either a LAMBDA-form or OPCODES-form and is treated as such.  Note that the internal representation of programs treats LAMBDA as a value-producing special form.") (IL:* IL:|;;;| "The CONTEXT argument is the return-context of the function, if known.  It is passed on to alpha-lambda.") (IL:* IL:|;;;| "We return a second value when the FORM is a symbol, saying whether or not the named function is supposed to be NOTINLINE.") (COND ((SYMBOLP FORM) (MULTIPLE-VALUE-BIND (KIND STRUCT) (ENV-FBOUNDP *ENVIRONMENT* FORM) (COND ((EQ KIND :FUNCTION) (VALUES (MAKE-VAR-REF :VARIABLE STRUCT) (ENV-INLINE-DISALLOWED *ENVIRONMENT* FORM))) (T (UNLESS (NULL KIND) (ASSERT (EQ KIND :MACRO)) (IL:* IL:|;;| "This case can only arise if we are alphatizing a FUNCTION form, since the macro would have been expanded otherwise.") (COMPILER-CERROR "Use the global function definition of ~S" "The symbol ~S names a lexically-bound macro and thus cannot be used with the FUNCTION special form." FORM)) (IL:* IL:|;;| "Account for block compilation.") (WHEN (NOT (NULL *CURRENT-BLOCK*)) (LET ((LOOKUP (ASSOC FORM (BLOCK-DECL-FN-NAME-MAP *CURRENT-BLOCK*)))) (WHEN (NOT (NULL LOOKUP)) (IL:* IL:\; "This function is to be renamed.") (SETQ FORM (CDR LOOKUP))))) (CHECK-FOR-UNKNOWN-FUNCTION FORM) (VALUES (MAKE-REFERENCE-TO-VARIABLE :NAME FORM :SCOPE :GLOBAL :KIND :FUNCTION) (ENV-INLINE-DISALLOWED *ENVIRONMENT* FORM)))))) ((CL::SETF-NAME-P FORM) (IL:* IL:|;;| "To be checked: ENV-INLINE-DISALLOWED (we don't currently try to inline local SETFs, but we should") (MULTIPLE-VALUE-BIND (KIND STRUCT) (ENV-SETF-FBOUNDP *ENVIRONMENT* FORM) (COND ((EQ KIND :FUNCTION) (VALUES (MAKE-VAR-REF :VARIABLE STRUCT) (ENV-INLINE-DISALLOWED *ENVIRONMENT* FORM))) (T (UNLESS (NULL KIND) (ASSERT (EQ KIND :MACRO)) (IL:* IL:|;;| "This case can only arise if we are alphatizing a FUNCTION form, since the macro would have been expanded otherwise.") (COMPILER-CERROR "Use the global function definition of ~S" "The symbol ~S names a lexically-bound macro and thus cannot be used with the FUNCTION special form." FORM)) (IL:* IL:|;;| "Account for block compilation.") (IL:* IL:|;;| "I don't think we have to worry about this for SETF functions") (IL:* IL:|;;| "(WHEN (NOT (NULL *CURRENT-BLOCK*)) (LET ((LOOKUP (ASSOC FORM (BLOCK-DECL-FN-NAME-MAP *CURRENT-BLOCK*)))) (WHEN (NOT (NULL LOOKUP)) (SETQ FORM (CDR LOOKUP)))))") (IL:* IL:|;;| "We hard-code a reference to (XCL::DEFUN-SETF-NAME (SECOND FORM)) here, to avoid looking at the :SETF-DEFUN property at runtime; if you have to do THAT, we really ahve to expand into the following mess to get it right:") (IL:* IL:|;;| "(LAMBDA (&REST ARGS) (APPLY (GET ',(SECOND FORM) :SETF-DEFUN) ARGS))") (LET ((DEFUN-SETF-NAME (XCL::DEFUN-SETF-NAME (SECOND FORM)))) (CHECK-FOR-UNKNOWN-SETF FORM FORM DEFUN-SETF-NAME) (ALPHA-FUNCTION DEFUN-SETF-NAME CONTEXT)))))) (T (CASE (CAR FORM) ((LAMBDA IL:LAMBDA IL:NLAMBDA IL:OPENLAMBDA) (ALPHA-LAMBDA FORM :CONTEXT CONTEXT)) ((IL:OPCODES :OPCODES) (MAKE-OPCODES :BYTES (CDR FORM))) (OTHERWISE (COMPILER-CERROR "Use (LAMBDA () NIL) instead" "The form ~S, appearing in a functional context, is neither a symbol nor a LAMBDA-form" FORM) (ALPHA-LAMBDA (QUOTE (LAMBDA NIL NIL)) :CONTEXT CONTEXT))))))
+
+(DEFUN ALPHA-FUNCTIONAL-FORM (FORM) (IF (AND (CONSP FORM) (OR (EQ (QUOTE QUOTE) (FIRST FORM)) (EQ (QUOTE IL:FUNCTION) (FIRST FORM))) (SYMBOLP (SECOND FORM))) (ALPHA-FUNCTION (SECOND FORM)) (LET ((*CONTEXT* (MAKE-CONTEXT :VALUES-USED 1 :APPLIED-CONTEXT *CONTEXT*))) (ALPHA-FORM FORM))))
+
+(DEFUN ALPHA-GO (TAG) (IL:* IL:\; "Edited 31-Jan-92 12:43 by jrb:") (LET ((DEST (ASSOC TAG *TAGBODY-STACK*))) (WHEN (NULL DEST) (COND ((NULL *TAGBODY-STACK*) (COMPILER-CERROR "Replace the GO with NIL" "The GO tag ~S does not appear in any enclosing TAGBODY" TAG) (RETURN-FROM ALPHA-GO *LITERALLY-NIL*)) (T (COMPILER-CERROR "Use the tag ~*~S instead" "The GO tag ~S does not appear in any enclosing TAGBODY" TAG (CAAR *TAGBODY-STACK*)) (SETQ DEST (CAR *TAGBODY-STACK*))))) (MAKE-GO :TAGBODY (CDR DEST) :TAG (CAR DEST))))
+
+(DEFUN ALPHA-IF (PRED-FORM THEN-FORM ELSE-FORM) (MAKE-IF :PRED (LET ((*CONTEXT* *PREDICATE-CONTEXT*)) (ALPHA-FORM PRED-FORM)) :THEN (ALPHA-FORM THEN-FORM) :ELSE (ALPHA-FORM ELSE-FORM)))
+
+(DEFUN ALPHA-IL-FUNCTION (FN CLOSE-P-FORM) (IL:* IL:|;;;| "If there is no close-p-form, then this is just like Common Lisp FUNCTION except that (IL:FUNCTION symbol) == 'symbol.") (IL:* IL:|;;;| "If there is a close-p-form, then turn this into a function call, remembering to quote the close-p-form and either quote or hash-quote the function.") (IL:* IL:|;;| "Account for block compilation.") (WHEN (AND (SYMBOLP FN) (NOT (NULL *CURRENT-BLOCK*))) (LET ((LOOKUP (ASSOC FN (BLOCK-DECL-FN-NAME-MAP *CURRENT-BLOCK*)))) (WHEN (NOT (NULL LOOKUP)) (IL:* IL:\; "This function is to be renamed.") (SETQ FN (CDR LOOKUP))))) (IF (NULL CLOSE-P-FORM) (COND ((AND (SYMBOLP FN) (NOT (ENV-FBOUNDP *ENVIRONMENT* FN))) (CHECK-FOR-UNKNOWN-FUNCTION FN) (ALPHA-LITERAL FN)) (T (ALPHA-FUNCTION FN))) (MAKE-CALL :FN (MAKE-REFERENCE-TO-VARIABLE :NAME (QUOTE IL:FUNCTION) :SCOPE :GLOBAL :KIND :FUNCTION) :ARGS (LIST (IF (SYMBOLP FN) (ALPHA-LITERAL FN) (ALPHA-FUNCTION FN)) (ALPHA-LITERAL CLOSE-P-FORM)))))
+
+(DEFUN ALPHA-LABELS (BINDINGS BODY) (IL:* IL:|;;;| "Make a first pass down the list of bindings in order to set up the environment in which they will all be defined.  Then alphatize each definition and transform the whole thing into a LABELS binding structure.") (LET* ((*ENVIRONMENT* (MAKE-CHILD-ENV *ENVIRONMENT*)) (LABELS (MAKE-LABELS)) (STRUCTS (MAPCAR (FUNCTION (LAMBDA (BINDING) (LET* ((BINDING-NAME (CAR BINDING)) (SETF? (CL::SETF-NAME-P BINDING-NAME)) (BINDING-NAME-STRING (IF SETF? (CONCATENATE (QUOTE STRING) "Local SETF for " (SYMBOL-NAME (SECOND BINDING-NAME))) (SYMBOL-NAME BINDING-NAME)))) (UNLESS (OR SETF? (CHECK-ARG BINDING-NAME)) (SETQ BINDING (CONS (QUOTE %LOSE%) (CDR BINDING)))) (LET ((STRUCT (MAKE-VARIABLE :NAME (IL:* IL:|;;| "Really want name to be \"Foo in Bar\"") BINDING-NAME-STRING :SCOPE :LEXICAL :KIND :FUNCTION :BINDER LABELS))) (ENV-BIND-FUNCTION *ENVIRONMENT* BINDING-NAME :FUNCTION STRUCT) STRUCT)))) BINDINGS))) (MULTIPLE-VALUE-BIND (FORMS DECLS) (PARSE-BODY BODY *ENVIRONMENT* NIL) (BINDING-CONTOUR DECLS (UPDATE-ENVIRONMENT *ENVIRONMENT*) (SETF (LABELS-FUNS LABELS) (MAPCAR (FUNCTION (LAMBDA (BINDING STRUCT) (CONS STRUCT (ALPHA-LAMBDA (BINDING-TO-LAMBDA BINDING) :NAME (VARIABLE-NAME STRUCT))))) BINDINGS STRUCTS)) (SETF (LABELS-BODY LABELS) (ALPHA-PROGN FORMS)))) LABELS))
+
+(DEFUN ALPHA-LAMBDA (ORIGINAL-FORM &KEY ((:CONTEXT *CONTEXT*) *NULL-CONTEXT*) NAME) (IL:* IL:|;;| "Check for something other than a CL:LAMBDA and coerce if necessary.") (MULTIPLE-VALUE-BIND (FORM ARG-TYPE) (CONVERT-TO-CL-LAMBDA ORIGINAL-FORM) (IL:* IL:|;;| "Crack the argument list, applying any declarations that might be present.") (LET ((ARG-LIST (SECOND FORM)) (BODY (CDDR FORM)) (*ENVIRONMENT* (MAKE-CHILD-ENV *ENVIRONMENT*))) (MULTIPLE-VALUE-BIND (CODE DECLS) (PARSE-BODY BODY *ENVIRONMENT* T) (BINDING-CONTOUR DECLS (IL:* IL:\; "Process the declarations") (UPDATE-ENVIRONMENT *ENVIRONMENT*) (LET* ((NODE (MAKE-LAMBDA :NAME NAME :ARG-TYPE ARG-TYPE)) (AUXES (ALPHA-LAMBDA-LIST ARG-LIST NODE)) (BODY-NODE (ALPHA-PROGN CODE))) (IL:* IL:|;;| "AUXES is now the list of values representing the &aux variables IN REVERSE ORDER.  We must bind them around the body one-by-one and then wrap that in the lambda node we've already created.") (IL:|for| AUX IL:|in| AUXES IL:|do| (LET ((BINDER (MAKE-LAMBDA :REQUIRED (LIST (CAR AUX)) :BODY BODY-NODE))) (SETF (VARIABLE-BINDER (CAR AUX)) BINDER) (SETQ BODY-NODE (MAKE-CALL :FN BINDER :ARGS (LIST (CDR AUX)))))) (SETF (LAMBDA-BODY NODE) BODY-NODE) (IL:* IL:|;;| "For Interlisp LAMBDA no-spread's, we need to save away the parameter name so that we can generate code for ARG properly.  (Yecch...)") (WHEN (EQ ARG-TYPE 2) (SETF (LAMBDA-NO-SPREAD-NAME NODE) (SECOND ORIGINAL-FORM))) NODE))))))
+
+(DEFUN ALPHA-LAMBDA-LIST (ARG-LIST BINDER) (IL:* IL:\; "Edited 31-Jan-92 12:47 by jrb:") (IL:* IL:|;;;| "Alpha-converts the argument list of a lambda form.  Stores the results of the analysis into the appropriate slots of the LAMBDA structure in BINDER.  Returns a list of the values representing the &aux argument variables, in reverse order of binding.") (LET ((STATE :REQUIRED) REQUIRED OPTIONAL KEYWORD AUX) (DOLIST (ARG ARG-LIST) (CASE ARG ((&OPTIONAL) (IF (EQ STATE :REQUIRED) (SETQ STATE :OPTIONAL) (COMPILER-CERROR "Ignore it." "Misplaced &optional in lambda-list"))) ((&REST) (IF (MEMBER STATE (QUOTE (:REQUIRED :OPTIONAL))) (SETQ STATE :REST) (COMPILER-CERROR "Ignore it." "Misplaced &rest in lambda-list"))) ((&IGNORE-REST) (IL:* IL:\; "Internal keyword used in translation of Interlisp spread functions.") (ASSERT (EQ STATE :OPTIONAL) NIL "BUG: Misplaced &IGNORE-REST keyword.") (SETF (LAMBDA-REST BINDER) (MAKE-VARIABLE :BINDER BINDER)) (RETURN) (IL:* IL:\; "Nothing is supposed to follow an &IGNORE-REST")) ((&KEY) (IF (AND (IL:NEQ STATE :AUX) (IL:NEQ STATE :KEY)) (SETQ STATE :KEY) (COMPILER-CERROR "Ignore it." "Misplaced &key in lambda-list"))) ((&ALLOW-OTHER-KEYS) (UNLESS (EQ STATE :KEY) (COMPILER-CERROR "Ignore it." "Stray &allow-other-keys in lambda-list.")) (SETF (LAMBDA-ALLOW-OTHER-KEYS BINDER) T)) ((&AUX) (IF (IL:NEQ STATE :AUX) (SETQ STATE :AUX) (COMPILER-CERROR "Ignore it." "Misplaced &aux in lambda-list."))) (OTHERWISE (ECASE STATE ((:REQUIRED) (WHEN (CHECK-ARG ARG) (PUSH (BIND-PARAMETER ARG BINDER *ENVIRONMENT*) REQUIRED))) ((:OPTIONAL) (IF (ATOM ARG) (WHEN (CHECK-ARG ARG) (PUSH (LIST (BIND-PARAMETER ARG BINDER *ENVIRONMENT*) *LITERALLY-NIL*) OPTIONAL)) (DESTRUCTURING-BIND (VAR &OPTIONAL (INIT-FORM NIL) (SVAR NIL SV-GIVEN)) ARG (WHEN (CHECK-ARG VAR) (LET ((INIT-STRUCT (ALPHA-ARGUMENT-FORM INIT-FORM))) (PUSH (IL:BQUOTE ((IL:\\\, (BIND-PARAMETER VAR BINDER *ENVIRONMENT*)) (IL:\\\, INIT-STRUCT) (IL:\\\,@ (AND SV-GIVEN (CHECK-ARG SVAR) (LIST (BIND-PARAMETER SVAR BINDER *ENVIRONMENT*)))))) OPTIONAL)))))) ((:REST) (WHEN (CHECK-ARG ARG) (SETF (LAMBDA-REST BINDER) (BIND-PARAMETER ARG BINDER *ENVIRONMENT*)) (SETQ STATE :AFTER-REST))) ((:AFTER-REST) (COMPILER-CERROR "Ignore it." "Stray argument ~S found after &rest var.")) ((:KEY) (IF (ATOM ARG) (WHEN (CHECK-ARG ARG) (PUSH (LIST (INTERN (STRING ARG) "KEYWORD") (BIND-PARAMETER ARG BINDER *ENVIRONMENT*) *LITERALLY-NIL*) KEYWORD)) (DESTRUCTURING-BIND (KEY&VAR &OPTIONAL (INIT-FORM NIL) (SVAR NIL SV-GIVEN) &AUX KEY VAR) ARG (COND ((ATOM KEY&VAR) (WHEN (CHECK-ARG KEY&VAR) (IL:* IL:|;;| "This is not the real legality test; that's below.  This just makes sure that the intern will work.") (SETQ KEY (INTERN (STRING KEY&VAR) "KEYWORD"))) (SETQ VAR KEY&VAR)) (T (SETQ KEY (FIRST KEY&VAR)) (SETQ VAR (SECOND KEY&VAR)))) (WHEN (CHECK-ARG VAR) (LET ((INIT-STRUCT (ALPHA-ARGUMENT-FORM INIT-FORM))) (PUSH (IL:BQUOTE ((IL:\\\, KEY) (IL:\\\, (BIND-PARAMETER VAR BINDER *ENVIRONMENT*)) (IL:\\\, INIT-STRUCT) (IL:\\\,@ (AND SV-GIVEN (CHECK-ARG SVAR) (LIST (BIND-PARAMETER SVAR BINDER *ENVIRONMENT*)))))) KEYWORD)))))) ((:AUX) (LET (VAR VAL) (COND ((ATOM ARG) (SETQ VAR ARG) (SETQ VAL NIL)) (T (SETQ VAR (FIRST ARG)) (SETQ VAL (SECOND ARG)))) (WHEN (CHECK-ARG VAR) (LET ((TREE (ALPHA-ARGUMENT-FORM VAL))) (PUSH (CONS (BIND-PARAMETER VAR BINDER *ENVIRONMENT*) TREE) AUX))))))))) (SETF (LAMBDA-REQUIRED BINDER) (NREVERSE REQUIRED)) (SETF (LAMBDA-OPTIONAL BINDER) (NREVERSE OPTIONAL)) (SETF (LAMBDA-KEYWORD BINDER) (NREVERSE KEYWORD)) AUX))
+
+(DEFUN ALPHA-LET (BINDINGS BODY) (IL:* IL:|;;| "Install the new variables in a new environment and then install that environment before alphatizing the body.") (MULTIPLE-VALUE-BIND (BODY DECLS) (PARSE-BODY BODY *ENVIRONMENT* NIL) (BINDING-CONTOUR DECLS (LET ((*ENVIRONMENT* (MAKE-CHILD-ENV *ENVIRONMENT*))) (IL:* IL:|;;| "The standard is losing and wants us to install the environment before alphatizing the init-forms so that SPECIAL declarations will have bigger scope.  Ugh.") (UPDATE-ENVIRONMENT *ENVIRONMENT*) (LET ((VARS NIL) (VALS NIL) (NEW-LAMBDA (MAKE-LAMBDA))) (IL:* IL:|;;| "Alphatize the init-forms.") (IL:|for| BINDING IL:|in| BINDINGS IL:|do| (COND ((CONSP BINDING) (PUSH (FIRST BINDING) VARS) (PUSH (ALPHA-ARGUMENT-FORM (SECOND BINDING)) VALS)) (T (PUSH BINDING VARS) (PUSH *LITERALLY-NIL* VALS)))) (IL:* IL:|;;| "Bind all of the variables") (SETF (LAMBDA-REQUIRED NEW-LAMBDA) (IL:|for| VAR IL:|in| (NREVERSE VARS) IL:|collect| (BIND-PARAMETER (IF (CHECK-ARG VAR) VAR (QUOTE %LOSE%)) NEW-LAMBDA *ENVIRONMENT*))) (IL:* IL:|;;| "Alphatize the body") (SETF (LAMBDA-BODY NEW-LAMBDA) (ALPHA-PROGN BODY)) (MAKE-CALL :FN NEW-LAMBDA :ARGS (NREVERSE VALS)))))))
+
+(DEFUN ALPHA-LET* (BINDINGS BODY) (IL:* IL:|;;;| "Install the new variables in the environment one at a time, processing the next in an environment including those that came before.  The LET* is then represented as several nested lambdas, so we must be careful to get the BINDER links set up properly.") (MULTIPLE-VALUE-BIND (BODY DECLS) (PARSE-BODY BODY *ENVIRONMENT* NIL) (BINDING-CONTOUR DECLS (LET ((*ENVIRONMENT* (MAKE-CHILD-ENV *ENVIRONMENT*)) (BINDING-LIST NIL)) (UPDATE-ENVIRONMENT *ENVIRONMENT*) (IL:* IL:|;;| "First, alphatize each of the init-forms in the correct environment.") (IL:|for| BINDING IL:|in| BINDINGS IL:|do| (IF (CONSP BINDING) (LET ((INIT-STRUCT (ALPHA-ARGUMENT-FORM (SECOND BINDING)))) (PUSH (CONS (BIND-PARAMETER (IF (CHECK-ARG (FIRST BINDING)) (FIRST BINDING) (QUOTE %LOSE%)) NIL *ENVIRONMENT*) INIT-STRUCT) BINDING-LIST)) (PUSH (CONS (BIND-PARAMETER (IF (CHECK-ARG BINDING) BINDING (QUOTE %LOSE%)) NIL *ENVIRONMENT*) *LITERALLY-NIL*) BINDING-LIST))) (IL:* IL:|;;| "BINDING-LIST is now in reverse order, so we can construct the nested lambdas from the inside out.") (IL:|bind| (BODY-STRUCT IL:_ (ALPHA-PROGN BODY)) IL:|for| PAIR IL:|in| BINDING-LIST IL:|do| (LET ((BINDER (MAKE-LAMBDA :REQUIRED (LIST (CAR PAIR)) :BODY BODY-STRUCT))) (SETQ BODY-STRUCT (MAKE-CALL :FN BINDER :ARGS (LIST (CDR PAIR)))) (SETF (VARIABLE-BINDER (CAR PAIR)) BINDER)) IL:|finally| (RETURN BODY-STRUCT))))))
+
+(DEFUN ALPHA-LITERAL (VALUE) (IL:* IL:|;;;| "Check for certain special values that have preallocated LITERAL structures.  Otherwise, make a new one.  The test for undumpable values used to be done in both COMPILE and COMPILE-FILE, but this lost in loading PCL, which COMPILE's functions containing circular structures as literals.") (CASE VALUE ((NIL) *LITERALLY-NIL*) ((T) *LITERALLY-T*) (OTHERWISE (MAKE-LITERAL :VALUE (COND ((AND (STREAMP *INPUT-STREAM*) (IL:* IL:\; "This is COMPILE-FILE") (NOT (FASL:VALUE-DUMPABLE-P VALUE))) (RESTART-CASE (ERROR "The literal value ~S would not be dumpable in a FASL file." VALUE) (NIL NIL :REPORT "Use the value NIL instead" NIL) (NIL NIL :REPORT (LAMBDA (STREAM) (FORMAT STREAM "Use the value ~S anyway and hope for the best" VALUE)) VALUE))) (T VALUE))))))
+
+(DEFUN ALPHA-MACROLET (BINDINGS BODY) (IL:* IL:|;;;| "Turn the bindings into expansion functions and add them into the environment for the analysis of the body.") (LET ((NEW-ENV (MAKE-CHILD-ENV *ENVIRONMENT*))) (IL:|for| MACRO IL:|in| BINDINGS IL:|do| (ENV-BIND-FUNCTION NEW-ENV (CAR MACRO) :MACRO (CRACK-DEFMACRO (CONS (QUOTE DEFMACRO) MACRO)))) (LET ((*ENVIRONMENT* NEW-ENV)) (MULTIPLE-VALUE-BIND (FORMS DECLS) (PARSE-BODY BODY *ENVIRONMENT* NIL) (BINDING-CONTOUR DECLS (UPDATE-ENVIRONMENT *ENVIRONMENT*) (ALPHA-PROGN FORMS))))))
+
+(DEFUN ALPHA-MV-CALL (FN-FORM ARG-FORMS) (LET (VALUES-USED) (MULTIPLE-VALUE-BIND (FN NOT-INLINE?) (ALPHA-FUNCTIONAL-FORM FN-FORM) (COND ((AND (NULL (CDR ARG-FORMS)) (LAMBDA-P FN) (NOT (OR (LAMBDA-OPTIONAL FN) (LAMBDA-REST FN) (LAMBDA-KEYWORD FN)))) (IL:* IL:\; "In this very common case, we can tell how many values are expected.") (SETQ VALUES-USED (LENGTH (LAMBDA-REQUIRED FN)))) (T (SETQ VALUES-USED :UNKNOWN))) (IF (NULL ARG-FORMS) (IL:* IL:\; "This is silly, but we'd better handle it correctly.") (MAKE-CALL :FN FN :ARGS NIL :NOT-INLINE NOT-INLINE?) (MAKE-MV-CALL :FN FN :ARG-EXPRS (LET ((*CONTEXT* (MAKE-CONTEXT :VALUES-USED VALUES-USED))) (MAPCAR (FUNCTION ALPHA-FORM) ARG-FORMS)) :NOT-INLINE NOT-INLINE?)))))
+
+(DEFUN ALPHA-MV-PROG1 (FORMS) (LET ((VALS-USED (CONTEXT-VALUES-USED *CONTEXT*))) (COND ((NULL (CDR FORMS)) (ALPHA-FORM (CAR FORMS))) ((AND (NUMBERP VALS-USED) (< VALS-USED 2)) (IL:* IL:\; "The multiple values aren't wanted.  Make this a normal PROG1.") (ALPHA-FORM (CONS (QUOTE PROG1) FORMS))) (T (MAKE-MV-PROG1 :STMTS (CONS (ALPHA-FORM (FIRST FORMS)) (LET ((*CONTEXT* *EFFECT-CONTEXT*)) (MAPCAR (FUNCTION ALPHA-FORM) (REST FORMS)))))))))
+
+(DEFUN ALPHA-PROGN (FORMS) (IF (NULL (CDR FORMS)) (ALPHA-FORM (CAR FORMS)) (MAKE-PROGN :STMTS (LET ((OLD-CONTEXT *CONTEXT*) (*CONTEXT* *EFFECT-CONTEXT*)) (IL:|for| TAIL IL:|on| FORMS IL:|collect| (IF (NULL (CDR TAIL)) (LET ((*CONTEXT* OLD-CONTEXT)) (ALPHA-FORM (CAR TAIL))) (ALPHA-FORM (CAR TAIL))))))))
+
+(DEFUN ALPHA-PROGV (SYMS-EXPR VALS-EXPR BODY-FORMS) (MAKE-PROGV :SYMS-EXPR (ALPHA-ARGUMENT-FORM SYMS-EXPR) :VALS-EXPR (ALPHA-ARGUMENT-FORM VALS-EXPR) :STMT (ALPHA-PROGN BODY-FORMS)))
+
+(DEFUN ALPHA-RETURN-FROM (NAME FORM) (IL:* IL:\; "Edited 31-Jan-92 12:44 by jrb:") (LET ((DEST (ASSOC NAME *BLOCK-STACK*))) (WHEN (NULL DEST) (COND ((NULL *BLOCK-STACK*) (COMPILER-CERROR "Treat (RETURN-FROM name value-form) as simply value-form" "~S, found in a RETURN-FROM, is not the name of any enclosing BLOCK" NAME) (RETURN-FROM ALPHA-RETURN-FROM (ALPHA-FORM FORM))) (T (COMPILER-CERROR "Use the name ~*~S instead" "~S, found in a RETURN-FROM, is not the name of any enclosing BLOCK" NAME (CAAR *BLOCK-STACK*)) (SETQ DEST (CAR *BLOCK-STACK*))))) (MAKE-RETURN :BLOCK (CDR DEST) :VALUE (LET ((*CONTEXT* (BLOCK-CONTEXT (CDR DEST)))) (ALPHA-FORM FORM)))))
+
+(DEFUN ALPHA-SETQ (KIND FORMS) (IL:* IL:\; "Edited 31-Jan-92 12:49 by jrb:") (LET ((SETQS (IL:|for| TAIL IL:|on| FORMS IL:|by| (CDDR TAIL) IL:|collect| (WHEN (AND (EQ KIND (QUOTE SETQ)) (NULL (CDR TAIL))) (COMPILER-CERROR "Add an extra NIL on the end of the form" "Odd number of forms given to SETQ.")) (MAKE-SETQ :VAR (RESOLVE-VARIABLE-REFERENCE *ENVIRONMENT* (CAR TAIL) T) :VALUE (ALPHA-ARGUMENT-FORM (CADR TAIL)))))) (IF (NULL (CDR SETQS)) (CAR SETQS) (MAKE-PROGN :STMTS SETQS))))
+
+(DEFUN ALPHA-TAGBODY (BODY) (IL:* IL:|;;;| "Break up the body into `segments', each of which is an unbroken series of forms along with the zero or more tags that begin that series of forms.") (WHEN (NULL BODY) (RETURN-FROM ALPHA-TAGBODY *LITERALLY-NIL*)) (LET ((TAGBODY (MAKE-TAGBODY)) (*TAGBODY-STACK* *TAGBODY-STACK*)) (IL:* IL:|;;| "Make a first pass down the body to find all of the tags") (IL:|for| FORM IL:|in| BODY IL:|do| (WHEN (ATOM FORM) (PUSH (CONS FORM TAGBODY) *TAGBODY-STACK*))) (IL:* IL:|;;| "On the second pass, put together the segments and alphatize all of the forms") (DO ((*CONTEXT* *EFFECT-CONTEXT*) (SEGMENT-LIST NIL)) ((NULL BODY) (SETF (TAGBODY-SEGMENTS TAGBODY) (NREVERSE SEGMENT-LIST))) (LET ((SEGMENT (MAKE-SEGMENT))) (DO NIL ((OR (NULL BODY) (CONSP (CAR BODY)))) (PUSH (POP BODY) (SEGMENT-TAGS SEGMENT))) (DO ((FORM-LIST NIL)) ((OR (NULL BODY) (ATOM (CAR BODY))) (SETF (SEGMENT-STMTS SEGMENT) (NREVERSE FORM-LIST))) (PUSH (ALPHA-FORM (POP BODY)) FORM-LIST)) (PUSH SEGMENT SEGMENT-LIST))) TAGBODY))
+
+(DEFUN ALPHA-THROW (TAG VALUE) (MAKE-THROW :TAG (ALPHA-ARGUMENT-FORM TAG) :VALUE (LET ((*CONTEXT* *NULL-CONTEXT*)) (ALPHA-FORM VALUE))))
+
+(DEFUN ALPHA-UNWIND-PROTECT (BODY CLEANUPS) (MAKE-UNWIND-PROTECT :STMT (ALPHA-LAMBDA (LET ((CLEANUP-VAR (GENSYM))) (IL:BQUOTE (LAMBDA ((IL:\\\, CLEANUP-VAR)) (MULTIPLE-VALUE-PROG1 (IL:\\\, BODY) (FUNCALL (IL:\\\, CLEANUP-VAR)))))) :CONTEXT *CONTEXT* :NAME (QUOTE SI::*UNWIND-PROTECT*)) :CLEANUP (ALPHA-LAMBDA (IL:BQUOTE (LAMBDA NIL (IL:\\\,@ CLEANUPS))) :CONTEXT *EFFECT-CONTEXT* :NAME "Clean-up forms")))
+
+(DEFUN CONVERT-TO-CL-LAMBDA (FORM) (IL:* IL:\; "Edited 31-Jan-92 12:41 by jrb:") (IL:* IL:|;;| "Return two values: a CL:LAMBDA form equivalent to the given one and the Interlisp ARGTYPE for the form.") (CASE (CAR FORM) ((LAMBDA) (IL:* IL:|;;| "Common Lisp LAMBDA's have indeterminate ARGTYPE.  The assembler will figure out whether it's 0 or 2.  The LOCALVARS declaration is because Interlisp's scoping rules have overwhelmed those of Common Lisp, may they rest in peace.") (VALUES (IL:BQUOTE (LAMBDA (IL:\\\, (SECOND FORM)) (DECLARE (IL:LOCALVARS . T)) (IL:\\\,@ (CDDR FORM)))) NIL)) ((IL:LAMBDA IL:OPENLAMBDA) (IF (LISTP (SECOND FORM)) (IL:* IL:|;;| "LAMBDA spread.  Use the Common Lisp &OPTIONAL keyword and also one made for internal compiler use that will throw away the extra arguments.") (VALUES (IL:BQUOTE (LAMBDA (&OPTIONAL (IL:\\\,@ (SECOND FORM)) &IGNORE-REST) (IL:\\\,@ (CDDR FORM)))) 0) (IL:* IL:|;;| "LAMBDA no-spread.  Bind the parameter to the number of arguments passed.  The handling of ARG must be done in code generation, unfortunately.") (VALUES (IL:BQUOTE (LAMBDA NIL (LET (((IL:\\\, (SECOND FORM)) (IL:\\MYARGCOUNT))) (IL:\\\,@ (CDDR FORM))))) 2))) ((IL:NLAMBDA) (IF (LISTP (SECOND FORM)) (IL:* IL:|;;| "NLAMBDA spread.  Just like the LAMBDA-spread case but we have a different ARG-TYPE.") (VALUES (IL:BQUOTE (LAMBDA (&OPTIONAL (IL:\\\,@ (SECOND FORM)) &IGNORE-REST) (IL:\\\,@ (CDDR FORM)))) 1) (IL:* IL:|;;| "NLAMBDA no-spread.  We take exactly one argument and are otherwise entirely normal.") (VALUES (IL:BQUOTE (LAMBDA ((IL:\\\, (SECOND FORM))) (IL:\\\,@ (CDDR FORM)))) 3))) (OTHERWISE (IL:* IL:|;;| "This is not my beautiful LAMBDA form!") (COMPILER-CERROR "Use (LAMBDA () NIL) instead" "The form ~S should be a LAMBDA form but is not." FORM) (VALUES (QUOTE (LAMBDA NIL NIL)) 0))))
+
+(DEFUN COMPLETELY-EXPAND (FORM) (IF (ATOM FORM) FORM (LET ((NEW-FORM FORM) CHANGED-P) (IL:|until| (MEMBER (CAR NEW-FORM) (QUOTE (BLOCK CATCH COMPILER-LET DECLARE EVAL-WHEN FLET IL:FUNCTION FUNCTION GO IF LABELS LET LET* MACROLET SI::%MACROLET MULTIPLE-VALUE-CALL MULTIPLE-VALUE-PROG1 PROGN PROGV QUOTE SETQ IL:SETQ TAGBODY THE THROW UNWIND-PROTECT)) :TEST (QUOTE EQ)) IL:|do| (MULTIPLE-VALUE-SETQ (NEW-FORM CHANGED-P) (OPTIMIZE-AND-MACROEXPAND-1 NEW-FORM)) (WHEN (NULL CHANGED-P) (IF (AND (CONSP (CAR NEW-FORM)) (EQ (QUOTE IL:OPENLAMBDA) (CAAR NEW-FORM))) (SETQ NEW-FORM (EXPAND-OPENLAMBDA-CALL (CAR NEW-FORM) (CDR NEW-FORM))) (RETURN NEW-FORM))) IL:|finally| (RETURN NEW-FORM)))))
+
+(DEFUN EXPAND-OPENLAMBDA-CALL (FN ARGS) (IL:* IL:|;;;| "The idea here is to try to do some substitution into the body of the OPENLAMBDA.  We do it here instead of in meta-evaluation because there are parts of the Interlisp system that count on their optimizers being able to find literals in their arguments.  They count on the substitution being done so that that will be the case.") (IL:* IL:|;;;| "It is well-known that the use of SUBLIS here is a bug: for example, if one of the arguments to the OPENLAMBDA has the same name as one of the functions called therein, the subst will still change both of them, undoubtably leading to chaos.  However, the ByteCompiler has always done it this way and nothing broke, so, since it's also very easy, we do it too.  If anything actually counts on this, though, I may kill the author.") (IL:* IL:|;;;| "The general details of this transformation are the way they are because it's the way the ByteCompiler did it.  Pavel will never defend this code on philosophical grounds.  (\"If this code is caught or killed, Pavel will disavow any knowledge of its actions...\")") (LET ((UNSUBBED-PARAMS NIL) (UNSUBBED-ARGS NIL) (SUBST-ALIST NIL) EXTRA-ARGS) (DO* ((PARAMS (CADR FN) (CDR PARAMS)) (ARGS (LET ((*CONTEXT* *ARGUMENT-CONTEXT*)) (MAPCAR (QUOTE COMPLETELY-EXPAND) ARGS)) (CDR ARGS)) (ARG (CAR ARGS) (CAR ARGS))) ((NULL PARAMS) (SETQ EXTRA-ARGS ARGS)) (IL:* IL:|;;| "For each pair, if the argument is a constant, add it to the substitution we'll later apply.") (COND ((OR (CONSTANTP ARG) (AND (ATOM ARG) (NOT (SYMBOLP ARG))) (AND (CONSP ARG) (EQ (CAR ARG) (QUOTE IL:FUNCTION)) (SYMBOLP (CADR ARG)))) (PUSH (CONS (CAR PARAMS) ARG) SUBST-ALIST)) (T (PUSH (CAR PARAMS) UNSUBBED-PARAMS) (PUSH ARG UNSUBBED-ARGS)))) (WHEN (NULL UNSUBBED-ARGS) (IL:* IL:\; "We got rid of all of them.") (RETURN-FROM EXPAND-OPENLAMBDA-CALL (IL:BQUOTE (PROGN (IL:\\\,@ EXTRA-ARGS) (IL:\\\,@ (SUBLIS SUBST-ALIST (CDDR FN) :TEST (QUOTE EQ))))))) (IL:* IL:|;;| "Perhaps there're no extra arguments or they're all constants.  This should really be a full-blown test for side-effect freedom, but that's too much work for alphatization.") (COND ((AND EXTRA-ARGS (NOTEVERY (FUNCTION (LAMBDA (ARG) (OR (CONSTANTP ARG) (AND (ATOM ARG) (NOT (SYMBOLP ARG))) (AND (CONSP ARG) (MEMBER (CAR ARG) (QUOTE (IL:FUNCTION FUNCTION))))))))) (IL:* IL:|;;| "There're extra arguments in the way, so we're done.") (SETF (CAR UNSUBBED-ARGS) (IL:BQUOTE (PROG1 (IL:\\\, (CAR UNSUBBED-ARGS)) (IL:\\\,@ EXTRA-ARGS)))) (IL:BQUOTE ((LAMBDA (IL:\\\, (REVERSE UNSUBBED-PARAMS)) (IL:\\\,@ (SUBLIS SUBST-ALIST (CDDR FN) :TEST (QUOTE EQ)))) (IL:\\\,@ (REVERSE UNSUBBED-ARGS))))) (T (IL:* IL:|;;| "There's nothing interesting between the body and the as yet unsubbed arguments, so maybe we can also substitute some variables.  Note that because the unsubbed lists are in reverse order now, we can easily examine the arguments starting with the last one and working backwards, just as we'd like.") (IL:|while| (AND UNSUBBED-ARGS (SYMBOLP (FIRST UNSUBBED-ARGS))) IL:|do| (PUSH (CONS (POP UNSUBBED-PARAMS) (POP UNSUBBED-ARGS)) SUBST-ALIST)) (COND ((NULL UNSUBBED-ARGS) (IL:* IL:\; "All substituted in.") (IL:BQUOTE (PROGN (IL:\\\,@ (SUBLIS SUBST-ALIST (CDDR FN) :TEST (QUOTE EQ)))))) ((MEMBER (CAR (FIRST UNSUBBED-ARGS)) (QUOTE (IL:SETQ SETQ))) (COND ((NULL (CDR UNSUBBED-ARGS)) (PUSH (CONS (FIRST UNSUBBED-PARAMS) (CADR (FIRST UNSUBBED-ARGS))) SUBST-ALIST) (IL:BQUOTE (PROGN (IL:\\\, (FIRST UNSUBBED-ARGS)) (IL:\\\,@ (SUBLIS SUBST-ALIST (CDDR FN) :TEST (QUOTE EQ)))))) (T (PUSH (CONS (POP UNSUBBED-PARAMS) (CADR (FIRST UNSUBBED-ARGS))) SUBST-ALIST) (SETQ UNSUBBED-ARGS (CONS (IL:BQUOTE (PROG1 (IL:\\\, (SECOND UNSUBBED-ARGS)) (IL:\\\, (FIRST UNSUBBED-ARGS)))) (CDDR UNSUBBED-ARGS))) (IL:BQUOTE ((LAMBDA (IL:\\\, (REVERSE UNSUBBED-PARAMS)) (IL:\\\,@ (SUBLIS SUBST-ALIST (CDDR FN) :TEST (QUOTE EQ)))) (IL:\\\,@ (REVERSE UNSUBBED-ARGS))))))) (T (IL:BQUOTE ((LAMBDA (IL:\\\, (REVERSE UNSUBBED-PARAMS)) (IL:\\\,@ (SUBLIS SUBST-ALIST (CDDR FN) :TEST (QUOTE EQ)))) (IL:\\\,@ (REVERSE UNSUBBED-ARGS))))))))))
+
+
+
+(IL:* IL:|;;| "Alphatization testing")
+
+
+(DEFPARAMETER *INDENT-INCREMENT* 3 (IL:* IL:|;;;| "Number of spaces by which the indentation should increase in nested nodes."))
+
+(DEFVAR *NODE-HASH* NIL "Used by the parse-tree pretty-printer")
+
+(DEFVAR *NODE-NUMBER* 0 "Used by the parse-tree pretty-printer")
+
+(DEFUN TEST-ALPHA (FN) (LET ((TREE (TEST-ALPHA-2 FN))) (UNWIND-PROTECT (PRINT-TREE TREE) (RELEASE-TREE TREE))))
+
+(DEFUN TEST-ALPHA-2 (FN) (LET ((*ENVIRONMENT* (MAKE-ENV)) (*CONTEXT* *NULL-CONTEXT*) (*CONSTANTS-HASH-TABLE* (MAKE-HASH-TABLE)) (IL:SPECVARS T) (IL:LOCALVARS IL:SYSLOCALVARS) (IL:GLOBALVARS IL:GLOBALVARS) (IL:LOCALFREEVARS NIL) (*PROCESSED-FUNCTIONS* NIL) (*UNKNOWN-FUNCTIONS* NIL) (*CURRENT-FUNCTION* NIL) (*AUTOMATIC-SPECIAL-DECLARATIONS* NIL)) (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS)) (ALPHA-LAMBDA (COND ((CONSP FN) FN) ((CONSP (IL:GETD FN)) (IL:GETD FN)) (T (PARSE-DEFUN (IL:GETDEF FN (QUOTE IL:FUNCTIONS))))))))
+
+(DEFUN PARSE-DEFUN (FORM) (DESTRUCTURING-BIND (IGNORE NAME ARG-LIST &BODY BODY) FORM (MULTIPLE-VALUE-BIND (FORMS DECLS) (PARSE-BODY BODY NIL T) (IL:BQUOTE (LAMBDA (IL:\\\, ARG-LIST) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\,@ FORMS)))))))
+
+(DEFUN PRINT-TREE (TREE) (LET ((*NODE-HASH* (MAKE-HASH-TABLE)) (*NODE-NUMBER* 0) (*PRINT-CASE* :UPCASE)) (PRINT-NODE TREE 0)) (TERPRI) (VALUES))
+
+(DEFUN PRINT-NODE (NODE INDENT) (IL:* IL:|;;;| "NODE is the node to print.  INDENT is the number of spaces over we are on entry to PRINT-NODE.  We should not ever print anything on the line to the left of that point.") (LET ((NUMBER (AND (NOT (LITERAL-P NODE)) (GETHASH NODE *NODE-HASH*)))) (COND (NUMBER (FORMAT T "-~S-" NUMBER)) (T (INCF *NODE-NUMBER*) (SETF (GETHASH NODE *NODE-HASH*) *NODE-NUMBER*) (FORMAT T "~S. ~A: " *NODE-NUMBER* (TYPE-OF NODE)) (LET ((NESTED-INDENT (+ INDENT *INDENT-INCREMENT*))) (MACROLET ((NEW-LINE (&OPTIONAL (DELTA 0)) (IL:BQUOTE (FORMAT T "~%~vT" (+ NESTED-INDENT (IL:\\\, DELTA))))) (PRINT-BLIPPER-INFO NIL (QUOTE (FORMAT T "  Closed-over-p: ~:[false~;true~]  New-frame-p: ~:[false~;true~]" (BLIPPER-CLOSED-OVER-P NODE) (BLIPPER-NEW-FRAME-P NODE))))) (ETYPECASE NODE (BLOCK-NODE (PRIN1 (BLOCK-NAME NODE)) (PRINT-BLIPPER-INFO) (NEW-LINE) (PRINT-NODE (BLOCK-STMT NODE) NESTED-INDENT)) (CALL-NODE (WHEN (CALLER-NOT-INLINE NODE) (PRINC "(not inline)")) (NEW-LINE) (PRINC "Func: ") (PRINT-NODE (CALL-FN NODE) (+ NESTED-INDENT 6)) (WHEN (CALL-ARGS NODE) (NEW-LINE) (PRINC "Args: ") (IL:|for| ARG-TAIL IL:|on| (CALL-ARGS NODE) IL:|do| (PRINT-NODE (CAR ARG-TAIL) (+ NESTED-INDENT 6)) (WHEN (NOT (NULL (CDR ARG-TAIL))) (NEW-LINE 6))))) (CATCH-NODE (NEW-LINE) (PRINC "Tag:  ") (PRINT-NODE (CATCH-TAG NODE) (+ NESTED-INDENT 6)) (NEW-LINE) (PRINC "Stmt: ") (PRINT-NODE (CATCH-STMT NODE) (+ NESTED-INDENT 6))) (GO-NODE (FORMAT T "to ~S" (GO-TAG NODE)) (NEW-LINE) (PRINC "Tagbody: ") (PRINT-NODE (GO-TAGBODY NODE) (+ NESTED-INDENT 9))) (IF-NODE (NEW-LINE) (PRINC "Pred: ") (PRINT-NODE (IF-PRED NODE) (+ NESTED-INDENT 6)) (NEW-LINE) (PRINC "Then: ") (PRINT-NODE (IF-THEN NODE) (+ NESTED-INDENT 6)) (NEW-LINE) (PRINC "Else: ") (PRINT-NODE (IF-ELSE NODE) (+ NESTED-INDENT 6))) (LABELS-NODE (NEW-LINE) (PRINC "Funs: ") (IL:|for| TAIL IL:|on| (LABELS-FUNS NODE) IL:|do| (PRINT-NODE (CAAR TAIL) (+ NESTED-INDENT 6)) (NEW-LINE 10) (PRINT-NODE (CDAR TAIL) (+ NESTED-INDENT 10)) (WHEN (NOT (NULL (CDR TAIL))) (NEW-LINE 6))) (NEW-LINE) (PRINC "Body: ") (PRINT-NODE (LABELS-BODY NODE) (+ NESTED-INDENT 6))) (LAMBDA-NODE (NEW-LINE) (WHEN (LAMBDA-REQUIRED NODE) (PRINC "&req: ") (IL:|for| VARS IL:|on| (LAMBDA-REQUIRED NODE) IL:|do| (PRINT-NODE (CAR VARS) (+ NESTED-INDENT 6)) (IF (NULL (CDR VARS)) (NEW-LINE) (NEW-LINE 6)))) (WHEN (LAMBDA-OPTIONAL NODE) (PRINC "&opt: ") (IL:|for| VARS IL:|on| (LAMBDA-OPTIONAL NODE) IL:|do| (DESTRUCTURING-BIND (VAR &OPTIONAL (INIT NIL I-GIVEN) (SVAR NIL SV-GIVEN)) (CAR VARS) (COND ((SYMBOLP VAR) (PRINT-NODE (CAR VARS) (+ NESTED-INDENT 6))) ((NOT I-GIVEN) (PRINT-NODE VAR (+ NESTED-INDENT 6))) (T (PRINC "(") (PRINT-NODE VAR (+ NESTED-INDENT 7)) (NEW-LINE 7) (PRINT-NODE INIT (+ NESTED-INDENT 7)) (NEW-LINE 7) (WHEN SV-GIVEN (PRINT-NODE SVAR (+ NESTED-INDENT 7)) (NEW-LINE 7)) (PRINC ")")))) (IF (NULL (CDR VARS)) (NEW-LINE) (NEW-LINE 6)))) (WHEN (LAMBDA-REST NODE) (PRINC "&rest: ") (PRINT-NODE (LAMBDA-REST NODE) (+ NESTED-INDENT 7)) (NEW-LINE)) (WHEN (LAMBDA-KEYWORD NODE) (PRINC "&key: ") (IL:|for| VARS IL:|on| (LAMBDA-KEYWORD NODE) IL:|do| (DESTRUCTURING-BIND (KEY VAR &OPTIONAL (INIT NIL I-GIVEN) (SVAR NIL SV-GIVEN)) (CAR VARS) (FORMAT T "((~S " KEY) (NEW-LINE 8) (PRINT-NODE VAR (+ NESTED-INDENT 8)) (PRINC ")") (NEW-LINE 7) (PRINT-NODE INIT (+ NESTED-INDENT 7)) (NEW-LINE 7) (WHEN SV-GIVEN (PRINT-NODE SVAR (+ NESTED-INDENT 7)) (NEW-LINE 7)) (PRINC ")")) (COND ((NULL (CDR VARS)) (WHEN (LAMBDA-ALLOW-OTHER-KEYS NODE) (PRINC "&allow-other-keys")) (NEW-LINE)) (T (NEW-LINE 6))))) (WHEN (LAMBDA-CLOSED-OVER-VARS NODE) (PRINC "Closed-over:") (NEW-LINE 10) (IL:|for| VARS IL:|on| (LAMBDA-CLOSED-OVER-VARS NODE) IL:|do| (PRINT-NODE (CAR VARS) (+ NESTED-INDENT 10)) (IF (NULL (CDR VARS)) (NEW-LINE) (NEW-LINE 10)))) (PRINT-NODE (LAMBDA-BODY NODE) NESTED-INDENT)) (LITERAL-NODE (PRIN1 (LITERAL-VALUE NODE))) (MV-CALL-NODE (WHEN (CALLER-NOT-INLINE NODE) (PRINC "(not inline)")) (NEW-LINE) (PRINC "Func: ") (PRINT-NODE (MV-CALL-FN NODE) (+ NESTED-INDENT 6)) (NEW-LINE) (PRINC "Args: ") (IL:|for| ARG-TAIL IL:|on| (MV-CALL-ARG-EXPRS NODE) IL:|do| (PRINT-NODE (CAR ARG-TAIL) (+ NESTED-INDENT 6)) (WHEN (NOT (NULL (CDR ARG-TAIL))) (NEW-LINE 6)))) (MV-PROG1-NODE (IL:|for| STMT IL:|in| (MV-PROG1-STMTS NODE) IL:|do| (NEW-LINE) (PRINT-NODE STMT NESTED-INDENT))) (OPCODES-NODE (PRIN1 (OPCODES-BYTES NODE))) (PROGN-NODE (IL:|for| STMT IL:|in| (PROGN-STMTS NODE) IL:|do| (NEW-LINE) (PRINT-NODE STMT NESTED-INDENT))) (PROGV-NODE (NEW-LINE) (PRINC "Vars: ") (PRINT-NODE (PROGV-SYMS-EXPR NODE) (+ NESTED-INDENT 6)) (NEW-LINE) (PRINC "Vals: ") (PRINT-NODE (PROGV-VALS-EXPR NODE) (+ NESTED-INDENT 6)) (NEW-LINE) (PRINC "Body: ") (PRINT-NODE (PROGV-STMT NODE) (+ NESTED-INDENT 6))) (RETURN-NODE (NEW-LINE) (PRINC "From:  ") (PRINT-NODE (RETURN-BLOCK NODE) (+ NESTED-INDENT 7)) (NEW-LINE) (PRINC "Value: ") (PRINT-NODE (RETURN-VALUE NODE) (+ NESTED-INDENT 7))) (SETQ-NODE (NEW-LINE) (PRINC "Var:   ") (PRINT-NODE (SETQ-VAR NODE) (+ NESTED-INDENT 7)) (NEW-LINE) (PRINC "Value: ") (PRINT-NODE (SETQ-VALUE NODE) (+ NESTED-INDENT 7))) (TAGBODY-NODE (PRINT-BLIPPER-INFO) (IL:|for| SEGMENT IL:|in| (TAGBODY-SEGMENTS NODE) IL:|do| (IL:|for| TAG IL:|in| (SEGMENT-TAGS SEGMENT) IL:|do| (NEW-LINE) (PRINC TAG)) (IL:|for| STMT IL:|in| (SEGMENT-STMTS SEGMENT) IL:|do| (NEW-LINE 4) (PRINT-NODE STMT (+ NESTED-INDENT 4))))) (THROW-NODE (NEW-LINE) (PRINC "Tag:   ") (PRINT-NODE (THROW-TAG NODE) (+ NESTED-INDENT 7)) (NEW-LINE) (PRINC "Value: ") (PRINT-NODE (THROW-VALUE NODE) (+ NESTED-INDENT 7))) (UNWIND-PROTECT-NODE (NEW-LINE) (PRINC "Stmt:    ") (PRINT-NODE (UNWIND-PROTECT-STMT NODE) (+ NESTED-INDENT 9)) (NEW-LINE) (PRINC "Cleanup: ") (PRINT-NODE (UNWIND-PROTECT-CLEANUP NODE) (+ NESTED-INDENT 9))) ((OR VARIABLE-STRUCT VAR-REF-NODE) (LET ((VAR (IF (VARIABLE-P NODE) NODE (VAR-REF-VARIABLE NODE)))) (FORMAT T "~S ~S ~S ~@[~*Closed-over ~]" (VARIABLE-SCOPE VAR) (VARIABLE-KIND VAR) (VARIABLE-NAME VAR) (VARIABLE-CLOSED-OVER VAR)) (WHEN (VARIABLE-BINDER VAR) (COND ((GETHASH (VARIABLE-BINDER VAR) *NODE-HASH*) (PRINC "Binder: ") (PRINT-NODE (VARIABLE-BINDER VAR) 0)) (T (NEW-LINE) (PRINC "Binder: ") (PRINT-NODE (VARIABLE-BINDER VAR) (+ NESTED-INDENT 8))))))))))))))
+
+(DEFPARAMETER CONTEXT-TEST-FORM (QUOTE (PROGN (CTXT) (LIST (IF (CTXT) (CTXT)) (MULTIPLE-VALUE-LIST (CTXT)) (MULTIPLE-VALUE-CALL (FUNCTION (LAMBDA (A B) (BAR A B))) (CTXT)) (MULTIPLE-VALUE-CALL (FUNCTION (LAMBDA (A &REST B) (BAR A B))) (CTXT)) (MULTIPLE-VALUE-CALL (FUNCTION (LAMBDA (A B) (BAR A B))) (CTXT) (CTXT)) (LET ((X (CTXT))) (SETQ X (CTXT))) ((LAMBDA (A &OPTIONAL (B (CTXT))) (CTXT)) (CTXT)) (MULTIPLE-VALUE-CALL (FUNCTION (LAMBDA (A B) (BAR A B))) ((LAMBDA (C) (CTXT)) 17))) (CTXT))) "Form for testing the alphatizer's manipulation of context information.")
+
+(DEFMACRO CTXT NIL (PRINC-TO-STRING *CONTEXT*))
+
+
+
+(IL:* IL:|;;| "Arrange to use the correct compiler.")
+
+
+(IL:PUTPROPS IL:XCLC-ALPHA IL:FILETYPE COMPILE-FILE)
+
+
+
+(IL:* IL:|;;| "Arrange for the correct makefile environment")
+
+
+(IL:PUTPROPS IL:XCLC-ALPHA IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL"))))
+(IL:PUTPROPS IL:XCLC-ALPHA IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/XCLC-ALPHA.LCOM b/CLTL2/XCLC-ALPHA.LCOM
new file mode 100644
index 00000000..5a50fc2d
Binary files /dev/null and b/CLTL2/XCLC-ALPHA.LCOM differ
diff --git a/CLTL2/XCLC-DATABASE b/CLTL2/XCLC-DATABASE
new file mode 100644
index 00000000..e9792282
--- /dev/null
+++ b/CLTL2/XCLC-DATABASE
@@ -0,0 +1,1328 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL")))
+(IL:FILECREATED "18-Oct-93 17:16:29" "{Pele:mv:envos}<LispCore>Sources>CLTL2>XCLC-DATABASE.;2" 37383  
+
+      IL:|previous| IL:|date:| " 3-Sep-91 18:26:14" 
+"{Pele:mv:envos}<LispCore>Sources>CLTL2>XCLC-DATABASE.;1")
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:XCLC-DATABASECOMS)
+
+(IL:RPAQQ IL:XCLC-DATABASECOMS
+          (
+
+(IL:* IL:|;;;| 
+"The XCL Compiler's database of information about the properties of functions and other constructs.")
+
+           (IL:DEFINE-TYPES COMPILER-DATA)
+           
+           (IL:* IL:|;;| "Side Effects (The first keyword is the effects of the function itself and the second is those effects that can affect the running of the function.)")
+
+           (IL:FUNCTIONS DECLARE-SIDE-EFFECTS SIDE-EFFECTS)
+           (IL:SETFS SIDE-EFFECTS)
+           (IL:PROP IL:PROPTYPE SIDE-EFFECTS-DATA)
+           (COMPILER-DATA ("Side-effects data for CLtL, Chapter 4: Type Specifiers" (:CONS)
+                                 :NONE)
+                  ("Side-effects data for CLtL, Chapter 4: Type Specifiers" :NONE :NONE)
+                  ("Side-effects data for CLtL, Chapter 6: Predicates" :NONE :NONE)
+                  ("Side-effects data for CLtL, Chapter 7: Control Structure" (:CONS)
+                         :ANY)
+                  ("Side-effects data for CLtL, Chapter 7: Control Structure" :ANY :NONE)
+                  ("Side-effects data for CLtL, Chapter 7: Control Structure" :NONE :ANY)
+                  ("Side-effects data for CLtL, Chapter 7: Control Structure" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 8: Macros" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 8: Macros" :NONE :ANY)
+                  ("Side-effects data for CLtL, Chapter 9: Declarations" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 10: Symbols" :NONE :ANY)
+                  ("Side-effects data for CLtL, Chapter 10: Symbols" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 10: Symbols" (:CONS LISP::*GENSYM-PREFIX* 
+                                                                            LISP::*GENSYM-COUNTER*)
+                         (LISP::*GENSYM-PREFIX* LISP::*GENSYM-COUNTER*))
+                  ("Side-effects data for CLtL, Chapter 10: Symbols" (:CONS)
+                         :NONE)
+                  ("Side-effects data for CLtL, Chapter 10: Symbols" (:CONS)
+                         :ANY)
+                  ("Side-effects data for CLtL, Chapter 10: Symbols" :NONE :NONE)
+                  ("Side-effects data for CLtL, Chapter 11: Packages" :NONE :ANY)
+                  ("Side-effects data for CLtL, Chapter 11: Packages" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 12: Numbers" (:CONS)
+                         :NONE)
+                  ("Side-effects data for CLtL, Chapter 12: Numbers" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 12: Numbers" :NONE :NONE)
+                  ("Side-effects data for CLtL, Chapter 13: Characters" :NONE :NONE)
+                  ("Side-effects data for CLtL, Chapter 14: Sequences" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 14: Sequences" :NONE :ANY)
+                  ("Side-effects data for CLtL, Chapter 14: Sequences" (:CONS)
+                         :ANY)
+                  ("Side-effects data for CLtL, Chapter 15: Lists" :NONE :NONE)
+                  ("Side-effects data for CLtL, Chapter 15: Lists" (:CONS)
+                         :NONE)
+                  ("Side-effects data for CLtL, Chapter 15: Lists" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 15: Lists" :ANY :NONE)
+                  ("Side-effects data for CLtL, Chapter 16: Hash Tables" :ANY :NONE)
+                  ("Side-effects data for CLtL, Chapter 16: Hash Tables" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 16: Hash Tables" :NONE :ANY)
+                  ("Side-effects data for CLtL, Chapter 16: Hash Tables" :NONE :NONE)
+                  ("Side-effects data for CLtL, Chapter 16: Hash Tables" (:CONS)
+                         :NONE)
+                  ("Side-effects data for CLtL, Chapter 17: Arrays" :NONE :NONE)
+                  ("Side-effects data for CLtL, Chapter 17: Arrays" :NONE :ANY)
+                  ("Side-effects data for CLtL, Chapter 17: Arrays" (:CONS)
+                         :NONE)
+                  ("Side-effects data for CLtL, Chapter 17: Arrays" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 18: Strings" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 18: Strings" (:CONS)
+                         :NONE)
+                  ("Side-effects data for CLtL, Chapter 18: Strings" (:CONS)
+                         :ANY)
+                  ("Side-effects data for CLtL, Chapter 18: Strings" :NONE :NONE)
+                  ("Side-effects data for CLtL, Chapter 18: Strings" :NONE :ANY)
+                  ("Side-effects data for CLtL, Chapter 20: The Evaluator" :NONE :ANY)
+                  ("Side-effects data for CLtL, Chapter 20: The Evaluator" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 21: Streams" (:CONS)
+                         :ANY)
+                  ("Side-effects data for CLtL, Chapter 21: Streams" (:CONS)
+                         :NONE)
+                  ("Side-effects data for CLtL, Chapter 21: Streams" :ANY :NONE)
+                  ("Side-effects data for CLtL, Chapter 21: Streams" :NONE :NONE)
+                  ("Side-effects data for CLtL, Chapter 21: Streams" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 22: Input/Output" :NONE :NONE)
+                  ("Side-effects data for CLtL, Chapter 22: Input/Output" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 22: Input/Output" :NONE :ANY)
+                  ("Side-effects data for CLtL, Chapter 22: Input/Output" (:CONS)
+                         :ANY)
+                  ("Side-effects data for CLtL, Chapter 23: File System Interface" :NONE :ANY)
+                  ("Side-effects data for CLtL, Chapter 23: File System Interface" (:CONS)
+                         :ANY)
+                  ("Side-effects data for CLtL, Chapter 23: File System Interface" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 23: File System Interface" :NONE :NONE)
+                  ("Side-effects data for CLtL, Chapter 24: Errors" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 25: Miscellaneous Features" :NONE :ANY)
+                  ("Side-effects data for CLtL, Chapter 25: Miscellaneous Features" :ANY :ANY)
+                  ("Side-effects data for CLtL, Chapter 25: Miscellaneous Features" :ANY :NONE)
+                  ("Side-effects data for CLtL, Chapter 25: Miscellaneous Features" :NONE :NONE)
+                  ("Side-effects data for IRM, Chapter 2: Litatoms" :ANY :NONE)
+                  ("Side-effects data for IRM, Chapter 2: Litatoms" :NONE :ANY)
+                  ("Side-effects data for IRM, Chapter 2: Litatoms" :NONE :NONE)
+                  ("Side-effects data for IRM, Chapter 2: Litatoms" :ANY :ANY)
+                  ("Side-effects data for IRM, Chapter 2: Litatoms" (:CONS)
+                         :ANY)
+                  ("Side-effects data for IRM, Chapter 3: Lists" :NONE :NONE)
+                  ("Side-effects data for IRM, Chapter 3: Lists" :ANY :ANY)
+                  ("Side-effects data for IRM, Chapter 3: Lists" :ANY :NONE)
+                  ("Side-effects data for IRM, Chapter 3: Lists" (:CONS)
+                         :NONE)
+                  ("Side-effects data for IRM, Chapter 3: Lists" (:CONS)
+                         :ANY)
+                  ("Side-effects data for IRM, Chapter 3: Lists" :NONE :ANY)
+                  ("Side-effects data for IRM, Chapter 4: Strings" (:CONS)
+                         :ANY)
+                  ("Side-effects data for IRM, Chapter 4: Strings" :NONE :ANY)
+                  ("Side-effects data for IRM, Chapter 4: Strings" :NONE :NONE)
+                  ("Side-effects data for IRM, Chapter 4: Strings" :ANY :ANY)
+                  ("Side-effects data for IRM, Chapter 5: Arrays" :ANY :NONE)
+                  ("Side-effects data for IRM, Chapter 5: Arrays" :NONE :ANY)
+                  ("Side-effects data for IRM, Chapter 5: Arrays" :NONE :NONE)
+                  ("Side-effects data for IRM, Chapter 5: Arrays" (:CONS)
+                         :ANY)
+                  ("Side-effects data for IRM, Chapter 6: Hash Arrays" :ANY :ANY)
+                  ("Side-effects data for IRM, Chapter 6: Hash Arrays" :NONE :NONE)
+                  ("Side-effects data for IRM, Chapter 6: Hash Arrays" (:CONS)
+                         :NONE)
+                  ("Side-effects data for IRM, Chapter 6: Hash Arrays" (:CONS)
+                         :ANY)
+                  ("Side-effects data for IRM, Chapter 6: Hash Arrays" :NONE :ANY)
+                  ("Side-effects data for IRM, Chapter 6: Hash Arrays" :ANY :NONE)
+                  ("Side-effects data for IRM, Chapter 7: Numbers and Arithmetic Functions" :ANY :ANY
+                         )
+                  ("Side-effects data for IRM, Chapter 7: Numbers and Arithmetic Functions" :NONE 
+                         :NONE)
+                  ("Side-effects data for IRM, Chapter 7: Numbers and Arithmetic Functions" :ANY 
+                         :NONE)
+                  ("Side-effects data for IRM, Chapter 8: Record Package" :NONE :ANY)
+                  ("Side-effects data for IRM, Chapter 8: Record Package" :ANY :ANY)
+                  ("Side-effects data for IRM, Chapter 9: Conditionals and Iterative Statements"
+                   :NONE :NONE)
+                  ("Side-effects data for IRM, Chapter 9: Conditionals and Iterative Statements"
+                   :NONE :ANY)
+                  ("Side-effects data for IRM, Chapter 9: Conditionals and Iterative Statements"
+                   :ANY :ANY)
+                  (
+           "Side-effects data for IRM, Chapter 10: Function Definition, Manipulation, and Evaluation"
+                   :ANY :NONE)
+                  (
+           "Side-effects data for IRM, Chapter 10: Function Definition, Manipulation, and Evaluation"
+                   :NONE :ANY)
+                  (
+           "Side-effects data for IRM, Chapter 10: Function Definition, Manipulation, and Evaluation"
+                   :ANY :ANY)
+                  (
+           "Side-effects data for IRM, Chapter 10: Function Definition, Manipulation, and Evaluation"
+                   :NONE :NONE)
+                  ("Side-effects data for IRM, Chapter 11: Variable Bindings and the Interlisp Stack"
+                   :NONE :ANY)
+                  ("Side-effects data for IRM, Chapter 11: Variable Bindings and the Interlisp Stack"
+                   :ANY :NONE)
+                  ("Side-effects data for IRM, Chapter 11: Variable Bindings and the Interlisp Stack"
+                   :ANY :ANY)
+                  ("Side-effects data for IRM, Chapter 11: Variable Bindings and the Interlisp Stack"
+                   :NONE :NONE)
+                  ("Side-effects data for IRM, Chapter 12: Miscellaneous" :NONE :NONE)
+                  ("Side-effects data for IRM, Chapter 12: Miscellaneous" :ANY :ANY)
+                  ("Side-effects data for IRM, Chapter 12: Miscellaneous" :NONE :ANY)
+                  ("Side-effects data for Pointer reads" :NONE :NONE)
+                  ("Side-effects data for Internal functions in CMLARITH" :NONE :NONE))
+           
+           (IL:* IL:|;;| "Arrange for the correct compiler to be used.")
+
+           (IL:PROP IL:FILETYPE IL:XCLC-DATABASE)
+           
+           (IL:* IL:|;;| "Set up the correct package environment.")
+
+           (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-DATABASE)))
+
+
+
+(IL:* IL:|;;;| 
+"The XCL Compiler's database of information about the properties of functions and other constructs.")
+
+
+(DEF-DEFINE-TYPE COMPILER-DATA "XCL Compiler information")
+
+
+
+(IL:* IL:|;;| 
+"Side Effects (The first keyword is the effects of the function itself and the second is those effects that can affect the running of the function.)"
+)
+
+
+(DEFDEFINER (DECLARE-SIDE-EFFECTS (:NAME (LAMBDA (WHOLE)
+                                                    (LIST (FORMAT NIL "Side-effects data for ~A"
+                                                                 (SECOND WHOLE))
+                                                          (THIRD WHOLE)
+                                                          (FOURTH WHOLE))))) COMPILER-DATA (TITLE
+                                                                                            EFFECTS 
+                                                                                            AFFECTED
+                                                                                            &REST 
+                                                                                            FUNCTIONS
+                                                                                            )
+   (COND
+      ((AND (OR (EQ EFFECTS :NONE)
+                (EQ EFFECTS :ANY)
+                (LISTP EFFECTS))
+            (OR (EQ AFFECTED :NONE)
+                (EQ AFFECTED :ANY)
+                (LISTP AFFECTED)))
+       `(LET ((DATA ',(CONS EFFECTS AFFECTED)))
+             ,@(MAPCAR #'(LAMBDA (F)
+                                `(SETF (SIDE-EFFECTS ',F)
+                                       DATA))
+                      FUNCTIONS)))
+      (T (CERROR "Ignore the declaration" 
+                "Malformed side-effects descriptor in DECLARE-SIDE-EFFECTS: ~S" (CONS EFFECTS 
+                                                                                      AFFECTED))
+         NIL)))
+
+(DEFUN SIDE-EFFECTS (NAME)
+   (GET NAME 'SIDE-EFFECTS-DATA))
+
+(DEFSETF SIDE-EFFECTS (NAME) (DATA)
+   `(IL:PUTPROP ,NAME 'SIDE-EFFECTS-DATA ,DATA))
+
+(IL:PUTPROPS SIDE-EFFECTS-DATA IL:PROPTYPE IGNORE)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 4: Type Specifiers" (:CONS)
+                                                             :NONE COERCE)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 4: Type Specifiers" :NONE :NONE
+   TYPE-OF)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 6: Predicates" :NONE :NONE
+   TYPEP
+   SUBTYPEP
+   NULL
+   SYMBOLP
+   ATOM
+   CONSP
+   LISTP
+   NUMBERP
+   INTEGERP
+   RATIONALP
+   FLOATP
+   COMPLEXP
+   CHARACTERP
+   STRINGP
+   BIT-VECTOR-P
+   VECTORP
+   SIMPLE-VECTOR-P
+   SIMPLE-STRING-P
+   SIMPLE-BIT-VECTOR-P
+   ARRAYP
+   PACKAGEP
+   FUNCTIONP
+   COMPILED-FUNCTION-P
+   COMMONP
+   EQ
+   EQL
+   EQUAL
+   EQUALP
+   NOT)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 7: Control Structure" (:CONS)
+                                                               :ANY GET-SETF-METHOD 
+                                                               GET-SETF-METHOD-MULTIPLE-VALUE)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 7: Control Structure" :ANY :NONE
+   SET
+   MAKUNBOUND
+   FMAKUNBOUND)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 7: Control Structure" :NONE :ANY
+   SYMBOL-VALUE
+   SYMBOL-FUNCTION
+   BOUNDP
+   FBOUNDP
+   SPECIAL-FORM-P
+   VALUES
+   VALUES-LIST)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 7: Control Structure" :ANY :ANY
+   APPLY
+   FUNCALL
+   MAPCAR
+   MAPLIST
+   MAPC
+   MAPL
+   MAPCAN
+   MAPCON)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 8: Macros" :ANY :ANY
+   MACROEXPAND
+   MACROEXPAND-1)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 8: Macros" :NONE :ANY
+   MACRO-FUNCTION)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 9: Declarations" :ANY :ANY
+   PROCLAIM)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 10: Symbols" :NONE :ANY
+   SYMBOL-PLIST
+   GETF
+   GET
+   GET-PROPERTIES
+   SYMBOL-NAME
+   SYMBOL-PACKAGE)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 10: Symbols" :ANY :ANY
+   REMF
+   REMPROP)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 10: Symbols" (:CONS LISP::*GENSYM-PREFIX* 
+                                                             LISP::*GENSYM-COUNTER*)
+                                                      (LISP::*GENSYM-PREFIX* LISP::*GENSYM-COUNTER*)
+                                                      GENSYM)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 10: Symbols" (:CONS)
+                                                      :NONE MAKE-SYMBOL GENTEMP)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 10: Symbols" (:CONS)
+                                                      :ANY COPY-SYMBOL)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 10: Symbols" :NONE :NONE
+   KEYWORDP)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 11: Packages" :NONE :ANY
+   PACKAGE-NAME
+   PACKAGE-NICKNAMES
+   PACKAGE-USE-LIST
+   PACKAGE-USED-BY-LIST
+   PACKAGE-SHADOWING-SYMBOLS
+   LIST-ALL-PACKAGES
+   FIND-SYMBOL
+   FIND-ALL-SYMBOLS
+   FIND-PACKAGE)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 11: Packages" :ANY :ANY
+   MAKE-PACKAGE
+   IN-PACKAGE
+   RENAME-PACKAGE
+   INTERN
+   UNINTERN
+   EXPORT
+   UNEXPORT
+   IMPORT
+   SHADOWING-IMPORT
+   SHADOW
+   USE-PACKAGE
+   UNUSE-PACKAGE
+   PROVIDE
+   REQUIRE)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 12: Numbers" (:CONS)
+                                                      :NONE MAKE-RANDOM-STATE)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 12: Numbers" :ANY :ANY
+   RANDOM)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 12: Numbers" :NONE :NONE
+   ZEROP
+   PLUSP
+   MINUSP
+   ODDP
+   EVENP
+   =
+   /=
+   <
+   >
+   <=
+   >=
+   MIN
+   MAX
+   +
+   -
+   *
+   /
+   1+
+   1-
+   CONJUGATE
+   GCD
+   LCM
+   EXP
+   EXPT
+   LOG
+   SQRT
+   ISQRT
+   ABS
+   PHASE
+   SIGNUM
+   SIN
+   COS
+   TAN
+   CIS
+   ASIN
+   ACOS
+   ATAN
+   SINH
+   COSH
+   TANH
+   ASINH
+   ACOSH
+   ATANH
+   FLOAT
+   RATIONAL
+   RATIONALIZE
+   NUMERATOR
+   DENOMINATOR
+   FLOOR
+   CEILING
+   TRUNCATE
+   ROUND
+   MOD
+   REM
+   FFLOOR
+   FCEILING
+   FTRUNCATE
+   FROUND
+   DECODE-FLOAT
+   SCALE-FLOAT
+   FLOAT-RADIX
+   FLOAT-SIGN
+   FLOAT-DIGITS
+   FLOAT-PRECISION
+   INTEGER-DECODE-FLOAT
+   COMPLEX
+   REALPART
+   IMAGPART
+   LOGIOR
+   LOGXOR
+   LOGAND
+   LOGEQV
+   LOGNAND
+   LOGNOR
+   LOGANDC1
+   LOGANDC2
+   LOGORC1
+   LOGORC2
+   BOOLE
+   LOGNOT
+   LOGTEST
+   LOGBITP
+   ASH
+   LOGCOUNT
+   INTEGER-LENGTH
+   BYTE
+   BYTE-SIZE
+   BYTE-POSITION
+   LDB
+   LDB-TEST
+   MASK-FIELD
+   DPB
+   DEPOSIT-FIELD
+   RANDOM-STATE-P)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 13: Characters" :NONE :NONE
+   STANDARD-CHAR-P
+   GRAPHIC-CHAR-P
+   STRING-CHAR-P
+   ALPHA-CHAR-P
+   UPPER-CASE-P
+   LOWER-CASE-P
+   BOTH-CASE-P
+   DIGIT-CHAR-P
+   ALPHANUMERICP
+   CHAR=
+   CHAR/=
+   CHAR<
+   CHAR>
+   CHAR<=
+   CHAR>=
+   CHAR-EQUAL
+   CHAR-NOT-EQUAL
+   CHAR-LESSP
+   CHAR-GREATERP
+   CHAR-NOT-LESSP
+   CHAR-NOT-GREATERP
+   CHAR-CODE
+   CHAR-BITS
+   CHAR-FONT
+   CODE-CHAR
+   MAKE-CHAR
+   CHARACTER
+   CHAR-UPCASE
+   CHAR-DOWNCASE
+   DIGIT-CHAR
+   CHAR-INT
+   INT-CHAR
+   CHAR-NAME
+   NAME-CHAR
+   CHAR-BIT
+   SET-CHAR-BIT)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 14: Sequences" :ANY :ANY
+   NREVERSE
+   MAP
+   SOME
+   EVERY
+   NOTANY
+   NOTEVERY
+   REDUCE
+   FILL
+   REPLACE
+   REMOVE
+   REMOVE-IF
+   REMOVE-IF-NOT
+   DELETE
+   DELETE-IF
+   DELETE-IF-NOT
+   REMOVE-DUPLICATES
+   DELETE-DUPLICATES
+   SUBSTITUTE
+   SUBSTITUTE-IF
+   SUBSTITUTE-IF-NOT
+   NSUBSTITUTE
+   NSUBSTITUTE-IF
+   NSUBSTITUTE-IF-NOT
+   FIND
+   FIND-IF
+   FIND-IF-NOT
+   POSITION
+   POSITION-IF
+   POSITION-IF-NOT
+   COUNT
+   COUNT-IF
+   COUNT-IF-NOT
+   MISMATCH
+   SEARCH
+   SORT
+   STABLE-SORT
+   MERGE)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 14: Sequences" :NONE :ANY
+   ELT
+   LENGTH)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 14: Sequences" (:CONS)
+                                                        :ANY SUBSEQ COPY-SEQ REVERSE MAKE-SEQUENCE 
+                                                        CONCATENATE)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 15: Lists" :NONE :NONE
+   CAR
+   CDR
+   CAAR
+   CADR
+   CDAR
+   CDDR
+   CAAAR
+   CAADR
+   CADAR
+   CADDR
+   CDAAR
+   CDADR
+   CDDAR
+   CDDDR
+   CAAAAR
+   CAAADR
+   CAADAR
+   CAADDR
+   CADAAR
+   CADADR
+   CADDAR
+   CADDDR
+   CDAAAR
+   CDAADR
+   CDADAR
+   CDADDR
+   CDDAAR
+   CDDADR
+   CDDDAR
+   CDDDDR
+   ENDP
+   LIST-LENGTH
+   NTH
+   FIRST
+   SECOND
+   THIRD
+   FOURTH
+   FIFTH
+   SIXTH
+   SEVENTH
+   EIGHTH
+   NINTH
+   TENTH
+   REST
+   NTHCDR
+   LAST
+   TAILP)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 15: Lists" (:CONS)
+                                                    :NONE CONS LIST LIST* MAKE-LIST APPEND COPY-LIST
+                                                    COPY-ALIST COPY-TREE REVAPPEND BUTLAST LDIFF 
+                                                    ACONS PAIRLIS)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 15: Lists" :ANY :ANY
+   TREE-EQUAL
+   SUBST
+   SUBST-IF
+   SUBST-IF-NOT
+   NSUBST
+   NSUBST-IF
+   NSUBST-IF-NOT
+   SUBLIS
+   NSUBLIS
+   MEMBER
+   MEMBER-IF
+   MEMBER-IF-NOT
+   ADJOIN
+   UNION
+   NUNION
+   INTERSECTION
+   NINTERSECTION
+   SET-DIFFERENCE
+   NSET-DIFFERENCE
+   SET-EXCLUSIVE-OR
+   NSET-EXCLUSIVE-OR
+   SUBSETP
+   ASSOC
+   ASSOC-IF
+   ASSOC-IF-NOT
+   RASSOC
+   RASSOC-IF
+   RASSOC-IF-NOT)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 15: Lists" :ANY :NONE
+   NCONC
+   NRECONC
+   NBUTLAST
+   RPLACA
+   RPLACD)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 16: Hash Tables" :ANY :NONE
+   CLRHASH)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 16: Hash Tables" :ANY :ANY
+   REMHASH
+   MAPHASH)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 16: Hash Tables" :NONE :ANY
+   GETHASH
+   HASH-TABLE-COUNT)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 16: Hash Tables" :NONE :NONE
+   HASH-TABLE-P
+   SXHASH)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 16: Hash Tables" (:CONS)
+                                                          :NONE MAKE-HASH-TABLE)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 17: Arrays" :NONE :NONE
+   ARRAY-ELEMENT-TYPE
+   ARRAY-RANK
+   ADJUSTABLE-ARRAY-P
+   ARRAY-HAS-FILL-POINTER-P)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 17: Arrays" :NONE :ANY
+   AREF
+   SVREF
+   ARRAY-DIMENSIONS
+   ARRAY-TOTAL-SIZE
+   ARRAY-IN-BOUNDS-P
+   ARRAY-ROW-MAJOR-INDEX
+   BIT
+   SBIT
+   FILL-POINTER)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 17: Arrays" (:CONS)
+                                                     :NONE MAKE-ARRAY VECTOR)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 17: Arrays" :ANY :ANY
+   BIT-AND
+   BIT-IOR
+   BIT-XOR
+   BIT-EQV
+   BIT-NAND
+   BIT-NOR
+   BIT-ANDC1
+   BIT-ANDC2
+   BIT-ORC1
+   BIT-ORC2
+   BIT-NOT
+   VECTOR-PUSH
+   VECTOR-PUSH-EXTEND
+   VECTOR-POP
+   ADJUST-ARRAY)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 18: Strings" :ANY :ANY
+   NSTRING-UPCASE
+   NSTRING-DOWNCASE
+   NSTRING-CAPITALIZE)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 18: Strings" (:CONS)
+                                                      :NONE MAKE-STRING STRING)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 18: Strings" (:CONS)
+                                                      :ANY STRING-TRIM STRING-LEFT-TRIM 
+                                                      STRING-RIGHT-TRIM STRING-UPCASE STRING-DOWNCASE
+                                                      STRING-CAPITALIZE)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 18: Strings" :NONE :NONE
+   STRING=
+   STRING/=
+   STRING<
+   STRING>
+   STRING<=
+   STRING>=
+   STRING-EQUAL
+   STRING-NOT-EQUAL
+   STRING-LESSP
+   STRING-NOT-LESSP
+   STRING-GREATERP
+   STRING-NOT-GREATERP)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 18: Strings" :NONE :ANY
+   CHAR
+   SCHAR)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 20: The Evaluator" :NONE :ANY
+   CONSTANTP)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 20: The Evaluator" :ANY :ANY
+   EVAL
+   EVALHOOK
+   APPLYHOOK)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 21: Streams" (:CONS)
+                                                      :ANY MAKE-BROADCAST-STREAM 
+                                                      MAKE-CONCATENATED-STREAM MAKE-TWO-WAY-STREAM 
+                                                      MAKE-ECHO-STREAM MAKE-STRING-INPUT-STREAM)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 21: Streams" (:CONS)
+                                                      :NONE MAKE-SYNONYM-STREAM 
+                                                      MAKE-STRING-OUTPUT-STREAM)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 21: Streams" :ANY :NONE
+   CLOSE)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 21: Streams" :NONE :NONE
+   STREAMP
+   INPUT-STREAM-P
+   OUTPUT-STREAM-P
+   STREAM-ELEMENT-TYPE)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 21: Streams" :ANY :ANY
+   GET-OUTPUT-STREAM-STRING)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 22: Input/Output" :NONE :NONE
+   READTABLEP)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 22: Input/Output" :ANY :ANY
+   COPY-READTABLE
+   SET-SYNTAX-FROM-CHAR
+   SET-MACRO-CHARACTER
+   MAKE-DISPATCH-MACRO-CHARACTER
+   SET-DISPATCH-MACRO-CHARACTER
+   READ
+   READ-PRESERVING-WHITESPACE
+   READ-DELIMITED-LIST
+   READ-LINE
+   READ-CHAR
+   UNREAD-CHAR
+   PEEK-CHAR
+   READ-CHAR-NO-HANG
+   CLEAR-INPUT
+   READ-FROM-STRING
+   READ-BYTE
+   WRITE
+   PRIN1
+   PRINT
+   PPRINT
+   PRINC
+   WRITE-CHAR
+   WRITE-STRING
+   WRITE-LINE
+   TERPRI
+   FRESH-LINE
+   FINISH-OUTPUT
+   FORCE-OUTPUT
+   CLEAR-OUTPUT
+   WRITE-BYTE
+   FORMAT
+   Y-OR-N-P
+   YES-OR-NO-P)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 22: Input/Output" :NONE :ANY
+   GET-MACRO-CHARACTER
+   GET-DISPATCH-MACRO-CHARACTER
+   LISTEN
+   PARSE-INTEGER)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 22: Input/Output" (:CONS)
+                                                           :ANY WRITE-TO-STRING PRIN1-TO-STRING 
+                                                           PRINC-TO-STRING)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 23: File System Interface" :NONE :ANY
+   TRUENAME
+   PARSE-NAMESTRING
+   PROBE-FILE
+   FILE-WRITE-DATE
+   FILE-AUTHOR
+   FILE-LENGTH
+   DIRECTORY)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 23: File System Interface" (:CONS)
+                                                                    :ANY PATHNAME MERGE-PATHNAMES 
+                                                                    MAKE-PATHNAME PATHNAME-HOST 
+                                                                    PATHNAME-DEVICE 
+                                                                    PATHNAME-DIRECTORY PATHNAME-NAME
+                                                                    PATHNAME-TYPE PATHNAME-VERSION 
+                                                                    NAMESTRING FILE-NAMESTRING 
+                                                                    DIRECTORY-NAMESTRING 
+                                                                    HOST-NAMESTRING ENOUGH-NAMESTRING
+                                                                    USER-HOMEDIR-PATHNAME OPEN)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 23: File System Interface" :ANY :ANY
+   RENAME-FILE
+   DELETE-FILE
+   FILE-POSITION
+   LOAD)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 23: File System Interface" :NONE :NONE
+   PATHNAMEP)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 24: Errors" :ANY :ANY
+   ERROR
+   CERROR
+   WARN
+   BREAK)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 25: Miscellaneous Features" :NONE :ANY
+   DOCUMENTATION
+   APROPOS-LIST
+   GET-DECODED-TIME
+   GET-UNIVERSAL-TIME
+   GET-INTERNAL-RUN-TIME
+   GET-INTERNAL-REAL-TIME
+   LISP-IMPLEMENTATION-TYPE
+   LISP-IMPLEMENTATION-VERSION
+   MACHINE-TYPE
+   MACHINE-VERSION
+   MACHINE-INSTANCE
+   SOFTWARE-TYPE
+   SOFTWARE-VERSION
+   SHORT-SITE-NAME
+   LONG-SITE-NAME)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 25: Miscellaneous Features" :ANY :ANY
+   COMPILE
+   COMPILE-FILE
+   DISASSEMBLE
+   DESCRIBE
+   INSPECT
+   ROOM
+   ED
+   DRIBBLE
+   APROPOS)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 25: Miscellaneous Features" :ANY :NONE
+   SLEEP)
+
+(DECLARE-SIDE-EFFECTS "CLtL, Chapter 25: Miscellaneous Features" :NONE :NONE
+   DECODE-UNIVERSAL-TIME
+   ENCODE-UNIVERSAL-TIME
+   IDENTITY)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 2: Litatoms" :ANY :NONE
+   IL:SETTOPVAL
+   IL:SETATOMVAL
+   IL:PUTPROP
+   IL:DEFLIST
+   IL:SETPROPLIST)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 2: Litatoms" :NONE :ANY
+   IL:GETTOPVAL
+   IL:GETATOMVAL
+   IL:GETPROP
+   IL:PROPNAMES
+   IL:GETPROPLIST
+   IL:GETLIS
+   IL:NCHARS
+   IL:NTHCHAR
+   IL:U-CASEP
+   IL:NTHCHARCODE
+   IL:CHCON1)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 2: Litatoms" :NONE :NONE
+   IL:LITATOM
+   IL:ATOM
+   IL:CHARACTER
+   IL:FCHARACTER)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 2: Litatoms" :ANY :ANY
+   REMPROP
+   IL:ADDPROP
+   IL:REMPROPLIST
+   IL:CHANGEPROP
+   IL:MKATOM
+   IL:SUBATOM
+   IL:PACK
+   IL:PACK*
+   IL:DUNPACK
+   IL:L-CASE
+   IL:U-CASE
+   IL:GENSYM
+   IL:MAPATOMS
+   IL:APROPOS
+   IL:PACKC
+   IL:DCHCON)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 2: Litatoms" (:CONS)
+                                                     :ANY IL:UNPACK IL:CHCON)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 3: Lists" :NONE :NONE
+   IL:LISTP
+   IL:NLISTP)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 3: Lists" :ANY :ANY
+   IL:RPLNODE2
+   IL:FRPLNODE2
+   IL:ATTACH
+   IL:TCONC
+   IL:LCONC
+   IL:DOCOLLECT
+   IL:ENDCOLLECT
+   IL:LDIFF
+   IL:DSUBST
+   IL:DSUBLIS
+   IL:PUTASSOC
+   IL:LISTPUT
+   IL:LISTPUT1
+   IL:SORT
+   IL:MERGE
+   IL:MERGEINSERT
+   IL:DREMOVE
+   IL:DREVERSE
+   IL:COMPARELISTS)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 3: Lists" :ANY :NONE
+   IL:RPLNODE
+   IL:FRPLACD
+   IL:FRPLACA
+   IL:FRPLNODE
+   IL:NCONC1)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 3: Lists" (:CONS)
+                                                  :NONE IL:MKLIST IL:APPEND)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 3: Lists" (:CONS)
+                                                  :ANY IL:COPY IL:COPYALL IL:HCOPYALL IL:LASTN 
+                                                  IL:LDIFFERENCE IL:INTERSECTION IL:UNION IL:SUBST 
+                                                  IL:LSUBST IL:SUBLIS IL:SUBPAIR IL:REMOVE IL:REVERSE
+                                                  IL:NEGATE)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 3: Lists" :NONE :ANY
+   IL:NTH
+   IL:FNTH
+   IL:FLAST
+   IL:NLEFT
+   IL:LENGTH
+   IL:FLENGTH
+   IL:EQLENGTH
+   IL:COUNT
+   IL:COUNTDOWN
+   IL:EQUALN
+   IL:MEMB
+   IL:FMEMB
+   IL:MEMBER
+   IL:EQMEMB
+   IL:ASSOC
+   IL:FASSOC
+   IL:SASSOC
+   IL:LISTGET
+   IL:LISTGET1
+   IL:ALPHORDER
+   IL:UALPHORDER)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 4: Strings" (:CONS)
+                                                    :ANY IL:ALLOCSTRING IL:MKSTRING IL:CONCAT 
+                                                    IL:CONCATLIST)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 4: Strings" :NONE :ANY
+   IL:STREQUAL
+   IL:NCHARS
+   IL:STRPOS
+   IL:STRPOSL)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 4: Strings" :NONE :NONE
+   IL:STRINGP)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 4: Strings" :ANY :ANY
+   IL:GNC
+   IL:GLC
+   IL:RPLSTRING
+   IL:RPLCHARCODE
+   IL:MAKEBITTABLE
+   IL:SUBSTRING)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 5: Arrays" :ANY :NONE
+   IL:SETA)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 5: Arrays" :NONE :ANY
+   IL:ELT)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 5: Arrays" :NONE :NONE
+   IL:ARRAYP
+   IL:ARRAYTYP
+   IL:ARRAYSIZE
+   IL:ARRAYORIG)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 5: Arrays" (:CONS)
+                                                   :ANY IL:ARRAY IL:COPYARRAY)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 6: Hash Arrays" :ANY :ANY
+   IL:HARRAYPROP
+   IL:PUTHASH
+   IL:REHASH
+   IL:MAPHASH
+   IL:DMPHASH)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 6: Hash Arrays" :NONE :NONE
+   IL:HARRAYP
+   IL:HARRAYSIZE)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 6: Hash Arrays" (:CONS)
+                                                        :NONE IL:HARRAY)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 6: Hash Arrays" (:CONS)
+                                                        :ANY IL:HASHARRAY)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 6: Hash Arrays" :NONE :ANY
+   IL:GETHASH
+   IL:STRINGHASHBITS)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 6: Hash Arrays" :ANY :NONE
+   CLRHASH)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 7: Numbers and Arithmetic Functions" :ANY :ANY
+   IL:RAND
+   IL:RANDSET)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 7: Numbers and Arithmetic Functions" :NONE :NONE
+   IL:SMALLP
+   IL:FIXP
+   IL:FLOATP
+   IL:NUMBERP
+   IL:EQP
+   IL:PLUS
+   IL:MINUS
+   IL:DIFFERENCE
+   IL:TIMES
+   IL:QUOTIENT
+   IL:REMAINDER
+   IL:GREATERP
+   IL:LESSP
+   IL:GEQ
+   IL:LEQ
+   IL:ZEROP
+   MINUSP
+   MIN
+   MAX
+   ABS
+   IL:IPLUS
+   IL:IMINUS
+   IL:IDIFFERENCE
+   IL:ADD1
+   IL:SUB1
+   IL:ITIMES
+   IL:IQUOTIENT
+   IL:IREMAINDER
+   IL:IMOD
+   IL:IGREATERP
+   IL:ILESSP
+   IL:IGEQ
+   IL:ILEQ
+   IL:IMIN
+   IL:IMAX
+   IL:IEQP
+   IL:FIX
+   IL:FIXR
+   IL:GCD
+   LOGAND
+   IL:LOGOR
+   LOGXOR
+   IL:LSH
+   IL:RSH
+   IL:LLSH
+   IL:LRSH
+   IL:INTEGERLENGTH
+   IL:POWEROFTWOP
+   EVENP
+   ODDP
+   LOGNOT
+   IL:BITTEST
+   IL:BITCLEAR
+   IL:BITSET
+   IL:MASK.1\'S
+   IL:MASK.0\'S
+   IL:LOADBYTE
+   IL:DEPOSITBYTE
+   IL:ROT
+   BYTE
+   IL:BYTESIZE
+   IL:BYTEPOSITION
+   LDB
+   DPB
+   IL:FPLUS
+   IL:FMINUS
+   IL:FDIFFERENCE
+   IL:FTIMES
+   IL:FQUOTIENT
+   IL:FREMAINDER
+   IL:FGREATERP
+   IL:FLESSP
+   IL:FEQP
+   IL:FMIN
+   IL:FMAX
+   FLOAT
+   IL:EXPT
+   IL:SQRT
+   IL:LOG
+   IL:ANTILOG
+   IL:SIN
+   IL:COS
+   IL:TAN
+   IL:ARCSIN
+   IL:ARCCOS
+   IL:ARCTAN
+   IL:ARCTAN2)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 7: Numbers and Arithmetic Functions" :ANY :NONE
+   IL:OVERFLOW)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 8: Record Package" :NONE :ANY
+   IL:RECLOOK
+   IL:FIELDLOOK
+   IL:RECORDFIELDNAMES
+   IL:RECORDACCESSFORM
+   IL:DATATYPES
+   IL:USERDATATYPES
+   IL:TYPENAME
+   IL:TYPENAMEP
+   IL:FETCHFIELD
+   IL:GETFIELDSPECS
+   IL:GETDESCRIPTORS)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 8: Record Package" :ANY :ANY
+   IL:EDITREC
+   IL:RECORDACCESS
+   IL:DECLAREDATATYPE
+   IL:REPLACEFIELD)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 9: Conditionals and Iterative Statements" :NONE :NONE
+   IL:NEQ)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 9: Conditionals and Iterative Statements" :NONE :ANY
+   IL:EQUAL
+   IL:EQUALALL)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 9: Conditionals and Iterative Statements" :ANY :ANY
+   IL:I.S.OPR)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 10: Function Definition, Manipulation, and Evaluation" :ANY 
+   :NONE
+   IL:SETARG)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 10: Function Definition, Manipulation, and Evaluation" :NONE 
+   :ANY
+   IL:ARG
+   IL:CCODEP
+   IL:EXPRP
+   IL:FNTYP
+   IL:ARGTYPE
+   IL:NARGS
+   IL:ARGLIST
+   IL:SMARTARGLIST
+   IL:GETD
+   IL:NLAMBDA.ARGS
+   IL:FUNCTION)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 10: Function Definition, Manipulation, and Evaluation" :ANY 
+   :ANY
+   IL:DEFINEQ
+   IL:DEFINE
+   IL:PUTD
+   IL:MOVD
+   IL:MOVD?
+   IL:APPLY
+   IL:APPLY*
+   IL:EVAL
+   IL:EVALA
+   IL:DEFEVAL
+   IL:EVALHOOK
+   IL:RPT
+   IL:MAP
+   IL:MAPC
+   IL:MAPLIST
+   IL:MAPCAR
+   IL:MAPCON
+   IL:MAPCONC
+   IL:MAP2C
+   IL:MAP2CAR
+   IL:SUBSET
+   IL:EVERY
+   IL:SOME
+   IL:NOTANY
+   IL:NOTEVERY
+   IL:MAPRINT
+   IL:EXPANDMACRO)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 10: Function Definition, Manipulation, and Evaluation" :NONE 
+   :NONE
+   IL:KWOTE
+   IL:NILL
+   TRUE
+   IL:ZERO)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 11: Variable Bindings and the Interlisp Stack" :NONE :ANY
+   IL:STKNAME
+   IL:STKSCAN
+   IL:FRAMESCAN
+   IL:STKARG
+   IL:STKARGNAME
+   IL:STKARGS
+   IL:VARIABLES
+   IL:EVALV
+   IL:REALFRAMEP)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 11: Variable Bindings and the Interlisp Stack" :ANY :NONE
+   IL:STKPOS
+   IL:STKNTH
+   IL:SETSTKNAME
+   IL:SETSTKARG
+   IL:SETSTKARGNAME
+   IL:RELSTK
+   IL:REALSTKNTH)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 11: Variable Bindings and the Interlisp Stack" :ANY :ANY
+   IL:ENVEVAL
+   IL:ENVAPPLY
+   IL:STKEVAL
+   IL:STKAPPLY
+   IL:RETFROM
+   IL:RETTO
+   IL:RETEVAL
+   IL:RETAPPLY
+   IL:CLEARSTK
+   IL:BACKTRACE
+   IL:BAKTRACE
+   IL:MAPDL
+   IL:SEARCHPDL)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 11: Variable Bindings and the Interlisp Stack" :NONE :NONE
+   IL:STKNARGS
+   IL:STACKP
+   IL:RELSTKP)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 12: Miscellaneous" :NONE :NONE
+   IL:DATEFORMAT
+   IL:TIMEREXPIRED?)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 12: Miscellaneous" :ANY :ANY
+   IL:SETTIME
+   IL:SETUPTIMER
+   IL:SETUPTIMER.DATE)
+
+(DECLARE-SIDE-EFFECTS "IRM, Chapter 12: Miscellaneous" :NONE :ANY
+   IL:DATE
+   IL:GDATE
+   IL:IDATE
+   IL:CLOCK
+   IL:MACHINETYPE)
+
+(DECLARE-SIDE-EFFECTS "Pointer reads" :NONE :NONE
+   IL:\\GETBASEPTR
+   IL:\\GETBASEBYTE
+   IL:\\GETBASE
+   IL:\\GETBASEFIXP
+   IL:\\GETBASESTRING
+   IL:\\VAG2
+   IL:\\ADDBASE)
+
+(DECLARE-SIDE-EFFECTS "Internal functions in CMLARITH" :NONE :NONE
+   LISP::%+
+   LISP::%-
+   LISP::%*
+   LISP::%/
+   LISP::%=
+   LISP::%>
+   LISP::%<
+   XCL::STRUNCATE
+   XCL::SFLOOR
+   XCL::SCEILING
+   XCL::SROUND
+   LISP::%LOGIOR
+   LISP::%LLSH8
+   LISP::%LLSH1
+   LISP::%LRSH8
+   LISP::%LRSH1)
+
+
+
+(IL:* IL:|;;| "Arrange for the correct compiler to be used.")
+
+
+(IL:PUTPROPS IL:XCLC-DATABASE IL:FILETYPE :COMPILE-FILE)
+
+
+
+(IL:* IL:|;;| "Set up the correct package environment.")
+
+
+(IL:PUTPROPS IL:XCLC-DATABASE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE
+                                                                     (DEFPACKAGE "COMPILER"
+                                                                            (:USE "LISP" "XCL"))))
+(IL:PUTPROPS IL:XCLC-DATABASE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1993)
+)
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/XCLC-DATABASE.DFASL b/CLTL2/XCLC-DATABASE.DFASL
new file mode 100644
index 00000000..555daf7c
Binary files /dev/null and b/CLTL2/XCLC-DATABASE.DFASL differ
diff --git a/CLTL2/XCLC-ENV-CTXT b/CLTL2/XCLC-ENV-CTXT
new file mode 100644
index 00000000..304e6365
--- /dev/null
+++ b/CLTL2/XCLC-ENV-CTXT
@@ -0,0 +1,139 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL")))
+(IL:FILECREATED " 4-Feb-92 10:32:41" IL:|{DSK}<usr>local>lde>lispcore>sources>XCLC-ENV-CTXT.;3| 18137  
+
+      IL:|changes| IL:|to:|  (IL:FUNCTIONS RESOLVE-VARIABLE-REFERENCE RESOLVE-VARIABLE-BINDING)
+
+      IL:|previous| IL:|date:| " 4-Jan-92 12:28:35" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>XCLC-ENV-CTXT.;2|)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:XCLC-ENV-CTXTCOMS)
+
+(IL:RPAQQ IL:XCLC-ENV-CTXTCOMS ((IL:* IL:|;;;| "Contexts and Environments") (IL:STRUCTURES CONTEXT ENV) (IL:FUNCTIONS ENV-SETF-FBOUNDP LOCAL-CONSTANT-P PRINT-CONTEXT PRINT-ENV) (IL:FUNCTIONS MAKE-CHILD-ENV ENV-BIND-VARIABLE ENV-BIND-FUNCTION ENV-ADD-DECLS ENV-DECL-P ENV-ALLOW-INLINES ENV-DISALLOW-INLINES ENV-INLINE-ALLOWED ENV-INLINE-DISALLOWED ENV-PROCLAIM-SPECIAL ENV-PROCLAIMED-SPECIAL-P ENV-PROCLAIM-GLOBAL ENV-PROCLAIMED-GLOBAL-P ENV-DECLARE-SPECIALS ENV-DECLARE-GLOBALS ENV-DECLARE-A-SPECIAL ENV-DECLARE-A-GLOBAL) (IL:FUNCTIONS FIND-TOP-ENVIRONMENT RESOLVE-VARIABLE-REFERENCE RESOLVE-VARIABLE-BINDING VALUE-FOLDABLE-P CHECK-GLOBAL-CONSTANT CONSTANT-VALUE SET-CONSTANT-VALUE LOCAL-CONSTANT-P) (IL:SETFS CONSTANT-VALUE) (IL:VARIABLES *CONSTANTS-HASH-TABLE*) (IL:VARIABLES *ENVIRONMENT* *CONTEXT* *ARGUMENT-CONTEXT* *EFFECT-CONTEXT* *NULL-CONTEXT* *PREDICATE-CONTEXT*) (IL:* IL:|;;| "External interface to environments") (IL:FUNCTIONS ENV-BOUNDP ENV-FBOUNDP COPY-ENV-WITH-FUNCTION COPY-ENV-WITH-VARIABLE MAKE-EMPTY-ENV) (IL:* IL:|;;| "Describe the machine we're running on and the target for hte compiled code") (IL:VARIABLES *HOST-ARCHITECTURE* *TARGET-ARCHITECTURE*) (IL:* IL:|;;| "Arrange for the correct compiler to be used.") (IL:PROP IL:FILETYPE IL:XCLC-ENV-CTXT) (IL:* IL:|;;| "Arrange for the correct reader environment.") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-ENV-CTXT)))
+
+
+
+(IL:* IL:|;;;| "Contexts and Environments")
+
+
+(DEFSTRUCT (CONTEXT (:PRINT-FUNCTION PRINT-CONTEXT) (:INLINE T)) (IL:* IL:|;;;| "TOP-LEVEL-P is non-nil iff we are analyzing a top-level form.") (IL:* IL:|;;;| "VALUES-USED is either :unknown or the non-negative number of values expected for the result of the current form.") (IL:* IL:|;;;| "PREDICATE-P is non-nil iff the value of the current form will only be used in a nil/non-nil test.") (IL:* IL:|;;;| "APPLIED-CONTEXT is either nil or the context in which the result of applying the current form as a function would be used.  If NIL, then assume the *null-context*.") (TOP-LEVEL-P NIL) (VALUES-USED :UNKNOWN) (PREDICATE-P NIL) (APPLIED-CONTEXT NIL))
+
+(DEFSTRUCT (ENV (:PRINT-FUNCTION PRINT-ENV) (:INLINE T)) (IL:* IL:|;;;| "Structure for maintaining the compiler's idea of the environment of a given form.") (IL:* IL:|;;;| "PARENT is either NIL, meaning that this environment is at the top, or another ENV structure.") (IL:* IL:|;;;| "VENV is an AList associating the symbol that is the name of the variable with a list of two elements, the SCOPE of the variable (one of :CONSTANT or :LEXICAL) and the VARIABLE or LITERAL structure corresponding to the variable.") (IL:* IL:|;;;| "FENV is an AList associating the symbol that is the name of the function with a list of two elements: the KIND of the symbol (either :MACRO or :FUNCTION) and either an expansion function (iff KIND = :MACRO) or a VARIABLE structure (iff KIND = :FUNCTION).  When KIND = :FUNCTION, the VARIABLE structure may be omitted.") (IL:* IL:|;;;| "The information about INLINE and NOTINLINE declarations is maintained by two lists, ALLOWED-INLINES and DISALLOWED-INLINES.  If a symbol is on DISALLOWED-INLINES, the compiler will not expand calls to it inline; nor will any optimizers on that symbol be applied.  If a symbol is on ALLOWED-INLINES, the compiler will try harder to expand calls to the symbol inline.  A given symbol should not appear on both lists.") (IL:* IL:|;;;| "DECL-SPECIFIERS is a list of non-standard declaration-specifiers to be allowed in the compilation.  Such specifiers are created by (declare (declaration foo)) forms.") (IL:* IL:|;;;| "DECLARED-SPECIALS is a list of those symbols that were DECLAREd SPECIAL at this contour.  In the top-most environment, the list is used for PROCLAIMed variables.") (IL:* IL:|;;;| "DECLARED-GLOBALS is just like DECLARED-SPECIALS but for globals.") (IL:* IL:|;;| "TARGET-ARCHITECTURE is a list analogous to *FEATURES* that describes the architecture of the target machine we're compiling to.  This is intended initially to support multiple instruction sets (for the 3-byte-symbol change).") (PARENT NIL) (VENV NIL) (FENV NIL) (ALLOWED-INLINES NIL) (DISALLOWED-INLINES NIL) (DECL-SPECIFIERS NIL) (DECLARED-SPECIALS NIL) (DECLARED-GLOBALS NIL) (TARGET-ARCHITECTURE *TARGET-ARCHITECTURE*))
+
+(DEFUN ENV-SETF-FBOUNDP (ENV NAME) (IL:* IL:|;;| "Code mostly stolen from ENV-FBOUNDP; I THINK we don't want to look in the top-level environment here, so ENV-FBOUNDP's LEXICAL-ONLY flag is hot-wired true. ") (LABELS ((FIND-FN (ENV) (LET ((PARENT (ENV-PARENT ENV))) (UNLESS (EQ PARENT T) (LET ((LOOKUP (ASSOC NAME (ENV-FENV ENV) :TEST (QUOTE EQUAL)))) (IF (NULL LOOKUP) (AND PARENT (FIND-FN PARENT)) (VALUES-LIST (CDR LOOKUP)))))))) (FIND-FN ENV)))
+
+(DEFUN LOCAL-CONSTANT-P (SYMBOL) (GETHASH SYMBOL *CONSTANTS-HASH-TABLE*))
+
+(DEFUN PRINT-CONTEXT (STRUCT STREAM DEPTH) (IL:* IL:|;;;| "Print almost all contexts in a more readable form, interpreting the various combinations of the fields.") (DECLARE (IGNORE DEPTH)) (LET ((TL (CONTEXT-TOP-LEVEL-P STRUCT)) (VALS (CONTEXT-VALUES-USED STRUCT)) (PRED (CONTEXT-PREDICATE-P STRUCT)) (APP (CONTEXT-APPLIED-CONTEXT STRUCT))) (MACROLET ((OUTPUT (STRING &REST ARGS) (IL:BQUOTE (FORMAT STREAM (IL:\\\, (CONCATENATE (QUOTE STRING) "~:[" STRING "~;#<Ctxt--" STRING ">~]")) *PRINT-ESCAPE* (IL:\\\,@ ARGS))))) (LET ((VALUE (COND ((AND (EQ TL NIL) (EQ VALS :UNKNOWN) (EQ PRED NIL) (EQ APP NIL)) (OUTPUT "Null")) ((AND (EQ TL T) (EQ VALS 0) (EQ PRED NIL) (EQ APP NIL)) (OUTPUT "Top-level form")) ((AND (EQ TL NIL) (EQ VALS 0) (EQ PRED NIL) (EQ APP NIL)) (OUTPUT "Effect")) ((AND (EQ TL NIL) (EQ VALS 1) (EQ PRED NIL) (EQ APP NIL)) (OUTPUT "Argument")) ((AND (EQ TL NIL) (EQ VALS 1) (EQ PRED T) (EQ APP NIL)) (OUTPUT "Predicate")) ((AND (EQ TL NIL) (EQ PRED NIL) (EQ APP NIL)) (OUTPUT "~S values" VALS)) (T (FORMAT STREAM "#<Ctxt--TL: ~S--Vals: ~S--Pred: ~S--App: ~A>" TL VALS PRED APP)))))))))
+
+(DEFUN PRINT-ENV (STRUCT STREAM DEPTH) (DECLARE (IGNORE DEPTH)) (FORMAT STREAM "#<Compiler Environment @ ~O,~O>" (IL:\\HILOC STRUCT) (IL:\\LOLOC STRUCT)))
+
+(DEFUN MAKE-CHILD-ENV (PARENT) (MAKE-ENV :PARENT PARENT))
+
+(DEFUN ENV-BIND-VARIABLE (ENV NAME STRUCT) (PUSH (CONS NAME STRUCT) (ENV-VENV ENV)))
+
+(DEFUN ENV-BIND-FUNCTION (ENV NAME KIND &OPTIONAL EXPN-OR-VAR) (PUSH (LIST NAME KIND EXPN-OR-VAR) (ENV-FENV ENV)))
+
+(DEFUN ENV-ADD-DECLS (ENV SPECIFIERS) (SETF (ENV-DECL-SPECIFIERS ENV) (APPEND SPECIFIERS (ENV-DECL-SPECIFIERS ENV))))
+
+(DEFUN ENV-DECL-P (ENV SPECIFIER) (OR (MEMBER SPECIFIER (ENV-DECL-SPECIFIERS ENV)) (LET ((PARENT (ENV-PARENT ENV))) (AND (ENV-P PARENT) (ENV-DECL-P PARENT SPECIFIER)))))
+
+(DEFUN ENV-ALLOW-INLINES (ENV NAMES) (SETF (ENV-DISALLOWED-INLINES ENV) (SET-DIFFERENCE (ENV-DISALLOWED-INLINES ENV) NAMES)) (SETF (ENV-ALLOWED-INLINES ENV) (UNION (ENV-ALLOWED-INLINES ENV) NAMES)))
+
+(DEFUN ENV-DISALLOW-INLINES (ENV NAMES) (SETF (ENV-ALLOWED-INLINES ENV) (SET-DIFFERENCE (ENV-ALLOWED-INLINES ENV) NAMES)) (SETF (ENV-DISALLOWED-INLINES ENV) (UNION (ENV-DISALLOWED-INLINES ENV) NAMES)))
+
+(DEFUN ENV-INLINE-ALLOWED (ENV NAME) (COND ((MEMBER NAME (ENV-ALLOWED-INLINES ENV) :TEST (QUOTE EQ)) T) ((MEMBER NAME (ENV-DISALLOWED-INLINES ENV) :TEST (QUOTE EQ)) NIL) (T (LET ((PARENT (ENV-PARENT ENV))) (IF (ENV-P PARENT) (ENV-INLINE-ALLOWED PARENT NAME) (IL:* IL:|;;| "We don't currently have a way to note globally inline-able functions.  Thus, if you run out of environments, you don't have permission to inline it.") NIL)))))
+
+(DEFUN ENV-INLINE-DISALLOWED (ENV NAME) (COND ((MEMBER NAME (ENV-DISALLOWED-INLINES ENV) :TEST (QUOTE EQ)) T) ((MEMBER NAME (ENV-ALLOWED-INLINES ENV) :TEST (QUOTE EQ)) NIL) (T (LET ((PARENT (ENV-PARENT ENV))) (IF (ENV-P PARENT) (ENV-INLINE-DISALLOWED PARENT NAME) (XCL::GLOBALLY-NOTINLINE-P NAME))))))
+
+(DEFUN ENV-PROCLAIM-SPECIAL (ENV NAME) (PUSH NAME (ENV-DECLARED-SPECIALS (FIND-TOP-ENVIRONMENT ENV))) NAME)
+
+(DEFUN ENV-PROCLAIMED-SPECIAL-P (ENV NAME) (MEMBER NAME (ENV-DECLARED-SPECIALS (FIND-TOP-ENVIRONMENT ENV)) :TEST (QUOTE EQ)))
+
+(DEFUN ENV-PROCLAIM-GLOBAL (ENV NAME) (PUSH NAME (ENV-DECLARED-GLOBALS (FIND-TOP-ENVIRONMENT ENV))) NAME)
+
+(DEFUN ENV-PROCLAIMED-GLOBAL-P (ENV NAME) (MEMBER NAME (ENV-DECLARED-GLOBALS (FIND-TOP-ENVIRONMENT ENV)) :TEST (QUOTE EQ)))
+
+(DEFUN ENV-DECLARE-SPECIALS (ENV SPECIALS) (SETF (ENV-DECLARED-SPECIALS ENV) (APPEND SPECIALS (ENV-DECLARED-SPECIALS ENV))))
+
+(DEFUN ENV-DECLARE-GLOBALS (ENV GLOBALS) (SETF (ENV-DECLARED-GLOBALS ENV) (APPEND GLOBALS (ENV-DECLARED-GLOBALS ENV))))
+
+(DEFUN ENV-DECLARE-A-SPECIAL (ENV VAR) (PUSH VAR (ENV-DECLARED-SPECIALS ENV)))
+
+(DEFUN ENV-DECLARE-A-GLOBAL (ENV VAR) (PUSH VAR (ENV-DECLARED-GLOBALS ENV)))
+
+(DEFUN FIND-TOP-ENVIRONMENT (ENV) (IL:|until| (NOT (ENV-P (ENV-PARENT ENV))) IL:|do| (SETQ ENV (ENV-PARENT ENV))) ENV)
+
+(DEFUN RESOLVE-VARIABLE-REFERENCE (CURRENT-ENV SYMBOL &OPTIONAL (SETQ-P NIL)) (IL:* IL:\; "Edited 31-Jan-92 12:54 by jrb:") (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS)) (LET ((OBJ (IL:* IL:|;;| "Check up the chain of environments for bindings or local declarations.") (DO ((ENV CURRENT-ENV (ENV-PARENT ENV)) TEMP) ((OR (EQ ENV NIL) (EQ ENV T)) (IL:* IL:|;;| "If we hit the end of the chain, then look for proclamations and check LOCALVARS, SPECVARS and GLOBALVARS.") (COND ((AND SETQ-P (OR (LOCAL-CONSTANT-P SYMBOL) (CONSTANTP SYMBOL))) (COMPILER-WARNING "Attempt to SETQ a declared constant: ~S" SYMBOL) (MAKE-VARIABLE :NAME SYMBOL :SCOPE :GLOBAL :KIND :VARIABLE)) ((LOCAL-CONSTANT-P SYMBOL) (MAKE-LITERAL :VALUE (CONSTANT-VALUE SYMBOL))) ((CONSTANTP SYMBOL) (MULTIPLE-VALUE-BIND (VALUE FOLDABLE?) (CHECK-GLOBAL-CONSTANT SYMBOL) (IF (NOT FOLDABLE?) (MAKE-VARIABLE :NAME SYMBOL :SCOPE :GLOBAL :KIND :VARIABLE) (MAKE-LITERAL :VALUE (SETF (CONSTANT-VALUE SYMBOL) VALUE))))) ((OR (IL:VARIABLE-GLOBAL-P SYMBOL) (MEMBER SYMBOL IL:GLOBALVARS :TEST (QUOTE EQ))) (MAKE-VARIABLE :NAME SYMBOL :SCOPE :GLOBAL :KIND :VARIABLE)) ((OR (AND (EQ IL:SPECVARS T) (NOT (MEMBER SYMBOL IL:LOCALVARS :TEST (QUOTE EQ)))) (MEMBER SYMBOL IL:SPECVARS :TEST (QUOTE EQ)) (MEMBER SYMBOL IL:LOCALFREEVARS :TEST (QUOTE EQ)) (IL:VARIABLE-GLOBALLY-SPECIAL-P SYMBOL)) (MAKE-VARIABLE :NAME SYMBOL :SCOPE :SPECIAL :KIND :VARIABLE)) (T (UNLESS (MEMBER SYMBOL *AUTOMATIC-SPECIAL-DECLARATIONS* :TEST (QUOTE EQ)) (COMPILER-WARNING "The variable ~S was unknown and has been declared SPECIAL." SYMBOL) (PUSH SYMBOL *AUTOMATIC-SPECIAL-DECLARATIONS*)) (ENV-DECLARE-A-SPECIAL CURRENT-ENV SYMBOL) (MAKE-VARIABLE :NAME SYMBOL :SCOPE :SPECIAL :KIND :VARIABLE)))) (IL:* IL:|;;| "In each environment, look for bindings or declarations that involve this variable.") (COND ((SETQ TEMP (ASSOC SYMBOL (ENV-VENV ENV))) (RETURN (CDR TEMP))) ((MEMBER SYMBOL (ENV-DECLARED-SPECIALS ENV) :TEST (QUOTE EQ)) (RETURN (MAKE-VARIABLE :NAME SYMBOL :SCOPE :SPECIAL :KIND :VARIABLE))) ((MEMBER SYMBOL (ENV-DECLARED-GLOBALS ENV) :TEST (QUOTE EQ)) (RETURN (MAKE-VARIABLE :NAME SYMBOL :SCOPE :GLOBAL :KIND :VARIABLE))))))) (IL:* IL:|;;| "SETQ's want a bare VARIABLE, not a VAR-REF.") (IF (AND (NULL SETQ-P) (VARIABLE-P OBJ)) (MAKE-VAR-REF :VARIABLE OBJ) OBJ)))
+
+(DEFUN RESOLVE-VARIABLE-BINDING (ENV SYMBOL) (IL:* IL:\; "Edited 31-Jan-92 12:42 by jrb:") (DECLARE (SPECIAL *NEW-GLOBALS* *NEW-SPECIALS* IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS)) (COND ((OR (LOCAL-CONSTANT-P SYMBOL) (CONSTANTP SYMBOL)) (COMPILER-CERROR "Make a lexical binding anyway." "The symbol ~S is declared as a constant and thus cannot be bound." SYMBOL) :LEXICAL) ((OR (MEMBER SYMBOL *NEW-GLOBALS* :TEST (QUOTE EQ)) (ENV-PROCLAIMED-GLOBAL-P ENV SYMBOL) (IL:VARIABLE-GLOBAL-P SYMBOL) (MEMBER SYMBOL IL:GLOBALVARS :TEST (QUOTE EQ))) (COMPILER-CERROR "Make a lexical binding anyway." "The symbol ~S is declared as a global and thus cannot be bound." SYMBOL) :LEXICAL) ((OR (MEMBER SYMBOL *NEW-SPECIALS* :TEST (QUOTE EQ)) (ENV-PROCLAIMED-SPECIAL-P ENV SYMBOL) (IL:VARIABLE-GLOBALLY-SPECIAL-P SYMBOL) (MEMBER SYMBOL IL:LOCALFREEVARS :TEST (QUOTE EQ)) (IF (EQ IL:SPECVARS T) (NOT (MEMBER SYMBOL IL:LOCALVARS :TEST (QUOTE EQ))) (MEMBER SYMBOL IL:SPECVARS :TEST (QUOTE EQ)))) :SPECIAL) (T :LEXICAL)))
+
+(DEFUN VALUE-FOLDABLE-P (VALUE) (IL:* IL:|;;;| "Should we replace a reference to a constant variable with the given value?  Be careful: this predicate must imply FASL:VALUE-DUMPABLE-P.  Also be careful about allowing folding of objects with components due to the EQ-ness problem.") (TYPEP VALUE (QUOTE (OR SYMBOL NUMBER CHARACTER))))
+
+(DEFUN CHECK-GLOBAL-CONSTANT (SYMBOL) (IL:* IL:|;;;| "Find the value for the globally-declared constant SYMBOL and decide whether or not it should be folded into code that references it.  Return two values, the constant value and a boolean which is true iff the value should be used.") (LET ((LOOKUP (GETHASH SYMBOL IL:COMPVARMACROHASH))) (COND ((NULL LOOKUP) (IL:* IL:|;;| "The symbol isn't in the COMPVARMACROHASH.  If it's bound, then use its value.  This is useful for keywords, for example.") (IF (BOUNDP SYMBOL) (VALUES (SYMBOL-VALUE SYMBOL) T) (ERROR "BUG: ~S is declared as a constant, but no value for it is known." SYMBOL))) ((OR (ATOM LOOKUP) (NOT (EQ (CAR LOOKUP) (QUOTE IL:CONSTANT))) (NULL (CDR LOOKUP)) (NOT (NULL (CDDR LOOKUP)))) (ERROR "BUG: The value of ~S in the constants hash table, ~S, has an illegal form." SYMBOL LOOKUP)) (T (LET* ((VALUE-EXPR (CADR LOOKUP)) (VALUE (EVAL VALUE-EXPR))) (IL:* IL:|;;| "Unless the VALUE-EXPR is the same as the SYMBOL (as it will be for all Common Lisp constants), we have no way of getting the value of the constant other than folding it in now.  For the cases where the VALUE-EXPR is the same as the SYMBOL, we can afford to use the more conservative VALUE-FOLDABLE-P test.") (VALUES VALUE (OR (NOT (EQ VALUE-EXPR SYMBOL)) (VALUE-FOLDABLE-P VALUE))))))))
+
+(DEFUN CONSTANT-VALUE (SYMBOL) (LET ((VALUE (GETHASH SYMBOL *CONSTANTS-HASH-TABLE*))) (ASSERT VALUE NIL "~S is not a known constant" SYMBOL) (CAR VALUE)))
+
+(DEFUN SET-CONSTANT-VALUE (SYMBOL VALUE) (CAR (SETF (GETHASH SYMBOL *CONSTANTS-HASH-TABLE*) (LIST VALUE))))
+
+(DEFUN LOCAL-CONSTANT-P (SYMBOL) (GETHASH SYMBOL *CONSTANTS-HASH-TABLE*))
+
+(DEFSETF CONSTANT-VALUE SET-CONSTANT-VALUE)
+
+(DEFVAR *CONSTANTS-HASH-TABLE* NIL (IL:* IL:|;;;| "Hash-table for keeping track of the constants defined in a given file."))
+
+(DEFVAR *ENVIRONMENT* NIL (IL:* IL:|;;;| "The current environment of declarations, bindings, etc.  Rebound at several places within the compiler."))
+
+(DEFVAR *CONTEXT* NIL "The evaluation context of the current form.  Rebound at several places within the compiler.")
+
+(DEFCONSTANT *ARGUMENT-CONTEXT* (MAKE-CONTEXT :VALUES-USED 1) "Context structure to be shared among all evaluations in return position.")
+
+(DEFCONSTANT *EFFECT-CONTEXT* (MAKE-CONTEXT :VALUES-USED 0) "Context structure to be shared among all evaluations for effect.")
+
+(DEFCONSTANT *NULL-CONTEXT* (MAKE-CONTEXT) "Context structure to be shared among all expressions in a position without any contextual information.")
+
+(DEFCONSTANT *PREDICATE-CONTEXT* (MAKE-CONTEXT :VALUES-USED 1 :PREDICATE-P T) "Context structure to be shared among all evaluations as predicates.")
+
+
+
+(IL:* IL:|;;| "External interface to environments")
+
+
+(DEFUN ENV-BOUNDP (ENV NAME) (IL:* IL:|;;;| "Only used by clients outside the compiler (i.e., macros and optimizers).") (LET ((LOOKUP (ASSOC NAME (ENV-VENV ENV)))) (COND (LOOKUP (LET ((SCOPE-OR-STRUCT (CDR LOOKUP))) (IF (VARIABLE-P SCOPE-OR-STRUCT) (VARIABLE-SCOPE SCOPE-OR-STRUCT) SCOPE-OR-STRUCT))) ((MEMBER NAME (ENV-DECLARED-SPECIALS ENV) :TEST (QUOTE EQ)) :SPECIAL) ((MEMBER NAME (ENV-DECLARED-GLOBALS ENV) :TEST (QUOTE EQ)) :GLOBAL) (T (LET ((PARENT (ENV-PARENT ENV))) (AND (ENV-P PARENT) (ENV-BOUNDP PARENT NAME)))))))
+
+(DEFUN ENV-FBOUNDP (ENV NAME &KEY (LEXICAL-ONLY NIL)) (IL:* IL:|;;;| "Return two values: the KIND of the given NAME (either :MACRO or :FUNCTION) and, iff KIND = :MACRO, the expansion function for the macro.") (IL:* IL:|;;;| "When LEXICAL-ONLY is true, we're only supposed to tell the user about lexically apparent functions and macros.  The environment chain ends in one representing the various top-level objects in the file.  In particular, top-level DEFMACRO's are in there.  Thus, in our search here, we must be careful to avoid looking in the top environment.  We can distinguish such environments because their PARENT is T.") (LABELS ((FIND-FN (ENV) (LET ((PARENT (ENV-PARENT ENV))) (UNLESS (AND LEXICAL-ONLY (EQ PARENT T)) (LET ((LOOKUP (ASSOC NAME (ENV-FENV ENV) :TEST (QUOTE EQ)))) (IF (NULL LOOKUP) (AND PARENT (NOT (EQ PARENT T)) (FIND-FN PARENT)) (VALUES-LIST (CDR LOOKUP)))))))) (FIND-FN ENV)))
+
+(DEFUN COPY-ENV-WITH-FUNCTION (ENV FN &OPTIONAL (KIND :FUNCTION) EXP-FN) (LET ((NEW-ENV (IF ENV (COPY-ENV ENV) (MAKE-EMPTY-ENV)))) (ENV-BIND-FUNCTION NEW-ENV FN KIND EXP-FN) NEW-ENV))
+
+(DEFUN COPY-ENV-WITH-VARIABLE (ENV VAR &OPTIONAL (KIND :LEXICAL)) (LET ((NEW-ENV (IF ENV (COPY-ENV ENV) (MAKE-EMPTY-ENV)))) (ENV-BIND-VARIABLE NEW-ENV VAR KIND) NEW-ENV))
+
+(DEFUN MAKE-EMPTY-ENV NIL (MAKE-ENV))
+
+
+
+(IL:* IL:|;;| "Describe the machine we're running on and the target for hte compiled code")
+
+
+(DEFVAR *HOST-ARCHITECTURE* NIL)
+
+(DEFVAR *TARGET-ARCHITECTURE* NIL)
+
+
+
+(IL:* IL:|;;| "Arrange for the correct compiler to be used.")
+
+
+(IL:PUTPROPS IL:XCLC-ENV-CTXT IL:FILETYPE COMPILE-FILE)
+
+
+
+(IL:* IL:|;;| "Arrange for the correct reader environment.")
+
+
+(IL:PUTPROPS IL:XCLC-ENV-CTXT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL"))))
+(IL:PUTPROPS IL:XCLC-ENV-CTXT IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/XCLC-ENV-CTXT.LCOM b/CLTL2/XCLC-ENV-CTXT.LCOM
new file mode 100644
index 00000000..86a7a067
Binary files /dev/null and b/CLTL2/XCLC-ENV-CTXT.LCOM differ
diff --git a/CLTL2/XCLC-GENCODE b/CLTL2/XCLC-GENCODE
new file mode 100644
index 00000000..da9e66b3
--- /dev/null
+++ b/CLTL2/XCLC-GENCODE
@@ -0,0 +1,170 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL")))
+(IL:FILECREATED " 4-Feb-92 10:30:26" IL:|{DSK}<usr>local>lde>lispcore>sources>XCLC-GENCODE.;2| 45625  
+
+      IL:|changes| IL:|to:|  (IL:FUNCTIONS STOP-UNBINDS-AT-FRAME-BOUNDARY GENCODE-CALL)
+
+      IL:|previous| IL:|date:| " 4-Jun-90 13:14:30" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>XCLC-GENCODE.;1|)
+
+
+; Copyright (c) 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:XCLC-GENCODECOMS)
+
+(IL:RPAQQ IL:XCLC-GENCODECOMS ((IL:* IL:|;;;| "Code Generation") (IL:VARIABLES *AVAILABLE-LEXICAL-NAMES* *BLIP-VAR* *CODE* *CURRENT-FRAME* *FRAME-NAME* *FREE-VENV* *NON-LOCALS* *OTHERS* *PC-VAR* *SPECIAL-LOCALS-BOUND* *SPECIAL-VENV* *STACK-NUMBER* *SUPPRESS-POPS* *TAG-NUMBER* *TAIL-RECURSION-THRESHOLD* *VAR-NUMBER* *LOCAL-FUNCTIONS*) (IL:FUNCTIONS START-LAP EMIT-LAP EMIT-LAP-LIST END-LAP) (IL:FUNCTIONS COLLECT-CODE FIND-SEGMENT MAKE-LAP-VAR MAKE-LAP-VAR-REFERENCE) (IL:FUNCTIONS SET-UP-RETURN-TO TAKE-DOWN-RETURN-TO) (IL:FUNCTIONS FRAME INTERCEPT-NON-LOCALS) (IL:COMS (IL:STRUCTURES UNBIND-FOR-TAIL-RECURSION) (IL:FUNCTIONS STOP-UNBINDS-AT-FRAME-BOUNDARY)) (IL:FUNCTIONS GENERATE-CODE GENCODE) (IL:* IL:\; "Yet to be written: gencode-progv") (IL:FUNCTIONS GENCODE-BLOCK GENCODE-CALL GENCODE-CATCH GENCODE-GO GENCODE-IF GENCODE-LABELS GENCODE-LAMBDA GENCODE-LET GENCODE-LITERAL GENCODE-MV-CALL GENCODE-MV-PROG1 GENCODE-OPCODES GENCODE-PROGN GENCODE-PROGV GENCODE-RETURN GENCODE-SEGMENT GENCODE-SETQ GENCODE-TAGBODY GENCODE-TAGBODY-INLINE GENCODE-THROW GENCODE-UNWIND-PROTECT GENCODE-VAR-REF) (IL:* IL:|;;| "Policy variables.") (IL:VARIABLES *POP-SUPPRESSION-POLICY* *TAIL-RECURSION-POLICY*) (IL:* IL:|;;| "Testing Code Generation") (IL:FUNCTIONS TEST-GENCODE TEST-GENCODE1) (IL:* IL:|;;| "Arrange to use the correct compiler.") (IL:PROP IL:FILETYPE IL:XCLC-GENCODE) (IL:* IL:|;;| "Arrange to use the proper makefile environment") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-GENCODE)))
+
+
+
+(IL:* IL:|;;;| "Code Generation")
+
+
+(DEFVAR *AVAILABLE-LEXICAL-NAMES* NIL (IL:* IL:|;;;| "A list of the previously-allocated-but-now-free names for lexical variables.  Newly-bound variables will take names from this list unless it's empty, at which point new names will be generated.  Each new frame rebinds this list to NIL."))
+
+(DEFVAR *BLIP-VAR* NIL "If non-NIL, this is the LAP variable to be used for naming the blip variable in the current frame.")
+
+(DEFVAR *CODE* NIL "The current collection of LAP instructions, in reverse order.  Added to during code generation.")
+
+(DEFVAR *CURRENT-FRAME* NIL (IL:* IL:|;;;| "Set to the block, tagbody, catch, unwind-protect, or lambda that was the cause of the current frame during code generation.  Used by GENCODE-GO and GENCODE-RETURN to determine if a jump is possible.  Also used by GENCODE-CALL in order to get the right code generated for calls to IL:ARG.  (Yecch.)"))
+
+(DEFVAR *FRAME-NAME* NIL "The name of the frame currently under construction.  Used in the code generator.")
+
+(DEFVAR *FREE-VENV* NIL "An AList mapping the symbols naming freely referenced special variables into the LAP variables representing them.  See also *special-venv*.")
+
+(DEFVAR *NON-LOCALS* NIL "A list of the lexical variables (in the form of VARIABLE structures) used freely below this point.  Added to and reset at various points during code generation.")
+
+(DEFVAR *OTHERS* NIL "A list of all auxillary variables used below the current point.  It eventually includes all non-parameter variables created within a given lambda.  Used during code generation.")
+
+(DEFVAR *PC-VAR* NIL (IL:* IL:|;;;| "Bound to the LAP-var representing the special variable SI::*CATCH-RETURN-PC* in the current frame.  Used by blippers for unwinding."))
+
+(DEFVAR *SPECIAL-LOCALS-BOUND* NIL "Bound to T in contexts in which local (i.e., non-argument) specials have been bound, in order to diable the tail-recursion optimization.")
+
+(DEFVAR *SPECIAL-VENV* NIL "An AList mapping the symbols naming currently-bound special variables into the LAP variables representing them.  See also *free-venv*.")
+
+(DEFVAR *STACK-NUMBER* NIL "Counter for generation of unique LAP stack-level names.")
+
+(DEFVAR *SUPPRESS-POPS* NIL "If non-NIL code in effect context will suppress any extra pop's that might normally be generated.  This variable is rebound throughout the code generator.  To turn off this optimization, set the variable *pop-suppression-policy* to NIL.")
+
+(DEFVAR *TAG-NUMBER* 0 "Counter for the generation of unique LAP statement labels.")
+
+(DEFPARAMETER *TAIL-RECURSION-THRESHOLD* 6 "The maximum number of required arguments a function can have and still enable the tail-recursion optimization.")
+
+(DEFVAR *VAR-NUMBER* 0 "Counter for the generation of unique LAP variables.")
+
+(DEFVAR *LOCAL-FUNCTIONS*)
+
+(DEFMACRO START-LAP NIL (QUOTE NIL))
+
+(DEFMACRO EMIT-LAP (INST) (IL:BQUOTE (PUSH (IL:\\\, INST) *CODE*)))
+
+(DEFMACRO EMIT-LAP-LIST (L) (IL:BQUOTE (SETQ *CODE* (REVAPPEND (IL:\\\, L) *CODE*))))
+
+(DEFMACRO END-LAP NIL (IL:BQUOTE (NREVERSE *CODE*)))
+
+(DEFUN COLLECT-CODE (NODE CONTEXT) (LET ((*CODE* (START-LAP))) (GENCODE NODE CONTEXT) (END-LAP)))
+
+(DEFUN FIND-SEGMENT (TAGBODY TAG) "Return the segment in the given tagbody that contains the given tag." (IL:|for| SEGMENT IL:|in| (TAGBODY-SEGMENTS TAGBODY) IL:|when| (MEMBER TAG (SEGMENT-TAGS SEGMENT) :TEST (QUOTE EQ)) IL:|do| (RETURN SEGMENT)))
+
+(DEFUN MAKE-LAP-VAR (VAR &OPTIONAL ARG-P) (IL:* IL:|;;;| "Create a new LAP variable for the given VARIABLE structure and make the appropriate kind of note about the variable created.") (IF (NOT (VARIABLE-P VAR)) VAR (ECASE (VARIABLE-SCOPE VAR) ((:SPECIAL) (LET ((LV (IL:BQUOTE (:S (IL:\\\, (VARIABLE-NAME VAR)) (IL:\\\, (INCF *VAR-NUMBER*)))))) (PUSH (CONS (VARIABLE-NAME VAR) LV) *SPECIAL-VENV*) (WHEN (NOT ARG-P) (PUSH LV *OTHERS*)) LV)) ((:LEXICAL) (IF (OR (NULL *AVAILABLE-LEXICAL-NAMES*) (VARIABLE-CLOSED-OVER VAR) (EQ :FUNCTION (VARIABLE-KIND VAR))) (IL:* IL:|;;| "Can't re-use a variable, so we'll make a new one.") (LET ((LV (LIST (IF (EQ :FUNCTION (VARIABLE-KIND VAR)) :FN :L) (VARIABLE-NAME VAR) (INCF *VAR-NUMBER*)))) (SETF (VARIABLE-LAP-VAR VAR) LV) (WHEN (AND (NOT ARG-P) (NOT (EQ (VARIABLE-KIND VAR) :FUNCTION))) (PUSH LV *OTHERS*)) LV) (IL:* IL:|;;| "There are old variables available for use.  Re-use one.") (SETF (VARIABLE-LAP-VAR VAR) (LIST :L (VARIABLE-NAME VAR) (POP *AVAILABLE-LEXICAL-NAMES*))))) ((:GLOBAL) (IL:BQUOTE (:G (IL:\\\, (VARIABLE-NAME VAR))))))))
+
+(DEFUN MAKE-LAP-VAR-REFERENCE (VAR) (ECASE (VARIABLE-SCOPE VAR) ((:LEXICAL) (PUSHNEW VAR *NON-LOCALS*) (LET ((LAP-VAR (VARIABLE-LAP-VAR VAR))) (ASSERT (NOT (NULL LAP-VAR)) NIL "BUG: ~S should should have a LAP var by now." VAR) LAP-VAR)) ((:SPECIAL) (LET ((LOOKUP (OR (ASSOC (VARIABLE-NAME VAR) *SPECIAL-VENV*) (ASSOC (VARIABLE-NAME VAR) *FREE-VENV*)))) (IF (NOT (NULL LOOKUP)) (CDR LOOKUP) (LET ((LV (IL:BQUOTE (:F (IL:\\\, (VARIABLE-NAME VAR)) (IL:\\\, (INCF *VAR-NUMBER*)))))) (PUSH (CONS (VARIABLE-NAME VAR) LV) *FREE-VENV*) (PUSH LV *OTHERS*) LV)))) ((:GLOBAL) (IL:BQUOTE (:G (IL:\\\, (VARIABLE-NAME VAR)))))))
+
+(DEFUN SET-UP-RETURN-TO NIL (IL:* IL:|;;| "Perform those operations necessary to set up a return-to context for code-generation.") (WHEN (NULL *BLIP-VAR*) (SETQ *BLIP-VAR* (IL:BQUOTE (:S SI::*CATCH-RETURN-TO* (IL:\\\, (INCF *VAR-NUMBER*))))) (PUSH *BLIP-VAR* *OTHERS*)) (WHEN (NULL *PC-VAR*) (SETQ *PC-VAR* (IL:BQUOTE (:S SI::*CATCH-RETURN-PC* (IL:\\\, (INCF *VAR-NUMBER*))))) (PUSH *PC-VAR* *OTHERS*)))
+
+(DEFUN TAKE-DOWN-RETURN-TO NIL (EMIT-LAP-LIST (IL:BQUOTE ((:CONST NIL) (:VAR_ (IL:\\\, *BLIP-VAR*)) (:POP)))))
+
+(DEFMACRO FRAME ((&KEY CURRENT-FRAME NAME BLIPS-ALLOWED) &BODY BODY) (IL:BQUOTE (LET ((IL:\\\,@ (AND CURRENT-FRAME (IL:BQUOTE ((*CURRENT-FRAME* (IL:\\\, CURRENT-FRAME)))))) (IL:\\\,@ (AND NAME (IL:BQUOTE ((*FRAME-NAME* (IL:\\\, NAME)))))) (*BLIP-VAR* NIL) (*PC-VAR* NIL) (*CODE* (START-LAP)) *OTHERS* *SPECIAL-LOCALS-BOUND* *SPECIAL-VENV* *FREE-VENV* *AVAILABLE-LEXICAL-NAMES* *LOCAL-FUNCTIONS*) (HANDLER-BIND ((UNBIND-FOR-TAIL-RECURSION (FUNCTION STOP-UNBINDS-AT-FRAME-BOUNDARY))) (IL:\\\,@ BODY)))))
+
+(DEFMACRO INTERCEPT-NON-LOCALS (PASS-ON &BODY BODY) (IL:BQUOTE (LET (OUTER-NON-LOCALS) (LET (*NON-LOCALS*) (IL:\\\,@ BODY) (SETQ OUTER-NON-LOCALS (IL:\\\, PASS-ON))) (SETQ *NON-LOCALS* (UNION OUTER-NON-LOCALS *NON-LOCALS*)))))
+
+(DEFINE-CONDITION UNBIND-FOR-TAIL-RECURSION (CONDITION) NIL)
+
+(DEFUN STOP-UNBINDS-AT-FRAME-BOUNDARY (CONDITION) (IL:* IL:\; "Edited 31-Jan-92 12:50 by jrb:") (IL:* IL:|;;| "This routine stops propagation of UNBIND-FOR-TAIL-RECURSION.") (ASSERT (TYPEP CONDITION (QUOTE UNBIND-FOR-TAIL-RECURSION)) NIL "BUG: Unbind stopper called with bad condition.") (LET ((RESTART (FIND-RESTART (QUOTE CONTINUE-TAIL-CALL-TRANSFORMATION)))) (WHEN (NULL RESTART) (COMPILER-CERROR "Muddle on anyway" "BUG: Can't find restart for tail call transformation")) (INVOKE-RESTART RESTART)))
+
+(DEFUN GENERATE-CODE (TREE) (IL:* IL:|;;;| "GenCode functions take a subtree as an argument and return a list of LAP instructions that implement that subtree.  Here, at the top of the generator, we know that TREE is a LAMBDA and that only one instruction will be returned.  We return that instruction.") (ASSERT (LAMBDA-P TREE) NIL "Root tree for code generation is not a LAMBDA") (LET* ((*VAR-NUMBER* 0) (*TAG-NUMBER* 0) (*STACK-NUMBER* 0) (*CODE* (START-LAP))) (GENCODE-LAMBDA TREE :ARGUMENT) (ASSERT (NULL (CDR (SETQ *CODE* (END-LAP)))) NIL "Code generation returned more than one instruction!") (CAR *CODE*)))
+
+(DEFUN GENCODE (NODE CONTEXT) "Dispatching function for code generation." (NODE-DISPATCH GENCODE NODE CONTEXT))
+
+
+
+(IL:* IL:\; "Yet to be written: gencode-progv")
+
+
+(DEFUN GENCODE-BLOCK (NODE CONTEXT) (COND ((BLOCK-NEW-FRAME-P NODE) (IL:* IL:\; "Construct a new lambda for the block.") (LET (NEW-LAMBDA) (FRAME (:NAME (FORMAT NIL "block ~A in ~A" (BLOCK-NAME NODE) *FRAME-NAME*) :CURRENT-FRAME NODE) (LET ((EFFECTIVE-CONTEXT (ECASE CONTEXT (:MV :MV) (:RETURN :RETURN) ((:EFFECT :ARGUMENT) :ARGUMENT))) (END-TAG (INCF *TAG-NUMBER*)) BLIP-RETURN-VAR OUR-NON-LOCALS) (SETF (BLOCK-FRAME NODE) *CURRENT-FRAME*) (SETF (BLOCK-CONTEXT NODE) EFFECTIVE-CONTEXT) (SETF (BLOCK-END-TAG NODE) END-TAG) (COND ((BLOCK-CLOSED-OVER-P NODE) (SETQ *BLIP-VAR* (IL:BQUOTE (:S SI::*CATCH-RETURN-FROM* (IL:\\\, (INCF *VAR-NUMBER*))))) (SETQ BLIP-RETURN-VAR (MAKE-LAP-VAR (BLOCK-BLIP-VAR NODE))) (EMIT-LAP-LIST (IL:BQUOTE ((:CONST (IL:\\\, *FRAME-NAME*)) (:CONST NIL) (:CALL CONS 2) (:VAR_ (IL:\\\, *BLIP-VAR*)) (:VAR_ (IL:\\\, BLIP-RETURN-VAR)) (:POP)))) (SETQ *OTHERS* (LIST BLIP-RETURN-VAR *BLIP-VAR*))) (T (SETQ *BLIP-VAR* (IL:BQUOTE (:S SI::*CATCH-RETURN-TO* (IL:\\\, (INCF *VAR-NUMBER*))))) (SETQ *OTHERS* (LIST *BLIP-VAR*)))) (INTERCEPT-NON-LOCALS (SETQ OUR-NON-LOCALS (DELETE (BLOCK-BLIP-VAR NODE) *NON-LOCALS*)) (GENCODE (BLOCK-STMT NODE) EFFECTIVE-CONTEXT)) (EMIT-LAP-LIST (IL:BQUOTE ((:TAG (IL:\\\, END-TAG)) (:RETURN)))) (SETQ NEW-LAMBDA (IL:BQUOTE (:LAMBDA (NIL (IL:\\\,@ (AND *OTHERS* (IL:BQUOTE (:OTHERS (IL:\\\, *OTHERS*))))) :NAME (IL:\\\, *FRAME-NAME*) :BLIP (IL:\\\, *BLIP-VAR*) (IL:\\\,@ (AND OUR-NON-LOCALS (IL:BQUOTE (:NON-LOCAL (IL:\\\, (MAPCAR (FUNCTION VARIABLE-LAP-VAR) OUR-NON-LOCALS)))))) (IL:\\\,@ (AND (BLOCK-CLOSED-OVER-VARS NODE) (IL:BQUOTE (:CLOSED-OVER (IL:\\\, (MAPCAR (FUNCTION VARIABLE-LAP-VAR) (BLOCK-CLOSED-OVER-VARS NODE))))))) (IL:\\\,@ (AND *LOCAL-FUNCTIONS* (IL:BQUOTE (:LOCAL-FUNCTIONS (IL:\\\, *LOCAL-FUNCTIONS*)))))) (IL:\\\,@ (END-LAP))))))) (EMIT-LAP (IL:BQUOTE (:CALL (IL:\\\, NEW-LAMBDA) 0))) (IL:* IL:\; "Generate a call to the new lambda.") (WHEN (AND (EQ CONTEXT :EFFECT) (NOT *SUPPRESS-POPS*)) (EMIT-LAP (QUOTE (:POP)))))) (T (IL:* IL:|;;| "No new frame is needed, so compile the block inline, setting up and taking down the blip stuff if it's closed over.") (LET ((END-TAG (INCF *TAG-NUMBER*)) (STK-NUM (INCF *STACK-NUMBER*))) (SETF (BLOCK-FRAME NODE) *CURRENT-FRAME*) (SETF (BLOCK-END-TAG NODE) END-TAG) (SETF (BLOCK-STK-NUM NODE) STK-NUM) (SETF (BLOCK-CONTEXT NODE) CONTEXT) (IL:* IL:|;;| "If the block is closed over, we need to set up and take down the blip stuff around the execution of the body.  If it isn't closed over, then almost nothing extra is needed.") (COND ((BLOCK-CLOSED-OVER-P NODE) (LET ((BLIP-VAR (MAKE-LAP-VAR (BLOCK-BLIP-VAR NODE))) (REMOTE-RETURN-TAG (INCF *TAG-NUMBER*))) (FLET ((GENCODE-CLOSED-OVER-BLOCK NIL (SET-UP-RETURN-TO) (EMIT-LAP-LIST (IL:BQUOTE ((:CONST (IL:\\\, (BLOCK-NAME NODE))) (:CONST (IL:\\\, *FRAME-NAME*)) (:CALL CONS 2) (:VAR_ (IL:\\\, *BLIP-VAR*)) (:VAR_ (IL:\\\, BLIP-VAR)) (:POP) (:PUSH-TAG (IL:\\\, REMOTE-RETURN-TAG)) (:VAR_ (IL:\\\, *PC-VAR*)) (:POP) (:NOTE-STACK (IL:\\\, STK-NUM))))) (INTERCEPT-NON-LOCALS (DELETE (BLOCK-BLIP-VAR NODE) *NON-LOCALS*) (GENCODE (BLOCK-STMT NODE) CONTEXT)) (ECASE CONTEXT ((:EFFECT) (EMIT-LAP-LIST (IL:BQUOTE ((:JUMP (IL:\\\, END-TAG)) (:TAG (IL:\\\, REMOTE-RETURN-TAG)) (:DSET-STACK (IL:\\\, STK-NUM)) (:TAG (IL:\\\, END-TAG))))) (TAKE-DOWN-RETURN-TO)) ((:MV :ARGUMENT) (EMIT-LAP-LIST (IL:BQUOTE ((:JUMP (IL:\\\, END-TAG)) (:TAG (IL:\\\, REMOTE-RETURN-TAG)) (:SET-STACK (IL:\\\, STK-NUM)) (:TAG (IL:\\\, END-TAG))))) (TAKE-DOWN-RETURN-TO)) ((:RETURN) (EMIT-LAP-LIST (IL:BQUOTE ((:TAG (IL:\\\, REMOTE-RETURN-TAG)) (:TAG (IL:\\\, END-TAG))))))))) (IF (NULL (BLOCK-CLOSED-OVER-VARS NODE)) (GENCODE-CLOSED-OVER-BLOCK) (LET ((CODE (LET ((*CODE* (START-LAP))) (GENCODE-CLOSED-OVER-BLOCK) (END-LAP)))) (EMIT-LAP (IL:BQUOTE (:CLOSE (IL:\\\, (MAPCAR (FUNCTION VARIABLE-LAP-VAR) (BLOCK-CLOSED-OVER-VARS NODE))) (IL:\\\,@ CODE))))))))) (T (IL:* IL:|;;| "Simplest case: the block is neither closed over nor needs a new frame.") (EMIT-LAP (IL:BQUOTE (:NOTE-STACK (IL:\\\, STK-NUM)))) (GENCODE (BLOCK-STMT NODE) CONTEXT) (EMIT-LAP (IL:BQUOTE (:TAG (IL:\\\, END-TAG))))))))))
+
+(DEFUN GENCODE-CALL (NODE CONTEXT) (IL:* IL:\; "Edited 31-Jan-92 12:51 by jrb:") (IL:* IL:|;;;| "If the function is a global function symbol, evaluate the arguments onto the stack and emit a FN.  If it's a lambda with only required parameters, then evaluate only the non-nil arguments on the stack, bind the parameters, execute the body, and unbind.  Otherwise, evaluate the args and function and call FUNCALL.") (LET* ((FN (CALL-FN NODE)) (ARGS (CALL-ARGS NODE)) (NUM-ARGS (LENGTH ARGS)) (IL-LAMBDA NIL)) (COND (IL:* IL:|;;| "Can we perform tail recursion elimination?") ((AND (EQ CONTEXT :RETURN) (NOT (NULL *TAIL-RECURSION-POLICY*)) (NOT *SPECIAL-LOCALS-BOUND*) (NOT (CALLER-NOT-INLINE NODE)) (VAR-REF-P FN) (LET ((VAR (VAR-REF-VARIABLE FN))) (AND (EQ :FUNCTION (VARIABLE-KIND VAR)) (EQUAL *FRAME-NAME* (VARIABLE-NAME VAR))) (IL:* IL:\; "EQUAL here because of FLET.")) (<= (LENGTH (LAMBDA-REQUIRED *CURRENT-FRAME*)) *TAIL-RECURSION-THRESHOLD*) (OR (AND (NULL (LAMBDA-OPTIONAL *CURRENT-FRAME*)) (NULL (LAMBDA-REST *CURRENT-FRAME*))) (IL:* IL:|;;| " This for Interlisp-D LAMBDA form") (PROG1 (= (LENGTH (LAMBDA-OPTIONAL *CURRENT-FRAME*)) NUM-ARGS) (SETQ IL-LAMBDA T))) (NULL (LAMBDA-KEYWORD *CURRENT-FRAME*))) (IL:|for| ARG IL:|in| ARGS IL:|do| (GENCODE ARG :ARGUMENT)) (IF IL-LAMBDA (IL:|for| PARAM IL:|in| (REVERSE (LAMBDA-OPTIONAL *CURRENT-FRAME*)) IL:|do| (EMIT-LAP-LIST (IL:BQUOTE ((:VAR_ (IL:\\\, (MAKE-LAP-VAR-REFERENCE (CAR PARAM)))) (:POP))))) (IL:|for| PARAM IL:|in| (REVERSE (LAMBDA-REQUIRED *CURRENT-FRAME*)) IL:|do| (EMIT-LAP-LIST (IL:BQUOTE ((:VAR_ (IL:\\\, (MAKE-LAP-VAR-REFERENCE PARAM))) (:POP)))))) (RESTART-CASE (SIGNAL (QUOTE UNBIND-FOR-TAIL-RECURSION)) (CONTINUE-TAIL-CALL-TRANSFORMATION NIL)) (EMIT-LAP (IL:BQUOTE (:JUMP (IL:\\\, (OR (LAMBDA-TAIL-CALL-TAG *CURRENT-FRAME*) (SETF (LAMBDA-TAIL-CALL-TAG *CURRENT-FRAME*) (INCF *TAG-NUMBER*)))))))) (IL:* IL:|;;| "Maybe it's a global function") ((GLOBAL-FUNCTION-P FN) (LET ((FN-VAR (VAR-REF-VARIABLE FN))) (COND ((EQ (VARIABLE-NAME FN-VAR) (QUOTE IL:\\CALLME)) (IL:* IL:|;;| "Hook for the IL:\\\\CALLME special form.  This simply changes the name of the current frame to the given argument and otherwise generates no code.") (ASSERT (EQ CONTEXT :EFFECT) NIL "BUG: The ~S special form not in effect context in code generation." (QUOTE IL:\\CALLME)) (ASSERT (LITERAL-P (FIRST ARGS)) NIL "BUG: The ~S special form has an unquoted argument in code generation." (QUOTE IL:\\CALLME)) (SETQ *FRAME-NAME* (LITERAL-VALUE (FIRST ARGS))) (RETURN-FROM GENCODE-CALL)) ((AND (MEMBER (VARIABLE-NAME FN-VAR) (QUOTE (IL:\\ARG IL:\\SETARG))) (LITERAL-P (FIRST ARGS)) (NOT (CALLER-NOT-INLINE NODE))) (IL:* IL:|;;| "Here it is, the nasty hook for compiling Interlisp's LAMBDA no-spread's.  If we're compiling a call to the function IL:ARG, we check to see if it's referring to the current frame.  If so, we compile it as a call to IL:\\\\ARG0 which will later be assembled into an opcode.  If the IL:ARG call doesn't refer to the current frame, then we compile it closed, using the LAMBDA-version of that function, IL:\\\\ARG.") (IL:* IL:|;;| "The same mechanism is here for IL:SETARG.") (LET* ((PARAMETER-NAME (LITERAL-VALUE (FIRST ARGS))) (CLOSED-FN-NAME (VARIABLE-NAME FN-VAR)) (OPEN-FN-NAME (CASE CLOSED-FN-NAME (IL:\\ARG (QUOTE IL:\\ARG0)) (IL:\\SETARG (QUOTE IL:\\SETARG0))))) (UNLESS (SYMBOLP PARAMETER-NAME) (COMPILER-CERROR "Use the symbol %LOSE% instead" "Illegal argument to the ~S function: ~S" (VARIABLE-NAME FN-VAR) PARAMETER-NAME)) (COND ((AND (LAMBDA-P *CURRENT-FRAME*) (EQ (LAMBDA-NO-SPREAD-NAME *CURRENT-FRAME*) PARAMETER-NAME)) (IL:* IL:\; "It's a reference to the local frame.") (GENCODE (SECOND ARGS) :ARGUMENT) (WHEN (THIRD ARGS) (GENCODE (THIRD ARGS) :ARGUMENT)) (EMIT-LAP (IL:BQUOTE (:CALL (IL:\\\, OPEN-FN-NAME) (IL:\\\, (1- (LENGTH ARGS))))))) (T (IL:* IL:\; "It's a remote reference.") (EMIT-LAP (IL:BQUOTE (:CONST (IL:\\\, PARAMETER-NAME)))) (GENCODE (SECOND ARGS) :ARGUMENT) (WHEN (THIRD ARGS) (GENCODE (THIRD ARGS) :ARGUMENT)) (EMIT-LAP (IL:BQUOTE (:CALL (IL:\\\, CLOSED-FN-NAME) (IL:\\\, (LENGTH ARGS))))))))) (T (IL:|for| ARG IL:|in| ARGS IL:|do| (GENCODE ARG :ARGUMENT)) (EMIT-LAP (IL:BQUOTE (:CALL (IL:\\\, (VARIABLE-NAME FN-VAR)) (IL:\\\, NUM-ARGS) (IL:\\\,@ (AND (CALLER-NOT-INLINE NODE) (IL:BQUOTE (:NOT-INLINE T))))))))) (CASE CONTEXT (:EFFECT (WHEN (NOT *SUPPRESS-POPS*) (EMIT-LAP (QUOTE (:POP))))) (:MV (EMIT-LAP (QUOTE (:CALL IL:\\MVLIST 1))))))) (IL:* IL:|;;| "Is it a desugared LET?") ((AND (LAMBDA-P FN) (NOT (LAMBDA-NEW-FRAME-P FN))) (IL:* IL:|;;| "NOTE: This code makes the assumption that *code* is maintained by pushing bytes onto a list and should be re-examined if that is ever changed (e.g., to the TCONC method).") (IL:* IL:|;;| "NOTE: This is a LET* so as to guarantee that the code below has been generated before we try to extract LAP vars from the variables, since those LAP vars might not exist yet.") (LET* ((INNER-CODE (LET (*CODE*) (GENCODE-LET FN ARGS CONTEXT) *CODE*)) (CLOSED-OVER (MAPCAR (FUNCTION VARIABLE-LAP-VAR) (LAMBDA-CLOSED-OVER-VARS FN)))) (COND ((NULL CLOSED-OVER) (SETQ *CODE* (NCONC INNER-CODE *CODE*))) (T (EMIT-LAP (IL:BQUOTE (:CLOSE (IL:\\\, CLOSED-OVER) (IL:\\\,@ (NREVERSE INNER-CODE))))))))) (IL:* IL:|;;| "Perhaps it's a low-level OPCODES function.") ((OPCODES-P FN) (IL:|for| ARG IL:|in| ARGS IL:|do| (GENCODE ARG :ARGUMENT)) (EMIT-LAP (IL:BQUOTE (:CALL (:OPCODES (IL:\\\,@ (OPCODES-BYTES FN))) (IL:\\\, NUM-ARGS)))) (CASE CONTEXT (:EFFECT (WHEN (NOT *SUPPRESS-POPS*) (EMIT-LAP (QUOTE (:POP))))) (:MV (EMIT-LAP (QUOTE (:CALL IL:\\MVLIST 1)))))) (IL:* IL:|;;| "Well, it wasn't any of those, so compile the general case. ") (T (COND ((IL:|for| ARG IL:|in| ARGS IL:|always| (PASSABLE FN ARG)) (IL:* IL:\; "The function can pass all of the arguments, so we can use APPLYFN without an auxillary variable.") (IL:|for| ARG IL:|in| ARGS IL:|do| (GENCODE ARG :ARGUMENT)) (COND ((LAMBDA-P FN) (LET ((CODE-FOR-FN (COLLECT-CODE FN :ARGUMENT))) (EMIT-LAP (IL:BQUOTE (:CALL (IL:\\\, (POP CODE-FOR-FN)) (IL:\\\, NUM-ARGS)))) (ASSERT (NULL CODE-FOR-FN) NIL "BUG: a lambda generated more than one LAP op."))) ((VAR-REF-P FN) (IL:* IL:\; "Must be a local or a special - external functions have already been handled.") (LET ((VAR (VAR-REF-VARIABLE FN))) (ASSERT (NOT (EQ (VARIABLE-SCOPE VAR) :GLOBAL)) (QUOTE (FN)) "BUG: external function call got into the general case.") (EMIT-LAP (IL:BQUOTE (:CALL (IL:\\\, (MAKE-LAP-VAR-REFERENCE VAR)) (IL:\\\, NUM-ARGS)))))) (T (IL:* IL:\; "Random expression - have to punt to a :STKCALL") (EMIT-LAP (IL:BQUOTE (:CONST (IL:\\\, NUM-ARGS)))) (GENCODE FN :ARGUMENT) (EMIT-LAP (IL:BQUOTE (:STKCALL (IL:\\\, NUM-ARGS)))))) (COND ((LAMBDA-P FN) (GENCODE-LAMBDA FN :ARGUMENT CONTEXT)))) (T (IL:* IL:\; "Rats!  We have to allocate a new local variable to store the function in during the evaluation of the arguments.") (LET ((FN-VAR (COND ((NULL *AVAILABLE-LEXICAL-NAMES*) (LET ((LV (IL:BQUOTE (:L "APPLYFN Variable" (IL:\\\, (INCF *VAR-NUMBER*)))))) (PUSH LV *OTHERS*) LV)) (T (IL:BQUOTE (:L "APPLYFN Variable" (IL:\\\, (POP *AVAILABLE-LEXICAL-NAMES*)))))))) (IF (LAMBDA-P FN) (GENCODE-LAMBDA FN :ARGUMENT CONTEXT) (GENCODE FN :ARGUMENT)) (EMIT-LAP-LIST (IL:BQUOTE ((:VAR_ (IL:\\\, FN-VAR)) (:POP)))) (IL:|for| ARG IL:|in| ARGS IL:|do| (GENCODE ARG :ARGUMENT)) (EMIT-LAP (IL:BQUOTE (:CALL (IL:\\\, FN-VAR) (IL:\\\, NUM-ARGS)))) (PUSH (THIRD FN-VAR) *AVAILABLE-LEXICAL-NAMES*)))) (CASE CONTEXT (:EFFECT (WHEN (NOT *SUPPRESS-POPS*) (EMIT-LAP (QUOTE (:POP))))) (:MV (UNLESS (LAMBDA-P FN) (IL:* IL:\; "If the function is a LAMBDA, then we've already made it return a list of values.") (EMIT-LAP (QUOTE (:CALL IL:\\MVLIST 1))))))))))
+
+(DEFUN GENCODE-CATCH (NODE CONTEXT) (COND ((BLIPPER-NEW-FRAME-P NODE) (IL:* IL:|;;| "This CATCH has to be a new frame.  Compile the body as a new function with one argument, the value of the tag expression.") (LET (NEW-LAMBDA) (FRAME (:CURRENT-FRAME NODE :NAME (FORMAT NIL "catch in ~A" *FRAME-NAME*)) (LET* ((BLIP-SLOT-NAME (IF (EQ CONTEXT :MV) (QUOTE SI::*CATCH-RETURN-TO*) (QUOTE SI::*CATCH-RETURN-FROM*))) (BLIP-SLOT-VAR (IL:BQUOTE (:S (IL:\\\, BLIP-SLOT-NAME) (IL:\\\, (INCF *VAR-NUMBER*))))) (TAG-VAR (IL:BQUOTE (:L "%TAG" (IL:\\\, (INCF *VAR-NUMBER*))))) OUR-NON-LOCALS (THROW-PC-VAR (IL:BQUOTE (:S SI::*CATCH-RETURN-PC* (IL:\\\, (INCF *VAR-NUMBER*))))) (THROW-DESTINATION-TAG (INCF *TAG-NUMBER*))) (INTERCEPT-NON-LOCALS (SETQ OUR-NON-LOCALS *NON-LOCALS*) (GENCODE (CATCH-STMT NODE) CONTEXT)) (SETQ NEW-LAMBDA (IL:BQUOTE (:LAMBDA (((IL:\\\, TAG-VAR)) :BLIP (IL:\\\, BLIP-SLOT-VAR) :NAME (IL:\\\, *FRAME-NAME*) :OTHERS ((IL:\\\, BLIP-SLOT-VAR) (IL:\\\,@ (AND (EQ CONTEXT :MV) (IL:BQUOTE ((IL:\\\, THROW-PC-VAR))))) (IL:\\\,@ *OTHERS*)) (IL:\\\,@ (AND OUR-NON-LOCALS (IL:BQUOTE (:NON-LOCAL (IL:\\\, (MAPCAR (FUNCTION VARIABLE-LAP-VAR) OUR-NON-LOCALS)))))) (IL:\\\,@ (AND (CATCH-CLOSED-OVER-VARS NODE) (IL:BQUOTE (:CLOSED-OVER (IL:\\\, (MAPCAR (FUNCTION VARIABLE-LAP-VAR) (CATCH-CLOSED-OVER-VARS NODE))))))) (IL:\\\,@ (AND *LOCAL-FUNCTIONS* (IL:BQUOTE (:LOCAL-FUNCTIONS (IL:\\\, *LOCAL-FUNCTIONS*)))))) (IL:* IL:|;;| "Set up the blip and, when in MV context, the THROW PC.") (:VAR (IL:\\\, TAG-VAR)) (:VAR_ (IL:\\\, BLIP-SLOT-VAR)) (:POP) (IL:\\\,@ (AND (EQ CONTEXT :MV) (IL:BQUOTE ((:PUSH-TAG (IL:\\\, THROW-DESTINATION-TAG)) (:VAR_ (IL:\\\, THROW-PC-VAR)) (:POP))))) (IL:\\\,@ (END-LAP)) (:RETURN) (IL:\\\,@ (AND (EQ CONTEXT :MV) (IL:BQUOTE ((:TAG (IL:\\\, THROW-DESTINATION-TAG)) (:CALL IL:\\MVLIST 1) (:RETURN)))))))))) (GENCODE (CATCH-TAG NODE) :ARGUMENT) (EMIT-LAP (IL:BQUOTE (:CALL (IL:\\\, NEW-LAMBDA) 1))) (WHEN (EQ CONTEXT :EFFECT) (EMIT-LAP (QUOTE (:POP)))))) (T (IL:* IL:|;;| "This CATCH should not be a new frame.  We compile it inline, setting up and taking down blip stuff around the computation of the body.") (LET ((END-TAG (INCF *TAG-NUMBER*)) (THROW-TAG (INCF *TAG-NUMBER*)) (STK-NUM (INCF *STACK-NUMBER*))) (SET-UP-RETURN-TO) (GENCODE (CATCH-TAG NODE) :ARGUMENT) (EMIT-LAP-LIST (IL:BQUOTE ((:VAR_ (IL:\\\, *BLIP-VAR*)) (:POP) (:PUSH-TAG (IL:\\\, THROW-TAG)) (:VAR_ (IL:\\\, *PC-VAR*)) (:POP) (:NOTE-STACK (IL:\\\, STK-NUM))))) (GENCODE (CATCH-STMT NODE) CONTEXT) (ECASE CONTEXT ((:EFFECT) (EMIT-LAP-LIST (IL:BQUOTE ((:JUMP (IL:\\\, END-TAG)) (:TAG (IL:\\\, THROW-TAG)) (:DSET-STACK (IL:\\\, STK-NUM)) (:TAG (IL:\\\, END-TAG))))) (TAKE-DOWN-RETURN-TO)) ((:MV) (EMIT-LAP-LIST (IL:BQUOTE ((:JUMP (IL:\\\, END-TAG)) (:TAG (IL:\\\, THROW-TAG)) (:CALL IL:\\MVLIST 1) (:SET-STACK (IL:\\\, STK-NUM)) (:TAG (IL:\\\, END-TAG))))) (TAKE-DOWN-RETURN-TO)) ((:ARGUMENT) (EMIT-LAP-LIST (IL:BQUOTE ((:JUMP (IL:\\\, END-TAG)) (:TAG (IL:\\\, THROW-TAG)) (:SET-STACK (IL:\\\, STK-NUM)) (:TAG (IL:\\\, END-TAG))))) (TAKE-DOWN-RETURN-TO)) ((:RETURN) (EMIT-LAP (IL:BQUOTE (:TAG (IL:\\\, THROW-TAG))))))))))
+
+(DEFUN GENCODE-GO (NODE CONTEXT) (DECLARE (IGNORE CONTEXT)) (LET* ((TAGBODY (GO-TAGBODY NODE)) (SEGMENT (FIND-SEGMENT TAGBODY (GO-TAG NODE)))) (COND ((EQ *CURRENT-FRAME* (TAGBODY-FRAME TAGBODY)) (IL:* IL:\; "The tagbody is local; a simple stack adjustment and JUMP suffice.") (EMIT-LAP-LIST (IL:BQUOTE ((:DSET-STACK (IL:\\\, (TAGBODY-STK-NUM TAGBODY))) (:JUMP (IL:\\\, (SEGMENT-LOCAL-TAG SEGMENT))))))) (T (EMIT-LAP-LIST (IL:BQUOTE ((:VAR (IL:\\\, (VARIABLE-LAP-VAR (TAGBODY-BLIP-VAR TAGBODY)))) (:PUSH-TAG (IL:\\\, (SEGMENT-REMOTE-TAG SEGMENT))) (:CALL SI::NON-LOCAL-GO 2)))) (PUSH (TAGBODY-BLIP-VAR TAGBODY) *NON-LOCALS*)))))
+
+(DEFUN GENCODE-IF (NODE CONTEXT) (LET ((ELSE-TAG (INCF *TAG-NUMBER*)) (AFTER-IF-TAG (INCF *TAG-NUMBER*))) (GENCODE (IF-PRED NODE) :ARGUMENT) (EMIT-LAP (IL:BQUOTE (:FJUMP (IL:\\\, ELSE-TAG)))) (GENCODE (IF-THEN NODE) CONTEXT) (IF (EQ CONTEXT :RETURN) (EMIT-LAP (QUOTE (:RETURN))) (EMIT-LAP (IL:BQUOTE (:JUMP (IL:\\\, AFTER-IF-TAG))))) (EMIT-LAP (IL:BQUOTE (:TAG (IL:\\\, ELSE-TAG)))) (GENCODE (IF-ELSE NODE) CONTEXT) (UNLESS (EQ CONTEXT :RETURN) (EMIT-LAP (IL:BQUOTE (:TAG (IL:\\\, AFTER-IF-TAG)))))))
+
+(DEFUN GENCODE-LABELS (NODE CONTEXT) (IL:* IL:|;;| "Make LAP vars first to take care of \"forward\" references.") (DOLIST (FN-PAIR (LABELS-FUNS NODE)) (MAKE-LAP-VAR (CAR FN-PAIR))) (IL:* IL:|;;| "Generate the local functions.") (LET (INNER-CODE CLOSED-OVER) (INTERCEPT-NON-LOCALS (DELETE-IF (FUNCTION (LAMBDA (VAR) (EQ (VARIABLE-BINDER VAR) NODE))) *NON-LOCALS*) (DOLIST (FN-PAIR (LABELS-FUNS NODE)) (PUSH (CONS (MAKE-LAP-VAR-REFERENCE (CAR FN-PAIR)) (COLLECT-CODE (CDR FN-PAIR) :ARGUMENT)) *LOCAL-FUNCTIONS*)) (SETQ INNER-CODE (COLLECT-CODE (LABELS-BODY NODE) CONTEXT)) (SETQ CLOSED-OVER (MAPCAR (FUNCTION VARIABLE-LAP-VAR) (LABELS-CLOSED-OVER-VARS NODE)))) (COND ((NULL CLOSED-OVER) (SETQ *CODE* (REVAPPEND INNER-CODE *CODE*))) (T (EMIT-LAP (IL:BQUOTE (:CLOSE (IL:\\\, CLOSED-OVER) (IL:\\\,@ INNER-CODE))))))))
+
+(DEFUN GENCODE-LAMBDA (NODE CONTEXT) (WHEN (EQ CONTEXT :EFFECT) (IL:* IL:\; "Lambda expressions cannot have any side-effects.") (RETURN-FROM GENCODE-LAMBDA)) (LET (NEW-LAMBDA OUR-NON-LOCALS CLOSED-OVER REQUIRED OPTIONAL REST KEY) (FRAME (:NAME (OR (LAMBDA-NAME NODE) (FORMAT NIL "lambda in ~A" *FRAME-NAME*)) :CURRENT-FRAME NODE) (INTERCEPT-NON-LOCALS (SETQ OUR-NON-LOCALS (DELETE-IF (FUNCTION (LAMBDA (VAR) (EQ (VARIABLE-BINDER VAR) NODE))) *NON-LOCALS*)) (IL:* IL:|;;| "Convert the parameters into LAP-code notation.") (SETQ REQUIRED (MAPCAR (FUNCTION (LAMBDA (VAR) (MAKE-LAP-VAR VAR T))) (LAMBDA-REQUIRED NODE))) (SETQ OPTIONAL (MAPCAR (FUNCTION (LAMBDA (OPT-VAR) (LET ((INIT-CODE (COLLECT-CODE (SECOND OPT-VAR) :ARGUMENT))) (IL:* IL:|;;| "Generating code for  the init form has to come before we create the varibles so that free references in the init form don't capture them.") (LIST (MAKE-LAP-VAR (FIRST OPT-VAR) T) INIT-CODE (MAKE-LAP-VAR (THIRD OPT-VAR) T))))) (LAMBDA-OPTIONAL NODE))) (SETQ REST (LET ((REST-VAR (LAMBDA-REST NODE))) (COND ((NULL REST-VAR) NIL) ((AND (EQ :LEXICAL (VARIABLE-SCOPE REST-VAR)) (NULL (VARIABLE-READ-REFS REST-VAR)) (NULL (VARIABLE-WRITE-REFS REST-VAR))) :IGNORED) (T (MAKE-LAP-VAR REST-VAR T))))) (SETQ KEY (MAPCAR (FUNCTION (LAMBDA (KEY-VAR) (LET ((INIT-CODE (COLLECT-CODE (THIRD KEY-VAR) :ARGUMENT))) (IL:* IL:|;;| "Generating code for  the init form has to come before we create the varibles so that free references in the init form don't capture them.") (LIST (FIRST KEY-VAR) (MAKE-LAP-VAR (SECOND KEY-VAR) T) INIT-CODE (MAKE-LAP-VAR (FOURTH KEY-VAR) T))))) (LAMBDA-KEYWORD NODE))) (IL:* IL:|;;| "Generate code for the body of the lambda.") (GENCODE (LAMBDA-BODY NODE) :RETURN)) (IL:* IL:|;;| "Convert the closed-over variable list into LAP vars.") (SETQ CLOSED-OVER (MAPCAR (FUNCTION VARIABLE-LAP-VAR) (LAMBDA-CLOSED-OVER-VARS NODE))) (IL:* IL:|;;| "Finally, construct the lambda-structure for the LAP-code.") (SETQ NEW-LAMBDA (IL:BQUOTE (:LAMBDA ((IL:\\\, REQUIRED) (IL:\\\,@ (AND OPTIONAL (IL:BQUOTE (:OPTIONAL (IL:\\\, OPTIONAL))))) (IL:\\\,@ (AND REST (IL:BQUOTE (:REST (IL:\\\, REST))))) (IL:\\\,@ (AND KEY (IL:BQUOTE (:KEY (IL:\\\, KEY))))) (IL:\\\,@ (AND (LAMBDA-ALLOW-OTHER-KEYS NODE) (QUOTE (:ALLOW-OTHER-KEYS T)))) (IL:\\\,@ (AND *OTHERS* (IL:BQUOTE (:OTHERS (IL:\\\, *OTHERS*))))) (IL:\\\,@ (AND *BLIP-VAR* (IL:BQUOTE (:BLIP (IL:\\\, *BLIP-VAR*))))) :NAME (IL:\\\, *FRAME-NAME*) (IL:\\\,@ (AND (LAMBDA-ARG-TYPE NODE) (IL:BQUOTE (:ARG-TYPE (IL:\\\, (LAMBDA-ARG-TYPE NODE)))))) (IL:\\\,@ (AND CLOSED-OVER (IL:BQUOTE (:CLOSED-OVER (IL:\\\, CLOSED-OVER))))) (IL:\\\,@ (AND OUR-NON-LOCALS (IL:BQUOTE (:NON-LOCAL (IL:\\\, (MAPCAR (FUNCTION VARIABLE-LAP-VAR) OUR-NON-LOCALS)))))) (IL:\\\,@ (AND *LOCAL-FUNCTIONS* (IL:BQUOTE (:LOCAL-FUNCTIONS (IL:\\\, *LOCAL-FUNCTIONS*)))))) (IL:\\\,@ (AND (LAMBDA-TAIL-CALL-TAG NODE) (IL:BQUOTE ((:TAG (IL:\\\, (LAMBDA-TAIL-CALL-TAG NODE))))))) (IL:\\\,@ (END-LAP)) (:RETURN))))) (IL:* IL:|;;| "Now that we're outside of the bindings of the specials above, we can pass on our results to the outside world.") (EMIT-LAP NEW-LAMBDA) (WHEN (EQ CONTEXT :MV) (IL:* IL:\; "In MV context, we need to make this a list.") (EMIT-LAP-LIST (QUOTE ((:CONST NIL) (:CALL CONS 2)))))))
+
+(DEFUN GENCODE-LET (FN ARGS CONTEXT) (IL:* IL:|;;;| "Compile the given function and arguments as a LET.") (IL:* IL:|;;| "Separate the arguments and matching parameters into two sets, according to whether or not the argument is NIL.  Also, since we're not allowed to BIND any closed-over variables, we have to store those arguments as we compute them to get them out of the way.") (LET ((*SPECIAL-VENV* *SPECIAL-VENV*) (SPECIAL-LOCALS-HERE NIL) (STK-NUM (INCF *STACK-NUMBER*)) NULL-PARAMS NON-NULL-PARAMS) (IL:FOR ARG IL:IN ARGS IL:AS PARAM IL:IN (LAMBDA-REQUIRED FN) IL:DO (WHEN (EQ :SPECIAL (VARIABLE-SCOPE PARAM)) (SETQ SPECIAL-LOCALS-HERE T)) (COND (IL:* IL:|;;| "This parameter is set to NIL.") ((AND (LITERAL-P ARG) (EQ NIL (LITERAL-VALUE ARG))) (IF (EQ :LEXICAL (VARIABLE-SCOPE PARAM)) (EMIT-LAP-LIST (IL:BQUOTE ((:CONST NIL) (:VAR_ (IL:\\\, (MAKE-LAP-VAR PARAM))) (:POP)))) (PUSH PARAM NULL-PARAMS))) (IL:* IL:|;;| "This parameter is bound to the result of a non-null expression") (T (GENCODE ARG :ARGUMENT) (IF (EQ :LEXICAL (VARIABLE-SCOPE PARAM)) (EMIT-LAP-LIST (IL:BQUOTE ((:VAR_ (IL:\\\, (MAKE-LAP-VAR PARAM))) (:POP)))) (PUSH PARAM NON-NULL-PARAMS))))) (SETQ NULL-PARAMS (MAPCAR (FUNCTION MAKE-LAP-VAR) NULL-PARAMS)) (SETQ NON-NULL-PARAMS (NREVERSE (MAPCAR (FUNCTION MAKE-LAP-VAR) NON-NULL-PARAMS))) (IL:* IL:|;;| "Bind the variables and evaluate the body") (WHEN (OR NULL-PARAMS NON-NULL-PARAMS) (EMIT-LAP (IL:BQUOTE (:BIND (IL:\\\, NON-NULL-PARAMS) (IL:\\\, NULL-PARAMS) (IL:\\\, STK-NUM))))) (INTERCEPT-NON-LOCALS (DELETE-IF (FUNCTION (LAMBDA (VAR) (EQ (VARIABLE-BINDER VAR) FN))) *NON-LOCALS*) (IL:* IL:|;;| "!!HACK!! Fix this silliness once the compiler can use lexical closures.") (LET* ((*SPECIAL-LOCALS-BOUND* (OR *SPECIAL-LOCALS-BOUND* SPECIAL-LOCALS-HERE))) (IL:* IL:|;;| "If we've done a BIND, then we need to make it possible for the tail-recursion optimization to generate a DUNBIND.  Otherwise, things are simpler.") (IF (OR NULL-PARAMS NON-NULL-PARAMS) (LET* ((UNBIND-INST (IL:BQUOTE (:DUNBIND (IL:\\\, NON-NULL-PARAMS) (IL:\\\, NULL-PARAMS) (IL:\\\, STK-NUM)))) (UNBIND-FN (IL:BQUOTE (LAMBDA (CONDITION) (DECLARE (IGNORE CONDITION)) (EMIT-LAP (QUOTE (IL:\\\, UNBIND-INST))))))) (CONDITION-BIND ((UNBIND-FOR-TAIL-RECURSION UNBIND-FN)) (GENCODE (LAMBDA-BODY FN) CONTEXT))) (GENCODE (LAMBDA-BODY FN) CONTEXT)))) (IL:* IL:|;;| "Again, we only need to UNBIND if we generated a BIND earlier.") (WHEN (OR NULL-PARAMS NON-NULL-PARAMS) (ECASE CONTEXT ((:EFFECT) (WHEN (NOT *SUPPRESS-POPS*) (EMIT-LAP (IL:BQUOTE (:DUNBIND (IL:\\\, NON-NULL-PARAMS) (IL:\\\, NULL-PARAMS) (IL:\\\, STK-NUM)))))) ((:ARGUMENT :MV) (EMIT-LAP (IL:BQUOTE (:UNBIND (IL:\\\, NON-NULL-PARAMS) (IL:\\\, NULL-PARAMS) (IL:\\\, STK-NUM))))) ((:RETURN)))) (IL:* IL:|;;| "Finally, we know that these variables aren't in use any more, so we can put their names on *AVAILABLE-LEXICAL-NAMES*.") (IL:|for| PARAM IL:|in| (LAMBDA-REQUIRED FN) IL:|when| (AND (EQ :LEXICAL (VARIABLE-SCOPE PARAM)) (NOT (VARIABLE-CLOSED-OVER PARAM))) IL:|do| (PUSH (THIRD (VARIABLE-LAP-VAR PARAM)) *AVAILABLE-LEXICAL-NAMES*))))
+
+(DEFUN GENCODE-LITERAL (NODE CONTEXT) (ECASE CONTEXT (:EFFECT (IL:* IL:\; "Do nothing.")) ((:ARGUMENT :RETURN) (EMIT-LAP (IL:BQUOTE (:CONST (IL:\\\, (LITERAL-VALUE NODE)))))) (:MV (IL:* IL:\; "In MV context, we need to make this a list.  Because MV-CALL uses NCONC to put the lists together, we have to CONS a fresh cell here.") (EMIT-LAP-LIST (IL:BQUOTE ((:CONST (IL:\\\, (LITERAL-VALUE NODE))) (:CONST NIL) (:CALL CONS 2)))))))
+
+(DEFUN GENCODE-MV-CALL (NODE CONTEXT) (LET ((FN (MV-CALL-FN NODE)) (ARGS (MV-CALL-ARG-EXPRS NODE))) (FLET ((GENERATE-VALUES NIL (IL:* IL:|;;| "Generate the code for putting the list of values on the top-of-stack.") (GENCODE (FIRST ARGS) :MV) (IL:|for| ARG IL:|in| (REST ARGS) IL:|do| (GENCODE ARG :MV) (EMIT-LAP (QUOTE (:CALL IL:\\NCONC2 2)))))) (COND ((AND (GLOBAL-FUNCTION-P FN) (EQ (VARIABLE-NAME (VAR-REF-VARIABLE FN)) (QUOTE LIST))) (IL:* IL:\; "This is a use of MULTIPLE-VALUE-LIST, the only use of multiple-values that XCL can do reasonably well.") (IL:* IL:|;;| "we can do better here - if we're in effect context, there's no reason to do all this consing and we should just treat this as a PROGN.") (GENERATE-VALUES)) (T (IF (GLOBAL-FUNCTION-P FN) (EMIT-LAP (IL:BQUOTE (:CONST (IL:\\\, (VARIABLE-NAME (VAR-REF-VARIABLE FN)))))) (GENCODE FN :ARGUMENT)) (GENERATE-VALUES) (EMIT-LAP (QUOTE (:CALL APPLY 2))))) (CASE CONTEXT (:EFFECT (WHEN (NOT *SUPPRESS-POPS*) (EMIT-LAP (QUOTE (:POP))))) (:MV (EMIT-LAP (QUOTE (:CALL IL:\\MVLIST 1))))))))
+
+(DEFUN GENCODE-MV-PROG1 (NODE CONTEXT) (ECASE CONTEXT ((:MV :RETURN) (IL:* IL:\; "All other contexts should have been meta-eval'ed away.") (DESTRUCTURING-BIND (VALUES-FORM . EFFECT-FORMS) (MV-PROG1-STMTS NODE) (IL:* IL:|;;| "Save the values from the first statement on the stack while we evaluate the rest of the values.") (GENCODE VALUES-FORM :MV) (IL:|for| FORM IL:|in| EFFECT-FORMS IL:|do| (GENCODE FORM :EFFECT)) (WHEN (EQ CONTEXT :RETURN) (EMIT-LAP (QUOTE (:CALL VALUES-LIST 1))))))))
+
+(DEFUN GENCODE-OPCODES (NODE CONTEXT) (DECLARE (IGNORE NODE CONTEXT)) (ASSERT NIL NIL "BUG: GENCODE-OPCODES was called!"))
+
+(DEFUN GENCODE-PROGN (NODE CONTEXT) (LET ((*SUPPRESS-POPS* (AND *POP-SUPPRESSION-POLICY* (EQ CONTEXT :RETURN)))) (IL:|for| TAIL IL:|on| (PROGN-STMTS NODE) IL:|do| (GENCODE (CAR TAIL) (IF (NULL (CDR TAIL)) CONTEXT :EFFECT)))))
+
+(DEFUN GENCODE-PROGV (&REST IGNORE) (ASSERT NIL NIL "BUG: GENCODE-PROGV was called."))
+
+(DEFUN GENCODE-RETURN (NODE CONTEXT) (LET ((BLOCK (RETURN-BLOCK NODE))) (COND ((EQ *CURRENT-FRAME* (BLOCK-FRAME BLOCK)) (IL:* IL:|;;| "The block is local; a simple stack adjustment and jump will suffice.") (GENCODE (RETURN-VALUE NODE) (BLOCK-CONTEXT BLOCK)) (COND ((BLOCK-NEW-FRAME-P BLOCK) (IL:* IL:|;;| "This RETURN is returning from the frame itself, rather than from a block internal to a frame.  Don't need the stack adjustment.") (IL:* IL:|;;| "JDS 1/26/89 I think this is correct.") (ECASE (BLOCK-CONTEXT BLOCK) ((:EFFECT) (EMIT-LAP-LIST (IL:BQUOTE ((:JUMP (IL:\\\, (BLOCK-END-TAG BLOCK))))))) ((:ARGUMENT :MV) (EMIT-LAP-LIST (IL:BQUOTE ((:JUMP (IL:\\\, (BLOCK-END-TAG BLOCK))))))) ((:RETURN) (EMIT-LAP (QUOTE (:RETURN)))))) (T (ECASE (BLOCK-CONTEXT BLOCK) ((:EFFECT) (EMIT-LAP-LIST (IL:BQUOTE ((:DSET-STACK (IL:\\\, (BLOCK-STK-NUM BLOCK))) (:JUMP (IL:\\\, (BLOCK-END-TAG BLOCK))))))) ((:ARGUMENT :MV) (EMIT-LAP-LIST (IL:BQUOTE ((:SET-STACK (IL:\\\, (BLOCK-STK-NUM BLOCK))) (:JUMP (IL:\\\, (BLOCK-END-TAG BLOCK))))))) ((:RETURN) (EMIT-LAP (QUOTE (:RETURN)))))))) (T (IL:* IL:|;;| "The block is remote; call on the unwinder.") (EMIT-LAP (IL:BQUOTE (:VAR (IL:\\\, (VARIABLE-LAP-VAR (BLOCK-BLIP-VAR BLOCK)))))) (ECASE (BLOCK-CONTEXT BLOCK) (:EFFECT (GENCODE (RETURN-VALUE NODE) :EFFECT) (EMIT-LAP (QUOTE (:CALL SI::NON-LOCAL-RETURN 1)))) ((:MV :ARGUMENT) (GENCODE (RETURN-VALUE NODE) (BLOCK-CONTEXT BLOCK)) (EMIT-LAP (QUOTE (:CALL SI::NON-LOCAL-RETURN 2)))) (:RETURN (GENCODE (RETURN-VALUE NODE) :MV) (EMIT-LAP (QUOTE (:CALL SI::NON-LOCAL-RETURN-VALUES 2))))) (EMIT-LAP (IL:BQUOTE (:RETURN))) (IL:* IL:\; "This :RETURN will never be reached, but it makes stack analysis happier.") (PUSH (BLOCK-BLIP-VAR BLOCK) *NON-LOCALS*)))))
+
+(DEFUN GENCODE-SEGMENT (SEGMENT) (LET ((*SUPPRESS-POPS* NIL)) (EMIT-LAP (IL:BQUOTE (:TAG (IL:\\\, (SEGMENT-LOCAL-TAG SEGMENT))))) (DOLIST (STMT (SEGMENT-STMTS SEGMENT)) (GENCODE STMT :EFFECT))))
+
+(DEFUN GENCODE-SETQ (NODE CONTEXT) (ASSERT (NOT (EQ (VARIABLE-KIND (SETQ-VAR NODE)) :FUNCTION)) (QUOTE (NODE)) "BUG: Attempt to set a function variable.") (GENCODE (SETQ-VALUE NODE) :ARGUMENT) (EMIT-LAP (IL:BQUOTE (:VAR_ (IL:\\\, (MAKE-LAP-VAR-REFERENCE (SETQ-VAR NODE)))))) (CASE CONTEXT (:EFFECT (WHEN (NOT *SUPPRESS-POPS*) (EMIT-LAP (QUOTE (:POP))))) (:MV (IL:* IL:\; "In MV context, we have to return a list of values.") (EMIT-LAP-LIST (QUOTE ((:CONST NIL) (:CALL CONS 2)))))))
+
+(DEFUN GENCODE-TAGBODY (NODE CONTEXT) (IL:* IL:|;;;| "Very much like the BLOCK case.  Sometimes we need to make a function call but usually we can avoid it to some degree.") (COND ((TAGBODY-NEW-FRAME-P NODE) (IL:* IL:\; "Construct a new lambda for the tagbody") (LET (NEW-LAMBDA) (FRAME (:CURRENT-FRAME NODE :NAME (FORMAT NIL "tagbody in ~A" *FRAME-NAME*)) (LET ((STK-NUM (INCF *STACK-NUMBER*)) BLIP-GO-VAR OUR-NON-LOCALS) (SETF (TAGBODY-FRAME NODE) *CURRENT-FRAME*) (SETF (TAGBODY-STK-NUM NODE) STK-NUM) (COND ((TAGBODY-CLOSED-OVER-P NODE) (SETQ *BLIP-VAR* (IL:BQUOTE (:S SI::*CATCH-RETURN-FROM* (IL:\\\, (INCF *VAR-NUMBER*))))) (SETQ BLIP-GO-VAR (MAKE-LAP-VAR (TAGBODY-BLIP-VAR NODE))) (EMIT-LAP-LIST (IL:BQUOTE ((:CONST (IL:\\\, *FRAME-NAME*)) (:CONST NIL) (:CALL CONS 2) (:VAR_ (IL:\\\, *BLIP-VAR*)) (:VAR_ (IL:\\\, BLIP-GO-VAR)) (:POP)))) (SETQ *OTHERS* (LIST BLIP-GO-VAR *BLIP-VAR*))) (T (SETQ *BLIP-VAR* (IL:BQUOTE (:S SI::*CATCH-RETURN-TO* (IL:\\\, (INCF *VAR-NUMBER*))))) (SETQ *OTHERS* (LIST *BLIP-VAR*)))) (EMIT-LAP (IL:BQUOTE (:NOTE-STACK (IL:\\\, STK-NUM)))) (IL:|for| SEGMENT IL:|in| (TAGBODY-SEGMENTS NODE) IL:|do| (SETF (SEGMENT-LOCAL-TAG SEGMENT) (INCF *TAG-NUMBER*)) (WHEN (SEGMENT-CLOSED-OVER-P SEGMENT) (SETF (SEGMENT-REMOTE-TAG SEGMENT) (INCF *TAG-NUMBER*)))) (INTERCEPT-NON-LOCALS (SETQ OUR-NON-LOCALS (DELETE (TAGBODY-BLIP-VAR NODE) *NON-LOCALS*)) (IL:|for| SEGMENT IL:|in| (TAGBODY-SEGMENTS NODE) IL:|do| (GENCODE-SEGMENT SEGMENT))) (IF (EQ CONTEXT :MV) (IL:* IL:\; "In MV context, we have to return a list of values.  We have to CONS it freshly since MV-CALL uses NCONC to put the lists together.") (EMIT-LAP-LIST (QUOTE ((:CONST NIL) (:CONST NIL) (:CALL CONS 2) (:RETURN)))) (EMIT-LAP-LIST (QUOTE ((:CONST NIL) (:RETURN))))) (WHEN (TAGBODY-CLOSED-OVER-P NODE) (IL:|for| SEGMENT IL:|in| (TAGBODY-SEGMENTS NODE) IL:|when| (SEGMENT-CLOSED-OVER-P SEGMENT) IL:|do| (EMIT-LAP-LIST (IL:BQUOTE ((:TAG (IL:\\\, (SEGMENT-REMOTE-TAG SEGMENT))) (:DSET-STACK (IL:\\\, STK-NUM)) (:JUMP (IL:\\\, (SEGMENT-LOCAL-TAG SEGMENT)))))))) (SETQ NEW-LAMBDA (IL:BQUOTE (:LAMBDA (NIL :NAME (IL:\\\, *FRAME-NAME*) (IL:\\\,@ (AND *OTHERS* (IL:BQUOTE (:OTHERS (IL:\\\, *OTHERS*))))) :BLIP (IL:\\\, *BLIP-VAR*) (IL:\\\,@ (AND OUR-NON-LOCALS (IL:BQUOTE (:NON-LOCAL (IL:\\\, (MAPCAR (FUNCTION VARIABLE-LAP-VAR) OUR-NON-LOCALS)))))) (IL:\\\,@ (AND (TAGBODY-CLOSED-OVER-VARS NODE) (IL:BQUOTE (:CLOSED-OVER (IL:\\\, (MAPCAR (FUNCTION VARIABLE-LAP-VAR) (TAGBODY-CLOSED-OVER-VARS NODE))))))) (IL:\\\,@ (AND *LOCAL-FUNCTIONS* (IL:BQUOTE (:LOCAL-FUNCTIONS (IL:\\\, *LOCAL-FUNCTIONS*)))))) (IL:\\\,@ (END-LAP))))))) (IL:* IL:|;;| "Generate a call to the new lambda.") (EMIT-LAP (IL:BQUOTE (:CALL (IL:\\\, NEW-LAMBDA) 0))) (WHEN (AND (EQ CONTEXT :EFFECT) (NOT *SUPPRESS-POPS*)) (EMIT-LAP (QUOTE (:POP)))))) (T (IF (NULL (TAGBODY-CLOSED-OVER-VARS NODE)) (GENCODE-TAGBODY-INLINE NODE CONTEXT) (LET ((CODE (LET ((*CODE* (START-LAP))) (GENCODE-TAGBODY-INLINE NODE CONTEXT) (END-LAP)))) (EMIT-LAP (IL:BQUOTE (:CLOSE (IL:\\\, (MAPCAR (FUNCTION VARIABLE-LAP-VAR) (TAGBODY-CLOSED-OVER-VARS NODE))) (IL:\\\,@ CODE)))))))))
+
+(DEFUN GENCODE-TAGBODY-INLINE (NODE CONTEXT) (IL:* IL:|;;| "We don't need a separate frame, so generate the code inline, setting up and taking down the blip stuff if necessary.") (LET ((STK-NUM (INCF *STACK-NUMBER*))) (SETF (TAGBODY-FRAME NODE) *CURRENT-FRAME*) (SETF (TAGBODY-STK-NUM NODE) STK-NUM) (COND ((TAGBODY-CLOSED-OVER-P NODE) (LET ((BLIP-VAR (MAKE-LAP-VAR (TAGBODY-BLIP-VAR NODE))) (END-TAG (INCF *TAG-NUMBER*))) (SET-UP-RETURN-TO) (EMIT-LAP-LIST (IL:BQUOTE ((:CONST TAGBODY) (:CONST (IL:\\\, *FRAME-NAME*)) (:CALL CONS 2) (:VAR_ (IL:\\\, *BLIP-VAR*)) (:VAR_ (IL:\\\, BLIP-VAR)) (:POP) (:NOTE-STACK (IL:\\\, STK-NUM))))) (IL:|for| SEGMENT IL:|in| (TAGBODY-SEGMENTS NODE) IL:|do| (SETF (SEGMENT-LOCAL-TAG SEGMENT) (INCF *TAG-NUMBER*)) (WHEN (SEGMENT-CLOSED-OVER-P SEGMENT) (SETF (SEGMENT-REMOTE-TAG SEGMENT) (INCF *TAG-NUMBER*)))) (INTERCEPT-NON-LOCALS (DELETE (TAGBODY-BLIP-VAR NODE) *NON-LOCALS*) (IL:|for| SEGMENT IL:|in| (TAGBODY-SEGMENTS NODE) IL:|do| (GENCODE-SEGMENT SEGMENT))) (TAKE-DOWN-RETURN-TO) (EMIT-LAP (IL:BQUOTE (:JUMP (IL:\\\, END-TAG)))) (IL:|for| SEGMENT IL:|in| (TAGBODY-SEGMENTS NODE) IL:|when| (SEGMENT-CLOSED-OVER-P SEGMENT) IL:|do| (EMIT-LAP-LIST (IL:BQUOTE ((:TAG (IL:\\\, (SEGMENT-REMOTE-TAG SEGMENT))) (:DSET-STACK (IL:\\\, STK-NUM)) (:JUMP (IL:\\\, (SEGMENT-LOCAL-TAG SEGMENT))))))) (EMIT-LAP (IL:BQUOTE (:TAG (IL:\\\, END-TAG)))))) (T (IL:* IL:\; "Simplest case: the tagbody isn't even closed over.") (EMIT-LAP (IL:BQUOTE (:NOTE-STACK (IL:\\\, STK-NUM)))) (IL:|for| SEGMENT IL:|in| (TAGBODY-SEGMENTS NODE) IL:|do| (SETF (SEGMENT-LOCAL-TAG SEGMENT) (INCF *TAG-NUMBER*))) (IL:|for| SEGMENT IL:|in| (TAGBODY-SEGMENTS NODE) IL:|do| (GENCODE-SEGMENT SEGMENT)))) (IL:* IL:|;;| "Arrange to return NIL from the TAGBODY.") (ECASE CONTEXT (:EFFECT (IL:* IL:\; "Do nothing")) ((:ARGUMENT :RETURN) (EMIT-LAP (QUOTE (:CONST NIL)))) (:MV (IL:* IL:\; "In MV context, we have to return a freshly-CONSed list of values.") (EMIT-LAP-LIST (QUOTE ((:CONST NIL) (:CONST NIL) (:CALL CONS 2))))))))
+
+(DEFUN GENCODE-THROW (NODE CONTEXT) (GENCODE (THROW-TAG NODE) :ARGUMENT) (CASE CONTEXT ((:ARGUMENT :RETURN) (GENCODE (THROW-VALUE NODE) CONTEXT) (EMIT-LAP-LIST (QUOTE ((:CALL SI::INTERNAL-THROW 2) (:RETURN))))) (OTHERWISE (GENCODE (THROW-VALUE NODE) :MV) (EMIT-LAP-LIST (QUOTE ((:CALL SI::INTERNAL-THROW-VALUES 2) (:RETURN)))) (IL:* IL:\; "The :RETURN will never be reached, but it makes stack-analysis happier."))))
+
+(DEFUN GENCODE-UNWIND-PROTECT (NODE CONTEXT) (IL:* IL:|;;;| "Funcall the body on the argument of the cleanup forms as a closure.") (GENCODE (UNWIND-PROTECT-CLEANUP NODE) :ARGUMENT) (LET ((STMT-CODE (COLLECT-CODE (UNWIND-PROTECT-STMT NODE) :ARGUMENT))) (EMIT-LAP (IL:BQUOTE (:CALL (IL:\\\, (POP STMT-CODE)) 1))) (ASSERT (NULL STMT-CODE) NIL "BUG: unwind-protect body code generated more than one LAP instruction")) (CASE CONTEXT (:EFFECT (WHEN (NOT *SUPPRESS-POPS*) (EMIT-LAP (QUOTE (:POP))))) (:MV (EMIT-LAP (QUOTE (:CALL IL:\\MVLIST 1))))))
+
+(DEFUN GENCODE-VAR-REF (NODE CONTEXT) (LET ((VAR (VAR-REF-VARIABLE NODE))) (UNLESS (EQ CONTEXT :EFFECT) (IF (AND (EQ :GLOBAL (VARIABLE-SCOPE VAR)) (EQ :FUNCTION (VARIABLE-KIND VAR))) (EMIT-LAP-LIST (IL:BQUOTE ((:CONST (IL:\\\, (VARIABLE-NAME VAR))) (:CALL SYMBOL-FUNCTION 1)))) (EMIT-LAP (IL:BQUOTE (:VAR (IL:\\\, (MAKE-LAP-VAR-REFERENCE VAR)))))) (WHEN (EQ CONTEXT :MV) (IL:* IL:\; "In MV context, we have to return a list of the values.") (EMIT-LAP-LIST (QUOTE ((:CONST NIL) (:CALL CONS 2))))))))
+
+
+
+(IL:* IL:|;;| "Policy variables.")
+
+
+(DEFPARAMETER *POP-SUPPRESSION-POLICY* NIL "If this is non-NIL, the code generator will suppress unnecessary pops.  This can increase stack usage.")
+
+(DEFVAR *TAIL-RECURSION-POLICY* T "Set this to NIL to disable the tail-recursion optimization.")
+
+
+
+(IL:* IL:|;;| "Testing Code Generation")
+
+
+(DEFUN TEST-GENCODE (FN) (PPRINT (TEST-GENCODE1 FN)) (FRESH-LINE) (VALUES))
+
+(DEFUN TEST-GENCODE1 (FN) (DESTRUCTURING-BIND (IGNORE NAME ARG-LIST &BODY BODY) (IL:GETDEF FN (QUOTE IL:FUNCTIONS)) (MULTIPLE-VALUE-BIND (FORMS DECLS) (PARSE-BODY BODY NIL T) (LET ((*ENVIRONMENT* (MAKE-CHILD-ENV T)) (*PROCESSED-FUNCTIONS* NIL) (*UNKNOWN-FUNCTIONS* NIL) (*CONSTANTS-HASH-TABLE* (MAKE-HASH-TABLE))) (COMPILE-ONE-LAMBDA FN (IL:BQUOTE (LAMBDA (IL:\\\, ARG-LIST) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\,@ FORMS)))))))))
+
+
+
+(IL:* IL:|;;| "Arrange to use the correct compiler.")
+
+
+(IL:PUTPROPS IL:XCLC-GENCODE IL:FILETYPE COMPILE-FILE)
+
+
+
+(IL:* IL:|;;| "Arrange to use the proper makefile environment")
+
+
+(IL:PUTPROPS IL:XCLC-GENCODE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL"))))
+(IL:PUTPROPS IL:XCLC-GENCODE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/XCLC-GENCODE.LCOM b/CLTL2/XCLC-GENCODE.LCOM
new file mode 100644
index 00000000..a68f1e04
Binary files /dev/null and b/CLTL2/XCLC-GENCODE.LCOM differ
diff --git a/CLTL2/XCLC-META-EVAL b/CLTL2/XCLC-META-EVAL
new file mode 100644
index 00000000..1ded026c
--- /dev/null
+++ b/CLTL2/XCLC-META-EVAL
@@ -0,0 +1,1476 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL")))
+(IL:FILECREATED "13-Oct-93 17:18:24" "{Pele:mv:envos}<LispCore>Sources>CLTL2>XCLC-META-EVAL.;1" 67835  
+
+      IL:|changes| IL:|to:|  (IL:FUNCTIONS META-EVAL-LABELS)
+
+      IL:|previous| IL:|date:| " 4-Feb-92 10:29:37" 
+IL:|{DSK}<mo>usr>users>sybalsky>cltl2>sources>XCLC-META-EVAL.;1|)
+
+
+; Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:XCLC-META-EVALCOMS)
+
+(IL:RPAQQ IL:XCLC-META-EVALCOMS
+          (
+
+(IL:* IL:|;;;| "Meta-evaluation")
+
+           (IL:FUNCTIONS META-EVALUATE)
+           (IL:FUNCTIONS MEVAL MEVAL-LIST REDO-MEVAL)
+           (IL:FUNCTIONS REMOVE-NESTED-PROGNS EXPAND-NESTED-PROGNS)
+           (IL:FUNCTIONS GLOBAL-FUNCTION-P)
+           (IL:FUNCTIONS CONSTRUCT-PROG1-TREE)
+           (IL:VARIABLES *MADE-CHANGES* *REDOING-ANALYSIS*)
+           (IL:FUNCTIONS META-EVAL-BLOCK META-EVAL-CALL META-EVAL-CATCH META-EVAL-GO META-EVAL-IF 
+                  META-EVAL-LABELS META-EVAL-LAMBDA META-EVAL-LITERAL META-EVAL-MV-CALL 
+                  META-EVAL-MV-PROG1 META-EVAL-OPCODES META-EVAL-PROGN META-EVAL-PROGV 
+                  META-EVAL-RETURN META-EVAL-SETQ META-EVAL-TAGBODY META-EVAL-THROW 
+                  META-EVAL-UNWIND-PROTECT META-EVAL-VAR-REF)
+           (IL:FUNCTIONS META-CALL-LAMBDA META-CALL-LAMBDA-SIMPLIFY-PARAMETERS CONSTRUCT-LIST)
+           
+
+(IL:* IL:|;;;| "Meta-substitution")
+
+           (IL:FUNCTIONS META-CALL-LAMBDA-SUBSTITUTE META-CALL-LABELS META-SUBSTITUTE META-SUBST)
+           (IL:FUNCTIONS MSUBST MSUBST-LIST)
+           (IL:FUNCTIONS SUBSTITUTABLE-P)
+           (IL:FUNCTIONS EFFECTLESS EFFECTLESS-EXCEPT-CONS NULL-INTERSECTION 
+                  NULL-EFFECTS-INTERSECTION NULL-EFFECTS-INTERSECTION-EXCEPT-CONS PASSABLE 
+                  NONLOCAL-VARIABLE-EFFECT-P COLLECT-NONLOCAL-VAR-EFFECTS)
+           (IL:VARIABLES *SUBST-VAR* *SUBST-EXPR* *SUBST-OCCURRED*)
+           (IL:FUNCTIONS META-SUBST-BLOCK META-SUBST-CALL META-SUBST-CATCH META-SUBST-GO 
+                  META-SUBST-IF META-SUBST-LABELS META-SUBST-LAMBDA META-SUBST-LITERAL 
+                  META-SUBST-MV-CALL META-SUBST-MV-PROG1 META-SUBST-OPCODES META-SUBST-PROGN 
+                  META-SUBST-PROGV META-SUBST-RETURN META-SUBST-SETQ META-SUBST-TAGBODY 
+                  META-SUBST-THROW META-SUBST-UNWIND-PROTECT META-SUBST-VAR-REF)
+           (IL:FUNCTIONS META-SUBST-ANY-CALL META-SUBST-STMTS)
+           
+           (IL:* IL:|;;| "Testing meta-evaluation")
+
+           (IL:FUNCTIONS TEST-META-EVAL)
+           
+           (IL:* IL:|;;| "Arrange to use the correct compiler")
+
+           (IL:PROP IL:FILETYPE IL:XCLC-META-EVAL)
+           
+           (IL:* IL:|;;| "Arrange for the proper makefile-environment")
+
+           (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-META-EVAL)))
+
+
+
+(IL:* IL:|;;;| "Meta-evaluation")
+
+
+(DEFUN META-EVALUATE (TREE &OPTIONAL (CONTEXT :ARGUMENT))
+
+(IL:* IL:|;;;| "Each meta-evaluation method takes in a subtree and mungs on it for a while, returning a (possibly identical) subtree.  If the method makes no changes or can otherwise guarantee that no further meta-evaluation will be useful, it should set the meta-p field to the current context.  This field must never be set if any node lower in the tree does not have it set.  You can count on the fact that no node gets returned by meta-evaluate unless it has that field set.")
+
+(IL:* IL:|;;;| "The CONTEXT argument has one of the following values:")
+
+(IL:* IL:|;;;| ":effect  --  No values of this expression are used.")
+
+(IL:* IL:|;;;| ":argument  --  Exactly one of the values of this expression is used.")
+
+(IL:* IL:|;;;| ":mv  --  More than one of the values of this expression may be used.")
+
+(IL:* IL:|;;;| ":return  --  The value(s) of this expression will be returned to the caller of the current function.")
+
+   (WHEN *REDOING-ANALYSIS*
+       (SETF (NODE-META-P TREE)
+             NIL))
+   (IL:|until| (EQ CONTEXT (NODE-META-P TREE)) IL:|do| (SETQ TREE (NODE-DISPATCH META-EVAL 
+                                                                                 TREE CONTEXT)))
+   TREE)
+
+(DEFINE-MODIFY-MACRO MEVAL (CONTEXT) META-EVALUATE)
+
+(DEFMACRO MEVAL-LIST (LIST-EXPR CONTEXT &OPTIONAL KEY-FN)
+   `(IL:FOR TAIL IL:ON ,LIST-EXPR IL:DO (MEVAL ,(IF KEY-FN
+                                                                    `(,KEY-FN (CAR TAIL))
+                                                                    '(CAR TAIL))
+                                                           ,CONTEXT)))
+
+(DEFMACRO REDO-MEVAL (NODE-EXPR CONTEXT)
+   `(LET ((*REDOING-ANALYSIS* T))
+         (MEVAL ,NODE-EXPR ,CONTEXT)))
+
+(DEFINE-MODIFY-MACRO REMOVE-NESTED-PROGNS () EXPAND-NESTED-PROGNS
+
+(IL:* IL:|;;;| "Replace the list of nodes in a given place with another list that has had its nested progns spliced inline.  It is assumed that the nested PROGN nodes will not be referred to afterwards; this operation uses NCONC to splice the lists together.")
+
+   )
+
+(DEFUN EXPAND-NESTED-PROGNS (NODE-LIST)
+   (IL:|for| NODE IL:|in| NODE-LIST IL:|join| (IF (PROGN-P NODE)
+                                                              (PROGN-STMTS NODE)
+                                                              (LIST NODE))))
+
+(DEFINLINE GLOBAL-FUNCTION-P (NODE)
+   (AND (VAR-REF-P NODE)
+        (LET ((VAR (VAR-REF-VARIABLE NODE)))
+             (AND (EQ :GLOBAL (VARIABLE-SCOPE VAR))
+                  (EQ :FUNCTION (VARIABLE-KIND VAR))))))
+
+(DEFUN CONSTRUCT-PROG1-TREE (FIRST REST)
+
+(IL:* IL:|;;;| 
+"Return a tree that represents a PROG1 in which FIRST's values are the ones that are wanted:")
+
+(IL:* IL:|;;;| "         ((lambda (x) ,@REST x) FIRST)")
+
+   (LET* ((PROG1-VAR (MAKE-VARIABLE))
+          (PROG1-VAR-REF (MAKE-VAR-REF :VARIABLE PROG1-VAR))
+          (NEW-LAMBDA (MAKE-LAMBDA :REQUIRED (LIST PROG1-VAR)
+                             :BODY
+                             (MAKE-PROGN :STMTS (APPEND REST (LIST PROG1-VAR-REF))))))
+         (SETF (VARIABLE-BINDER PROG1-VAR)
+               NEW-LAMBDA)
+         (PUSH PROG1-VAR-REF (VARIABLE-READ-REFS PROG1-VAR))
+         (MAKE-CALL :FN NEW-LAMBDA :ARGS (LIST FIRST))))
+
+(DEFVAR *MADE-CHANGES* NIL
+
+(IL:* IL:|;;;| "This variable is rebound in a few places in meta-evaluation in order to keep track of whether or not a large collection of routines has had any effect on the program tree.")
+
+   )
+
+(DEFVAR *REDOING-ANALYSIS* NIL
+
+(IL:* IL:|;;;| "Bound to T when meta-evaluation is being redone.  This forces the analysis to descend all the way back down to the bottom again.")
+
+   )
+
+(DEFUN META-EVAL-BLOCK (NODE CONTEXT)
+   (SETF (BLOCK-CONTEXT NODE)
+         CONTEXT)
+   (MEVAL (BLOCK-STMT NODE)
+          CONTEXT)
+   (ANALYZE-TREE NODE)
+   (SETF (NODE-META-P NODE)
+         CONTEXT)
+   NODE)
+
+(DEFUN META-EVAL-CALL (NODE CONTEXT)
+
+   (IL:* IL:|;;| "First, meta-eval the subtrees.")
+
+   (MEVAL (CALL-FN NODE)
+          :ARGUMENT)
+   (MEVAL-LIST (CALL-ARGS NODE)
+          :ARGUMENT)
+   (ANALYZE-TREE NODE)
+   (LET
+    ((FN (CALL-FN NODE))
+     TRANSFORM ARGS EVAL-WHEN-LOAD? LIST-OF-VALUES)
+    (COND
+
+       (IL:* IL:|;;| "Then, if it's a lambda-call, try hacking on it.")
+
+       ((LAMBDA-P FN)
+
+        (IL:* IL:|;;| "But first, re-meta-evaluate the lambda-body since we now know the context in which it will be evaluated.")
+
+        (UNLESS (EQ CONTEXT :RETURN)
+            (MEVAL (LAMBDA-BODY FN)
+                   CONTEXT)
+            (ANALYZE-TREE FN))
+        (SETQ NODE (META-CALL-LAMBDA NODE CONTEXT)))
+
+       (IL:* IL:|;;| 
+     "If it's a call to a side-effect-less function in effect context, blow it away.")
+
+       (IL:* IL:|;;| "Fix this to find local function side-effects.")
+
+       ((AND (EQ CONTEXT :EFFECT)
+             (NOT (CALLER-NOT-INLINE NODE))
+             (GLOBAL-FUNCTION-P FN)
+             (LET ((EFFECTS (CAR (SIDE-EFFECTS (VARIABLE-NAME (VAR-REF-VARIABLE FN))))))
+                  (OR (EQ EFFECTS :NONE)
+                      (EQUAL EFFECTS '(:CONS)))))
+        (SETQ NODE (PROG1 (MAKE-PROGN :STMTS (CALL-ARGS NODE))
+                       (SETF (CALL-ARGS NODE)
+                             NIL)                            (IL:* IL:\; 
+                                                "Detach the args, since they're still in the tree.")
+                       (RELEASE-TREE NODE))))
+
+       (IL:* IL:|;;| "If it's a constant-foldable function and the arguments are all literals, fold it.  We must be careful because some of the literals might be EVAL-WHEN-LOAD objects.  In that case, we bring the entire call inside a new EVAL-WHEN-LOAD.  This accomplishes, in effect, load-time constant-folding.")
+
+       ((AND (NOT (CALLER-NOT-INLINE NODE))
+             (GLOBAL-FUNCTION-P FN)
+             (EQUAL '(:NONE . :NONE)
+                    (SIDE-EFFECTS (VARIABLE-NAME (VAR-REF-VARIABLE FN))))
+             (LISTP (SETQ ARGS (IL:|for| ARG IL:|in| (CALL-ARGS NODE)
+                                  IL:|collect| (IF (NOT (LITERAL-P ARG))
+                                                       (RETURN T)
+                                                       (LET ((VALUE (LITERAL-VALUE ARG)))
+                                                            (WHEN (EVAL-WHEN-LOAD-P VALUE)
+                                                                  (SETQ EVAL-WHEN-LOAD? T))
+                                                            VALUE)))))
+             (OR (EQ CONTEXT :ARGUMENT)
+                 (NOT EVAL-WHEN-LOAD?)))
+        (LET
+         ((FN-NAME (VARIABLE-NAME (VAR-REF-VARIABLE FN))))
+         (RELEASE-TREE NODE)
+         (COND
+            ((EQ CONTEXT :ARGUMENT)
+             (SETQ
+              NODE
+              (MAKE-LITERAL
+               :VALUE
+               (IF EVAL-WHEN-LOAD?
+                   (MAKE-EVAL-WHEN-LOAD
+                    :FORM
+                    `(,FN-NAME ,@(IL:|for| ARG IL:|in| ARGS
+                                    IL:|collect| (IF (EVAL-WHEN-LOAD-P ARG)
+                                                         (EVAL-WHEN-LOAD-FORM ARG)
+                                                         `',ARG))))
+                   (APPLY FN-NAME ARGS)))))
+
+            (IL:* IL:|;;| "We're in either :RETURN or :MV context and the expression doesn't include any EVAL-WHEN-LOAD forms.")
+
+            ((NULL (CDR (SETQ LIST-OF-VALUES (MULTIPLE-VALUE-LIST (APPLY FN-NAME ARGS)))))
+
+             (IL:* IL:|;;| "The form does not return multiple values.")
+
+             (SETQ NODE (MAKE-LITERAL :VALUE (CAR LIST-OF-VALUES))))
+            (T 
+               (IL:* IL:|;;| 
+             "The form does return multiple values.  Turn it into a call on VALUES-LIST.")
+
+               (SETQ NODE (MAKE-CALL :FN (MAKE-REFERENCE-TO-VARIABLE :NAME 'VALUES-LIST :KIND 
+                                                :FUNCTION :SCOPE :GLOBAL)
+                                 :ARGS
+                                 (LIST (MAKE-LITERAL :VALUE LIST-OF-VALUES))))))))
+
+       (IL:* IL:|;;| "If there's a function-specific transformation defined for it, give it a try.")
+
+       ((AND (NOT (CALLER-NOT-INLINE NODE))
+             (GLOBAL-FUNCTION-P FN)
+             (SETQ TRANSFORM (GET (VARIABLE-NAME (VAR-REF-VARIABLE FN))
+                                  'TRANSFORM)))
+        (SETQ NODE (FUNCALL TRANSFORM NODE CONTEXT)))
+
+       (IL:* IL:|;;| "Nothing to do, so we must be done.")
+
+       (T (SETF (NODE-META-P NODE)
+                CONTEXT)))
+    NODE))
+
+(DEFUN META-EVAL-CATCH (NODE CONTEXT)
+   (MEVAL (CATCH-TAG NODE)
+          :ARGUMENT)
+   (MEVAL (CATCH-STMT NODE)
+          CONTEXT)
+   (ANALYZE-TREE NODE)
+   (SETF (NODE-META-P NODE)
+         CONTEXT)
+   NODE)
+
+(DEFUN META-EVAL-GO (NODE CONTEXT)
+   (ANALYZE-TREE NODE)
+   (SETF (NODE-META-P NODE)
+         CONTEXT)
+   NODE)
+
+(DEFUN META-EVAL-IF (NODE CONTEXT)
+   (MEVAL (IF-PRED NODE)
+          :ARGUMENT)
+   (MEVAL (IF-THEN NODE)
+          CONTEXT)
+   (MEVAL (IF-ELSE NODE)
+          CONTEXT)
+   (ANALYZE-TREE NODE)
+
+   (IL:* IL:|;;| "If the predicate is a literal, we can eliminate one of the arms.")
+
+   (WHEN (LITERAL-P (IF-PRED NODE))
+       (RETURN-FROM META-EVAL-IF (COND
+                                    ((LITERAL-VALUE (IF-PRED NODE))
+                                     (RELEASE-TREE (IF-ELSE NODE))
+                                     (IF-THEN NODE))
+                                    (T (RELEASE-TREE (IF-THEN NODE))
+                                       (IF-ELSE NODE)))))
+
+   (IL:* IL:|;;| "If both arms turned into literals and we're in effect context, then the only thing left is the predicate.")
+
+   (WHEN (AND (EQ CONTEXT :EFFECT)
+              (LITERAL-P (IF-THEN NODE))
+              (LITERAL-P (IF-ELSE NODE)))
+       (RETURN-FROM META-EVAL-IF (IF-PRED NODE)))
+
+   (IL:* IL:|;;| "If both arms have no side-effects and we're in effect context, then the only thing left is the predicate.")
+
+   (WHEN (AND (EQ CONTEXT :EFFECT)
+              (EFFECTLESS-EXCEPT-CONS (NODE-EFFECTS (IF-THEN NODE)))
+              (EFFECTLESS-EXCEPT-CONS (NODE-EFFECTS (IF-ELSE NODE))))
+       (RETURN-FROM META-EVAL-IF (IF-PRED NODE)))
+
+   (IL:* IL:|;;| 
+ "If the IF has the form (IF (IF pred NIL T) then else) then reduce to (IF pred else then).")
+
+   (LET ((PRED (IF-PRED NODE)))
+        (WHEN (AND (IF-P PRED)
+                   (LITERAL-P (IF-THEN PRED))
+                   (EQ NIL (LITERAL-VALUE (IF-THEN PRED)))
+                   (LITERAL-P (IF-ELSE PRED))
+                   (EQ T (LITERAL-VALUE (IF-ELSE PRED))))
+            (SETF (IF-PRED NODE)
+                  (IF-PRED PRED))
+            (ROTATEF (IF-THEN NODE)
+                   (IF-ELSE NODE))))
+
+   (IL:* IL:|;;| "Nothing worked, so give up.")
+
+   (SETF (NODE-META-P NODE)
+         CONTEXT)
+   NODE)
+
+(DEFUN META-EVAL-LABELS (NODE CONTEXT)
+
+   (IL:* IL:|;;| "First, meta-eval the subtrees:  The bodies of the FLET/LABELS-d functions must be meta-evaled first, so we get the side-effects info for meta-evaluating the body correctly (e.g., to detect effect-free FLETd fns in effect context).  This fixes AR 11447 JDS 12/8/91")
+
+   (MEVAL-LIST (LABELS-FUNS NODE)
+          :ARGUMENT CDR)
+   (MEVAL (LABELS-BODY NODE)
+          CONTEXT)
+   (ANALYZE-TREE NODE)
+
+   (IL:* IL:|;;| "Now try to substitute the local functions into the body.")
+
+   (SETQ NODE (META-CALL-LABELS NODE CONTEXT))
+   NODE)
+
+(DEFUN META-EVAL-LAMBDA (NODE CONTEXT)
+   (WHEN (EQ CONTEXT :EFFECT)                                (IL:* IL:\; 
+                                                           "LAMBDA's have no side effects.")
+       (RELEASE-TREE NODE)
+       (RETURN-FROM META-EVAL-LAMBDA *LITERALLY-NIL*))
+   (MEVAL (LAMBDA-BODY NODE)
+          :RETURN)
+   (MEVAL-LIST (LAMBDA-OPTIONAL NODE)
+          :ARGUMENT SECOND)
+   (MEVAL-LIST (LAMBDA-KEYWORD NODE)
+          :ARGUMENT THIRD)
+   (ANALYZE-TREE NODE)
+   (SETF (NODE-META-P NODE)
+         CONTEXT)
+   NODE)
+
+(DEFUN META-EVAL-LITERAL (NODE CONTEXT)
+   (ANALYZE-TREE NODE)
+   (SETF (NODE-META-P NODE)
+         CONTEXT)
+   NODE)
+
+(DEFUN META-EVAL-MV-CALL (NODE CONTEXT)
+
+(IL:* IL:|;;;| "Come back to this.  If all of the arg-exprs can be guaranteed to return a single value each, we can transform this in to a normal function call.  Unfortunately, the information about how many values something might return is not passed up the tree.")
+
+   (MEVAL (MV-CALL-FN NODE)
+          :ARGUMENT)
+   (WHEN (LAMBDA-P (MV-CALL-FN NODE))
+
+       (IL:* IL:|;;| "If the function is a LAMBDA, we should redo the analysis of the body because we now know the context in which it will be evaluated.")
+
+       (MEVAL (LAMBDA-BODY (MV-CALL-FN NODE))
+              CONTEXT)
+       (ANALYZE-TREE (MV-CALL-FN NODE)))
+   (MEVAL-LIST (MV-CALL-ARG-EXPRS NODE)
+          :MV)
+   (ANALYZE-TREE NODE)
+   (SETF (NODE-META-P NODE)
+         CONTEXT)
+   NODE)
+
+(DEFUN META-EVAL-MV-PROG1 (NODE CONTEXT)
+   (LET ((STMTS (MV-PROG1-STMTS NODE)))
+        (MEVAL (FIRST STMTS)
+               CONTEXT)
+        (MEVAL-LIST (REST STMTS)
+               :EFFECT)
+        (REMOVE-NESTED-PROGNS (REST STMTS))
+        (ECASE CONTEXT
+            (:EFFECT                                         (IL:* IL:\; 
+                                "In effect context, we transform the MV-PROG1 into a simple PROGN.")
+               (MAKE-PROGN :STMTS STMTS))
+            (:ARGUMENT                                       (IL:* IL:\; 
+                                 "If multiple-values aren't wanted, turn this into a normal PROG1:")
+               (CONSTRUCT-PROG1-TREE (FIRST STMTS)
+                      (REST STMTS)))
+            ((:RETURN :MV)                                   (IL:* IL:\; 
+                   "Oh, well, it's MV context after all.  We can still try one last thing, though.")
+               (SETF (NODE-META-P NODE)
+                     CONTEXT)
+               (WHEN (PROGN-P (FIRST STMTS))                 (IL:* IL:\; 
+                                               "Transform MV-PROG1 of PROGN into PROGN of MV-PROG1")
+                   (ROTATEF NODE (FIRST STMTS)
+                          (CAR (LAST (PROGN-STMTS (FIRST STMTS))))))
+               NODE))))
+
+(DEFUN META-EVAL-OPCODES (NODE CONTEXT)
+
+(IL:* IL:|;;;| "Go ahead.  Meta-evaluate these opcodes.  I dare you.")
+
+   (ANALYZE-TREE NODE)
+   (SETF (NODE-META-P NODE)
+         CONTEXT)
+   NODE)
+
+(DEFUN META-EVAL-PROGN (NODE CONTEXT)
+
+(IL:* IL:|;;;| "Meta-evaluate the subtrees and then eliminate any nested PROGN's.")
+
+   (IL:|for| TAIL IL:|on| (PROGN-STMTS NODE) IL:|do| (IF (NULL (CDR TAIL))
+                                                                     (MEVAL (CAR TAIL)
+                                                                            CONTEXT)
+                                                                     (MEVAL (CAR TAIL)
+                                                                            :EFFECT)))
+   (ANALYZE-TREE NODE)
+   (REMOVE-NESTED-PROGNS (PROGN-STMTS NODE))
+
+   (IL:* IL:|;;| "Eliminate any effect-context literals and reduce (PROGN <exp>) to <exp>.")
+
+   (LET ((NEW-STMTS (IL:|for| TAIL IL:|on| (PROGN-STMTS NODE)
+                       IL:|when| (OR (NOT (LITERAL-P (CAR TAIL)))
+                                         (NULL (CDR TAIL))) IL:|collect| (CAR TAIL))))
+        (COND
+           ((NULL NEW-STMTS)
+            *LITERALLY-NIL*)
+           ((NULL (CDR NEW-STMTS))
+            (SETQ NODE (CAR NEW-STMTS)))
+           (T (SETF (PROGN-STMTS NODE)
+                    NEW-STMTS))))
+   (SETF (NODE-META-P NODE)
+         CONTEXT)
+   NODE)
+
+(DEFUN META-EVAL-PROGV (NODE CONTEXT)
+   (MEVAL (PROGV-SYMS-EXPR NODE)
+          :ARGUMENT)
+   (MEVAL (PROGV-VALS-EXPR NODE)
+          :ARGUMENT)
+   (MEVAL (PROGV-STMT NODE)
+          CONTEXT)
+   (ANALYZE-TREE NODE)
+   (SETF (NODE-META-P NODE)
+         CONTEXT)
+   NODE)
+
+(DEFUN META-EVAL-RETURN (NODE CONTEXT)
+   (MEVAL (RETURN-VALUE NODE)
+          (BLOCK-CONTEXT (RETURN-BLOCK NODE)))
+   (ANALYZE-TREE NODE)
+   (SETF (NODE-META-P NODE)
+         CONTEXT)
+   NODE)
+
+(DEFUN META-EVAL-SETQ (NODE CONTEXT)
+   (MEVAL (SETQ-VALUE NODE)
+          :ARGUMENT)
+   (ANALYZE-TREE NODE)
+   (SETF (NODE-META-P NODE)
+         CONTEXT)
+   NODE)
+
+(DEFUN META-EVAL-TAGBODY (NODE CONTEXT)
+   (IL:|for| SEGMENT IL:|in| (TAGBODY-SEGMENTS NODE) IL:|do| (MEVAL-LIST (
+                                                                                        SEGMENT-STMTS
+                                                                                          SEGMENT)
+                                                                                :EFFECT))
+   (ANALYZE-TREE NODE)
+   (SETF (NODE-META-P NODE)
+         CONTEXT)
+   NODE)
+
+(DEFUN META-EVAL-THROW (NODE CONTEXT)
+   (MEVAL (THROW-TAG NODE)
+          :ARGUMENT)
+   (MEVAL (THROW-VALUE NODE)
+          :MV)
+   (ANALYZE-TREE NODE)
+   (SETF (NODE-META-P NODE)
+         CONTEXT)
+   NODE)
+
+(DEFUN META-EVAL-UNWIND-PROTECT (NODE CONTEXT)
+
+(IL:* IL:|;;;| "This is fucked up right now.")
+
+   (MEVAL (UNWIND-PROTECT-STMT NODE)
+          :ARGUMENT)
+   (MEVAL (UNWIND-PROTECT-CLEANUP NODE)
+          :ARGUMENT)
+   (ANALYZE-TREE NODE)
+   (SETF (NODE-META-P NODE)
+         CONTEXT)
+   NODE)
+
+(DEFUN META-EVAL-VAR-REF (NODE CONTEXT)
+   (COND
+      ((EQ CONTEXT :EFFECT)                                  (IL:* IL:\; 
+                                                        "Variable references have no side-effects.")
+       (RELEASE-VAR-REF NODE)
+       *LITERALLY-NIL*)
+      (T (ANALYZE-TREE NODE)
+         (SETF (NODE-META-P NODE)
+               CONTEXT)
+         NODE)))
+
+(DEFUN META-CALL-LAMBDA (NODE CONTEXT)
+
+   (IL:* IL:|;;| "This is a directly-called LAMBDA.  Here are the steps to meta-evaluate it:")
+
+   (IL:* IL:|;;| "     -- Try to eliminate all of the non-required arguments")
+
+   (IL:* IL:|;;| "     -- Try to substitute in all of the required arguments")
+
+   (IL:* IL:|;;| "     -- Try to eliminate all arguments to unreferenced parameters")
+
+   (IL:* IL:|;;| "     -- Beta-convert the now-argument-less LAMBDA")
+
+   (LET ((*MADE-CHANGES* NIL)
+         (FN (CALL-FN NODE)))
+
+        (IL:* IL:|;;| "We can't meta-evaluate direct calls to Interlisp's LAMBDA no-spread's.")
+
+        (WHEN (EQ 2 (LAMBDA-ARG-TYPE FN))
+              (RETURN-FROM META-CALL-LAMBDA NODE))
+
+        (IL:* IL:|;;| "If there are non-required parameters, try to get rid of them.")
+
+        (WHEN (OR (LAMBDA-OPTIONAL FN)
+                  (LAMBDA-KEYWORD FN)
+                  (LAMBDA-REST FN)
+                  (/= (LENGTH (CALL-ARGS NODE))
+                      (LENGTH (LAMBDA-REQUIRED FN))))        (IL:* IL:\; "Attempt to eliminate all of the non-required parameters.  Also, catch wrong number of arguments errors.")
+            (WHEN (NULL (META-CALL-LAMBDA-SIMPLIFY-PARAMETERS NODE))
+                (WHEN (NULL *MADE-CHANGES*)
+                    (SETF (NODE-META-P NODE)
+                          CONTEXT))
+                (RETURN-FROM META-CALL-LAMBDA NODE))
+
+            (IL:* IL:|;;| "Some changes were made.  We need to re-meta-evaluate the call in order to make sure it's up to date.")
+
+            (MEVAL (CALL-FN NODE)
+                   :ARGUMENT)
+            (MEVAL-LIST (CALL-ARGS NODE)
+                   :ARGUMENT))
+
+        (IL:* IL:|;;| "Now there are only required parameters.  Try to substitute arguments for parameters where appropriate.")
+
+        (META-CALL-LAMBDA-SUBSTITUTE NODE)
+
+        (IL:* IL:|;;| "Now we can get rid of any parameters that aren't referenced. ")
+
+        (LET ((NEW-PARAMS NIL)
+              (NEW-ARGS NIL)
+              (CURRENT-PROG1-TAIL NIL)
+              (CURRENT-PROGN NIL))
+
+             (IL:* IL:|;;| "If the first parameter is not referenced, we can turn (fn arg1 . args) into (progn arg1 (fn' . args)) where fn' is just like fn but doesn't have the first parameter.")
+
+             (IL:* IL:|;;| "If the first is referenced, but the second is not, we can turn (fn arg1 arg2 . args) into (fn' (prog1 arg1 arg2) .args), where fn' is just like fn but without the second parameter and (prog1 (a) . b) is really ((lambda (anon) ,@b anon) (a)) .")
+
+             (IL:FOR PARAM IL:IN (LAMBDA-REQUIRED FN) IL:AS ARG IL:IN (CALL-ARGS
+                                                                                       NODE)
+                IL:DO (COND
+                             ((OR (EQ :SPECIAL (VARIABLE-SCOPE PARAM))
+                                  (NOT (NULL (VARIABLE-READ-REFS PARAM)))
+                                  (NOT (NULL (VARIABLE-WRITE-REFS PARAM))))
+                                                             (IL:* IL:\; 
+                                                           "This one's used.   Leave it.")
+                              (PUSH PARAM NEW-PARAMS)
+                              (PUSH ARG NEW-ARGS)
+                              (SETQ CURRENT-PROG1-TAIL NIL))
+                             (T                              (IL:* IL:\; 
+                                                           "This one is not used.  Can it.")
+                                (SETQ *MADE-CHANGES* T)
+                                (COND
+                                   ((NODE-SUBST-P ARG)       (IL:* IL:\; 
+      "The corresponding argument has been substituted into the body.  We need not save it at all.")
+                                    (RELEASE-TREE ARG))
+                                   ((NULL NEW-ARGS)          (IL:* IL:\; 
+                                                       "It's an early one.  Stick it into a PROGN.")
+                                    (PUSH ARG CURRENT-PROGN))
+                                   ((NULL CURRENT-PROG1-TAIL)(IL:* IL:\; 
+                                           "We need to set up a PROG1 using the previous argument.")
+                                                             (IL:* IL:\; "After putting it together, we make CURRENT-PROG1-TAIL hold the last CONS cell in the body of the LAMBDA of the PROG1.  This is to allow splicing new stmts into that body.")
+                                    (LET* ((NEW-PROG1 (CONSTRUCT-PROG1-TREE (CAR NEW-ARGS)
+                                                             (LIST ARG))))
+                                          (SETQ CURRENT-PROG1-TAIL (CDR (PROGN-STMTS
+                                                                         (LAMBDA-BODY (CALL-FN 
+                                                                                            NEW-PROG1
+                                                                                             )))))
+                                          (SETF (CAR NEW-ARGS)
+                                                NEW-PROG1)))
+                                   (T                        (IL:* IL:\; 
+                                                           "There's already a PROG1 set up for us.")
+                                      (IL:RPLNODE CURRENT-PROG1-TAIL ARG (LIST (CAR 
+                                                                                   CURRENT-PROG1-TAIL
+                                                                                    )))
+                                      (SETQ CURRENT-PROG1-TAIL (CDR CURRENT-PROG1-TAIL)))))))
+
+             (IL:* IL:|;;| "If there aren't any arguments left, then we can beta-reduce.")
+
+             (COND
+                ((NULL NEW-ARGS)
+                 (SETQ NODE (LAMBDA-BODY FN))
+                 (SETF (LAMBDA-BODY FN)
+                       NIL)
+                 (SETF (LAMBDA-REQUIRED FN)
+                       NIL)
+                 (RELEASE-TREE FN)
+                 (SETQ *MADE-CHANGES* T))
+                (T (SETF (LAMBDA-REQUIRED FN)
+                         (NREVERSE NEW-PARAMS))
+                   (SETF (CALL-ARGS NODE)
+                         (NREVERSE NEW-ARGS))))
+             (WHEN (NOT (NULL CURRENT-PROGN))
+                 (SETQ NODE (MAKE-PROGN :STMTS (NREVERSE (CONS NODE CURRENT-PROGN))))))
+        (WHEN (NULL *MADE-CHANGES*)
+            (SETF (NODE-META-P NODE)
+                  CONTEXT))
+        NODE))
+
+(DEFUN META-CALL-LAMBDA-SIMPLIFY-PARAMETERS (NODE)       (IL:* IL:\; 
+                                                           "Edited 31-Jan-92 12:45 by jrb:")
+
+   (IL:* IL:|;;| "Attempt to eliminate all of the non-required parameters from the given lambda-call.  Return non-nil iff we can get rid of all of them.  Also, check for wrong number of arguments.")
+
+   (LET* ((FN (CALL-FN NODE))
+          (ARGS (CALL-ARGS NODE))
+          (INNERMOST-CALL NODE)
+          (INNERMOST-LAMBDA FN)
+          (NEW-ARGS NIL)
+          (NEW-PARAMS NIL)
+          (KEY-PARAMS NIL))
+         (LABELS ((ADD-PARAM (PARAM ARG)
+
+                         (IL:* IL:|;;| 
+                      "Match up the given argument with the given parameter in the current lambda.")
+
+                         (PUSH PARAM NEW-PARAMS)
+                         (PUSH ARG NEW-ARGS)
+                         (SETF (VARIABLE-BINDER PARAM)
+                               INNERMOST-LAMBDA))
+                  (CLOSE-LAMBDA NIL 
+
+                         (IL:* IL:|;;| "Close off the current lambda.")
+
+                         (SETF (LAMBDA-REQUIRED INNERMOST-LAMBDA)
+                               (NREVERSE NEW-PARAMS))
+                         (SETF (CALL-ARGS INNERMOST-CALL)
+                               (NREVERSE NEW-ARGS))
+                         (SETQ NEW-ARGS NIL)
+                         (SETQ NEW-PARAMS NIL))
+                  (NEW-LAMBDA NIL 
+
+                         (IL:* IL:|;;| "Close off the old lambda and add a new one inside of it.")
+
+                         (CLOSE-LAMBDA)
+                         (LET* ((NEW-LAMBDA (MAKE-LAMBDA :BODY (LAMBDA-BODY INNERMOST-LAMBDA)))
+                                (NEW-CALL (MAKE-CALL :FN NEW-LAMBDA)))
+                               (SETF (LAMBDA-BODY INNERMOST-LAMBDA)
+                                     NEW-CALL)
+                               (SETQ INNERMOST-LAMBDA NEW-LAMBDA)
+                               (SETQ INNERMOST-CALL NEW-CALL)))
+                  (OUTER-LAMBDA-P NIL 
+
+                         (IL:* IL:|;;| "Is the current lambda the outermost one?")
+
+                         (EQ INNERMOST-LAMBDA FN))
+                  (ENSURE-INNER-LAMBDA NIL 
+
+                         (IL:* IL:|;;| 
+                       "Make sure that the current lambda is not the outermost one.")
+
+                         (WHEN (OUTER-LAMBDA-P)
+                               (NEW-LAMBDA))))
+
+                (IL:* IL:|;;| "Handle the required parameters")
+
+                (IL:|for| TAIL IL:|on| (LAMBDA-REQUIRED FN)
+                   IL:|do| (COND
+                                  ((NULL ARGS)
+                                   (COMPILER-CERROR "Use NIL for the remaining parameters." 
+                                          "Too few arguments given for explicit LAMBDA call.")
+                                   (IL:|for| PARAM IL:|in| TAIL IL:|do| (ADD-PARAM PARAM
+                                                                                           
+                                                                                      *LITERALLY-NIL*
+                                                                                           ))
+                                   (RETURN))
+                                  (T (ADD-PARAM (CAR TAIL)
+                                            (POP ARGS)))))
+
+                (IL:* IL:|;;| "Handle the optional parameters")
+
+                (WHEN (NOT (NULL (LAMBDA-OPTIONAL FN)))
+                    (IL:FOR OPT-VAR IL:IN (LAMBDA-OPTIONAL FN)
+                       IL:DO (COND
+                                    ((NULL ARGS)
+
+                                 (IL:* IL:|;;| "No arguments left.  Wrap the body in a LET binding the optional parameter to its default value.  Also bind the supplied-p parameter, if any.")
+
+                                     (NEW-LAMBDA)
+                                     (ADD-PARAM (FIRST OPT-VAR)
+                                            (SECOND OPT-VAR))
+                                     (WHEN (THIRD OPT-VAR)   (IL:* IL:\; "There's a supplied-p")
+                                         (ADD-PARAM (THIRD OPT-VAR)
+                                                *LITERALLY-NIL*)))
+                                    (T 
+                                       (IL:* IL:|;;| "There are arguments left, so match one up with this optional and match up T with the supplied-p parameter, if any.")
+
+                                       (ADD-PARAM (FIRST OPT-VAR)
+                                              (POP ARGS))
+                                       (RELEASE-TREE (SECOND OPT-VAR))
+                                       (WHEN (THIRD OPT-VAR) (IL:* IL:\; "There's a supplied-p")
+                                           (ADD-PARAM (THIRD OPT-VAR)
+                                                  *LITERALLY-T*)))))
+                    (SETF (LAMBDA-OPTIONAL FN)
+                          NIL)                               (IL:* IL:\; 
+                                                           "All of the optionals are gone now.")
+                    (SETF (NODE-META-P FN)
+                          NIL)
+                    (SETQ *MADE-CHANGES* T))
+
+                (IL:* IL:|;;| "We can't go any further if there are keyword parameters and we can't tell what the corresponding keyword arguments are.")
+
+                (WHEN (AND (NOT (NULL (LAMBDA-KEYWORD FN)))
+                           (NOT (IL:|for| ARG IL:|in| ARGS IL:|by| (CDDR ARG)
+                                   IL:|always| (LITERAL-P ARG))))
+                    (CLOSE-LAMBDA)
+                    (RETURN-FROM META-CALL-LAMBDA-SIMPLIFY-PARAMETERS NIL))
+
+                (IL:* IL:|;;| "If there are keyword parameters, we need to bind the remaining arguments to new, anonymous variables for any more processing.")
+
+                (WHEN (NOT (NULL (LAMBDA-KEYWORD FN)))
+                    (ENSURE-INNER-LAMBDA)
+                    (SETQ KEY-PARAMS (IL:|in| ARGS IL:|collect| (MAKE-VARIABLE :BINDER FN)))
+                    (WHEN (NOT (NULL KEY-PARAMS))
+                        (SETF (LAMBDA-REQUIRED FN)
+                              (APPEND (LAMBDA-REQUIRED FN)
+                                     KEY-PARAMS))
+                        (SETF (CALL-ARGS NODE)
+                              (APPEND (CALL-ARGS NODE)
+                                     ARGS)))
+                    (SETF (NODE-META-P FN)
+                          NIL)
+                    (SETQ *MADE-CHANGES* T))
+
+                (IL:* IL:|;;| "Handle the &rest parameter, if any.  If there are keyword parameters, then we bind the rest-var to a list of the anonymous variables used in that translation.  If not, we transform the arguments into a single call on LIST and bind that to the rest-var.")
+
+                (LET ((REST-VAR (LAMBDA-REST FN)))
+                     (WHEN (NOT (NULL REST-VAR))
+                         (COND
+                            ((NOT (NULL KEY-PARAMS))         (IL:* IL:\; 
+                                                           "There are keyword parameters.")
+                             (ADD-PARAM REST-VAR
+                                    (CONSTRUCT-LIST
+                                     (MAPCAR #'(LAMBDA (PARAM)
+                                                      (LET ((REF (MAKE-VAR-REF :VARIABLE PARAM)))
+                                                           (PUSH REF (VARIABLE-READ-REFS PARAM))
+                                                           REF))
+                                            KEY-PARAMS))))
+                            (T                               (IL:* IL:\; 
+                                                           "There are no keyword parameters.")
+                               (COND
+                                  ((NULL ARGS)               (IL:* IL:\; 
+                                                         "There aren't any arguments left, either.")
+                                   (ADD-PARAM REST-VAR *LITERALLY-NIL*))
+                                  ((OUTER-LAMBDA-P)          (IL:* IL:\; 
+    "We're still in the outer lambda, so we can just bind the rest-var to a list of the arguments.")
+                                   (ADD-PARAM REST-VAR (CONSTRUCT-LIST ARGS)))
+                                  (T                         (IL:* IL:\; "Sigh.  This is the messiest case.  We're in an inner lambda, so we have to add an anonymous variable to the outer one, bind that to the list of arguments, and then bind the rest-var to that in the current lambda.")
+                                     (LET* ((ANON-VAR (MAKE-VARIABLE :BINDER FN))
+                                            (ANON-VAR-REF (MAKE-VAR-REF :VARIABLE ANON-VAR)))
+                                           (SETF (LAMBDA-REQUIRED FN)
+                                                 (NCONC (LAMBDA-REQUIRED FN)
+                                                        (LIST ANON-VAR)))
+                                           (SETF (CALL-ARGS NODE)
+                                                 (NCONC (CALL-ARGS NODE)
+                                                        (LIST (CONSTRUCT-LIST ARGS))))
+                                           (ADD-PARAM REST-VAR ANON-VAR-REF)
+                                           (PUSH ANON-VAR-REF (VARIABLE-READ-REFS ANON-VAR)))))
+                               (SETQ ARGS NIL)               (IL:* IL:\; 
+                                                          "All of the arguments have been handled.")
+                               ))
+                         (SETF (LAMBDA-REST FN)
+                               NIL)                          (IL:* IL:\; 
+                                                           "The &rest parameter is no more.")
+                         (SETF (NODE-META-P FN)
+                               NIL)
+                         (SETQ *MADE-CHANGES* T)))
+
+                (IL:* IL:|;;| "Handle the keyword parameters.  All of the keyword-position arguments are literals; we can thus determine which arguments go with which keyword parameters.  Thus, we can turn them all into required ones.")
+
+                (WHEN (NOT (NULL (LAMBDA-KEYWORD FN)))
+                    (IL:FOR KEY-VAR IL:IN (LAMBDA-KEYWORD FN)
+                       IL:DO (LET* ((KEYWORD (FIRST KEY-VAR))
+                                        (ANON-VAR (IL:|for| ARG IL:|in| ARGS
+                                                     IL:|by| (CDDR ARG) IL:|as| TAIL
+                                                     IL:|on| KEY-PARAMS IL:|by| (CDDR TAIL)
+                                                     IL:|when| (EQ KEYWORD (LITERAL-VALUE ARG))
+                                                     IL:|do| (RETURN (SECOND TAIL))))
+                                        (ANON-VAR-REF (MAKE-VAR-REF :VARIABLE ANON-VAR)))
+                                       (COND
+                                          ((NULL ANON-VAR)
+
+                                           (IL:* IL:|;;| 
+               "This keyword isn't present in the call; treat the same as an unsupplied optional. ")
+
+                                           (NEW-LAMBDA)
+                                           (ADD-PARAM (SECOND KEY-VAR)
+                                                  (THIRD KEY-VAR))
+                                           (WHEN (FOURTH KEY-VAR)
+                                               (ADD-PARAM (FOURTH KEY-VAR)
+                                                      *LITERALLY-NIL*)))
+                                          (T 
+
+                                            (IL:* IL:|;;| "There is a matching keyword in the argument list, so we bind the parameter to the corresponding anonymous one.")
+
+                                             (ENSURE-INNER-LAMBDA)
+                                             (ADD-PARAM (SECOND KEY-VAR)
+                                                    ANON-VAR-REF)
+                                             (PUSH ANON-VAR-REF (VARIABLE-READ-REFS ANON-VAR))
+                                             (RELEASE-TREE (THIRD KEY-VAR))
+                                             (WHEN (FOURTH KEY-VAR)
+                                                 (ADD-PARAM (FOURTH KEY-VAR)
+                                                        *LITERALLY-T*))))))
+                    (SETF (LAMBDA-KEYWORD FN)
+                          NIL)                               (IL:* IL:\; 
+                                                      "All of the keyword parameters are gone now.")
+                    (SETQ ARGS NIL)                          (IL:* IL:\; 
+                                                "And we've managed to use up all of the arguments.")
+                    )
+
+                (IL:* IL:|;;| "Make one final check that there weren't too many arguments.")
+
+                (WHEN (NOT (NULL ARGS))
+                    (COMPILER-CERROR "Ignore the extra arguments" 
+                           "Too many arguments were given to an inline LAMBDA call.")
+                    (IL:|for| ARG IL:|in| ARGS IL:|do| (RELEASE-TREE ARG)))
+
+                (IL:* IL:|;;| 
+              "We're done now. Close up the inner lambda machinery and return a sign of success.")
+
+                (CLOSE-LAMBDA)
+                T)))
+
+(DEFUN CONSTRUCT-LIST (ARGS)
+
+(IL:* IL:|;;;| "ARGS is a non-empty list of nodes.  Return an tree that computes the result of LIST applied to the results of those nodes.  A simple implementation would just make an actual call to the function LIST, but this is inefficient.  Instead, we make a nested series of calls to the function CONS.")
+
+   (LET ((NODE *LITERALLY-NIL*))
+        (IL:MAPC (REVERSE ARGS)
+               (IL:FUNCTION (IL:LAMBDA (ARG)
+                              (SETQ NODE (MAKE-CALL :FN (MAKE-REFERENCE-TO-VARIABLE :KIND :FUNCTION 
+                                                               :SCOPE :GLOBAL :NAME 'CONS)
+                                                :ARGS
+                                                (LIST ARG NODE))))))
+        NODE))
+
+
+
+(IL:* IL:|;;;| "Meta-substitution")
+
+
+(DEFUN META-CALL-LAMBDA-SUBSTITUTE (NODE)
+   (LET* ((FN (CALL-FN NODE))
+          (REQUIRED-ARGS (LAMBDA-REQUIRED FN))
+          (NON-LOCAL-EFFECTS (WITH-COLLECTION (DOLIST (VAR REQUIRED-ARGS)
+                                                  (UNLESS (EQ (VARIABLE-SCOPE VAR)
+                                                              :LEXICAL)
+                                                      (COLLECT (EFFECTS-REPRESENTATION VAR))))))
+          (*SUBST-OCCURRED* NIL))                            (IL:* IL:\; 
+"Bind *SUBST-OCCURRED* just so that META-SUBST-VAR-REF has a binding to set even when nobody cares.")
+         (IL:|for| VAR IL:|in| REQUIRED-ARGS IL:|as| TAIL IL:|on| (CALL-ARGS NODE)
+            IL:|when| (AND (EQ (VARIABLE-SCOPE VAR)
+                                   :LEXICAL)
+                               (SUBSTITUTABLE-P (CAR TAIL)
+                                      VAR)
+                               (DOLIST (NON-LOCAL-EFFECT NON-LOCAL-EFFECTS T)
+                                   (UNLESS (NULL-EFFECTS-INTERSECTION NON-LOCAL-EFFECT
+                                                  (NODE-AFFECTED (CAR TAIL)))
+                                          (RETURN NIL)))
+                               (DOLIST (LATER-ARG (CDR TAIL)
+                                              T)
+                                   (WHEN (NOT (PASSABLE (CAR TAIL)
+                                                     LATER-ARG))
+                                         (RETURN NIL)))) IL:|do| (SETF (LAMBDA-BODY FN)
+                                                                           (META-SUBSTITUTE
+                                                                            (CAR TAIL)
+                                                                            VAR
+                                                                            (LAMBDA-BODY FN))))
+         (WHEN (NULL (NODE-META-P (LAMBDA-BODY FN)))
+             (SETF (NODE-META-P FN)
+                   NIL)
+             (SETQ *MADE-CHANGES* T))))
+
+(DEFUN META-CALL-LABELS (NODE CONTEXT)
+
+   (IL:* IL:|;;| "This is similar to META-CALL-LAMBDA, but we have some extra information. There are only required arguments, and we have the correct number of them.")
+
+   (LET ((*MADE-CHANGES* NIL))
+
+        (IL:* IL:|;;| "First, substitute the functions wherever possible.")
+
+        (DOLIST (FN-PAIR (LABELS-FUNS NODE)
+                       (WHEN (NULL (NODE-META-P (LABELS-BODY NODE)))
+                           (SETF (NODE-META-P NODE)
+                                 NIL)
+                           (SETQ *MADE-CHANGES* T)))
+            (WHEN (SUBSTITUTABLE-P (CDR FN-PAIR)
+                         (CAR FN-PAIR))
+                (LET ((*SUBST-OCCURRED* NIL))
+
+                     (IL:* IL:|;;| "First try substituting into the body.")
+
+                     (SETF (LABELS-BODY NODE)
+                           (META-SUBSTITUTE (CDR FN-PAIR)
+                                  (CAR FN-PAIR)
+                                  (LABELS-BODY NODE)))
+                     (WHEN (NOT *SUBST-OCCURRED*)
+
+                         (IL:* IL:|;;| "Wasn't in the body - try the other functions.")
+
+                         (DOLIST (TARGET-PAIR (LABELS-FUNS NODE))
+                             (UNLESS (EQ TARGET-PAIR FN-PAIR)
+                                 (SETF (CDR TARGET-PAIR)
+                                       (META-SUBSTITUTE (CDR FN-PAIR)
+                                              (CAR FN-PAIR)
+                                              (CDR TARGET-PAIR)))
+                                 (WHEN *SUBST-OCCURRED*      (IL:* IL:\; 
+                                                           "Found it, we can stop now.")
+                                     (SETF (NODE-META-P NODE)
+                                           NIL)
+                                     (SETQ *MADE-CHANGES* T)
+                                     (RETURN)))))
+
+                     (IL:* IL:|;;| "May need to reanalyze the node, since things might have changed.  Note that reanalyzing the parts of the node this way means the the state in the enclosing loop is not lost.")
+
+                     (DOLIST (FNS (LABELS-FUNS NODE))
+                         (MEVAL (CDR FNS)
+                                :ARGUMENT))
+                     (MEVAL (LABELS-BODY NODE)
+                            :RETURN))))
+
+        (IL:* IL:|;;| "Now remove any functions that aren't referenced.")
+
+        (DOLIST (FN-PAIR (PROG1 (LABELS-FUNS NODE)
+                             (SETF (LABELS-FUNS NODE)
+                                   NIL)))
+            (COND
+               ((NULL (VARIABLE-READ-REFS (CAR FN-PAIR)))
+                (RELEASE-TREE (CDR FN-PAIR))
+                (SETQ *MADE-CHANGES* T))
+               (T (PUSH FN-PAIR (LABELS-FUNS NODE)))))
+
+        (IL:* IL:|;;| "If there aren't any functions left, replace the node with its body.")
+
+        (WHEN (NULL (LABELS-FUNS NODE))
+            (LET ((BODY (LABELS-BODY NODE)))
+                 (SETF (LABELS-BODY NODE)
+                       NIL)
+                 (RELEASE-TREE NODE)
+                 (SETQ NODE BODY *MADE-CHANGES* T)))
+
+        (IL:* IL:|;;| "Finally, set the meta-p flag if everythings OK.")
+
+        (IF (NULL *MADE-CHANGES*)
+            (SETF (NODE-META-P NODE)
+                  CONTEXT)
+            (SETF (NODE-META-P NODE)
+                  NIL)))
+   NODE)
+
+(DEFUN META-SUBSTITUTE (*SUBST-EXPR* *SUBST-VAR* TREE)
+   (META-SUBST TREE))
+
+(DEFUN META-SUBST (NODE)
+   (NODE-DISPATCH META-SUBST NODE))
+
+(DEFINE-MODIFY-MACRO MSUBST (CONTEXT) META-SUBST)
+
+(DEFMACRO MSUBST-LIST (LIST-EXPR CONTEXT &OPTIONAL KEY-FN)
+   `(IL:FOR TAIL IL:ON ,LIST-EXPR IL:DO (MSUBST ,(IF KEY-FN
+                                                                     `(,KEY-FN (CAR TAIL))
+                                                                     '(CAR TAIL))
+                                                           ,CONTEXT)))
+
+(DEFUN SUBSTITUTABLE-P (ARG VAR)
+
+(IL:* IL:|;;;| "Should ARG be substituted for all of the references to VAR?")
+
+(IL:* IL:|;;;| 
+"This test is very conservative, but still catches an enormous number of cases in practice.")
+
+(IL:* IL:|;;;| "NOTEZ BIEN: If you change this test, be sure to look carefully at the various substitution methods and at the code in META-CALL-LAMBDA.  Some of it depends upon the precise test being made; in particular, it matters if more side effects are allowed to be substituted.")
+
+   (AND (NULL (VARIABLE-WRITE-REFS VAR))                     (IL:* IL:\; 
+                                                        "The variable is never SETQ'd in the body,")
+        (NOT (NULL (VARIABLE-READ-REFS VAR)))                (IL:* IL:\; 
+                                                           "the variable is read at least once,")
+                                                             (IL:* IL:\; "and either")
+        (OR (VAR-REF-P ARG)                                  (IL:* IL:\; 
+                                                           " -- the arg is a variable reference,")
+            (AND (LITERAL-P ARG)
+                 (NOT (EVAL-WHEN-LOAD-P (LITERAL-VALUE ARG))))
+                                                             (IL:* IL:\; " -- the arg is a literal")
+            )))
+
+(DEFUN EFFECTLESS (EFFECTS)
+   (OR (NULL EFFECTS)
+       (EQ EFFECTS :NONE)))
+
+(DEFUN EFFECTLESS-EXCEPT-CONS (EFFECTS)
+   (OR (NULL EFFECTS)
+       (EQ EFFECTS :NONE)
+       (EQUAL EFFECTS '(:CONS))))
+
+(DEFUN NULL-INTERSECTION (LIST-1 LIST-2)
+   (OR (NULL LIST-1)
+       (NULL LIST-2)
+       (DOLIST (X LIST-1 T)
+           (WHEN (MEMBER X LIST-2 :TEST 'EQ)
+                 (RETURN NIL)))))
+
+(DEFUN NULL-EFFECTS-INTERSECTION (EFFECTS-1 EFFECTS-2)
+   (OR (NULL EFFECTS-1)
+       (NULL EFFECTS-2)
+       (EQ EFFECTS-1 :NONE)
+       (EQ EFFECTS-2 :NONE)
+       (COND
+          ((EQ EFFECTS-1 :ANY)
+           NIL)
+          ((EQ EFFECTS-2 :ANY)
+           NIL)
+          (T (NULL-INTERSECTION EFFECTS-1 EFFECTS-2)))))
+
+(DEFUN NULL-EFFECTS-INTERSECTION-EXCEPT-CONS (EFFECTS-1 EFFECTS-2)
+   (COND
+      ((OR (NULL EFFECTS-1)
+           (NULL EFFECTS-2)
+           (EQ EFFECTS-1 :NONE)
+           (EQ EFFECTS-2 :NONE))
+       T)
+      ((EQ EFFECTS-1 :ANY)
+       (IL:EQUAL (IL:MKLIST EFFECTS-2 '(:CONS))))
+      ((EQ EFFECTS-2 :ANY)
+       (IL:EQUAL (IL:MKLIST EFFECTS-1 '(:CONS))))
+      (T (DOLIST (EFFECT EFFECTS-1 T)
+             (WHEN (AND (NOT (EQ EFFECT :CONS))
+                        (MEMBER EFFECT EFFECTS-2 :TEST 'EQ))
+                   (RETURN NIL))))))
+
+(DEFUN PASSABLE (NODE-1 NODE-2)
+
+(IL:* IL:|;;;| 
+"This predicate is true if and only if the two given nodes can be executed in either order.")
+
+   (AND (NULL-EFFECTS-INTERSECTION (NODE-EFFECTS NODE-1)
+               (NODE-AFFECTED NODE-2))
+        (NULL-EFFECTS-INTERSECTION (NODE-AFFECTED NODE-1)
+               (NODE-EFFECTS NODE-2))
+        (NULL-EFFECTS-INTERSECTION-EXCEPT-CONS (NODE-EFFECTS NODE-1)
+               (NODE-EFFECTS NODE-2))))
+
+(DEFINLINE NONLOCAL-VARIABLE-EFFECT-P (EFFECT-REP)
+   (AND (SYMBOLP EFFECT-REP)
+        (NOT (KEYWORDP EFFECT-REP))))
+
+(DEFUN COLLECT-NONLOCAL-VAR-EFFECTS (NODE)
+   (LET ((VARS NIL))
+        (DOLIST (EFFECT (IL:MKLIST (NODE-EFFECTS NODE)))
+            (WHEN (NONLOCAL-VARIABLE-EFFECT-P EFFECT)
+                (PUSHNEW EFFECT VARS :TEST 'EQ)))
+        (DOLIST (EFFECT (IL:MKLIST (NODE-AFFECTED NODE)))
+            (WHEN (NONLOCAL-VARIABLE-EFFECT-P EFFECT)
+                (PUSHNEW EFFECT VARS :TEST 'EQ)))
+        VARS))
+
+(DEFVAR *SUBST-VAR* NIL
+
+(IL:* IL:|;;;| "The variable for occurrences of which we are substituting *SUBST-EXPR*.")
+
+   )
+
+(DEFVAR *SUBST-EXPR* NIL
+
+(IL:* IL:|;;;| "The expression being substituted for all occurrences of *SUBST-VAR*.")
+
+   )
+
+(DEFVAR *SUBST-OCCURRED*
+
+(IL:* IL:|;;;| "Bound by substitution methods that need to know whether or not anything actually happened and set by META-SUBST-VAR-REF when something does.")
+
+   )
+
+(DEFUN META-SUBST-BLOCK (NODE)                           (IL:* IL:\; "")
+   (MSUBST (BLOCK-STMT NODE))
+   (SETF (NODE-META-P NODE)
+         (NODE-META-P (BLOCK-STMT NODE)))
+   NODE)
+
+(DEFUN META-SUBST-CALL (NODE)
+   (WHEN (AND (NOT (LAMBDA-P (CALL-FN NODE)))
+              (NOT (CALLER-NOT-INLINE NODE)))                (IL:* IL:\; 
+                                "The body of the lambda won't be eval'd until after the arguments.")
+       (MSUBST (CALL-FN NODE)))
+   (META-SUBST-ANY-CALL NODE (CALL-FN NODE)
+          (CALL-ARGS NODE)))
+
+(DEFUN META-SUBST-CATCH (NODE)                           (IL:* IL:\; "")
+   (MSUBST (CATCH-TAG NODE))
+   (WHEN (PASSABLE *SUBST-EXPR* (CATCH-TAG NODE))
+       (MSUBST (CATCH-STMT NODE)))
+   (WHEN (OR (NULL (NODE-META-P (CATCH-TAG NODE)))
+             (NULL (NODE-META-P (CATCH-STMT NODE))))
+       (SETF (NODE-META-P NODE)
+             NIL))
+   NODE)
+
+(DEFUN META-SUBST-GO (NODE)
+   NODE)
+
+(DEFUN META-SUBST-IF (NODE)                              (IL:* IL:\; "")
+   (MSUBST (IF-PRED NODE))
+   (WHEN (AND (EFFECTLESS-EXCEPT-CONS (NODE-EFFECTS *SUBST-EXPR*))
+              (PASSABLE *SUBST-EXPR* (IF-PRED NODE)))
+       (MSUBST (IF-THEN NODE))
+       (MSUBST (IF-ELSE NODE)))
+   (WHEN (OR (NULL (NODE-META-P (IF-PRED NODE)))
+             (NULL (NODE-META-P (IF-THEN NODE)))
+             (NULL (NODE-META-P (IF-ELSE NODE))))
+       (SETF (NODE-META-P NODE)
+             NIL))
+   NODE)
+
+(DEFUN META-SUBST-LABELS (NODE)
+   (DOLIST (FUN (LABELS-FUNS NODE))
+       (MSUBST (CDR FUN))
+       (WHEN (NULL (NODE-META-P (CDR FUN)))
+           (SETF (NODE-META-P NODE)
+                 NIL)))
+   (MSUBST (LABELS-BODY NODE))
+   (WHEN (NULL (NODE-META-P (LABELS-BODY NODE)))
+       (SETF (NODE-META-P NODE)
+             NIL))
+   NODE)
+
+(DEFUN META-SUBST-LAMBDA (NODE &OPTIONAL (IN-FUNCTIONAL-POSITION NIL))
+   (WHEN (OR IN-FUNCTIONAL-POSITION (AND (EFFECTLESS (NODE-EFFECTS *SUBST-EXPR*))
+                                         (EFFECTLESS (NODE-AFFECTED *SUBST-EXPR*))))
+       (LET ((NONLOCAL-VAR-EFFECTS (COLLECT-NONLOCAL-VAR-EFFECTS *SUBST-EXPR*)))
+            (FLET ((SPECIAL-CLASHES-WITH-EFFECTS (VAR)
+
+                          (IL:* IL:|;;| "This is to check for the case of substituting an expression which depends on a special variable into a scope that rebinds that special.")
+
+                          (AND (EQ (VARIABLE-SCOPE VAR)
+                                   :SPECIAL)
+                               (IL:FMEMB (VARIABLE-NAME VAR)
+                                      NONLOCAL-VAR-EFFECTS))))
+                  (BLOCK SUBSTITUTION
+                      (DOLIST (REQ-VAR (LAMBDA-REQUIRED NODE))
+                          (WHEN (SPECIAL-CLASHES-WITH-EFFECTS REQ-VAR)
+                                (RETURN-FROM SUBSTITUTION)))
+                      (DOLIST (OPT-VAR (LAMBDA-OPTIONAL NODE))
+                          (MSUBST (SECOND OPT-VAR))
+                          (WHEN (NULL (NODE-META-P (SECOND OPT-VAR)))
+                              (SETF (NODE-META-P NODE)
+                                    NIL))
+                          (WHEN (OR (SPECIAL-CLASHES-WITH-EFFECTS (FIRST OPT-VAR))
+                                    (NOT (PASSABLE *SUBST-EXPR* (SECOND OPT-VAR))))
+                                (RETURN-FROM SUBSTITUTION)))
+                      (WHEN (AND (LAMBDA-REST NODE)
+                                 (SPECIAL-CLASHES-WITH-EFFECTS (LAMBDA-REST NODE)))
+                            (RETURN-FROM SUBSTITUTION))
+
+                      (IL:* IL:|;;| "JDS 1/6/89:  This appears to loop thru the keywords, checking each one.  There uesd to be a (SPECIAL-CLASHES-WITH-EFFECTS (THIRD KEY-VAR)) in the (when (or...)) clause, but that list seems to be ")
+
+                      (IL:* IL:|;;| "( variable-symbol variable-structure var's-value-structure)")
+
+                      (IL:* IL:|;;| 
+                    "and that's not checkable with SPECIAL-CLASHES-WITH-EFFECTS....")
+
+                      (DOLIST (KEY-VAR (LAMBDA-KEYWORD NODE))
+                          (MSUBST (THIRD KEY-VAR))
+                          (WHEN (NULL (NODE-META-P (THIRD KEY-VAR)))
+                              (SETF (NODE-META-P NODE)
+                                    NIL))
+                          (WHEN (OR (SPECIAL-CLASHES-WITH-EFFECTS (SECOND KEY-VAR))
+                                    (NOT (PASSABLE *SUBST-EXPR* (THIRD KEY-VAR))))
+                                (RETURN-FROM SUBSTITUTION)))
+                      (MSUBST (LAMBDA-BODY NODE))
+                      (WHEN (NULL (NODE-META-P (LAMBDA-BODY NODE)))
+                          (SETF (NODE-META-P NODE)
+                                NIL))))))
+   NODE)
+
+(DEFUN META-SUBST-LITERAL (NODE)
+   NODE)
+
+(DEFUN META-SUBST-MV-CALL (NODE)
+   (WHEN (AND (NOT (LAMBDA-P (MV-CALL-FN NODE)))
+              (NOT (CALLER-NOT-INLINE NODE)))                (IL:* IL:\; 
+                                "The body of the lambda won't be eval'd until after the arguments.")
+       (MSUBST (MV-CALL-FN NODE)))
+   (META-SUBST-ANY-CALL NODE (MV-CALL-FN NODE)
+          (MV-CALL-ARG-EXPRS NODE)))
+
+(DEFUN META-SUBST-MV-PROG1 (NODE)
+   (DESTRUCTURING-BIND (VALUES-STMT . EFFECT-STMTS)
+          (MV-PROG1-STMTS NODE)
+          (MSUBST VALUES-STMT)
+          (WHEN (NULL (NODE-META-P VALUES-STMT))
+              (SETF (NODE-META-P NODE)
+                    NIL))
+          (WHEN (PASSABLE *SUBST-EXPR* VALUES-STMT)
+              (SETQ EFFECT-STMTS (META-SUBST-STMTS NODE EFFECT-STMTS NIL)))
+          (SETF (MV-PROG1-STMTS NODE)
+                (CONS VALUES-STMT EFFECT-STMTS)))
+   NODE)
+
+(DEFUN META-SUBST-OPCODES (NODE)
+   NODE)
+
+(DEFUN META-SUBST-PROGN (NODE)
+   (SETF (PROGN-STMTS NODE)
+         (META-SUBST-STMTS NODE (PROGN-STMTS NODE)
+                T))
+   NODE)
+
+(DEFUN META-SUBST-PROGV (NODE)                           (IL:* IL:\; "")
+   (MSUBST (PROGV-SYMS-EXPR NODE))
+   (WHEN (PASSABLE (PROGV-SYMS-EXPR NODE)
+                *SUBST-EXPR*)
+       (MSUBST (PROGV-VALS-EXPR NODE))
+       (WHEN (PASSABLE (PROGV-VALS-EXPR NODE)
+                    *SUBST-EXPR*)
+           (MSUBST (PROGV-STMT NODE))))
+   (WHEN (OR (NULL (NODE-META-P (PROGV-SYMS-EXPR NODE)))
+             (NULL (NODE-META-P (PROGV-VALS-EXPR NODE)))
+             (NULL (NODE-META-P (PROGV-STMT NODE))))
+       (SETF (NODE-META-P NODE)
+             NIL))
+   NODE)
+
+(DEFUN META-SUBST-RETURN (NODE)
+   (MSUBST (RETURN-VALUE NODE))
+   (WHEN (NULL (NODE-META-P (RETURN-VALUE NODE)))
+       (SETF (NODE-META-P NODE)
+             NIL))
+   NODE)
+
+(DEFUN META-SUBST-SETQ (NODE)
+
+(IL:* IL:|;;;| "Someday, the SETQ removal code will make this method more substantial.")
+
+   (MSUBST (SETQ-VALUE NODE))
+   (WHEN (NULL (NODE-META-P (SETQ-VALUE NODE)))
+       (SETF (NODE-META-P NODE)
+             NIL))
+   NODE)
+
+(DEFUN META-SUBST-TAGBODY (NODE)
+
+(IL:* IL:|;;;| "Because we don't do enough flow-analysis (or any, really), we can only safely substitute literals into loops.  Even variables are unsafe since they could be SETQ'd later in the loop.  We decide that we may be in a loop when we encounter a segment with a non-empty list of tags.")
+
+   (DOLIST (SEGMENT (TAGBODY-SEGMENTS NODE))
+       (UNLESS (OR (LITERAL-P *SUBST-EXPR*)
+                   (NULL (SEGMENT-TAGS SEGMENT)))
+              (RETURN))
+       (MULTIPLE-VALUE-BIND (STMTS PASSABLE?)
+              (META-SUBST-STMTS NODE (SEGMENT-STMTS SEGMENT)
+                     NIL)
+              (SETF (SEGMENT-STMTS SEGMENT)
+                    STMTS)
+              (UNLESS PASSABLE? (RETURN))))
+   NODE)
+
+(DEFUN META-SUBST-THROW (NODE)                           (IL:* IL:\; "")
+   (MSUBST (THROW-TAG NODE))
+   (WHEN (PASSABLE *SUBST-EXPR* (THROW-TAG NODE))
+       (MSUBST (THROW-VALUE NODE)))
+   (WHEN (OR (NULL (NODE-META-P (THROW-TAG NODE)))
+             (NULL (NODE-META-P (THROW-VALUE NODE))))
+       (SETF (NODE-META-P NODE)
+             NIL))
+   NODE)
+
+(DEFUN META-SUBST-UNWIND-PROTECT (NODE)
+
+(IL:* IL:|;;;| "This is fucked up because of the fact that the components of UNWIND-PROTECT's are stored as LAMBDA's prematurely.")
+
+   (MSUBST (UNWIND-PROTECT-STMT NODE))
+   (WHEN (PASSABLE *SUBST-EXPR* (UNWIND-PROTECT-STMT NODE))
+       (MSUBST (UNWIND-PROTECT-CLEANUP NODE)))
+   (WHEN (OR (NULL (NODE-META-P (UNWIND-PROTECT-STMT NODE)))
+             (NULL (NODE-META-P (UNWIND-PROTECT-CLEANUP NODE))))
+       (SETF (NODE-META-P NODE)
+             NIL))
+   NODE)
+
+(DEFUN META-SUBST-VAR-REF (NODE)
+   (IF (AND (EQ *SUBST-VAR* (VAR-REF-VARIABLE NODE))
+            (NOT (MEMBER (NODE-META-P NODE)
+                        '(:MV :RETURN))))
+       (LET ((NEW-CODE (COPY-CODE *SUBST-EXPR*)))
+            (RELEASE-TREE NODE)
+            (SETF (NODE-SUBST-P *SUBST-EXPR*)
+                  T)
+            (SETQ *SUBST-OCCURRED* T)
+            NEW-CODE)
+       NODE))
+
+(DEFUN META-SUBST-ANY-CALL (NODE FN ARGS)
+
+(IL:* IL:|;;;| "Common code between CALL and MV-CALL")
+
+   (WHEN (PASSABLE *SUBST-EXPR* FN)
+
+       (IL:* IL:|;;| "This can avoid being the case when the function is computed, for example by function call.  Remember, CALL nodes are used for uses of FUNCALL in the source, as well as in other cases.")
+
+       (DO ((TAIL ARGS (CDR TAIL)))
+           ((NULL TAIL)
+            (WHEN (LAMBDA-P FN)
+
+                (IL:* IL:|;;| "Finally it's time to substitute inside the lambda.")
+
+                (META-SUBST-LAMBDA FN T)))
+
+         (IL:* IL:|;;| "Substitute into each argument and see if we can go further.")
+
+         (MSUBST (CAR TAIL))
+         (WHEN (NOT (PASSABLE *SUBST-EXPR* (CAR TAIL)))  (IL:* IL:\; 
+                                                           "Can't go beyond this argument.")
+             (RETURN))))
+
+   (IL:* IL:|;;| "Keep the META-P information up to date.")
+
+   (WHEN (OR (NULL (NODE-META-P FN))
+             (NOTEVERY #'NODE-META-P ARGS))
+       (SETF (NODE-META-P NODE)
+             NIL))
+   NODE)
+
+(DEFUN META-SUBST-STMTS (NODE STMTS-LIST FINAL-STMT-IMMOVABLE)
+
+(IL:* IL:|;;;| 
+"Common code between all of the too-many PROGN-like structures (PROGN, MV-PROG1, TAGBODY).")
+
+(IL:* IL:|;;;| "The idea here is that we can reorder the nodes in the list as long as the side-effects analysis permits.  We will partition the already-processed nodes into two sets, named after their counterparts in the S-1 compiler: WINNERS and BARRIERS.  BARRIERS are nodes that are not PASSABLE with the *SUBST-EXPR*.  For each node we process, we try to bring it past all of the BARRIERS.  If we succeed, then we can substitute into it.  Afterwards, if the node is PASSABLE with *SUBST-EXPR*, it goes on the WINNERS list; otherwise, it gets put onto BARRIERS at the end closer to the front of the stmts list.")
+
+(IL:* IL:|;;;| 
+"Before processing node A:                        || WINNERS || BARRIERS || A | OTHERS ||")
+
+(IL:* IL:|;;;| 
+"If can't pass all BARRIERS:                       || WINNERS || BARRIERS | A || OTHERS ||")
+
+(IL:* IL:|;;;| 
+"If passes all BARRIERS and is itself passable:  || WINNERS | A || BARRIERS || OTHERS ||")
+
+(IL:* IL:|;;;| 
+"If passes all BARRIERS but not itself passable: || WINNERS || A | BARRIERS || OTHERS ||")
+
+(IL:* IL:|;;;| "The lists WINNERS and BARRIERS are kept in reverse order, with the CAR being closer to the end of the stmts list.")
+
+(IL:* IL:|;;;| "We return the new, possibly-permuted stmts list.  Just for META-SUBST-TAGBODY, if there were no barriers (i.e., the whole stmts list is passable) we return a second value of T.  The given NODE has its META-P field set to NIL if anything changes under here.")
+
+   (LET (NEW-STMTS-LIST)
+        (DO ((TAIL STMTS-LIST (CDR TAIL))
+             (WINNERS NIL)
+             (BARRIERS NIL))
+
+            (IL:* IL:|;;| "In some cases (notably PROGN), the final stmt is not movable.")
+
+            ((NULL (IF FINAL-STMT-IMMOVABLE
+                       (CDR TAIL)
+                       TAIL))
+             (WHEN (AND TAIL (NULL BARRIERS))
+                 (MSUBST (CAR TAIL))
+                 (WHEN (NULL (NODE-META-P (CAR TAIL)))
+                     (SETF (NODE-META-P NODE)
+                           NIL)))
+             (RETURN (VALUES (NCONC (REVERSE WINNERS)
+                                    (REVERSE BARRIERS)
+                                    TAIL)
+                            (NULL BARRIERS))))
+
+          (IL:* IL:|;;| "For each stmt, see if we can get it past all of the barriers.")
+
+          (COND
+             ((EVERY #'(LAMBDA (BARRIER)
+                              (PASSABLE (CAR TAIL)
+                                     BARRIER))
+                     BARRIERS)
+
+              (IL:* IL:|;;| "We got past the barriers.")
+
+              (LET (OUTER-S-O)
+                   (LET ((*SUBST-OCCURRED* NIL))
+                        (MSUBST (CAR TAIL))
+                        (SETQ OUTER-S-O *SUBST-OCCURRED*)
+
+                        (IL:* IL:|;;| "We made a change here if either we've permuted some stmts or a substitution was made inside the node.")
+
+                        (COND
+                           ((PASSABLE (CAR TAIL)
+                                   *SUBST-EXPR*)
+                            (PUSH (CAR TAIL)
+                                  WINNERS)
+                            (WHEN (OR BARRIERS *SUBST-OCCURRED*)
+                                (SETF (NODE-META-P NODE)
+                                      NIL)))
+                           (*SUBST-OCCURRED* (SETQ BARRIERS (NCONC BARRIERS (LIST (CAR TAIL))))
+                                  (SETF (NODE-META-P NODE)
+                                        NIL))
+                           (T 
+                              (IL:* IL:|;;| 
+              "Nothing happened and this one's not a winner, so don't make any gratuitous changes.")
+
+                              (PUSH (CAR TAIL)
+                                    BARRIERS))))
+
+                   (IL:* IL:|;;| "Pass on the fact that a substitution happened below here.")
+
+                   (WHEN OUTER-S-O (SETQ *SUBST-OCCURRED* OUTER-S-O))))
+             (T 
+                (IL:* IL:|;;| "We couldn't get past the barriers.")
+
+                (PUSH (CAR TAIL)
+                      BARRIERS))))))
+
+
+
+(IL:* IL:|;;| "Testing meta-evaluation")
+
+
+(DEFUN TEST-META-EVAL (FN)
+   (LET ((TREE (TEST-ALPHA-2 FN)))
+        (UNWIND-PROTECT
+            (PRINT-TREE (META-EVALUATE TREE))
+            (RELEASE-TREE TREE))))
+
+
+
+(IL:* IL:|;;| "Arrange to use the correct compiler")
+
+
+(IL:PUTPROPS IL:XCLC-META-EVAL IL:FILETYPE COMPILE-FILE)
+
+
+
+(IL:* IL:|;;| "Arrange for the proper makefile-environment")
+
+
+(IL:PUTPROPS IL:XCLC-META-EVAL IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE
+                                                                      (DEFPACKAGE "COMPILER"
+                                                                             (:USE "LISP" "XCL"))))
+(IL:PUTPROPS IL:XCLC-META-EVAL IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1991
+ 1992 1993))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/XCLC-META-EVAL.LCOM b/CLTL2/XCLC-META-EVAL.LCOM
new file mode 100644
index 00000000..36c01622
Binary files /dev/null and b/CLTL2/XCLC-META-EVAL.LCOM differ
diff --git a/CLTL2/XCLC-OPTIMIZERS b/CLTL2/XCLC-OPTIMIZERS
new file mode 100644
index 00000000..79c86200
--- /dev/null
+++ b/CLTL2/XCLC-OPTIMIZERS
@@ -0,0 +1,450 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL")))
+(IL:FILECREATED "18-Oct-93 17:19:21" "{Pele:mv:envos}<LispCore>Sources>CLTL2>XCLC-OPTIMIZERS.;2" 18825  
+
+      IL:|previous| IL:|date:| " 4-Feb-92 10:31:17" 
+"{Pele:mv:envos}<LispCore>Sources>CLTL2>XCLC-OPTIMIZERS.;1")
+
+
+; Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:XCLC-OPTIMIZERSCOMS)
+
+(IL:RPAQQ IL:XCLC-OPTIMIZERSCOMS
+          (
+
+(IL:* IL:|;;;| "Compiler optimizers")
+
+           (IL:DEFINE-TYPES OPTIMIZERS)
+           (IL:FUNCTIONS OPTIMIZER-LIST)
+           (IL:PROP IL:PROPTYPE OPTIMIZER-LIST)
+           (IL:FUNCTIONS DEFOPTIMIZER)
+           
+           (IL:* IL:|;;| "Random optimizers defined within the compiler.")
+
+           (OPTIMIZERS CAAAAR CAAADR CAAAR CAADAR CAADDR CAADR CAAR CADAAR CADADR CADAR CADDAR CADDDR
+                  CADDR CADR CDAAAR CDAADR CDAAR CDADAR CDADDR CDADR CDAR CDDAAR CDDADR CDDAR CDDDAR
+                  CDDDDR CDDDR CDDR)
+           (OPTIMIZERS (IL:ARG :OPTIMIZED-BY CONVERT-ARG-TO-\\ARG)
+                  (IL:SETARG :OPTIMIZED-BY CONVERT-SETARG-TO-\\SETARG))
+           (OPTIMIZERS VALUES VALUES-LIST)
+           (OPTIMIZERS IL:LOADTIMECONSTANT IL:GETD IL:FGETD IL:EVQ)
+           (OPTIMIZERS LOAD-TIME-VALUE)
+           (IL:SPECIAL-FORMS LOAD-TIME-VALUE)
+           (OPTIMIZERS EQ EQL IL:EQP EQUAL IL:EQUAL EQUALP)
+           (IL:FUNCTIONS OPTIMIZE-EQUALITY OPTIMIZE-EQL)
+           (OPTIMIZERS (MULTIPLE-VALUE-CALL :OPTIMIZED-BY SCREEN-MV-CALL)
+                  (NOT :OPTIMIZED-BY NOT-TO-IF)
+                  (NULL :OPTIMIZED-BY NULL-TO-IF))
+           (OPTIMIZERS IL:\\CALLME)
+           
+           (IL:* IL:|;;| "Optimizers for File Manager forms")
+
+           (IL:VARIABLES *INPUT-FILECOMS-VARIABLE*)
+           (OPTIMIZERS IL:RPAQ IL:RPAQ? IL:RPAQQ IL:PRETTYCOMPRINT IL:FILECREATED)
+           
+           (IL:* IL:|;;| "Other Otimization")
+
+           (OPTIMIZERS IL:\\PILOTBITBLT)
+           
+           (IL:* IL:|;;| "Use the proper makefile-environment")
+
+           (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-OPTIMIZERS)
+           
+           (IL:* IL:|;;| "Use the proper compiler.")
+
+           (IL:PROP IL:FILETYPE IL:XCLC-OPTIMIZERS)))
+
+
+
+(IL:* IL:|;;;| "Compiler optimizers")
+
+
+(DEF-DEFINE-TYPE OPTIMIZERS "Compiler optimizers")
+
+(DEFMACRO OPTIMIZER-LIST (FN)
+   `(GET ,FN 'OPTIMIZER-LIST))
+
+(IL:PUTPROPS OPTIMIZER-LIST IL:PROPTYPE IGNORE)
+
+(DEFDEFINER (DEFOPTIMIZER (:PROTOTYPE (LAMBDA (XCL::NAME)
+                                                 (IF (SYMBOLP XCL::NAME)
+                                                     `(DEFOPTIMIZER ,XCL::NAME ("Arg list")
+                                                                               "Body")
+                                                     (DESTRUCTURING-BIND
+                                                      (XCL::FORM-NAME XCL::OPTIMIZED-BY XCL::OPT-NAME
+                                                             )
+                                                      XCL::NAME
+                                                      (AND (EQ ':OPTIMIZED-BY XCL::OPTIMIZED-BY)
+                                                           (NOT (NULL XCL::OPT-NAME))
+                                                           `(DEFOPTIMIZER ,XCL::FORM-NAME
+                                                               ,XCL::OPT-NAME ("Arg list")
+                                                                     "Body"))))))
+                              (:NAME (LAMBDA (IL:WHOLE)
+                                            (LET ((IL:NAME (SECOND IL:WHOLE))
+                                                  (IL:OPT-NAME (THIRD IL:WHOLE)))
+                                                 (IF (LISTP IL:OPT-NAME)
+                                                     IL:NAME (IL:* IL:\; 
+                                                          "(defoptimizer form-name arglist . body)")
+                                                     `(,IL:NAME :OPTIMIZED-BY ,IL:OPT-NAME)
+                                                             (IL:* IL:\; 
+                                              "(defoptimizer form-name opt-name [arg-list . body])")
+                                                     ))))) OPTIMIZERS (IL:NAME IL:OPT-NAME &REST 
+                                                                             IL:ARGLIST-BODY 
+                                                                             &ENVIRONMENT IL:ENV)
+   (COND
+      ((NOT IL:ARGLIST-BODY)                                 (IL:* IL:\; 
+                                                           "(defoptimizer name optfn)")
+       `(EVAL-WHEN (EVAL COMPILE LOAD)
+               (PUSHNEW ',IL:OPT-NAME (OPTIMIZER-LIST ',IL:NAME))))
+      (T (LET* ((IL:ARG-LIST IL:OPT-NAME)
+                (IL:OPT-FN-NAME (IL:|if| (LISTP IL:OPT-NAME)
+                                    IL:|then|            (IL:* IL:\; 
+                                                          "(defoptimizer form-name arglist . body)")
+                                          (PACK (LIST "optimize-" IL:NAME)
+                                                (SYMBOL-PACKAGE IL:NAME))
+                                  IL:|else|              (IL:* IL:\; 
+                                                 "(defoptimizer form-name opt-name arglist . body)")
+                                        (IL:SETQ IL:ARG-LIST (IL:POP IL:ARGLIST-BODY))
+                                        IL:OPT-NAME)))
+               (MULTIPLE-VALUE-BIND (IL:BODY IL:DECLS IL:DOC)
+                      (IL:PARSE-DEFMACRO IL:ARG-LIST 'IL:$$WHOLE IL:ARGLIST-BODY IL:NAME IL:ENV 
+                             :ENVIRONMENT 'IL:$$ENV :CONTEXT 'IL:$$CTX)
+                      `(EVAL-WHEN (EVAL COMPILE LOAD)
+                              (SETF (SYMBOL-FUNCTION ',IL:OPT-FN-NAME)
+                                    #'(LAMBDA (IL:$$WHOLE IL:$$ENV IL:$$CTX)
+                                             ,@IL:DECLS
+                                             (BLOCK ,IL:OPT-FN-NAME ,IL:BODY)))
+                              (PUSHNEW ',IL:OPT-FN-NAME (OPTIMIZER-LIST ',IL:NAME))))))))
+
+
+
+(IL:* IL:|;;| "Random optimizers defined within the compiler.")
+
+
+(DEFOPTIMIZER CAAAAR (LISP::X)
+                         `(CAR (CAR (CAR (CAR ,LISP::X)))))
+
+(DEFOPTIMIZER CAAADR (LISP::X)
+                         `(CAR (CAR (CAR (CDR ,LISP::X)))))
+
+(DEFOPTIMIZER CAAAR (LISP::X)
+                        `(CAR (CAR (CAR ,LISP::X))))
+
+(DEFOPTIMIZER CAADAR (LISP::X)
+                         `(CAR (CAR (CDR (CAR ,LISP::X)))))
+
+(DEFOPTIMIZER CAADDR (LISP::X)
+                         `(CAR (CAR (CDR (CDR ,LISP::X)))))
+
+(DEFOPTIMIZER CAADR (LISP::X)
+                        `(CAR (CAR (CDR ,LISP::X))))
+
+(DEFOPTIMIZER CAAR (LISP::X)
+                       `(CAR (CAR ,LISP::X)))
+
+(DEFOPTIMIZER CADAAR (LISP::X)
+                         `(CAR (CDR (CAR (CAR ,LISP::X)))))
+
+(DEFOPTIMIZER CADADR (LISP::X)
+                         `(CAR (CDR (CAR (CDR ,LISP::X)))))
+
+(DEFOPTIMIZER CADAR (LISP::X)
+                        `(CAR (CDR (CAR ,LISP::X))))
+
+(DEFOPTIMIZER CADDAR (LISP::X)
+                         `(CAR (CDR (CDR (CAR ,LISP::X)))))
+
+(DEFOPTIMIZER CADDDR (LISP::X)
+                         `(CAR (CDR (CDR (CDR ,LISP::X)))))
+
+(DEFOPTIMIZER CADDR (LISP::X)
+                        `(CAR (CDR (CDR ,LISP::X))))
+
+(DEFOPTIMIZER CADR (LISP::X)
+                       `(CAR (CDR ,LISP::X)))
+
+(DEFOPTIMIZER CDAAAR (LISP::X)
+                         `(CDR (CAR (CAR (CAR ,LISP::X)))))
+
+(DEFOPTIMIZER CDAADR (LISP::X)
+                         `(CDR (CAR (CAR (CDR ,LISP::X)))))
+
+(DEFOPTIMIZER CDAAR (LISP::X)
+                        `(CDR (CAR (CAR ,LISP::X))))
+
+(DEFOPTIMIZER CDADAR (LISP::X)
+                         `(CDR (CAR (CDR (CAR ,LISP::X)))))
+
+(DEFOPTIMIZER CDADDR (LISP::X)
+                         `(CDR (CAR (CDR (CDR ,LISP::X)))))
+
+(DEFOPTIMIZER CDADR (LISP::X)
+                        `(CDR (CAR (CDR ,LISP::X))))
+
+(DEFOPTIMIZER CDAR (LISP::X)
+                       `(CDR (CAR ,LISP::X)))
+
+(DEFOPTIMIZER CDDAAR (LISP::X)
+                         `(CDR (CDR (CAR (CAR ,LISP::X)))))
+
+(DEFOPTIMIZER CDDADR (LISP::X)
+                         `(CDR (CDR (CAR (CDR ,LISP::X)))))
+
+(DEFOPTIMIZER CDDAR (LISP::X)
+                        `(CDR (CDR (CAR ,LISP::X))))
+
+(DEFOPTIMIZER CDDDAR (LISP::X)
+                         `(CDR (CDR (CDR (CAR ,LISP::X)))))
+
+(DEFOPTIMIZER CDDDDR (LISP::X)
+                         `(CDR (CDR (CDR (CDR ,LISP::X)))))
+
+(DEFOPTIMIZER CDDDR (LISP::X)
+                        `(CDR (CDR (CDR ,LISP::X))))
+
+(DEFOPTIMIZER CDDR (LISP::X)
+                       `(CDR (CDR ,LISP::X)))
+
+(DEFOPTIMIZER IL:ARG CONVERT-ARG-TO-\\ARG
+   (NAME EXPR)
+   (IF *NEW-COMPILER-IS-EXPANDING*
+       `(IL:\\ARG ',NAME ,EXPR)
+       'PASS))
+
+(DEFOPTIMIZER IL:SETARG CONVERT-SETARG-TO-\\SETARG
+   (NAME EXPR NEW-VALUE)
+   (IF *NEW-COMPILER-IS-EXPANDING*
+       `(IL:\\SETARG ',NAME ,EXPR ,NEW-VALUE)
+       'PASS))
+
+(DEFOPTIMIZER VALUES (&REST LISP::ARGS &CONTEXT LISP::CTXT)
+                         (COND
+                            ((AND LISP::ARGS (NULL (CDR LISP::ARGS)))
+                                                             (IL:* IL:\; "Throw away extra values.")
+                             `((IL:OPCODES IL:NOP)
+                               ,(CAR LISP::ARGS)))
+                            (*NEW-COMPILER-IS-EXPANDING* (CASE (CONTEXT-VALUES-USED LISP::CTXT)
+                                                             ((0) `(PROGN ,@LISP::ARGS))
+                                                             ((1) `(PROG1 ,@LISP::ARGS))
+                                                             (OTHERWISE `(IL:MISCN VALUES
+                                                                                ,@LISP::ARGS))))
+                            (T `(IL:MISCN VALUES ,@LISP::ARGS))))
+
+(DEFOPTIMIZER VALUES-LIST (LISP::ARG &CONTEXT LISP::CTXT)
+                              (IF *NEW-COMPILER-IS-EXPANDING*
+                                  (CASE (CONTEXT-VALUES-USED LISP::CTXT)
+                                      ((0) LISP::ARG)
+                                      ((1) `(CAR ,LISP::ARG))
+                                      (OTHERWISE `(IL:MISCN VALUES-LIST ,LISP::ARG)))
+                                  `(IL:MISCN VALUES-LIST ,LISP::ARG)))
+
+(DEFOPTIMIZER IL:LOADTIMECONSTANT (IL:FORM)
+
+(IL:* IL:|;;;| "The new compiler uses an unforgable data structure to mark load-time forms.  The old ByteCompiler used LOADTIMECONSTANTMARKER, a unique string.")
+
+                                      (IF *NEW-COMPILER-IS-EXPANDING*
+                                          (MAKE-EVAL-WHEN-LOAD :FORM IL:FORM)
+                                          (LIST 'QUOTE (CONS IL:LOADTIMECONSTANTMARKER IL:FORM))))
+
+(DEFOPTIMIZER IL:GETD (IL:FN &CONTEXT IL:CTXT)
+                          (IF (CONTEXT-PREDICATE-P IL:CTXT)
+                              `(IL:\\DEFINEDP ,IL:FN)
+                              'PASS))
+
+(DEFOPTIMIZER IL:FGETD (IL:FN)
+                           `(IL:GETD ,IL:FN))
+
+(DEFOPTIMIZER IL:EVQ (IL:ARG)
+                         IL:ARG)
+
+(DEFOPTIMIZER LOAD-TIME-VALUE (LISP::FORM &OPTIONAL LISP::READ-ONLY-P)
+
+                                  (IL:* IL:|;;| 
+         "Copied from IL:LOADTIMECONSTANT; they're the same thing to the PavCompiler, I believe...")
+
+                                  (IF *NEW-COMPILER-IS-EXPANDING*
+                                      (MAKE-EVAL-WHEN-LOAD :FORM LISP::FORM)
+                                      (LIST 'QUOTE (CONS IL:LOADTIMECONSTANTMARKER LISP::FORM))))
+
+(DEFINE-SPECIAL-FORM LOAD-TIME-VALUE (LISP::FORM &OPTIONAL LISP::READ-ONLY-P)
+   (EVAL LISP::FORM NIL))
+
+(DEFOPTIMIZER EQ (LISP::ONE LISP::TWO)
+                     (COND
+                        ((AND (CONSTANTP LISP::ONE)
+                              (NULL (EVAL LISP::ONE)))
+                         `(NULL ,LISP::TWO))
+                        ((AND (CONSTANTP LISP::TWO)
+                              (NULL (EVAL LISP::TWO)))
+                         `(NULL ,LISP::ONE))
+                        (T 'PASS)))
+
+(DEFOPTIMIZER EQL (&WHOLE LISP::FORM)
+                      (OPTIMIZE-EQL LISP::FORM))
+
+(DEFOPTIMIZER IL:EQP (&WHOLE IL:FORM)
+                         (OPTIMIZE-EQUALITY IL:FORM))
+
+(DEFOPTIMIZER EQUAL (&WHOLE LISP::FORM)
+                        (OPTIMIZE-EQUALITY LISP::FORM))
+
+(DEFOPTIMIZER IL:EQUAL (&WHOLE IL:FORM)
+                           (OPTIMIZE-EQUALITY IL:FORM))
+
+(DEFOPTIMIZER EQUALP (&WHOLE LISP::FORM)
+                         (OPTIMIZE-EQUALITY LISP::FORM))
+
+(DEFUN OPTIMIZE-EQUALITY (FORM)
+
+(IL:* IL:|;;;| "FORM is a call on one of the equality-testing predicates EQL, IL:EQP, EQUAL, IL:EQUAL, or EQUALP.  If one of the arguments is a literal symbol, then we can use EQ.")
+
+   (DESTRUCTURING-BIND (FN ONE TWO)
+          FORM
+          (COND
+             ((AND (CONSTANTP ONE)
+                   (SYMBOLP (EVAL ONE)))
+              `(EQ ,TWO ',(EVAL ONE)))
+             ((AND (CONSTANTP TWO)
+                   (SYMBOLP (EVAL TWO)))
+              `(EQ ,ONE ',(EVAL TWO)))
+             (T 'PASS))))
+
+(DEFUN OPTIMIZE-EQL (FORM)
+
+   (IL:* IL:|;;| "TRANSFORM to EQ if possible")
+
+   (DESTRUCTURING-BIND (FN ONE TWO)
+          FORM
+          (LET (E-ONE E-TWO)
+               (COND
+                  ((AND (CONSTANTP ONE)
+                        (OR (SYMBOLP (SETQ E-ONE (EVAL ONE)))
+                            (TYPEP E-ONE 'FIXNUM)))
+                   `(EQ ',E-ONE ,TWO))
+                  ((AND (CONSTANTP TWO)
+                        (OR (SYMBOLP (SETQ E-TWO (EVAL TWO)))
+                            (TYPEP E-TWO 'FIXNUM)))
+                   `(EQ ,ONE ',E-TWO))
+                  (T 'PASS)))))
+
+(DEFOPTIMIZER MULTIPLE-VALUE-CALL SCREEN-MV-CALL
+   (FN &BODY BODY)
+
+(IL:* IL:|;;;| "``Optimizer'' for special form MULTIPLE-VALUE-CALL - handle special case of list and let the rest turn into an APPLY")
+
+   (COND
+      ((AND (EQUAL FN '(IL:FUNCTION LIST))
+            (NULL (CDR BODY)))
+       (CONS 'IL:\\MVLIST BODY))
+      (T `(IL:APPLY ,FN (NCONC ,@(IL:FOR F IL:IN BODY IL:COLLECT
+                                                              `(MULTIPLE-VALUE-LIST ,F)))))))
+
+(DEFOPTIMIZER NOT NOT-TO-IF
+   (X)
+   (IF *NEW-COMPILER-IS-EXPANDING*
+       `(IF ,X
+            NIL
+            T)
+       'PASS))
+
+(DEFOPTIMIZER NULL NULL-TO-IF
+   (X)
+   (IF *NEW-COMPILER-IS-EXPANDING*
+       `(IF ,X
+            NIL
+            T)
+       'PASS))
+
+(DEFOPTIMIZER IL:\\CALLME (NAME &CONTEXT CTXT)
+                              (COND
+                                 ((NOT (EQL (CONTEXT-VALUES-USED CTXT)
+                                            0))
+                                  (WARN "The ~S special form appeared in non-effect context."
+                                        'IL:\\CALLME)
+                                  `(PROGN (IL:\\CALLME ,NAME)
+                                          NIL))
+                                 ((AND (NOT (CONSTANTP NAME))
+                                       (OR (ATOM NAME)
+                                           (NOT (EQ (CAR NAME)
+                                                    'QUOTE))))
+                                  (WARN "The ~S special form was given an unquoted argument."
+                                        'IL:\\CALLME)
+                                  `(IL:\\CALLME ',NAME))
+                                 (T 'PASS)))
+
+
+
+(IL:* IL:|;;| "Optimizers for File Manager forms")
+
+
+(DEFVAR *INPUT-FILECOMS-VARIABLE*
+
+(IL:* IL:|;;;| "Used for communication between the optimizers on RPAQQ and PRETTYCOMPRINT so that the file coms can be eliminated from the file during compilation.")
+
+   )
+
+(DEFOPTIMIZER IL:RPAQ (VAR EXPR &CONTEXT CTXT)
+                          (IF (CONTEXT-TOP-LEVEL-P CTXT)
+                              `(LOCALLY (DECLARE (GLOBAL ,VAR))
+                                      (SETQ ,VAR ,EXPR))
+                              'PASS))
+
+(DEFOPTIMIZER IL:RPAQ? (VAR EXPR &CONTEXT CTXT)
+                           (IF (CONTEXT-TOP-LEVEL-P CTXT)
+                               `(LOCALLY (DECLARE (GLOBAL ,VAR))
+                                       (AND (EQ ,VAR 'IL:NOBIND)
+                                            (SETQ ,VAR ,EXPR)))
+                               'PASS))
+
+(DEFOPTIMIZER IL:RPAQQ (VAR EXPR &CONTEXT CTXT)
+                           (IF (CONTEXT-TOP-LEVEL-P CTXT)
+                               `(LOCALLY (DECLARE (GLOBAL ,VAR))
+                                       (SETQ ,VAR ',EXPR))
+                               'PASS))
+
+(DEFOPTIMIZER IL:PRETTYCOMPRINT (COMS-NAME &CONTEXT CTXT)
+                                    (COND
+                                       ((CONTEXT-TOP-LEVEL-P CTXT)
+                                        NIL)
+                                       (T 'PASS)))
+
+(DEFOPTIMIZER IL:FILECREATED (FILEDATE FILENAME &REST JUNK &CONTEXT CTXT)
+                                 (DECLARE (IGNORE JUNK))
+                                 (IF (AND (CONTEXT-TOP-LEVEL-P CTXT)
+                                          FILENAME
+                                          (SYMBOLP FILENAME))
+                                     `(IL:PUTPROP ',(IL:ROOTFILENAME FILENAME)
+                                             'IL:FILEDATES
+                                             '(,(CONS FILEDATE FILENAME)))
+                                     'PASS))
+
+
+
+(IL:* IL:|;;| "Other Otimization")
+
+
+(DEFOPTIMIZER IL:\\PILOTBITBLT (&REST IL:ARGS)
+                                   (IF (AND IL:ARGS (NULL (CDR IL:ARGS)))
+                                       `(IL:\\PILOTBITBLT ,@IL:ARGS NIL)
+                                       'PASS))
+
+
+
+(IL:* IL:|;;| "Use the proper makefile-environment")
+
+
+(IL:PUTPROPS IL:XCLC-OPTIMIZERS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE
+                                                                       (DEFPACKAGE "COMPILER"
+                                                                              (:USE "LISP" "XCL"))))
+
+
+
+(IL:* IL:|;;| "Use the proper compiler.")
+
+
+(IL:PUTPROPS IL:XCLC-OPTIMIZERS IL:FILETYPE :COMPILE-FILE)
+(IL:PUTPROPS IL:XCLC-OPTIMIZERS IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 
+1991 1992 1993))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/XCLC-OPTIMIZERS.DFASL b/CLTL2/XCLC-OPTIMIZERS.DFASL
new file mode 100644
index 00000000..4e73c314
Binary files /dev/null and b/CLTL2/XCLC-OPTIMIZERS.DFASL differ
diff --git a/CLTL2/XCLC-PEEPHOLE b/CLTL2/XCLC-PEEPHOLE
new file mode 100644
index 00000000..c2f960b0
--- /dev/null
+++ b/CLTL2/XCLC-PEEPHOLE
@@ -0,0 +1,475 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL")))
+(IL:FILECREATED "13-Oct-93 17:36:04" "{Pele:mv:envos}<LispCore>Sources>CLTL2>XCLC-PEEPHOLE.;1" 23903  
+
+      IL:|changes| IL:|to:|  (IL:FUNCTIONS PEEPHOLE-OPTIMIZE PEEPHOLE-OPTIMIZE-CODE)
+
+      IL:|previous| IL:|date:| "16-Aug-91 18:52:23" 
+IL:|{DSK}<mo>usr>users>sybalsky>cltl2>sources>XCLC-PEEPHOLE.;1|)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1993 by Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:XCLC-PEEPHOLECOMS)
+
+(IL:RPAQQ IL:XCLC-PEEPHOLECOMS
+          (
+
+(IL:* IL:|;;;| "Peephole Optimization")
+
+           (IL:VARIABLES *REACHABLE-TAG-TABLE* *TAG-EQUIV-TABLE* *TAG-LOCATION-TABLE*)
+           (IL:FUNCTIONS PEEPHOLE-OPTIMIZE FIND-ALL-TAGS FIND-REACHABLE-TAGS FIND-TAG-DUPLICATION 
+                  PEEPHOLE-OPTIMIZE-CODE)
+           
+           (IL:* IL:|;;| "Arrange to use the proper compiler")
+
+           (IL:PROP IL:FILETYPE IL:XCLC-PEEPHOLE)
+           
+           (IL:* IL:|;;| "Get the right reader environment")
+
+           (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-PEEPHOLE)))
+
+
+
+(IL:* IL:|;;;| "Peephole Optimization")
+
+
+(DEFVAR *REACHABLE-TAG-TABLE* NIL
+
+(IL:* IL:|;;;| "A hash-table of those tags that are reachable during execution.  See FIND-REACHABLE-TAGS for details.")
+
+   )
+
+(DEFVAR *TAG-EQUIV-TABLE* NIL
+
+(IL:* IL:|;;;| "Hash table mapping LAP tag identifiers into one of two things: 1) the keyword :REFERENCES paired with a list of the jump and push-tag instructions referring to this tag, or 2) the keyword :EQUIV paired with the identifier of the representative of the tags equivalent to this one.  Used in the current, ad hoc peephole-optimizer.")
+
+   )
+
+(DEFVAR *TAG-LOCATION-TABLE* NIL
+
+(IL:* IL:|;;;| "A hash-table mapping tag identifiers into the tails of code beginning with them.")
+
+   )
+
+(DEFUN PEEPHOLE-OPTIMIZE (LAP-FN)
+
+   (IL:* IL:|;;| 
+ "Extremely ad-hoc peephole optimizer for LAP code.  It currently has two obligations:")
+
+   (IL:* IL:|;;| "   -- Eliminate jumps to the very next location.  Those screw up the jump-resolution algorithm in the D-machine assembler.")
+
+   (IL:* IL:|;;| "   -- Eliminate unreachable code.  This is necessary to make keep stack-analysis from barfing during assembly.")
+
+   (IL:* IL:|;;| "")
+
+   (IL:* IL:|;;| "First, optimize any local functions (e.g. FLET, LABELS, etc.):")
+
+   (DESTRUCTURING-BIND ((REQUIRED &KEY OPTIONAL REST KEY ALLOW-OTHER-KEYS OTHERS NAME ARG-TYPE BLIP 
+                               CLOSED-OVER NON-LOCAL LOCAL-FUNCTIONS)
+                        &REST BODY)
+          (CDR LAP-FN)
+          (IL:FOR LOCAL-FN IL:IN LOCAL-FUNCTIONS IL:DO (PEEPHOLE-OPTIMIZE
+                                                                    (CADR LOCAL-FN))))
+
+   (IL:* IL:|;;| "Now peephole-optimize the main-body code for this function:")
+
+   (LET ((*TAG-EQUIV-TABLE* (MAKE-HASH-TABLE :TEST 'EQL))
+         (*REACHABLE-TAG-TABLE* (MAKE-HASH-TABLE :TEST 'EQL))
+         (TAGS-USED NIL))
+        (DECLARE (SPECIAL TAGS-USED))
+        (FIND-REACHABLE-TAGS (CDDR LAP-FN))
+        (MULTIPLE-VALUE-BIND (NEW-CODE CHANGED-P)
+               (PEEPHOLE-OPTIMIZE-CODE (CDDR LAP-FN))
+               (SETF (CDDR LAP-FN)
+                     NEW-CODE)
+               (SETQ TAGS-USED NIL)
+               (IF CHANGED-P
+                   (PEEPHOLE-OPTIMIZE LAP-FN)
+                   LAP-FN))))
+
+(DEFUN FIND-ALL-TAGS (CODE)
+   (DO* ((TAIL CODE (CDR TAIL))
+         (INST (CAR TAIL)
+               (CAR TAIL)))
+        ((ENDP TAIL))
+
+      (IL:* IL:|;;| "")
+
+      (CASE (CAR INST)
+          ((:TAG) (SETF (GETHASH (SECOND INST)
+                               *TAG-LOCATION-TABLE*)
+                        TAIL))
+          ((:CLOSE :LAMBDA) (FIND-ALL-TAGS (CDDR INST)))
+          ((:CALL) (LET ((FN-TO-CALL (SECOND INST)))
+                        (WHEN (AND (CONSP FN-TO-CALL)
+                                   (EQ (FIRST FN-TO-CALL)
+                                       :LAMBDA))
+                            (FIND-ALL-TAGS (CDDR FN-TO-CALL))))))))
+
+(DEFUN FIND-REACHABLE-TAGS (CODE)
+
+(IL:* IL:|;;;| "A tag is reachable if and only if")
+
+(IL:* IL:|;;;| 
+"   -- It lies in the direct path of execution, starting at the first instruction in CODE.")
+
+(IL:* IL:|;;;| "   -- It is reachable from the beginning of the inner code of a reachable :CLOSE or :LAMBDA instruction.")
+
+(IL:* IL:|;;;| "   -- It is the object of a reachable :PUSH-TAG instruction.")
+
+   (LET ((*TAG-LOCATION-TABLE* (MAKE-HASH-TABLE :TEST 'EQL)))
+        (FIND-ALL-TAGS CODE)
+        (DO ((ROOTS (LIST CODE)))
+            ((NULL ROOTS))
+
+          (IL:* IL:|;;| "For each root found, seek out tags reachable form that root.")
+
+          (ASSERT (NOT (NULL (FIRST ROOTS)))
+                 NIL "A tag was referred to but not found.")
+          (DOLIST (INST (POP ROOTS))
+              (CASE (FIRST INST)
+                  ((:TAG)                                    (IL:* IL:\; 
+                    "This is a reachable tag.  If we already knew that, stop here.  Else, mark it.")
+                     (IF (GETHASH (SECOND INST)
+                                *REACHABLE-TAG-TABLE*)
+                         (RETURN)
+                         (SETF (GETHASH (SECOND INST)
+                                      *REACHABLE-TAG-TABLE*)
+                               T)))
+                  ((:JUMP :TJUMP :FJUMP :NTJUMP :NFJUMP :PUSH-TAG) 
+                                                             (IL:* IL:\; "The object of the instruction is reachable, so add it to the list of roots and keep seeking from this root.")
+                     (LET ((NEW-ROOT (GETHASH (SECOND INST)
+                                            *TAG-LOCATION-TABLE*)))
+                          (ASSERT (NOT (NULL NEW-ROOT))
+                                 NIL "The tag ~S was referred to but not found." (SECOND INST))
+                          (PUSH NEW-ROOT ROOTS))
+                     (WHEN (EQ (FIRST INST)
+                               :JUMP)
+                           (RETURN)))
+                  ((:RETURN)                                 (IL:* IL:\; 
+                                             "No more reachable tags from this root, so stop here.")
+                     (RETURN))
+                  ((:CLOSE :LAMBDA)                          (IL:* IL:\; 
+                                            "Add the body of the instruction to the list of roots.")
+                     (PUSH (CDDR INST)
+                           ROOTS))
+                  ((:CALL) (LET ((FN-TO-CALL (SECOND INST)))
+                                (WHEN (AND (CONSP FN-TO-CALL)
+                                           (EQ (FIRST FN-TO-CALL)
+                                               :LAMBDA))     (IL:* IL:\; 
+                                 "Add the body of the directly called lambda to the list of roots.")
+                                    (PUSH (CDDR FN-TO-CALL)
+                                          ROOTS)))))))))
+
+(DEFUN FIND-TAG-DUPLICATION (CODE)
+   (LET ((NEW-CODE NIL)
+         (FIND-P NIL)
+         INST)
+        (IL:FOR TAIL IL:ON CODE IL:EACHTIME (SETQ INST (CAR TAIL))
+           IL:DO 
+
+                 (IL:* IL:|;;| "Check for unreachable code.")
+
+                 (UNLESS (AND (IL:FMEMB (FIRST (FIRST NEW-CODE))
+                                     '(:JUMP :RETURN))
+                              (NOT (AND (EQ (FIRST INST)
+                                            :TAG)
+                                        (GETHASH (SECOND INST)
+                                               *REACHABLE-TAG-TABLE*))))
+                     (CASE (FIRST INST)
+                         ((:TAG) 
+                            (IF (EQ (FIRST (FIRST NEW-CODE))
+                                    :TAG)
+                                (PROGN (SETQ FIND-P T)
+                                       (RETURN)))
+                            (PUSH INST NEW-CODE))
+                         ((:CLOSE :LAMBDA) 
+                            (SETQ FIND-P (FIND-TAG-DUPLICATION (CDDR INST)))
+                            (PUSH INST NEW-CODE))
+                         ((:CALL) (LET ((FN-TO-CALL (SECOND INST)))
+                                       (WHEN (AND (CONSP FN-TO-CALL)
+                                                  (EQ (FIRST FN-TO-CALL)
+                                                      :LAMBDA))
+                                           (SETQ FIND-P (FIND-TAG-DUPLICATION (CDDR INST)))
+                                           (PUSH INST NEW-CODE))))
+                         (OTHERWISE (PUSH INST NEW-CODE)))))
+        FIND-P))
+
+(DEFUN PEEPHOLE-OPTIMIZE-CODE (CODE)
+
+(IL:* IL:|;;;| "Run through the given code collapsing adjacent TAGs into a single one and eliminating jumps to immediately following TAGs.  Also eliminate code that cannot be reached.  Return the new version of the code.")
+
+   (LET
+    ((NEW-CODE NIL)
+     (CHANGED-P NIL)
+     (TAG-DUPLICATED-P (FIND-TAG-DUPLICATION CODE))
+     INST)
+    (IL:FOR TAIL IL:ON CODE IL:EACHTIME (SETQ INST (CAR TAIL))
+       IL:DO
+
+       (IL:* IL:|;;| "Check for unreachable code.")
+
+       (IL:* IL:|;;| "Code is unreachable if the last instruction was a JUMP or RETURN, and the next thing coming isn't a TAG that is reachable from somewhere else.")
+
+       (IL:* IL:|;;| " (If dead code is removed here, that's worth a CHANGED-P indication)")
+
+       (UNLESS (AND (IL:FMEMB (FIRST (FIRST NEW-CODE))
+                           '(:JUMP :RETURN))
+                    (NOT (AND (EQ (FIRST INST)
+                                  :TAG)
+                              (GETHASH (SECOND INST)
+                                     *REACHABLE-TAG-TABLE*)))
+                    (SETQ CHANGED-P T))
+           (CASE (FIRST INST)
+               ((:JUMP :TJUMP :FJUMP :NTJUMP :NFJUMP :PUSH-TAG) 
+                  (LET ((LOOKUP (GETHASH (SECOND INST)
+                                       *TAG-EQUIV-TABLE*)))
+                       (PUSH INST NEW-CODE)
+                       (ECASE (CAR LOOKUP)
+                           ((NIL)                            (IL:* IL:\; "This tag is not yet in the table. Put it in there mapping to a list of references including only this one.")
+                              (PUSHNEW (SECOND INST)
+                                     TAGS-USED)
+                              (SETF (GETHASH (SECOND INST)
+                                           *TAG-EQUIV-TABLE*)
+                                    (CONS :REFERENCES (LIST INST))))
+                           ((:REFERENCES)                    (IL:* IL:\; 
+   "We haven't seen the TAG for this reference yet.  Add it to the list of references to that tag.")
+                              (PUSHNEW (SECOND INST)
+                                     TAGS-USED)
+                              (PUSH INST (CDR LOOKUP)))
+                           ((:EQUIV)                         (IL:* IL:\; 
+                                            "We know what the right tag for this reference is now.")
+                              (PUSHNEW (CDR LOOKUP)
+                                     TAGS-USED)
+                              (SETF (SECOND INST)
+                                    (CDR LOOKUP))))))
+               ((:TAG) 
+                  (LET ((LOOKUP (GETHASH (SECOND INST)
+                                       *TAG-EQUIV-TABLE*)))
+                       (IF (EQ (FIRST (FIRST NEW-CODE))
+                               :TAG)
+                           (PROGN 
+                                  (IL:* IL:|;;| "Mark this tag in the table as being equivalent either to the directly previous tag, if any, or to itself.")
+
+                                  (SETF (GETHASH (SECOND INST)
+                                               *TAG-EQUIV-TABLE*)
+                                        (CONS :EQUIV (SECOND (FIRST NEW-CODE))))
+                                  (PUSHNEW (SECOND (FIRST NEW-CODE))
+                                         TAGS-USED)
+
+                                  (IL:* IL:|;;| 
+      "If there were forward references to this tag, update all of them to refer to the EQUIV-TAG.")
+
+                                  (IF (EQ (CAR LOOKUP)
+                                          :REFERENCES)
+                                      (IL:FOR REFERENCE IL:IN (CDR LOOKUP)
+                                         IL:DO (SETF (SECOND REFERENCE)
+                                                         (SECOND (FIRST NEW-CODE))))
+                                      (ASSERT (NULL LOOKUP)
+                                             NIL "This tag has been seen before!"))
+                                  (SETQ CHANGED-P T))
+                           (COND
+                              ((AND (NOT TAG-DUPLICATED-P)
+                                    (EQ (FIRST (SECOND TAIL))
+                                        :JUMP))
+                               (SETF (GETHASH (SECOND INST)
+                                            *TAG-EQUIV-TABLE*)
+                                     (CONS :EQUIV (SECOND (SECOND TAIL))))
+                               (IF (EQ (CAR LOOKUP)
+                                       :REFERENCES)
+                                   (IL:FOR REFERENCE IL:IN (CDR LOOKUP)
+                                      IL:DO (WHEN (NOT (EQL (SECOND REFERENCE)
+                                                                (SECOND (SECOND TAIL))))
+                                                    (SETF (SECOND REFERENCE)
+                                                          (SECOND (SECOND TAIL)))
+                                                    (SETQ CHANGED-P T))))
+                               (PUSH INST NEW-CODE))
+                              (T (SETF (GETHASH (SECOND INST)
+                                              *TAG-EQUIV-TABLE*)
+                                       (CONS :EQUIV (SECOND INST)))
+                                 (IF (EQ (CAR LOOKUP)
+                                         :REFERENCES)
+                                     (IL:FOR REFERENCE IL:IN (CDR LOOKUP)
+                                        IL:DO (SETF (SECOND REFERENCE)
+                                                        (SECOND INST)))
+                                     (ASSERT (NULL LOOKUP)
+                                            NIL "This tag has been seen before!"))
+                                 (PUSH INST NEW-CODE)))))
+
+                  (IL:* IL:|;;| "If the next instruction is not a :TAG, then it's time to check for useless jumps and to eliminate them.")
+
+                  (WHEN (OR (NULL (CDR TAIL))
+                            (NOT (EQ (FIRST (CDR TAIL))
+                                     :TAG)))
+                      (LOOP 
+                            (IL:* IL:|;;| 
+                          "Repeatedly examine the top 2 or 3 instructions, looking for sequences")
+
+                            (IL:* IL:|;;| "     JUMP x - TAG x   or")
+
+                            (IL:* IL:|;;| "     JUMP x - SET-STACK - TAG x")
+
+                            (IL:* IL:|;;| "     cJUMP x - JUMP y - TAG x")
+
+                            (IL:* IL:|;;| 
+                          "and reducing them to just the TAG, with a POP if need be.")
+
+                            (LET ((TAG-INST (FIRST NEW-CODE))
+                                  (JUMP-INST (SECOND NEW-CODE))
+                                  (SET-STACK-INST (THIRD NEW-CODE)))
+                                 (IF (EQL (SECOND TAG-INST)
+                                          (SECOND JUMP-INST))
+
+                                     (IL:* IL:|;;| "Looks like something to eliminate.")
+
+                                     (CASE (FIRST JUMP-INST)
+                                         ((:JUMP) 
+                                            (SETF (CDR NEW-CODE)
+                                                  (CDDR NEW-CODE))
+                                            (SETQ CHANGED-P T))
+                                         ((:FJUMP :TJUMP) 
+                                            (SETF (SECOND NEW-CODE)
+                                                  '(:POP))
+                                            (SETQ CHANGED-P T)
+                                            (RETURN))
+                                         ((:NTJUMP :NFJUMP) (ERROR 
+                                                       "BUG: Non-popping jump to very next location."
+                                                                   ))
+                                         (OTHERWISE 
+
+                                            (IL:* IL:|;;| 
+                                   "The instruction before the :TAG was not a jump, so do nothing.")
+
+                                            (RETURN)))
+                                     (IF (EQL (SECOND TAG-INST)
+                                              (SECOND SET-STACK-INST))
+
+                                         (IL:* IL:|;;| 
+                                       "Looks like it might be JUMP-SET-TAG or cJUMP - JUMP - TAG")
+
+                                         (COND
+                                            ((EQ (FIRST JUMP-INST)
+                                                 :DSET-STACK)
+
+                                             (IL:* IL:|;;| "YES, it's JUMP - SET - TAG")
+
+                                             (ROTATEF JUMP-INST SET-STACK-INST)
+                                             (CASE (FIRST JUMP-INST)
+                                                 ((:JUMP) 
+                                                    (SETF (CDR NEW-CODE)
+                                                          (CDDDR NEW-CODE))
+                                                    (SETQ CHANGED-P T))
+                                                 ((:FJUMP :TJUMP) 
+                                                    (SETF (SECOND NEW-CODE)
+                                                          '(:POP))
+                                                    (SETF (CDDR NEW-CODE)
+                                                          (CDDDR NEW-CODE))
+                                                    (SETQ CHANGED-P T)
+                                                    (RETURN))
+                                                 ((:NTJUMP :NFJUMP) (ERROR 
+                                                       "BUG: Non-popping jump to very next location."
+                                                                           ))
+                                                 (OTHERWISE 
+
+                                                    (IL:* IL:|;;| 
+                                   "The instruction before the :SET was not a jump, so do nothing.")
+
+                                                    (RETURN))))
+                                            ((EQ (FIRST JUMP-INST)
+                                                 :JUMP)
+
+                                             (IL:* IL:|;;| " YES, it's cJUMP - JUMP - TAG")
+
+                                             (CASE (FIRST SET-STACK-INST)
+                                                 ((:TJUMP) 
+                                                    (RPLACA JUMP-INST :FJUMP)
+                                                    (SETF (CDDR NEW-CODE)
+                                                          (CDDDR NEW-CODE))
+                                                    (SETQ CHANGED-P T))
+                                                 ((:FJUMP) 
+                                                    (RPLACA JUMP-INST :TJUMP)
+                                                    (SETF (CDDR NEW-CODE)
+                                                          (CDDDR NEW-CODE))
+                                                    (SETQ CHANGED-P T))
+                                                 (OTHERWISE 
+
+                                                    (IL:* IL:|;;| 
+                                   "The instruction before the JUMP was not a cJUMP, so do nothing")
+
+                                                    (RETURN))))
+                                            (T 
+                                               (IL:* IL:|;;| 
+                                    "The instruction before the :TAG was not a SET, so do nothing.")
+
+                                               (RETURN)))
+
+                                         (IL:* IL:|;;| "Nothing (more) to get rid of, so stop.")
+
+                                         (RETURN)))))))
+               ((:VAR) 
+
+                  (IL:* IL:|;;| "Eliminate any unnecesary POPs, e.g.:")
+
+                  (IL:* IL:|;;| "VAR_ x ; POP ;  VAR x")
+
+                  (LET ((SET-INST (SECOND NEW-CODE))
+                        (POP-INST (FIRST NEW-CODE)))
+                       (COND
+                          ((AND (EQ (FIRST POP-INST)
+                                    :POP)
+                                (EQ (FIRST SET-INST)
+                                    :VAR_)
+                                (EQL (SECOND SET-INST)
+                                     (SECOND INST)))
+                           (SETF NEW-CODE (CDR NEW-CODE))
+                           (SETQ CHANGED-P T))
+                          (T (PUSH INST NEW-CODE)))))
+               ((:CLOSE :LAMBDA) 
+                  (MULTIPLE-VALUE-BIND (CODE-SET CHANGED?)
+                         (PEEPHOLE-OPTIMIZE-CODE (CDDR INST))
+                         (SETF (CDDR INST)
+                               CODE-SET)
+                         (SETQ CHANGED-P (OR CHANGED-P CHANGED?)))
+                  (PUSH INST NEW-CODE))
+               ((:CALL) 
+                  (LET ((FN-TO-CALL (SECOND INST)))
+                       (WHEN (AND (CONSP FN-TO-CALL)
+                                  (EQ (FIRST FN-TO-CALL)
+                                      :LAMBDA))
+                           (MULTIPLE-VALUE-BIND (CODE-SET CHANGED?)
+                                  (PEEPHOLE-OPTIMIZE-CODE (CDDR FN-TO-CALL))
+                                  (SETF (CDDR FN-TO-CALL)
+                                        CODE-SET)
+                                  (SETQ CHANGED-P (OR CHANGED-P CHANGED?)))))
+                  (PUSH INST NEW-CODE))
+               (OTHERWISE (PUSH INST NEW-CODE)))))
+
+    (IL:* IL:|;;| "Now remove unused tags, and put things back into first-to-last order.")
+
+    (VALUES (NREVERSE (IL:FOR INST IL:IN NEW-CODE IL:WHEN (OR (IL:NEQ (FIRST INST)
+                                                                                 :TAG)
+                                                                          (IL:FMEMB (SECOND INST)
+                                                                                 TAGS-USED)
+                                                                          (NOT (SETQ CHANGED-P T)))
+                         IL:COLLECT INST))
+           CHANGED-P)))
+
+
+
+(IL:* IL:|;;| "Arrange to use the proper compiler")
+
+
+(IL:PUTPROPS IL:XCLC-PEEPHOLE IL:FILETYPE COMPILE-FILE)
+
+
+
+(IL:* IL:|;;| "Get the right reader environment")
+
+
+(IL:PUTPROPS IL:XCLC-PEEPHOLE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE
+                                                                     (DEFPACKAGE "COMPILER"
+                                                                            (:USE "LISP" "XCL"))))
+(IL:PUTPROPS IL:XCLC-PEEPHOLE IL:COPYRIGHT ("Xerox Corporation" 1986 1987 1988 1990 1991 1993))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/XCLC-PEEPHOLE.LCOM b/CLTL2/XCLC-PEEPHOLE.LCOM
new file mode 100644
index 00000000..628385ee
Binary files /dev/null and b/CLTL2/XCLC-PEEPHOLE.LCOM differ
diff --git a/CLTL2/XCLC-TOP-LEVEL b/CLTL2/XCLC-TOP-LEVEL
new file mode 100644
index 00000000..6d994a00
--- /dev/null
+++ b/CLTL2/XCLC-TOP-LEVEL
@@ -0,0 +1,1739 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL")))
+(IL:FILECREATED "19-Oct-93 10:41:17" "{Pele:mv:envos}<LispCore>Sources>CLTL2>XCLC-TOP-LEVEL.;2" 89121  
+
+      IL:|previous| IL:|date:| "15-Dec-92 21:18:47" 
+"{Pele:mv:envos}<LispCore>Sources>CLTL2>XCLC-TOP-LEVEL.;1")
+
+
+; Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:XCLC-TOP-LEVELCOMS)
+
+(IL:RPAQQ IL:XCLC-TOP-LEVELCOMS
+          (
+           (IL:* IL:|;;| "Top-level entry points")
+
+           (IL:STRUCTURES COMPILER-CONTEXT)
+           (IL:VARIABLES *COMPILE-FILE-CONTEXT* *COMPILE-SCAN-CONTEXT* *COMPILE-DEFINER-CONTEXT*)
+           (IL:FUNCTIONS COMPILER-ERROR)
+           (IL:FUNCTIONS COMPILER-APPLY)
+           (IL:FUNCTIONS COMPILER-WARNING COMPILER-CERROR BUMP-DIAGNOSTIC-COUNT COMPILATION-VALUES)
+           (IL:FUNCTIONS WITH-COMPILATION-UNIT)
+           (IL:VARIABLES *EVAL-WHEN-COMPILE* *FASL-HANDLE* *INPUT-FILENAME* *INPUT-STREAM* 
+                  *LAP-STREAM* *LOAD-COMPILED-CODE* *NEW-COMPILER-IS-EXPANDING* 
+                  *OUTSTANDING-LOOSE-FORMS* *COMPILING-DEFINER* *LOOSE-NAME* *COMPILE-VERBOSE* 
+                  *COMPILE-PRINT* *ANY-DIAGNOSTICS* *ANY-SERIOUS-DIAGNOSTICS*)
+           (IL:VARIABLES *COMPILE-FILE-PATHNAME* *COMPILE-FILE-TRUENAME*)
+           (IL:FUNCTIONS COMPILE-FILE COMPILE-FILE-PATHNAME)
+           (IL:FUNCTIONS START-COMPILATION FINISH-COMPILATION)
+           (IL:FUNCTIONS SCAN-ONE-FORM FUNCTION-P)
+           (IL:FUNCTIONS COMPILER-MESSAGE COMPILING-MESSAGE DONE-MESSAGE)
+           (IL:COMS (IL:STRUCTURES STYLE-WARNING UNKNOWN-FUNCTION-WARNING)
+                  (IL:FUNCTIONS STYLE-WARN CHECK-FOR-UNKNOWN-FUNCTION CHECK-FOR-UNKNOWN-SETF 
+                         WARN-ABOUT-UNKNOWN-FUNCTIONS))
+           (IL:VARIABLES *PROCESSED-FUNCTIONS* *UNKNOWN-FUNCTIONS* *CURRENT-FUNCTION*)
+           (IL:COMS (IL:STRUCTURES ASSEMBLER-ERROR)
+                  (IL:FUNCTIONS ASSEMBLER-ERROR))
+           
+           (IL:* IL:|;;| "Reading the #, macro")
+
+           (IL:VARIABLES *COMPILER-IS-READING*)
+           (IL:STRUCTURES EVAL-WHEN-LOAD)
+           
+           (IL:* IL:|;;| "Support for Block Compilation")
+
+           (IL:VARIABLES *BLOCK-HASH-TABLE* *BLOCKS* *CURRENT-BLOCK*)
+           (IL:STRUCTURES BLOCK-DECL)
+           (IL:FUNCTIONS SET-UP-BLOCK-DECLS)
+           
+           (IL:* IL:|;;| "Processing of top-level forms in a file")
+
+           (IL:VARIABLES PASS)
+           (IL:FUNCTIONS CONSTANT-EXPRESSION-P)
+           (IL:FUNCTIONS COMPILE-AND-DUMP COMPILE-AND-DUMP-1 COMPILE-ONE-LAMBDA)
+           (IL:FUNCTIONS OPTIMIZE-AND-MACROEXPAND OPTIMIZE-AND-MACROEXPAND-1 EXPAND-DEFINER 
+                  PROCESS-FORMS)
+           (IL:FUNCTIONS MAYBE-REMOVE-COMMENTS)
+           (IL:FUNCTIONS COMPILE-FILE-SETF-SYMBOL-FUNCTION COMPILE-FILE-DEFINEQ 
+                  COMPILE-FILE-DEFCONSTANT COMPILE-FILE-DECLARE\: COMPILE-FILE-DEFINE-FILE-INFO 
+                  COMPILE-FILE-PACKAGE-FORM COMPILE-FILE-PROCLAMATION COMPILE-FILE-COMPILER-LET 
+                  COMPILE-FILE-MACROLET COMPILE-FILE-DEFINER COMPILE-FILE-NAMED-PROGN 
+                  COMPILE-FILE-OUTSTANDING-LOOSE-FORMS COMPILE-FILE-LOOSE-FORM 
+                  COMPILE-FILE-PROCESS-FUNCTION)
+           (IL:FUNCTIONS CRACK-DEFMACRO ESTABLISH-MACRO-IN-COMPILER)
+           
+           (IL:* IL:|;;| "Support for :Process-Entire-File")
+
+           (IL:VARIABLES *DEFERRED-FORMS* *MAKING-SECOND-PASS* *PREPROCESSING-PHASE*)
+           (IL:FUNCTIONS COMPILE-SCAN-DECLARE\: COMPILE-SCAN-DEFINE-FILE-INFO COMPILE-SCAN-MACROLET 
+                  COMPILE-SCAN-DEFINER COMPILE-SCAN-LOOSE-FORM COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS)
+           (IL:FUNCTIONS MERGE-FIRST-FORMS)
+           
+           (IL:* IL:|;;| "for compiling definers")
+
+           (IL:VARIABLES *LAP-FLG* *AUTOMATIC-SPECIAL-DECLARATIONS*)
+           (IL:FUNCTIONS COMPILE COMPILE-SYMBOL-FUNCTION COMPILE-DEFINER)
+           (IL:FUNCTIONS COMPILE-FORM RAW-COMPILE)
+           (IL:FUNCTIONS COMPILE-DEFINER-DEFINER COMPILE-DEFINER-NAMED-PROGN 
+                  COMPILE-DEFINER-PROCESS-FUNCTION COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS)
+           
+           (IL:* IL:|;;| "Arrange for correct compiler to be used.")
+
+           (IL:PROP IL:FILETYPE IL:XCLC-TOP-LEVEL)
+           
+           (IL:* IL:|;;| "Arrange for the correct makefile environment")
+
+           (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-TOP-LEVEL)))
+
+
+
+(IL:* IL:|;;| "Top-level entry points")
+
+
+(DEFSTRUCT (COMPILER-CONTEXT (:FAST-ACCESSORS T)
+                                 (:CONC-NAME NIL)
+                                 (:COPIER NIL)
+                                 (:PREDICATE NIL))
+   SETF-SYMBOL-FUNCTION-FN
+   DEFINEQ-FN
+   DEFCONSTANT-FN
+   DECLARE\:-FN
+   DEFINE-FILE-INFO-FN
+   PACKAGE-FORM-FN
+   PROCLAIM-FN
+   COMPILER-LET-FN
+   MACROLET-FN
+   DEFINER-FN
+   NAMED-PROGN-FN
+   PROCESS-FUNCTION-FN
+   PROCESS-LOOSE-FORM-FN
+   PROCESS-OUTSTANDING-LOOSE-FORMS-FN)
+
+(DEFPARAMETER *COMPILE-FILE-CONTEXT*
+   (MAKE-COMPILER-CONTEXT :SETF-SYMBOL-FUNCTION-FN 'COMPILE-FILE-SETF-SYMBOL-FUNCTION :DEFINEQ-FN
+          'COMPILE-FILE-DEFINEQ :DEFCONSTANT-FN 'COMPILE-FILE-DEFCONSTANT :DECLARE\:-FN 
+          'COMPILE-FILE-DECLARE\: :DEFINE-FILE-INFO-FN 'COMPILE-FILE-DEFINE-FILE-INFO 
+          :PACKAGE-FORM-FN 'COMPILE-FILE-PACKAGE-FORM :PROCLAIM-FN 'COMPILE-FILE-PROCLAMATION 
+          :COMPILER-LET-FN 'COMPILE-FILE-COMPILER-LET :MACROLET-FN 'COMPILE-FILE-MACROLET :DEFINER-FN
+          'COMPILE-FILE-DEFINER :NAMED-PROGN-FN 'COMPILE-FILE-NAMED-PROGN :PROCESS-FUNCTION-FN
+          'COMPILE-FILE-PROCESS-FUNCTION :PROCESS-LOOSE-FORM-FN 'COMPILE-FILE-LOOSE-FORM 
+          :PROCESS-OUTSTANDING-LOOSE-FORMS-FN 'COMPILE-FILE-OUTSTANDING-LOOSE-FORMS))
+
+(DEFPARAMETER *COMPILE-SCAN-CONTEXT*
+   (MAKE-COMPILER-CONTEXT :SETF-SYMBOL-FUNCTION-FN 'COMPILE-SCAN-LOOSE-FORM :DEFINEQ-FN 
+          'COMPILE-SCAN-LOOSE-FORM :DEFCONSTANT-FN 'COMPILE-SCAN-LOOSE-FORM :DECLARE\:-FN
+          'COMPILE-SCAN-DECLARE\: :DEFINE-FILE-INFO-FN 'COMPILE-SCAN-DEFINE-FILE-INFO 
+          :PACKAGE-FORM-FN 'COMPILE-FILE-PACKAGE-FORM :PROCLAIM-FN 'COMPILE-FILE-PROCLAMATION 
+          :COMPILER-LET-FN 'COMPILE-SCAN-LOOSE-FORM :MACROLET-FN 'COMPILE-SCAN-MACROLET :DEFINER-FN
+          'COMPILE-SCAN-DEFINER :NAMED-PROGN-FN 'COMPILE-SCAN-LOOSE-FORM :PROCESS-FUNCTION-FN
+          'COMPILER-ERROR :PROCESS-LOOSE-FORM-FN 'COMPILE-SCAN-LOOSE-FORM 
+          :PROCESS-OUTSTANDING-LOOSE-FORMS-FN 'COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS))
+
+(DEFPARAMETER *COMPILE-DEFINER-CONTEXT*
+   (MAKE-COMPILER-CONTEXT :SETF-SYMBOL-FUNCTION-FN 'COMPILE-FILE-SETF-SYMBOL-FUNCTION :DEFINEQ-FN
+          'COMPILE-FILE-DEFINEQ :DEFCONSTANT-FN 'COMPILE-FILE-DEFCONSTANT :DECLARE\:-FN 
+          'COMPILER-ERROR :DEFINE-FILE-INFO-FN 'COMPILER-ERROR :PACKAGE-FORM-FN 
+          'COMPILE-FILE-PACKAGE-FORM :PROCLAIM-FN 'COMPILE-FILE-PROCLAMATION :COMPILER-LET-FN
+          'COMPILE-FILE-COMPILER-LET :MACROLET-FN 'COMPILE-FILE-MACROLET :DEFINER-FN 
+          'COMPILE-DEFINER-DEFINER :NAMED-PROGN-FN 'COMPILE-DEFINER-NAMED-PROGN :PROCESS-FUNCTION-FN
+          'COMPILE-DEFINER-PROCESS-FUNCTION :PROCESS-LOOSE-FORM-FN 'COMPILE-FILE-LOOSE-FORM 
+          :PROCESS-OUTSTANDING-LOOSE-FORMS-FN 'COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS))
+
+(DEFUN COMPILER-ERROR (COMPILER-CONTEXT &REST ARGS)
+   (ERROR "Unexpected compiler error. Context is ~s args are ~s" COMPILER-CONTEXT ARGS))
+
+(DEFMACRO COMPILER-APPLY (KEY COMPILER-CONTEXT &OPTIONAL FORM &REST OTHER-ARGS)
+   (LET ((ACCESSOR (INTERN (CONCATENATE 'STRING (STRING KEY)
+                                  "-FN")
+                          (FIND-PACKAGE "COMPILER"))))
+        (IF FORM
+            `(FUNCALL (,ACCESSOR ,COMPILER-CONTEXT)
+                    ,COMPILER-CONTEXT
+                    ,FORM
+                    ,@OTHER-ARGS)
+            `(FUNCALL (,ACCESSOR ,COMPILER-CONTEXT)
+                    ,COMPILER-CONTEXT))))
+
+(DEFMACRO COMPILER-WARNING (&REST ARGS)
+   `(PROGN (INCF *ANY-DIAGNOSTICS*)
+           (STYLE-WARN ,@ARGS)))
+
+(DEFMACRO COMPILER-CERROR (&REST ARGS)
+   `(PROGN (INCF *ANY-SERIOUS-DIAGNOSTICS*)
+           (INCF *ANY-DIAGNOSTICS*)
+           (CERROR ,@ARGS)))
+
+(DEFMACRO BUMP-DIAGNOSTIC-COUNT (FORM)
+
+   (IL:* IL:|;;| 
+ "A trivial hack to bump the diagnostic count returned by some other part of the compiler ")
+
+   `(MULTIPLE-VALUE-BIND (NAME DIAGS SERIOUS)
+           ,FORM
+           (VALUES NAME (IF DIAGS
+                            (1+ DIAGS)
+                            1)
+                  SERIOUS)))
+
+(DEFMACRO COMPILATION-VALUES (VALUE)
+   `(VALUES ,VALUE (COND
+                      ((NOT (ZEROP *ANY-DIAGNOSTICS*))
+                       *ANY-DIAGNOSTICS*))
+           (COND
+              ((NOT (ZEROP *ANY-SERIOUS-DIAGNOSTICS*))
+               *ANY-SERIOUS-DIAGNOSTICS*))))
+
+(DEFMACRO WITH-COMPILATION-UNIT ((&REST LISP::OPTION-LIST)
+                                     &BODY LISP::FORMS)
+   `(PROGN ,@LISP::FORMS))
+
+(DEFVAR *EVAL-WHEN-COMPILE* NIL
+   "Bound to T during processing of forms to be evaluated at compile-time.")
+
+(DEFVAR *FASL-HANDLE* NIL
+   "Handle used for writing out the code to a FASL file.")
+
+(DEFVAR *INPUT-FILENAME* NIL
+   "Full name of the file being compiled.")
+
+(DEFVAR *INPUT-STREAM* NIL
+   "Stream from which compile-file reads forms.")
+
+(DEFVAR *LAP-STREAM* NIL
+   "Stream to which compile-file writes LAP output.")
+
+(DEFVAR *LOAD-COMPILED-CODE* NIL
+   "Non-nil if new compiled code should be installed in running Lisp.
+ :save   if old versions should be saved on the property list before installing")
+
+(DEFVAR *NEW-COMPILER-IS-EXPANDING* NIL
+   "Bound to T whenever the new compiler might be expanding macros.  Used in some optimizers to let them only take effect in the new compiler."
+)
+
+(DEFVAR *OUTSTANDING-LOOSE-FORMS* NIL
+   
+ "A list of the random top-level forms to be gathered together into a single lambda for compilation.")
+
+(DEFVAR *COMPILING-DEFINER* NIL)
+
+(DEFVAR *LOOSE-NAME* NIL)
+
+(DEFVAR *COMPILE-VERBOSE* NIL)
+
+(DEFVAR *COMPILE-PRINT* T)
+
+(DEFVAR *ANY-DIAGNOSTICS* NIL)
+
+(DEFVAR *ANY-SERIOUS-DIAGNOSTICS* NIL)
+
+(DEFVAR *COMPILE-FILE-PATHNAME* NIL
+   "Pathname of file being compiled")
+
+(DEFVAR *COMPILE-FILE-TRUENAME* NIL
+   "Truename of file being compiled")
+
+(DEFUN COMPILE-FILE (INPUT-FILE &KEY (OUTPUT-FILE NIL)
+                               (LAP-FILE NIL)
+                               (ERROR-FILE NIL)
+                               (ERRORS-TO-TERMINAL T)
+                               (FILE-MANAGER-FORMAT NIL F-M-F-GIVEN)
+                               (PROCESS-ENTIRE-FILE NIL P-E-F-GIVEN)
+                               (LOAD NIL)
+                               ((:VERBOSE *COMPILE-VERBOSE*)
+                                *COMPILE-VERBOSE*)
+                               ((:PRINT *COMPILE-PRINT*)
+                                *COMPILE-PRINT*)
+                               (PACKAGE NIL))                (IL:* IL:\; 
+                                                           "Edited 15-Dec-92 16:06 by jrb:")
+
+(IL:* IL:|;;;| "Compiles the forms on Input-File, producing a FASL file.")
+
+(IL:* IL:|;;;| " :Output-File")
+
+   (IL:* IL:|;;| "The name of a file to which binary code should be written.")
+
+   (IL:* IL:|;;| " Defaults to Input-File with the extension '.dfasl'")
+
+(IL:* IL:|;;;| ":Lap-File")
+
+   (IL:* IL:|;;| "The name of a file to which LAP assemble code should be written.")
+
+   (IL:* IL:|;;| 
+ " If T, defulats to Input-File with the extension '.dlap', if NIL, no LAP file is produced.")
+
+(IL:* IL:|;;;| ":Error-FIle")
+
+   (IL:* IL:|;;| "The name of a file to which compiler error messages should be written. Defaults like :Lap-File, but with the extension '.log'")
+
+(IL:* IL:|;;;| ":Errors-To-Terminal")
+
+   (IL:* IL:|;;| 
+ "True if error messages should be sent to *ERROR-OUTPUT* as well as any :Error-File.")
+
+(IL:* IL:|;;;| ":File-Manager-Format")
+
+   (IL:* IL:|;;| 
+ "True if the file should be assumed to have been produced by the MAKEFILE function.")
+
+   (IL:* IL:|;;| "If not specified, we check the first non-blank character in the file. If that character is a left-paren, we assume that MAKEFILE made the file.")
+
+(IL:* IL:|;;;| ":Process-Entire-File")
+
+   (IL:* IL:|;;| "If true, the whole file is read in, evaluating those forms which are explicitly or implicitly EVAL-WHEN (COMPILE), before any code is generated. This allows macros to be defined after use, for example. This defaults to T if the file is declared or discovered to be in Interlisp format.")
+
+(IL:* IL:|;;;| ":Load")
+
+   (IL:* IL:|;;| "If true, definitions will be installed in the environment after they are compiled. If this is :SAVE, the any previous definitions are saved on the property list before the new ones are installed.")
+
+(IL:* IL:|;;;| ":Verbose")
+
+   (IL:* IL:|;;| "Controls *COMPILE-VERBOSE*, which controls the printing of a banner on *STANDARD-OUTPUT* desfribing the file being compiled.")
+
+(IL:* IL:|;;;| ":Print")
+
+   (IL:* IL:|;;| " Controls *COMPILE-PRINT*, which controls the printing of per-form compilation messages to *STANDARD-OUTPUT*")
+
+(IL:* IL:|;;;| ":Package")
+
+   (IL:* IL:|;;| 
+ "Controls the default package for reading the source; similar to the :PACKAGE keyword for :LOAD")
+
+   (LET ((*ERROR-OUTPUT* *ERROR-OUTPUT*)
+         (*INPUT-STREAM* NIL)
+         (*INPUT-FILENAME* NIL)
+         (*FASL-HANDLE* NIL)
+         (FASL-PATHNAME NIL)
+         (*LAP-STREAM* NIL)
+         (*COMPILE-FILE-PATHNAME*)
+         (*COMPILE-FILE-TRUENAME*)
+         (ERROR-FILE-STREAM NIL)
+         (COMPILATION-SUCCEEDED NIL)
+         (*LOAD-COMPILED-CODE* LOAD)
+         (*CONTEXT* (MAKE-CONTEXT :TOP-LEVEL-P T :VALUES-USED 0))
+         (*ENVIRONMENT* (MAKE-ENV :PARENT T))
+         (*CONSTANTS-HASH-TABLE* (MAKE-HASH-TABLE))
+         (*OUTSTANDING-LOOSE-FORMS* NIL)
+         (*PROCESSED-FUNCTIONS* NIL)
+         (*UNKNOWN-FUNCTIONS* NIL)
+         (*ANY-DIAGNOSTICS* 0)
+         (*ANY-SERIOUS-DIAGNOSTICS* 0)
+         (*INPUT-FILECOMS-VARIABLE* NIL)                     (IL:* IL:\; 
+                         "Bound for the convenience of the optimizers on RPAQQ and PRETTYCOMPRINT.")
+
+         (IL:* IL:|;;| "Rebind all of these both to set up a canonical environment inside the compiler and to protect the outside environment from anything that might happen during this file.")
+
+         (IL:SPECVARS T)
+         (IL:LOCALVARS IL:SYSLOCALVARS)
+         (IL:LOCALFREEVARS NIL)
+         (IL:GLOBALVARS IL:GLOBALVARS)
+         (IL:NLAMA IL:NLAMA)
+         (IL:NLAML IL:NLAML)
+         (IL:LAMA IL:LAMA)
+         (IL:DONTCOMPILEFNS IL:DONTCOMPILEFNS))
+        (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS IL:NLAMA 
+                            IL:NLAML IL:LAMA IL:DONTCOMPILEFNS))
+        (UNWIND-PROTECT
+            (PROGN 
+                   (IL:* IL:|;;| "Set up the input stream.")
+
+                   (IL:* IL:|;;| "NOTE: If you change the handling of *INPUT-FILENAME* or *FASL-PATHNAME*, you also have to change COMPILE-FILE-PATHNAME to do the same thing.")
+
+                   (LET ((PATH (OR (PROBE-FILE INPUT-FILE)
+                                   (PROBE-FILE (MERGE-PATHNAMES INPUT-FILE ".lisp")))))
+                        (COND
+                           (PATH (SETQ *INPUT-FILENAME* PATH)
+                                 (SETQ *INPUT-STREAM* (OPEN PATH :DIRECTION :INPUT))
+                                 (WHEN (AND (FBOUNDP 'IL:OPENTEXTSTREAM)
+                                            (FBOUNDP 'IL:\\TEDIT.FORMATTEDP1)
+                                            (IF (IL:RANDACCESSP *INPUT-STREAM*)
+                                                (IL:\\TEDIT.FORMATTEDP1 *INPUT-STREAM*)
+                                                (WITH-OPEN-FILE (TEMP-STREAM *INPUT-STREAM*)
+                                                       (IL:\\TEDIT.FORMATTEDP1 TEMP-STREAM))))
+                                     (SETQ *INPUT-STREAM* (IL:OPENTEXTSTREAM *INPUT-STREAM* NIL NIL 
+                                                                 NIL '(IL:READONLY T)))))
+                           (T (ERROR "The file \"~A\" is nonexistent or cannot be read.~%" INPUT-FILE
+                                     )))
+                        (SETQ *COMPILE-FILE-PATHNAME* PATH)
+                        (SETQ *COMPILE-FILE-TRUENAME* (TRUENAME PATH)))
+
+                   (IL:* IL:|;;| "Set up the FASL output stream.")
+
+                   (SETQ FASL-PATHNAME (COND
+                                          (OUTPUT-FILE (PATHNAME OUTPUT-FILE))
+                                          (T (MAKE-PATHNAME :TYPE
+                                                    (STRING (LOCALLY (DECLARE (SPECIAL 
+                                                                                         IL:FASL.EXT)
+                                                                            )
+                                                                   IL:FASL.EXT))
+                                                    :VERSION :NEWEST :DEFAULTS *INPUT-FILENAME*))))
+                   (SETQ *FASL-HANDLE* (FASL:OPEN-FASL-HANDLE FASL-PATHNAME))
+
+                   (IL:* IL:|;;| "Set up the LAP stream.")
+
+                   (WHEN LAP-FILE
+                       (SETQ *LAP-STREAM* (OPEN (IF (EQ LAP-FILE T)
+                                                    (MAKE-PATHNAME :TYPE "dlap" :VERSION :NEWEST 
+                                                           :DEFAULTS *INPUT-FILENAME*)
+                                                    LAP-FILE)
+                                                :DIRECTION :OUTPUT)))
+
+                   (IL:* IL:|;;| "Set up the error output stream.")
+
+                   (WHEN ERROR-FILE
+                       (SETQ ERROR-FILE-STREAM (OPEN (IF (EQ ERROR-FILE T)
+                                                         (MAKE-PATHNAME :TYPE "log" :VERSION :NEWEST
+                                                                :DEFAULTS *INPUT-FILENAME*)
+                                                         ERROR-FILE)
+                                                     :DIRECTION :OUTPUT)))
+                   (SETQ *ERROR-OUTPUT* (IF ERRORS-TO-TERMINAL
+                                            (IF ERROR-FILE-STREAM
+                                                (MAKE-BROADCAST-STREAM ERROR-FILE-STREAM 
+                                                       *ERROR-OUTPUT*)
+                                                *ERROR-OUTPUT*)
+                                            ERROR-FILE-STREAM))
+
+                   (IL:* IL:|;;| 
+                 "Fix up the default values of FILE-MANAGER-FORMAT and PROCESS-ENTIRE-FILE.")
+
+                   (IF (NOT F-M-F-GIVEN)
+                       (SETQ FILE-MANAGER-FORMAT (EQ (IL:SKIPSEPRCODES *INPUT-STREAM* IL:FILERDTBL)
+                                                     (IL:CHARCODE "("))))
+                   (IF (NOT P-E-F-GIVEN)
+                       (SETQ PROCESS-ENTIRE-FILE FILE-MANAGER-FORMAT))
+
+                   (IL:* IL:|;;| "Pick the right readtable and do the compilation.")
+
+                   (IL:WITH-READER-ENVIRONMENT (IF FILE-MANAGER-FORMAT
+                                                   IL:*OLD-INTERLISP-READ-ENVIRONMENT*
+                                                   IL:*COMMON-LISP-READ-ENVIRONMENT*)
+
+                       (IL:* IL:|;;| "If we have a FILE-MANAGER file and :PACKAGE is not specified, leave *PACKAGE* in the current reader-environment alone, otherwise go default *PACKAGE*.")
+
+                       (UNLESS (AND (NULL PACKAGE)
+                                    FILE-MANAGER-FORMAT)
+                           (SETQ *PACKAGE* (LISP::DEFAULT-IO-PACKAGE PACKAGE)))
+                       (START-COMPILATION FASL-PATHNAME)
+                       (PROCESS-FORMS PROCESS-ENTIRE-FILE)
+                       (FINISH-COMPILATION)
+                       (SETQ COMPILATION-SUCCEEDED T)
+
+                       (IL:* IL:|;;| 
+         "Return the DFASL pathname so that people can say, for example, (LOAD (COMPILE-FILE ...))")
+
+                       (COMPILATION-VALUES FASL-PATHNAME)))
+
+            (IL:* IL:|;;| "The compilation is over. Close all of the streams. If the compilations did not succeed (that is, we have aborted it), then delete the FASL file as well rather than leave garbage around.")
+
+            (IF (STREAMP *INPUT-STREAM*)
+                (CLOSE *INPUT-STREAM*))
+            (IF (NOT (NULL *FASL-HANDLE*))
+                (FASL:CLOSE-FASL-HANDLE *FASL-HANDLE* :ABORT (NOT COMPILATION-SUCCEEDED)))
+            (IF (STREAMP ERROR-FILE-STREAM)
+                (CLOSE ERROR-FILE-STREAM))
+            (IF (STREAMP *LAP-STREAM*)
+                (CLOSE *LAP-STREAM*)))))
+
+(DEFUN COMPILE-FILE-PATHNAME (PATHNAME &KEY LISP::OUTPUT-FILE &ALLOW-OTHER-KEYS)
+                                                             (IL:* IL:\; 
+                                                           "Edited 13-Apr-92 14:37 by jrb:")
+   (OR (AND LISP::OUTPUT-FILE (PATHNAME LISP::OUTPUT-FILE))
+       (MAKE-PATHNAME :TYPE (STRING (LOCALLY (DECLARE (SPECIAL IL:FASL.EXT))
+                                           IL:FASL.EXT))
+              :VERSION :NEWEST :DEFAULTS (OR (PROBE-FILE PATHNAME)
+                                             (PROBE-FILE (MERGE-PATHNAMES PATHNAME ".lisp"))
+                                             (PATHNAME PATHNAME)))))
+
+(DEFUN START-COMPILATION (FASL-PATHNAME)                 (IL:* IL:\; 
+                                                           "Edited 29-Jan-92 14:18 by jrb:")
+
+(IL:* IL:|;;;| "Write out banners on the various output files.")
+
+   (FLET ((DATE-STRING (UNIV-TIME)
+                 (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOUR DATE MONTH YEAR DAY-OF-WEEK)
+                        (DECODE-UNIVERSAL-TIME UNIV-TIME)
+                        (FORMAT NIL "~A, ~D ~A ~D, ~D:~2,'0D:~2,'0D"
+                               (NTH DAY-OF-WEEK '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday"
+                                                        "Saturday" "Sunday"))
+                               DATE
+                               (NTH (1- MONTH)
+                                    '("January" "February" "March" "April" "May" "June" "July" 
+                                            "August" "September" "October" "November" "December"))
+                               YEAR HOUR MINUTES SECONDS))))
+         (LET ((FASL-STREAM (FASL:BEGIN-TEXT *FASL-HANDLE*)))
+              (FORMAT FASL-STREAM 
+       "XCL Compiler output for source file ~A~%~
+Source file created ~A.~%~
+FASL file created ~A.~%" (NAMESTRING *INPUT-FILENAME*)
+                     (DATE-STRING (FILE-WRITE-DATE *INPUT-FILENAME*))
+                     (DATE-STRING (GET-UNIVERSAL-TIME))))
+         (FASL:BEGIN-BLOCK *FASL-HANDLE*)
+         (WHEN (STREAMP *LAP-STREAM*)
+             (FORMAT *LAP-STREAM* 
+      "XCL Compiler output for source file ~A~%~
+Source file created ~A.~%~
+LAP file created ~A.~%~%" (NAMESTRING *INPUT-FILENAME*)
+                    (DATE-STRING (FILE-WRITE-DATE *INPUT-FILENAME*))
+                    (DATE-STRING (GET-UNIVERSAL-TIME))))
+         (WHEN *COMPILE-VERBOSE*
+             (FORMAT *STANDARD-OUTPUT* ";;; Compiling ~a created ~a~%;;;  to ~a on ~a~2%"
+                    (NAMESTRING *INPUT-FILENAME*)
+                    (DATE-STRING (FILE-WRITE-DATE *INPUT-FILENAME*))
+                    (NAMESTRING FASL-PATHNAME)
+                    (DATE-STRING (FILE-WRITE-DATE FASL-PATHNAME))))))
+
+(DEFUN FINISH-COMPILATION NIL
+
+(IL:* IL:|;;;| "Clean up after the compilation.")
+
+   (IL:* IL:|;;| "Remove this file from IL:NOTCOMPILEDFILES for CLEANUP.")
+
+   (LOCALLY (DECLARE (IL:GLOBALVARS IL:NOTCOMPILEDFILES))
+          (SETQ IL:NOTCOMPILEDFILES (REMOVE (INTERN (LET ((TYPE (PATHNAME-TYPE *INPUT-FILENAME*)))
+                                                         (STRING-UPCASE (IF (ZEROP (LENGTH TYPE))
+                                                                            (PATHNAME-NAME 
+                                                                                   *INPUT-FILENAME*)
+                                                                            (FORMAT NIL "~A.~A"
+                                                                                   (PATHNAME-NAME
+                                                                                    *INPUT-FILENAME*)
+                                                                                   TYPE))))
+                                                   "INTERLISP")
+                                           IL:NOTCOMPILEDFILES)))
+
+   (IL:* IL:|;;| "Possibly warn about unknown functions encountered during compilation.")
+
+   (WARN-ABOUT-UNKNOWN-FUNCTIONS))
+
+(DEFUN SCAN-ONE-FORM (FORM COMPILER-CONTEXT)             (IL:* IL:\; 
+                                                           "Edited 31-Jan-92 11:56 by jrb:")
+
+   (IL:* IL:|;;| "Assumes sedit like comments have already been stripped ")
+
+   (IF (ATOM FORM)
+       FORM
+       (CASE (CAR FORM)
+           ((IL:FUNCTION FUNCTION QUOTE) (EVAL FORM))
+           ((PROGN) (LET ((VALUE NIL))
+                         (DOLIST (SUB-FORM (CDR FORM))
+                             (SETQ VALUE (SCAN-ONE-FORM SUB-FORM COMPILER-CONTEXT)))
+                         VALUE))
+           ((DEFMACRO) (LET ((NAME (SECOND FORM)))
+                            (COND
+                               ((NOT (SYMBOLP NAME))
+                                (COMPILER-CERROR "Ignore this DEFMACRO." 
+                                       "~S is not a legal macro name." NAME))
+                               (T (UNLESS *MAKING-SECOND-PASS*
+                                      (ESTABLISH-MACRO-IN-COMPILER NAME (CRACK-DEFMACRO
+                                                                             FORM)))
+                                  (SCAN-ONE-FORM (OPTIMIZE-AND-MACROEXPAND-1 FORM)
+                                         COMPILER-CONTEXT)))))
+           ((EVAL-WHEN) (IF (NOT (AND (LISTP (SECOND FORM))
+                                      (NOT (EQ 'QUOTE (CAR (SECOND FORM))))))
+                            (COMPILER-CERROR "Ignore its contents." "Ill-formed EVAL-WHEN:~%~S" 
+                                   FORM)
+                            (LET ((EVAL-SPECIFIED (OR (MEMBER :EXECUTE (CADR FORM)
+                                                             :TEST
+                                                             #'EQ)
+                                                      (MEMBER 'IL:EVAL (CADR FORM)
+                                                             :TEST
+                                                             #'EQ)
+                                                      (MEMBER 'EVAL (CADR FORM)
+                                                             :TEST
+                                                             #'EQ)))
+                                  (LOAD-TOPLEVEL-SPECIFIED (AND (CONTEXT-TOP-LEVEL-P *CONTEXT*)
+                                                                (MEMBER :LOAD-TOPLEVEL (CADR FORM)
+                                                                       :TEST
+                                                                       #'EQ)))
+                                  (LOAD-SPECIFIED (OR (MEMBER 'IL:LOAD (CADR FORM)
+                                                             :TEST
+                                                             #'EQ)
+                                                      (MEMBER 'LOAD (CADR FORM)
+                                                             :TEST
+                                                             #'EQ)))
+                                  (COMPILE-TOPLEVEL-SPECIFIED (AND (CONTEXT-TOP-LEVEL-P *CONTEXT*)
+                                                                   (MEMBER :COMPILE-TOPLEVEL
+                                                                          (CADR FORM)
+                                                                          :TEST
+                                                                          #'EQ)))
+                                  (COMPILE-SPECIFIED (OR (MEMBER 'IL:COMPILE (CADR FORM)
+                                                                :TEST
+                                                                #'EQ)
+                                                         (MEMBER 'COMPILE (CADR FORM)
+                                                                :TEST
+                                                                #'EQ))))
+                                 (COND
+                                    ((OR LOAD-SPECIFIED LOAD-TOPLEVEL-SPECIFIED)
+                                     (LET ((*EVAL-WHEN-COMPILE* (OR COMPILE-SPECIFIED 
+                                                                    COMPILE-TOPLEVEL-SPECIFIED
+                                                                    (AND *EVAL-WHEN-COMPILE* 
+                                                                         EVAL-SPECIFIED))))
+                                          (LET ((VALUE NIL))
+                                               (DOLIST (SUB-FORM (CDDR FORM))
+                                                   (SETQ VALUE (SCAN-ONE-FORM SUB-FORM 
+                                                                      COMPILER-CONTEXT)))
+                                               VALUE)))
+                                    (T (WHEN (OR COMPILE-SPECIFIED COMPILE-TOPLEVEL-SPECIFIED
+                                                 (AND *EVAL-WHEN-COMPILE* EVAL-SPECIFIED))
+                                           (LET ((VALUE NIL))
+                                                (DOLIST (INNER-FORM (CDDR FORM))
+                                                    (SETQ VALUE (EVAL INNER-FORM)))
+                                                VALUE)))))))
+           ((DEFCONSTANT) (COMPILER-APPLY DEFCONSTANT COMPILER-CONTEXT FORM))
+           ((IL:DECLARE\:) (COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT FORM))
+           ((IL:SETF-SYMBOL-FUNCTION) (COMPILER-APPLY IL:SETF-SYMBOL-FUNCTION COMPILER-CONTEXT 
+                                             FORM))
+           ((IL:DEFINEQ) (COMPILER-APPLY IL:DEFINEQ COMPILER-CONTEXT FORM))
+           ((IL:DEFINE-FILE-INFO) (COMPILER-APPLY IL:DEFINE-FILE-INFO COMPILER-CONTEXT FORM))
+           ((MAKE-PACKAGE IN-PACKAGE IN-PACKAGE SHADOW SHADOWING-IMPORT EXPORT UNEXPORT USE-PACKAGE 
+                   UNUSE-PACKAGE IMPORT DEFPACKAGE) (COMPILER-APPLY PACKAGE-FORM COMPILER-CONTEXT
+                                                           FORM))
+           ((PROCLAIM) (COMPILER-APPLY PROCLAIM COMPILER-CONTEXT FORM))
+           ((COMPILER-LET) (COMPILER-APPLY COMPILER-LET COMPILER-CONTEXT FORM))
+           ((MACROLET SI::%MACROLET) (COMPILER-APPLY MACROLET COMPILER-CONTEXT FORM))
+           ((DEFINER) (COMPILER-APPLY DEFINER COMPILER-CONTEXT FORM))
+           ((NAMED-PROGN) (COMPILER-APPLY NAMED-PROGN COMPILER-CONTEXT FORM))
+           (OTHERWISE (IF *MAKING-SECOND-PASS*
+                          (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM)
+                          (MULTIPLE-VALUE-BIND (NEW-FORM CHANGED-P)
+                                 (OPTIMIZE-AND-MACROEXPAND-1 FORM)
+                                 (IF (NOT CHANGED-P)
+                                     (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM)
+                                     (SCAN-ONE-FORM NEW-FORM COMPILER-CONTEXT))))))))
+
+(DEFUN FUNCTION-P (FORM)
+   (AND (CONSP FORM)
+        (OR (EQ (FIRST FORM)
+                'FUNCTION)
+            (EQ (FIRST FORM)
+                'IL:FUNCTION))
+        (CONSP (SECOND FORM))))
+
+(DEFMACRO COMPILER-MESSAGE (FORMAT-STRING &REST FORMAT-ARGS)
+
+   (IL:* IL:|;;| "Strangely enough, this macro is used ONLY in XCLC-TOP-LEVEL")
+
+   `(AND *COMPILE-PRINT* (FORMAT *STANDARD-OUTPUT* ,FORMAT-STRING ,@FORMAT-ARGS)))
+
+(DEFMACRO COMPILING-MESSAGE (NAME)
+   `(COMPILER-MESSAGE "Compiling ~a " ,NAME))
+
+(DEFMACRO DONE-MESSAGE NIL
+   `(COMPILER-MESSAGE " Done~%"))
+
+(DEFINE-CONDITION STYLE-WARNING (SIMPLE-WARNING)
+   NIL)
+
+(DEFINE-CONDITION UNKNOWN-FUNCTION-WARNING (STYLE-WARNING)
+   (CALL-LIST)
+   (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*)
+                   (FORMAT T 
+       "The following functions were called in the code just compiled, but are not known to exist:~%"
+                          )
+                   (DOLIST (PAIR (UNKNOWN-FUNCTION-WARNING-CALL-LIST CONDITION))
+                       (FORMAT T "  ~S -- called from " (CAR PAIR))
+
+                       (IL:* IL:|;;| 
+                     "I almost used this hairy thing, but FORMAT is too slow...  Aren't you glad?")
+
+                       (IL:* IL:|;;| 
+                     "\"~:[nowhere?!~;~:*~{~#[~;~S~;~S and ~S~:;~@{~#[~;and ~]~S~^, ~}~]~}.~]~%\"")
+
+                       (COND
+                          ((NULL (CDR PAIR))
+                           (FORMAT T "nowhere?!~%"))
+                          ((NULL (CDDR PAIR))
+                           (FORMAT T "~S.~%" (SECOND PAIR)))
+                          ((NULL (CDDDR PAIR))
+                           (FORMAT T "~S and ~S.~%" (SECOND PAIR)
+                                  (THIRD PAIR)))
+                          (T (DO ((TAIL (CDR PAIR)
+                                        (CDR TAIL)))
+                                 ((NULL TAIL))
+                               (PRIN1 (CAR TAIL))
+                               (COND
+                                  ((CDDR TAIL)
+                                   (PRINC ", "))
+                                  ((CDR TAIL)
+                                   (PRINC " and "))))
+                             (PRINC ".")
+                             (TERPRI)))))))
+
+(DEFUN STYLE-WARN (DATUM &REST ARGUMENTS)                (IL:* IL:\; 
+                                                           "Edited 19-Feb-92 14:55 by jrb:")
+   (LET ((*CURRENT-CONDITION* (IL:MAKE-INTO-CONDITION DATUM 'STYLE-WARNING ARGUMENTS)))
+        (WHEN *BREAK-ON-WARNINGS* (BREAK "Warning: ~A" *CURRENT-CONDITION*))
+        (PROCEED-CASE (PROGN (IL:RAISE-SIGNAL *CURRENT-CONDITION*)
+                             (FORMAT *ERROR-OUTPUT* "~&Warning: ~A~%" *CURRENT-CONDITION*)
+                             NIL)
+               (MUFFLE-WARNING NIL :REPORT "Don't print the warning" NIL))))
+
+(DEFUN CHECK-FOR-UNKNOWN-FUNCTION (NAME)
+   (WHEN (AND (NOT (FBOUNDP NAME))
+              (NOT (MEMBER NAME *PROCESSED-FUNCTIONS* :TEST 'EQ))
+              (OR (ENV-INLINE-DISALLOWED *ENVIRONMENT* NAME)
+                  (NOT (OR (GET NAME 'OPTIMIZER-LIST)
+                           (GET NAME 'TRANSFORM)
+                           (GET NAME 'IL:DOPVAL)))))
+       (LET ((LOOKUP (ASSOC NAME *UNKNOWN-FUNCTIONS* :TEST 'EQ)))
+            (IF (NULL LOOKUP)
+                (PUSH (LIST NAME *CURRENT-FUNCTION*)
+                      *UNKNOWN-FUNCTIONS*)
+                (PUSHNEW *CURRENT-FUNCTION* (CDR LOOKUP))))))
+
+(DEFUN CHECK-FOR-UNKNOWN-SETF (SETF-NAME DEFUN-SETF-NAME)
+   (WHEN (AND (NOT (FBOUNDP DEFUN-SETF-NAME))
+              (NOT (MEMBER DEFUN-SETF-NAME *PROCESSED-FUNCTIONS* :TEST 'EQ))
+              (OR (ENV-INLINE-DISALLOWED *ENVIRONMENT* DEFUN-SETF-NAME)
+                  (NOT (OR (GET DEFUN-SETF-NAME 'OPTIMIZER-LIST)
+                           (GET DEFUN-SETF-NAME 'TRANSFORM)
+                           (GET DEFUN-SETF-NAME 'IL:DOPVAL)))))
+       (LET ((LOOKUP (ASSOC SETF-NAME *UNKNOWN-FUNCTIONS* :TEST 'EQUAL)))
+            (IF (NULL LOOKUP)
+                (PUSH (LIST SETF-NAME *CURRENT-FUNCTION*)
+                      *UNKNOWN-FUNCTIONS*)
+                (PUSHNEW *CURRENT-FUNCTION* (CDR LOOKUP))))))
+
+(DEFUN WARN-ABOUT-UNKNOWN-FUNCTIONS NIL                  (IL:* IL:\; 
+                                                           "Edited 31-Jan-92 12:03 by jrb:")
+
+(IL:* IL:|;;;| "If there's anything on *UNKNOWN-FUNCTIONS*, issue a summary and warning.")
+
+   (WHEN (NOT (NULL *UNKNOWN-FUNCTIONS*))
+       (COMPILER-WARNING 'UNKNOWN-FUNCTION-WARNING :CALL-LIST *UNKNOWN-FUNCTIONS*)))
+
+(DEFVAR *PROCESSED-FUNCTIONS*
+
+(IL:* IL:|;;;| "A list of the names of the global functions processed during this compilation.  Used in conjunction with *UNKNOWN-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.")
+
+   )
+
+(DEFVAR *UNKNOWN-FUNCTIONS*
+
+(IL:* IL:|;;;| "A list containing the names of undefined global functions called from code in the current compilation.  Actually, it's an AList mapping the unknown function to the list of functions in which it is called.  Used in conjunction with *PROCESSED-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.")
+
+   )
+
+(DEFVAR *CURRENT-FUNCTION*
+
+(IL:* IL:|;;;| "The name of the unit currently being compiled.")
+
+   )
+
+(DEFINE-CONDITION ASSEMBLER-ERROR
+
+(IL:* IL:|;;;| "Signalled by an assembler when it encounters an unrecoverable error. The compiler catches such, prints an error message, and continues with the next form on the file.")
+
+    (ERROR)
+   (FORMAT-STRING FORMAT-ARGUMENTS)
+   (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*)
+                   (FORMAT *ERROR-OUTPUT* "Error during assembly:~%  ~?" (
+                                                                        ASSEMBLER-ERROR-FORMAT-STRING
+                                                                          CONDITION)
+                          (ASSEMBLER-ERROR-FORMAT-ARGUMENTS CONDITION)))))
+
+(DEFUN ASSEMBLER-ERROR (STRING &REST ARGUMENTS)
+   (ERROR 'ASSEMBLER-ERROR :FORMAT-STRING STRING :FORMAT-ARGUMENTS ARGUMENTS))
+
+
+
+(IL:* IL:|;;| "Reading the #, macro")
+
+
+(DEFVAR *COMPILER-IS-READING* NIL
+   "Bound to T during compile-file so that READ can properly treat #,")
+
+(DEFSTRUCT EVAL-WHEN-LOAD
+   "Structure wrapping a form to be evaluated at load time.  Used in the implementation of the #, reader macro."
+   IL:FORM)
+
+
+
+(IL:* IL:|;;| "Support for Block Compilation")
+
+
+(DEFVAR *BLOCK-HASH-TABLE* NIL
+
+(IL:* IL:|;;;| "A mapping from function names to lists of BLOCK-DECL structures describing blocks that include that function.  Initialized from the list of BLOCK: declarations gathered into *BLOCKS* (q.v.) during the preprocessing scan.")
+
+   )
+
+(DEFVAR *BLOCKS* NIL
+
+(IL:* IL:|;;;| "A list of the Interlisp block descriptions found on the file.  This list is added to during the preprocessing scan of the file and then used for initialising *BLOCK-HASH-TABLE* (q.v.)")
+
+   )
+
+(DEFVAR *CURRENT-BLOCK* NIL
+
+(IL:* IL:|;;;| "Bound during compilation of a LAMBDA to the BLOCK-DECL structure describing the block containing the current function.  This is NIL if the function is not a part of any block.")
+
+   )
+
+(DEFSTRUCT (BLOCK-DECL (:INLINE NIL))
+
+(IL:* IL:|;;;| 
+"A BLOCK-DECL holds the information describing a particular Interlisp BLOCK: declaration.")
+
+(IL:* IL:|;;;| "NAME is the symbol naming the block or NIL if this is only a pseudo-block.")
+
+(IL:* IL:|;;;| 
+"FN-NAME-MAP is an AList mapping internal function names to their new \\BLOCK/FN style name.")
+
+(IL:* IL:|;;;| "SPECVARS, LOCALVARS, LOCALFREEVARS and GLOBALVARS contain the values those variables should have during the compilation of functions in this block.")
+
+   NAME
+   FN-NAME-MAP
+   SPECVARS
+   LOCALVARS
+   LOCALFREEVARS
+   GLOBALVARS)
+
+(DEFUN SET-UP-BLOCK-DECLS (DECLS)                        (IL:* IL:\; 
+                                                           "Edited 31-Jan-92 12:02 by jrb:")
+
+(IL:* IL:|;;;| "Parse the given list of Interlisp BLOCK: declarations and return a hash-table mapping functions named therein to a list of the BLOCK-DECLs representing decls mentioning that function.")
+
+   (LET ((HASH-TABLE (MAKE-HASH-TABLE)))
+        (DOLIST (DECL DECLS)
+            (LET* ((BLOCK-NAME (CAR DECL))
+                   (BD (MAKE-BLOCK-DECL :NAME BLOCK-NAME))
+                   (IL:SPECVARS IL:SPECVARS)
+                   (IL:LOCALVARS IL:LOCALVARS)
+                   (IL:LOCALFREEVARS NIL)
+                   (IL:GLOBALVARS IL:GLOBALVARS)
+                   (NOT-RENAMED-FNS (CONS BLOCK-NAME (UNION IL:RETFNS IL:NOLINKFNS)))
+                   (FNS NIL))
+                  (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS 
+                                      IL:NOLINKFNS))
+
+                  (IL:* IL:|;;| "We do this next bit because BCOMPL2 does it.")
+
+                  (COND
+                     ((NULL BLOCK-NAME)
+                      (SETQ IL:SPECVARS T)
+                      (SETQ IL:LOCALVARS IL:SYSLOCALVARS))
+                     (T (SETQ IL:LOCALVARS T)
+                        (SETQ IL:SPECVARS IL:SYSSPECVARS)))
+
+                  (IL:* IL:|;;| "For each item in the declaration, either add it to the list of functions or make the appropriate modifications to the named variable.")
+
+                  (DOLIST (ITEM (CDR DECL))
+                      (COND
+                         ((SYMBOLP ITEM)
+                          (PUSH ITEM FNS)
+                          (PUSH BD (GETHASH ITEM HASH-TABLE)))
+                         ((CONSP ITEM)
+                          (CASE (CAR ITEM)
+                              ((IL:SPECVARS IL:LOCALVARS) (IL:EVAL ITEM))
+                              ((IL:GLOBALVARS IL:LOCALFREEVARS) 
+                                 (LET ((VARIABLE (CAR ITEM))
+                                       (VALUE (CDR ITEM)))
+                                      (WHEN (AND (CONSP VALUE)
+                                                 (EQ (CAR VALUE)
+                                                     'IL:*))
+                                          (SETQ VALUE (IL:EVAL (CADR VALUE))))
+                                      (IF (LISTP VALUE)
+                                          (SET VARIABLE (UNION (CDR ITEM)
+                                                               (SYMBOL-VALUE (CAR ITEM))))
+                                          (SET VARIABLE VALUE))))
+                              ((IL:BLKLIBRARY IL:LINKFNS) (COMPILER-WARNING 
+                                                             "The ~S feature is no longer supported."
+                                                                 (CAR ITEM)))
+                              ((IL:DONTCOMPILEFNS) (COMPILER-WARNING 
+                                            "DONTCOMPILEFNS is not supported in BLOCK: declarations."
+                                                          ))
+                              ((IL:BLKAPPLYFNS IL:NOLINKFNS IL:RETFNS IL:ENTRIES) 
+                                                             (IL:* IL:\; 
+                           "These functions should not be renamed, according to BYTEBLOCKCOMPILE2.")
+                                 (WHEN (CONSP (CDR ITEM))
+                                     (SETQ NOT-RENAMED-FNS (APPEND (CDR ITEM)
+                                                                  NOT-RENAMED-FNS))))
+                              (OTHERWISE (COMPILER-CERROR "Ignore the unknown variable." 
+                                              "Unknown variable ~S mentioned in a BLOCK: declaration"
+                                                (CAR ITEM)))))
+                         (T (COMPILER-CERROR "Ignore the illegal item" 
+                                   "Illegal item in a BLOCK: declaration: ~S" ITEM))))
+                  (SETF (BLOCK-DECL-SPECVARS BD)
+                        IL:SPECVARS)
+                  (SETF (BLOCK-DECL-LOCALVARS BD)
+                        IL:LOCALVARS)
+                  (SETF (BLOCK-DECL-LOCALFREEVARS BD)
+                        IL:LOCALFREEVARS)
+                  (SETF (BLOCK-DECL-GLOBALVARS BD)
+                        IL:GLOBALVARS)
+                  (LET* ((BLOCK-NAME-STRING (STRING BLOCK-NAME))
+                         (BLOCK-PACKAGE (SYMBOL-PACKAGE BLOCK-NAME)))
+                        (UNLESS (NULL BLOCK-NAME)            (IL:* IL:\; 
+                                                           "NIL blocks don't do renaming.")
+                            (SETF (BLOCK-DECL-FN-NAME-MAP BD)
+                                  (IL:|for| FN IL:|in| (NSET-DIFFERENCE FNS NOT-RENAMED-FNS)
+                                     IL:|collect| (CONS FN (INTERN (CONCATENATE 'STRING "\\" 
+                                                                              BLOCK-NAME-STRING "/"
+                                                                              (STRING FN))
+                                                                      BLOCK-PACKAGE))))))))
+        HASH-TABLE))
+
+
+
+(IL:* IL:|;;| "Processing of top-level forms in a file")
+
+
+(DEFCONSTANT PASS 'PASS "Useful for ameliorating the obvious quoting bug.")
+
+(DEFUN CONSTANT-EXPRESSION-P (FORM)
+   (OR (CONSTANTP FORM)
+       (AND (CONSP FORM)
+            (LET* ((FN (CAR FORM))
+                   (S-E-DATA (GET FN 'SIDE-EFFECTS-DATA)))
+                  (AND (EQ (CAR S-E-DATA)
+                           :NONE)
+                       (EQ (CDR S-E-DATA)
+                           :NONE)
+                       (DOLIST (ARG (CDR FORM)
+                                    T)
+                           (IF (NOT (CONSTANT-EXPRESSION-P ARG))
+                               (RETURN NIL))))))))
+
+(DEFUN COMPILE-AND-DUMP (NAME DEFN KIND)
+   (LET ((*CURRENT-BLOCK* NIL)                               (IL:* IL:\; 
+                                          "So that we aren't dependent upon the top-level binding.")
+         )
+        (COND
+           ((AND (SYMBOLP NAME)
+                 (EQ KIND :FUNCTION))
+            (WHEN (MEMBER NAME IL:DONTCOMPILEFNS :TEST 'EQ)
+                  (RETURN-FROM COMPILE-AND-DUMP))
+            (LET ((BD-LIST (AND *BLOCK-HASH-TABLE* (GETHASH NAME *BLOCK-HASH-TABLE*))))
+                 (COND
+                    ((NULL BD-LIST)
+                     (COMPILE-AND-DUMP-1 NAME DEFN KIND))
+                    (T (DOLIST (*CURRENT-BLOCK* BD-LIST)
+                           (LET* ((LOOKUP (ASSOC NAME (BLOCK-DECL-FN-NAME-MAP *CURRENT-BLOCK*)))
+                                  (NEW-NAME (IF (NULL LOOKUP)
+                                                NAME
+                                                (CDR LOOKUP)))
+                                  (IL:SPECVARS (BLOCK-DECL-SPECVARS *CURRENT-BLOCK*))
+                                  (IL:LOCALVARS (BLOCK-DECL-LOCALVARS *CURRENT-BLOCK*))
+                                  (IL:LOCALFREEVARS (BLOCK-DECL-LOCALFREEVARS *CURRENT-BLOCK*))
+                                  (IL:GLOBALVARS (BLOCK-DECL-GLOBALVARS *CURRENT-BLOCK*)))
+                                 (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS 
+                                                     IL:GLOBALVARS))
+                                 (COMPILE-AND-DUMP-1 NEW-NAME DEFN KIND)))))))
+           (T (COMPILE-AND-DUMP-1 NAME DEFN KIND)))))
+
+(DEFUN COMPILE-AND-DUMP-1 (NAME DEFN KIND)               (IL:* IL:\; 
+                                                           "Edited 29-Jan-92 15:58 by jrb:")
+   (WHEN (EQ KIND :FUNCTION)
+       (PUSH NAME *PROCESSED-FUNCTIONS*)
+       (SETQ *UNKNOWN-FUNCTIONS* (REMOVE NAME *UNKNOWN-FUNCTIONS* :KEY 'CAR)))
+   (LET* ((*CURRENT-FUNCTION* NAME)
+          (LAP-FN (COMPILE-ONE-LAMBDA NAME DEFN))
+          DCODE)
+         (WHEN (STREAMP *LAP-STREAM*)
+             (PPRINT LAP-FN *LAP-STREAM*)
+             (TERPRI *LAP-STREAM*)
+             (TERPRI *LAP-STREAM*))
+         (WHEN *COMPILE-PRINT* (PRINC "."))
+         (IL:BLOCK)
+         (CONDITION-CASE (SETQ DCODE (D-ASSEM:ASSEMBLE-FUNCTION LAP-FN))
+                (ASSEMBLER-ERROR (CONDITION)
+                       (FORMAT *ERROR-OUTPUT* "~&~A~%" CONDITION)
+                       (PRINC "Aborted.")
+                       (TERPRI)
+                       (RETURN-FROM COMPILE-AND-DUMP-1 NIL)))
+         (WHEN *COMPILE-PRINT* (PRINC "."))
+         (IL:BLOCK)
+         (ECASE KIND
+             ((:FUNCTION) (FASL:DUMP-FUNCTION-DEF *FASL-HANDLE* DCODE NAME))
+             ((:ONE-SHOT) (FASL:DUMP-FUNCALL *FASL-HANDLE* DCODE)))
+         (WHEN *COMPILE-PRINT* (PRINC "."))
+         (IL:BLOCK)
+         (WHEN (NOT (NULL *LOAD-COMPILED-CODE*))
+             (ECASE KIND
+                 (:FUNCTION 
+                    (WHEN (AND (EQ :SAVE *LOAD-COMPILED-CODE*)
+                               (FBOUNDP NAME)
+                               (CONSP (SYMBOL-FUNCTION NAME))
+                               (NOT (IL:HASDEF NAME 'IL:FUNCTIONS)))
+                        (SETF (GET NAME 'IL:EXPR)
+                              (SYMBOL-FUNCTION NAME)))
+                    (SETF (SYMBOL-FUNCTION NAME)
+                          (D-ASSEM:INTERN-DCODE DCODE)))
+                 (:ONE-SHOT (LET ((IL:FILEPKGFLG NIL))       (IL:* IL:\; 
+                        "so that things don't get marked as changed when you execute the one-shot.")
+                                 (DECLARE (SPECIAL IL:FILEPKGFLG))
+                                 (FUNCALL (D-ASSEM:INTERN-DCODE DCODE))))))))
+
+(DEFUN COMPILE-ONE-LAMBDA (NAME DEFN)
+
+(IL:* IL:|;;;| "Return a LAP function for the given function definition.  NAME is the symbol with which the definition will be associated at load time and DEFN is the LAMBDA-expression to be compiled.")
+
+   (LET ((*CONTEXT* *NULL-CONTEXT*)
+         (*AUTOMATIC-SPECIAL-DECLARATIONS* NIL))
+        (LET ((TREE (ALPHA-LAMBDA DEFN :NAME NAME))
+              LAP-CODE)
+             (UNWIND-PROTECT
+                 (SETQ LAP-CODE (PEEPHOLE-OPTIMIZE (GENERATE-CODE (ANNOTATE-TREE (META-EVALUATE
+                                                                                  TREE)))))
+                 (RELEASE-TREE TREE))
+             LAP-CODE)))
+
+(DEFUN OPTIMIZE-AND-MACROEXPAND (FORM &OPTIONAL (ENVIRONMENT *ENVIRONMENT*)
+                                          (CONTEXT *CONTEXT*))
+
+(IL:* IL:|;;;| "Analagous to MACROEXPAND: keep trying OPTIMIZE-AND-MACROEXPAND-1 until it fails to change the form.")
+
+   (PROG (NEW-FORM CHANGED-P)
+         (MULTIPLE-VALUE-SETQ (NEW-FORM CHANGED-P)
+                (OPTIMIZE-AND-MACROEXPAND-1 FORM ENVIRONMENT CONTEXT))
+         (UNLESS CHANGED-P
+             (RETURN (VALUES FORM NIL)))
+     LOOP
+         (MULTIPLE-VALUE-SETQ (NEW-FORM CHANGED-P)
+                (OPTIMIZE-AND-MACROEXPAND-1 NEW-FORM ENVIRONMENT CONTEXT))
+         (IF CHANGED-P
+             (GO LOOP)
+             (RETURN (VALUES NEW-FORM T)))))
+
+(DEFUN OPTIMIZE-AND-MACROEXPAND-1 (FORM &OPTIONAL (ENVIRONMENT *ENVIRONMENT*)
+                                            (CONTEXT *CONTEXT*))
+
+(IL:* IL:|;;;| "If the given form is a list, then look for macros and optimizers defined for its CAR.  Return two values like MACROEXPAND-1.")
+
+   (LET ((*NEW-COMPILER-IS-EXPANDING* T))
+        (COND
+           ((OR (ATOM FORM)
+                (NOT (SYMBOLP (CAR FORM))))
+            (VALUES FORM NIL))
+           (T 
+              (IL:* IL:|;;| "Check for compiler optimizers.")
+
+              (LET ((OPTIMIZERS (OPTIMIZER-LIST (CAR FORM))))
+                   (WHEN (AND (NOT (NULL OPTIMIZERS))
+                              (NOT (ENV-FBOUNDP ENVIRONMENT (CAR FORM)
+                                          :LEXICAL-ONLY T))
+                              (NOT (ENV-INLINE-DISALLOWED ENVIRONMENT (CAR FORM))))
+                                                             (IL:* IL:\; 
+       "Optimizers cannot apply to lexical functions or macros or to functions declared NOTINLINE.")
+                       (DOLIST (OPT-FN OPTIMIZERS)
+                           (LET ((RESULT (FUNCALL OPT-FN FORM ENVIRONMENT CONTEXT)))
+                                (UNLESS (OR (EQ RESULT 'PASS)
+                                            (EQ RESULT 'IL:IGNOREMACRO)
+                                            (EQ RESULT FORM))(IL:* IL:\; "This optimizer fired.")
+                                    (RETURN-FROM OPTIMIZE-AND-MACROEXPAND-1 (VALUES RESULT T)))))))
+
+              (IL:* IL:|;;| "Check for a macro expansion function.")
+
+              (MACROEXPAND-1 FORM ENVIRONMENT)))))
+
+(DEFMACRO EXPAND-DEFINER (DEFINER BODY-WITHOUT-COMMENTS &OPTIONAL ENVIRONMENT)
+   `(LET ((*NEW-COMPILER-IS-EXPANDING* T))
+         (XCL::%EXPAND-DEFINER ,DEFINER ,BODY-WITHOUT-COMMENTS ,ENVIRONMENT)))
+
+(DEFUN PROCESS-FORMS (PROCESS-ENTIRE-FILE)
+   (LET ((*DEFERRED-FORMS* NIL)
+         (*BLOCKS* NIL)
+         (*BLOCK-HASH-TABLE* NIL)
+         (*PREPROCESSING-PHASE* PROCESS-ENTIRE-FILE)
+         (EOF-VALUE '(NIL))
+         FORM)
+        (LOOP (IL:SKIPSEPRS *INPUT-STREAM*)
+              (WHEN (IL:EOFP *INPUT-STREAM*)
+                    (RETURN))
+              (SETQ FORM (LET ((*COMPILER-IS-READING* T))
+                              (READ *INPUT-STREAM* NIL EOF-VALUE)))
+              (WHEN (EQ FORM EOF-VALUE)
+                    (RETURN))
+              (IF PROCESS-ENTIRE-FILE
+                  (LET ((NEW-FORM (CASE (AND (CONSP FORM)
+                                             (CAR FORM))
+                                      (IL:PRETTYCOMPRINT 
+                                         (SETQ *INPUT-FILECOMS-VARIABLE* (CADR FORM))
+                                         NIL)
+                                      (IL:RPAQQ (IF (EQ (SECOND FORM)
+                                                        *INPUT-FILECOMS-VARIABLE*)
+
+                                                    (IL:* IL:|;;| 
+                                                  "Don't remove comments from file coms")
+
+                                                    FORM
+                                                    (REMOVE-COMMENTS FORM)))
+                                      (IL:DEFCLASS 
+
+                                         (IL:* IL:|;;| 
+                                       "Don't remove comments from LOOPS DEFCLASS forms")
+
+                                         FORM)
+                                      (OTHERWISE (REMOVE-COMMENTS FORM)))))
+                       (SCAN-ONE-FORM NEW-FORM *COMPILE-SCAN-CONTEXT*))
+                  (SCAN-ONE-FORM FORM *COMPILE-FILE-CONTEXT*)))
+        (WHEN PROCESS-ENTIRE-FILE
+            (LET ((*MAKING-SECOND-PASS* T)
+                  (*BLOCK-HASH-TABLE* (SET-UP-BLOCK-DECLS *BLOCKS*)))
+                 (MAPC #'(LAMBDA (FORM)
+                                (SCAN-ONE-FORM FORM *COMPILE-FILE-CONTEXT*))
+                       (NREVERSE *DEFERRED-FORMS*))))
+        (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS *COMPILE-FILE-CONTEXT*)))
+
+(DEFUN MAYBE-REMOVE-COMMENTS (FORM)
+   (COND
+      ((EQ 'IL:DEFCLASS (CAR FORM))
+       IL:FORM)
+      (T (REMOVE-COMMENTS FORM))))
+
+(DEFUN COMPILE-FILE-SETF-SYMBOL-FUNCTION (COMPILER-CONTEXT FORM)
+   (LET ((NAME-FORM (SECOND FORM))
+         (FUNCTION-FORM (THIRD FORM)))
+        (COND
+           ((AND (CONSTANTP NAME-FORM)
+                 (SYMBOLP (EVAL NAME-FORM))
+                 (FUNCTION-P FUNCTION-FORM))
+            (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)
+            (WHEN *EVAL-WHEN-COMPILE* (EVAL FORM))
+            (LET ((NAME (SECOND NAME-FORM))
+                  (DEFINITION (SECOND FUNCTION-FORM)))
+                 (COMPILER-APPLY PROCESS-FUNCTION COMPILER-CONTEXT (FORMAT NIL "~s ~a"
+                                                                              (CAR DEFINITION)
+                                                                              NAME)
+                        NAME DEFINITION)))
+           (T (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM)))))
+
+(DEFUN COMPILE-FILE-DEFINEQ (COMPILER-CONTEXT FORM)
+   (WHEN *EVAL-WHEN-COMPILE* (IL:EVAL FORM))
+   (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)
+   (MAPCAR #'(LAMBDA (DEFN)
+                    (LET ((REAL-DEFN (IF (NULL (CDDR DEFN))
+                                         (SECOND DEFN)
+                                         (CONS 'IL:LAMBDA (CDR DEFN)))))
+                         (COMPILER-APPLY PROCESS-FUNCTION COMPILER-CONTEXT (FORMAT NIL "~s ~s"
+                                                                                      (CAR REAL-DEFN)
+                                                                                      (CAR DEFN))
+                                (CAR DEFN)
+                                REAL-DEFN)))
+          (CDR FORM)))
+
+(DEFUN COMPILE-FILE-DEFCONSTANT (COMPILER-CONTEXT FORM)
+   (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)
+   (DESTRUCTURING-BIND (NAME SYMBOL INITIAL-VALUE &OPTIONAL DOC)
+          FORM
+          (LET ((VALUE NIL))
+               (IF (AND (CONSTANT-EXPRESSION-P INITIAL-VALUE)
+                        (VALUE-FOLDABLE-P (SETQ VALUE (EVAL INITIAL-VALUE))))
+                   (SETF (CONSTANT-VALUE SYMBOL)
+                         VALUE)
+                   (ENV-DECLARE-A-GLOBAL (FIND-TOP-ENVIRONMENT *ENVIRONMENT*)
+                          SYMBOL)))
+          (SCAN-ONE-FORM `(NAMED-PROGN DEFCONSTANT ,SYMBOL
+                                     (LOCALLY (DECLARE (GLOBAL ,SYMBOL))
+                                            ,(EXPAND-DEFINER 'DEFCONSTANT (REMOVE-COMMENTS FORM)
+                                                    *ENVIRONMENT*)))
+                 COMPILER-CONTEXT)))
+
+(DEFUN COMPILE-FILE-DECLARE\: (COMPILER-CONTEXT FORM &OPTIONAL (DOCOPY T))
+                                                             (IL:* IL:\; 
+                                                           "Edited 31-Jan-92 12:57 by jrb:")
+   (LET ((*EVAL-WHEN-COMPILE* *EVAL-WHEN-COMPILE*))
+        (DO ((TAIL (CDR FORM)
+                   (CDR TAIL)))
+            ((ENDP TAIL))
+          (COND
+             ((SYMBOLP (CAR TAIL))
+              (CASE (CAR TAIL)
+                  ((IL:EVAL@LOAD IL:DOEVAL@LOAD IL:DONTEVAL@LOAD) NIL)
+                  ((IL:EVAL@LOADWHEN) (POP TAIL))
+                  ((IL:EVAL@COMPILE IL:DOEVAL@COMPILE) (SETQ *EVAL-WHEN-COMPILE* T))
+                  ((IL:DONTEVAL@COMPILE) (SETQ *EVAL-WHEN-COMPILE* NIL))
+                  ((IL:EVAL@COMPILEWHEN) (SETQ *EVAL-WHEN-COMPILE* (IL:EVAL
+                                                                    (CAR (SETQ TAIL (CDR TAIL))))))
+                  ((IL:COPY IL:DOCOPY) (SETQ DOCOPY T))
+                  ((IL:DONTCOPY) (SETQ DOCOPY NIL))
+                  ((IL:COPYWHEN) (SETQ DOCOPY (IL:EVAL (CAR (SETQ TAIL (CDR TAIL))))))
+                  ((IL:FIRST) )
+                  ((IL:NOTFIRST IL:COMPILERVARS) )
+                  (OTHERWISE (COMPILER-WARNING 
+                                    "Warning: Ignoring unrecognized DECLARE: tag: ~S~%" (CAR TAIL))))
+              )
+             ((EQ 'IL:DECLARE\: (CAR (CAR TAIL)))
+              (COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT (CAR TAIL)
+                     DOCOPY))
+             ((EQ 'IL:BLOCK\: (CAR (CAR TAIL)))
+              (IF (NULL *PREPROCESSING-PHASE*)
+                  (COMPILER-CERROR "Ignore the BLOCK: declaration." 
+           "Files with Interlisp BLOCK: declarations must be compiled with :PROCESS-ENTIRE-FILE = T."
+                         )
+                  (PUSH (CDR (CAR TAIL))
+                        *BLOCKS*)))
+             (T (WHEN *EVAL-WHEN-COMPILE*
+                    (IL:EVAL (CAR TAIL)))
+                (WHEN DOCOPY
+                    (SCAN-ONE-FORM (CAR TAIL)
+                           COMPILER-CONTEXT)))))))
+
+(DEFUN COMPILE-FILE-DEFINE-FILE-INFO (COMPILER-CONTEXT FORM)
+   (LET ((*STANDARD-INPUT* *INPUT-STREAM*)
+         IL:FILECREATEDLOC)
+        (DECLARE (SPECIAL *STANDARD-INPUT* IL:FILECREATEDLOC))
+        (EVAL FORM))
+   (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT
+          `(LET ((*STANDARD-INPUT* (OPEN "{Null}" :DIRECTION :OUTPUT))
+                 IL:FILECREATEDLOC)
+                (DECLARE (SPECIAL *STANDARD-INPUT* IL:FILECREATEDLOC))
+                ,FORM))
+   (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT))
+
+(DEFUN COMPILE-FILE-PACKAGE-FORM (COMPILER-CONTEXT FORM)
+   (UNLESS *MAKING-SECOND-PASS* (EVAL FORM))
+   (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM)
+   (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT))
+
+(DEFUN COMPILE-FILE-PROCLAMATION (COMPILER-CONTEXT FORM) (IL:* IL:\; 
+                                                           "Edited 31-Jan-92 11:59 by jrb:")
+   (DECLARE (SPECIAL IL:GLOBALVARS IL:SPECVARS IL:LOCALVARS))
+   (LET ((FORM (EVAL (SECOND FORM)))
+         (TOP-ENV (FIND-TOP-ENVIRONMENT *ENVIRONMENT*)))
+        (IF (ATOM FORM)
+            (COMPILER-CERROR "Ignore the proclamation." "Illegal form in PROCLAIM:~%~S" FORM)
+            (CASE (CAR FORM)
+                ((SPECIAL) (MAPC #'(LAMBDA (SYMBOL)
+                                          (ENV-PROCLAIM-SPECIAL TOP-ENV SYMBOL))
+                                 (CDR FORM)))
+                ((GLOBAL) (MAPC #'(LAMBDA (SYMBOL)
+                                         (ENV-PROCLAIM-GLOBAL TOP-ENV SYMBOL))
+                                (CDR FORM)))
+                ((IL:GLOBALVARS) (SETQ IL:GLOBALVARS (UNION IL:GLOBALVARS (CDR FORM))))
+                ((IL:SPECVARS) (COND
+                                  ((CONSP (CDR FORM))
+                                   (UNLESS (EQ IL:SPECVARS T)
+                                       (SETQ IL:SPECVARS (UNION IL:SPECVARS (CDR FORM)))))
+                                  ((EQ (CDR FORM)
+                                       T)
+                                   (SETQ IL:SPECVARS T)
+                                   (SETQ IL:LOCALVARS IL:SYSLOCALVARS))
+                                  (T (COMPILER-CERROR "Ignore it" 
+                                            "Illegal SPECVARS proclamation: ~S" FORM))))
+                ((IL:LOCALVARS) (COND
+                                   ((CONSP (CDR FORM))
+                                    (UNLESS (EQ IL:LOCALVARS T)
+                                        (SETQ IL:LOCALVARS (UNION IL:LOCALVARS (CDR FORM)))))
+                                   ((EQ (CDR FORM)
+                                        T)
+                                    (SETQ IL:LOCALVARS T)
+                                    (SETQ IL:SPECVARS IL:SYSSPECVARS))
+                                   (T (COMPILER-CERROR "Ignore it" 
+                                             "Illegal LOCALVARS proclamation: ~S" FORM))))
+                ((TYPE FTYPE IL:FUNCTION FUNCTION) NIL)
+                ((INLINE) (ENV-ALLOW-INLINES TOP-ENV (CDR FORM)))
+                ((NOTINLINE) (ENV-DISALLOW-INLINES TOP-ENV (CDR FORM)))
+                ((IGNORE OPTIMIZE) NIL)
+                ((DECLARATION) (ENV-ADD-DECLS TOP-ENV (CDR FORM)))
+                (OTHERWISE (UNLESS (OR (LISP::TYPE-EXPANDER (CAR FORM))
+                                       (XCL::DECL-SPECIFIER-P (CAR FORM))
+                                       (ENV-DECL-P TOP-ENV (CAR FORM)))
+                               (COMPILER-CERROR "Ignore it." 
+                                      "Unknown declaration specifier in PROCLAIM: ~S." (CAR FORM))))))
+        )
+   (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM))
+
+(DEFUN COMPILE-FILE-COMPILER-LET (COMPILER-CONTEXT FORM) (IL:* IL:\; 
+                                                           "Edited 31-Jan-92 11:55 by jrb:")
+   (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)
+   (DESTRUCTURING-BIND (BINDING-LIST &REST INNER-FORMS)
+          (CDR FORM)
+          (LET (VARS VALS)
+               (DOLIST (BINDING BINDING-LIST)
+                   (COND
+                      ((ATOM BINDING)
+                       (PUSH BINDING VARS)
+                       (PUSH NIL VALS))
+                      ((NULL (CDR BINDING))
+                       (PUSH (CAR BINDING)
+                             VARS)
+                       (PUSH NIL VALS))
+                      ((AND (CONSP (CDR BINDING))
+                            (NULL (CDDR BINDING)))
+                       (PUSH (CAR BINDING)
+                             VARS)
+                       (PUSH (EVAL (CADR BINDING))
+                             VALS))
+                      (T (COMPILER-CERROR "Bind the CAR of the binding to NIL" 
+                                "Bad binding in COMPILER-LET: ~S" BINDING)
+                         (PUSH (CAR BINDING)
+                               VARS)
+                         (PUSH NIL VALS))))
+               (PROGV VARS VALS
+                   (MAPC #'(LAMBDA (FORM)
+                                  (SCAN-ONE-FORM FORM COMPILER-CONTEXT))
+                         INNER-FORMS)
+                   (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)))))
+
+(DEFUN COMPILE-FILE-MACROLET (COMPILER-CONTEXT FORM)
+   (DESTRUCTURING-BIND (JUNK MACRO-DEFNS &BODY BODY)
+          FORM
+          (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)
+          (LET ((*ENVIRONMENT* (MAKE-CHILD-ENV *ENVIRONMENT*)))
+               (DOLIST (MACRO-DEFN MACRO-DEFNS)
+                   (ENV-BIND-FUNCTION *ENVIRONMENT* (CAR MACRO-DEFN)
+                          :MACRO
+                          (CRACK-DEFMACRO (CONS 'DEFMACRO MACRO-DEFN))))
+               (DOLIST (FORM BODY)
+                   (SCAN-ONE-FORM FORM COMPILER-CONTEXT))
+               (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT))))
+
+(DEFUN COMPILE-FILE-DEFINER (COMPILER-CONTEXT FORM)
+   (DESTRUCTURING-BIND (TYPE DEFINER DEFINITION &OPTIONAL ENV)
+          (CDR FORM)
+          (LET* ((MACRO-DEFINITION (REMOVE-COMMENTS DEFINITION))
+                 (NAME (XCL::%DEFINER-NAME DEFINER MACRO-DEFINITION))
+                 (BODY (EXPAND-DEFINER DEFINER MACRO-DEFINITION ENV)))
+                (IF *COMPILING-DEFINER*
+                    (SCAN-ONE-FORM BODY COMPILER-CONTEXT)
+                    (PROGN (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)
+                           (LET ((*COMPILING-DEFINER* T)
+                                 (*LOOSE-NAME* (FORMAT NIL "~s ~s" DEFINER NAME)))
+                                (COMPILING-MESSAGE *LOOSE-NAME*)
+                                (SCAN-ONE-FORM BODY COMPILER-CONTEXT)
+                                (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)
+                                (DONE-MESSAGE)))))))
+
+(DEFUN COMPILE-FILE-NAMED-PROGN (COMPILER-CONTEXT FORM)
+   (DESTRUCTURING-BIND (DEFINER-NAME NAME &REST PROGN-FORMS)
+          (CDR FORM)
+          (IF *COMPILING-DEFINER*
+              (MAPC #'(LAMBDA (FORM)
+                             (SCAN-ONE-FORM FORM COMPILER-CONTEXT))
+                    PROGN-FORMS)
+              (PROGN (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)
+                     (LET ((*COMPILING-DEFINER* T)
+                           (*LOOSE-NAME* (FORMAT NIL "~s ~s" DEFINER-NAME NAME)))
+                          (COMPILING-MESSAGE *LOOSE-NAME*)
+                          (MAPC #'(LAMBDA (FORM)
+                                         (SCAN-ONE-FORM FORM COMPILER-CONTEXT))
+                                PROGN-FORMS)
+                          (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)
+                          (DONE-MESSAGE))))))
+
+(DEFUN COMPILE-FILE-OUTSTANDING-LOOSE-FORMS (COMPILER-CONTEXT)
+   (WHEN (NOT (NULL *OUTSTANDING-LOOSE-FORMS*))
+       (IF *COMPILING-DEFINER*
+           (COMPILE-AND-DUMP *LOOSE-NAME* `(LAMBDA NIL ,@(REVERSE *OUTSTANDING-LOOSE-FORMS*))
+                  :ONE-SHOT)
+           (LET ((NAME (FORMAT NIL "~&~D top-level form~:P" (LIST-LENGTH *OUTSTANDING-LOOSE-FORMS*)))
+                 )
+                (COMPILING-MESSAGE NAME)
+                (COMPILE-AND-DUMP NAME `(LAMBDA NIL ,@(REVERSE *OUTSTANDING-LOOSE-FORMS*))
+                       :ONE-SHOT)
+                (DONE-MESSAGE)))
+       (SETQ *OUTSTANDING-LOOSE-FORMS* NIL)))
+
+(DEFUN COMPILE-FILE-LOOSE-FORM (COMPILER-CONTEXT FORM)
+   (WHEN *EVAL-WHEN-COMPILE* (EVAL FORM))
+   (PUSH FORM *OUTSTANDING-LOOSE-FORMS*))
+
+(DEFUN COMPILE-FILE-PROCESS-FUNCTION (COMPILER-CONTEXT MESSAGE NAME DEFINITION)
+   (IF *COMPILING-DEFINER*
+       (COMPILE-AND-DUMP NAME DEFINITION :FUNCTION)
+       (PROGN (COMPILING-MESSAGE MESSAGE)
+              (COMPILE-AND-DUMP NAME DEFINITION :FUNCTION)
+              (DONE-MESSAGE)))
+   NAME)
+
+(DEFUN CRACK-DEFMACRO (FORM)
+
+(IL:* IL:|;;;| "FORM is a call to DEFMACRO.  Return two values: the LAMBDA-expression representing the expansion function for the macro and the documentation string, if present.")
+
+   (LET ((NAME (SECOND FORM))
+         (ARG-LIST (THIRD FORM))
+         (BODY (CDDDR FORM))
+         (WHOLE (GENSYM))
+         (ENV-VAR (GENSYM)))
+        (MULTIPLE-VALUE-BIND (CODE DECLS DOC)
+               (IL:PARSE-DEFMACRO ARG-LIST WHOLE BODY NAME *ENVIRONMENT* :ENVIRONMENT ENV-VAR)
+               (VALUES `(LAMBDA (,WHOLE ,ENV-VAR)
+                               ,@DECLS
+                               (BLOCK ,NAME ,CODE))
+                      DOC))))
+
+(DEFUN ESTABLISH-MACRO-IN-COMPILER (NAME EXPN-FN)
+
+(IL:* IL:|;;;| "Arrange for the symbol NAME to refer to a macro with the given expansion-function EXPN-FN within this compilation.")
+
+   (ENV-BIND-FUNCTION (FIND-TOP-ENVIRONMENT *ENVIRONMENT*)
+          NAME :MACRO EXPN-FN))
+
+
+
+(IL:* IL:|;;| "Support for :Process-Entire-File")
+
+
+(DEFVAR *DEFERRED-FORMS* NIL
+   "A list onto which most forms will be pushed if we are preprocessing an Interlisp-format file.  After the first pass through the file is done, and all macros and other eval-when(compile) forms have been processed, a second pass will be made down this list to actually compile the forms."
+)
+
+(DEFVAR *MAKING-SECOND-PASS* NIL
+
+(IL:* IL:|;;;| "Bound to T during second pass over saved forms; used for :Process-Entire-File option to compile-file.")
+
+   )
+
+(DEFVAR *PREPROCESSING-PHASE* NIL
+
+(IL:* IL:|;;;| "Bound to T during the preprocessing phase so that inferiors can tell.")
+
+   )
+
+(DEFUN COMPILE-SCAN-DECLARE\: (COMPILER-CONTEXT FORM &OPTIONAL (DOCOPY T)
+                                         (DOFIRST NIL))      (IL:* IL:\; 
+                                                           "Edited 31-Jan-92 12:59 by jrb:")
+   (LET ((FIRST-FORMS NIL)
+         (IL:DFNFLG IL:DFNFLG)
+         (*EVAL-WHEN-COMPILE* *EVAL-WHEN-COMPILE*))
+        (DO ((TAIL (CDR FORM)
+                   (CDR TAIL)))
+            ((ENDP TAIL)
+             (WHEN FIRST-FORMS (MERGE-FIRST-FORMS FIRST-FORMS)))
+          (COND
+             ((SYMBOLP (CAR TAIL))
+              (CASE (CAR TAIL)
+                  ((IL:EVAL@LOAD IL:DOEVAL@LOAD IL:DONTEVAL@LOAD) NIL)
+                  ((IL:EVAL@LOADWHEN) (POP TAIL))
+                  ((IL:EVAL@COMPILE IL:DOEVAL@COMPILE) (SETQ *EVAL-WHEN-COMPILE* T))
+                  ((IL:DONTEVAL@COMPILE) (SETQ *EVAL-WHEN-COMPILE* NIL))
+                  ((IL:EVAL@COMPILEWHEN) (SETQ *EVAL-WHEN-COMPILE* (IL:EVAL
+                                                                    (CAR (SETQ TAIL (CDR TAIL))))))
+                  ((IL:COPY IL:DOCOPY) (SETQ DOCOPY T))
+                  ((IL:DONTCOPY) (SETQ DOCOPY NIL))
+                  ((IL:COPYWHEN) (SETQ DOCOPY (IL:EVAL (CAR (SETQ TAIL (CDR TAIL))))))
+                  ((IL:FIRST) (SETQ DOFIRST T))
+                  ((IL:NOTFIRST) (SETQ DOFIRST NIL))
+                  ((IL:COMPILERVARS) (SETQ IL:DFNFLG T))
+                  (OTHERWISE (COMPILER-WARNING 
+                                    "Warning: Ignoring unrecognized DECLARE: tag: ~S~%" (CAR TAIL))))
+              )
+             ((EQ 'IL:DECLARE\: (CAR (CAR TAIL)))
+              (COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT (CAR TAIL)
+                     DOCOPY DOFIRST))
+             ((EQ 'IL:BLOCK\: (CAR (CAR TAIL)))
+              (PUSH (CDR (CAR TAIL))
+                    *BLOCKS*))
+             (T (WHEN *EVAL-WHEN-COMPILE*
+                    (IL:EVAL (CAR TAIL)))
+                (WHEN DOCOPY
+                    (IF DOFIRST
+                        (LET ((*DEFERRED-FORMS* NIL))
+                             (SCAN-ONE-FORM (CAR TAIL)
+                                    COMPILER-CONTEXT)
+                             (SETQ FIRST-FORMS (APPEND FIRST-FORMS *DEFERRED-FORMS*)))
+                        (SCAN-ONE-FORM (CAR TAIL)
+                               COMPILER-CONTEXT))))))))
+
+(DEFUN COMPILE-SCAN-DEFINE-FILE-INFO (COMPILER-CONTEXT FORM)
+   (LET ((*STANDARD-INPUT* *INPUT-STREAM*)
+         IL:FILECREATEDLOC)
+        (DECLARE (SPECIAL *STANDARD-INPUT* IL:FILECREATEDLOC))
+        (EVAL FORM))
+   (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM)
+   (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT))
+
+(DEFUN COMPILE-SCAN-MACROLET (COMPILER-CONTEXT FORM)
+   (DESTRUCTURING-BIND (JUNK MACRO-DEFNS &BODY BODY)
+          FORM
+          (LET (OUTER-DEFERRED-FORMS)
+               (LET ((*DEFERRED-FORMS* NIL)
+                     (*ENVIRONMENT* (MAKE-CHILD-ENV *ENVIRONMENT*)))
+                    (DOLIST (MACRO-DEFN MACRO-DEFNS)
+                        (ENV-BIND-FUNCTION *ENVIRONMENT* (CAR MACRO-DEFN)
+                               :MACRO
+                               (CRACK-DEFMACRO (CONS 'DEFMACRO MACRO-DEFN))))
+                    (DOLIST (FORM BODY)
+                        (SCAN-ONE-FORM FORM COMPILER-CONTEXT))
+                    (SETQ OUTER-DEFERRED-FORMS *DEFERRED-FORMS*))
+               (WHEN (NOT (NULL OUTER-DEFERRED-FORMS))
+                   (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT
+                          `(MACROLET ,MACRO-DEFNS ,@(REVERSE OUTER-DEFERRED-FORMS)))))))
+
+(DEFUN COMPILE-SCAN-DEFINER (COMPILER-CONTEXT FORM)
+   (DESTRUCTURING-BIND (TYPE DEFINER DEFINITION &OPTIONAL ENV)
+          (CDR FORM)
+          (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT
+                 (LET* ((*DEFERRED-FORMS* NIL)
+                        (MACRO-DEFINITION (REMOVE-COMMENTS DEFINITION))
+                        (NAME (XCL::%DEFINER-NAME DEFINER MACRO-DEFINITION))
+                        (BODY (EXPAND-DEFINER DEFINER MACRO-DEFINITION ENV)))
+                       (SCAN-ONE-FORM BODY COMPILER-CONTEXT)
+                       `(NAMED-PROGN ,DEFINER ,NAME ,@(NREVERSE *DEFERRED-FORMS*))))))
+
+(DEFUN COMPILE-SCAN-LOOSE-FORM (COMPILER-CONTEXT FORM)
+   (WHEN *EVAL-WHEN-COMPILE* (EVAL FORM))
+   (PUSH FORM *DEFERRED-FORMS*))
+
+(DEFUN COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS (COMPILER-CONTEXT)
+   NIL)
+
+(DEFUN MERGE-FIRST-FORMS (FORMS)
+   (DO* ((TAIL *DEFERRED-FORMS* (CDR TAIL))
+         (NEW-TAIL (CDR TAIL)
+                (CDR TAIL)))
+        ((ENDP TAIL)
+         (IF (NULL NEW-TAIL)
+             (NCONC *DEFERRED-FORMS* FORMS))
+         NIL)
+      (WHEN (EQL (CAAR NEW-TAIL)
+                 'IL:FILECREATED)
+          (SETF (CDR TAIL)
+                FORMS)
+          (SETF (CDR (LAST FORMS))
+                NEW-TAIL)
+          (RETURN))))
+
+
+
+(IL:* IL:|;;| "for compiling definers")
+
+
+(DEFVAR *LAP-FLG* NIL)
+
+(DEFVAR *AUTOMATIC-SPECIAL-DECLARATIONS*)
+
+(DEFUN COMPILE (NAME &OPTIONAL DEFN &KEY LAP)            (IL:* IL:\; 
+                                                           "Edited 31-Jan-92 15:34 by jrb:")
+
+   (IL:* IL:|;;| "COMPILE now uses the XCL::NAME-OF-EXECUTABLE name-mapping service; this blots up a lot of junk special-cases.")
+
+   (LET ((EXECUTABLE-NAME (XCL::NAME-OF-EXECUTABLE NAME)))
+        (IF (AND NAME (NULL EXECUTABLE-NAME))
+            (ERROR "~s is not a function name" NAME)
+            (PROGN (IL:VIRGINFN NAME T)
+                   (COND
+                      ((EQ NAME EXECUTABLE-NAME)
+                       (COMPILE-SYMBOL-FUNCTION NAME DEFN LAP))
+                      (DEFN (COMPILE-SYMBOL-FUNCTION EXECUTABLE-NAME DEFN LAP NAME))
+                      ((LISP::SETF-NAME-P NAME)
+
+                       (IL:* IL:|;;| "We have to special-case this one because (SETF FOO) is not the file-package name of (DEFUN (SETF FOO)...).")
+
+                       (LET ((REAL-NAME (SECOND NAME))
+                             (SETF-DEFN (IL:GETD EXECUTABLE-NAME)))
+                            (TYPECASE SETF-DEFN
+                                (CONS (COMPILE-SYMBOL-FUNCTION EXECUTABLE-NAME SETF-DEFN LAP NAME
+                                             ))
+                                ((OR NULL IL:COMPILED-CLOSURE) 
+                                   (FORMAT T (IF SETF-DEFN
+                                                 "~s is already compiled"
+                                                 "~s has no installed definition")
+                                          NAME)
+                                   (IF (AND (IL:HASDEF REAL-NAME 'IL:SETFS)
+                                            (EQ (CAR (IL:GETDEF REAL-NAME 'IL:SETFS))
+                                                'DEFUN)
+                                            (Y-OR-N-P "Shall I use the SETFS definition? "))
+                                       (BUMP-DIAGNOSTIC-COUNT (COMPILE-DEFINER REAL-NAME
+                                                                         'IL:SETFS :LAP LAP))
+                                       (VALUES NIL 1 1)))
+                                (OTHERWISE 
+                                   (FORMAT T 
+          "There's something funny installed as the definition for ~S.~%I'm not going any further.~%"
+                                          NAME)
+                                   (VALUES NIL 1 1)))))
+                      (T (COMPILE-SYMBOL-FUNCTION EXECUTABLE-NAME NIL LAP NAME)))))))
+
+(DEFUN COMPILE-SYMBOL-FUNCTION (NAME DEFN LAP &OPTIONAL (REAL-NAME NAME))
+                                                             (IL:* IL:\; 
+                                                           "Edited 31-Jan-92 15:36 by jrb:")
+   (LET ((DIAGS 0))
+        (WHEN (NULL DEFN)
+            (SETQ DEFN (IL:GETD NAME))
+            (TYPECASE DEFN
+                (CONS NIL)
+                ((OR NULL IL:COMPILED-CLOSURE) 
+                   (IF (NULL DEFN)
+                       (FORMAT T "There's no installed definition for ~S.~%" REAL-NAME)
+                       (FORMAT T "~S is already compiled.~%" REAL-NAME))
+                   (WHEN (AND (IL:HASDEF REAL-NAME 'IL:FUNCTIONS)
+                              (Y-OR-N-P "Shall I use the FUNCTIONS definition? "))
+                       (RETURN-FROM COMPILE-SYMBOL-FUNCTION (BUMP-DIAGNOSTIC-COUNT
+                                                             (COMPILE-DEFINER REAL-NAME
+                                                                    'IL:FUNCTIONS :LAP LAP))))
+                   (WHEN (AND (GET NAME 'IL:EXPR)
+                              (Y-OR-N-P "Shall I use the definition on the EXPR property? " NAME))
+                       (BUMP-DIAGNOSTIC-COUNT (RETURN-FROM COMPILE-SYMBOL-FUNCTION
+                                                         (COMPILE NAME (GET NAME 'IL:EXPR)
+                                                                :LAP LAP))))
+                   (RETURN-FROM COMPILE-SYMBOL-FUNCTION (VALUES NIL 1 1)))
+                (OTHERWISE 
+                   (FORMAT T 
+          "There's something funny installed as the definition for ~S.~%I'm not going any further.~%"
+                          NAME)
+                   (RETURN-FROM COMPILE-SYMBOL-FUNCTION (VALUES NIL 1 1)))))
+        (LET* ((*ENVIRONMENT* (MAKE-ENV :PARENT T :TARGET-ARCHITECTURE *HOST-ARCHITECTURE*))
+               (IL:SPECVARS IL:SPECVARS)
+               (IL:LOCALVARS IL:LOCALVARS)
+               (IL:LOCALFREEVARS NIL)
+               (IL:GLOBALVARS IL:GLOBALVARS)
+               (*CONSTANTS-HASH-TABLE* (MAKE-HASH-TABLE))
+               (*PROCESSED-FUNCTIONS* (LIST NAME))
+               (*UNKNOWN-FUNCTIONS* NIL)
+               (*CURRENT-FUNCTION* NAME)
+               (*INPUT-STREAM* NIL)
+               (*LAP-FLG* LAP)                               (IL:* IL:\; "FXAR-111")
+               (*ANY-DIAGNOSTICS* 0)
+               (*ANY-SERIOUS-DIAGNOSTICS* 0)
+               (COMPILED-DEFN (RAW-COMPILE NAME DEFN)))
+              (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS))
+              (WARN-ABOUT-UNKNOWN-FUNCTIONS)
+              (COMPILATION-VALUES (IF (NULL NAME)
+                                          COMPILED-DEFN
+                                          (PROGN (WHEN (AND (NOT (IL:HASDEF NAME 'IL:FUNCTIONS))
+                                                            (CONSP (IL:GETD NAME)))
+                                                     (SETF (GET NAME 'IL:EXPR)
+                                                           (IL:GETD NAME)))
+                                                 (SETF (SYMBOL-FUNCTION NAME)
+                                                       COMPILED-DEFN)
+                                                 NAME))))))
+
+(DEFUN COMPILE-DEFINER (NAME TYPE &KEY LAP)              (IL:* IL:\; 
+                                                           "Edited 31-Jan-92 13:49 by jrb:")
+   (LET ((*ENVIRONMENT* (MAKE-ENV :PARENT T))
+         (*OUTSTANDING-LOOSE-FORMS* NIL)
+         (*EVAL-WHEN-COMPILE* NIL)
+         (*ANY-DIAGNOSTICS* 0)
+         (*ANY-SERIOUS-DIAGNOSTICS* 0))
+        (COMPILE-FORM (IL:GETDEF NAME TYPE NIL '(IL:NOCOPY T)))
+        (COMPILATION-VALUES NAME)))
+
+(DEFUN COMPILE-FORM (FORM &KEY LAP)                      (IL:* IL:\; 
+                                                           "Edited 31-Jan-92 15:20 by jrb:")
+   (LET ((*CONTEXT* (MAKE-CONTEXT :TOP-LEVEL-P T :VALUES-USED 0))
+         (*ENVIRONMENT* (MAKE-ENV :PARENT T))
+         (*CONSTANTS-HASH-TABLE* (MAKE-HASH-TABLE))
+         (*PROCESSED-FUNCTIONS* NIL)
+         (*UNKNOWN-FUNCTIONS* NIL)
+         (*OUTSTANDING-LOOSE-FORMS* NIL)
+         (*LAP-FLG* LAP)
+         (IL:SPECVARS IL:SPECVARS)
+         (IL:LOCALVARS IL:LOCALVARS)
+         (IL:LOCALFREEVARS NIL)
+         (IL:GLOBALVARS IL:GLOBALVARS)
+         VALUE)
+        (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS))
+        (PROGV (IF *ANY-DIAGNOSTICS*
+                   NIL
+                   `(*ANY-DIAGNOSTICS* *ANY-SERIOUS-DIAGNOSTICS*))
+               (IF *ANY-DIAGNOSTICS*
+                   NIL
+                   `(0 0))
+               (SETQ VALUE (MULTIPLE-VALUE-LIST (SCAN-ONE-FORM (REMOVE-COMMENTS FORM)
+                                                       *COMPILE-DEFINER-CONTEXT*)))
+               (IF *OUTSTANDING-LOOSE-FORMS*
+                   (SETQ VALUE (MULTIPLE-VALUE-LIST (COMPILER-APPLY 
+                                                           PROCESS-OUTSTANDING-LOOSE-FORMS 
+                                                           *COMPILE-DEFINER-CONTEXT*))))
+               (WARN-ABOUT-UNKNOWN-FUNCTIONS)
+               (COMPILATION-VALUES VALUE))))
+
+(DEFUN RAW-COMPILE (NAME DEFINITION)
+   (LET* ((*CURRENT-FUNCTION* NAME)
+          (LAP-FN (COMPILE-ONE-LAMBDA NAME DEFINITION))
+          COMPILED-DEFN)
+         (WHEN (NOT (NULL *LAP-FLG*))
+             (PPRINT LAP-FN (IF (STREAMP *LAP-FLG*)
+                                *LAP-FLG*
+                                *STANDARD-OUTPUT*)))
+         (CONDITION-CASE (SETQ COMPILED-DEFN (LET ((DCODE (D-ASSEM:ASSEMBLE-FUNCTION LAP-FN)))
+                                                  (UNWIND-PROTECT
+                                                      (D-ASSEM:INTERN-DCODE DCODE)
+                                                      (D-ASSEM:RELEASE-DCODE DCODE))))
+                (ASSEMBLER-ERROR (CONDITION)
+                       (FORMAT *ERROR-OUTPUT* "~&~A~%" CONDITION)
+                       (RETURN-FROM RAW-COMPILE NIL)))
+         COMPILED-DEFN))
+
+(DEFUN COMPILE-DEFINER-DEFINER (COMPILER-CONTEXT FORM)
+   (DESTRUCTURING-BIND (TYPE DEFINER DEFINITION &OPTIONAL ENV)
+          (CDR FORM)
+          (LET* ((MACRO-DEFINITION (REMOVE-COMMENTS DEFINITION))
+                 (NAME (XCL::%DEFINER-NAME DEFINER MACRO-DEFINITION))
+                 (BODY (EXPAND-DEFINER DEFINER MACRO-DEFINITION ENV)))
+                (IF *COMPILING-DEFINER*
+                    (SCAN-ONE-FORM BODY COMPILER-CONTEXT)
+                    (PROGN (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)
+                           (LET ((*COMPILING-DEFINER* T)
+                                 (*LOOSE-NAME* (FORMAT NIL "~s ~s" DEFINER NAME))
+                                 VALUE)
+                                (SETQ VALUE (SCAN-ONE-FORM BODY COMPILER-CONTEXT))
+                                (IF *OUTSTANDING-LOOSE-FORMS*
+                                    (SETQ VALUE (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS 
+                                                       COMPILER-CONTEXT)))
+                                VALUE))))))
+
+(DEFUN COMPILE-DEFINER-NAMED-PROGN (COMPILER-CONTEXT FORM)
+   (DESTRUCTURING-BIND (DEFINER-NAME NAME &REST PROGN-FORMS)
+          (CDR FORM)
+          (IF *COMPILING-DEFINER*
+              (MAPC #'(LAMBDA (FORM)
+                             (SCAN-ONE-FORM FORM COMPILER-CONTEXT))
+                    PROGN-FORMS)
+              (PROGN (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)
+                     (LET ((*COMPILING-DEFINER* T)
+                           (*LOOSE-NAME* (FORMAT NIL "~s ~s" DEFINER-NAME NAME)))
+                          (MAPC #'(LAMBDA (FORM)
+                                         (SCAN-ONE-FORM FORM COMPILER-CONTEXT))
+                                PROGN-FORMS)
+                          (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT))))
+          NAME))
+
+(DEFUN COMPILE-DEFINER-PROCESS-FUNCTION (COMPILER-CONTEXT MESSAGE NAME DEFINITION)
+   (PUSH NAME *PROCESSED-FUNCTIONS*)
+   (SETQ *UNKNOWN-FUNCTIONS* (REMOVE NAME *UNKNOWN-FUNCTIONS* :KEY 'CAR))
+   (LET ((*ENVIRONMENT* (COPY-ENV *ENVIRONMENT*))
+         COMPILED-DEFN)
+
+        (IL:* IL:|;;| "The resulting function is defined locally, so we have to compile for the host architecture rather than the target architecture:")
+
+        (SETF (ENV-TARGET-ARCHITECTURE *ENVIRONMENT*)
+              *HOST-ARCHITECTURE*)
+        (SETQ COMPILED-DEFN (RAW-COMPILE NAME DEFINITION))
+        (WHEN (AND (NOT (IL:HASDEF NAME 'IL:FUNCTIONS))
+                   (CONSP (IL:GETD NAME)))
+            (SETF (GET NAME 'IL:EXPR)
+                  (IL:GETD NAME)))
+        (SETF (SYMBOL-FUNCTION NAME)
+              COMPILED-DEFN)
+        NAME))
+
+(DEFUN COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS (COMPILER-CONTEXT)
+
+   (IL:* IL:|;;| 
+ "Compile any outstanding loose forms in the context of a structure definition being compiled")
+
+   (WHEN (NOT (NULL *OUTSTANDING-LOOSE-FORMS*))
+       (LET* ((*ENVIRONMENT* (COPY-ENV *ENVIRONMENT*))
+              COMPILED-DEFN)
+
+             (IL:* IL:|;;| "The resulting function is executed locally, so have to compile for the host architecture rather than the target architecture:")
+
+             (SETF (ENV-TARGET-ARCHITECTURE *ENVIRONMENT*)
+                   *HOST-ARCHITECTURE*)
+             (SETQ COMPILED-DEFN (RAW-COMPILE *LOOSE-NAME* `(LAMBDA NIL ,@(REVERSE 
+                                                                            *OUTSTANDING-LOOSE-FORMS*
+                                                                                     ))))
+             (SETQ *OUTSTANDING-LOOSE-FORMS* NIL)
+             (FUNCALL COMPILED-DEFN))))
+
+
+
+(IL:* IL:|;;| "Arrange for correct compiler to be used.")
+
+
+(IL:PUTPROPS IL:XCLC-TOP-LEVEL IL:FILETYPE :COMPILE-FILE)
+
+
+
+(IL:* IL:|;;| "Arrange for the correct makefile environment")
+
+
+(IL:PUTPROPS IL:XCLC-TOP-LEVEL IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE
+                                                                      (DEFPACKAGE "COMPILER"
+                                                                             (:USE "LISP" "XCL"))))
+(IL:PUTPROPS IL:XCLC-TOP-LEVEL IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1991
+ 1992 1993))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/XCLC-TOP-LEVEL.DFASL b/CLTL2/XCLC-TOP-LEVEL.DFASL
new file mode 100644
index 00000000..e9cab0b8
Binary files /dev/null and b/CLTL2/XCLC-TOP-LEVEL.DFASL differ
diff --git a/CLTL2/XP b/CLTL2/XP
new file mode 100644
index 00000000..5acc5706
--- /dev/null
+++ b/CLTL2/XP
@@ -0,0 +1,1360 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "XP" (USE "LISP") (SHADOW "CLEAR-OUTPUT" 
+"FORCE-OUTPUT" "FINISH-OUTPUT" "DEFSTRUCT" "FRESH-LINE" "TERPRI" "WRITE-CHAR" "WRITE-STRING" 
+"WRITE-LINE" "PRIN1-TO-STRING" "PRINC-TO-STRING" "WRITE-TO-STRING" "FORMAT" "PPRINT" "PRINC" "PRIN1" 
+"PRINT" "WRITE") (IMPORT-FROM "COMMON-LISP" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" 
+"*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT" "PPRINT-NEWLINE" 
+"PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR" "PPRINT-LINEAR" 
+"PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" "FORMATTER") (EXPORT 
+"*PRINT-SHARED*" "*LAST-ABBREVIATED-PRINTING*" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" 
+"*DEFAULT-RIGHT-MARGIN*" "*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT"
+ "PPRINT-NEWLINE" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR"
+ "PPRINT-LINEAR" "PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" 
+"FORMATTER")) BASE 10)
+(IL:FILECREATED " 4-Feb-93 15:08:51" IL:|{DSK}<usr>local>lde>lispcore>sources>XP.;12| 152559 
+
+      IL:|changes| IL:|to:|  (IL:FUNCTIONS DEF-FORMAT-HANDLER BQ-PRINT BQ-COMMA-PRINT BQ-COMMA@-PRINT)
+ (INITIAL-DISPATCH (CONS (MEMBER IL:BQUOTE)) (CONS (MEMBER IL:\\\,)) (CONS (MEMBER IL:\\\,@))) (FORMAT-HANDLERS #\/)
+ (IL:VARS IL:XPCOMS) (IL:VARIABLES *FAST-FORMATTER-SLASH-CALL* *FORMATTER-SLASH-PARANOIA* *FORMATTER-SLASH-PARANOIA-LIST*)
+
+      IL:|previous| IL:|date:| "10-Jul-92 11:51:54" IL:|{DSK}<usr>local>lde>lispcore>sources>XP.;10|
+)
+
+
+; Copyright (c) 1990, 1991, 1992, 1993 by Venue Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:XPCOMS)
+
+(IL:RPAQQ IL:XPCOMS ((IL:* IL:|;;| "------------------------------------------------------------------------ Copyright 1989,1990 by the Massachusetts Institute of Technology, Cambridge,  Massachusetts. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that this copyright and permission notice appear in all copies and supporting documentation, and that the name of M.I.T. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. M.I.T. makes no representations about the suitability of this software for any purpose.  It is provided \"as is\" without express or implied warranty.    M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL    M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,    ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS    SOFTWARE. ------------------------------------------------------------------------ This file \"XP.LISP\" implements an efficient pretty printer for Common Lisp.  The functions in this file are documented fully in MIT/AIM-1102a, July 1989.  This report can be obtained by sending $3.25 to              Publications 	       MIT AI Laboratory 	       545 Tech. Sq. 	       Cambridge MA 02139 This file attempts to be as compatible with pure Common Lisp as possible. It has been tested on the following Common Lisps to date (7/31/89).  Symbolics CL version 7 (does not work in version 6),  LUCID CL version 3.0.2 on a sun.  Allegro CL version 1.2.1 on a Macintosh.  CMU CL. The companion file \"XPTEST.LISP\" contains a set of 600+ tests.  You should run these tests after the first time you compile this file on a new system. The companion file \"XPDOC.TXT\" contains brief documentation.") (IL:VARIABLES *XP-PRINTING-FUNCTIONS*) (IL:* IL:|;;| "must do the following in common lisps not supporting *print-shared*") (IL:VARIABLES *PRINT-SHARED*) (IL:VARIABLES *PRINT-PPRINT-DISPATCH* *PRINT-RIGHT-MARGIN* *PRINT-MISER-WIDTH* *PRINT-LINES* *DEFAULT-RIGHT-MARGIN* *LAST-ABBREVIATED-PRINTING* *IPD* *CURRENT-LEVEL* *CURRENT-LENGTH* *ABBREVIATION-HAPPENED* *RESULT*) (IL:* IL:|;;| "default (bad) definitions for the non-portable functions") (IL:FUNCTIONS STRUCTURE-TYPE-P OUTPUT-WIDTH OUTPUT-POSITION) (IL:* IL:|;;| "XP is being considered for inclusion in Lucid Common Lisp. The prime contact there is Eric Benson \"eb@lucid.com\".") (IL:* IL:|;;| "XP is being included in CMU's Common Lisp. The prime contact there is Bill Chiles \"chiles@cs.cmu.edu\" and/or Blain Burks \"mbb@cs.cmu.edu\".") (IL:* IL:|;;| "Definitions for FRANZ Common Lisp. (Only verified for the version 1.3 (5/31/87) currently running on suns at MIT.)") (IL:* IL:|;;| "Joachim Laubsch <laubsch%hpljl@hplabs.hp.com> is the contact at HP Labs. He reports that HP COMMON LISP II Development Environment Rev A.02.15 11/10/88 requires the following patch due to a bug in REPLACE:") (IL:* IL:|;;| "JRB - Here is the Medley-specific code for XP.  There have also been a few #+ hacks inserted into things like WRITE+") (IL:VARIABLES *XP-STREAM-DEVICE*) (IL:FUNCTIONS XP-STREAM-OUTCHARFN XP-STREAM-DEVICE-CLOSEFILE) (IL:FUNCTIONS INSTALL) (IL:VARIABLES *LOCATING-CIRCULARITIES* *PARENTS* *CIRCULARITY-HASH-TABLE*) (IL:* IL:|;;| "When an entry is first made it is zero. If a duplicate is found, a positive integer tag is assigned. After the first time the object is printed out, the tag is negated.") (IL:VARIABLES *FREE-CIRCULARITY-HASH-TABLES*) (IL:* IL:\; "never bound") (IL:FUNCTIONS GET-CIRCULARITY-HASH-TABLE) (IL:* IL:|;;| "If you call this, then the table gets efficiently recycled.") (IL:FUNCTIONS FREE-CIRCULARITY-HASH-TABLE) (IL:* IL:|;;| "                      ---- DISPATCHING ----") (IL:STRUCTURES PPRINT-DISPATCH) (IL:* IL:|;;| "The list and the hash-tables contain entries of the following form.  When stored in the hash tables, the test entry is  the number of entries in the OTHERS list that have a higher priority.") (IL:STRUCTURES ENTRY) (IL:* IL:\; "list of priority and type specifier") (IL:FUNCTIONS COPY-PPRINT-DISPATCH SET-PPRINT-DISPATCH SET-PPRINT-DISPATCH+ PRIORITY-> ADJUST-COUNTS PPRINT-DISPATCH GET-PRINTER FITS SPECIFIER-CATEGORY) (IL:VARIABLES *PREDS-FOR-SPECS*) (IL:FUNCTIONS ALWAYS-TRUE SPECIFIER-FN CONVERT-BODY) (IL:* IL:|;;| "              ---- XP STRUCTURES, AND THE INTERNAL ALGORITHM ----") (IL:* IL:\; "not used at run time.") (IL:VARIABLES BLOCK-STACK-ENTRY-SIZE PREFIX-STACK-ENTRY-SIZE QUEUE-ENTRY-SIZE BUFFER-ENTRY-SIZE PREFIX-ENTRY-SIZE SUFFIX-ENTRY-SIZE) (IL:* IL:\; "used at run time") (IL:VARIABLES BLOCK-STACK-MIN-SIZE PREFIX-STACK-MIN-SIZE QUEUE-MIN-SIZE BUFFER-MIN-SIZE PREFIX-MIN-SIZE SUFFIX-MIN-SIZE) (IL:* IL:|;;| "Hack of the month: The following definitions are used in Medley instead of the Common Lisp strcuture definition for XP-STRUCTURE; the idea is to make an XP-STRUCTURE look like a vanilla STREAM object to as much of the system as possible; most of its funny functionality will be buried in stream functions") (IL:* IL:|;;| "We need a way to conditionalize file manager entries; I'll look into it sometime soon...") (IL:* IL:|;;| "Here is the DEFSTRUCT we are simulating :") (IL:* IL:|;;| "(CL:DEFSTRUCT") (IL:* IL:|;;| "(XP::XP-STRUCTURE (:CONC-NAME NIL) (:PRINT-FUNCTION XP::DESCRIBE-XP) #+INTERLISP (:FAST-ACCESSORS T))") (IL:* IL:|;;| "(XP::BASE-STREAM NIL) ; The stream io eventually goes to. XP::LINEL ; The line length to use for formatting.") (IL:* IL:|;;| "XP::LINE-LIMIT ; If non-NIL the max number of lines to ; print.") (IL:* IL:|;;| "XP::LINE-NO ; number of next line to be printed.") (IL:* IL:|;;| "XP::CHAR-MODE ; NIL :UP :DOWN :CAP0 :CAP1 :CAPW XP::CHAR-MODE-COUNTER ; depth of nesting of ~(...~)") (IL:* IL:|;;| "XP::DEPTH-IN-BLOCKS ; Number of logical blocks at QRIGHT ; that are started but not ended.") (IL:* IL:|;;| "(XP::BLOCK-STACK (CL:MAKE-ARRAY #.XP::BLOCK-STACK-MIN-SIZE)) XP::BLOCK-STACK-PTR ;; This stack is pushed and popped in accordance with the way blocks are  nested at the moment ;; they are entered into the queue.  It contains the  following block specific value. ;; SECTION-START total position where the section (see AIM-1102) that is rightmost in the queue ;; started.") (IL:* IL:|;;| "(XP::BUFFER (CL:MAKE-ARRAY #.XP::BUFFER-MIN-SIZE :ELEMENT-TYPE #-SYMBOLICS (QUOTE LISP:STRING-CHAR) #+SYMBOLICS 'character)) XP::CHARPOS") (IL:* IL:|;;| "XP::BUFFER-PTR") (IL:* IL:|;;| "XP::BUFFER-OFFSET ;; This is a vector of characters (eg a string) that builds up the line images that will be ;; printed out.  BUFFER-PTR is the buffer position where the next character should be inserted in ;; the string.  CHARPOS is the output character position of the first character in the buffer ;; (non-zero only if a partial line has been output).  BUFFER-OFFSET is used in computing total ;; lengths. It is changed to reflect all shifting and insertion of prefixes so that total length ;; computes things as they would be if they were  all on one line.  Positions are kept three ;; different ways Buffer position (eg BUFFER-PTR) Line position (eg (+ BUFFER-PTR CHARPOS)).  ;; Indentations are stored in this form. Total position if all on one line (eg (+ BUFFER-PTR ;; BUFFER-OFFSET))  Positions are stored in this form.") (IL:* IL:|;;| "(XP::QUEUE (CL:MAKE-ARRAY #.XP::QUEUE-MIN-SIZE)) XP::QLEFT XP::QRIGHT ;; This holds a queue of action descriptors.  QLEFT and QRIGHT point to the next entry to dequeue ;; and the last entry enqueued respectively.  The queue is empty when (> QLEFT QRIGHT).  The ;; queue entries have several parts: QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK QKIND ;; :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH or :BLOCK/:CURRENT QPOS total ;; position corresponding to this entry QDEPTH depth in blocks of this entry. QEND offset to ;; entry marking end of section this entry starts. (NIL until known.) Only :start-block and ;; non-literal :newline entries can start sections. QOFFSET offset to :END-BLOCK for :START-BLOCK ;; (NIL until known). QARG for :IND indentation delta     for :START-BLOCK suffix in the block if ;; any.                      or if per-line-prefix then cons of suffix and                      ;; per-line-prefix.     for :END-BLOCK suffix for the block if any.") (IL:* IL:|;;| "(XP::PREFIX (CL:MAKE-ARRAY #.XP::BUFFER-MIN-SIZE :ELEMENT-TYPE #-SYMBOLICS (QUOTE LISP:STRING-CHAR) #+SYMBOLICS 'character)) ;; this stores the prefix that should be used at the start of the line") (IL:* IL:|;;| "(XP::PREFIX-STACK (CL:MAKE-ARRAY #.XP::PREFIX-STACK-MIN-SIZE))") (IL:* IL:|;;| "XP::PREFIX-STACK-PTR ;; This stack is pushed and popped in accordance with the way blocks  are nested at the moment ;; things are taken off the queue and printed. It contains the following block specific values. ;; PREFIX-PTR current length of PREFIX. SUFFIX-PTR current length of pending suffix ;; NON-BLANK-PREFIX-PTR current length of non-blank prefix. INITIAL-PREFIX-PTR prefix-ptr at the ;; start of this block. SECTION-START-LINE line-no value at last non-literal break at this level.") (IL:* IL:|;;| "(XP::SUFFIX (CL:MAKE-ARRAY #.XP::BUFFER-MIN-SIZE :ELEMENT-TYPE #-SYMBOLICS (QUOTE LISP:STRING-CHAR) #+SYMBOLICS 'character)))") (IL:RECORDS XP-STRUCTURE) (IL:FUNCTIONS BASE-STREAM LINEL LINE-LIMIT LINE-NO CHAR-MODE CHAR-MODE-COUNTER DEPTH-IN-BLOCKS BLOCK-STACK BLOCK-STACK-PTR BUFFER CHARPOS BUFFER-PTR BUFFER-OFFSET QUEUE QLEFT QRIGHT PREFIX PREFIX-STACK PREFIX-STACK-PTR SUFFIX MAKE-XP-STRUCTURE XP-STRUCTURE-P) (IL:* IL:|;;| "this stores the suffixes that have to be printed to close of the current open blocks.  For convenient in popping, the whole suffix is stored in reverse order.") (IL:FUNCTIONS LP<-BP TP<-BP BP<-LP BP<-TP) (IL:* IL:|;;| "This does not tell you the line position you were at when the TP was set, unless there have been no newlines or indentation output  between ptr and the current output point.") (IL:FUNCTIONS LP<-TP) (IL:* IL:|;;| "We don't use adjustable vectors or any of that, because we seldom have to actually extend and non-adjustable vectors are a lot faster in many Common Lisps.") (IL:FUNCTIONS CHECK-SIZE SECTION-START PUSH-BLOCK-STACK POP-BLOCK-STACK PREFIX-PTR SUFFIX-PTR NON-BLANK-PREFIX-PTR INITIAL-PREFIX-PTR SECTION-START-LINE PUSH-PREFIX-STACK POP-PREFIX-STACK QTYPE QKIND QPOS QDEPTH QEND QOFFSET QARG) (IL:* IL:|;;| "we shift the queue over rather than using a circular queue because that works out to be a lot faster in practice.  Note, short printout does not ever cause a shift, and even in long printout, the queue is shifted left for free every time it happens to empty out.") (IL:FUNCTIONS ENQUEUE QNEXT) (IL:VARIABLES *DESCRIBE-XP-STREAMS-FULLY*) (IL:FUNCTIONS DESCRIBE-XP) (IL:* IL:|;;| "This maintains a list of XP structures.  We save them so that we don't have to create new ones all of the time. We have separate objects so that many can be in use at once. (Note should really be doing some locking here, but CL does not have the primitives for it.  There is a tiny probability here that two different processes could end up trying to use the same xp-stream)") (IL:VARIABLES *FREE-XPS*) (IL:* IL:\; "never bound") (IL:FUNCTIONS GET-PRETTY-PRINT-STREAM) (IL:* IL:|;;| "If you call this, the xp-stream gets efficiently recycled.") (IL:FUNCTIONS FREE-PRETTY-PRINT-STREAM) (IL:* IL:|;;| "This is called to initialize things when you start pretty printing.") (IL:FUNCTIONS INITIALIZE-XP) (IL:* IL:|;;| "The char-mode stuff is a bit tricky. one can be in one of the following modes: NIL no changes to characters output. :UP CHAR-UPCASE used. :DOWN CHAR-DOWNCASE used. :CAP0 capitalize next alphanumeric letter then switch to :DOWN. :CAP1 capitalize next alphanumeric letter then switch to :CAPW :CAPW downcase letters.  When a word break letter found, switch to :CAP1. It is possible for ~(~) to be nested in a format string, but note that each mode specifies what should happen to every letter.  Therefore, inner nested modes never have any effect.  You can just ignore them.") (IL:FUNCTIONS PUSH-CHAR-MODE POP-CHAR-MODE HANDLE-CHAR-MODE) (IL:* IL:|;;| ":DOWN All characters output are passed through the handler above.  However, it must be noted that on-each-line prefixes are only processed in the context of the first place they appear.  They stay the same later no matter what.  Also non-literal newlines do not count as word breaks. This handles the basic outputting of characters.  note + suffix means that the stream is known to be an XP stream, all inputs are mandatory, and no error checking has to be done.  Suffix ++ additionally means that the output is guaranteed not to contain a newline char.") (IL:FUNCTIONS WRITE-CHAR+ WRITE-STRING+) (IL:* IL:|;;| "note this checks (> BUFFER-PTR LINEL) instead of (> (LP<-BP) LINEL) this is important so that when things are longer than a line they end up getting printed in chunks of size LINEL.") (IL:FUNCTIONS WRITE-CHAR++ FORCE-SOME-OUTPUT WRITE-STRING++) (IL:* IL:|;;| "never forces output; therefore safe to call from within output-line.") (IL:FUNCTIONS WRITE-STRING+++ PPRINT-TAB+) (IL:* IL:|;;| "note following is smallest number >= x that is a multiple of colinc  (* colinc (floor (+ x (1- colinc)) colinc))") (IL:FUNCTIONS PPRINT-NEWLINE+ START-BLOCK END-BLOCK PPRINT-INDENT+) (IL:* IL:|;;| "The next function scans the queue looking for things it can do. it keeps outputting things until the queue is empty, or it finds a place where it cannot make a decision yet.") (IL:FUNCTIONS MAYBE-TOO-LARGE) (IL:* IL:\; "wait until later to decide.") (IL:FUNCTIONS MISERING?) (IL:* IL:|;;| "If flush-out? is T and force-newlines? is NIL then the buffer, prefix-stack, and queue will be in an inconsistent state after the call. You better not call it this way except as the last act of outputting.") (IL:FUNCTIONS ATTEMPT-TO-OUTPUT) (IL:* IL:\; "this can only be called last!") (IL:FUNCTIONS FLUSH) (IL:* IL:\; "This prints out a line of stuff.") (IL:FUNCTIONS OUTPUT-LINE SETUP-FOR-NEXT-LINE SET-INDENTATION-PREFIX SET-PREFIX SET-SUFFIX REVERSE-STRING-IN-PLACE) (IL:* IL:|;;| "		   ---- BASIC INTERFACE FUNCTIONS ---- The internal functions in this file, and the (formatter \"...\") expansions use the '+' forms of these functions directly (which is faster) because, they do not need error checking of fancy stream coercion.  The '++' forms additionally assume the thing being output does not contain a newline.") (IL:FUNCTIONS WRITE BASIC-WRITE MAYBE-INITIATE-XP-PRINTING) (IL:FUNCTIONS XP-PRINT) (IL:FUNCTIONS DECODE-STREAM-ARG DO-XP-PRINTING WRITE+ NON-PRETTY-PRINT) (IL:* IL:|;;| "It is vital that this function be called EXACTLY once for each occurrence of   each thing in something being printed. Returns nil if printing should just continue on.  Either it is not a duplicate, or we are in the first pass and do not know. returns :FIRST if object is first occurrence of a DUPLICATE.  (This can only be returned on a second pass.)  After an initial code (printed by this routine on the second pass)  printing should continue on for the object. returns :SUBSEQUENT if second or later occurrence.  Printing is all taken care of by this routine. Note many (maybe most) lisp implementations have characters and small numbers represented in a single word so that the are always eq when they are equal and the reader takes care of properly sharing them (just as it does with symbols). Therefore, we do not want circularity processing applied to them.  However, some kinds of numbers (e.g., bignums) undoubtedly are complex structures that the reader does not share.  However, they cannot have circular pointers in them and it is therefore probably a waste to do circularity checking on them.  In any case, it is not clear that it easy to tell exactly what kinds of numbers a given implementation of CL is going to have the reader automatically share.") (IL:FUNCTIONS CIRCULARITY-PROCESS) (IL:* IL:|;;| "This prints a few very common, simple atoms very fast. Pragmatically, this turns out to be an enormous savings over going to the standard printer all the time.  There would be diminishing returns from making this work with more things, but might be worth it.") (IL:FUNCTIONS MAYBE-PRINT-FAST PRINT-FIXNUM) (IL:* IL:|;;| "just wants to succeed fast in a lot of common cases. assumes no funny readtable junk for the characters shown.") (IL:FUNCTIONS NO-ESCAPES-NEEDED PRINT PRIN1 PRINC PPRINT WRITE-TO-STRING PRINC-TO-STRING PRIN1-TO-STRING) (IL:* IL:|;;| "Any format string that is converted to a function is always printed via an XP stream (See formatter).") (IL:FUNCTIONS FORMAT) (IL:VARIABLES *FORMAT-STRING-CACHE*) (IL:FUNCTIONS PROCESS-FORMAT-STRING WRITE-LINE WRITE-STRING WRITE-CHAR TERPRI) (IL:* IL:|;;| "This has to violate the XP data abstraction and fool with internal stuff, in order to find out the right info to return as the result.") (IL:FUNCTIONS FRESH-LINE) (IL:* IL:|;;| "Each of these causes the stream to be pessimistic and insert newlines wherever it might have to, when forcing the partial output out.  This is so that things will be in a consistent state if output continues to the stream later.") (IL:FUNCTIONS FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT) (IL:* IL:|;;| "note we are assuming that if a structure is defined using xp::defstruct, then its print-function (if any) will be defined using xp::print etc.") (IL:FUNCTIONS DEFSTRUCT SAFE-ASSOC) (IL:* IL:|;;| "A few helper functions.  Calls to these are generated by SET-XP-PRINTER, which handles default pretty-printing of structures") (IL:FUNCTIONS CL::STRUCTURE-WITH-USER-PRINTER CL::STRUCTURE-WITH-DEFAULT-PRINTER) (IL:* IL:|;;| "          ---- FUNCTIONAL INTERFACE TO DYNAMIC FORMATTING ---- The internal functions in this file, and the (formatter \"...\") expansions use the '+' forms of these functions directly (which is faster) because, they do not need error checking or fancy stream coercion.  The '++' forms additionally assume the thing being output does not contain a newline.") (IL:FUNCTIONS PPRINT-LOGICAL-BLOCK) (IL:* IL:|;;| "Assumes var and args must be variables.  Other arguments must be literals or variables.") (IL:FUNCTIONS PPRINT-LOGICAL-BLOCK+ PPRINT-NEWLINE PPRINT-INDENT PPRINT-TAB) (IL:* IL:|;;| "                       ---- COMPILED FORMAT ---- Note that compiled format strings always print through xp streams even if they don't have any xp directives in them.  As a result, the compiled code can depend on the fact that the stream being operated on is an xp stream not an ordinary one.") (IL:P (PROCLAIM (QUOTE (SPECIAL *STRING* *USED-ARGS* *USED-OUTER-ARGS* *USED-INITIAL* *GET-ARG-CAREFULLY* *INNER-END* *OUTER-END* *AT-TOP* *DEFAULT-PACKAGE*)))) (IL:VARIABLES *FN-TABLE*) (IL:* IL:|;;| "Each of these functions expect to get called with two arguments start and end.  Start points to the first character after the ~ marking the command.  End points to the first character after the command.  This includes the matching end command for paired commands.") (IL:DEFINE-TYPES FORMAT-HANDLERS) (IL:FUNCTIONS DEF-FORMAT-HANDLER FORMAT-HANDLER-UNDEFINE) (IL:* IL:|;;| "Definitions of the forms used in the code created by PARSE. Note these functions assume the stream is in the var XP and is an xp stream, INITIAL holds the initial value of ARGS (for ~@*). Initial is always bound to (args) if it is bound at all. Note this uses args, but only when actually binding") (IL:FUNCTIONS INITIAL BIND-INITIAL MAYBE-BIND-INITIAL) (IL:* IL:|;;| "ARGS holds the current argument list The val bound to args must always be computed (to use it up) even if args is not used.") (IL:FUNCTIONS ARGS BIND-ARGS OUTER-ARGS BIND-OUTER-ARGS MAYBE-BIND MAKE-BINDING NUM-ARGS GET-ARG PPRINT-POP+ PPRINT-POP-CHECK+ PPRINT-POP+TOP PPRINT-POP-CHECK+TOP LITERAL) (IL:* IL:\; "This is available for putting on #\".") (IL:FUNCTIONS FORMAT-STRING-READER FORMATTER-IN-PACKAGE FORMATTER FORMATTER-FN) (IL:* IL:|;;| "The business with the catch above allows many (formatter \"...\") errors to be reported in a file without stopping the compilation of the file.") (IL:FUNCTIONS MAYBE-COMPILE-FORMAT-STRING) (IL:* IL:|;;| "COMPILE-FORMAT gets called to turn a bit of format control string into code.") (IL:VARIABLES *TESTING-ERRORS*) (IL:FUNCTIONS ERR POSITION-IN POSITION-NOT-IN NEXT-DIRECTIVE1 PARAMS-END) (IL:* IL:|;;| "Only called after correct parse is known.") (IL:FUNCTIONS DIRECTIVE-START NEXT-DIRECTIVE) (IL:* IL:\; "breaks things up at ~; directives.") (IL:FUNCTIONS CHUNK-UP FANCY-DIRECTIVES-P NUM-ARGS-IN-ARGS COMPILE-FORMAT) (IL:* IL:|;;| "This gets called with start pointing to the character after the ~ that starts a command.  Defaults, is a list of default values for the parameters.  Max is the maximum number of parameters allowed.  Nocolon, noatsign, nocolonatsign can be used to specify what colon atsign combinations are permitted. Parse params returns three values, colon?, atsign? and a list of code chunks that correspond to the parameters specified.") (IL:FUNCTIONS PARSE-PARAMS) (IL:* IL:|;;| "Both these only called if correct parse already known.") (IL:FUNCTIONS COLONP ATSIGNP) (IL:* IL:|;;| "These flags and lists control some non-spec behavior in FORMATTER's handling of the ~/.../ directive") (IL:VARIABLES *FAST-FORMATTER-SLASH-CALL* *FORMATTER-SLASH-PARANOIA* *FORMATTER-SLASH-PARANOIA-LIST*) (FORMAT-HANDLERS #\/ #\A #\S) (IL:* IL:|;;| "The basic Format directives \"DBOXRCFEG$\".  The key thing about all of these directives is that they just get a single arg and print a chunk of stuff.  Further they are complex enough that I just call the standard definition of FORMAT to get the work done.  What should really be being called is the internal routine that FORMAT uses to do the corresponding work.  However, this cannot be done in a portable way.") (FORMAT-HANDLERS #\D #\B #\O #\X #\R #\C #\F #\E #\G #\$) (IL:FUNCTIONS SIMPLE-DIRECTIVE USING-FORMAT) (IL:* IL:|;;| "Format directives that get open coded \"P%&~|T*?^\"") (FORMAT-HANDLERS #\P #\% #\&) (IL:FUNCTIONS MULTIPLE-NEWLINES MULTIPLE-NEWLINES1) (FORMAT-HANDLERS #\| #\~) (IL:FUNCTIONS MULTIPLE-CHARS MULTIPLE-CHARS1) (FORMAT-HANDLERS #\T #\*) (IL:* IL:|;;| "fancy stuff here, so will not get spurious indications of circularity.") (IL:FUNCTIONS BACKUP-IN-LIST BACKUP-TO) (IL:* IL:|;;| "because of backup-to, a prefix of some-tail may have been copied (in which case it cannot share anything with list), but there is a cons in some-tail that is in list.  This can be used to determine the position of some-tail relative to list.  However, we have to be careful, because they both could be cdr recursive.") (IL:FUNCTIONS TAIL-POS) (FORMAT-HANDLERS #\? #\^) (IL:FUNCTIONS DO-COMPLEX-^-TEST) (IL:* IL:|;;| "delimited pairs of format directives. \"(){}[]<>;\"") (FORMAT-HANDLERS #\[ #\( #\; #\] #\) #\> #\} #\{ #\<) (IL:FUNCTIONS HANDLE-STANDARD-< NUM-ARGS-IN-DIRECTIVE) (IL:* IL:\; "The pretty-printing directives. \"_IW<:>\"") (FORMAT-HANDLERS #\_ #\I #\W) (IL:FUNCTIONS HANDLE-LOGICAL-BLOCK CHECK-BLOCK-ABBREVIATION FILL-TRANSFORM FILL-TRANSFORM-CHAR FILL-TRANSFORM-LITERAL) (IL:* IL:|;;| "end of eval when for all (formatter \"...\") stuff.                ---- PRETTY PRINTING FORMATS ----") (IL:FUNCTIONS PRETTY-ARRAY PRETTY-VECTOR PRETTY-NON-VECTOR) (IL:* IL:|;;| "Must use pprint-logical-block (no +) in the following three, because they are exported functions.") (IL:FUNCTIONS PPRINT-LINEAR PPRINT-FILL PPRINT-TABULAR FN-CALL) (IL:* IL:|;;| "Although idiosyncratic, I have found this very useful to avoid large indentations when printing out code.") (IL:FUNCTIONS ALTERNATIVE-FN-CALL BIND-LIST BLOCK-LIKE DEFUN-LIKE PRINT-FANCY-FN-CALL MAYBELAB FUNCTION-CALL-P) (IL:* IL:|;;| "THE FOLLOWING STUFF SETS UP THE DEFAULT *PRINT-PPRINT-DISPATCH* This is an attempt to specify a correct format for every form in the CL book that does not just get printed out like an ordinary function call  (i.e., most special forms and many macros).  This of course does not  cover anything new you define.") (IL:FUNCTIONS LET-PRINT COND-PRINT DMM-PRINT DEFSETF-PRINT DO-PRINT FLET-PRINT FUNCTION-PRINT MVB-PRINT PROG-PRINT SETQ-PRINT QUOTE-PRINT TAGBODY-PRINT UP-PRINT) (IL:* IL:|;;| "here is some simple stuff for printing LOOP The challange here is that we have to effectively parse the clauses of the loop in order to know how to print things.  Also you want to do this in a  purely incremental way so that all of the abbreviation things work, and you wont blow up on circular lists or the like.  (More aesthic output could be produced by really parsing the clauses into nested lists before printing them.) The following program assumes the following simplified grammar of the loop clauses that explains how to print them.  Note that it does not bare much resemblence to the right parsing grammar, however, it produces half decent output.  The way to make the output better is to make the grammar more detailed.    loop == (LOOP {clause}*)      ;one clause on each line. clause == block | linear | cond | finally block == block-head {expr}*   ;as many exprs as possible on each line. linear == linear-head {expr}* ;one expr on each line. finally == FINALLY [DO | DOING | RETURN] {expr}* ;one expr on each line. cond == cond-head [expr]          clause 	   {AND clause}*       ;one AND on each line.        [ELSE          clause 	   {AND clause}*]      ;one AND on each line.        [END] block-head == FOR | AS | WITH | AND              | REPEAT | NAMED | WHILE | UNTIL | ALWAYS | NEVER | THEREIS | RETURN              | COLLECT | COLLECTING | APPEND | APPENDING | NCONC | NCONCING | COUNT              | COUNTING | SUM | SUMMING | MAXIMIZE | MAXIMIZING | MINIMIZE | MINIMIZING  linear-head == DO | DOING | INITIALLY var-head == FOR | AS | WITH cond-head == IF | WHEN | UNLESS expr == <anything that is not a head symbol> Note all the string comparisons below are required to support some existing implementations of LOOP.") (IL:FUNCTIONS TOKEN-TYPE PRETTY-LOOP) (IL:* IL:|;;| "Backquote-printing is easy for us, since the read macros just expand into simple wrappers.") (IL:FUNCTIONS BQ-PRINT BQ-COMMA-PRINT BQ-COMMA@-PRINT) (IL:* IL:|;;| "This method of handling Interlisp comments sucks, BUT there is no way under XP to temporarily ignore an existing per-line-prefix, which is what you would have to do to get ;;; and ;;;; comments to go to the left margin.  Phooey!") (IL:FUNCTIONS IL-COMMENT) (IL:P (SETQ *IPD* (MAKE-PPRINT-DISPATCH))) (IL:DEFINE-TYPES INITIAL-DISPATCH) (IL:FUNCTIONS SET-PPD-IPD) (INITIAL-DISPATCH (SATISFIES FUNCTION-CALL-P) CONS) (INITIAL-DISPATCH (CONS (MEMBER DEFSTRUCT)) (CONS (MEMBER BLOCK)) (CONS (MEMBER CASE)) (CONS (MEMBER CATCH)) (CONS (MEMBER CCASE)) (CONS (MEMBER COMPILER-LET)) (CONS (MEMBER COND)) (CONS (MEMBER CTYPECASE)) (CONS (MEMBER DEFCONSTANT)) (CONS (MEMBER DEFINE-SETF-METHOD)) (CONS (MEMBER DEFMACRO)) (CONS (MEMBER DEFINE-MODIFY-MACRO)) (CONS (MEMBER DEFPARAMETER)) (CONS (MEMBER DEFSETF)) (CONS (MEMBER DEFINE-SETF-METHOD)) (CONS (MEMBER CL:DEFSTRUCT)) (CONS (MEMBER DEFTYPE)) (CONS (MEMBER DEFUN)) (CONS (MEMBER DEFVAR)) (CONS (MEMBER DO)) (CONS (MEMBER DO*)) (CONS (MEMBER DO-ALL-SYMBOLS)) (CONS (MEMBER DO-EXTERNAL-SYMBOLS)) (CONS (MEMBER DO-SYMBOLS)) (CONS (MEMBER DOLIST)) (CONS (MEMBER DOTIMES)) (CONS (MEMBER ECASE)) (CONS (MEMBER ETYPECASE)) (CONS (MEMBER EVAL-WHEN)) (CONS (MEMBER FLET)) (CONS (MEMBER FUNCTION)) (CONS (MEMBER LABELS)) (CONS (MEMBER LAMBDA)) (CONS (MEMBER LET)) (CONS (MEMBER LET*)) (CONS (MEMBER LOCALLY)) (CONS (MEMBER LOOP)) (CONS (MEMBER MACROLET)) (CONS (MEMBER MULTIPLE-VALUE-BIND)) (CONS (MEMBER MULTIPLE-VALUE-SETQ)) (CONS (MEMBER PROG)) (CONS (MEMBER PROG*)) (CONS (MEMBER PROGV)) (CONS (MEMBER PSETF)) (CONS (MEMBER PSETQ)) (CONS (MEMBER QUOTE)) (CONS (MEMBER RETURN-FROM)) (CONS (MEMBER SETF)) (CONS (MEMBER SETQ)) (CONS (MEMBER TAGBODY)) (CONS (MEMBER THROW)) (CONS (MEMBER TYPECASE)) (CONS (MEMBER UNLESS)) (CONS (MEMBER UNWIND-PROTECT)) (CONS (MEMBER WHEN)) (CONS (MEMBER WITH-INPUT-FROM-STRING)) (CONS (MEMBER WITH-OPEN-FILE)) (CONS (MEMBER WITH-OPEN-STREAM)) (CONS (MEMBER WITH-OUTPUT-TO-STRING))) (IL:* IL:|;;| "Interlisp-specific entries in the original table; we need a bunch more of these, and a MUCH better way to print Interlisp comments") (INITIAL-DISPATCH (CONS (MEMBER IL:*)) (CONS (MEMBER IL:BQUOTE)) (CONS (MEMBER IL:\\\,)) (CONS (MEMBER IL:\\\,@))) (IL:FUNCTIONS PPRINT-DISPATCH-PRINT) (IL:P (SETF (GET (QUOTE PPRINT-DISPATCH) (QUOTE CL::STRUCTURE-PRINTER)) (FUNCTION PPRINT-DISPATCH-PRINT))) (INITIAL-DISPATCH PPRINT-DISPATCH) (IL:* IL:\; "so only happens first time is loaded.") (IL:P (WHEN (EQ *PRINT-PPRINT-DISPATCH* T) (SETQ *PRINT-PPRINT-DISPATCH* (COPY-PPRINT-DISPATCH NIL)))) (IL:* IL:|;;| "changes since last documentation. ~/fn/ only refers to global function values, not lexical. ------------------------------------------------------------------------ Copyright 1989,1990 by the Massachusetts Institute of Technology, Cambridge,  Massachusetts. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that this copyright and permission notice appear in all copies and supporting documentation, and that the name of M.I.T. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. M.I.T. makes no representations about the suitability of this software for any purpose.  It is provided \"as is\" without express or implied warranty.    M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL    M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,    ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS    SOFTWARE. ------------------------------------------------------------------------") (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:XP)))
+
+
+
+(IL:* IL:|;;| 
+"------------------------------------------------------------------------ Copyright 1989,1990 by the Massachusetts Institute of Technology, Cambridge,  Massachusetts. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that this copyright and permission notice appear in all copies and supporting documentation, and that the name of M.I.T. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. M.I.T. makes no representations about the suitability of this software for any purpose.  It is provided \"as is\" without express or implied warranty.    M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL    M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,    ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS    SOFTWARE. ------------------------------------------------------------------------ This file \"XP.LISP\" implements an efficient pretty printer for Common Lisp.  The functions in this file are documented fully in MIT/AIM-1102a, July 1989.  This report can be obtained by sending $3.25 to              Publications 	       MIT AI Laboratory 	       545 Tech. Sq. 	       Cambridge MA 02139 This file attempts to be as compatible with pure Common Lisp as possible. It has been tested on the following Common Lisps to date (7/31/89).  Symbolics CL version 7 (does not work in version 6),  LUCID CL version 3.0.2 on a sun.  Allegro CL version 1.2.1 on a Macintosh.  CMU CL. The companion file \"XPTEST.LISP\" contains a set of 600+ tests.  You should run these tests after the first time you compile this file on a new system. The companion file \"XPDOC.TXT\" contains brief documentation."
+)
+
+
+(DEFVAR *XP-PRINTING-FUNCTIONS* (QUOTE (WRITE PRINT PRIN1 PRINC PPRINT FORMAT WRITE-TO-STRING PRINC-TO-STRING PRIN1-TO-STRING WRITE-LINE WRITE-STRING WRITE-CHAR TERPRI FRESH-LINE DEFSTRUCT FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT)) "printing functions redefined by xp.")
+
+
+
+(IL:* IL:|;;| "must do the following in common lisps not supporting *print-shared*")
+
+
+(DEFVAR *PRINT-SHARED* NIL)
+
+(DEFVAR *PRINT-PPRINT-DISPATCH* T (IL:* IL:\; "see initialization at end of file.") "controls pretty printing of output")
+
+(DEFVAR *PRINT-RIGHT-MARGIN* NIL "+#/nil the right margin for pretty printing")
+
+(DEFVAR *PRINT-MISER-WIDTH* 40 "+#/nil miser format starts when there is less than this width left")
+
+(DEFVAR *PRINT-LINES* NIL "+#/nil truncates printing after # lines")
+
+(DEFVAR *DEFAULT-RIGHT-MARGIN* 70 "controls default line length; must be a non-negative integer")
+
+(DEFVAR *LAST-ABBREVIATED-PRINTING* (FUNCTION (LAMBDA (&OPTIONAL STREAM) (DECLARE (IGNORE STREAM)) NIL)) "funcalling this redoes the last xp printing that was abbreviated.")
+
+(DEFVAR *IPD* NIL (IL:* IL:\; "see initialization at end of file.") "initial print dispatch table.")
+
+(DEFVAR *CURRENT-LEVEL* 0 "current depth in logical blocks.")
+
+(DEFVAR *CURRENT-LENGTH* 0 "current position in logical block.")
+
+(DEFVAR *ABBREVIATION-HAPPENED* NIL "t if current thing being printed has been abbreviated.")
+
+(DEFVAR *RESULT* NIL "used to pass back a value")
+
+
+
+(IL:* IL:|;;| "default (bad) definitions for the non-portable functions")
+
+
+(DEFUN STRUCTURE-TYPE-P (X) (IL:* IL:|;;| "(AND (SYMBOLP X) (GET X 'STRUCTURE-PRINTER))") (LISP::PARSED-STRUCTURE X T))
+
+(DEFUN OUTPUT-WIDTH (&OPTIONAL (S *STANDARD-OUTPUT*)) (IL:LINELENGTH NIL S))
+
+(DEFUN OUTPUT-POSITION (&OPTIONAL (S *STANDARD-OUTPUT*)) (IL:* IL:\; "Edited  6-May-92 12:37 by jrb:") (IL:POSITION S))
+
+
+
+(IL:* IL:|;;| 
+"XP is being considered for inclusion in Lucid Common Lisp. The prime contact there is Eric Benson \"eb@lucid.com\"."
+)
+
+
+
+
+(IL:* IL:|;;| 
+"XP is being included in CMU's Common Lisp. The prime contact there is Bill Chiles \"chiles@cs.cmu.edu\" and/or Blain Burks \"mbb@cs.cmu.edu\"."
+)
+
+
+
+
+(IL:* IL:|;;| 
+"Definitions for FRANZ Common Lisp. (Only verified for the version 1.3 (5/31/87) currently running on suns at MIT.)"
+)
+
+
+
+
+(IL:* IL:|;;| 
+"Joachim Laubsch <laubsch%hpljl@hplabs.hp.com> is the contact at HP Labs. He reports that HP COMMON LISP II Development Environment Rev A.02.15 11/10/88 requires the following patch due to a bug in REPLACE:"
+)
+
+
+
+
+(IL:* IL:|;;| 
+"JRB - Here is the Medley-specific code for XP.  There have also been a few #+ hacks inserted into things like WRITE+"
+)
+
+
+(DEFVAR *XP-STREAM-DEVICE* (IL:* IL:|;;| "A first hack at integrating XP into Medley.  A stream with this as its fdev lives in the MEDLEY-STREAM slot of an XP-STRUCTURE.  Whenever XP punts in WRITE+, it just does its output to its MEDLEY-STREAM, which catches each character and calls WRITE-CHAR++; this is actually reasonably fast.") (IL:|create| IL:FDEV IL:DEVICENAME IL:_ (QUOTE *XP-STREAM-DEVICE*) IL:RESETABLE IL:_ NIL IL:RANDOMACCESSP IL:_ NIL IL:NODIRECTORIES IL:_ T IL:BUFFERED IL:_ NIL IL:PAGEMAPPED IL:_ NIL IL:FDBINABLE IL:_ NIL IL:FDBOUTABLE IL:_ NIL IL:FDEXTENDABLE IL:_ NIL IL:DEVICEINFO IL:_ NIL IL:HOSTNAMEP IL:_ (IL:FUNCTION IL:NILL) IL:EVENTFN IL:_ (IL:FUNCTION IL:NILL) IL:DIRECTORYNAMEP IL:_ (IL:FUNCTION IL:NILL) IL:OPENFILE IL:_ (IL:FUNCTION IL:NILL) IL:REOPENFILE IL:_ (IL:FUNCTION IL:NILL) IL:CLOSEFILE IL:_ (IL:FUNCTION XP-STREAM-DEVICE-CLOSEFILE) IL:GETFILENAME IL:_ (IL:FUNCTION IL:NILL) IL:DELETEFILE IL:_ (IL:FUNCTION IL:NILL) IL:GENERATEFILES IL:_ (IL:FUNCTION IL:\\GENERATENOFILES) IL:RENAMEFILE IL:_ (IL:FUNCTION IL:NILL) IL:BIN IL:_ (IL:FUNCTION IL:\\ILLEGAL.DEVICEOP) IL:BOUT IL:_ (IL:FUNCTION IL:NILL) IL:PEEKBIN IL:_ (IL:FUNCTION IL:\\ILLEGAL.DEVICEOP) IL:READP IL:_ (IL:FUNCTION IL:\\ILLEGAL.DEVICEOP) IL:EOFP IL:_ (IL:FUNCTION IL:NILL) IL:BLOCKIN IL:_ (IL:FUNCTION IL:\\ILLEGAL.DEVICEOP) IL:BLOCKOUT IL:_ (IL:FUNCTION IL:\\GENERIC.BOUTS) IL:FORCEOUTPUT IL:_ (IL:FUNCTION IL:NILL) IL:GETFILEPTR IL:_ (IL:FUNCTION IL:\\ILLEGAL.DEVICEOP) IL:SETFILEINFO IL:_ (IL:FUNCTION IL:\\ILLEGAL.DEVICEOP)))
+
+(DEFUN XP-STREAM-OUTCHARFN (STREAM CHARNO) (IL:* IL:|;;| "For the moment, keep it simple.  We'll gussy this up with block stuff later.  For now, we assume no newlines or other white-space junk in this function") (WRITE-CHAR++ (INT-CHAR CHARNO) STREAM))
+
+(DEFUN XP-STREAM-DEVICE-CLOSEFILE (STREAM &OPTIONAL IL:ABORTFLAG) (IL:* IL:|;;| "What the heck, close the underlying \"real\" stream") (CLOSE (BASE-STREAM (IL:|fetch| IL:F1 IL:|of| STREAM))))
+
+(DEFUN INSTALL (&KEY (PACKAGE *PACKAGE*) (MACRO NIL) (SHADOW T) (REMOVE NIL)) (WHEN (NOT (PACKAGEP PACKAGE)) (SETQ PACKAGE (FIND-PACKAGE PACKAGE))) (WHEN (NOT REMOVE) (WHEN MACRO (SET-DISPATCH-MACRO-CHARACTER #\# #\" (FUNCTION FORMAT-STRING-READER))) (WHEN (NOT (EQ PACKAGE (FIND-PACKAGE "XP"))) (USE-PACKAGE "XP" PACKAGE) (WHEN SHADOW (SHADOWING-IMPORT *XP-PRINTING-FUNCTIONS* PACKAGE)))) (WHEN (AND REMOVE (MEMBER (FIND-PACKAGE "XP") (PACKAGE-USE-LIST PACKAGE))) (UNUSE-PACKAGE "XP" PACKAGE) (DOLIST (SYM (INTERSECTION *XP-PRINTING-FUNCTIONS* (PACKAGE-SHADOWING-SYMBOLS PACKAGE))) (UNINTERN SYM PACKAGE))) T)
+
+(DEFVAR *LOCATING-CIRCULARITIES* NIL "Integer if making a first pass over things to identify circularities.
+   Integer used as counter for #n= syntax.")
+
+(DEFVAR *PARENTS* NIL "used when *print-shared* is nil")
+
+(DEFVAR *CIRCULARITY-HASH-TABLE* NIL "Contains hash table used for locating circularities, or a stack.")
+
+
+
+(IL:* IL:|;;| 
+"When an entry is first made it is zero. If a duplicate is found, a positive integer tag is assigned. After the first time the object is printed out, the tag is negated."
+)
+
+
+(DEFVAR *FREE-CIRCULARITY-HASH-TABLES* NIL "free list of circularity hash tables")
+
+
+
+(IL:* IL:\; "never bound")
+
+
+(DEFUN GET-CIRCULARITY-HASH-TABLE NIL (LET ((TABLE (POP *FREE-CIRCULARITY-HASH-TABLES*))) (IF TABLE TABLE (MAKE-HASH-TABLE :TEST (QUOTE EQ)))))
+
+
+
+(IL:* IL:|;;| "If you call this, then the table gets efficiently recycled.")
+
+
+(DEFUN FREE-CIRCULARITY-HASH-TABLE (TABLE) (CLRHASH TABLE) (PUSHNEW TABLE *FREE-CIRCULARITY-HASH-TABLES*))
+
+
+
+(IL:* IL:|;;| "                      ---- DISPATCHING ----")
+
+
+(CL:DEFSTRUCT (PPRINT-DISPATCH (:CONC-NAME NIL) (:COPIER NIL) (:FAST-ACCESSORS T)) (CONSES-WITH-CARS (MAKE-HASH-TABLE :TEST (FUNCTION EQ)) :TYPE HASH-TABLE) (STRUCTURES (MAKE-HASH-TABLE :TEST (FUNCTION EQ)) :TYPE HASH-TABLE) (OTHERS NIL :TYPE LIST))
+
+
+
+(IL:* IL:|;;| 
+"The list and the hash-tables contain entries of the following form.  When stored in the hash tables, the test entry is  the number of entries in the OTHERS list that have a higher priority."
+)
+
+
+(CL:DEFSTRUCT (ENTRY (:CONC-NAME NIL) (:FAST-ACCESSORS T)) (TEST NIL) (IL:* IL:|;;| "predicate function or count of higher priority others.") (FN NIL) (IL:* IL:\; "pprint function") (FULL-SPEC NIL))
+
+
+
+(IL:* IL:\; "list of priority and type specifier")
+
+
+(DEFUN COPY-PPRINT-DISPATCH (&OPTIONAL (TABLE *PRINT-PPRINT-DISPATCH*)) (WHEN (NULL TABLE) (SETQ TABLE *IPD*)) (LET* ((NEW-CONSES-WITH-CARS (MAKE-HASH-TABLE :TEST (FUNCTION EQ) :SIZE (MAX (HASH-TABLE-COUNT (CONSES-WITH-CARS TABLE)) 32))) (NEW-STRUCTURES (MAKE-HASH-TABLE :TEST (FUNCTION EQ) :SIZE (MAX (HASH-TABLE-COUNT (STRUCTURES TABLE)) 32)))) (MAPHASH (FUNCTION (LAMBDA (KEY VALUE) (SETF (GETHASH KEY NEW-CONSES-WITH-CARS) (COPY-ENTRY VALUE)))) (CONSES-WITH-CARS TABLE)) (MAPHASH (FUNCTION (LAMBDA (KEY VALUE) (SETF (GETHASH KEY NEW-STRUCTURES) (COPY-ENTRY VALUE)))) (STRUCTURES TABLE)) (MAKE-PPRINT-DISPATCH :CONSES-WITH-CARS NEW-CONSES-WITH-CARS :STRUCTURES NEW-STRUCTURES :OTHERS (COPY-LIST (OTHERS TABLE)))))
+
+(DEFUN SET-PPRINT-DISPATCH (TYPE-SPECIFIER FUNCTION &OPTIONAL (PRIORITY 0) (TABLE *PRINT-PPRINT-DISPATCH*)) (WHEN (OR (NOT (NUMBERP PRIORITY)) (COMPLEXP PRIORITY)) (ERROR "invalid PRIORITY argument ~A to SET-PPRINT-DISPATCH" PRIORITY)) (SET-PPRINT-DISPATCH+ TYPE-SPECIFIER FUNCTION PRIORITY TABLE))
+
+(DEFUN SET-PPRINT-DISPATCH+ (TYPE-SPECIFIER FUNCTION PRIORITY TABLE) (LET* ((CATEGORY (SPECIFIER-CATEGORY TYPE-SPECIFIER)) (PRED (IF (NOT (EQ CATEGORY (QUOTE OTHER))) NIL (LET ((PRED (SPECIFIER-FN TYPE-SPECIFIER))) (IF (AND (CONSP (CADDR PRED)) (SYMBOLP (CAADDR PRED)) (EQUAL (CDADDR PRED) (QUOTE (X)))) (SYMBOL-FUNCTION (CAADDR PRED)) (COMPILE NIL PRED))))) (ENTRY (IF FUNCTION (MAKE-ENTRY :TEST PRED :FN FUNCTION :FULL-SPEC (LIST PRIORITY TYPE-SPECIFIER))))) (CASE CATEGORY (CONS-WITH-CAR (COND ((NULL ENTRY) (REMHASH (CADADR TYPE-SPECIFIER) (CONSES-WITH-CARS TABLE))) (T (SETF (TEST ENTRY) (COUNT-IF (FUNCTION (LAMBDA (E) (PRIORITY-> (CAR (FULL-SPEC E)) PRIORITY))) (OTHERS TABLE))) (SETF (GETHASH (CADADR TYPE-SPECIFIER) (CONSES-WITH-CARS TABLE)) ENTRY)))) (STRUCTURE-TYPE (COND ((NULL ENTRY) (REMHASH TYPE-SPECIFIER (STRUCTURES TABLE))) (T (SETF (TEST ENTRY) (COUNT-IF (FUNCTION (LAMBDA (E) (PRIORITY-> (CAR (FULL-SPEC E)) PRIORITY))) (OTHERS TABLE))) (SETF (GETHASH TYPE-SPECIFIER (STRUCTURES TABLE)) ENTRY)))) (T (IL:* IL:\; "other") (LET ((OLD (CAR (MEMBER TYPE-SPECIFIER (OTHERS TABLE) :TEST (FUNCTION EQUAL) :KEY (FUNCTION (LAMBDA (E) (CADR (FULL-SPEC E)))))))) (WHEN OLD (SETF (OTHERS TABLE) (DELETE OLD (OTHERS TABLE))) (ADJUST-COUNTS TABLE (CAR (FULL-SPEC OLD)) -1))) (WHEN ENTRY (LET ((OTHERS (CONS NIL (OTHERS TABLE)))) (DO ((L OTHERS (CDR L))) ((NULL (CDR L)) (RPLACD L (LIST ENTRY))) (WHEN (PRIORITY-> PRIORITY (CAR (FULL-SPEC (CADR L)))) (RPLACD L (CONS ENTRY (CDR L))) (RETURN NIL))) (SETF (OTHERS TABLE) (CDR OTHERS))) (ADJUST-COUNTS TABLE PRIORITY 1))))) NIL)
+
+(DEFUN PRIORITY-> (X Y) (IF (CONSP X) (IF (CONSP Y) (> (CAR X) (CAR Y)) NIL) (IF (CONSP Y) T (> X Y))))
+
+(DEFUN ADJUST-COUNTS (TABLE PRIORITY DELTA) (MAPHASH (FUNCTION (LAMBDA (KEY VALUE) (DECLARE (IGNORE KEY)) (IF (PRIORITY-> PRIORITY (CAR (FULL-SPEC VALUE))) (INCF (TEST VALUE) DELTA)))) (CONSES-WITH-CARS TABLE)) (MAPHASH (FUNCTION (LAMBDA (KEY VALUE) (DECLARE (IGNORE KEY)) (IF (PRIORITY-> PRIORITY (CAR (FULL-SPEC VALUE))) (INCF (TEST VALUE) DELTA)))) (STRUCTURES TABLE)))
+
+(DEFUN PPRINT-DISPATCH (OBJECT &OPTIONAL (TABLE *PRINT-PPRINT-DISPATCH*)) (WHEN (NULL TABLE) (SETQ TABLE *IPD*)) (LET ((FN (GET-PRINTER OBJECT TABLE))) (VALUES (OR FN (FUNCTION NON-PRETTY-PRINT)) (NOT (NULL FN)))))
+
+(DEFUN GET-PRINTER (OBJECT TABLE) (LET ((ENTRY (IF (CONSP OBJECT) (GETHASH (CAR OBJECT) (CONSES-WITH-CARS TABLE)) (GETHASH (TYPE-OF OBJECT) (STRUCTURES TABLE))))) (IF (NOT ENTRY) (IL:* IL:|;;| "(SETQ ENTRY (FIND OBJECT (OTHERS TABLE) :TEST #'FITS))  ") (IL:* IL:|;;| "Equivalent code below") (DO ((L (OTHERS TABLE) (CDR L))) ((COND ((NULL L)) ((FUNCALL (TEST (CAR L)) OBJECT) (SETQ ENTRY (CAR L)))))) (DO ((I (TEST ENTRY) (1- I)) (L (OTHERS TABLE) (CDR L))) ((ZEROP I)) (WHEN (IL:* IL:|;;| "(FITS OBJECT (CAR L))") (IL:* IL:|;;| "Equivalent code below ") (FUNCALL (TEST (CAR L)) OBJECT) (SETQ ENTRY (CAR L)) (RETURN NIL)))) (WHEN ENTRY (FN ENTRY))))
+
+(DEFUN FITS (OBJ ENTRY) (FUNCALL (TEST ENTRY) OBJ))
+
+(DEFUN SPECIFIER-CATEGORY (SPEC) (COND ((AND (CONSP SPEC) (EQ (CAR SPEC) (QUOTE CONS)) (CONSP (CDR SPEC)) (NULL (CDDR SPEC)) (CONSP (CADR SPEC)) (EQ (CAADR SPEC) (QUOTE MEMBER)) (CONSP (CDADR SPEC)) (NULL (CDDADR SPEC))) (QUOTE CONS-WITH-CAR)) ((AND (SYMBOLP SPEC) (STRUCTURE-TYPE-P SPEC)) (QUOTE STRUCTURE-TYPE)) (T (QUOTE OTHER))))
+
+(DEFVAR *PREDS-FOR-SPECS* (QUOTE ((T ALWAYS-TRUE) (CONS CONSP) (SIMPLE-ATOM SIMPLE-ATOM-P) (OTHER OTHERP) (NULL NULL) (SYMBOL SYMBOLP) (ATOM ATOM) (CONS CONSP) (LIST LISTP) (NUMBER NUMBERP) (INTEGER INTEGERP) (RATIONAL RATIONALP) (FLOAT FLOATP) (COMPLEX COMPLEXP) (CHARACTER CHARACTERP) (STRING STRINGP) (BIT-VECTOR BIT-VECTOR-P) (VECTOR VECTORP) (SIMPLE-VECTOR SIMPLE-VECTOR-P) (SIMPLE-STRING SIMPLE-STRING-P) (SIMPLE-BIT-VECTOR SIMPLE-BIT-VECTOR-P) (ARRAY ARRAYP) (PACKAGE PACKAGEP) (FUNCTION FUNCTIONP) (COMPILED-FUNCTION COMPILED-FUNCTION-P) (COMMON COMMONP))))
+
+(DEFUN ALWAYS-TRUE (X) (DECLARE (IGNORE X)) T)
+
+(DEFUN SPECIFIER-FN (SPEC) (IL:BQUOTE (LAMBDA (X) (IL:\\\, (CONVERT-BODY SPEC)))))
+
+(DEFUN CONVERT-BODY (SPEC) (COND ((ATOM SPEC) (LET ((PRED (CADR (ASSOC SPEC *PREDS-FOR-SPECS*)))) (IF PRED (IL:BQUOTE ((IL:\\\, PRED) X)) (IL:BQUOTE (TYPEP X (QUOTE (IL:\\\, SPEC))))))) ((MEMBER (CAR SPEC) (QUOTE (AND OR NOT))) (CONS (CAR SPEC) (MAPCAR (FUNCTION CONVERT-BODY) (CDR SPEC)))) ((EQ (CAR SPEC) (QUOTE MEMBER)) (IL:BQUOTE (MEMBER X (QUOTE (IL:\\\, (COPY-LIST (CDR SPEC))))))) ((EQ (CAR SPEC) (QUOTE CONS)) (IL:BQUOTE (AND (CONSP X) (IL:\\\,@ (IF (CDR SPEC) (IL:BQUOTE ((LET ((X (CAR X))) (IL:\\\, (CONVERT-BODY (CADR SPEC)))))))) (IL:\\\,@ (IF (CDDR SPEC) (IL:BQUOTE ((LET ((X (CDR X))) (IL:\\\, (CONVERT-BODY (CADDR SPEC))))))))))) ((EQ (CAR SPEC) (QUOTE SATISFIES)) (IL:BQUOTE (FUNCALL (FUNCTION (IL:\\\, (CADR SPEC))) X))) (T (IL:BQUOTE (TYPEP X (QUOTE (IL:\\\, (COPY-TREE SPEC))))))))
+
+
+
+(IL:* IL:|;;| "              ---- XP STRUCTURES, AND THE INTERNAL ALGORITHM ----")
+
+
+
+
+(IL:* IL:\; "not used at run time.")
+
+
+(DEFVAR BLOCK-STACK-ENTRY-SIZE 1)
+
+(DEFVAR PREFIX-STACK-ENTRY-SIZE 5)
+
+(DEFVAR QUEUE-ENTRY-SIZE 7)
+
+(DEFVAR BUFFER-ENTRY-SIZE 1)
+
+(DEFVAR PREFIX-ENTRY-SIZE 1)
+
+(DEFVAR SUFFIX-ENTRY-SIZE 1)
+
+
+
+(IL:* IL:\; "used at run time")
+
+
+(DEFVAR BLOCK-STACK-MIN-SIZE 35)
+
+(DEFVAR PREFIX-STACK-MIN-SIZE 150)
+
+(DEFVAR QUEUE-MIN-SIZE 525)
+
+(DEFVAR BUFFER-MIN-SIZE 256)
+
+(DEFVAR PREFIX-MIN-SIZE 256)
+
+(DEFVAR SUFFIX-MIN-SIZE 256)
+
+
+
+(IL:* IL:|;;| 
+"Hack of the month: The following definitions are used in Medley instead of the Common Lisp strcuture definition for XP-STRUCTURE; the idea is to make an XP-STRUCTURE look like a vanilla STREAM object to as much of the system as possible; most of its funny functionality will be buried in stream functions"
+)
+
+
+
+
+(IL:* IL:|;;| 
+"We need a way to conditionalize file manager entries; I'll look into it sometime soon...")
+
+
+
+
+(IL:* IL:|;;| "Here is the DEFSTRUCT we are simulating :")
+
+
+
+
+(IL:* IL:|;;| "(CL:DEFSTRUCT")
+
+
+
+
+(IL:* IL:|;;| 
+"(XP::XP-STRUCTURE (:CONC-NAME NIL) (:PRINT-FUNCTION XP::DESCRIBE-XP) #+INTERLISP (:FAST-ACCESSORS T))"
+)
+
+
+
+
+(IL:* IL:|;;| 
+"(XP::BASE-STREAM NIL) ; The stream io eventually goes to. XP::LINEL ; The line length to use for formatting."
+)
+
+
+
+
+(IL:* IL:|;;| "XP::LINE-LIMIT ; If non-NIL the max number of lines to ; print.")
+
+
+
+
+(IL:* IL:|;;| "XP::LINE-NO ; number of next line to be printed.")
+
+
+
+
+(IL:* IL:|;;| 
+"XP::CHAR-MODE ; NIL :UP :DOWN :CAP0 :CAP1 :CAPW XP::CHAR-MODE-COUNTER ; depth of nesting of ~(...~)")
+
+
+
+
+(IL:* IL:|;;| 
+"XP::DEPTH-IN-BLOCKS ; Number of logical blocks at QRIGHT ; that are started but not ended.")
+
+
+
+
+(IL:* IL:|;;| 
+"(XP::BLOCK-STACK (CL:MAKE-ARRAY #.XP::BLOCK-STACK-MIN-SIZE)) XP::BLOCK-STACK-PTR ;; This stack is pushed and popped in accordance with the way blocks are  nested at the moment ;; they are entered into the queue.  It contains the  following block specific value. ;; SECTION-START total position where the section (see AIM-1102) that is rightmost in the queue ;; started."
+)
+
+
+
+
+(IL:* IL:|;;| 
+"(XP::BUFFER (CL:MAKE-ARRAY #.XP::BUFFER-MIN-SIZE :ELEMENT-TYPE #-SYMBOLICS (QUOTE LISP:STRING-CHAR) #+SYMBOLICS 'character)) XP::CHARPOS"
+)
+
+
+
+
+(IL:* IL:|;;| "XP::BUFFER-PTR")
+
+
+
+
+(IL:* IL:|;;| 
+"XP::BUFFER-OFFSET ;; This is a vector of characters (eg a string) that builds up the line images that will be ;; printed out.  BUFFER-PTR is the buffer position where the next character should be inserted in ;; the string.  CHARPOS is the output character position of the first character in the buffer ;; (non-zero only if a partial line has been output).  BUFFER-OFFSET is used in computing total ;; lengths. It is changed to reflect all shifting and insertion of prefixes so that total length ;; computes things as they would be if they were  all on one line.  Positions are kept three ;; different ways Buffer position (eg BUFFER-PTR) Line position (eg (+ BUFFER-PTR CHARPOS)).  ;; Indentations are stored in this form. Total position if all on one line (eg (+ BUFFER-PTR ;; BUFFER-OFFSET))  Positions are stored in this form."
+)
+
+
+
+
+(IL:* IL:|;;| 
+"(XP::QUEUE (CL:MAKE-ARRAY #.XP::QUEUE-MIN-SIZE)) XP::QLEFT XP::QRIGHT ;; This holds a queue of action descriptors.  QLEFT and QRIGHT point to the next entry to dequeue ;; and the last entry enqueued respectively.  The queue is empty when (> QLEFT QRIGHT).  The ;; queue entries have several parts: QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK QKIND ;; :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH or :BLOCK/:CURRENT QPOS total ;; position corresponding to this entry QDEPTH depth in blocks of this entry. QEND offset to ;; entry marking end of section this entry starts. (NIL until known.) Only :start-block and ;; non-literal :newline entries can start sections. QOFFSET offset to :END-BLOCK for :START-BLOCK ;; (NIL until known). QARG for :IND indentation delta     for :START-BLOCK suffix in the block if ;; any.                      or if per-line-prefix then cons of suffix and                      ;; per-line-prefix.     for :END-BLOCK suffix for the block if any."
+)
+
+
+
+
+(IL:* IL:|;;| 
+"(XP::PREFIX (CL:MAKE-ARRAY #.XP::BUFFER-MIN-SIZE :ELEMENT-TYPE #-SYMBOLICS (QUOTE LISP:STRING-CHAR) #+SYMBOLICS 'character)) ;; this stores the prefix that should be used at the start of the line"
+)
+
+
+
+
+(IL:* IL:|;;| "(XP::PREFIX-STACK (CL:MAKE-ARRAY #.XP::PREFIX-STACK-MIN-SIZE))")
+
+
+
+
+(IL:* IL:|;;| 
+"XP::PREFIX-STACK-PTR ;; This stack is pushed and popped in accordance with the way blocks  are nested at the moment ;; things are taken off the queue and printed. It contains the following block specific values. ;; PREFIX-PTR current length of PREFIX. SUFFIX-PTR current length of pending suffix ;; NON-BLANK-PREFIX-PTR current length of non-blank prefix. INITIAL-PREFIX-PTR prefix-ptr at the ;; start of this block. SECTION-START-LINE line-no value at last non-literal break at this level."
+)
+
+
+
+
+(IL:* IL:|;;| 
+"(XP::SUFFIX (CL:MAKE-ARRAY #.XP::BUFFER-MIN-SIZE :ELEMENT-TYPE #-SYMBOLICS (QUOTE LISP:STRING-CHAR) #+SYMBOLICS 'character)))"
+)
+
+(IL:DECLARE\: IL:EVAL@COMPILE
+
+(IL:BLOCKRECORD XP-STRUCTURE ((BUFFER-OFFSET IL:SIGNEDWORD) (BUFFER-PTR IL:SIGNEDWORD) (BUFFER IL:POINTER) (IL:BYTESIZE BYTE) (NIL BYTE) (NIL IL:SIGNEDWORD) (CHARPOS IL:SIGNEDWORD) (DEPTH-IN-BLOCKS IL:SIGNEDWORD) (NIL IL:POINTER) (NIL IL:POINTER) (NIL IL:POINTER) (NIL IL:POINTER) (CHAR-MODE IL:POINTER) (CHAR-MODE-COUNTER IL:SIGNEDWORD) (LINEL IL:SIGNEDWORD) (BASE-STREAM IL:POINTER) (BLOCK-STACK IL:POINTER) (QUEUE IL:POINTER) (PREFIX IL:POINTER) (PREFIX-STACK IL:POINTER) (QLEFT IL:SIGNEDWORD) (QRIGHT IL:SIGNEDWORD) (BLOCK-STACK-PTR IL:SIGNEDWORD) (PREFIX-STACK-PTR IL:SIGNEDWORD) (SUFFIX IL:POINTER) (NIL IL:POINTER) (NIL IL:POINTER) (NIL IL:POINTER) (NIL IL:POINTER) (NIL IL:POINTER) (NIL IL:POINTER) (NIL IL:POINTER) (NIL IL:POINTER) (NIL IL:SIGNEDWORD) (LINE-NO IL:SIGNEDWORD) (LINE-LIMIT IL:POINTER))
+)
+)
+
+(DEFMACRO BASE-STREAM (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BASE-STREAM) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO LINEL (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE LINEL) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO LINE-LIMIT (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE LINE-LIMIT) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO LINE-NO (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE LINE-NO) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO CHAR-MODE (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE CHAR-MODE) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO CHAR-MODE-COUNTER (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE CHAR-MODE-COUNTER) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO DEPTH-IN-BLOCKS (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE DEPTH-IN-BLOCKS) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO BLOCK-STACK (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BLOCK-STACK) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO BLOCK-STACK-PTR (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BLOCK-STACK-PTR) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO BUFFER (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BUFFER) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO CHARPOS (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE CHARPOS) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO BUFFER-PTR (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BUFFER-PTR) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO BUFFER-OFFSET (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BUFFER-OFFSET) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO QUEUE (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE QUEUE) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO QLEFT (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE QLEFT) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO QRIGHT (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE QRIGHT) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO PREFIX (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE PREFIX) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO PREFIX-STACK (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE PREFIX-STACK) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO PREFIX-STACK-PTR (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE PREFIX-STACK-PTR) IL:|of| (IL:\\\, XP))))
+
+(DEFMACRO SUFFIX (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE SUFFIX) IL:|of| (IL:\\\, XP))))
+
+(DEFUN MAKE-XP-STRUCTURE (&KEY (BASE-STREAM NIL) (BLOCK-STACK (MAKE-ARRAY 35)) (BUFFER (MAKE-ARRAY 256 :ELEMENT-TYPE (QUOTE STRING-CHAR))) (QUEUE (MAKE-ARRAY 525)) (PREFIX (MAKE-ARRAY 256 :ELEMENT-TYPE (QUOTE STRING-CHAR))) (PREFIX-STACK (MAKE-ARRAY 150)) (SUFFIX (MAKE-ARRAY 256 :ELEMENT-TYPE (QUOTE STRING-CHAR))) (LINEL 0) (LINE-LIMIT 65535) (LINE-NO 0) (DEPTH-IN-BLOCKS 0) (BLOCK-STACK-PTR 0) (CHARPOS 0) (BUFFER-PTR 0) (BUFFER-OFFSET 0) (QLEFT 0) (QRIGHT 0) (PREFIX-STACK-PTR 0)) (LET ((XP (IL:|create| STREAM IL:DEVICE IL:_ *XP-STREAM-DEVICE* IL:ACCESS IL:_ (QUOTE IL:OUTPUT) IL:OTHERPROPS IL:_ (QUOTE (*XP-STREAM-DEVICE* T)) IL:OUTCHARFN IL:_ (IL:FUNCTION XP-STREAM-OUTCHARFN) IL:STRMBOUTFN IL:_ (IL:FUNCTION IL:\\OUTCHAR)))) (SETF (BUFFER XP) BUFFER) (SETF (BASE-STREAM XP) BASE-STREAM) (SETF (BLOCK-STACK XP) BLOCK-STACK) (SETF (QUEUE XP) QUEUE) (SETF (PREFIX XP) PREFIX) (SETF (PREFIX-STACK XP) PREFIX-STACK) (SETF (SUFFIX XP) SUFFIX) (SETF (LINEL XP) LINEL) (SETF (LINE-LIMIT XP) LINE-LIMIT) (SETF (LINE-NO XP) LINE-NO) (SETF (DEPTH-IN-BLOCKS XP) DEPTH-IN-BLOCKS) (SETF (BLOCK-STACK-PTR XP) BLOCK-STACK-PTR) (SETF (CHARPOS XP) CHARPOS) (SETF (BUFFER-PTR XP) BUFFER-PTR) (SETF (BUFFER-OFFSET XP) BUFFER-OFFSET) (SETF (QLEFT XP) QLEFT) (SETF (QRIGHT XP) QRIGHT) (SETF (PREFIX-STACK-PTR XP) PREFIX-STACK-PTR) XP))
+
+(DEFMACRO XP-STRUCTURE-P (OBJECT) (IL:BQUOTE (AND (TYPEP (IL:\\\, OBJECT) (QUOTE STREAM)) (EQ (IL:|fetch| (STREAM IL:DEVICE) IL:|of| (IL:\\\, OBJECT)) *XP-STREAM-DEVICE*))))
+
+
+
+(IL:* IL:|;;| 
+"this stores the suffixes that have to be printed to close of the current open blocks.  For convenient in popping, the whole suffix is stored in reverse order."
+)
+
+
+(DEFMACRO LP<-BP (XP &OPTIONAL (PTR NIL)) (IF (NULL PTR) (SETQ PTR (IL:BQUOTE (BUFFER-PTR (IL:\\\, XP))))) (IL:BQUOTE (+ (IL:\\\, PTR) (CHARPOS (IL:\\\, XP)))))
+
+(DEFMACRO TP<-BP (XP) (IL:BQUOTE (+ (BUFFER-PTR (IL:\\\, XP)) (BUFFER-OFFSET (IL:\\\, XP)))))
+
+(DEFMACRO BP<-LP (XP PTR) (IL:BQUOTE (- (IL:\\\, PTR) (CHARPOS (IL:\\\, XP)))))
+
+(DEFMACRO BP<-TP (XP PTR) (IL:BQUOTE (- (IL:\\\, PTR) (BUFFER-OFFSET (IL:\\\, XP)))))
+
+
+
+(IL:* IL:|;;| 
+"This does not tell you the line position you were at when the TP was set, unless there have been no newlines or indentation output  between ptr and the current output point."
+)
+
+
+(DEFMACRO LP<-TP (XP PTR) (IL:BQUOTE (LP<-BP (IL:\\\, XP) (BP<-TP (IL:\\\, XP) (IL:\\\, PTR)))))
+
+
+
+(IL:* IL:|;;| 
+"We don't use adjustable vectors or any of that, because we seldom have to actually extend and non-adjustable vectors are a lot faster in many Common Lisps."
+)
+
+
+(DEFMACRO CHECK-SIZE (XP VECT PTR) (LET* ((MIN-SIZE (SYMBOL-VALUE (INTERN (CONCATENATE (QUOTE STRING) (STRING VECT) "-MIN-SIZE") (FIND-PACKAGE "XP")))) (ENTRY-SIZE (SYMBOL-VALUE (INTERN (CONCATENATE (QUOTE STRING) (STRING VECT) "-ENTRY-SIZE") (FIND-PACKAGE "XP"))))) (IL:BQUOTE (WHEN (AND (> (IL:\\\, PTR) (IL:\\\, (- MIN-SIZE ENTRY-SIZE))) (IL:* IL:\; "seldom happens") (> (IL:\\\, PTR) (- (LENGTH ((IL:\\\, VECT) (IL:\\\, XP))) (IL:\\\, ENTRY-SIZE)))) (LET* ((OLD ((IL:\\\, VECT) (IL:\\\, XP))) (NEW (MAKE-ARRAY (+ (IL:\\\, PTR) (IL:\\\, (IF (= ENTRY-SIZE 1) 50 (* 10 ENTRY-SIZE)))) :ELEMENT-TYPE (ARRAY-ELEMENT-TYPE OLD)))) (REPLACE NEW OLD) (SETF ((IL:\\\, VECT) (IL:\\\, XP)) NEW))))))
+
+(DEFMACRO SECTION-START (XP) (IL:BQUOTE (AREF (BLOCK-STACK (IL:\\\, XP)) (BLOCK-STACK-PTR (IL:\\\, XP)))))
+
+(DEFUN PUSH-BLOCK-STACK (XP) (INCF (BLOCK-STACK-PTR XP) 1) (CHECK-SIZE XP BLOCK-STACK (BLOCK-STACK-PTR XP)))
+
+(DEFUN POP-BLOCK-STACK (XP) (IL:* IL:\; "Edited 10-Jun-92 19:54 by jrb:") (DECF (BLOCK-STACK-PTR XP) 1))
+
+(DEFMACRO PREFIX-PTR (XP) (IL:BQUOTE (AREF (PREFIX-STACK (IL:\\\, XP)) (PREFIX-STACK-PTR (IL:\\\, XP)))))
+
+(DEFMACRO SUFFIX-PTR (XP) (IL:BQUOTE (AREF (PREFIX-STACK (IL:\\\, XP)) (+ (PREFIX-STACK-PTR (IL:\\\, XP)) 1))))
+
+(DEFMACRO NON-BLANK-PREFIX-PTR (XP) (IL:BQUOTE (AREF (PREFIX-STACK (IL:\\\, XP)) (+ (PREFIX-STACK-PTR (IL:\\\, XP)) 2))))
+
+(DEFMACRO INITIAL-PREFIX-PTR (XP) (IL:BQUOTE (AREF (PREFIX-STACK (IL:\\\, XP)) (+ (PREFIX-STACK-PTR (IL:\\\, XP)) 3))))
+
+(DEFMACRO SECTION-START-LINE (XP) (IL:BQUOTE (AREF (PREFIX-STACK (IL:\\\, XP)) (+ (PREFIX-STACK-PTR (IL:\\\, XP)) 4))))
+
+(DEFUN PUSH-PREFIX-STACK (XP) (LET ((OLD-PREFIX 0) (OLD-SUFFIX 0) (OLD-NON-BLANK 0)) (WHEN (NOT (MINUSP (PREFIX-STACK-PTR XP))) (SETQ OLD-PREFIX (PREFIX-PTR XP) OLD-SUFFIX (SUFFIX-PTR XP) OLD-NON-BLANK (NON-BLANK-PREFIX-PTR XP))) (INCF (PREFIX-STACK-PTR XP) 5) (CHECK-SIZE XP PREFIX-STACK (PREFIX-STACK-PTR XP)) (SETF (PREFIX-PTR XP) OLD-PREFIX) (SETF (SUFFIX-PTR XP) OLD-SUFFIX) (SETF (NON-BLANK-PREFIX-PTR XP) OLD-NON-BLANK)))
+
+(DEFUN POP-PREFIX-STACK (XP) (DECF (PREFIX-STACK-PTR XP) 5))
+
+(DEFMACRO QTYPE (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (IL:\\\, INDEX))))
+
+(DEFMACRO QKIND (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (1+ (IL:\\\, INDEX)))))
+
+(DEFMACRO QPOS (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (+ (IL:\\\, INDEX) 2))))
+
+(DEFMACRO QDEPTH (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (+ (IL:\\\, INDEX) 3))))
+
+(DEFMACRO QEND (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (+ (IL:\\\, INDEX) 4))))
+
+(DEFMACRO QOFFSET (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (+ (IL:\\\, INDEX) 5))))
+
+(DEFMACRO QARG (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (+ (IL:\\\, INDEX) 6))))
+
+
+
+(IL:* IL:|;;| 
+"we shift the queue over rather than using a circular queue because that works out to be a lot faster in practice.  Note, short printout does not ever cause a shift, and even in long printout, the queue is shifted left for free every time it happens to empty out."
+)
+
+
+(DEFUN ENQUEUE (XP TYPE KIND &OPTIONAL ARG) (INCF (QRIGHT XP) 7) (WHEN (> (QRIGHT XP) 518) (IL:* IL:|;;| "Equivalent code below, assuming the queue is an array") (IL:* IL:|;;| "(DO ((S1 0 (INCF S1)) (S2 (QLEFT XP) (INCF S2)) (E2 (QRIGHT XP)) (Q (QUEUE XP))) ((IL:IGREATERP S2 E2)) (SETF (AREF Q S1) (AREF Q S2)))") (REPLACE (QUEUE XP) (QUEUE XP) :START2 (QLEFT XP) :END2 (QRIGHT XP)) (SETF (QRIGHT XP) (- (QRIGHT XP) (QLEFT XP))) (SETF (QLEFT XP) 0)) (CHECK-SIZE XP QUEUE (QRIGHT XP)) (SETF (QTYPE XP (QRIGHT XP)) TYPE) (SETF (QKIND XP (QRIGHT XP)) KIND) (SETF (QPOS XP (QRIGHT XP)) (TP<-BP XP)) (SETF (QDEPTH XP (QRIGHT XP)) (DEPTH-IN-BLOCKS XP)) (SETF (QEND XP (QRIGHT XP)) NIL) (SETF (QOFFSET XP (QRIGHT XP)) NIL) (SETF (QARG XP (QRIGHT XP)) ARG))
+
+(DEFMACRO QNEXT (INDEX) (IL:BQUOTE (+ (IL:\\\, INDEX) 7)))
+
+(DEFVAR *DESCRIBE-XP-STREAMS-FULLY* NIL "Set to T to see more info.")
+
+(DEFUN DESCRIBE-XP (XP S DEPTH) (DECLARE (IGNORE DEPTH)) (CL:FORMAT S "#<XP stream ") (IF (NOT (BASE-STREAM XP)) (CL:FORMAT S "not currently in use") (CL:FORMAT S "outputting to ~S" (BASE-STREAM XP))) (WHEN (BASE-STREAM XP) (CL:FORMAT S "~&buffer= ~S" (SUBSEQ (BUFFER XP) 0 (MAX (BUFFER-PTR XP) 0))) (WHEN (NOT *DESCRIBE-XP-STREAMS-FULLY*) (CL:PRINC " ..." S)) (WHEN *DESCRIBE-XP-STREAMS-FULLY* (CL:FORMAT S "~&   pos   _123456789_123456789_123456789_123456789") (CL:FORMAT S "~&depth-in-blocks= ~D linel= ~D line-no= ~D line-limit= ~D" (DEPTH-IN-BLOCKS XP) (LINEL XP) (LINE-NO XP) (LINE-LIMIT XP)) (WHEN (OR (CHAR-MODE XP) (NOT (ZEROP (CHAR-MODE-COUNTER XP)))) (CL:FORMAT S "~&char-mode= ~S char-mode-counter= ~D" (CHAR-MODE XP) (CHAR-MODE-COUNTER XP))) (UNLESS (MINUSP (BLOCK-STACK-PTR XP)) (CL:FORMAT S "~&section-start") (DO ((SAVE (BLOCK-STACK-PTR XP))) ((MINUSP (BLOCK-STACK-PTR XP)) (SETF (BLOCK-STACK-PTR XP) SAVE)) (CL:FORMAT S " ~D" (SECTION-START XP)) (POP-BLOCK-STACK XP))) (CL:FORMAT S "~&linel= ~D charpos= ~D buffer-ptr= ~D buffer-offset= ~D" (LINEL XP) (CHARPOS XP) (BUFFER-PTR XP) (BUFFER-OFFSET XP)) (UNLESS (MINUSP (PREFIX-STACK-PTR XP)) (CL:FORMAT S "~&prefix= ~S" (SUBSEQ (PREFIX XP) 0 (MAX (PREFIX-PTR XP) 0))) (CL:FORMAT S "~&suffix= ~S" (SUBSEQ (SUFFIX XP) 0 (MAX (SUFFIX-PTR XP) 0)))) (UNLESS (> (QLEFT XP) (QRIGHT XP)) (CL:FORMAT S "~&ptr type         kind           pos depth end offset arg") (DO ((P (QLEFT XP) (QNEXT P))) ((> P (QRIGHT XP))) (CL:FORMAT S "~&~4A~13A~15A~4A~6A~4A~7A~A" (/ (- P (QLEFT XP)) 7) (QTYPE XP P) (IF (MEMBER (QTYPE XP P) (QUOTE (:NEWLINE :IND))) (QKIND XP P) "") (BP<-TP XP (QPOS XP P)) (QDEPTH XP P) (IF (NOT (MEMBER (QTYPE XP P) (QUOTE (:NEWLINE :START-BLOCK)))) "" (AND (QEND XP P) (/ (- (+ P (QEND XP P)) (QLEFT XP)) 7))) (IF (NOT (EQ (QTYPE XP P) :START-BLOCK)) "" (AND (QOFFSET XP P) (/ (- (+ P (QOFFSET XP P)) (QLEFT XP)) 7))) (IF (NOT (MEMBER (QTYPE XP P) (QUOTE (:IND :START-BLOCK :END-BLOCK)))) "" (QARG XP P))))) (UNLESS (MINUSP (PREFIX-STACK-PTR XP)) (CL:FORMAT S "~&initial-prefix-ptr prefix-ptr suffix-ptr non-blank start-line") (DO ((SAVE (PREFIX-STACK-PTR XP))) ((MINUSP (PREFIX-STACK-PTR XP)) (SETF (PREFIX-STACK-PTR XP) SAVE)) (CL:FORMAT S "~& ~19A~11A~11A~10A~A" (INITIAL-PREFIX-PTR XP) (PREFIX-PTR XP) (SUFFIX-PTR XP) (NON-BLANK-PREFIX-PTR XP) (SECTION-START-LINE XP)) (POP-PREFIX-STACK XP))))) (CL:PRINC ">" S) (VALUES))
+
+
+
+(IL:* IL:|;;| 
+"This maintains a list of XP structures.  We save them so that we don't have to create new ones all of the time. We have separate objects so that many can be in use at once. (Note should really be doing some locking here, but CL does not have the primitives for it.  There is a tiny probability here that two different processes could end up trying to use the same xp-stream)"
+)
+
+
+(DEFVAR *FREE-XPS* NIL "free list of XP stream objects")
+
+
+
+(IL:* IL:\; "never bound")
+
+
+(DEFUN GET-PRETTY-PRINT-STREAM (STREAM) (LET ((XP (POP *FREE-XPS*))) (INITIALIZE-XP (IF XP XP (MAKE-XP-STRUCTURE)) STREAM)))
+
+
+
+(IL:* IL:|;;| "If you call this, the xp-stream gets efficiently recycled.")
+
+
+(DEFUN FREE-PRETTY-PRINT-STREAM (XP) (SETF (BASE-STREAM XP) NIL) (PUSHNEW XP *FREE-XPS*))
+
+
+
+(IL:* IL:|;;| "This is called to initialize things when you start pretty printing.")
+
+
+(DEFUN INITIALIZE-XP (XP STREAM) (SETF (BASE-STREAM XP) STREAM) (SETF (LINEL XP) (MAX 0 (COND (*PRINT-RIGHT-MARGIN*) ((OUTPUT-WIDTH STREAM)) (T *DEFAULT-RIGHT-MARGIN*)))) (SETF (LINE-LIMIT XP) *PRINT-LINES*) (SETF (LINE-NO XP) 1) (SETF (CHAR-MODE XP) NIL) (SETF (CHAR-MODE-COUNTER XP) 0) (SETF (DEPTH-IN-BLOCKS XP) 0) (SETF (BLOCK-STACK-PTR XP) 0) (SETF (CHARPOS XP) (COND ((OUTPUT-POSITION STREAM)) (T 0))) (SETF (SECTION-START XP) 0) (SETF (BUFFER-PTR XP) 0) (SETF (BUFFER-OFFSET XP) (CHARPOS XP)) (SETF (QLEFT XP) 0) (SETF (QRIGHT XP) -7) (SETF (PREFIX-STACK-PTR XP) -5) XP)
+
+
+
+(IL:* IL:|;;| 
+"The char-mode stuff is a bit tricky. one can be in one of the following modes: NIL no changes to characters output. :UP CHAR-UPCASE used. :DOWN CHAR-DOWNCASE used. :CAP0 capitalize next alphanumeric letter then switch to :DOWN. :CAP1 capitalize next alphanumeric letter then switch to :CAPW :CAPW downcase letters.  When a word break letter found, switch to :CAP1. It is possible for ~(~) to be nested in a format string, but note that each mode specifies what should happen to every letter.  Therefore, inner nested modes never have any effect.  You can just ignore them."
+)
+
+
+(DEFUN PUSH-CHAR-MODE (XP NEW-MODE) (IF (ZEROP (CHAR-MODE-COUNTER XP)) (SETF (CHAR-MODE XP) NEW-MODE)) (INCF (CHAR-MODE-COUNTER XP)))
+
+(DEFUN POP-CHAR-MODE (XP) (DECF (CHAR-MODE-COUNTER XP)) (IF (ZEROP (CHAR-MODE-COUNTER XP)) (SETF (CHAR-MODE XP) NIL)))
+
+(DEFUN HANDLE-CHAR-MODE (XP CHAR) (CASE (CHAR-MODE XP) (:CAP0 (COND ((NOT (ALPHANUMERICP CHAR)) CHAR) (T (SETF (CHAR-MODE XP) :DOWN) (CHAR-UPCASE CHAR)))) (:CAP1 (COND ((NOT (ALPHANUMERICP CHAR)) CHAR) (T (SETF (CHAR-MODE XP) :CAPW) (CHAR-UPCASE CHAR)))) (:CAPW (COND ((ALPHANUMERICP CHAR) (CHAR-DOWNCASE CHAR)) (T (SETF (CHAR-MODE XP) :CAP1) CHAR))) (:UP (CHAR-UPCASE CHAR)) (T (CHAR-DOWNCASE CHAR))))
+
+
+
+(IL:* IL:|;;| 
+":DOWN All characters output are passed through the handler above.  However, it must be noted that on-each-line prefixes are only processed in the context of the first place they appear.  They stay the same later no matter what.  Also non-literal newlines do not count as word breaks. This handles the basic outputting of characters.  note + suffix means that the stream is known to be an XP stream, all inputs are mandatory, and no error checking has to be done.  Suffix ++ additionally means that the output is guaranteed not to contain a newline char."
+)
+
+
+(DEFUN WRITE-CHAR+ (CHAR XP) (IF (EQL CHAR #\Newline) (PPRINT-NEWLINE+ :UNCONDITIONAL XP) (WRITE-CHAR++ CHAR XP)))
+
+(DEFUN WRITE-STRING+ (STRING XP START END) (LET ((SUB-END NIL) NEXT-NEWLINE) (LOOP (SETQ NEXT-NEWLINE (POSITION #\Newline STRING :TEST (FUNCTION CHAR=) :START START :END END)) (SETQ SUB-END (IF NEXT-NEWLINE NEXT-NEWLINE END)) (WRITE-STRING++ STRING XP START SUB-END) (WHEN (NULL NEXT-NEWLINE) (RETURN NIL)) (PPRINT-NEWLINE+ :UNCONDITIONAL XP) (SETQ START (1+ SUB-END)))))
+
+
+
+(IL:* IL:|;;| 
+"note this checks (> BUFFER-PTR LINEL) instead of (> (LP<-BP) LINEL) this is important so that when things are longer than a line they end up getting printed in chunks of size LINEL."
+)
+
+
+(DEFUN WRITE-CHAR++ (CHAR XP) (WHEN (> (BUFFER-PTR XP) (LINEL XP)) (FORCE-SOME-OUTPUT XP)) (LET ((NEW-BUFFER-END (1+ (BUFFER-PTR XP)))) (CHECK-SIZE XP BUFFER NEW-BUFFER-END) (IF (CHAR-MODE XP) (SETQ CHAR (HANDLE-CHAR-MODE XP CHAR))) (SETF (CHAR (BUFFER XP) (BUFFER-PTR XP)) CHAR) (SETF (BUFFER-PTR XP) NEW-BUFFER-END)))
+
+(DEFUN FORCE-SOME-OUTPUT (XP) (ATTEMPT-TO-OUTPUT XP NIL NIL) (WHEN (> (BUFFER-PTR XP) (LINEL XP)) (IL:* IL:\; "only if printing off end of line") (ATTEMPT-TO-OUTPUT XP T T)))
+
+(DEFUN WRITE-STRING++ (STRING XP START END) (WHEN (> (BUFFER-PTR XP) (LINEL XP)) (FORCE-SOME-OUTPUT XP)) (WRITE-STRING+++ STRING XP START END))
+
+
+
+(IL:* IL:|;;| "never forces output; therefore safe to call from within output-line.")
+
+
+(DEFUN WRITE-STRING+++ (STRING XP START END) (LET ((NEW-BUFFER-END (+ (BUFFER-PTR XP) (- END START)))) (CHECK-SIZE XP BUFFER NEW-BUFFER-END) (DO ((BUFFER (BUFFER XP)) (I (BUFFER-PTR XP) (1+ I)) (J START (1+ J))) ((= J END)) (LET ((CHAR (CHAR STRING J))) (IF (CHAR-MODE XP) (SETQ CHAR (HANDLE-CHAR-MODE XP CHAR))) (SETF (CHAR BUFFER I) CHAR))) (SETF (BUFFER-PTR XP) NEW-BUFFER-END)))
+
+(DEFUN PPRINT-TAB+ (KIND COLNUM COLINC XP) (LET ((INDENTED? NIL) (RELATIVE? NIL)) (CASE KIND (:SECTION (SETQ INDENTED? T)) (:LINE-RELATIVE (SETQ RELATIVE? T)) (:SECTION-RELATIVE (SETQ INDENTED? T RELATIVE? T))) (LET* ((CURRENT (IF (NOT INDENTED?) (LP<-BP XP) (- (TP<-BP XP) (SECTION-START XP)))) (NEW (IF (ZEROP COLINC) (IF RELATIVE? (+ CURRENT COLNUM) (MAX COLNUM CURRENT)) (COND (RELATIVE? (* COLINC (FLOOR (+ CURRENT COLNUM COLINC -1) COLINC))) ((> COLNUM CURRENT) COLNUM) (T (+ COLNUM (* COLINC (FLOOR (+ CURRENT (- COLNUM) COLINC) COLINC))))))) (LENGTH (- NEW CURRENT))) (WHEN (PLUSP LENGTH) (IF (CHAR-MODE XP) (HANDLE-CHAR-MODE XP #\Space)) (LET ((END (+ (BUFFER-PTR XP) LENGTH))) (CHECK-SIZE XP BUFFER END) (FILL (BUFFER XP) #\Space :START (BUFFER-PTR XP) :END END) (SETF (BUFFER-PTR XP) END))))))
+
+
+
+(IL:* IL:|;;| 
+"note following is smallest number >= x that is a multiple of colinc  (* colinc (floor (+ x (1- colinc)) colinc))"
+)
+
+
+(DEFUN PPRINT-NEWLINE+ (KIND XP) (ENQUEUE XP :NEWLINE KIND) (DO ((PTR (QLEFT XP) (QNEXT PTR))) (IL:* IL:\; "find sections we are ending") ((NOT (< PTR (QRIGHT XP)))) (IL:* IL:\; "all but last") (WHEN (AND (NULL (QEND XP PTR)) (NOT (> (DEPTH-IN-BLOCKS XP) (QDEPTH XP PTR))) (MEMBER (QTYPE XP PTR) (QUOTE (:NEWLINE :START-BLOCK)))) (SETF (QEND XP PTR) (- (QRIGHT XP) PTR)))) (SETF (SECTION-START XP) (TP<-BP XP)) (WHEN (AND (MEMBER KIND (QUOTE (:FRESH :UNCONDITIONAL))) (CHAR-MODE XP)) (HANDLE-CHAR-MODE XP #\Newline)) (WHEN (MEMBER KIND (QUOTE (:FRESH :UNCONDITIONAL :MANDATORY))) (ATTEMPT-TO-OUTPUT XP T NIL)))
+
+(DEFUN START-BLOCK (XP PREFIX-STRING ON-EACH-LINE? SUFFIX-STRING) (WHEN PREFIX-STRING (WRITE-STRING++ PREFIX-STRING XP 0 (LENGTH PREFIX-STRING))) (IF (AND (CHAR-MODE XP) ON-EACH-LINE?) (SETQ PREFIX-STRING (SUBSEQ (BUFFER XP) (- (BUFFER-PTR XP) (LENGTH PREFIX-STRING)) (BUFFER-PTR XP)))) (PUSH-BLOCK-STACK XP) (ENQUEUE XP :START-BLOCK NIL (IF ON-EACH-LINE? (CONS SUFFIX-STRING PREFIX-STRING) SUFFIX-STRING)) (INCF (DEPTH-IN-BLOCKS XP)) (IL:* IL:\; "must be after enqueue") (SETF (SECTION-START XP) (TP<-BP XP)))
+
+(DEFUN END-BLOCK (XP SUFFIX) (UNLESS (EQ *ABBREVIATION-HAPPENED* (QUOTE *PRINT-LINES*)) (WHEN SUFFIX (WRITE-STRING+ SUFFIX XP 0 (LENGTH SUFFIX))) (DECF (DEPTH-IN-BLOCKS XP)) (ENQUEUE XP :END-BLOCK NIL SUFFIX) (DO ((PTR (QLEFT XP) (QNEXT PTR))) (IL:* IL:\; "looking for start of block we are ending") ((NOT (< PTR (QRIGHT XP)))) (IL:* IL:\; "all but last") (WHEN (AND (= (DEPTH-IN-BLOCKS XP) (QDEPTH XP PTR)) (EQ (QTYPE XP PTR) :START-BLOCK) (NULL (QOFFSET XP PTR))) (SETF (QOFFSET XP PTR) (- (QRIGHT XP) PTR)) (RETURN NIL))) (IL:* IL:\; "can only be 1") (POP-BLOCK-STACK XP)))
+
+(DEFUN PPRINT-INDENT+ (KIND N XP) (ENQUEUE XP :IND KIND N))
+
+
+
+(IL:* IL:|;;| 
+"The next function scans the queue looking for things it can do. it keeps outputting things until the queue is empty, or it finds a place where it cannot make a decision yet."
+)
+
+
+(DEFMACRO MAYBE-TOO-LARGE (XP QENTRY) (IL:BQUOTE (LET ((LIMIT (LINEL (IL:\\\, XP)))) (WHEN (EQL (LINE-LIMIT (IL:\\\, XP)) (LINE-NO (IL:\\\, XP))) (IL:* IL:\; "prevents suffix overflow") (DECF LIMIT 2) (IL:* IL:|;;| "3 for \" ..\" minus 1 for space (heuristic)") (WHEN (NOT (MINUSP (PREFIX-STACK-PTR (IL:\\\, XP)))) (DECF LIMIT (SUFFIX-PTR (IL:\\\, XP))))) (COND ((QEND (IL:\\\, XP) (IL:\\\, QENTRY)) (> (LP<-TP (IL:\\\, XP) (QPOS (IL:\\\, XP) (+ (IL:\\\, QENTRY) (QEND (IL:\\\, XP) (IL:\\\, QENTRY))))) LIMIT)) ((OR FORCE-NEWLINES? (> (LP<-BP (IL:\\\, XP)) LIMIT)) T) (T (RETURN NIL))))))
+
+
+
+(IL:* IL:\; "wait until later to decide.")
+
+
+(DEFMACRO MISERING? (XP) (IL:BQUOTE (AND *PRINT-MISER-WIDTH* (<= (- (LINEL (IL:\\\, XP)) (INITIAL-PREFIX-PTR (IL:\\\, XP))) *PRINT-MISER-WIDTH*))))
+
+
+
+(IL:* IL:|;;| 
+"If flush-out? is T and force-newlines? is NIL then the buffer, prefix-stack, and queue will be in an inconsistent state after the call. You better not call it this way except as the last act of outputting."
+)
+
+
+(DEFUN ATTEMPT-TO-OUTPUT (XP FORCE-NEWLINES? FLUSH-OUT?) (DO NIL ((> (QLEFT XP) (QRIGHT XP)) (SETF (QLEFT XP) 0) (SETF (QRIGHT XP) -7)) (IL:* IL:\; "saves shifting") (CASE (QTYPE XP (QLEFT XP)) (:IND (UNLESS (MISERING? XP) (SET-INDENTATION-PREFIX XP (CASE (QKIND XP (QLEFT XP)) (:BLOCK (+ (INITIAL-PREFIX-PTR XP) (QARG XP (QLEFT XP)))) (T (IL:* IL:\; ":current") (+ (LP<-TP XP (QPOS XP (QLEFT XP))) (QARG XP (QLEFT XP))))))) (SETF (QLEFT XP) (QNEXT (QLEFT XP)))) (:START-BLOCK (COND ((MAYBE-TOO-LARGE XP (QLEFT XP)) (PUSH-PREFIX-STACK XP) (SETF (INITIAL-PREFIX-PTR XP) (PREFIX-PTR XP)) (SET-INDENTATION-PREFIX XP (LP<-TP XP (QPOS XP (QLEFT XP)))) (LET ((ARG (QARG XP (QLEFT XP)))) (WHEN (CONSP ARG) (SET-PREFIX XP (CDR ARG))) (SETF (INITIAL-PREFIX-PTR XP) (PREFIX-PTR XP)) (COND ((NOT (LISTP ARG)) (SET-SUFFIX XP ARG)) ((CAR ARG) (SET-SUFFIX XP (CAR ARG))))) (SETF (SECTION-START-LINE XP) (LINE-NO XP))) (T (INCF (QLEFT XP) (QOFFSET XP (QLEFT XP))))) (SETF (QLEFT XP) (QNEXT (QLEFT XP)))) (:END-BLOCK (POP-PREFIX-STACK XP) (SETF (QLEFT XP) (QNEXT (QLEFT XP)))) (T (IL:* IL:\; ":newline") (WHEN (CASE (QKIND XP (QLEFT XP)) (:FRESH (NOT (ZEROP (LP<-BP XP)))) (:MISER (MISERING? XP)) (:FILL (OR (MISERING? XP) (> (LINE-NO XP) (SECTION-START-LINE XP)) (MAYBE-TOO-LARGE XP (QLEFT XP)))) (T T)) (IL:* IL:\; "(:linear :unconditional :mandatory) ") (OUTPUT-LINE XP (QLEFT XP)) (SETUP-FOR-NEXT-LINE XP (QLEFT XP))) (SETF (QLEFT XP) (QNEXT (QLEFT XP)))))) (WHEN FLUSH-OUT? (FLUSH XP)))
+
+
+
+(IL:* IL:\; "this can only be called last!")
+
+
+(DEFUN FLUSH (XP) (UNLESS *LOCATING-CIRCULARITIES* (CL:WRITE-STRING (BUFFER XP) (BASE-STREAM XP) :END (BUFFER-PTR XP))) (INCF (BUFFER-OFFSET XP) (BUFFER-PTR XP)) (INCF (CHARPOS XP) (BUFFER-PTR XP)) (SETF (BUFFER-PTR XP) 0))
+
+
+
+(IL:* IL:\; "This prints out a line of stuff.")
+
+
+(DEFUN OUTPUT-LINE (XP QENTRY) (LET* ((OUT-POINT (BP<-TP XP (QPOS XP QENTRY))) (LAST-NON-BLANK (POSITION #\Space (BUFFER XP) :TEST-NOT (FUNCTION CHAR=) :FROM-END T :END OUT-POINT)) (END (COND ((MEMBER (QKIND XP QENTRY) (QUOTE (:FRESH :UNCONDITIONAL))) OUT-POINT) (LAST-NON-BLANK (1+ LAST-NON-BLANK)) (T 0))) (LINE-LIMIT-EXIT (AND (LINE-LIMIT XP) (NOT (> (LINE-LIMIT XP) (LINE-NO XP)))))) (WHEN LINE-LIMIT-EXIT (SETF (BUFFER-PTR XP) END) (IL:* IL:\; "truncate pending output.") (WRITE-STRING+++ " .." XP 0 3) (REVERSE-STRING-IN-PLACE (SUFFIX XP) 0 (SUFFIX-PTR XP)) (WRITE-STRING+++ (SUFFIX XP) XP 0 (SUFFIX-PTR XP)) (SETF (QLEFT XP) (QNEXT (QRIGHT XP))) (SETQ *ABBREVIATION-HAPPENED* (QUOTE *PRINT-LINES*)) (THROW (QUOTE LINE-LIMIT-ABBREVIATION-EXIT) T)) (INCF (LINE-NO XP)) (UNLESS *LOCATING-CIRCULARITIES* (IL:* IL:|;;| "(CL:WRITE-LINE (BUFFER XP) (BASE-STREAM XP) :END END)") (IL:* IL:|;;| "The code below is equivalent assuming (BASE-STREAM XP) is not an XP-stream (I believe we can be sure this is the case)") (IL:WRITE-STRING* (BUFFER XP) (BASE-STREAM XP) 0 END) (IL:TERPRI (BASE-STREAM XP)))))
+
+(DEFUN SETUP-FOR-NEXT-LINE (XP QENTRY) (LET* ((OUT-POINT (BP<-TP XP (QPOS XP QENTRY))) (PREFIX-END (COND ((MEMBER (QKIND XP QENTRY) (QUOTE (:UNCONDITIONAL :FRESH))) (NON-BLANK-PREFIX-PTR XP)) (T (PREFIX-PTR XP)))) (CHANGE (- PREFIX-END OUT-POINT))) (SETF (CHARPOS XP) 0) (IL:* IL:|;;| "(REPLACE (BUFFER XP) (BUFFER XP) :START1 PREFIX-END :START2 OUT-POINT :END2 (BUFFER-PTR XP))") (IL:* IL:|;;| "Equivalent code below; we could sure stand mega-optimizers on stuff like this...") (IF (PLUSP CHANGE) (PROGN (IL:* IL:\; "almost never happens") (CHECK-SIZE XP BUFFER (+ (BUFFER-PTR XP) CHANGE)) (REPLACE (BUFFER XP) (BUFFER XP) :START1 PREFIX-END :START2 OUT-POINT :END2 (BUFFER-PTR XP))) (DO ((S1 PREFIX-END (INCF S1)) (S2 OUT-POINT (INCF S2)) (E2 (BUFFER-PTR XP)) (B (BUFFER XP))) ((IL:IGEQ S2 E2)) (SETF (CHAR B S1) (CHAR B S2)))) (IL:* IL:|;;| "(REPLACE (BUFFER XP) (PREFIX XP) :END2 PREFIX-END)") (IL:* IL:|;;| "Equivalent code below; we could sure stand mega-optimizers on stuff like this...") (DO ((S1 0 (INCF S1)) (E2 PREFIX-END) (B (BUFFER XP)) (P (PREFIX XP))) ((IL:IGEQ S1 E2)) (SETF (CHAR B S1) (CHAR P S1))) (INCF (BUFFER-PTR XP) CHANGE) (DECF (BUFFER-OFFSET XP) CHANGE) (WHEN (NOT (MEMBER (QKIND XP QENTRY) (QUOTE (:UNCONDITIONAL :FRESH)))) (SETF (SECTION-START-LINE XP) (LINE-NO XP)))))
+
+(DEFUN SET-INDENTATION-PREFIX (XP NEW-POSITION) (LET ((NEW-IND (MAX (NON-BLANK-PREFIX-PTR XP) NEW-POSITION))) (SETF (PREFIX-PTR XP) (INITIAL-PREFIX-PTR XP)) (CHECK-SIZE XP PREFIX NEW-IND) (WHEN (> NEW-IND (PREFIX-PTR XP)) (FILL (PREFIX XP) #\Space :START (PREFIX-PTR XP) :END NEW-IND)) (SETF (PREFIX-PTR XP) NEW-IND)))
+
+(DEFUN SET-PREFIX (XP PREFIX-STRING) (REPLACE (PREFIX XP) PREFIX-STRING :START1 (- (PREFIX-PTR XP) (LENGTH PREFIX-STRING))) (SETF (NON-BLANK-PREFIX-PTR XP) (PREFIX-PTR XP)))
+
+(DEFUN SET-SUFFIX (XP SUFFIX-STRING) (LET* ((END (LENGTH SUFFIX-STRING)) (NEW-END (+ (SUFFIX-PTR XP) END))) (CHECK-SIZE XP SUFFIX NEW-END) (DO ((I (1- NEW-END) (1- I)) (J 0 (1+ J))) ((= J END)) (SETF (CHAR (SUFFIX XP) I) (CHAR SUFFIX-STRING J))) (SETF (SUFFIX-PTR XP) NEW-END)))
+
+(DEFUN REVERSE-STRING-IN-PLACE (STRING START END) (DO ((I START (1+ I)) (J (1- END) (1- J))) ((NOT (< I J)) STRING) (LET ((C (CHAR STRING I))) (SETF (CHAR STRING I) (CHAR STRING J)) (SETF (CHAR STRING J) C))))
+
+
+
+(IL:* IL:|;;| 
+"		   ---- BASIC INTERFACE FUNCTIONS ---- The internal functions in this file, and the (formatter \"...\") expansions use the '+' forms of these functions directly (which is faster) because, they do not need error checking of fancy stream coercion.  The '++' forms additionally assume the thing being output does not contain a newline."
+)
+
+
+(DEFUN WRITE (OBJECT &REST PAIRS &KEY (STREAM *STANDARD-OUTPUT*) (ESCAPE *PRINT-ESCAPE*) (RADIX *PRINT-RADIX*) (BASE *PRINT-BASE*) (CIRCLE *PRINT-CIRCLE*) (PRETTY *PRINT-PRETTY*) (LEVEL *PRINT-LEVEL*) (LENGTH *PRINT-LENGTH*) (CASE *PRINT-CASE*) (GENSYM *PRINT-GENSYM*) (ARRAY *PRINT-ARRAY*) (PPRINT-DISPATCH *PRINT-PPRINT-DISPATCH*) (RIGHT-MARGIN *PRINT-RIGHT-MARGIN*) (LINES *PRINT-LINES*) (MISER-WIDTH *PRINT-MISER-WIDTH*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (LET ((*PRINT-PPRINT-DISPATCH* PPRINT-DISPATCH) (*PRINT-RIGHT-MARGIN* RIGHT-MARGIN) (*PRINT-LINES* LINES) (*PRINT-MISER-WIDTH* MISER-WIDTH)) (COND ((OR (XP-STRUCTURE-P STREAM) PRETTY) (LET ((*PRINT-ESCAPE* ESCAPE) (*PRINT-RADIX* RADIX) (*PRINT-BASE* BASE) (*PRINT-CIRCLE* CIRCLE) (*PRINT-PRETTY* PRETTY) (*PRINT-LEVEL* LEVEL) (*PRINT-LENGTH* LENGTH) (*PRINT-CASE* CASE) (*PRINT-GENSYM* GENSYM) (*PRINT-ARRAY* ARRAY)) (BASIC-WRITE OBJECT STREAM))) (T (REMF PAIRS :DISPATCH) (REMF PAIRS :RIGHT-MARGIN) (REMF PAIRS :LINES) (REMF PAIRS :MISER-WIDTH) (APPLY (FUNCTION CL:WRITE) OBJECT PAIRS)))) OBJECT)
+
+(DEFUN BASIC-WRITE (OBJECT STREAM) (COND ((XP-STRUCTURE-P STREAM) (WRITE+ OBJECT STREAM)) (*PRINT-PRETTY* (MAYBE-INITIATE-XP-PRINTING (FUNCTION (LAMBDA (S O) (WRITE+ O S))) STREAM OBJECT)) (T (CL:WRITE OBJECT :STREAM STREAM))))
+
+(DEFUN MAYBE-INITIATE-XP-PRINTING (FN STREAM &REST ARGS) (IL:* IL:\; "Edited 10-Jul-92 11:51 by jrb:") (IF (XP-STRUCTURE-P STREAM) (APPLY FN STREAM ARGS) (LET ((*ABBREVIATION-HAPPENED* NIL) (*LOCATING-CIRCULARITIES* (IF *PRINT-CIRCLE* 0 NIL)) (*CIRCULARITY-HASH-TABLE* (IF *PRINT-CIRCLE* (GET-CIRCULARITY-HASH-TABLE) NIL)) (*PARENTS* (WHEN (NOT *PRINT-SHARED*) (LIST NIL))) (*RESULT* NIL) (IL:\\THISFILELINELENGTH)) (DECLARE (SPECIAL IL:\\THISFILELINELENGTH)) (IL:* IL:|;;| "Common Lisp streams do not observe line length") (XP-PRINT FN (DECODE-STREAM-ARG STREAM) ARGS) (IF *CIRCULARITY-HASH-TABLE* (FREE-CIRCULARITY-HASH-TABLE *CIRCULARITY-HASH-TABLE*)) (WHEN *ABBREVIATION-HAPPENED* (SETQ *LAST-ABBREVIATED-PRINTING* (EVAL (IL:BQUOTE (FUNCTION (LAMBDA (&OPTIONAL (STREAM (QUOTE (IL:\\\, STREAM)))) (LET ((*PACKAGE* (QUOTE (IL:\\\, *PACKAGE*)))) (APPLY (FUNCTION MAYBE-INITIATE-XP-PRINTING) (QUOTE (IL:\\\, FN)) STREAM (QUOTE (IL:\\\, (COPY-LIST ARGS))))))))))) *RESULT*)))
+
+(DEFUN XP-PRINT (FN STREAM ARGS) (SETQ *RESULT* (DO-XP-PRINTING FN STREAM ARGS)) (WHEN *LOCATING-CIRCULARITIES* (SETQ *LOCATING-CIRCULARITIES* NIL) (SETQ *ABBREVIATION-HAPPENED* NIL) (SETQ *PARENTS* NIL) (SETQ *RESULT* (DO-XP-PRINTING FN STREAM ARGS))))
+
+(DEFUN DECODE-STREAM-ARG (STREAM) (COND ((NULL STREAM) *STANDARD-OUTPUT*) ((EQ STREAM T) *TERMINAL-IO*) (T STREAM)))
+
+(DEFUN DO-XP-PRINTING (FN STREAM ARGS) (LET ((XP (GET-PRETTY-PRINT-STREAM STREAM)) (*CURRENT-LEVEL* 0) (RESULT NIL)) (CATCH (QUOTE LINE-LIMIT-ABBREVIATION-EXIT) (START-BLOCK XP NIL NIL NIL) (SETQ RESULT (APPLY FN XP ARGS)) (END-BLOCK XP NIL)) (WHEN (AND *LOCATING-CIRCULARITIES* (ZEROP *LOCATING-CIRCULARITIES*) (IL:* IL:\; "No circularities.") (= (LINE-NO XP) 1) (IL:* IL:\; "Didn't suppress line.") (ZEROP (BUFFER-OFFSET XP))) (IL:* IL:\; "Didn't suppress partial line.") (SETQ *LOCATING-CIRCULARITIES* NIL)) (IL:* IL:\; "print what you have got.") (WHEN (CATCH (QUOTE LINE-LIMIT-ABBREVIATION-EXIT) (ATTEMPT-TO-OUTPUT XP NIL T) NIL) (ATTEMPT-TO-OUTPUT XP T T)) (FREE-PRETTY-PRINT-STREAM XP) RESULT))
+
+(DEFUN WRITE+ (OBJECT XP) (IL:* IL:\; "Edited  7-Jan-92 14:31 by jrb:") (LET ((*PARENTS* *PARENTS*)) (UNLESS (AND *CIRCULARITY-HASH-TABLE* (EQ (CIRCULARITY-PROCESS XP OBJECT NIL) :SUBSEQUENT)) (WHEN (AND *CIRCULARITY-HASH-TABLE* (CONSP OBJECT)) (IL:* IL:|;;| "avoid possible double check in handle-logical-block.") (SETQ OBJECT (CONS (CAR OBJECT) (CDR OBJECT)))) (LET ((PRINTER (IF *PRINT-PRETTY* (GET-PRINTER OBJECT *PRINT-PPRINT-DISPATCH*) NIL)) TYPE) (COND (PRINTER (FUNCALL PRINTER XP OBJECT)) ((MAYBE-PRINT-FAST XP OBJECT)) ((AND *PRINT-PRETTY* (SYMBOLP (SETQ TYPE (TYPE-OF OBJECT))) (SETQ PRINTER (GET TYPE (QUOTE CL::STRUCTURE-PRINTER))) (NOT (EQ PRINTER :NONE))) (FUNCALL PRINTER XP OBJECT)) ((AND *PRINT-PRETTY* *PRINT-ARRAY* (ARRAYP OBJECT) (NOT (STRINGP OBJECT)) (NOT (BIT-VECTOR-P OBJECT)) (NOT (STRUCTURE-TYPE-P (TYPE-OF OBJECT)))) (PRETTY-ARRAY XP OBJECT)) (T (IL:* IL:|;;| "OK, we're going to do it the new, strange way; just print it to XP, which SHOULD, through the magic of stream functions, hose the characters into the XP buffer") (NON-PRETTY-PRINT OBJECT XP)))))))
+
+(DEFUN NON-PRETTY-PRINT (OBJECT S) (IL:* IL:|;;| "(CL:WRITE OBJECT :LEVEL (IF *PRINT-LEVEL* (- *PRINT-LEVEL* *CURRENT-LEVEL*)) :PRETTY NIL :STREAM S)") (LET (*PRINT-PRETTY* (*PRINT-LEVEL* (IF *PRINT-LEVEL* (- *PRINT-LEVEL* *CURRENT-LEVEL*)))) (IL:\\WRITE1 OBJECT S)))
+
+
+
+(IL:* IL:|;;| 
+"It is vital that this function be called EXACTLY once for each occurrence of   each thing in something being printed. Returns nil if printing should just continue on.  Either it is not a duplicate, or we are in the first pass and do not know. returns :FIRST if object is first occurrence of a DUPLICATE.  (This can only be returned on a second pass.)  After an initial code (printed by this routine on the second pass)  printing should continue on for the object. returns :SUBSEQUENT if second or later occurrence.  Printing is all taken care of by this routine. Note many (maybe most) lisp implementations have characters and small numbers represented in a single word so that the are always eq when they are equal and the reader takes care of properly sharing them (just as it does with symbols). Therefore, we do not want circularity processing applied to them.  However, some kinds of numbers (e.g., bignums) undoubtedly are complex structures that the reader does not share.  However, they cannot have circular pointers in them and it is therefore probably a waste to do circularity checking on them.  In any case, it is not clear that it easy to tell exactly what kinds of numbers a given implementation of CL is going to have the reader automatically share."
+)
+
+
+(DEFUN CIRCULARITY-PROCESS (XP OBJECT INTERIOR-CDR?) (UNLESS (OR (NUMBERP OBJECT) (CHARACTERP OBJECT) (AND (SYMBOLP OBJECT) (IL:* IL:\; "Reader takes care of sharing.") (OR (NULL *PRINT-GENSYM*) (SYMBOL-PACKAGE OBJECT)))) (LET ((ID (GETHASH OBJECT *CIRCULARITY-HASH-TABLE*))) (IF *LOCATING-CIRCULARITIES* (COND ((NULL ID) (IL:* IL:\; "never seen before") (WHEN *PARENTS* (PUSH OBJECT *PARENTS*)) (SETF (GETHASH OBJECT *CIRCULARITY-HASH-TABLE*) 0) NIL) ((ZEROP ID) (IL:* IL:\; "possible second occurrence") (COND ((OR (NULL *PARENTS*) (MEMBER OBJECT *PARENTS*)) (SETF (GETHASH OBJECT *CIRCULARITY-HASH-TABLE*) (INCF *LOCATING-CIRCULARITIES*)) :SUBSEQUENT) (T NIL))) (T :SUBSEQUENT)) (IL:* IL:\; "third or later occurrence") (COND ((OR (NULL ID) (IL:* IL:\; "never seen before (note ~@* etc. conses)") (ZEROP ID)) (IL:* IL:\; "no duplicates") NIL) ((PLUSP ID) (COND (INTERIOR-CDR? (DECF *CURRENT-LEVEL*) (WRITE-STRING++ ". #" XP 0 3)) (T (WRITE-CHAR++ #\# XP))) (PRINT-FIXNUM XP ID) (WRITE-CHAR++ #\= XP) (SETF (GETHASH OBJECT *CIRCULARITY-HASH-TABLE*) (- ID)) :FIRST) (T (IF INTERIOR-CDR? (WRITE-STRING++ ". #" XP 0 3) (WRITE-CHAR++ #\# XP)) (PRINT-FIXNUM XP (- ID)) (WRITE-CHAR++ #\# XP) :SUBSEQUENT))))))
+
+
+
+(IL:* IL:|;;| 
+"This prints a few very common, simple atoms very fast. Pragmatically, this turns out to be an enormous savings over going to the standard printer all the time.  There would be diminishing returns from making this work with more things, but might be worth it."
+)
+
+
+(DEFUN MAYBE-PRINT-FAST (XP OBJECT) (COND ((SYMBOLP OBJECT) (IL:* IL:|;;| "The \"fast case\" for us is to print the atom to XP; our atom printer is tuned at a lower-than CLtL level so it should be fast enough.  Besides, it observes READTABLE-CASE, which the portable code does not; it could be made to, but why bother?") (NON-PRETTY-PRINT OBJECT XP) T) ((STRINGP OBJECT) (COND ((NULL *PRINT-ESCAPE*) (WRITE-STRING+ OBJECT XP 0 (LENGTH OBJECT)) T) ((EVERY (FUNCTION (LAMBDA (C) (NOT (OR (CHAR= C #\") (CHAR= C #\\))))) OBJECT) (WRITE-CHAR++ #\" XP) (WRITE-STRING+ OBJECT XP 0 (LENGTH OBJECT)) (WRITE-CHAR++ #\" XP) T))) ((TYPEP OBJECT (QUOTE FIXNUM)) (WHEN (AND (NULL *PRINT-RADIX*) (= *PRINT-BASE* 10)) (WHEN (MINUSP OBJECT) (WRITE-CHAR++ #\- XP) (SETQ OBJECT (- OBJECT))) (PRINT-FIXNUM XP OBJECT) T))))
+
+(DEFUN PRINT-FIXNUM (XP FIXNUM) (MULTIPLE-VALUE-BIND (DIGITS D) (TRUNCATE FIXNUM 10) (UNLESS (ZEROP DIGITS) (PRINT-FIXNUM XP DIGITS)) (WRITE-CHAR++ (CODE-CHAR (+ 48 D)) XP)))
+
+
+
+(IL:* IL:|;;| 
+"just wants to succeed fast in a lot of common cases. assumes no funny readtable junk for the characters shown."
+)
+
+
+(DEFUN NO-ESCAPES-NEEDED (S) (LET ((N (LENGTH S))) (AND (NOT (ZEROP N)) (LET ((C (SCHAR S 0))) (OR (AND (ALPHA-CHAR-P C) (UPPER-CASE-P C)) (FIND C "*<>"))) (DO ((I 1 (1+ I))) ((= I N) T) (LET ((C (SCHAR S I))) (IF (NOT (OR (DIGIT-CHAR-P C) (AND (ALPHA-CHAR-P C) (UPPER-CASE-P C)) (FIND C "*+<>-"))) (RETURN NIL)))))))
+
+(DEFUN PRINT (OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (TERPRI STREAM) (LET ((*PRINT-ESCAPE* T)) (BASIC-WRITE OBJECT STREAM)) (WRITE-CHAR #\Space STREAM) OBJECT)
+
+(DEFUN PRIN1 (OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (LET ((*PRINT-ESCAPE* T)) (BASIC-WRITE OBJECT STREAM)) OBJECT)
+
+(DEFUN PRINC (OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (LET ((*PRINT-ESCAPE* NIL)) (BASIC-WRITE OBJECT STREAM)) OBJECT)
+
+(DEFUN PPRINT (OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (TERPRI STREAM) (LET ((*PRINT-ESCAPE* T) (*PRINT-PRETTY* T)) (BASIC-WRITE OBJECT STREAM)) (VALUES))
+
+(DEFUN WRITE-TO-STRING (OBJECT &REST PAIRS &KEY &ALLOW-OTHER-KEYS) (WITH-OUTPUT-TO-STRING (S) (APPLY (FUNCTION WRITE) OBJECT :STREAM S PAIRS)))
+
+(DEFUN PRINC-TO-STRING (OBJECT) (WITH-OUTPUT-TO-STRING (STREAM) (LET ((*PRINT-ESCAPE* NIL)) (BASIC-WRITE OBJECT STREAM))))
+
+(DEFUN PRIN1-TO-STRING (OBJECT) (WITH-OUTPUT-TO-STRING (STREAM) (LET ((*PRINT-ESCAPE* T)) (BASIC-WRITE OBJECT STREAM))))
+
+
+
+(IL:* IL:|;;| 
+"Any format string that is converted to a function is always printed via an XP stream (See formatter)."
+)
+
+
+(DEFUN FORMAT (STREAM STRING-OR-FN &REST ARGS) (COND ((STRINGP STREAM) (CL:FORMAT STREAM "~A" (WITH-OUTPUT-TO-STRING (STREAM) (APPLY (FUNCTION FORMAT) STREAM STRING-OR-FN ARGS))) NIL) ((NULL STREAM) (WITH-OUTPUT-TO-STRING (STREAM) (APPLY (FUNCTION FORMAT) STREAM STRING-OR-FN ARGS))) (T (IF (EQ STREAM T) (SETQ STREAM *STANDARD-OUTPUT*)) (WHEN (STRINGP STRING-OR-FN) (SETQ STRING-OR-FN (PROCESS-FORMAT-STRING STRING-OR-FN NIL))) (COND ((NOT (STRINGP STRING-OR-FN)) (APPLY STRING-OR-FN STREAM ARGS)) ((XP-STRUCTURE-P STREAM) (APPLY (FUNCTION USING-FORMAT) STREAM STRING-OR-FN ARGS)) (T (APPLY (FUNCTION CL:FORMAT) STREAM STRING-OR-FN ARGS))) NIL)))
+
+(DEFVAR *FORMAT-STRING-CACHE* T)
+
+(DEFUN PROCESS-FORMAT-STRING (STRING-OR-FN FORCE-FN?) (COND ((NOT (STRINGP STRING-OR-FN)) STRING-OR-FN) (IL:* IL:\; "called from ~? too.") ((NOT *FORMAT-STRING-CACHE*) (MAYBE-COMPILE-FORMAT-STRING STRING-OR-FN FORCE-FN?)) (T (WHEN (NOT (HASH-TABLE-P *FORMAT-STRING-CACHE*)) (SETQ *FORMAT-STRING-CACHE* (MAKE-HASH-TABLE :TEST (FUNCTION EQ)))) (LET ((VALUE (GETHASH STRING-OR-FN *FORMAT-STRING-CACHE*))) (WHEN (OR (NOT VALUE) (AND FORCE-FN? (STRINGP VALUE))) (SETQ VALUE (MAYBE-COMPILE-FORMAT-STRING STRING-OR-FN FORCE-FN?)) (SETF (GETHASH STRING-OR-FN *FORMAT-STRING-CACHE*) VALUE)) VALUE))))
+
+(DEFUN WRITE-LINE (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*) &KEY (START 0) (END (LENGTH STRING))) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (IF (XP-STRUCTURE-P STREAM) (PROGN (WRITE-STRING+ STRING STREAM START END) (PPRINT-NEWLINE+ :UNCONDITIONAL STREAM)) (CL:WRITE-LINE STRING STREAM :START START :END END)) STRING)
+
+(DEFUN WRITE-STRING (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*) &KEY (START 0) (END (LENGTH STRING))) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (IF (XP-STRUCTURE-P STREAM) (WRITE-STRING+ STRING STREAM START END) (CL:WRITE-STRING STRING STREAM :START START :END END)) STRING)
+
+(DEFUN WRITE-CHAR (CHAR &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (IF (XP-STRUCTURE-P STREAM) (WRITE-CHAR+ CHAR STREAM) (CL:WRITE-CHAR CHAR STREAM)) CHAR)
+
+(DEFUN TERPRI (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (IF (XP-STRUCTURE-P STREAM) (PPRINT-NEWLINE+ :UNCONDITIONAL STREAM) (CL:TERPRI STREAM)) NIL)
+
+
+
+(IL:* IL:|;;| 
+"This has to violate the XP data abstraction and fool with internal stuff, in order to find out the right info to return as the result."
+)
+
+
+(DEFUN FRESH-LINE (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (COND ((XP-STRUCTURE-P STREAM) (ATTEMPT-TO-OUTPUT STREAM T T) (IL:* IL:\; "ok because we want newline") (WHEN (NOT (ZEROP (LP<-BP STREAM))) (PPRINT-NEWLINE+ :FRESH STREAM) T)) (T (CL:FRESH-LINE STREAM))))
+
+
+
+(IL:* IL:|;;| 
+"Each of these causes the stream to be pessimistic and insert newlines wherever it might have to, when forcing the partial output out.  This is so that things will be in a consistent state if output continues to the stream later."
+)
+
+
+(DEFUN FINISH-OUTPUT (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (IF (XP-STRUCTURE-P STREAM) (ATTEMPT-TO-OUTPUT STREAM T T) (CL:FINISH-OUTPUT STREAM)) NIL)
+
+(DEFUN FORCE-OUTPUT (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (IF (XP-STRUCTURE-P STREAM) (ATTEMPT-TO-OUTPUT STREAM T T) (CL:FORCE-OUTPUT STREAM)) NIL)
+
+(DEFUN CLEAR-OUTPUT (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (IF (XP-STRUCTURE-P STREAM) (LET ((*LOCATING-CIRCULARITIES* 0)) (IL:* IL:\; "hack to prevent visible output") (ATTEMPT-TO-OUTPUT STREAM T T)) (CL:CLEAR-OUTPUT STREAM)) NIL)
+
+
+
+(IL:* IL:|;;| 
+"note we are assuming that if a structure is defined using xp::defstruct, then its print-function (if any) will be defined using xp::print etc."
+)
+
+
+(DEFMACRO DEFSTRUCT (NAME &BODY BODY) (LET* ((STRUCT-NAME (IF (CONSP NAME) (CAR NAME) NAME)) (PRINTER (CADR (SAFE-ASSOC :PRINT-FUNCTION NAME))) (XP-PRINT-FN (INTERN (CONCATENATE (QUOTE STRING) "PRINT-" (STRING (PACKAGE-NAME (SYMBOL-PACKAGE STRUCT-NAME))) ":" (STRING STRUCT-NAME)) (FIND-PACKAGE "XP")))) (COND (PRINTER (IL:BQUOTE (EVAL-WHEN (EVAL LOAD COMPILE) (CL:DEFSTRUCT (IL:\\\, NAME) (IL:\\\,@ BODY)) (DEFUN (IL:\\\, XP-PRINT-FN) (XP OBJ) (FUNCALL (FUNCTION (IL:\\\, PRINTER)) OBJ XP *CURRENT-LEVEL*)) (SETF (GET (QUOTE (IL:\\\, STRUCT-NAME)) (QUOTE CL::STRUCTURE-PRINTER)) (FUNCTION (IL:\\\, XP-PRINT-FN))) (QUOTE (IL:\\\, (IF (CONSP NAME) (CAR NAME) NAME)))))) ((AND (NOT (SAFE-ASSOC :TYPE NAME)) (NOT (SAFE-ASSOC :INCLUDE NAME))) (LET* ((CONC-NAME-SPEC (SAFE-ASSOC :CONC-NAME NAME)) (CONC-NAME (COND ((NULL CONC-NAME-SPEC) (CONCATENATE (QUOTE STRING) (STRING STRUCT-NAME) "-")) ((NULL (CADR CONC-NAME-SPEC)) "") (T (STRING (CADR CONC-NAME-SPEC))))) (SLOTS (MAPCAR (FUNCTION (LAMBDA (X) (IF (CONSP X) (CAR X) X))) BODY))) (IL:BQUOTE (EVAL-WHEN (EVAL LOAD COMPILE) (CL:DEFSTRUCT (IL:\\\, NAME) (IL:\\\,@ BODY)) (DEFUN (IL:\\\, XP-PRINT-FN) (XP OBJ) (FUNCALL (FORMATTER "~@<#S(~;~W ~:I~@_~@{:~A ~W~^ ~:_~}~;)~:>") XP (QUOTE (IL:\\\, STRUCT-NAME)) (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (SLOT) (IL:BQUOTE ((IL:\\\, (STRING SLOT)) ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) CONC-NAME (STRING SLOT)))) OBJ))))) SLOTS)))) (SETF (GET (QUOTE (IL:\\\, STRUCT-NAME)) (QUOTE CL::STRUCTURE-PRINTER)) (FUNCTION (IL:\\\, XP-PRINT-FN))) (QUOTE (IL:\\\, (IF (CONSP NAME) (CAR NAME) NAME))))))) (T (IL:BQUOTE (EVAL-WHEN (EVAL LOAD COMPILE) (SETF (GET (QUOTE (IL:\\\, STRUCT-NAME)) (QUOTE CL::STRUCTURE-PRINTER)) :NONE) (CL:DEFSTRUCT (IL:\\\, NAME) (IL:\\\,@ BODY))))))))
+
+(DEFUN SAFE-ASSOC (ITEM LIST) (DO ((L LIST (CDR L))) ((NOT (CONSP L)) NIL) (IF (AND (CONSP (CAR L)) (EQ (CAAR L) ITEM)) (RETURN (CAR L)))))
+
+
+
+(IL:* IL:|;;| 
+"A few helper functions.  Calls to these are generated by SET-XP-PRINTER, which handles default pretty-printing of structures"
+)
+
+
+(DEFUN CL::STRUCTURE-WITH-USER-PRINTER (CL::XP CL::OBJ) (IL:* IL:\; "Edited  7-Jan-92 14:27 by jrb:") (FUNCALL (LISP::PS-PRINT-FUNCTION (LISP::PARSED-STRUCTURE (TYPE-OF CL::OBJ))) CL::OBJ CL::XP *CURRENT-LEVEL*))
+
+(DEFUN CL::STRUCTURE-WITH-DEFAULT-PRINTER (&REST CL::STUFF-TO-PRINT) (IL:* IL:\; "Edited  7-Jan-92 14:27 by jrb:") (APPLY (FORMATTER "~@<#S(~;~W ~:I~@_~@{:~A ~W~^ ~:_~}~;)~:>") CL::STUFF-TO-PRINT))
+
+
+
+(IL:* IL:|;;| 
+"          ---- FUNCTIONAL INTERFACE TO DYNAMIC FORMATTING ---- The internal functions in this file, and the (formatter \"...\") expansions use the '+' forms of these functions directly (which is faster) because, they do not need error checking or fancy stream coercion.  The '++' forms additionally assume the thing being output does not contain a newline."
+)
+
+
+(DEFMACRO PPRINT-LOGICAL-BLOCK ((STREAM-SYMBOL LIST &KEY (PREFIX NIL) (PER-LINE-PREFIX NIL) (SUFFIX "")) &BODY BODY) (COND ((EQ STREAM-SYMBOL NIL) (SETQ STREAM-SYMBOL (QUOTE *STANDARD-OUTPUT*))) ((EQ STREAM-SYMBOL T) (SETQ STREAM-SYMBOL (QUOTE *TERMINAL-IO*)))) (WHEN (NOT (SYMBOLP STREAM-SYMBOL)) (WARN "STREAM-SYMBOL arg ~S to PPRINT-LOGICAL-BLOCK is not a bindable symbol" STREAM-SYMBOL) (SETQ STREAM-SYMBOL (QUOTE *STANDARD-OUTPUT*))) (WHEN (AND PREFIX PER-LINE-PREFIX) (WARN "prefix ~S and per-line-prefix ~S cannot both be specified in PPRINT-LOGICAL-BLOCK" PREFIX PER-LINE-PREFIX) (SETQ PER-LINE-PREFIX NIL)) (IL:BQUOTE (MAYBE-INITIATE-XP-PRINTING (FUNCTION (LAMBDA ((IL:\\\, STREAM-SYMBOL)) (LET ((+L (IL:\\\, LIST)) (+P (IL:\\\, (OR PREFIX PER-LINE-PREFIX ""))) (+S (IL:\\\, SUFFIX))) (PPRINT-LOGICAL-BLOCK+ ((IL:\\\, STREAM-SYMBOL) +L +P +S (IL:\\\, (NOT (NULL PER-LINE-PREFIX))) T NIL) (IL:\\\,@ BODY) NIL)))) (DECODE-STREAM-ARG (IL:\\\, STREAM-SYMBOL)))))
+
+
+
+(IL:* IL:|;;| 
+"Assumes var and args must be variables.  Other arguments must be literals or variables.")
+
+
+(DEFMACRO PPRINT-LOGICAL-BLOCK+ ((VAR ARGS PREFIX SUFFIX PER-LINE? CIRCLE-CHECK? ATSIGN?) &BODY BODY) (WHEN (AND CIRCLE-CHECK? ATSIGN?) (SETQ CIRCLE-CHECK? (QUOTE NOT-FIRST-P))) (IL:BQUOTE (LET ((*CURRENT-LEVEL* (1+ *CURRENT-LEVEL*)) (*CURRENT-LENGTH* -1) (*PARENTS* *PARENTS*) (IL:\\\,@ (IF (AND CIRCLE-CHECK? ATSIGN?) (IL:BQUOTE ((NOT-FIRST-P (PLUSP *CURRENT-LENGTH*))))))) (UNLESS (CHECK-BLOCK-ABBREVIATION (IL:\\\, VAR) (IL:\\\, ARGS) (IL:\\\, CIRCLE-CHECK?)) (BLOCK LOGICAL-BLOCK (START-BLOCK (IL:\\\, VAR) (IL:\\\, PREFIX) (IL:\\\, PER-LINE?) (IL:\\\, SUFFIX)) (UNWIND-PROTECT (MACROLET ((PPRINT-POP NIL (IL:BQUOTE (PPRINT-POP+ (IL:\\\, (QUOTE (IL:\\\, ARGS))) (IL:\\\, (QUOTE (IL:\\\, VAR)))))) (PPRINT-EXIT-IF-LIST-EXHAUSTED NIL (IL:BQUOTE (IF (NULL (IL:\\\, (QUOTE (IL:\\\, ARGS)))) (RETURN-FROM LOGICAL-BLOCK NIL))))) (IL:\\\,@ BODY)) (END-BLOCK (IL:\\\, VAR) (IL:\\\, SUFFIX))))))))
+
+(DEFUN PPRINT-NEWLINE (KIND &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (WHEN (NOT (MEMBER KIND (QUOTE (:LINEAR :MISER :FILL :MANDATORY)))) (ERROR "Invalid KIND argument ~A to PPRINT-NEWLINE" KIND)) (WHEN (XP-STRUCTURE-P STREAM) (PPRINT-NEWLINE+ KIND STREAM)) NIL)
+
+(DEFUN PPRINT-INDENT (RELATIVE-TO N &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (WHEN (NOT (MEMBER RELATIVE-TO (QUOTE (:BLOCK :CURRENT)))) (ERROR "Invalid KIND argument ~A to PPRINT-INDENT" RELATIVE-TO)) (WHEN (XP-STRUCTURE-P STREAM) (PPRINT-INDENT+ RELATIVE-TO N STREAM)) NIL)
+
+(DEFUN PPRINT-TAB (KIND COLNUM COLINC &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (WHEN (NOT (MEMBER KIND (QUOTE (:LINE :SECTION :LINE-RELATIVE :SECTION-RELATIVE)))) (ERROR "Invalid KIND argument ~A to PPRINT-TAB" KIND)) (WHEN (XP-STRUCTURE-P STREAM) (PPRINT-TAB+ KIND COLNUM COLINC STREAM)) NIL)
+
+
+
+(IL:* IL:|;;| 
+"                       ---- COMPILED FORMAT ---- Note that compiled format strings always print through xp streams even if they don't have any xp directives in them.  As a result, the compiled code can depend on the fact that the stream being operated on is an xp stream not an ordinary one."
+)
+
+
+(PROCLAIM (QUOTE (SPECIAL *STRING* *USED-ARGS* *USED-OUTER-ARGS* *USED-INITIAL* *GET-ARG-CAREFULLY* *INNER-END* *OUTER-END* *AT-TOP* *DEFAULT-PACKAGE*)))
+
+(DEFVAR *FN-TABLE* (MAKE-HASH-TABLE) "used to access fns for commands")
+
+
+
+(IL:* IL:|;;| 
+"Each of these functions expect to get called with two arguments start and end.  Start points to the first character after the ~ marking the command.  End points to the first character after the command.  This includes the matching end command for paired commands."
+)
+
+
+(XCL:DEF-DEFINE-TYPE FORMAT-HANDLERS "XP pretty-printer FORMAT handlers" :UNDEFINER FORMAT-HANDLER-UNDEFINE)
+
+(XCL:DEFDEFINER DEF-FORMAT-HANDLER FORMAT-HANDLERS (CHAR ARGS &BODY BODY) (IL:BQUOTE (EVAL-WHEN (EVAL LOAD COMPILE) (LET ((HANDLER (FUNCTION (LAMBDA (IL:\\\, ARGS) (IL:\\\,@ BODY))))) (SETF (GETHASH (CHAR-UPCASE (IL:\\\, CHAR)) *FN-TABLE*) HANDLER) (SETF (GETHASH (CHAR-DOWNCASE (IL:\\\, CHAR)) *FN-TABLE*) HANDLER)))))
+
+(DEFUN FORMAT-HANDLER-UNDEFINE (CHAR) (SETF (GETHASH (CHAR-UPCASE CHAR) *FN-TABLE*) NIL (GETHASH (CHAR-DOWNCASE CHAR) *FN-TABLE*) NIL))
+
+
+
+(IL:* IL:|;;| 
+"Definitions of the forms used in the code created by PARSE. Note these functions assume the stream is in the var XP and is an xp stream, INITIAL holds the initial value of ARGS (for ~@*). Initial is always bound to (args) if it is bound at all. Note this uses args, but only when actually binding"
+)
+
+
+(DEFUN INITIAL NIL (SETQ *USED-INITIAL* T) (QUOTE INIT))
+
+(DEFMACRO BIND-INITIAL (&BODY CODE) (IL:BQUOTE (LET* ((*USED-INITIAL* NIL) (BODY (PROGN (IL:\\\,@ CODE)))) (IF *USED-INITIAL* (MAKE-BINDING (QUOTE INIT) (ARGS) BODY) BODY))))
+
+(DEFMACRO MAYBE-BIND-INITIAL (DOIT? &BODY CODE) (IL:* IL:|;;| "Hacked to use *USED-INITIAL* bound higher up in ~{ handler") (IL:BQUOTE (LET ((BODY (PROGN (IL:\\\,@ CODE)))) (IF (AND (IL:\\\, DOIT?) *USED-INITIAL*) (MAKE-BINDING (QUOTE INIT) (ARGS) BODY) BODY))))
+
+
+
+(IL:* IL:|;;| 
+"ARGS holds the current argument list The val bound to args must always be computed (to use it up) even if args is not used."
+)
+
+
+(DEFUN ARGS NIL (SETQ *USED-ARGS* T) (QUOTE ARGS))
+
+(DEFMACRO BIND-ARGS (DOIT? VAL &BODY CODE) (IF (EQ DOIT? T) (IL:BQUOTE (LET* ((VAL (IL:\\\, VAL)) (*USED-ARGS* NIL) (BODY (PROGN (IL:\\\,@ CODE)))) (IF *USED-ARGS* (MAKE-BINDING (QUOTE ARGS) VAL BODY) (CONS VAL BODY)))) (IL:BQUOTE (FLET ((CODE NIL (IL:\\\,@ CODE))) (IF (NOT (IL:\\\, DOIT?)) (CODE) (IL:* IL:\; "important bindings not done if not doit?") (LET* ((VAL (IL:\\\, VAL)) (*USED-ARGS* NIL) (BODY (CODE))) (IF *USED-ARGS* (MAKE-BINDING (QUOTE ARGS) VAL BODY) (CONS VAL BODY))))))))
+
+(DEFUN OUTER-ARGS NIL (SETQ *USED-OUTER-ARGS* T) (QUOTE OUTER-ARGS))
+
+(DEFMACRO BIND-OUTER-ARGS (&BODY CODE) (IL:BQUOTE (LET* ((*USED-OUTER-ARGS* NIL) (BODY (PROGN (IL:\\\,@ CODE)))) (IF *USED-OUTER-ARGS* (MAKE-BINDING (QUOTE OUTER-ARGS) (ARGS) BODY) BODY))))
+
+(DEFMACRO MAYBE-BIND (DOIT? VAR VAL &BODY CODE) (IL:BQUOTE (LET ((BODY (PROGN (IL:\\\,@ CODE)))) (IF (IL:\\\, DOIT?) (MAKE-BINDING (IL:\\\, VAR) (IL:\\\, VAL) BODY) BODY))))
+
+(DEFUN MAKE-BINDING (VAR VALUE BODY) (IL:BQUOTE ((LET (((IL:\\\, VAR) (IL:\\\, VALUE))) (IL:\\\,@ BODY)))))
+
+(DEFUN NUM-ARGS NIL (IL:BQUOTE (LENGTH (IL:\\\, (ARGS)))))
+
+(DEFUN GET-ARG NIL (IF *GET-ARG-CAREFULLY* (IF *AT-TOP* (IL:BQUOTE (PPRINT-POP+TOP (IL:\\\, (ARGS)) XP)) (IL:BQUOTE (PPRINT-POP+ (IL:\\\, (ARGS)) XP))) (IL:BQUOTE (POP (IL:\\\, (ARGS))))))
+
+(DEFMACRO PPRINT-POP+ (ARGS XP) (IL:BQUOTE (IF (PPRINT-POP-CHECK+ (IL:\\\, ARGS) (IL:\\\, XP)) (RETURN-FROM LOGICAL-BLOCK NIL) (POP (IL:\\\, ARGS)))))
+
+(DEFUN PPRINT-POP-CHECK+ (ARGS XP) (INCF *CURRENT-LENGTH*) (COND ((NOT (LISTP ARGS)) (IL:* IL:|;;| "must be first so supersedes length abbrev") (WRITE-STRING++ ". " XP 0 2) (WRITE+ ARGS XP) T) ((AND *PRINT-LENGTH* (IL:* IL:\; "must supersede circle check") (NOT (< *CURRENT-LENGTH* *PRINT-LENGTH*))) (WRITE-STRING++ "..." XP 0 3) (SETQ *ABBREVIATION-HAPPENED* T) T) ((AND *CIRCULARITY-HASH-TABLE* (NOT (ZEROP *CURRENT-LENGTH*))) (CASE (CIRCULARITY-PROCESS XP ARGS T) (:FIRST (IL:* IL:|;;| "note must inhibit rechecking of circularity for args.") (WRITE+ (CONS (CAR ARGS) (CDR ARGS)) XP) T) (:SUBSEQUENT T) (T NIL)))))
+
+(DEFMACRO PPRINT-POP+TOP (ARGS XP) (IL:BQUOTE (IF (PPRINT-POP-CHECK+TOP (IL:\\\, ARGS) (IL:\\\, XP)) (RETURN-FROM LOGICAL-BLOCK NIL) (POP (IL:\\\, ARGS)))))
+
+(DEFUN PPRINT-POP-CHECK+TOP (ARGS XP) (INCF *CURRENT-LENGTH*) (COND ((NOT (LISTP ARGS)) (IL:* IL:|;;| "must be first so supersedes length abbrev") (WRITE-STRING++ ". " XP 0 2) (WRITE+ ARGS XP) T) ((AND *PRINT-LENGTH* (IL:* IL:\; "must supersede circle check") (NOT (< *CURRENT-LENGTH* *PRINT-LENGTH*))) (WRITE-STRING++ "..." XP 0 3) (SETQ *ABBREVIATION-HAPPENED* T) T)))
+
+(DEFUN LITERAL (START END) (LET ((SUB-END NIL) NEXT-NEWLINE (RESULT NIL)) (LOOP (SETQ NEXT-NEWLINE (POSITION #\Newline *STRING* :START START :END END)) (SETQ SUB-END (IF NEXT-NEWLINE NEXT-NEWLINE END)) (WHEN (< START SUB-END) (PUSH (IF (= START (1- SUB-END)) (IL:BQUOTE (WRITE-CHAR++ (IL:\\\, (AREF *STRING* START)) XP)) (IL:BQUOTE (WRITE-STRING++ (IL:\\\, (SUBSEQ *STRING* START SUB-END)) XP (IL:\\\, 0) (IL:\\\, (- SUB-END START))))) RESULT)) (WHEN (NULL NEXT-NEWLINE) (RETURN NIL)) (PUSH (IL:BQUOTE (PPRINT-NEWLINE+ :UNCONDITIONAL XP)) RESULT) (SETQ START (1+ SUB-END))) (IF (NULL (CDR RESULT)) (CAR RESULT) (CONS (QUOTE PROGN) (NREVERSE RESULT)))))
+
+
+
+(IL:* IL:\; "This is available for putting on #\".")
+
+
+(DEFUN FORMAT-STRING-READER (STREAM SUB-CHAR ARG) (DECLARE (IGNORE ARG)) (UNREAD-CHAR SUB-CHAR STREAM) (IL:BQUOTE (FORMATTER-IN-PACKAGE (IL:\\\, (READ STREAM)) (IL:\\\, (PACKAGE-NAME *PACKAGE*)))))
+
+(DEFMACRO FORMATTER-IN-PACKAGE (STRING READER-PACKAGE) (FORMATTER-FN STRING READER-PACKAGE))
+
+(DEFMACRO FORMATTER (STRING) (FORMATTER-FN STRING "USER"))
+
+(DEFUN FORMATTER-FN (*STRING* *DEFAULT-PACKAGE*) (OR (CATCH :FORMAT-COMPILATION-ERROR (IL:BQUOTE (FUNCTION (LAMBDA (S &REST ARGS) (APPLY (FUNCTION MAYBE-INITIATE-XP-PRINTING) (FUNCTION (LAMBDA (XP &REST ARGS) (IL:\\\,@ (BIND-INITIAL (IL:BQUOTE ((BLOCK TOP (IL:\\\,@ (LET ((*GET-ARG-CAREFULLY* NIL) (*AT-TOP* T) (*INNER-END* (QUOTE TOP)) (*OUTER-END* (QUOTE TOP))) (COMPILE-FORMAT 0 (LENGTH *STRING*))))))))) (IF (IL:\\\, (ARGS)) (COPY-LIST (IL:\\\, (ARGS)))))) (IL:* IL:\; "needed by symbolics.") S ARGS))))) *STRING*))
+
+
+
+(IL:* IL:|;;| 
+"The business with the catch above allows many (formatter \"...\") errors to be reported in a file without stopping the compilation of the file."
+)
+
+
+(DEFUN MAYBE-COMPILE-FORMAT-STRING (STRING FORCE-FN?) (IF (NOT (OR FORCE-FN? (FANCY-DIRECTIVES-P STRING))) STRING (EVAL (IL:BQUOTE (FORMATTER (IL:\\\, STRING))))))
+
+
+
+(IL:* IL:|;;| "COMPILE-FORMAT gets called to turn a bit of format control string into code.")
+
+
+(DEFVAR *TESTING-ERRORS* NIL "Used only when testing XP")
+
+(DEFUN ERR (ID MSG I) (IF *TESTING-ERRORS* (THROW :TESTING-ERRORS (LIST ID I))) (WARN "XP: cannot compile format string ~%~A~%~S~%~V@T|" MSG *STRING* (1+ I)) (THROW :FORMAT-COMPILATION-ERROR NIL))
+
+(DEFUN POSITION-IN (SET START) (POSITION-IF (FUNCTION (LAMBDA (C) (FIND C SET))) *STRING* :START START))
+
+(DEFUN POSITION-NOT-IN (SET START) (POSITION-IF-NOT (FUNCTION (LAMBDA (C) (FIND C SET))) *STRING* :START START))
+
+(DEFUN NEXT-DIRECTIVE1 (START END) (LET ((I (POSITION #\~ *STRING* :START START :END END)) J) (WHEN I (SETQ J (PARAMS-END (1+ I))) (WHEN (CHAR= (AREF *STRING* J) #\/) (SETQ J (POSITION #\/ *STRING* :START (1+ J) :END END)) (WHEN (NULL J) (ERR 3 "Matching / missing" (POSITION #\/ *STRING* :START START))))) (VALUES I J)))
+
+(DEFUN PARAMS-END (START) (IL:* IL:\; "start points just after ~") (LET ((J START) (END (LENGTH *STRING*))) (LOOP (SETQ J (POSITION-NOT-IN "+-0123456789,Vv@" J)) (WHEN (NULL J) (ERR 1 "missing directive" (1- START))) (WHEN (NOT (EQ (AREF *STRING* J) #\')) (RETURN J)) (INCF J) (IF (= J END) (ERR 2 "No character after '" (1- J))) (INCF J))))
+
+
+
+(IL:* IL:|;;| "Only called after correct parse is known.")
+
+
+(DEFUN DIRECTIVE-START (END) (IL:* IL:\; "end points at characters after params") (LOOP (SETQ END (POSITION #\~ *STRING* :END END :FROM-END T)) (WHEN (OR (ZEROP END) (NOT (EQ (AREF *STRING* (1- END)) #\'))) (RETURN END)) (DECF END)))
+
+(DEFUN NEXT-DIRECTIVE (START END) (LET (I J II K COUNT C CLOSE (PAIRS (QUOTE ((#\( . #\)) (#\[ . #\]) (#\< . #\>) (#\{ . #\}))))) (MULTIPLE-VALUE-SETQ (I J) (NEXT-DIRECTIVE1 START END)) (WHEN I (SETQ C (AREF *STRING* J)) (SETQ CLOSE (CDR (ASSOC C PAIRS))) (WHEN CLOSE (SETQ K J COUNT 0) (LOOP (MULTIPLE-VALUE-SETQ (II K) (NEXT-DIRECTIVE1 K END)) (WHEN (NULL II) (ERR 4 "No matching close directive" J)) (WHEN (EQL (AREF *STRING* K) C) (INCF COUNT)) (WHEN (EQL (AREF *STRING* K) CLOSE) (DECF COUNT) (WHEN (MINUSP COUNT) (SETQ J K) (RETURN NIL)))))) (VALUES C I J)))
+
+
+
+(IL:* IL:\; "breaks things up at ~; directives.")
+
+
+(DEFUN CHUNK-UP (START END) (LET ((POSITIONS (LIST START)) (SPOT START)) (LOOP (MULTIPLE-VALUE-BIND (C I J) (NEXT-DIRECTIVE SPOT END) (DECLARE (IGNORE I)) (WHEN (NULL C) (RETURN (NREVERSE (CONS END POSITIONS)))) (WHEN (EQL C #\;) (PUSH (1+ J) POSITIONS)) (SETQ SPOT J)))))
+
+(DEFUN FANCY-DIRECTIVES-P (*STRING*) (LET (I (J 0) (END (LENGTH *STRING*)) C) (LOOP (MULTIPLE-VALUE-SETQ (I J) (NEXT-DIRECTIVE1 J END)) (WHEN (NOT I) (RETURN NIL)) (SETQ C (AREF *STRING* J)) (WHEN (OR (FIND C "_Ii/Ww") (AND (FIND C ">Tt") (COLONP J))) (RETURN T)))))
+
+(DEFUN NUM-ARGS-IN-ARGS (START &OPTIONAL (ERR NIL)) (LET ((N 0) (I (1- START)) C) (LOOP (SETQ I (POSITION-NOT-IN "+-0123456789," (1+ I))) (SETQ C (AREF *STRING* I)) (COND ((OR (CHAR= C #\V) (CHAR= C #\v)) (INCF N)) ((CHAR= C #\#) (WHEN ERR (ERR 21 "# not allowed in ~~<...~~> by (formatter \"...\")" START)) (RETURN NIL)) ((CHAR= C #\') (INCF I)) (T (RETURN N))))))
+
+(DEFUN COMPILE-FORMAT (START END) (LET ((RESULT NIL)) (PROG (C I J FN) L (MULTIPLE-VALUE-SETQ (C I J) (NEXT-DIRECTIVE START END)) (WHEN (IF (NULL C) (< START END) (< START I)) (PUSH (LITERAL START (IF I I END)) RESULT)) (WHEN (NULL C) (RETURN (NREVERSE RESULT))) (WHEN (CHAR= C #\Newline) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (PARSE-PARAMS (1+ I) NIL :NOCOLONATSIGN T) (WHEN ATSIGN (PUSH (IL:BQUOTE (PPRINT-NEWLINE+ :UNCONDITIONAL XP)) RESULT)) (INCF J) (WHEN (NOT COLON) (SETQ J (POSITION-IF-NOT (FUNCTION (LAMBDA (C) (OR (CHAR= C #\Tab) (CHAR= C #\Space)))) *STRING* :START J :END END)) (WHEN (NULL J) (SETQ J END))) (SETQ START J) (GO L))) (SETQ FN (GETHASH C *FN-TABLE*)) (WHEN (NULL FN) (ERR 5 "Unknown format directive" J)) (INCF J) (PUSH (FUNCALL FN (1+ I) J) RESULT) (SETQ START J) (GO L))))
+
+
+
+(IL:* IL:|;;| 
+"This gets called with start pointing to the character after the ~ that starts a command.  Defaults, is a list of default values for the parameters.  Max is the maximum number of parameters allowed.  Nocolon, noatsign, nocolonatsign can be used to specify what colon atsign combinations are permitted. Parse params returns three values, colon?, atsign? and a list of code chunks that correspond to the parameters specified."
+)
+
+
+(DEFUN PARSE-PARAMS (START DEFAULTS &KEY (MAX (LENGTH DEFAULTS)) (NOCOLON NIL) (NOATSIGN NIL) (NOCOLONATSIGN NIL)) (LET ((COLON NIL) (ATSIGN NIL) (PARAMS NIL) (I START) J C) (LOOP (SETQ C (AREF *STRING* I)) (COND ((OR (CHAR= C #\V) (CHAR= C #\v)) (PUSH (GET-ARG) PARAMS) (INCF I)) ((CHAR= C #\#) (PUSH (NUM-ARGS) PARAMS) (INCF I)) ((CHAR= C #\') (INCF I) (PUSH (AREF *STRING* I) PARAMS) (INCF I)) ((CHAR= C #\,) (PUSH NIL PARAMS)) (T (SETQ J (POSITION-NOT-IN "+-0123456789" I)) (IF (= I J) (RETURN NIL)) (PUSH (PARSE-INTEGER *STRING* :START I :END J :RADIX 10) PARAMS) (SETQ I J))) (IF (CHAR= (AREF *STRING* I) #\,) (INCF I) (RETURN NIL))) (SETQ PARAMS (NREVERSE PARAMS)) (DO ((PS PARAMS (CDR PS)) (DS DEFAULTS (CDR DS)) (NPS NIL)) ((NULL DS) (SETQ PARAMS (NRECONC NPS PS))) (PUSH (COND ((OR (NULL PS) (NULL (CAR PS))) (CAR DS)) ((NOT (CONSP (CAR PS))) (CAR PS)) (T (IL:BQUOTE (COND ((IL:\\\, (CAR PS))) (T (IL:\\\, (CAR DS))))))) NPS)) (IF (AND MAX (< MAX (LENGTH PARAMS))) (ERR 6 "Too many parameters" I)) (LOOP (SETQ C (AREF *STRING* I)) (COND ((CHAR= C #\:) (IF COLON (ERR 7 "Two colons specified" I)) (SETQ COLON T)) ((CHAR= C #\@) (IF ATSIGN (ERR 8 "Two atsigns specified" I)) (SETQ ATSIGN T)) (T (RETURN NIL))) (INCF I)) (IF (AND COLON NOCOLON) (ERR 9 "Colon not permitted" I)) (IF (AND ATSIGN NOATSIGN) (ERR 10 "Atsign not permitted" I)) (IF (AND COLON ATSIGN NOCOLONATSIGN) (ERR 11 "Colon and atsign together not permitted" I)) (VALUES COLON ATSIGN PARAMS)))
+
+
+
+(IL:* IL:|;;| "Both these only called if correct parse already known.")
+
+
+(DEFUN COLONP (J) (IL:* IL:\; "j points to directive name") (OR (EQL (AREF *STRING* (1- J)) #\:) (AND (EQL (AREF *STRING* (1- J)) #\@) (EQL (AREF *STRING* (- J 2)) #\:))))
+
+(DEFUN ATSIGNP (J) (IL:* IL:\; "j points to directive name") (OR (EQL (AREF *STRING* (1- J)) #\@) (AND (EQL (AREF *STRING* (1- J)) #\:) (EQL (AREF *STRING* (- J 2)) #\@))))
+
+
+
+(IL:* IL:|;;| 
+"These flags and lists control some non-spec behavior in FORMATTER's handling of the ~/.../ directive"
+)
+
+
+(DEFVAR *FAST-FORMATTER-SLASH-CALL* (QUOTE (PPRINT-LINEAR PPRINT-FILL PPRINT-TABULAR MAYBELAB BLOCK-LIKE BIND-LIST)) "Functions to make hard links to in ~/.../ FORMATTER code.")
+
+(DEFVAR *FORMATTER-SLASH-PARANOIA* T "If non-NIL, formatter calls to ~/.../ functions check for forms whose CAR is on *formatter-slash-paranoia-list*; those forms do NOT call the ~/.../ function but instead get printed by WRITE+")
+
+(DEFVAR *FORMATTER-SLASH-PARANOIA-LIST* (QUOTE (IL:BQUOTE IL:\\\, IL:\\\,@)) "Initially paranoia is only applied to backquote operators.")
+
+(DEF-FORMAT-HANDLER #\/ (START END) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START NIL :MAX NIL) (LET* ((WHOLE-NAME-START (1+ (PARAMS-END START))) (COLON-POS (POSITION #\: *STRING* :START WHOLE-NAME-START :END (1- END))) (PKG (FIND-PACKAGE (IF COLON-POS (STRING-UPCASE (SUBSEQ *STRING* WHOLE-NAME-START COLON-POS)) *DEFAULT-PACKAGE*))) (NAME-START (COND ((NULL COLON-POS) WHOLE-NAME-START) ((AND (< COLON-POS (1- END)) (CHAR= #\: (AREF *STRING* (1+ COLON-POS)))) (+ COLON-POS 2)) (T (1+ COLON-POS)))) (FN (INTERN (STRING-UPCASE (SUBSEQ *STRING* NAME-START (1- END))) PKG)) (FN-NAME (IF (MEMBER FN *FAST-FORMATTER-SLASH-CALL*) (IL:BQUOTE (FUNCTION (IL:\\\, FN))) (IL:BQUOTE (SYMBOL-FUNCTION (QUOTE (IL:\\\, FN))))))) (IL:* IL:|;;;| "Hacks of interest below:") (IL:* IL:|;;;| "*FAST-FORMATTER-SLASH-CALL* makes ~/.../ calls to functions on that list turn into #'... rather than (SYMBOL-FUNCTION '...) which should improve performance a bit.") (IL:* IL:|;;;| "*FORMATTER-SLASH-PARANOIA* tells ~/.../ to check for forms whose CAR is on *FORMATTER-SLASH-PARANOIA-LIST*, and to NOT call the ... function for those.  This is currently used to catch our back-quote wrappers.") (IF *FORMATTER-SLASH-PARANOIA* (IF (NOT (FIND-IF (FUNCTION CONSP) PARAMS)) (IL:BQUOTE (LET ((LOCAL-ARG (IL:\\\, (GET-ARG)))) (IF (AND (CONSP LOCAL-ARG) (MEMBER (CAR LOCAL-ARG) *FORMATTER-SLASH-PARANOIA-LIST*)) (WRITE+ LOCAL-ARG XP) (FUNCALL (IL:\\\, FN-NAME) XP LOCAL-ARG (IL:\\\, COLON) (IL:\\\, ATSIGN) (IL:\\\,@ PARAMS))))) (LET ((VARS (MAPCAR (FUNCTION (LAMBDA (ARG) (DECLARE (IGNORE ARG)) (GENTEMP))) PARAMS))) (IL:BQUOTE (LET ((IL:\\\,@ (MAPCAR (FUNCTION LIST) VARS PARAMS)) (LOCAL-ARG (IL:\\\, (GET-ARG)))) (IF (AND (CONSP LOCAL-ARG) (MEMBER (CAR LOCAL-ARG) *FORMATTER-SLASH-PARANOIA-LIST*)) (WRITE+ LOCAL-ARG XP) (FUNCALL (IL:\\\, FN-NAME) XP LOCAL-ARG (IL:\\\, COLON) (IL:\\\, ATSIGN) (IL:\\\,@ VARS))))))) (IF (NOT (FIND-IF (FUNCTION CONSP) PARAMS)) (IL:BQUOTE (FUNCALL (IL:\\\, FN-NAME) XP (IL:\\\, (GET-ARG)) (IL:\\\, COLON) (IL:\\\, ATSIGN) (IL:\\\,@ PARAMS))) (LET ((VARS (MAPCAR (FUNCTION (LAMBDA (ARG) (DECLARE (IGNORE ARG)) (GENTEMP))) PARAMS))) (IL:BQUOTE (LET (IL:\\\, (MAPCAR (FUNCTION LIST) VARS PARAMS)) (FUNCALL (IL:\\\, FN-NAME) XP (IL:\\\, (GET-ARG)) (IL:\\\, COLON) (IL:\\\, ATSIGN) (IL:\\\,@ VARS))))))))))
+
+(DEF-FORMAT-HANDLER #\A (START END) (IF (NOT (= END (1+ START))) (SIMPLE-DIRECTIVE START END) (IL:BQUOTE (LET ((*PRINT-ESCAPE* NIL)) (WRITE+ (IL:\\\, (GET-ARG)) XP)))))
+
+(DEF-FORMAT-HANDLER #\S (START END) (IF (NOT (= END (1+ START))) (SIMPLE-DIRECTIVE START END) (IL:BQUOTE (LET ((*PRINT-ESCAPE* T)) (WRITE+ (IL:\\\, (GET-ARG)) XP)))))
+
+
+
+(IL:* IL:|;;| 
+"The basic Format directives \"DBOXRCFEG$\".  The key thing about all of these directives is that they just get a single arg and print a chunk of stuff.  Further they are complex enough that I just call the standard definition of FORMAT to get the work done.  What should really be being called is the internal routine that FORMAT uses to do the corresponding work.  However, this cannot be done in a portable way."
+)
+
+
+(DEF-FORMAT-HANDLER #\D (START END) (SIMPLE-DIRECTIVE START END))
+
+(DEF-FORMAT-HANDLER #\B (START END) (SIMPLE-DIRECTIVE START END))
+
+(DEF-FORMAT-HANDLER #\O (START END) (SIMPLE-DIRECTIVE START END))
+
+(DEF-FORMAT-HANDLER #\X (START END) (SIMPLE-DIRECTIVE START END))
+
+(DEF-FORMAT-HANDLER #\R (START END) (SIMPLE-DIRECTIVE START END))
+
+(DEF-FORMAT-HANDLER #\C (START END) (SIMPLE-DIRECTIVE START END))
+
+(DEF-FORMAT-HANDLER #\F (START END) (SIMPLE-DIRECTIVE START END))
+
+(DEF-FORMAT-HANDLER #\E (START END) (SIMPLE-DIRECTIVE START END))
+
+(DEF-FORMAT-HANDLER #\G (START END) (SIMPLE-DIRECTIVE START END))
+
+(DEF-FORMAT-HANDLER #\$ (START END) (SIMPLE-DIRECTIVE START END))
+
+(DEFUN SIMPLE-DIRECTIVE (START END) (LET ((N (NUM-ARGS-IN-ARGS START))) (IF N (IL:BQUOTE (USING-FORMAT XP (IL:\\\, (SUBSEQ *STRING* (1- START) END)) (IL:\\\,@ (COPY-TREE (MAKE-LIST (1+ N) :INITIAL-ELEMENT (GET-ARG)))))) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START NIL :MAX 8) (LET* ((ARG-STR (SUBSEQ "v,v,v,v,v,v,v,v" 0 (MAX 0 (1- (* 2 (LENGTH PARAMS)))))) (STR (CONCATENATE (QUOTE STRING) "~" ARG-STR (IF COLON ":" "") (IF ATSIGN "@" "") (SUBSEQ *STRING* (1- END) END)))) (IL:BQUOTE (USING-FORMAT XP (IL:\\\, STR) (IL:\\\,@ PARAMS) (IL:\\\, (GET-ARG)))))))))
+
+(DEFUN USING-FORMAT (XP STRING &REST ARGS) (IL:* IL:|;;| "The code below is bogus in our merged world; we can just print the damned thing.  The clear intent of this code is to non-pretty-print something; the way we're doing it, it should be sufficient to turn *print-pretty* off") (IL:* IL:|;;| "(LET ((RESULT (APPLY #'CL:FORMAT NIL STRING ARGS))) (WRITE-STRING+ RESULT XP 0 (LENGTH RESULT)))") (IL:* IL:|;;| "This should \"really\" be a macro, except that it is APPLYed several places in XP.  I suspect an optimizer is in order here...") (LET (*PRINT-PRETTY*) (APPLY (FUNCTION CL:FORMAT) XP STRING ARGS)))
+
+
+
+(IL:* IL:|;;| "Format directives that get open coded \"P%&~|T*?^\"")
+
+
+(DEF-FORMAT-HANDLER #\P (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (PARSE-PARAMS START NIL) (LET ((ARG (IF COLON (IL:BQUOTE (CAR (BACKUP-IN-LIST 1 (IL:\\\, (INITIAL)) (IL:\\\, (ARGS))))) (GET-ARG)))) (IF ATSIGN (IL:BQUOTE (IF (NOT (EQL (IL:\\\, ARG) 1)) (WRITE-STRING++ "ies" XP 0 3) (WRITE-CHAR++ #\y XP))) (IL:BQUOTE (IF (NOT (EQL (IL:\\\, ARG) 1)) (WRITE-CHAR++ #\s XP)))))))
+
+(DEF-FORMAT-HANDLER #\% (START END) (DECLARE (IGNORE END)) (MULTIPLE-NEWLINES START :UNCONDITIONAL))
+
+(DEF-FORMAT-HANDLER #\& (START END) (DECLARE (IGNORE END)) (MULTIPLE-NEWLINES START :FRESH))
+
+(DEFUN MULTIPLE-NEWLINES (START KIND) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (QUOTE (1)) :NOCOLON T :NOATSIGN T) (DECLARE (IGNORE COLON ATSIGN)) (IF (EQL (CAR PARAMS) 1) (IL:BQUOTE (PPRINT-NEWLINE+ (IL:\\\, KIND) XP)) (IL:BQUOTE (MULTIPLE-NEWLINES1 XP (IL:\\\, KIND) (IL:\\\, (CAR PARAMS)))))))
+
+(DEFUN MULTIPLE-NEWLINES1 (XP KIND NUM) (DO ((N NUM (1- N))) ((NOT (PLUSP N))) (PPRINT-NEWLINE+ KIND XP) (SETQ KIND :UNCONDITIONAL)))
+
+(DEF-FORMAT-HANDLER #\| (START END) (DECLARE (IGNORE END)) (MULTIPLE-CHARS START #\Page))
+
+(DEF-FORMAT-HANDLER #\~ (START END) (DECLARE (IGNORE END)) (MULTIPLE-CHARS START #\~))
+
+(DEFUN MULTIPLE-CHARS (START CHAR) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (QUOTE (1)) :NOCOLON T :NOATSIGN T) (DECLARE (IGNORE COLON ATSIGN)) (IF (EQL (CAR PARAMS) 1) (IL:BQUOTE (WRITE-CHAR++ (IL:\\\, CHAR) XP)) (IL:BQUOTE (MULTIPLE-CHARS1 XP (IL:\\\, (CAR PARAMS)) (IL:\\\, CHAR))))))
+
+(DEFUN MULTIPLE-CHARS1 (XP NUM CHAR) (DO ((N NUM (1- N))) ((NOT (PLUSP N))) (WRITE-CHAR++ CHAR XP)))
+
+(DEF-FORMAT-HANDLER #\T (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (QUOTE (1 1))) (IL:BQUOTE (PPRINT-TAB+ (IL:\\\, (IF COLON (IF ATSIGN :SECTION-RELATIVE :SECTION) (IF ATSIGN :LINE-RELATIVE :LINE))) (IL:\\\, (POP PARAMS)) (IL:\\\, (POP PARAMS)) XP))))
+
+(DEF-FORMAT-HANDLER #\* (START END) (DECLARE (IGNORE END)) (IF (ATSIGNP (PARAMS-END START)) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (QUOTE (0)) :NOCOLON T) (DECLARE (IGNORE COLON ATSIGN)) (IL:BQUOTE (SETQ ARGS (BACKUP-TO (IL:\\\, (CAR PARAMS)) (IL:\\\, (INITIAL)) (IL:\\\, (ARGS)))))) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (QUOTE (1))) (DECLARE (IGNORE ATSIGN)) (IL:BQUOTE (SETQ ARGS (IL:\\\, (IF COLON (IL:BQUOTE (BACKUP-IN-LIST (IL:\\\, (CAR PARAMS)) (IL:\\\, (INITIAL)) (IL:\\\, (ARGS)))) (IL:BQUOTE (NTHCDR (IL:\\\, (CAR PARAMS)) (IL:\\\, (ARGS)))))))))))
+
+
+
+(IL:* IL:|;;| "fancy stuff here, so will not get spurious indications of circularity.")
+
+
+(DEFUN BACKUP-IN-LIST (NUM LIST SOME-TAIL) (BACKUP-TO (- (TAIL-POS LIST SOME-TAIL) NUM) LIST SOME-TAIL))
+
+(DEFUN BACKUP-TO (NUM LIST SOME-TAIL) (IF (NOT *CIRCULARITY-HASH-TABLE*) (NTHCDR NUM LIST) (MULTIPLE-VALUE-BIND (POS SHARE) (TAIL-POS LIST SOME-TAIL) (DECLARE (IGNORE POS)) (IF (NOT (< NUM SHARE)) (NTHCDR NUM LIST) (DO ((L (NTHCDR NUM LIST) (CDR L)) (N (- SHARE NUM) (1- N)) (R NIL (CONS (CAR L) R))) ((ZEROP N) (NRECONC R L)))))))
+
+
+
+(IL:* IL:|;;| 
+"because of backup-to, a prefix of some-tail may have been copied (in which case it cannot share anything with list), but there is a cons in some-tail that is in list.  This can be used to determine the position of some-tail relative to list.  However, we have to be careful, because they both could be cdr recursive."
+)
+
+
+(DEFUN TAIL-POS (LIST SOME-TAIL) (BLOCK OUTER (DO ((N 0 (1+ N)) (L LIST (CDR L))) (NIL) (DO ((M N (1- M)) (ST SOME-TAIL (CDR ST))) (NIL) (IF (MINUSP M) (RETURN NIL)) (IF (EQ ST L) (RETURN-FROM OUTER (VALUES M N)))))))
+
+(DEF-FORMAT-HANDLER #\? (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (PARSE-PARAMS START NIL :NOCOLON T) (DECLARE (IGNORE COLON)) (IF (NOT ATSIGN) (IL:BQUOTE (APPLY (FUNCTION FORMAT) XP (IL:\\\, (GET-ARG)) (IL:\\\, (GET-ARG)))) (IL:BQUOTE (LET ((FN (PROCESS-FORMAT-STRING (IL:\\\, (GET-ARG)) T))) (SETQ ARGS (APPLY FN XP (IL:\\\, (ARGS)))))))))
+
+(DEF-FORMAT-HANDLER #\^ (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START NIL :MAX 3 :NOATSIGN T) (DECLARE (IGNORE ATSIGN)) (IL:BQUOTE (IF (IL:\\\, (COND ((NULL PARAMS) (IL:BQUOTE (NULL (IL:\\\, (IF COLON (IL:BQUOTE (CDR (IL:\\\, (OUTER-ARGS)))) (ARGS)))))) (T (IL:BQUOTE (DO-COMPLEX-^-TEST (IL:\\\,@ PARAMS)))))) (RETURN-FROM (IL:\\\, (IF COLON *OUTER-END* *INNER-END*)) NIL)))))
+
+(DEFUN DO-COMPLEX-^-TEST (A1 &OPTIONAL (A2 NIL) (A3 NIL)) (COND (A3 (AND (<= A1 A2) (<= A2 A3))) (A2 (= A1 A2)) (T (= 0 A1))))
+
+
+
+(IL:* IL:|;;| "delimited pairs of format directives. \"(){}[]<>;\"")
+
+
+(DEF-FORMAT-HANDLER #\[ (START END) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START NIL :MAX 1 :NOCOLONATSIGN T) (SETQ START (1+ (PARAMS-END START))) (LET* ((CHUNKS (CHUNK-UP START END)) (INNARDS (DO ((NS CHUNKS (CDR NS)) (MS (CDR CHUNKS) (CDR MS)) (RESULT NIL)) ((NULL MS) (RETURN (NREVERSE RESULT))) (PUSH (COMPILE-FORMAT (CAR NS) (DIRECTIVE-START (CAR MS))) RESULT)))) (COND (COLON (WHEN (NOT (= (LENGTH INNARDS) 2)) (ERR 13 "Wrong number of clauses in ~~:[...~~]" (1- START))) (IL:BQUOTE (COND ((NULL (IL:\\\, (GET-ARG))) (IL:\\\,@ (CAR INNARDS))) (T (IL:\\\,@ (CADR INNARDS)))))) (ATSIGN (WHEN (NOT (= (LENGTH INNARDS) 1)) (ERR 14 "Too many clauses in ~~@[...~~]" (1- START))) (IL:BQUOTE (COND ((CAR ARGS) (IL:\\\,@ (CAR INNARDS))) (T (IL:\\\, (GET-ARG)))))) (T (LET* ((J -1) (LEN (- (LENGTH CHUNKS) 2)) (ELSE? (COLONP (1- (NTH LEN CHUNKS))))) (IL:BQUOTE (CASE (IL:\\\, (IF PARAMS (CAR PARAMS) (GET-ARG))) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (UNIT) (INCF J) (IL:BQUOTE ((IL:\\\, (IF (AND ELSE? (= J LEN)) T J)) (IL:\\\,@ UNIT))))) INNARDS))))))))))
+
+(DEF-FORMAT-HANDLER #\( (START END) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (PARSE-PARAMS START NIL) (SETQ START (1+ (PARAMS-END START))) (SETQ END (DIRECTIVE-START END)) (IL:BQUOTE (PROGN (PUSH-CHAR-MODE XP (IL:\\\, (COND ((AND COLON ATSIGN) :UP) (COLON :CAP1) (ATSIGN :CAP0) (T :DOWN)))) (IL:\\\,@ (COMPILE-FORMAT START END)) (POP-CHAR-MODE XP)))))
+
+(DEF-FORMAT-HANDLER #\; (START END) (DECLARE (IGNORE START)) (ERR 15 "~~; appears out of context" (1- END)))
+
+(DEF-FORMAT-HANDLER #\] (START END) (DECLARE (IGNORE START)) (ERR 16 "Unmatched closing directive" (1- END)))
+
+(DEF-FORMAT-HANDLER #\) (START END) (DECLARE (IGNORE START)) (ERR 17 "Unmatched closing directive" (1- END)))
+
+(DEF-FORMAT-HANDLER #\> (START END) (DECLARE (IGNORE START)) (ERR 18 "Unmatched closing directive" (1- END)))
+
+(DEF-FORMAT-HANDLER #\} (START END) (DECLARE (IGNORE START)) (ERR 19 "Unmatched closing directive" (1- END)))
+
+(DEF-FORMAT-HANDLER #\{ (START END) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (QUOTE (-1)) :MAX 1) (LET* ((FORCE-ONCE (COLONP (1- END))) (N (CAR PARAMS)) (BOUNDED (NOT (EQL N -1))) (*USED-INITIAL* NIL)) (SETQ START (1+ (PARAMS-END START))) (SETQ END (DIRECTIVE-START END)) (CAR (MAYBE-BIND BOUNDED (QUOTE N) N (IL:* IL:\; "must be outermost if is V or #") (MAYBE-BIND (NOT (> END START)) (QUOTE FN) (IL:* IL:\; "must be second") (IL:BQUOTE (PROCESS-FORMAT-STRING (IL:\\\, (GET-ARG)) T)) (BIND-ARGS (NOT ATSIGN) (GET-ARG) (IL:BQUOTE ((IL:\\\,@ (MAYBE-BIND-INITIAL (OR (NOT ATSIGN) (NOT COLON)) (IL:BQUOTE ((PROG NIL (IL:\\\,@ (IF FORCE-ONCE (QUOTE ((GO S))))) L (IF (NULL (IL:\\\, (ARGS))) (RETURN NIL)) (IL:\\\,@ (IF FORCE-ONCE (QUOTE (S)))) (IL:\\\,@ (IF BOUNDED (QUOTE ((IF (= N 0) (RETURN NIL) (DECF N)))))) (IL:\\\,@ (BIND-OUTER-ARGS (BIND-ARGS COLON (GET-ARG) (IL:BQUOTE ((IL:\\\,@ (MAYBE-BIND-INITIAL COLON (LET ((*GET-ARG-CAREFULLY* (AND *GET-ARG-CAREFULLY* ATSIGN)) (*AT-TOP* (AND *AT-TOP* ATSIGN)) (*OUTER-END* NIL) (*INNER-END* NIL)) (IF (NOT COLON) (IF (NOT (> END START)) (IL:BQUOTE ((SETQ ARGS (APPLY FN XP (IL:\\\, (ARGS)))))) (COMPILE-FORMAT START END)) (LET ((*INNER-END* (QUOTE INNER))) (IL:BQUOTE ((BLOCK INNER (IL:\\\,@ (IF (NOT (> END START)) (IL:BQUOTE ((SETQ ARGS (APPLY FN XP (IL:\\\, (ARGS)))))) (COMPILE-FORMAT START END)))))))))))))))) (GO L)))))))))))))))
+
+(DEF-FORMAT-HANDLER #\< (START END) (IF (COLONP (1- END)) (HANDLE-LOGICAL-BLOCK START END) (HANDLE-STANDARD-< START END)))
+
+(DEFUN HANDLE-STANDARD-< (START END) (LET ((N (NUM-ARGS-IN-DIRECTIVE START END))) (IL:BQUOTE (USING-FORMAT XP (IL:\\\, (SUBSEQ *STRING* (1- START) END)) (IL:\\\,@ (COPY-TREE (MAKE-LIST N :INITIAL-ELEMENT (GET-ARG))))))))
+
+(DEFUN NUM-ARGS-IN-DIRECTIVE (START END) (LET ((N 0) C I J) (INCF N (NUM-ARGS-IN-ARGS START T)) (MULTIPLE-VALUE-SETQ (J I) (NEXT-DIRECTIVE1 START END)) (LOOP (MULTIPLE-VALUE-SETQ (C I J) (NEXT-DIRECTIVE J END)) (WHEN (NULL C) (RETURN N)) (COND ((EQL C #\;) (IF (COLONP J) (ERR 22 "~~:; not supported in ~~<...~~> by (formatter \"...\")." J))) ((FIND C "*[^<_IiWw{Tt") (ERR 23 "~~<...~~> too complicated to be supported by (formatter \"...\")." J)) ((EQL C #\() (INCF N (NUM-ARGS-IN-DIRECTIVE (1+ I) J))) ((FIND C "%&|~") (INCF N (NUM-ARGS-IN-ARGS (1+ I) T))) ((EQL C #\?) (WHEN (ATSIGNP J) (ERR 23 "~~<...~~> too complicated to be supported by (formatter \"...\")." J)) (INCF N 2)) ((FIND C "AaSsDdBbOoXxRrCcFfEeGg$Pp") (INCF N (1+ (NUM-ARGS-IN-ARGS (1+ I) T))))))))
+
+
+
+(IL:* IL:\; "The pretty-printing directives. \"_IW<:>\"")
+
+
+(DEF-FORMAT-HANDLER #\_ (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (PARSE-PARAMS START NIL) (IL:BQUOTE (PPRINT-NEWLINE+ (IL:\\\, (COND ((AND COLON ATSIGN) :MANDATORY) (COLON :FILL) (ATSIGN :MISER) (T :LINEAR))) XP))))
+
+(DEF-FORMAT-HANDLER #\I (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (QUOTE (0)) :NOATSIGN T) (DECLARE (IGNORE ATSIGN)) (IL:BQUOTE (PPRINT-INDENT+ (IL:\\\, (IF COLON :CURRENT :BLOCK)) (IL:\\\, (CAR PARAMS)) XP))))
+
+(DEF-FORMAT-HANDLER #\W (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (PARSE-PARAMS START NIL) (COND ((NOT (OR COLON ATSIGN)) (IL:BQUOTE (WRITE+ (IL:\\\, (GET-ARG)) XP))) (T (IL:BQUOTE (LET ((IL:\\\,@ (IF COLON (QUOTE ((*PRINT-PRETTY* T))))) (IL:\\\,@ (IF ATSIGN (QUOTE ((*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL)))))) (WRITE+ (IL:\\\, (GET-ARG)) XP)))))))
+
+(DEFUN HANDLE-LOGICAL-BLOCK (START END) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (PARSE-PARAMS START NIL) (SETQ START (1+ (PARAMS-END START))) (LET* ((CHUNKS (CHUNK-UP START END)) (ON-EACH-LINE? (AND (CDDR CHUNKS) (ATSIGNP (1- (CADR CHUNKS))))) (PREFIX (COND ((CDDR CHUNKS) (POP CHUNKS) (SUBSEQ *STRING* START (DIRECTIVE-START (CAR CHUNKS)))) (COLON "("))) (SUFFIX (COND ((CDDR CHUNKS) (SUBSEQ *STRING* (CADR CHUNKS) (DIRECTIVE-START (CADDR CHUNKS)))) (COLON ")")))) (WHEN (CDDDR CHUNKS) (ERR 24 "Too many subclauses in ~~<...~~:>" (1- START))) (WHEN (AND PREFIX (OR (FIND #\~ PREFIX) (FIND #\Newline PREFIX))) (ERR 25 "Prefix in ~~<...~~:> must be a literal string without newline" START)) (WHEN (AND SUFFIX (OR (FIND #\~ SUFFIX) (FIND #\Newline SUFFIX))) (ERR 26 "Suffix in ~~<...~~:> must be a literal string without newline" (CADR CHUNKS))) (CAR (BIND-ARGS T (IF ATSIGN (IL:BQUOTE (PROG1 (IL:\\\, (ARGS)) (SETQ (IL:\\\, (ARGS)) NIL))) (GET-ARG)) (BIND-INITIAL (IL:BQUOTE ((PPRINT-LOGICAL-BLOCK+ (XP (IL:\\\, (ARGS)) (IL:\\\, PREFIX) (IL:\\\, SUFFIX) (IL:\\\, ON-EACH-LINE?) (IL:\\\, (NOT (AND *AT-TOP* ATSIGN))) (IL:\\\, ATSIGN)) (IL:\\\,@ (FILL-TRANSFORM (ATSIGNP (1- END)) (LET ((*GET-ARG-CAREFULLY* T) (*AT-TOP* (AND *AT-TOP* ATSIGN)) (*INNER-END* (QUOTE LOGICAL-BLOCK)) (*OUTER-END* (QUOTE LOGICAL-BLOCK))) (COMPILE-FORMAT (CAR CHUNKS) (DIRECTIVE-START (CADR CHUNKS)))))))))))))))
+
+(DEFUN CHECK-BLOCK-ABBREVIATION (XP ARGS CIRCLE-CHECK?) (COND ((NOT (LISTP ARGS)) (WRITE+ ARGS XP) T) ((AND *PRINT-LEVEL* (> *CURRENT-LEVEL* *PRINT-LEVEL*)) (WRITE-CHAR++ #\# XP) (SETQ *ABBREVIATION-HAPPENED* T) T) ((AND *CIRCULARITY-HASH-TABLE* CIRCLE-CHECK? (EQ (CIRCULARITY-PROCESS XP ARGS NIL) :SUBSEQUENT)) T) (T NIL)))
+
+(DEFUN FILL-TRANSFORM (DOIT? BODY) (IF (NOT DOIT?) BODY (MAPCAN (FUNCTION (LAMBDA (FORM) (COND ((EQ (CAR FORM) (QUOTE WRITE-STRING++)) (FILL-TRANSFORM-LITERAL (CADR FORM))) ((EQ (CAR FORM) (QUOTE WRITE-CHAR++)) (FILL-TRANSFORM-CHAR (CADR FORM))) (T (LIST FORM))))) BODY)))
+
+(DEFUN FILL-TRANSFORM-CHAR (CHAR) (IF (OR (CHAR= CHAR #\Space) (CHAR= CHAR #\Tab)) (LIST (IL:BQUOTE (WRITE-CHAR++ (IL:\\\, CHAR) XP)) (QUOTE (PPRINT-NEWLINE+ :FILL XP))) (IL:BQUOTE ((WRITE-CHAR++ (IL:\\\, CHAR) XP)))))
+
+(DEFUN FILL-TRANSFORM-LITERAL (STRING) (FLET ((WHITE-SPACE (C) (OR (CHAR= C #\Space) (CHAR= C #\Tab)))) (DO ((INDEX 0 END) (RESULT) (END NIL NIL)) (NIL) (LET ((WHITE (POSITION-IF (FUNCTION WHITE-SPACE) STRING :START INDEX))) (WHEN WHITE (SETQ END (POSITION-IF-NOT (FUNCTION WHITE-SPACE) STRING :START (1+ WHITE)))) (WHEN (NULL END) (SETQ END (LENGTH STRING))) (PUSH (IL:BQUOTE (WRITE-STRING++ (IL:\\\, (SUBSEQ STRING INDEX END)) XP (IL:\\\, 0) (IL:\\\, (- END INDEX)))) RESULT) (IF WHITE (PUSH (QUOTE (PPRINT-NEWLINE+ :FILL XP)) RESULT)) (IF (NULL WHITE) (RETURN (NREVERSE RESULT)))))))
+
+
+
+(IL:* IL:|;;| 
+"end of eval when for all (formatter \"...\") stuff.                ---- PRETTY PRINTING FORMATS ----"
+)
+
+
+(DEFUN PRETTY-ARRAY (XP ARRAY) (COND ((VECTORP ARRAY) (PRETTY-VECTOR XP ARRAY)) ((ZEROP (ARRAY-RANK ARRAY)) (WRITE-STRING++ "#0A " XP 0 4) (WRITE+ (AREF ARRAY) XP)) (T (PRETTY-NON-VECTOR XP ARRAY))))
+
+(DEFUN PRETTY-VECTOR (XP V) (PPRINT-LOGICAL-BLOCK (XP NIL :PREFIX "#(" :SUFFIX ")") (LET ((END (LENGTH V)) (I 0)) (WHEN (PLUSP END) (LOOP (PPRINT-POP) (WRITE+ (AREF V I) XP) (IF (= (INCF I) END) (RETURN NIL)) (WRITE-CHAR++ #\Space XP) (PPRINT-NEWLINE+ :FILL XP))))))
+
+(DEFUN PRETTY-NON-VECTOR (XP ARRAY) (LET* ((BOTTOM (1- (ARRAY-RANK ARRAY))) (INDICES (MAKE-LIST (1+ BOTTOM) :INITIAL-ELEMENT 0)) (DIMS (ARRAY-DIMENSIONS ARRAY))) (FUNCALL (FORMATTER "#~DA") XP (1+ BOTTOM)) (LABELS ((PRETTY-SLICE (SLICE) (PPRINT-LOGICAL-BLOCK (XP NIL :PREFIX "(" :SUFFIX ")") (LET ((END (NTH SLICE DIMS)) (SPOT (NTHCDR SLICE INDICES)) (I 0)) (WHEN (PLUSP END) (LOOP (PPRINT-POP) (SETF (CAR SPOT) I) (IF (= SLICE BOTTOM) (WRITE+ (APPLY (FUNCTION AREF) ARRAY INDICES) XP) (PRETTY-SLICE (1+ SLICE))) (IF (= (INCF I) END) (RETURN NIL)) (WRITE-CHAR++ #\Space XP) (PPRINT-NEWLINE+ (IF (= SLICE BOTTOM) :FILL :LINEAR) XP))))))) (PRETTY-SLICE 0))))
+
+
+
+(IL:* IL:|;;| 
+"Must use pprint-logical-block (no +) in the following three, because they are exported functions.")
+
+
+(DEFUN PPRINT-LINEAR (S LIST &OPTIONAL (COLON? T) ATSIGN?) (DECLARE (IGNORE ATSIGN?)) (PPRINT-LOGICAL-BLOCK (S LIST :PREFIX (IF COLON? "(" "") :SUFFIX (IF COLON? ")" "")) (PPRINT-EXIT-IF-LIST-EXHAUSTED) (LOOP (WRITE+ (PPRINT-POP) S) (PPRINT-EXIT-IF-LIST-EXHAUSTED) (WRITE-CHAR++ #\Space S) (PPRINT-NEWLINE+ :LINEAR S))))
+
+(DEFUN PPRINT-FILL (S LIST &OPTIONAL (COLON? T) ATSIGN?) (DECLARE (IGNORE ATSIGN?)) (PPRINT-LOGICAL-BLOCK (S LIST :PREFIX (IF COLON? "(" "") :SUFFIX (IF COLON? ")" "")) (PPRINT-EXIT-IF-LIST-EXHAUSTED) (LOOP (WRITE+ (PPRINT-POP) S) (PPRINT-EXIT-IF-LIST-EXHAUSTED) (WRITE-CHAR++ #\Space S) (PPRINT-NEWLINE+ :FILL S))))
+
+(DEFUN PPRINT-TABULAR (S LIST &OPTIONAL (COLON? T) ATSIGN? (TABSIZE NIL)) (DECLARE (IGNORE ATSIGN?)) (WHEN (NULL TABSIZE) (SETQ TABSIZE 16)) (PPRINT-LOGICAL-BLOCK (S LIST :PREFIX (IF COLON? "(" "") :SUFFIX (IF COLON? ")" "")) (PPRINT-EXIT-IF-LIST-EXHAUSTED) (LOOP (WRITE+ (PPRINT-POP) S) (PPRINT-EXIT-IF-LIST-EXHAUSTED) (WRITE-CHAR++ #\Space S) (PPRINT-TAB+ :SECTION-RELATIVE 0 TABSIZE S) (PPRINT-NEWLINE+ :FILL S))))
+
+(DEFUN FN-CALL (XP LIST) (FUNCALL (FORMATTER "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") XP LIST))
+
+
+
+(IL:* IL:|;;| 
+"Although idiosyncratic, I have found this very useful to avoid large indentations when printing out code."
+)
+
+
+(DEFUN ALTERNATIVE-FN-CALL (XP LIST) (IF (> (LENGTH (SYMBOL-NAME (CAR LIST))) 12) (FUNCALL (FORMATTER "~:<~1I~@{~W~^ ~_~}~:>") XP LIST) (FUNCALL (FORMATTER "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") XP LIST)))
+
+(DEFUN BIND-LIST (XP LIST &REST ARGS) (DECLARE (IGNORE ARGS)) (IF (DO ((I 50 (1- I)) (LS LIST (CDR LS))) ((NULL LS) T) (WHEN (OR (NOT (CONSP LS)) (NOT (SYMBOLP (CAR LS))) (MINUSP I)) (RETURN NIL))) (PPRINT-FILL XP LIST) (FUNCALL (FORMATTER "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>") XP LIST)))
+
+(DEFUN BLOCK-LIKE (XP LIST &REST ARGS) (DECLARE (IGNORE ARGS)) (FUNCALL (FORMATTER "~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>") XP LIST))
+
+(DEFUN DEFUN-LIKE (XP LIST &REST ARGS) (DECLARE (IGNORE ARGS)) (FUNCALL (FORMATTER "~:<~1I~W~^ ~@_~W~^ ~@_~:/xp:pprint-fill/~^~@{ ~_~W~^~}~:>") XP LIST))
+
+(DEFUN PRINT-FANCY-FN-CALL (XP LIST TEMPLATE) (LET ((I 0) (IN-FIRST-SECTION T)) (PPRINT-LOGICAL-BLOCK+ (XP LIST "(" ")" NIL T NIL) (WRITE+ (PPRINT-POP) XP) (PPRINT-INDENT+ :CURRENT 1 XP) (LOOP (PPRINT-EXIT-IF-LIST-EXHAUSTED) (WRITE-CHAR++ #\Space XP) (WHEN (EQ I (CAR TEMPLATE)) (PPRINT-INDENT+ :BLOCK (CADR TEMPLATE) XP) (SETQ TEMPLATE (CDDR TEMPLATE)) (SETQ IN-FIRST-SECTION NIL)) (PPRINT-NEWLINE (COND ((AND (ZEROP I) IN-FIRST-SECTION) :MISER) (IN-FIRST-SECTION :FILL) (T :LINEAR)) XP) (WRITE+ (PPRINT-POP) XP) (INCF I)))))
+
+(DEFUN MAYBELAB (XP ITEM &REST ARGS) (DECLARE (IGNORE ARGS) (SPECIAL NEED-NEWLINE INDENTATION)) (WHEN NEED-NEWLINE (PPRINT-NEWLINE+ :MANDATORY XP)) (COND ((AND ITEM (SYMBOLP ITEM)) (WRITE+ ITEM XP) (SETQ NEED-NEWLINE NIL)) (T (PPRINT-TAB+ :SECTION INDENTATION 0 XP) (WRITE+ ITEM XP) (SETQ NEED-NEWLINE T))))
+
+(DEFUN FUNCTION-CALL-P (X) (AND (CONSP X) (SYMBOLP (CAR X)) (FBOUNDP (CAR X))))
+
+
+
+(IL:* IL:|;;| 
+"THE FOLLOWING STUFF SETS UP THE DEFAULT *PRINT-PPRINT-DISPATCH* This is an attempt to specify a correct format for every form in the CL book that does not just get printed out like an ordinary function call  (i.e., most special forms and many macros).  This of course does not  cover anything new you define."
+)
+
+
+(DEFUN LET-PRINT (XP OBJ) (FUNCALL (FORMATTER "~:<~1I~W~^ ~@_~/xp:bind-list/~^~@{ ~_~W~^~}~:>") XP OBJ))
+
+(DEFUN COND-PRINT (XP OBJ) (FUNCALL (FORMATTER "~:<~W~^ ~:I~@_~@{~:/xp:pprint-linear/~^ ~_~}~:>") XP OBJ))
+
+(DEFUN DMM-PRINT (XP LIST) (PRINT-FANCY-FN-CALL XP LIST (QUOTE (3 1))))
+
+(DEFUN DEFSETF-PRINT (XP LIST) (PRINT-FANCY-FN-CALL XP LIST (QUOTE (3 1))))
+
+(DEFUN DO-PRINT (XP OBJ) (FUNCALL (FORMATTER "~:<~W~^ ~:I~@_~/xp:bind-list/~^ ~_~:/xp:pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>") XP OBJ))
+
+(DEFUN FLET-PRINT (XP OBJ) (FUNCALL (FORMATTER "~:<~1I~W~^ ~@_~:<~@{~/xp:block-like/~^ ~_~}~:>~^~@{ ~_~W~^~}~:>") XP OBJ))
+
+(DEFUN FUNCTION-PRINT (XP LIST) (IF (AND (CONSP (CDR LIST)) (NULL (CDDR LIST))) (FUNCALL (FORMATTER "#'~W") XP (CADR LIST)) (FN-CALL XP LIST)))
+
+(DEFUN MVB-PRINT (XP LIST) (PRINT-FANCY-FN-CALL XP LIST (QUOTE (1 3 2 1))))
+
+(DEFUN PROG-PRINT (XP LIST) (LET ((NEED-NEWLINE T) (INDENTATION (1+ (LENGTH (SYMBOL-NAME (CAR LIST)))))) (DECLARE (SPECIAL NEED-NEWLINE INDENTATION)) (FUNCALL (FORMATTER "~:<~W~^ ~:/xp:pprint-fill/~^ ~@{~/xp:maybelab/~^ ~}~:>") XP LIST)))
+
+(DEFUN SETQ-PRINT (XP OBJ) (FUNCALL (FORMATTER "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>") XP OBJ))
+
+(DEFUN QUOTE-PRINT (XP LIST) (IF (AND (CONSP (CDR LIST)) (NULL (CDDR LIST))) (FUNCALL (FORMATTER "'~W") XP (CADR LIST)) (PPRINT-FILL XP LIST)))
+
+(DEFUN TAGBODY-PRINT (XP LIST) (LET ((NEED-NEWLINE (AND (CONSP (CDR LIST)) (SYMBOLP (CADR LIST)) (CADR LIST))) (INDENTATION (1+ (LENGTH (SYMBOL-NAME (CAR LIST)))))) (DECLARE (SPECIAL NEED-NEWLINE INDENTATION)) (FUNCALL (FORMATTER "~:<~W~^ ~@{~/xp:maybelab/~^ ~}~:>") XP LIST)))
+
+(DEFUN UP-PRINT (XP LIST) (PRINT-FANCY-FN-CALL XP LIST (QUOTE (0 3 1 1))))
+
+
+
+(IL:* IL:|;;| 
+"here is some simple stuff for printing LOOP The challange here is that we have to effectively parse the clauses of the loop in order to know how to print things.  Also you want to do this in a  purely incremental way so that all of the abbreviation things work, and you wont blow up on circular lists or the like.  (More aesthic output could be produced by really parsing the clauses into nested lists before printing them.) The following program assumes the following simplified grammar of the loop clauses that explains how to print them.  Note that it does not bare much resemblence to the right parsing grammar, however, it produces half decent output.  The way to make the output better is to make the grammar more detailed.    loop == (LOOP {clause}*)      ;one clause on each line. clause == block | linear | cond | finally block == block-head {expr}*   ;as many exprs as possible on each line. linear == linear-head {expr}* ;one expr on each line. finally == FINALLY [DO | DOING | RETURN] {expr}* ;one expr on each line. cond == cond-head [expr]          clause 	   {AND clause}*       ;one AND on each line.        [ELSE          clause 	   {AND clause}*]      ;one AND on each line.        [END] block-head == FOR | AS | WITH | AND              | REPEAT | NAMED | WHILE | UNTIL | ALWAYS | NEVER | THEREIS | RETURN              | COLLECT | COLLECTING | APPEND | APPENDING | NCONC | NCONCING | COUNT              | COUNTING | SUM | SUMMING | MAXIMIZE | MAXIMIZING | MINIMIZE | MINIMIZING  linear-head == DO | DOING | INITIALLY var-head == FOR | AS | WITH cond-head == IF | WHEN | UNLESS expr == <anything that is not a head symbol> Note all the string comparisons below are required to support some existing implementations of LOOP."
+)
+
+
+(DEFUN TOKEN-TYPE (TOKEN &AUX STRING) (COND ((NOT (SYMBOLP TOKEN)) :EXPR) ((STRING= (SETQ STRING (STRING TOKEN)) "FINALLY") :FINALLY) ((MEMBER STRING (QUOTE ("IF" "WHEN" "UNLESS")) :TEST (FUNCTION STRING=)) :COND-HEAD) ((MEMBER STRING (QUOTE ("DO" "DOING" "INITIALLY")) :TEST (FUNCTION STRING=)) :LINEAR-HEAD) ((MEMBER STRING (QUOTE ("FOR" "AS" "WITH" "AND" "END" "ELSE" "REPEAT" "NAMED" "WHILE" "UNTIL" "ALWAYS" "NEVER" "THEREIS" "RETURN" "COLLECT" "COLLECTING" "APPEND" "APPENDING" "NCONC" "NCONCING" "COUNT" "COUNTING" "SUM" "SUMMING" "MAXIMIZE" "MAXIMIZING" "MINIMIZE" "MINIMIZING")) :TEST (FUNCTION STRING=)) :BLOCK-HEAD) (T :EXPR)))
+
+(DEFUN PRETTY-LOOP (XP LOOP) (IF (NOT (AND (CONSP (CDR LOOP)) (SYMBOLP (CADR LOOP)))) (IL:* IL:\; "old-style loop") (FUNCTION-PRINT XP LOOP) (PPRINT-LOGICAL-BLOCK (XP LOOP :PREFIX "(" :SUFFIX ")") (LET (TOKEN TYPE) (LABELS ((NEXT-TOKEN NIL (PPRINT-EXIT-IF-LIST-EXHAUSTED) (SETQ TOKEN (PPRINT-POP)) (SETQ TYPE (TOKEN-TYPE TOKEN))) (PRINT-CLAUSE (XP) (CASE TYPE (:LINEAR-HEAD (PRINT-EXPRS XP NIL :MANDATORY)) (:COND-HEAD (PRINT-COND XP)) (:FINALLY (PRINT-EXPRS XP T :MANDATORY)) (OTHERWISE (PRINT-EXPRS XP NIL :FILL)))) (PRINT-EXPRS (XP SKIP-FIRST-NON-EXPR NEWLINE-TYPE) (LET ((FIRST TOKEN)) (NEXT-TOKEN) (IL:* IL:\; "so always happens no matter what") (PPRINT-LOGICAL-BLOCK (XP NIL) (WRITE FIRST :STREAM XP) (WHEN (AND SKIP-FIRST-NON-EXPR (NOT (EQ TYPE :EXPR))) (WRITE-CHAR #\Space XP) (WRITE TOKEN :STREAM XP) (NEXT-TOKEN)) (WHEN (EQ TYPE :EXPR) (WRITE-CHAR #\Space XP) (PPRINT-INDENT :CURRENT 0 XP) (LOOP (WRITE TOKEN :STREAM XP) (NEXT-TOKEN) (WHEN (NOT (EQ TYPE :EXPR)) (RETURN NIL)) (WRITE-CHAR #\Space XP) (PPRINT-NEWLINE NEWLINE-TYPE XP)))))) (PRINT-COND (XP) (LET ((FIRST TOKEN)) (NEXT-TOKEN) (IL:* IL:\; "so always happens no matter what") (PPRINT-LOGICAL-BLOCK (XP NIL) (WRITE FIRST :STREAM XP) (WHEN (EQ TYPE :EXPR) (WRITE-CHAR #\Space XP) (WRITE TOKEN :STREAM XP) (NEXT-TOKEN)) (WRITE-CHAR #\Space XP) (PPRINT-INDENT :BLOCK 2 XP) (PPRINT-NEWLINE :LINEAR XP) (PRINT-CLAUSE XP) (PRINT-AND-LIST XP) (WHEN (STRING= (STRING TOKEN) "ELSE") (PRINT-ELSE-OR-END XP) (WRITE-CHAR #\Space XP) (PPRINT-NEWLINE :LINEAR XP) (PRINT-CLAUSE XP) (PRINT-AND-LIST XP)) (WHEN (STRING= (STRING TOKEN) "END") (PRINT-ELSE-OR-END XP))))) (PRINT-AND-LIST (XP) (LOOP (WHEN (NOT (STRING= (STRING TOKEN) "AND")) (RETURN NIL)) (WRITE-CHAR #\Space XP) (PPRINT-NEWLINE :MANDATORY XP) (WRITE TOKEN :STREAM XP) (NEXT-TOKEN) (WRITE-CHAR #\Space XP) (PRINT-CLAUSE XP))) (PRINT-ELSE-OR-END (XP) (WRITE-CHAR #\Space XP) (PPRINT-INDENT :BLOCK 0 XP) (PPRINT-NEWLINE :LINEAR XP) (WRITE TOKEN :STREAM XP) (NEXT-TOKEN) (PPRINT-INDENT :BLOCK 2 XP))) (PPRINT-EXIT-IF-LIST-EXHAUSTED) (WRITE (PPRINT-POP) :STREAM XP) (NEXT-TOKEN) (WRITE-CHAR #\Space XP) (PPRINT-INDENT :CURRENT 0 XP) (LOOP (PRINT-CLAUSE XP) (WRITE-CHAR #\Space XP) (PPRINT-NEWLINE :LINEAR XP)))))))
+
+
+
+(IL:* IL:|;;| 
+"Backquote-printing is easy for us, since the read macros just expand into simple wrappers.")
+
+
+(DEFUN BQ-PRINT (XP LIST) (IF (AND (CONSP (CDR LIST)) (NULL (CDDR LIST))) (FUNCALL (FORMATTER "`~W") XP (CADR LIST)) (PPRINT-FILL XP LIST)))
+
+(DEFUN BQ-COMMA-PRINT (XP LIST) (IF (AND (CONSP (CDR LIST)) (NULL (CDDR LIST))) (FUNCALL (FORMATTER ",~W") XP (CADR LIST)) (PPRINT-FILL XP LIST)))
+
+(DEFUN BQ-COMMA@-PRINT (XP LIST) (IF (AND (CONSP (CDR LIST)) (NULL (CDDR LIST))) (FUNCALL (FORMATTER ",@~W") XP (CADR LIST)) (PPRINT-FILL XP LIST)))
+
+
+
+(IL:* IL:|;;| 
+"This method of handling Interlisp comments sucks, BUT there is no way under XP to temporarily ignore an existing per-line-prefix, which is what you would have to do to get ;;; and ;;;; comments to go to the left margin.  Phooey!"
+)
+
+
+(DEFUN IL-COMMENT (XP THING) (IL:* IL:\; "Edited  8-Jul-92 13:44 by jrb:") (POP THING) (IL:* IL:\; "Flush the IL:*") (FLET ((HOSE-COMMENT-STRING (S) (DO ((START (POSITION #\Space S :TEST (QUOTE IL:NEQ))) (END)) ((NULL START)) (IF (SETQ END (POSITION #\Space S :START START)) (PROGN (CL:WRITE-STRING S XP :START START :END (1+ END)) (WHEN (SETQ START (POSITION #\Space S :START END :TEST (QUOTE IL:NEQ))) (PPRINT-NEWLINE :FILL XP))) (PROGN (CL:WRITE-STRING S XP :START START) (SETQ START NIL)))))) (IL:* IL:|;;| "This method of handling Interlisp comments sucks, BUT there is no way under XP to temporarily ignore an existing per-line-prefix, which is what you would have to do to get ;;; and ;;;; comments to go to the left margin.  Phooey!") (LET (PER-LINE-PREFIX) (CASE (CAR THING) ((IL:\; IL:|;;| IL:|;;;| IL:|;;;;|) (SETQ PER-LINE-PREFIX (CONCATENATE (QUOTE STRING) (SYMBOL-NAME (CAR THING) " ")))) (IL:* IL:|;;| "Last two cases have their own logical blocks, since they either have weird :PREFIX/:SUFFIXes or aren't strings") (IL:\| (IL:* IL:\; "a #|ignore everything|#") (CL:FRESH-LINE XP) (PPRINT-LOGICAL-BLOCK (XP NIL :PREFIX "#|" :SUFFIX "|#") (HOSE-COMMENT-STRING (CADR THING)))) (T (IL:* IL:|;;| "an OLD-style comment; punt and use ;;, but just use PPRINT-FILL since the body of the comment is not a string") (PPRINT-LOGICAL-BLOCK (XP NIL :PER-LINE-PREFIX ";; ") (PPRINT-FILL XP THING NIL)))) (WHEN PER-LINE-PREFIX (PPRINT-LOGICAL-BLOCK (XP NIL :PER-LINE-PREFIX PER-LINE-PREFIX) (HOSE-COMMENT-STRING (CADR THING)))) (PPRINT-NEWLINE :MANDATORY XP) (IL:* IL:\; "ALWAYS end comments with a newline"))))
+
+(SETQ *IPD* (MAKE-PPRINT-DISPATCH))
+
+(XCL:DEF-DEFINE-TYPE INITIAL-DISPATCH "XP initial pretty-print dispatch entries")
+
+(XCL:DEFDEFINER SET-PPD-IPD INITIAL-DISPATCH (TYPE-SPECIFIER FUNCTION &OPTIONAL (PRIORITY (QUOTE (0)))) (IL:BQUOTE (SET-PPRINT-DISPATCH+ (QUOTE (IL:\\\, TYPE-SPECIFIER)) (IL:\\\, FUNCTION) (IL:\\\, PRIORITY) *IPD*)))
+
+(SET-PPD-IPD (SATISFIES FUNCTION-CALL-P) (FUNCTION FN-CALL) (QUOTE (-5)))
+
+(SET-PPD-IPD CONS (FUNCTION PPRINT-FILL) (QUOTE (-10)))
+
+(SET-PPD-IPD (CONS (MEMBER DEFSTRUCT)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER BLOCK)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER CASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER CATCH)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER CCASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER COMPILER-LET)) (FUNCTION LET-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER COND)) (FUNCTION COND-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER CTYPECASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DEFCONSTANT)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DEFINE-SETF-METHOD)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DEFMACRO)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DEFINE-MODIFY-MACRO)) (FUNCTION DMM-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DEFPARAMETER)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DEFSETF)) (FUNCTION DEFSETF-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DEFINE-SETF-METHOD)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER CL:DEFSTRUCT)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DEFTYPE)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DEFUN)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DEFVAR)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DO)) (FUNCTION DO-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DO*)) (FUNCTION DO-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DO-ALL-SYMBOLS)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DO-EXTERNAL-SYMBOLS)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DO-SYMBOLS)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DOLIST)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER DOTIMES)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER ECASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER ETYPECASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER EVAL-WHEN)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER FLET)) (FUNCTION FLET-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER FUNCTION)) (FUNCTION FUNCTION-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER LABELS)) (FUNCTION FLET-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER LAMBDA)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER LET)) (FUNCTION LET-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER LET*)) (FUNCTION LET-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER LOCALLY)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER LOOP)) (FUNCTION PRETTY-LOOP) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER MACROLET)) (FUNCTION FLET-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER MULTIPLE-VALUE-BIND)) (FUNCTION MVB-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER MULTIPLE-VALUE-SETQ)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER PROG)) (FUNCTION PROG-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER PROG*)) (FUNCTION PROG-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER PROGV)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER PSETF)) (FUNCTION SETQ-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER PSETQ)) (FUNCTION SETQ-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER QUOTE)) (FUNCTION QUOTE-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER RETURN-FROM)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER SETF)) (FUNCTION SETQ-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER SETQ)) (FUNCTION SETQ-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER TAGBODY)) (FUNCTION TAGBODY-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER THROW)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER TYPECASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER UNLESS)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER UNWIND-PROTECT)) (FUNCTION UP-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER WHEN)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER WITH-INPUT-FROM-STRING)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER WITH-OPEN-FILE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER WITH-OPEN-STREAM)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER WITH-OUTPUT-TO-STRING)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
+
+
+
+(IL:* IL:|;;| 
+"Interlisp-specific entries in the original table; we need a bunch more of these, and a MUCH better way to print Interlisp comments"
+)
+
+
+(SET-PPD-IPD (CONS (MEMBER IL:*)) (FUNCTION IL-COMMENT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER IL:BQUOTE)) (FUNCTION BQ-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER IL:\\\,)) (FUNCTION BQ-COMMA-PRINT) (QUOTE (0)))
+
+(SET-PPD-IPD (CONS (MEMBER IL:\\\,@)) (FUNCTION BQ-COMMA@-PRINT) (QUOTE (0)))
+
+(DEFUN PPRINT-DISPATCH-PRINT (XP TABLE) (DECLARE (IGNORE LEVEL)) (LET ((STUFF (COPY-LIST (OTHERS TABLE)))) (MAPHASH (FUNCTION (LAMBDA (KEY VAL) (DECLARE (IGNORE KEY)) (PUSH VAL STUFF))) (CONSES-WITH-CARS TABLE)) (MAPHASH (FUNCTION (LAMBDA (KEY VAL) (DECLARE (IGNORE KEY)) (PUSH VAL STUFF))) (STRUCTURES TABLE)) (SETQ STUFF (SORT STUFF (FUNCTION PRIORITY->) :KEY (FUNCTION (LAMBDA (X) (CAR (FULL-SPEC X)))))) (PPRINT-LOGICAL-BLOCK (XP STUFF :PREFIX "#<" :SUFFIX ">") (FORMAT XP (FORMATTER "pprint dispatch table containing ~A entries: ") (LENGTH STUFF)) (LOOP (PPRINT-EXIT-IF-LIST-EXHAUSTED) (LET ((ENTRY (PPRINT-POP))) (FORMAT XP (FORMATTER "~{~_P=~4D ~W~} F=~W ") (FULL-SPEC ENTRY) (FN ENTRY)))))))
+
+(SETF (GET (QUOTE PPRINT-DISPATCH) (QUOTE CL::STRUCTURE-PRINTER)) (FUNCTION PPRINT-DISPATCH-PRINT))
+
+(SET-PPD-IPD PPRINT-DISPATCH (FUNCTION PPRINT-DISPATCH-PRINT) (QUOTE (0)))
+
+
+
+(IL:* IL:\; "so only happens first time is loaded.")
+
+
+(WHEN (EQ *PRINT-PPRINT-DISPATCH* T) (SETQ *PRINT-PPRINT-DISPATCH* (COPY-PPRINT-DISPATCH NIL)))
+
+
+
+(IL:* IL:|;;| 
+"changes since last documentation. ~/fn/ only refers to global function values, not lexical. ------------------------------------------------------------------------ Copyright 1989,1990 by the Massachusetts Institute of Technology, Cambridge,  Massachusetts. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that this copyright and permission notice appear in all copies and supporting documentation, and that the name of M.I.T. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. M.I.T. makes no representations about the suitability of this software for any purpose.  It is provided \"as is\" without express or implied warranty.    M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL    M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,    ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS    SOFTWARE. ------------------------------------------------------------------------"
+)
+
+
+(IL:PUTPROPS IL:XP IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (CL:DEFPACKAGE "XP" (:USE "LISP") (:SHADOW "CLEAR-OUTPUT" "FORCE-OUTPUT" "FINISH-OUTPUT" "DEFSTRUCT" "FRESH-LINE" "TERPRI" "WRITE-CHAR" "WRITE-STRING" "WRITE-LINE" "PRIN1-TO-STRING" "PRINC-TO-STRING" "WRITE-TO-STRING" "FORMAT" "PPRINT" "PRINC" "PRIN1" "PRINT" "WRITE") (:IMPORT-FROM "COMMON-LISP" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" "*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT" "PPRINT-NEWLINE" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR" "PPRINT-LINEAR" "PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" "FORMATTER") (:EXPORT "*PRINT-SHARED*" "*LAST-ABBREVIATED-PRINTING*" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" "*DEFAULT-RIGHT-MARGIN*" "*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT" "PPRINT-NEWLINE" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR" "PPRINT-LINEAR" "PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" "FORMATTER")) :BASE 10))
+
+(IL:PUTPROPS IL:XP IL:FILETYPE :COMPILE-FILE)
+(IL:PUTPROPS IL:XP IL:COPYRIGHT ("Venue Corporation" 1990 1991 1992 1993))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/XP-PACKAGE b/CLTL2/XP-PACKAGE
new file mode 100644
index 00000000..54b5c1eb
--- /dev/null
+++ b/CLTL2/XP-PACKAGE
@@ -0,0 +1,31 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "XP" (USE "LISP") (SHADOW "CLEAR-OUTPUT" 
+"FORCE-OUTPUT" "FINISH-OUTPUT" "DEFSTRUCT" "FRESH-LINE" "TERPRI" "WRITE-CHAR" "WRITE-STRING" 
+"WRITE-LINE" "PRIN1-TO-STRING" "PRINC-TO-STRING" "WRITE-TO-STRING" "FORMAT" "PPRINT" "PRINC" "PRIN1" 
+"PRINT" "WRITE") (IMPORT-FROM "COMMON-LISP" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" 
+"*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT" "PPRINT-NEWLINE" 
+"PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR" "PPRINT-LINEAR" 
+"PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" "FORMATTER") (EXPORT 
+"*PRINT-SHARED*" "*LAST-ABBREVIATED-PRINTING*" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" 
+"*DEFAULT-RIGHT-MARGIN*" "*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT"
+ "PPRINT-NEWLINE" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR"
+ "PPRINT-LINEAR" "PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" 
+"FORMATTER")) BASE 10)
+(IL:FILECREATED " 8-Jul-92 14:04:20" IL:|{DSK}<usr>local>lde>lispcore>sources>XP-PACKAGE.;4| 2828   
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:XP-PACKAGECOMS) (IL:PROPS (IL:XP-PACKAGE IL:MAKEFILE-ENVIRONMENT))
+
+      IL:|previous| IL:|date:| "26-Oct-91 20:32:58" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>XP-PACKAGE.;1|)
+
+
+; Copyright (c) 1991, 1992 by Venue Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:XP-PACKAGECOMS)
+
+(IL:RPAQQ IL:XP-PACKAGECOMS ((IL:PROP (IL:MAKEFILE-ENVIRONMENT) IL:XP-PACKAGE)))
+
+(IL:PUTPROPS IL:XP-PACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (CL:DEFPACKAGE "XP" (:USE "LISP") (:SHADOW "CLEAR-OUTPUT" "FORCE-OUTPUT" "FINISH-OUTPUT" "DEFSTRUCT" "FRESH-LINE" "TERPRI" "WRITE-CHAR" "WRITE-STRING" "WRITE-LINE" "PRIN1-TO-STRING" "PRINC-TO-STRING" "WRITE-TO-STRING" "FORMAT" "PPRINT" "PRINC" "PRIN1" "PRINT" "WRITE") (:IMPORT-FROM "COMMON-LISP" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" "*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT" "PPRINT-NEWLINE" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR" "PPRINT-LINEAR" "PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" "FORMATTER") (:EXPORT "*PRINT-SHARED*" "*LAST-ABBREVIATED-PRINTING*" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" "*DEFAULT-RIGHT-MARGIN*" "*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT" "PPRINT-NEWLINE" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR" "PPRINT-LINEAR" "PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" "FORMATTER")) :BASE 10))
+(IL:PUTPROPS IL:XP-PACKAGE IL:COPYRIGHT ("Venue Corporation" 1991 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/CLTL2/XP-PACKAGE.LCOM b/CLTL2/XP-PACKAGE.LCOM
new file mode 100644
index 00000000..1ebce97d
--- /dev/null
+++ b/CLTL2/XP-PACKAGE.LCOM
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (|:DEFPACKAGE "XP" (USE "LISP") (SHADOW "CLEAR-OUTPUT" 
"FORCE-OUTPUT" "FINISH-OUTPUT" "DEFSTRUCT" "FRESH-LINE" "TERPRI" "WRITE-CHAR" "WRITE-STRING" 
"WRITE-LINE" "PRIN1-TO-STRING" "PRINC-TO-STRING" "WRITE-TO-STRING" "FORMAT" "PPRINT" "PRINC" "PRIN1" 
"PRINT" "WRITE") (IMPORT-FROM "COMMON-LISP" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" 
"*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT" "PPRINT-NEWLINE" 
"PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR" "PPRINT-LINEAR" 
"PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" "FORMATTER") (EXPORT 
"*PRINT-SHARED*" "*LAST-ABBREVIATED-PRINTING*" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" 
"*DEFAULT-RIGHT-MARGIN*" "*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT"
 "PPRINT-NEWLINE" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR"
 "PPRINT-LINEAR" "PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" 
"FORMATTER")) BASE 10)
(IL:FILECREATED "12-Nov-93 15:23:57" ("compiled on " 
IL:|{DSK}<king>export>lispcore>sources>CLTL2>XP-PACKAGE.;1|) "11-Nov-93 16:58:33" IL:|bcompl'd| IL:|in|
 "Medley 11-Nov-93 ..." IL:|dated| "11-Nov-93 17:07:44")
(IL:FILECREATED " 8-Jul-92 14:04:20" IL:|{DSK}<usr>local>lde>lispcore>sources>XP-PACKAGE.;4| 2828 
IL:|changes| IL:|to:| (IL:VARS IL:XP-PACKAGECOMS) (IL:PROPS (IL:XP-PACKAGE IL:MAKEFILE-ENVIRONMENT)) 
IL:|previous| IL:|date:| "26-Oct-91 20:32:58" IL:|{DSK}<usr>local>lde>lispcore>sources>XP-PACKAGE.;1|)
(IL:PRETTYCOMPRINT IL:XP-PACKAGECOMS)
(IL:RPAQQ IL:XP-PACKAGECOMS ((IL:PROP (IL:MAKEFILE-ENVIRONMENT) IL:XP-PACKAGE)))
(IL:PUTPROPS IL:XP-PACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "XP" (:USE 
"LISP") (:SHADOW "CLEAR-OUTPUT" "FORCE-OUTPUT" "FINISH-OUTPUT" "DEFSTRUCT" "FRESH-LINE" "TERPRI" 
"WRITE-CHAR" "WRITE-STRING" "WRITE-LINE" "PRIN1-TO-STRING" "PRINC-TO-STRING" "WRITE-TO-STRING" 
"FORMAT" "PPRINT" "PRINC" "PRIN1" "PRINT" "WRITE") (:IMPORT-FROM "COMMON-LISP" "*PRINT-LINES*" 
"*PRINT-MISER-WIDTH*" "*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT" 
"PPRINT-NEWLINE" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR" 
"PPRINT-LINEAR" "PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" 
"FORMATTER") (:EXPORT "*PRINT-SHARED*" "*LAST-ABBREVIATED-PRINTING*" "*PRINT-LINES*" 
"*PRINT-MISER-WIDTH*" "*DEFAULT-RIGHT-MARGIN*" "*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" 
"PPRINT-TAB" "PPRINT-INDENT" "PPRINT-NEWLINE" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" 
"PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR" "PPRINT-LINEAR" "PPRINT-FILL" "SET-PPRINT-DISPATCH" 
"PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" "FORMATTER")) :BASE 10))
(IL:PUTPROPS IL:XP-PACKAGE IL:COPYRIGHT ("Venue Corporation" 1991 1992))
IL:NIL
\ No newline at end of file
diff --git a/CLTL2/XP.LCOM b/CLTL2/XP.LCOM
new file mode 100644
index 00000000..810f1b3d
--- /dev/null
+++ b/CLTL2/XP.LCOM
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (|:DEFPACKAGE "XP" (USE "LISP") (SHADOW "CLEAR-OUTPUT" 
"FORCE-OUTPUT" "FINISH-OUTPUT" "DEFSTRUCT" "FRESH-LINE" "TERPRI" "WRITE-CHAR" "WRITE-STRING" 
"WRITE-LINE" "PRIN1-TO-STRING" "PRINC-TO-STRING" "WRITE-TO-STRING" "FORMAT" "PPRINT" "PRINC" "PRIN1" 
"PRINT" "WRITE") (IMPORT-FROM "COMMON-LISP" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" 
"*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT" "PPRINT-NEWLINE" 
"PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR" "PPRINT-LINEAR" 
"PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" "FORMATTER") (EXPORT 
"*PRINT-SHARED*" "*LAST-ABBREVIATED-PRINTING*" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" 
"*DEFAULT-RIGHT-MARGIN*" "*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT"
 "PPRINT-NEWLINE" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR"
 "PPRINT-LINEAR" "PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" 
"FORMATTER")) BASE 10)
(IL:FILECREATED "12-Nov-93 15:21:42" ("compiled on " IL:|{DSK}<king>export>lispcore>sources>CLTL2>XP.;1|
) "11-Nov-93 16:58:33" IL:|bcompl'd| IL:|in| "Medley 11-Nov-93 ..." IL:|dated| "11-Nov-93 17:07:44")
(IL:FILECREATED " 4-Feb-93 15:08:51" IL:|{DSK}<usr>local>lde>lispcore>sources>XP.;12| 152559 
IL:|changes| IL:|to:| (IL:FUNCTIONS DEF-FORMAT-HANDLER BQ-PRINT BQ-COMMA-PRINT BQ-COMMA@-PRINT) (
INITIAL-DISPATCH (CONS (MEMBER IL:BQUOTE)) (CONS (MEMBER IL:\\\,)) (CONS (MEMBER IL:\\\,@))) (
FORMAT-HANDLERS #\/) (IL:VARS IL:XPCOMS) (IL:VARIABLES *FAST-FORMATTER-SLASH-CALL* 
*FORMATTER-SLASH-PARANOIA* *FORMATTER-SLASH-PARANOIA-LIST*) IL:|previous| IL:|date:| 
"10-Jul-92 11:51:54" IL:|{DSK}<usr>local>lde>lispcore>sources>XP.;10|)
(IL:PRETTYCOMPRINT IL:XPCOMS)
(IL:RPAQQ IL:XPCOMS ((IL:* IL:|;;| 
"------------------------------------------------------------------------ Copyright 1989,1990 by the Massachusetts Institute of Technology, Cambridge,  Massachusetts. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that this copyright and permission notice appear in all copies and supporting documentation, and that the name of M.I.T. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. M.I.T. makes no representations about the suitability of this software for any purpose.  It is provided \"as is\" without express or implied warranty.    M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL    M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,    ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS    SOFTWARE. ------------------------------------------------------------------------ This file \"XP.LISP\" implements an efficient pretty printer for Common Lisp.  The functions in this file are documented fully in MIT/AIM-1102a, July 1989.  This report can be obtained by sending $3.25 to              Publications 	       MIT AI Laboratory 	       545 Tech. Sq. 	       Cambridge MA 02139 This file attempts to be as compatible with pure Common Lisp as possible. It has been tested on the following Common Lisps to date (7/31/89).  Symbolics CL version 7 (does not work in version 6),  LUCID CL version 3.0.2 on a sun.  Allegro CL version 1.2.1 on a Macintosh.  CMU CL. The companion file \"XPTEST.LISP\" contains a set of 600+ tests.  You should run these tests after the first time you compile this file on a new system. The companion file \"XPDOC.TXT\" contains brief documentation."
) (IL:VARIABLES *XP-PRINTING-FUNCTIONS*) (IL:* IL:|;;| 
"must do the following in common lisps not supporting *print-shared*") (IL:VARIABLES *PRINT-SHARED*) (
IL:VARIABLES *PRINT-PPRINT-DISPATCH* *PRINT-RIGHT-MARGIN* *PRINT-MISER-WIDTH* *PRINT-LINES* 
*DEFAULT-RIGHT-MARGIN* *LAST-ABBREVIATED-PRINTING* *IPD* *CURRENT-LEVEL* *CURRENT-LENGTH* 
*ABBREVIATION-HAPPENED* *RESULT*) (IL:* IL:|;;| 
"default (bad) definitions for the non-portable functions") (IL:FUNCTIONS STRUCTURE-TYPE-P 
OUTPUT-WIDTH OUTPUT-POSITION) (IL:* IL:|;;| 
"XP is being considered for inclusion in Lucid Common Lisp. The prime contact there is Eric Benson \"eb@lucid.com\"."
) (IL:* IL:|;;| 
"XP is being included in CMU's Common Lisp. The prime contact there is Bill Chiles \"chiles@cs.cmu.edu\" and/or Blain Burks \"mbb@cs.cmu.edu\"."
) (IL:* IL:|;;| 
"Definitions for FRANZ Common Lisp. (Only verified for the version 1.3 (5/31/87) currently running on suns at MIT.)"
) (IL:* IL:|;;| 
"Joachim Laubsch <laubsch%hpljl@hplabs.hp.com> is the contact at HP Labs. He reports that HP COMMON LISP II Development Environment Rev A.02.15 11/10/88 requires the following patch due to a bug in REPLACE:"
) (IL:* IL:|;;| 
"JRB - Here is the Medley-specific code for XP.  There have also been a few #+ hacks inserted into things like WRITE+"
) (IL:VARIABLES *XP-STREAM-DEVICE*) (IL:FUNCTIONS XP-STREAM-OUTCHARFN XP-STREAM-DEVICE-CLOSEFILE) (
IL:FUNCTIONS INSTALL) (IL:VARIABLES *LOCATING-CIRCULARITIES* *PARENTS* *CIRCULARITY-HASH-TABLE*) (IL:*
 IL:|;;| 
"When an entry is first made it is zero. If a duplicate is found, a positive integer tag is assigned. After the first time the object is printed out, the tag is negated."
) (IL:VARIABLES *FREE-CIRCULARITY-HASH-TABLES*) (IL:* IL:\; "never bound") (IL:FUNCTIONS 
GET-CIRCULARITY-HASH-TABLE) (IL:* IL:|;;| 
"If you call this, then the table gets efficiently recycled.") (IL:FUNCTIONS 
FREE-CIRCULARITY-HASH-TABLE) (IL:* IL:|;;| "                      ---- DISPATCHING ----") (IL:STRUCTURES
 PPRINT-DISPATCH) (IL:* IL:|;;| 
"The list and the hash-tables contain entries of the following form.  When stored in the hash tables, the test entry is  the number of entries in the OTHERS list that have a higher priority."
) (IL:STRUCTURES ENTRY) (IL:* IL:\; "list of priority and type specifier") (IL:FUNCTIONS 
COPY-PPRINT-DISPATCH SET-PPRINT-DISPATCH SET-PPRINT-DISPATCH+ PRIORITY-> ADJUST-COUNTS PPRINT-DISPATCH
 GET-PRINTER FITS SPECIFIER-CATEGORY) (IL:VARIABLES *PREDS-FOR-SPECS*) (IL:FUNCTIONS ALWAYS-TRUE 
SPECIFIER-FN CONVERT-BODY) (IL:* IL:|;;| 
"              ---- XP STRUCTURES, AND THE INTERNAL ALGORITHM ----") (IL:* IL:\; 
"not used at run time.") (IL:VARIABLES BLOCK-STACK-ENTRY-SIZE PREFIX-STACK-ENTRY-SIZE QUEUE-ENTRY-SIZE
 BUFFER-ENTRY-SIZE PREFIX-ENTRY-SIZE SUFFIX-ENTRY-SIZE) (IL:* IL:\; "used at run time") (IL:VARIABLES 
BLOCK-STACK-MIN-SIZE PREFIX-STACK-MIN-SIZE QUEUE-MIN-SIZE BUFFER-MIN-SIZE PREFIX-MIN-SIZE 
SUFFIX-MIN-SIZE) (IL:* IL:|;;| 
"Hack of the month: The following definitions are used in Medley instead of the Common Lisp strcuture definition for XP-STRUCTURE; the idea is to make an XP-STRUCTURE look like a vanilla STREAM object to as much of the system as possible; most of its funny functionality will be buried in stream functions"
) (IL:* IL:|;;| 
"We need a way to conditionalize file manager entries; I'll look into it sometime soon...") (IL:* 
IL:|;;| "Here is the DEFSTRUCT we are simulating :") (IL:* IL:|;;| "(CL:DEFSTRUCT") (IL:* IL:|;;| 
"(XP::XP-STRUCTURE (:CONC-NAME NIL) (:PRINT-FUNCTION XP::DESCRIBE-XP) #+INTERLISP (:FAST-ACCESSORS T))"
) (IL:* IL:|;;| 
"(XP::BASE-STREAM NIL) ; The stream io eventually goes to. XP::LINEL ; The line length to use for formatting."
) (IL:* IL:|;;| "XP::LINE-LIMIT ; If non-NIL the max number of lines to ; print.") (IL:* IL:|;;| 
"XP::LINE-NO ; number of next line to be printed.") (IL:* IL:|;;| 
"XP::CHAR-MODE ; NIL :UP :DOWN :CAP0 :CAP1 :CAPW XP::CHAR-MODE-COUNTER ; depth of nesting of ~(...~)")
 (IL:* IL:|;;| 
"XP::DEPTH-IN-BLOCKS ; Number of logical blocks at QRIGHT ; that are started but not ended.") (IL:* 
IL:|;;| 
"(XP::BLOCK-STACK (CL:MAKE-ARRAY #.XP::BLOCK-STACK-MIN-SIZE)) XP::BLOCK-STACK-PTR ;; This stack is pushed and popped in accordance with the way blocks are  nested at the moment ;; they are entered into the queue.  It contains the  following block specific value. ;; SECTION-START total position where the section (see AIM-1102) that is rightmost in the queue ;; started."
) (IL:* IL:|;;| 
"(XP::BUFFER (CL:MAKE-ARRAY #.XP::BUFFER-MIN-SIZE :ELEMENT-TYPE #-SYMBOLICS (QUOTE LISP:STRING-CHAR) #+SYMBOLICS 'character)) XP::CHARPOS"
) (IL:* IL:|;;| "XP::BUFFER-PTR") (IL:* IL:|;;| 
"XP::BUFFER-OFFSET ;; This is a vector of characters (eg a string) that builds up the line images that will be ;; printed out.  BUFFER-PTR is the buffer position where the next character should be inserted in ;; the string.  CHARPOS is the output character position of the first character in the buffer ;; (non-zero only if a partial line has been output).  BUFFER-OFFSET is used in computing total ;; lengths. It is changed to reflect all shifting and insertion of prefixes so that total length ;; computes things as they would be if they were  all on one line.  Positions are kept three ;; different ways Buffer position (eg BUFFER-PTR) Line position (eg (+ BUFFER-PTR CHARPOS)).  ;; Indentations are stored in this form. Total position if all on one line (eg (+ BUFFER-PTR ;; BUFFER-OFFSET))  Positions are stored in this form."
) (IL:* IL:|;;| 
"(XP::QUEUE (CL:MAKE-ARRAY #.XP::QUEUE-MIN-SIZE)) XP::QLEFT XP::QRIGHT ;; This holds a queue of action descriptors.  QLEFT and QRIGHT point to the next entry to dequeue ;; and the last entry enqueued respectively.  The queue is empty when (> QLEFT QRIGHT).  The ;; queue entries have several parts: QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK QKIND ;; :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH or :BLOCK/:CURRENT QPOS total ;; position corresponding to this entry QDEPTH depth in blocks of this entry. QEND offset to ;; entry marking end of section this entry starts. (NIL until known.) Only :start-block and ;; non-literal :newline entries can start sections. QOFFSET offset to :END-BLOCK for :START-BLOCK ;; (NIL until known). QARG for :IND indentation delta     for :START-BLOCK suffix in the block if ;; any.                      or if per-line-prefix then cons of suffix and                      ;; per-line-prefix.     for :END-BLOCK suffix for the block if any."
) (IL:* IL:|;;| 
"(XP::PREFIX (CL:MAKE-ARRAY #.XP::BUFFER-MIN-SIZE :ELEMENT-TYPE #-SYMBOLICS (QUOTE LISP:STRING-CHAR) #+SYMBOLICS 'character)) ;; this stores the prefix that should be used at the start of the line"
) (IL:* IL:|;;| "(XP::PREFIX-STACK (CL:MAKE-ARRAY #.XP::PREFIX-STACK-MIN-SIZE))") (IL:* IL:|;;| 
"XP::PREFIX-STACK-PTR ;; This stack is pushed and popped in accordance with the way blocks  are nested at the moment ;; things are taken off the queue and printed. It contains the following block specific values. ;; PREFIX-PTR current length of PREFIX. SUFFIX-PTR current length of pending suffix ;; NON-BLANK-PREFIX-PTR current length of non-blank prefix. INITIAL-PREFIX-PTR prefix-ptr at the ;; start of this block. SECTION-START-LINE line-no value at last non-literal break at this level."
) (IL:* IL:|;;| 
"(XP::SUFFIX (CL:MAKE-ARRAY #.XP::BUFFER-MIN-SIZE :ELEMENT-TYPE #-SYMBOLICS (QUOTE LISP:STRING-CHAR) #+SYMBOLICS 'character)))"
) (IL:RECORDS XP-STRUCTURE) (IL:FUNCTIONS BASE-STREAM LINEL LINE-LIMIT LINE-NO CHAR-MODE 
CHAR-MODE-COUNTER DEPTH-IN-BLOCKS BLOCK-STACK BLOCK-STACK-PTR BUFFER CHARPOS BUFFER-PTR BUFFER-OFFSET 
QUEUE QLEFT QRIGHT PREFIX PREFIX-STACK PREFIX-STACK-PTR SUFFIX MAKE-XP-STRUCTURE XP-STRUCTURE-P) (IL:*
 IL:|;;| 
"this stores the suffixes that have to be printed to close of the current open blocks.  For convenient in popping, the whole suffix is stored in reverse order."
) (IL:FUNCTIONS LP<-BP TP<-BP BP<-LP BP<-TP) (IL:* IL:|;;| 
"This does not tell you the line position you were at when the TP was set, unless there have been no newlines or indentation output  between ptr and the current output point."
) (IL:FUNCTIONS LP<-TP) (IL:* IL:|;;| 
"We don't use adjustable vectors or any of that, because we seldom have to actually extend and non-adjustable vectors are a lot faster in many Common Lisps."
) (IL:FUNCTIONS CHECK-SIZE SECTION-START PUSH-BLOCK-STACK POP-BLOCK-STACK PREFIX-PTR SUFFIX-PTR 
NON-BLANK-PREFIX-PTR INITIAL-PREFIX-PTR SECTION-START-LINE PUSH-PREFIX-STACK POP-PREFIX-STACK QTYPE 
QKIND QPOS QDEPTH QEND QOFFSET QARG) (IL:* IL:|;;| 
"we shift the queue over rather than using a circular queue because that works out to be a lot faster in practice.  Note, short printout does not ever cause a shift, and even in long printout, the queue is shifted left for free every time it happens to empty out."
) (IL:FUNCTIONS ENQUEUE QNEXT) (IL:VARIABLES *DESCRIBE-XP-STREAMS-FULLY*) (IL:FUNCTIONS DESCRIBE-XP) (
IL:* IL:|;;| 
"This maintains a list of XP structures.  We save them so that we don't have to create new ones all of the time. We have separate objects so that many can be in use at once. (Note should really be doing some locking here, but CL does not have the primitives for it.  There is a tiny probability here that two different processes could end up trying to use the same xp-stream)"
) (IL:VARIABLES *FREE-XPS*) (IL:* IL:\; "never bound") (IL:FUNCTIONS GET-PRETTY-PRINT-STREAM) (IL:* 
IL:|;;| "If you call this, the xp-stream gets efficiently recycled.") (IL:FUNCTIONS 
FREE-PRETTY-PRINT-STREAM) (IL:* IL:|;;| 
"This is called to initialize things when you start pretty printing.") (IL:FUNCTIONS INITIALIZE-XP) (
IL:* IL:|;;| 
"The char-mode stuff is a bit tricky. one can be in one of the following modes: NIL no changes to characters output. :UP CHAR-UPCASE used. :DOWN CHAR-DOWNCASE used. :CAP0 capitalize next alphanumeric letter then switch to :DOWN. :CAP1 capitalize next alphanumeric letter then switch to :CAPW :CAPW downcase letters.  When a word break letter found, switch to :CAP1. It is possible for ~(~) to be nested in a format string, but note that each mode specifies what should happen to every letter.  Therefore, inner nested modes never have any effect.  You can just ignore them."
) (IL:FUNCTIONS PUSH-CHAR-MODE POP-CHAR-MODE HANDLE-CHAR-MODE) (IL:* IL:|;;| 
":DOWN All characters output are passed through the handler above.  However, it must be noted that on-each-line prefixes are only processed in the context of the first place they appear.  They stay the same later no matter what.  Also non-literal newlines do not count as word breaks. This handles the basic outputting of characters.  note + suffix means that the stream is known to be an XP stream, all inputs are mandatory, and no error checking has to be done.  Suffix ++ additionally means that the output is guaranteed not to contain a newline char."
) (IL:FUNCTIONS WRITE-CHAR+ WRITE-STRING+) (IL:* IL:|;;| 
"note this checks (> BUFFER-PTR LINEL) instead of (> (LP<-BP) LINEL) this is important so that when things are longer than a line they end up getting printed in chunks of size LINEL."
) (IL:FUNCTIONS WRITE-CHAR++ FORCE-SOME-OUTPUT WRITE-STRING++) (IL:* IL:|;;| 
"never forces output; therefore safe to call from within output-line.") (IL:FUNCTIONS WRITE-STRING+++ 
PPRINT-TAB+) (IL:* IL:|;;| 
"note following is smallest number >= x that is a multiple of colinc  (* colinc (floor (+ x (1- colinc)) colinc))"
) (IL:FUNCTIONS PPRINT-NEWLINE+ START-BLOCK END-BLOCK PPRINT-INDENT+) (IL:* IL:|;;| 
"The next function scans the queue looking for things it can do. it keeps outputting things until the queue is empty, or it finds a place where it cannot make a decision yet."
) (IL:FUNCTIONS MAYBE-TOO-LARGE) (IL:* IL:\; "wait until later to decide.") (IL:FUNCTIONS MISERING?) (
IL:* IL:|;;| 
"If flush-out? is T and force-newlines? is NIL then the buffer, prefix-stack, and queue will be in an inconsistent state after the call. You better not call it this way except as the last act of outputting."
) (IL:FUNCTIONS ATTEMPT-TO-OUTPUT) (IL:* IL:\; "this can only be called last!") (IL:FUNCTIONS FLUSH) (
IL:* IL:\; "This prints out a line of stuff.") (IL:FUNCTIONS OUTPUT-LINE SETUP-FOR-NEXT-LINE 
SET-INDENTATION-PREFIX SET-PREFIX SET-SUFFIX REVERSE-STRING-IN-PLACE) (IL:* IL:|;;| 
"		   ---- BASIC INTERFACE FUNCTIONS ---- The internal functions in this file, and the (formatter \"...\") expansions use the '+' forms of these functions directly (which is faster) because, they do not need error checking of fancy stream coercion.  The '++' forms additionally assume the thing being output does not contain a newline."
) (IL:FUNCTIONS WRITE BASIC-WRITE MAYBE-INITIATE-XP-PRINTING) (IL:FUNCTIONS XP-PRINT) (IL:FUNCTIONS 
DECODE-STREAM-ARG DO-XP-PRINTING WRITE+ NON-PRETTY-PRINT) (IL:* IL:|;;| 
"It is vital that this function be called EXACTLY once for each occurrence of   each thing in something being printed. Returns nil if printing should just continue on.  Either it is not a duplicate, or we are in the first pass and do not know. returns :FIRST if object is first occurrence of a DUPLICATE.  (This can only be returned on a second pass.)  After an initial code (printed by this routine on the second pass)  printing should continue on for the object. returns :SUBSEQUENT if second or later occurrence.  Printing is all taken care of by this routine. Note many (maybe most) lisp implementations have characters and small numbers represented in a single word so that the are always eq when they are equal and the reader takes care of properly sharing them (just as it does with symbols). Therefore, we do not want circularity processing applied to them.  However, some kinds of numbers (e.g., bignums) undoubtedly are complex structures that the reader does not share.  However, they cannot have circular pointers in them and it is therefore probably a waste to do circularity checking on them.  In any case, it is not clear that it easy to tell exactly what kinds of numbers a given implementation of CL is going to have the reader automatically share."
) (IL:FUNCTIONS CIRCULARITY-PROCESS) (IL:* IL:|;;| 
"This prints a few very common, simple atoms very fast. Pragmatically, this turns out to be an enormous savings over going to the standard printer all the time.  There would be diminishing returns from making this work with more things, but might be worth it."
) (IL:FUNCTIONS MAYBE-PRINT-FAST PRINT-FIXNUM) (IL:* IL:|;;| 
"just wants to succeed fast in a lot of common cases. assumes no funny readtable junk for the characters shown."
) (IL:FUNCTIONS NO-ESCAPES-NEEDED PRINT PRIN1 PRINC PPRINT WRITE-TO-STRING PRINC-TO-STRING 
PRIN1-TO-STRING) (IL:* IL:|;;| 
"Any format string that is converted to a function is always printed via an XP stream (See formatter)."
) (IL:FUNCTIONS FORMAT) (IL:VARIABLES *FORMAT-STRING-CACHE*) (IL:FUNCTIONS PROCESS-FORMAT-STRING 
WRITE-LINE WRITE-STRING WRITE-CHAR TERPRI) (IL:* IL:|;;| 
"This has to violate the XP data abstraction and fool with internal stuff, in order to find out the right info to return as the result."
) (IL:FUNCTIONS FRESH-LINE) (IL:* IL:|;;| 
"Each of these causes the stream to be pessimistic and insert newlines wherever it might have to, when forcing the partial output out.  This is so that things will be in a consistent state if output continues to the stream later."
) (IL:FUNCTIONS FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT) (IL:* IL:|;;| 
"note we are assuming that if a structure is defined using xp::defstruct, then its print-function (if any) will be defined using xp::print etc."
) (IL:FUNCTIONS DEFSTRUCT SAFE-ASSOC) (IL:* IL:|;;| 
"A few helper functions.  Calls to these are generated by SET-XP-PRINTER, which handles default pretty-printing of structures"
) (IL:FUNCTIONS CL::STRUCTURE-WITH-USER-PRINTER CL::STRUCTURE-WITH-DEFAULT-PRINTER) (IL:* IL:|;;| 
"          ---- FUNCTIONAL INTERFACE TO DYNAMIC FORMATTING ---- The internal functions in this file, and the (formatter \"...\") expansions use the '+' forms of these functions directly (which is faster) because, they do not need error checking or fancy stream coercion.  The '++' forms additionally assume the thing being output does not contain a newline."
) (IL:FUNCTIONS PPRINT-LOGICAL-BLOCK) (IL:* IL:|;;| 
"Assumes var and args must be variables.  Other arguments must be literals or variables.") (IL:FUNCTIONS
 PPRINT-LOGICAL-BLOCK+ PPRINT-NEWLINE PPRINT-INDENT PPRINT-TAB) (IL:* IL:|;;| 
"                       ---- COMPILED FORMAT ---- Note that compiled format strings always print through xp streams even if they don't have any xp directives in them.  As a result, the compiled code can depend on the fact that the stream being operated on is an xp stream not an ordinary one."
) (IL:P (PROCLAIM (QUOTE (SPECIAL *STRING* *USED-ARGS* *USED-OUTER-ARGS* *USED-INITIAL* 
*GET-ARG-CAREFULLY* *INNER-END* *OUTER-END* *AT-TOP* *DEFAULT-PACKAGE*)))) (IL:VARIABLES *FN-TABLE*) (
IL:* IL:|;;| 
"Each of these functions expect to get called with two arguments start and end.  Start points to the first character after the ~ marking the command.  End points to the first character after the command.  This includes the matching end command for paired commands."
) (IL:DEFINE-TYPES FORMAT-HANDLERS) (IL:FUNCTIONS DEF-FORMAT-HANDLER FORMAT-HANDLER-UNDEFINE) (IL:* 
IL:|;;| 
"Definitions of the forms used in the code created by PARSE. Note these functions assume the stream is in the var XP and is an xp stream, INITIAL holds the initial value of ARGS (for ~@*). Initial is always bound to (args) if it is bound at all. Note this uses args, but only when actually binding"
) (IL:FUNCTIONS INITIAL BIND-INITIAL MAYBE-BIND-INITIAL) (IL:* IL:|;;| 
"ARGS holds the current argument list The val bound to args must always be computed (to use it up) even if args is not used."
) (IL:FUNCTIONS ARGS BIND-ARGS OUTER-ARGS BIND-OUTER-ARGS MAYBE-BIND MAKE-BINDING NUM-ARGS GET-ARG 
PPRINT-POP+ PPRINT-POP-CHECK+ PPRINT-POP+TOP PPRINT-POP-CHECK+TOP LITERAL) (IL:* IL:\; 
"This is available for putting on #\".") (IL:FUNCTIONS FORMAT-STRING-READER FORMATTER-IN-PACKAGE 
FORMATTER FORMATTER-FN) (IL:* IL:|;;| 
"The business with the catch above allows many (formatter \"...\") errors to be reported in a file without stopping the compilation of the file."
) (IL:FUNCTIONS MAYBE-COMPILE-FORMAT-STRING) (IL:* IL:|;;| 
"COMPILE-FORMAT gets called to turn a bit of format control string into code.") (IL:VARIABLES 
*TESTING-ERRORS*) (IL:FUNCTIONS ERR POSITION-IN POSITION-NOT-IN NEXT-DIRECTIVE1 PARAMS-END) (IL:* 
IL:|;;| "Only called after correct parse is known.") (IL:FUNCTIONS DIRECTIVE-START NEXT-DIRECTIVE) (IL:*
 IL:\; "breaks things up at ~; directives.") (IL:FUNCTIONS CHUNK-UP FANCY-DIRECTIVES-P 
NUM-ARGS-IN-ARGS COMPILE-FORMAT) (IL:* IL:|;;| 
"This gets called with start pointing to the character after the ~ that starts a command.  Defaults, is a list of default values for the parameters.  Max is the maximum number of parameters allowed.  Nocolon, noatsign, nocolonatsign can be used to specify what colon atsign combinations are permitted. Parse params returns three values, colon?, atsign? and a list of code chunks that correspond to the parameters specified."
) (IL:FUNCTIONS PARSE-PARAMS) (IL:* IL:|;;| "Both these only called if correct parse already known.") 
(IL:FUNCTIONS COLONP ATSIGNP) (IL:* IL:|;;| 
"These flags and lists control some non-spec behavior in FORMATTER's handling of the ~/.../ directive"
) (IL:VARIABLES *FAST-FORMATTER-SLASH-CALL* *FORMATTER-SLASH-PARANOIA* *FORMATTER-SLASH-PARANOIA-LIST*
) (FORMAT-HANDLERS #\/ #\A #\S) (IL:* IL:|;;| 
"The basic Format directives \"DBOXRCFEG$\".  The key thing about all of these directives is that they just get a single arg and print a chunk of stuff.  Further they are complex enough that I just call the standard definition of FORMAT to get the work done.  What should really be being called is the internal routine that FORMAT uses to do the corresponding work.  However, this cannot be done in a portable way."
) (FORMAT-HANDLERS #\D #\B #\O #\X #\R #\C #\F #\E #\G #\$) (IL:FUNCTIONS SIMPLE-DIRECTIVE 
USING-FORMAT) (IL:* IL:|;;| "Format directives that get open coded \"P%&~|T*?^\"") (FORMAT-HANDLERS 
#\P #\% #\&) (IL:FUNCTIONS MULTIPLE-NEWLINES MULTIPLE-NEWLINES1) (FORMAT-HANDLERS #\| #\~) (IL:FUNCTIONS
 MULTIPLE-CHARS MULTIPLE-CHARS1) (FORMAT-HANDLERS #\T #\*) (IL:* IL:|;;| 
"fancy stuff here, so will not get spurious indications of circularity.") (IL:FUNCTIONS BACKUP-IN-LIST
 BACKUP-TO) (IL:* IL:|;;| 
"because of backup-to, a prefix of some-tail may have been copied (in which case it cannot share anything with list), but there is a cons in some-tail that is in list.  This can be used to determine the position of some-tail relative to list.  However, we have to be careful, because they both could be cdr recursive."
) (IL:FUNCTIONS TAIL-POS) (FORMAT-HANDLERS #\? #\^) (IL:FUNCTIONS DO-COMPLEX-^-TEST) (IL:* IL:|;;| 
"delimited pairs of format directives. \"(){}[]<>;\"") (FORMAT-HANDLERS #\[ #\( #\; #\] #\) #\> #\} 
#\{ #\<) (IL:FUNCTIONS HANDLE-STANDARD-< NUM-ARGS-IN-DIRECTIVE) (IL:* IL:\; 
"The pretty-printing directives. \"_IW<:>\"") (FORMAT-HANDLERS #\_ #\I #\W) (IL:FUNCTIONS 
HANDLE-LOGICAL-BLOCK CHECK-BLOCK-ABBREVIATION FILL-TRANSFORM FILL-TRANSFORM-CHAR 
FILL-TRANSFORM-LITERAL) (IL:* IL:|;;| 
"end of eval when for all (formatter \"...\") stuff.                ---- PRETTY PRINTING FORMATS ----"
) (IL:FUNCTIONS PRETTY-ARRAY PRETTY-VECTOR PRETTY-NON-VECTOR) (IL:* IL:|;;| 
"Must use pprint-logical-block (no +) in the following three, because they are exported functions.") (
IL:FUNCTIONS PPRINT-LINEAR PPRINT-FILL PPRINT-TABULAR FN-CALL) (IL:* IL:|;;| 
"Although idiosyncratic, I have found this very useful to avoid large indentations when printing out code."
) (IL:FUNCTIONS ALTERNATIVE-FN-CALL BIND-LIST BLOCK-LIKE DEFUN-LIKE PRINT-FANCY-FN-CALL MAYBELAB 
FUNCTION-CALL-P) (IL:* IL:|;;| 
"THE FOLLOWING STUFF SETS UP THE DEFAULT *PRINT-PPRINT-DISPATCH* This is an attempt to specify a correct format for every form in the CL book that does not just get printed out like an ordinary function call  (i.e., most special forms and many macros).  This of course does not  cover anything new you define."
) (IL:FUNCTIONS LET-PRINT COND-PRINT DMM-PRINT DEFSETF-PRINT DO-PRINT FLET-PRINT FUNCTION-PRINT 
MVB-PRINT PROG-PRINT SETQ-PRINT QUOTE-PRINT TAGBODY-PRINT UP-PRINT) (IL:* IL:|;;| 
"here is some simple stuff for printing LOOP The challange here is that we have to effectively parse the clauses of the loop in order to know how to print things.  Also you want to do this in a  purely incremental way so that all of the abbreviation things work, and you wont blow up on circular lists or the like.  (More aesthic output could be produced by really parsing the clauses into nested lists before printing them.) The following program assumes the following simplified grammar of the loop clauses that explains how to print them.  Note that it does not bare much resemblence to the right parsing grammar, however, it produces half decent output.  The way to make the output better is to make the grammar more detailed.    loop == (LOOP {clause}*)      ;one clause on each line. clause == block | linear | cond | finally block == block-head {expr}*   ;as many exprs as possible on each line. linear == linear-head {expr}* ;one expr on each line. finally == FINALLY [DO | DOING | RETURN] {expr}* ;one expr on each line. cond == cond-head [expr]          clause 	   {AND clause}*       ;one AND on each line.        [ELSE          clause 	   {AND clause}*]      ;one AND on each line.        [END] block-head == FOR | AS | WITH | AND              | REPEAT | NAMED | WHILE | UNTIL | ALWAYS | NEVER | THEREIS | RETURN              | COLLECT | COLLECTING | APPEND | APPENDING | NCONC | NCONCING | COUNT              | COUNTING | SUM | SUMMING | MAXIMIZE | MAXIMIZING | MINIMIZE | MINIMIZING  linear-head == DO | DOING | INITIALLY var-head == FOR | AS | WITH cond-head == IF | WHEN | UNLESS expr == <anything that is not a head symbol> Note all the string comparisons below are required to support some existing implementations of LOOP."
) (IL:FUNCTIONS TOKEN-TYPE PRETTY-LOOP) (IL:* IL:|;;| 
"Backquote-printing is easy for us, since the read macros just expand into simple wrappers.") (
IL:FUNCTIONS BQ-PRINT BQ-COMMA-PRINT BQ-COMMA@-PRINT) (IL:* IL:|;;| 
"This method of handling Interlisp comments sucks, BUT there is no way under XP to temporarily ignore an existing per-line-prefix, which is what you would have to do to get ;;; and ;;;; comments to go to the left margin.  Phooey!"
) (IL:FUNCTIONS IL-COMMENT) (IL:P (SETQ *IPD* (MAKE-PPRINT-DISPATCH))) (IL:DEFINE-TYPES 
INITIAL-DISPATCH) (IL:FUNCTIONS SET-PPD-IPD) (INITIAL-DISPATCH (SATISFIES FUNCTION-CALL-P) CONS) (
INITIAL-DISPATCH (CONS (MEMBER DEFSTRUCT)) (CONS (MEMBER BLOCK)) (CONS (MEMBER CASE)) (CONS (MEMBER 
CATCH)) (CONS (MEMBER CCASE)) (CONS (MEMBER COMPILER-LET)) (CONS (MEMBER COND)) (CONS (MEMBER 
CTYPECASE)) (CONS (MEMBER DEFCONSTANT)) (CONS (MEMBER DEFINE-SETF-METHOD)) (CONS (MEMBER DEFMACRO)) (
CONS (MEMBER DEFINE-MODIFY-MACRO)) (CONS (MEMBER DEFPARAMETER)) (CONS (MEMBER DEFSETF)) (CONS (MEMBER 
DEFINE-SETF-METHOD)) (CONS (MEMBER CL:DEFSTRUCT)) (CONS (MEMBER DEFTYPE)) (CONS (MEMBER DEFUN)) (CONS 
(MEMBER DEFVAR)) (CONS (MEMBER DO)) (CONS (MEMBER DO*)) (CONS (MEMBER DO-ALL-SYMBOLS)) (CONS (MEMBER 
DO-EXTERNAL-SYMBOLS)) (CONS (MEMBER DO-SYMBOLS)) (CONS (MEMBER DOLIST)) (CONS (MEMBER DOTIMES)) (CONS 
(MEMBER ECASE)) (CONS (MEMBER ETYPECASE)) (CONS (MEMBER EVAL-WHEN)) (CONS (MEMBER FLET)) (CONS (MEMBER
 FUNCTION)) (CONS (MEMBER LABELS)) (CONS (MEMBER LAMBDA)) (CONS (MEMBER LET)) (CONS (MEMBER LET*)) (
CONS (MEMBER LOCALLY)) (CONS (MEMBER LOOP)) (CONS (MEMBER MACROLET)) (CONS (MEMBER MULTIPLE-VALUE-BIND
)) (CONS (MEMBER MULTIPLE-VALUE-SETQ)) (CONS (MEMBER PROG)) (CONS (MEMBER PROG*)) (CONS (MEMBER PROGV)
) (CONS (MEMBER PSETF)) (CONS (MEMBER PSETQ)) (CONS (MEMBER QUOTE)) (CONS (MEMBER RETURN-FROM)) (CONS 
(MEMBER SETF)) (CONS (MEMBER SETQ)) (CONS (MEMBER TAGBODY)) (CONS (MEMBER THROW)) (CONS (MEMBER 
TYPECASE)) (CONS (MEMBER UNLESS)) (CONS (MEMBER UNWIND-PROTECT)) (CONS (MEMBER WHEN)) (CONS (MEMBER 
WITH-INPUT-FROM-STRING)) (CONS (MEMBER WITH-OPEN-FILE)) (CONS (MEMBER WITH-OPEN-STREAM)) (CONS (MEMBER
 WITH-OUTPUT-TO-STRING))) (IL:* IL:|;;| 
"Interlisp-specific entries in the original table; we need a bunch more of these, and a MUCH better way to print Interlisp comments"
) (INITIAL-DISPATCH (CONS (MEMBER IL:*)) (CONS (MEMBER IL:BQUOTE)) (CONS (MEMBER IL:\\\,)) (CONS (
MEMBER IL:\\\,@))) (IL:FUNCTIONS PPRINT-DISPATCH-PRINT) (IL:P (SETF (GET (QUOTE PPRINT-DISPATCH) (
QUOTE CL::STRUCTURE-PRINTER)) (FUNCTION PPRINT-DISPATCH-PRINT))) (INITIAL-DISPATCH PPRINT-DISPATCH) (
IL:* IL:\; "so only happens first time is loaded.") (IL:P (WHEN (EQ *PRINT-PPRINT-DISPATCH* T) (SETQ 
*PRINT-PPRINT-DISPATCH* (COPY-PPRINT-DISPATCH IL:NIL)))) (IL:* IL:|;;| 
"changes since last documentation. ~/fn/ only refers to global function values, not lexical. ------------------------------------------------------------------------ Copyright 1989,1990 by the Massachusetts Institute of Technology, Cambridge,  Massachusetts. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that this copyright and permission notice appear in all copies and supporting documentation, and that the name of M.I.T. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. M.I.T. makes no representations about the suitability of this software for any purpose.  It is provided \"as is\" without express or implied warranty.    M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL    M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,    ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS    SOFTWARE. ------------------------------------------------------------------------"
) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:XP)))
(DEFVAR *XP-PRINTING-FUNCTIONS* (QUOTE (WRITE PRINT PRIN1 PRINC PPRINT FORMAT WRITE-TO-STRING 
PRINC-TO-STRING PRIN1-TO-STRING WRITE-LINE WRITE-STRING WRITE-CHAR TERPRI FRESH-LINE DEFSTRUCT 
FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT)) "printing functions redefined by xp.")
(DEFVAR *PRINT-SHARED* IL:NIL)
(DEFVAR *PRINT-PPRINT-DISPATCH* T (IL:* IL:\; "see initialization at end of file.") 
"controls pretty printing of output")
(DEFVAR *PRINT-RIGHT-MARGIN* IL:NIL "+#/nil the right margin for pretty printing")
(DEFVAR *PRINT-MISER-WIDTH* 40 "+#/nil miser format starts when there is less than this width left")
(DEFVAR *PRINT-LINES* IL:NIL "+#/nil truncates printing after # lines")
(DEFVAR *DEFAULT-RIGHT-MARGIN* 70 "controls default line length; must be a non-negative integer")
(DEFVAR *LAST-ABBREVIATED-PRINTING* (FUNCTION (LAMBDA (&OPTIONAL STREAM) (DECLARE (IGNORE STREAM)) 
IL:NIL)) "funcalling this redoes the last xp printing that was abbreviated.")
(DEFVAR *IPD* IL:NIL (IL:* IL:\; "see initialization at end of file.") "initial print dispatch table."
)
(DEFVAR *CURRENT-LEVEL* 0 "current depth in logical blocks.")
(DEFVAR *CURRENT-LENGTH* 0 "current position in logical block.")
(DEFVAR *ABBREVIATION-HAPPENED* IL:NIL "t if current thing being printed has been abbreviated.")
(DEFVAR *RESULT* IL:NIL "used to pass back a value")
(DEFUN STRUCTURE-TYPE-P (X) (IL:* IL:|;;| "(AND (SYMBOLP X) (GET X 'STRUCTURE-PRINTER))") (
CL::PARSED-STRUCTURE X T))
(DEFUN OUTPUT-WIDTH (&OPTIONAL (S *STANDARD-OUTPUT*)) (IL:LINELENGTH IL:NIL S))
(DEFUN OUTPUT-POSITION (&OPTIONAL (S *STANDARD-OUTPUT*)) (IL:* IL:\; "Edited  6-May-92 12:37 by jrb:")
 (IL:POSITION S))
(DEFVAR *XP-STREAM-DEVICE* (IL:* IL:|;;| 
"A first hack at integrating XP into Medley.  A stream with this as its fdev lives in the MEDLEY-STREAM slot of an XP-STRUCTURE.  Whenever XP punts in WRITE+, it just does its output to its MEDLEY-STREAM, which catches each character and calls WRITE-CHAR++; this is actually reasonably fast."
) (IL:|create| IL:FDEV IL:DEVICENAME IL:_ (QUOTE *XP-STREAM-DEVICE*) IL:RESETABLE IL:_ IL:NIL 
IL:RANDOMACCESSP IL:_ IL:NIL IL:NODIRECTORIES IL:_ T IL:BUFFERED IL:_ IL:NIL IL:PAGEMAPPED IL:_ IL:NIL
 IL:FDBINABLE IL:_ IL:NIL IL:FDBOUTABLE IL:_ IL:NIL IL:FDEXTENDABLE IL:_ IL:NIL IL:DEVICEINFO IL:_ 
IL:NIL IL:HOSTNAMEP IL:_ (IL:FUNCTION IL:NILL) IL:EVENTFN IL:_ (IL:FUNCTION IL:NILL) IL:DIRECTORYNAMEP
 IL:_ (IL:FUNCTION IL:NILL) IL:OPENFILE IL:_ (IL:FUNCTION IL:NILL) IL:REOPENFILE IL:_ (IL:FUNCTION 
IL:NILL) IL:CLOSEFILE IL:_ (IL:FUNCTION XP-STREAM-DEVICE-CLOSEFILE) IL:GETFILENAME IL:_ (IL:FUNCTION 
IL:NILL) IL:DELETEFILE IL:_ (IL:FUNCTION IL:NILL) IL:GENERATEFILES IL:_ (IL:FUNCTION 
IL:\\GENERATENOFILES) IL:RENAMEFILE IL:_ (IL:FUNCTION IL:NILL) IL:BIN IL:_ (IL:FUNCTION 
IL:\\ILLEGAL.DEVICEOP) IL:BOUT IL:_ (IL:FUNCTION IL:NILL) IL:PEEKBIN IL:_ (IL:FUNCTION 
IL:\\ILLEGAL.DEVICEOP) IL:READP IL:_ (IL:FUNCTION IL:\\ILLEGAL.DEVICEOP) IL:EOFP IL:_ (IL:FUNCTION 
IL:NILL) IL:BLOCKIN IL:_ (IL:FUNCTION IL:\\ILLEGAL.DEVICEOP) IL:BLOCKOUT IL:_ (IL:FUNCTION 
IL:\\GENERIC.BOUTS) IL:FORCEOUTPUT IL:_ (IL:FUNCTION IL:NILL) IL:GETFILEPTR IL:_ (IL:FUNCTION 
IL:\\ILLEGAL.DEVICEOP) IL:SETFILEINFO IL:_ (IL:FUNCTION IL:\\ILLEGAL.DEVICEOP)))
(DEFUN XP-STREAM-OUTCHARFN (STREAM CHARNO) (IL:* IL:|;;| 
"For the moment, keep it simple.  We'll gussy this up with block stuff later.  For now, we assume no newlines or other white-space junk in this function"
) (WRITE-CHAR++ (INT-CHAR CHARNO) STREAM))
(DEFUN XP-STREAM-DEVICE-CLOSEFILE (STREAM &OPTIONAL IL:ABORTFLAG) (IL:* IL:|;;| 
"What the heck, close the underlying \"real\" stream") (CLOSE (BASE-STREAM (IL:|fetch| IL:F1 IL:|of| 
STREAM))))
(DEFUN INSTALL (&KEY (PACKAGE *PACKAGE*) (MACRO IL:NIL) (SHADOW T) (REMOVE IL:NIL)) (WHEN (NOT (
PACKAGEP PACKAGE)) (SETQ PACKAGE (FIND-PACKAGE PACKAGE))) (WHEN (NOT REMOVE) (WHEN MACRO (
SET-DISPATCH-MACRO-CHARACTER #\# #\" (FUNCTION FORMAT-STRING-READER))) (WHEN (NOT (EQ PACKAGE (
FIND-PACKAGE "XP"))) (USE-PACKAGE "XP" PACKAGE) (WHEN SHADOW (SHADOWING-IMPORT *XP-PRINTING-FUNCTIONS*
 PACKAGE)))) (WHEN (AND REMOVE (MEMBER (FIND-PACKAGE "XP") (PACKAGE-USE-LIST PACKAGE))) (UNUSE-PACKAGE
 "XP" PACKAGE) (DOLIST (SYM (INTERSECTION *XP-PRINTING-FUNCTIONS* (PACKAGE-SHADOWING-SYMBOLS PACKAGE))
) (UNINTERN SYM PACKAGE))) T)
(DEFVAR *LOCATING-CIRCULARITIES* IL:NIL 
"Integer if making a first pass over things to identify circularities.
   Integer used as counter for #n= syntax.")
(DEFVAR *PARENTS* IL:NIL "used when *print-shared* is nil")
(DEFVAR *CIRCULARITY-HASH-TABLE* IL:NIL 
"Contains hash table used for locating circularities, or a stack.")
(DEFVAR *FREE-CIRCULARITY-HASH-TABLES* IL:NIL "free list of circularity hash tables")
(DEFUN GET-CIRCULARITY-HASH-TABLE IL:NIL (LET ((TABLE (POP *FREE-CIRCULARITY-HASH-TABLES*))) (IF TABLE
 TABLE (MAKE-HASH-TABLE :TEST (QUOTE EQ)))))
(DEFUN FREE-CIRCULARITY-HASH-TABLE (TABLE) (CLRHASH TABLE) (PUSHNEW TABLE 
*FREE-CIRCULARITY-HASH-TABLES*))
(CL:DEFSTRUCT (PPRINT-DISPATCH (:CONC-NAME IL:NIL) (:COPIER IL:NIL) (:FAST-ACCESSORS T)) (
CONSES-WITH-CARS (MAKE-HASH-TABLE :TEST (FUNCTION EQ)) :TYPE HASH-TABLE) (STRUCTURES (MAKE-HASH-TABLE 
:TEST (FUNCTION EQ)) :TYPE HASH-TABLE) (OTHERS IL:NIL :TYPE LIST))
(CL:DEFSTRUCT (ENTRY (:CONC-NAME IL:NIL) (:FAST-ACCESSORS T)) (TEST IL:NIL) (IL:* IL:|;;| 
"predicate function or count of higher priority others.") (FN IL:NIL) (IL:* IL:\; "pprint function") (
FULL-SPEC IL:NIL))
(DEFUN COPY-PPRINT-DISPATCH (&OPTIONAL (TABLE *PRINT-PPRINT-DISPATCH*)) (WHEN (NULL TABLE) (SETQ TABLE
 *IPD*)) (LET* ((NEW-CONSES-WITH-CARS (MAKE-HASH-TABLE :TEST (FUNCTION EQ) :SIZE (MAX (
HASH-TABLE-COUNT (CONSES-WITH-CARS TABLE)) 32))) (NEW-STRUCTURES (MAKE-HASH-TABLE :TEST (FUNCTION EQ) 
:SIZE (MAX (HASH-TABLE-COUNT (STRUCTURES TABLE)) 32)))) (MAPHASH (FUNCTION (LAMBDA (KEY VALUE) (SETF (
GETHASH KEY NEW-CONSES-WITH-CARS) (COPY-ENTRY VALUE)))) (CONSES-WITH-CARS TABLE)) (MAPHASH (FUNCTION (
LAMBDA (KEY VALUE) (SETF (GETHASH KEY NEW-STRUCTURES) (COPY-ENTRY VALUE)))) (STRUCTURES TABLE)) (
MAKE-PPRINT-DISPATCH :CONSES-WITH-CARS NEW-CONSES-WITH-CARS :STRUCTURES NEW-STRUCTURES :OTHERS (
COPY-LIST (OTHERS TABLE)))))
(DEFUN SET-PPRINT-DISPATCH (TYPE-SPECIFIER FUNCTION &OPTIONAL (PRIORITY 0) (TABLE 
*PRINT-PPRINT-DISPATCH*)) (WHEN (OR (NOT (NUMBERP PRIORITY)) (COMPLEXP PRIORITY)) (ERROR 
"invalid PRIORITY argument ~A to SET-PPRINT-DISPATCH" PRIORITY)) (SET-PPRINT-DISPATCH+ TYPE-SPECIFIER 
FUNCTION PRIORITY TABLE))
(DEFUN SET-PPRINT-DISPATCH+ (TYPE-SPECIFIER FUNCTION PRIORITY TABLE) (LET* ((CATEGORY (
SPECIFIER-CATEGORY TYPE-SPECIFIER)) (PRED (IF (NOT (EQ CATEGORY (QUOTE OTHER))) IL:NIL (LET ((PRED (
SPECIFIER-FN TYPE-SPECIFIER))) (IF (AND (CONSP (CADDR PRED)) (SYMBOLP (CAADDR PRED)) (EQUAL (CDADDR 
PRED) (QUOTE (X)))) (SYMBOL-FUNCTION (CAADDR PRED)) (COMPILE IL:NIL PRED))))) (ENTRY (IF FUNCTION (
MAKE-ENTRY :TEST PRED :FN FUNCTION :FULL-SPEC (LIST PRIORITY TYPE-SPECIFIER))))) (CASE CATEGORY (
CONS-WITH-CAR (COND ((NULL ENTRY) (REMHASH (CADADR TYPE-SPECIFIER) (CONSES-WITH-CARS TABLE))) (T (SETF
 (TEST ENTRY) (COUNT-IF (FUNCTION (LAMBDA (E) (PRIORITY-> (CAR (FULL-SPEC E)) PRIORITY))) (OTHERS 
TABLE))) (SETF (GETHASH (CADADR TYPE-SPECIFIER) (CONSES-WITH-CARS TABLE)) ENTRY)))) (STRUCTURE-TYPE (
COND ((NULL ENTRY) (REMHASH TYPE-SPECIFIER (STRUCTURES TABLE))) (T (SETF (TEST ENTRY) (COUNT-IF (
FUNCTION (LAMBDA (E) (PRIORITY-> (CAR (FULL-SPEC E)) PRIORITY))) (OTHERS TABLE))) (SETF (GETHASH 
TYPE-SPECIFIER (STRUCTURES TABLE)) ENTRY)))) (T (IL:* IL:\; "other") (LET ((OLD (CAR (MEMBER 
TYPE-SPECIFIER (OTHERS TABLE) :TEST (FUNCTION EQUAL) :KEY (FUNCTION (LAMBDA (E) (CADR (FULL-SPEC E))))
)))) (WHEN OLD (SETF (OTHERS TABLE) (DELETE OLD (OTHERS TABLE))) (ADJUST-COUNTS TABLE (CAR (FULL-SPEC 
OLD)) -1))) (WHEN ENTRY (LET ((OTHERS (CONS IL:NIL (OTHERS TABLE)))) (DO ((L OTHERS (CDR L))) ((NULL (
CDR L)) (RPLACD L (LIST ENTRY))) (WHEN (PRIORITY-> PRIORITY (CAR (FULL-SPEC (CADR L)))) (RPLACD L (
CONS ENTRY (CDR L))) (RETURN IL:NIL))) (SETF (OTHERS TABLE) (CDR OTHERS))) (ADJUST-COUNTS TABLE 
PRIORITY 1))))) IL:NIL)
(DEFUN PRIORITY-> (X Y) (IF (CONSP X) (IF (CONSP Y) (> (CAR X) (CAR Y)) IL:NIL) (IF (CONSP Y) T (> X Y
))))
(DEFUN ADJUST-COUNTS (TABLE PRIORITY DELTA) (MAPHASH (FUNCTION (LAMBDA (KEY VALUE) (DECLARE (IGNORE 
KEY)) (IF (PRIORITY-> PRIORITY (CAR (FULL-SPEC VALUE))) (INCF (TEST VALUE) DELTA)))) (CONSES-WITH-CARS
 TABLE)) (MAPHASH (FUNCTION (LAMBDA (KEY VALUE) (DECLARE (IGNORE KEY)) (IF (PRIORITY-> PRIORITY (CAR (
FULL-SPEC VALUE))) (INCF (TEST VALUE) DELTA)))) (STRUCTURES TABLE)))
(DEFUN PPRINT-DISPATCH (OBJECT &OPTIONAL (TABLE *PRINT-PPRINT-DISPATCH*)) (WHEN (NULL TABLE) (SETQ 
TABLE *IPD*)) (LET ((FN (GET-PRINTER OBJECT TABLE))) (VALUES (OR FN (FUNCTION NON-PRETTY-PRINT)) (NOT 
(NULL FN)))))
(DEFUN GET-PRINTER (OBJECT TABLE) (LET ((ENTRY (IF (CONSP OBJECT) (GETHASH (CAR OBJECT) (
CONSES-WITH-CARS TABLE)) (GETHASH (TYPE-OF OBJECT) (STRUCTURES TABLE))))) (IF (NOT ENTRY) (IL:* IL:|;;|
 "(SETQ ENTRY (FIND OBJECT (OTHERS TABLE) :TEST #'FITS))  ") (IL:* IL:|;;| "Equivalent code below") (
DO ((L (OTHERS TABLE) (CDR L))) ((COND ((NULL L)) ((FUNCALL (TEST (CAR L)) OBJECT) (SETQ ENTRY (CAR L)
))))) (DO ((I (TEST ENTRY) (1- I)) (L (OTHERS TABLE) (CDR L))) ((ZEROP I)) (WHEN (IL:* IL:|;;| 
"(FITS OBJECT (CAR L))") (IL:* IL:|;;| "Equivalent code below ") (FUNCALL (TEST (CAR L)) OBJECT) (SETQ
 ENTRY (CAR L)) (RETURN IL:NIL)))) (WHEN ENTRY (FN ENTRY))))
(DEFUN FITS (OBJ ENTRY) (FUNCALL (TEST ENTRY) OBJ))
(DEFUN SPECIFIER-CATEGORY (SPEC) (COND ((AND (CONSP SPEC) (EQ (CAR SPEC) (QUOTE CONS)) (CONSP (CDR 
SPEC)) (NULL (CDDR SPEC)) (CONSP (CADR SPEC)) (EQ (CAADR SPEC) (QUOTE MEMBER)) (CONSP (CDADR SPEC)) (
NULL (CDDADR SPEC))) (QUOTE CONS-WITH-CAR)) ((AND (SYMBOLP SPEC) (STRUCTURE-TYPE-P SPEC)) (QUOTE 
STRUCTURE-TYPE)) (T (QUOTE OTHER))))
(DEFVAR *PREDS-FOR-SPECS* (QUOTE ((T ALWAYS-TRUE) (CONS CONSP) (SIMPLE-ATOM SIMPLE-ATOM-P) (OTHER 
OTHERP) (NULL NULL) (SYMBOL SYMBOLP) (ATOM ATOM) (CONS CONSP) (LIST LISTP) (NUMBER NUMBERP) (INTEGER 
INTEGERP) (RATIONAL RATIONALP) (FLOAT FLOATP) (COMPLEX COMPLEXP) (CHARACTER CHARACTERP) (STRING 
STRINGP) (BIT-VECTOR BIT-VECTOR-P) (VECTOR VECTORP) (SIMPLE-VECTOR SIMPLE-VECTOR-P) (SIMPLE-STRING 
SIMPLE-STRING-P) (SIMPLE-BIT-VECTOR SIMPLE-BIT-VECTOR-P) (ARRAY ARRAYP) (PACKAGE PACKAGEP) (FUNCTION 
FUNCTIONP) (COMPILED-FUNCTION COMPILED-FUNCTION-P) (COMMON COMMONP))))
(DEFUN ALWAYS-TRUE (X) (DECLARE (IGNORE X)) T)
(DEFUN SPECIFIER-FN (SPEC) (IL:BQUOTE (LAMBDA (X) (IL:\\\, (CONVERT-BODY SPEC)))))
(DEFUN CONVERT-BODY (SPEC) (COND ((ATOM SPEC) (LET ((PRED (CADR (ASSOC SPEC *PREDS-FOR-SPECS*)))) (IF 
PRED (IL:BQUOTE ((IL:\\\, PRED) X)) (IL:BQUOTE (TYPEP X (QUOTE (IL:\\\, SPEC))))))) ((MEMBER (CAR SPEC
) (QUOTE (AND OR NOT))) (CONS (CAR SPEC) (MAPCAR (FUNCTION CONVERT-BODY) (CDR SPEC)))) ((EQ (CAR SPEC)
 (QUOTE MEMBER)) (IL:BQUOTE (MEMBER X (QUOTE (IL:\\\, (COPY-LIST (CDR SPEC))))))) ((EQ (CAR SPEC) (
QUOTE CONS)) (IL:BQUOTE (AND (CONSP X) (IL:\\\,@ (IF (CDR SPEC) (IL:BQUOTE ((LET ((X (CAR X))) (IL:\\\,
 (CONVERT-BODY (CADR SPEC)))))))) (IL:\\\,@ (IF (CDDR SPEC) (IL:BQUOTE ((LET ((X (CDR X))) (IL:\\\, (
CONVERT-BODY (CADDR SPEC))))))))))) ((EQ (CAR SPEC) (QUOTE SATISFIES)) (IL:BQUOTE (FUNCALL (FUNCTION (
IL:\\\, (CADR SPEC))) X))) (T (IL:BQUOTE (TYPEP X (QUOTE (IL:\\\, (COPY-TREE SPEC))))))))
(DEFVAR BLOCK-STACK-ENTRY-SIZE 1)
(DEFVAR PREFIX-STACK-ENTRY-SIZE 5)
(DEFVAR QUEUE-ENTRY-SIZE 7)
(DEFVAR BUFFER-ENTRY-SIZE 1)
(DEFVAR PREFIX-ENTRY-SIZE 1)
(DEFVAR SUFFIX-ENTRY-SIZE 1)
(DEFVAR BLOCK-STACK-MIN-SIZE 35)
(DEFVAR PREFIX-STACK-MIN-SIZE 150)
(DEFVAR QUEUE-MIN-SIZE 525)
(DEFVAR BUFFER-MIN-SIZE 256)
(DEFVAR PREFIX-MIN-SIZE 256)
(DEFVAR SUFFIX-MIN-SIZE 256)
(IL:BLOCKRECORD XP-STRUCTURE ((BUFFER-OFFSET IL:SIGNEDWORD) (BUFFER-PTR IL:SIGNEDWORD) (BUFFER 
IL:POINTER) (IL:BYTESIZE BYTE) (IL:NIL BYTE) (IL:NIL IL:SIGNEDWORD) (CHARPOS IL:SIGNEDWORD) (
DEPTH-IN-BLOCKS IL:SIGNEDWORD) (IL:NIL IL:POINTER) (IL:NIL IL:POINTER) (IL:NIL IL:POINTER) (IL:NIL 
IL:POINTER) (CHAR-MODE IL:POINTER) (CHAR-MODE-COUNTER IL:SIGNEDWORD) (LINEL IL:SIGNEDWORD) (
BASE-STREAM IL:POINTER) (BLOCK-STACK IL:POINTER) (QUEUE IL:POINTER) (PREFIX IL:POINTER) (PREFIX-STACK 
IL:POINTER) (QLEFT IL:SIGNEDWORD) (QRIGHT IL:SIGNEDWORD) (BLOCK-STACK-PTR IL:SIGNEDWORD) (
PREFIX-STACK-PTR IL:SIGNEDWORD) (SUFFIX IL:POINTER) (IL:NIL IL:POINTER) (IL:NIL IL:POINTER) (IL:NIL 
IL:POINTER) (IL:NIL IL:POINTER) (IL:NIL IL:POINTER) (IL:NIL IL:POINTER) (IL:NIL IL:POINTER) (IL:NIL 
IL:POINTER) (IL:NIL IL:SIGNEDWORD) (LINE-NO IL:SIGNEDWORD) (LINE-LIMIT IL:POINTER)))
(DEFMACRO BASE-STREAM (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BASE-STREAM) IL:|of| (IL:\\\, XP))))
(DEFMACRO LINEL (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE LINEL) IL:|of| (IL:\\\, XP))))
(DEFMACRO LINE-LIMIT (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE LINE-LIMIT) IL:|of| (IL:\\\, XP))))
(DEFMACRO LINE-NO (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE LINE-NO) IL:|of| (IL:\\\, XP))))
(DEFMACRO CHAR-MODE (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE CHAR-MODE) IL:|of| (IL:\\\, XP))))
(DEFMACRO CHAR-MODE-COUNTER (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE CHAR-MODE-COUNTER) IL:|of| (
IL:\\\, XP))))
(DEFMACRO DEPTH-IN-BLOCKS (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE DEPTH-IN-BLOCKS) IL:|of| (IL:\\\, 
XP))))
(DEFMACRO BLOCK-STACK (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BLOCK-STACK) IL:|of| (IL:\\\, XP))))
(DEFMACRO BLOCK-STACK-PTR (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BLOCK-STACK-PTR) IL:|of| (IL:\\\, 
XP))))
(DEFMACRO BUFFER (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BUFFER) IL:|of| (IL:\\\, XP))))
(DEFMACRO CHARPOS (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE CHARPOS) IL:|of| (IL:\\\, XP))))
(DEFMACRO BUFFER-PTR (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BUFFER-PTR) IL:|of| (IL:\\\, XP))))
(DEFMACRO BUFFER-OFFSET (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BUFFER-OFFSET) IL:|of| (IL:\\\, XP))
))
(DEFMACRO QUEUE (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE QUEUE) IL:|of| (IL:\\\, XP))))
(DEFMACRO QLEFT (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE QLEFT) IL:|of| (IL:\\\, XP))))
(DEFMACRO QRIGHT (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE QRIGHT) IL:|of| (IL:\\\, XP))))
(DEFMACRO PREFIX (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE PREFIX) IL:|of| (IL:\\\, XP))))
(DEFMACRO PREFIX-STACK (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE PREFIX-STACK) IL:|of| (IL:\\\, XP))))
(DEFMACRO PREFIX-STACK-PTR (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE PREFIX-STACK-PTR) IL:|of| (IL:\\\,
 XP))))
(DEFMACRO SUFFIX (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE SUFFIX) IL:|of| (IL:\\\, XP))))
(DEFUN MAKE-XP-STRUCTURE (&KEY (BASE-STREAM IL:NIL) (BLOCK-STACK (MAKE-ARRAY 35)) (BUFFER (MAKE-ARRAY 
256 :ELEMENT-TYPE (QUOTE STRING-CHAR))) (QUEUE (MAKE-ARRAY 525)) (PREFIX (MAKE-ARRAY 256 :ELEMENT-TYPE
 (QUOTE STRING-CHAR))) (PREFIX-STACK (MAKE-ARRAY 150)) (SUFFIX (MAKE-ARRAY 256 :ELEMENT-TYPE (QUOTE 
STRING-CHAR))) (LINEL 0) (LINE-LIMIT 65535) (LINE-NO 0) (DEPTH-IN-BLOCKS 0) (BLOCK-STACK-PTR 0) (
CHARPOS 0) (BUFFER-PTR 0) (BUFFER-OFFSET 0) (QLEFT 0) (QRIGHT 0) (PREFIX-STACK-PTR 0)) (LET ((XP (
IL:|create| STREAM IL:DEVICE IL:_ *XP-STREAM-DEVICE* IL:ACCESS IL:_ (QUOTE IL:OUTPUT) IL:OTHERPROPS IL:_
 (QUOTE (*XP-STREAM-DEVICE* T)) IL:OUTCHARFN IL:_ (IL:FUNCTION XP-STREAM-OUTCHARFN) IL:STRMBOUTFN IL:_
 (IL:FUNCTION IL:\\OUTCHAR)))) (SETF (BUFFER XP) BUFFER) (SETF (BASE-STREAM XP) BASE-STREAM) (SETF (
BLOCK-STACK XP) BLOCK-STACK) (SETF (QUEUE XP) QUEUE) (SETF (PREFIX XP) PREFIX) (SETF (PREFIX-STACK XP)
 PREFIX-STACK) (SETF (SUFFIX XP) SUFFIX) (SETF (LINEL XP) LINEL) (SETF (LINE-LIMIT XP) LINE-LIMIT) (
SETF (LINE-NO XP) LINE-NO) (SETF (DEPTH-IN-BLOCKS XP) DEPTH-IN-BLOCKS) (SETF (BLOCK-STACK-PTR XP) 
BLOCK-STACK-PTR) (SETF (CHARPOS XP) CHARPOS) (SETF (BUFFER-PTR XP) BUFFER-PTR) (SETF (BUFFER-OFFSET XP
) BUFFER-OFFSET) (SETF (QLEFT XP) QLEFT) (SETF (QRIGHT XP) QRIGHT) (SETF (PREFIX-STACK-PTR XP) 
PREFIX-STACK-PTR) XP))
(DEFMACRO XP-STRUCTURE-P (OBJECT) (IL:BQUOTE (AND (TYPEP (IL:\\\, OBJECT) (QUOTE STREAM)) (EQ (
IL:|fetch| (STREAM IL:DEVICE) IL:|of| (IL:\\\, OBJECT)) *XP-STREAM-DEVICE*))))
(DEFMACRO LP<-BP (XP &OPTIONAL (PTR IL:NIL)) (IF (NULL PTR) (SETQ PTR (IL:BQUOTE (BUFFER-PTR (IL:\\\, 
XP))))) (IL:BQUOTE (+ (IL:\\\, PTR) (CHARPOS (IL:\\\, XP)))))
(DEFMACRO TP<-BP (XP) (IL:BQUOTE (+ (BUFFER-PTR (IL:\\\, XP)) (BUFFER-OFFSET (IL:\\\, XP)))))
(DEFMACRO BP<-LP (XP PTR) (IL:BQUOTE (- (IL:\\\, PTR) (CHARPOS (IL:\\\, XP)))))
(DEFMACRO BP<-TP (XP PTR) (IL:BQUOTE (- (IL:\\\, PTR) (BUFFER-OFFSET (IL:\\\, XP)))))
(DEFMACRO LP<-TP (XP PTR) (IL:BQUOTE (LP<-BP (IL:\\\, XP) (BP<-TP (IL:\\\, XP) (IL:\\\, PTR)))))
(DEFMACRO CHECK-SIZE (XP VECT PTR) (LET* ((MIN-SIZE (SYMBOL-VALUE (INTERN (CONCATENATE (QUOTE STRING) 
(STRING VECT) "-MIN-SIZE") (FIND-PACKAGE "XP")))) (ENTRY-SIZE (SYMBOL-VALUE (INTERN (CONCATENATE (
QUOTE STRING) (STRING VECT) "-ENTRY-SIZE") (FIND-PACKAGE "XP"))))) (IL:BQUOTE (WHEN (AND (> (IL:\\\, 
PTR) (IL:\\\, (- MIN-SIZE ENTRY-SIZE))) (IL:* IL:\; "seldom happens") (> (IL:\\\, PTR) (- (LENGTH ((
IL:\\\, VECT) (IL:\\\, XP))) (IL:\\\, ENTRY-SIZE)))) (LET* ((OLD ((IL:\\\, VECT) (IL:\\\, XP))) (NEW (
MAKE-ARRAY (+ (IL:\\\, PTR) (IL:\\\, (IF (= ENTRY-SIZE 1) 50 (* 10 ENTRY-SIZE)))) :ELEMENT-TYPE (
ARRAY-ELEMENT-TYPE OLD)))) (REPLACE NEW OLD) (SETF ((IL:\\\, VECT) (IL:\\\, XP)) NEW))))))
(DEFMACRO SECTION-START (XP) (IL:BQUOTE (AREF (BLOCK-STACK (IL:\\\, XP)) (BLOCK-STACK-PTR (IL:\\\, XP)
))))
(DEFUN PUSH-BLOCK-STACK (XP) (INCF (BLOCK-STACK-PTR XP) 1) (CHECK-SIZE XP BLOCK-STACK (BLOCK-STACK-PTR
 XP)))
(DEFUN POP-BLOCK-STACK (XP) (IL:* IL:\; "Edited 10-Jun-92 19:54 by jrb:") (DECF (BLOCK-STACK-PTR XP) 1
))
(DEFMACRO PREFIX-PTR (XP) (IL:BQUOTE (AREF (PREFIX-STACK (IL:\\\, XP)) (PREFIX-STACK-PTR (IL:\\\, XP))
)))
(DEFMACRO SUFFIX-PTR (XP) (IL:BQUOTE (AREF (PREFIX-STACK (IL:\\\, XP)) (+ (PREFIX-STACK-PTR (IL:\\\, 
XP)) 1))))
(DEFMACRO NON-BLANK-PREFIX-PTR (XP) (IL:BQUOTE (AREF (PREFIX-STACK (IL:\\\, XP)) (+ (PREFIX-STACK-PTR 
(IL:\\\, XP)) 2))))
(DEFMACRO INITIAL-PREFIX-PTR (XP) (IL:BQUOTE (AREF (PREFIX-STACK (IL:\\\, XP)) (+ (PREFIX-STACK-PTR (
IL:\\\, XP)) 3))))
(DEFMACRO SECTION-START-LINE (XP) (IL:BQUOTE (AREF (PREFIX-STACK (IL:\\\, XP)) (+ (PREFIX-STACK-PTR (
IL:\\\, XP)) 4))))
(DEFUN PUSH-PREFIX-STACK (XP) (LET ((OLD-PREFIX 0) (OLD-SUFFIX 0) (OLD-NON-BLANK 0)) (WHEN (NOT (
MINUSP (PREFIX-STACK-PTR XP))) (SETQ OLD-PREFIX (PREFIX-PTR XP) OLD-SUFFIX (SUFFIX-PTR XP) 
OLD-NON-BLANK (NON-BLANK-PREFIX-PTR XP))) (INCF (PREFIX-STACK-PTR XP) 5) (CHECK-SIZE XP PREFIX-STACK (
PREFIX-STACK-PTR XP)) (SETF (PREFIX-PTR XP) OLD-PREFIX) (SETF (SUFFIX-PTR XP) OLD-SUFFIX) (SETF (
NON-BLANK-PREFIX-PTR XP) OLD-NON-BLANK)))
(DEFUN POP-PREFIX-STACK (XP) (DECF (PREFIX-STACK-PTR XP) 5))
(DEFMACRO QTYPE (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (IL:\\\, INDEX))))
(DEFMACRO QKIND (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (1+ (IL:\\\, INDEX)))))
(DEFMACRO QPOS (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (+ (IL:\\\, INDEX) 2))))
(DEFMACRO QDEPTH (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (+ (IL:\\\, INDEX) 3))))
(DEFMACRO QEND (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (+ (IL:\\\, INDEX) 4))))
(DEFMACRO QOFFSET (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (+ (IL:\\\, INDEX) 5))))
(DEFMACRO QARG (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (+ (IL:\\\, INDEX) 6))))
(DEFUN ENQUEUE (XP TYPE KIND &OPTIONAL ARG) (INCF (QRIGHT XP) 7) (WHEN (> (QRIGHT XP) 518) (IL:* IL:|;;|
 "Equivalent code below, assuming the queue is an array") (IL:* IL:|;;| 
"(DO ((S1 0 (INCF S1)) (S2 (QLEFT XP) (INCF S2)) (E2 (QRIGHT XP)) (Q (QUEUE XP))) ((IL:IGREATERP S2 E2)) (SETF (AREF Q S1) (AREF Q S2)))"
) (REPLACE (QUEUE XP) (QUEUE XP) :START2 (QLEFT XP) :END2 (QRIGHT XP)) (SETF (QRIGHT XP) (- (QRIGHT XP
) (QLEFT XP))) (SETF (QLEFT XP) 0)) (CHECK-SIZE XP QUEUE (QRIGHT XP)) (SETF (QTYPE XP (QRIGHT XP)) 
TYPE) (SETF (QKIND XP (QRIGHT XP)) KIND) (SETF (QPOS XP (QRIGHT XP)) (TP<-BP XP)) (SETF (QDEPTH XP (
QRIGHT XP)) (DEPTH-IN-BLOCKS XP)) (SETF (QEND XP (QRIGHT XP)) IL:NIL) (SETF (QOFFSET XP (QRIGHT XP)) 
IL:NIL) (SETF (QARG XP (QRIGHT XP)) ARG))
(DEFMACRO QNEXT (INDEX) (IL:BQUOTE (+ (IL:\\\, INDEX) 7)))
(DEFVAR *DESCRIBE-XP-STREAMS-FULLY* IL:NIL "Set to T to see more info.")
(DEFUN DESCRIBE-XP (XP S DEPTH) (DECLARE (IGNORE DEPTH)) (CL:FORMAT S "#<XP stream ") (IF (NOT (
BASE-STREAM XP)) (CL:FORMAT S "not currently in use") (CL:FORMAT S "outputting to ~S" (BASE-STREAM XP)
)) (WHEN (BASE-STREAM XP) (CL:FORMAT S "~&buffer= ~S" (SUBSEQ (BUFFER XP) 0 (MAX (BUFFER-PTR XP) 0))) 
(WHEN (NOT *DESCRIBE-XP-STREAMS-FULLY*) (CL:PRINC " ..." S)) (WHEN *DESCRIBE-XP-STREAMS-FULLY* (
CL:FORMAT S "~&   pos   _123456789_123456789_123456789_123456789") (CL:FORMAT S 
"~&depth-in-blocks= ~D linel= ~D line-no= ~D line-limit= ~D" (DEPTH-IN-BLOCKS XP) (LINEL XP) (LINE-NO 
XP) (LINE-LIMIT XP)) (WHEN (OR (CHAR-MODE XP) (NOT (ZEROP (CHAR-MODE-COUNTER XP)))) (CL:FORMAT S 
"~&char-mode= ~S char-mode-counter= ~D" (CHAR-MODE XP) (CHAR-MODE-COUNTER XP))) (UNLESS (MINUSP (
BLOCK-STACK-PTR XP)) (CL:FORMAT S "~&section-start") (DO ((SAVE (BLOCK-STACK-PTR XP))) ((MINUSP (
BLOCK-STACK-PTR XP)) (SETF (BLOCK-STACK-PTR XP) SAVE)) (CL:FORMAT S " ~D" (SECTION-START XP)) (
POP-BLOCK-STACK XP))) (CL:FORMAT S "~&linel= ~D charpos= ~D buffer-ptr= ~D buffer-offset= ~D" (LINEL 
XP) (CHARPOS XP) (BUFFER-PTR XP) (BUFFER-OFFSET XP)) (UNLESS (MINUSP (PREFIX-STACK-PTR XP)) (CL:FORMAT
 S "~&prefix= ~S" (SUBSEQ (PREFIX XP) 0 (MAX (PREFIX-PTR XP) 0))) (CL:FORMAT S "~&suffix= ~S" (SUBSEQ 
(SUFFIX XP) 0 (MAX (SUFFIX-PTR XP) 0)))) (UNLESS (> (QLEFT XP) (QRIGHT XP)) (CL:FORMAT S 
"~&ptr type         kind           pos depth end offset arg") (DO ((P (QLEFT XP) (QNEXT P))) ((> P (
QRIGHT XP))) (CL:FORMAT S "~&~4A~13A~15A~4A~6A~4A~7A~A" (/ (- P (QLEFT XP)) 7) (QTYPE XP P) (IF (
MEMBER (QTYPE XP P) (QUOTE (:NEWLINE :IND))) (QKIND XP P) "") (BP<-TP XP (QPOS XP P)) (QDEPTH XP P) (
IF (NOT (MEMBER (QTYPE XP P) (QUOTE (:NEWLINE :START-BLOCK)))) "" (AND (QEND XP P) (/ (- (+ P (QEND XP
 P)) (QLEFT XP)) 7))) (IF (NOT (EQ (QTYPE XP P) :START-BLOCK)) "" (AND (QOFFSET XP P) (/ (- (+ P (
QOFFSET XP P)) (QLEFT XP)) 7))) (IF (NOT (MEMBER (QTYPE XP P) (QUOTE (:IND :START-BLOCK :END-BLOCK))))
 "" (QARG XP P))))) (UNLESS (MINUSP (PREFIX-STACK-PTR XP)) (CL:FORMAT S 
"~&initial-prefix-ptr prefix-ptr suffix-ptr non-blank start-line") (DO ((SAVE (PREFIX-STACK-PTR XP))) 
((MINUSP (PREFIX-STACK-PTR XP)) (SETF (PREFIX-STACK-PTR XP) SAVE)) (CL:FORMAT S 
"~& ~19A~11A~11A~10A~A" (INITIAL-PREFIX-PTR XP) (PREFIX-PTR XP) (SUFFIX-PTR XP) (NON-BLANK-PREFIX-PTR 
XP) (SECTION-START-LINE XP)) (POP-PREFIX-STACK XP))))) (CL:PRINC ">" S) (VALUES))
(DEFVAR *FREE-XPS* IL:NIL "free list of XP stream objects")
(DEFUN GET-PRETTY-PRINT-STREAM (STREAM) (LET ((XP (POP *FREE-XPS*))) (INITIALIZE-XP (IF XP XP (
MAKE-XP-STRUCTURE)) STREAM)))
(DEFUN FREE-PRETTY-PRINT-STREAM (XP) (SETF (BASE-STREAM XP) IL:NIL) (PUSHNEW XP *FREE-XPS*))
(DEFUN INITIALIZE-XP (XP STREAM) (SETF (BASE-STREAM XP) STREAM) (SETF (LINEL XP) (MAX 0 (COND (
*PRINT-RIGHT-MARGIN*) ((OUTPUT-WIDTH STREAM)) (T *DEFAULT-RIGHT-MARGIN*)))) (SETF (LINE-LIMIT XP) 
*PRINT-LINES*) (SETF (LINE-NO XP) 1) (SETF (CHAR-MODE XP) IL:NIL) (SETF (CHAR-MODE-COUNTER XP) 0) (
SETF (DEPTH-IN-BLOCKS XP) 0) (SETF (BLOCK-STACK-PTR XP) 0) (SETF (CHARPOS XP) (COND ((OUTPUT-POSITION 
STREAM)) (T 0))) (SETF (SECTION-START XP) 0) (SETF (BUFFER-PTR XP) 0) (SETF (BUFFER-OFFSET XP) (
CHARPOS XP)) (SETF (QLEFT XP) 0) (SETF (QRIGHT XP) -7) (SETF (PREFIX-STACK-PTR XP) -5) XP)
(DEFUN PUSH-CHAR-MODE (XP NEW-MODE) (IF (ZEROP (CHAR-MODE-COUNTER XP)) (SETF (CHAR-MODE XP) NEW-MODE))
 (INCF (CHAR-MODE-COUNTER XP)))
(DEFUN POP-CHAR-MODE (XP) (DECF (CHAR-MODE-COUNTER XP)) (IF (ZEROP (CHAR-MODE-COUNTER XP)) (SETF (
CHAR-MODE XP) IL:NIL)))
(DEFUN HANDLE-CHAR-MODE (XP CHAR) (CASE (CHAR-MODE XP) (:CAP0 (COND ((NOT (ALPHANUMERICP CHAR)) CHAR) 
(T (SETF (CHAR-MODE XP) :DOWN) (CHAR-UPCASE CHAR)))) (:CAP1 (COND ((NOT (ALPHANUMERICP CHAR)) CHAR) (T
 (SETF (CHAR-MODE XP) :CAPW) (CHAR-UPCASE CHAR)))) (:CAPW (COND ((ALPHANUMERICP CHAR) (CHAR-DOWNCASE 
CHAR)) (T (SETF (CHAR-MODE XP) :CAP1) CHAR))) (:UP (CHAR-UPCASE CHAR)) (T (CHAR-DOWNCASE CHAR))))
(DEFUN WRITE-CHAR+ (CHAR XP) (IF (EQL CHAR #\Newline) (PPRINT-NEWLINE+ :UNCONDITIONAL XP) (
WRITE-CHAR++ CHAR XP)))
(DEFUN WRITE-STRING+ (STRING XP START END) (LET ((SUB-END IL:NIL) NEXT-NEWLINE) (LOOP (SETQ 
NEXT-NEWLINE (POSITION #\Newline STRING :TEST (FUNCTION CHAR=) :START START :END END)) (SETQ SUB-END (
IF NEXT-NEWLINE NEXT-NEWLINE END)) (WRITE-STRING++ STRING XP START SUB-END) (WHEN (NULL NEXT-NEWLINE) 
(RETURN IL:NIL)) (PPRINT-NEWLINE+ :UNCONDITIONAL XP) (SETQ START (1+ SUB-END)))))
(DEFUN WRITE-CHAR++ (CHAR XP) (WHEN (> (BUFFER-PTR XP) (LINEL XP)) (FORCE-SOME-OUTPUT XP)) (LET ((
NEW-BUFFER-END (1+ (BUFFER-PTR XP)))) (CHECK-SIZE XP BUFFER NEW-BUFFER-END) (IF (CHAR-MODE XP) (SETQ 
CHAR (HANDLE-CHAR-MODE XP CHAR))) (SETF (CHAR (BUFFER XP) (BUFFER-PTR XP)) CHAR) (SETF (BUFFER-PTR XP)
 NEW-BUFFER-END)))
(DEFUN FORCE-SOME-OUTPUT (XP) (ATTEMPT-TO-OUTPUT XP IL:NIL IL:NIL) (WHEN (> (BUFFER-PTR XP) (LINEL XP)
) (IL:* IL:\; "only if printing off end of line") (ATTEMPT-TO-OUTPUT XP T T)))
(DEFUN WRITE-STRING++ (STRING XP START END) (WHEN (> (BUFFER-PTR XP) (LINEL XP)) (FORCE-SOME-OUTPUT XP
)) (WRITE-STRING+++ STRING XP START END))
(DEFUN WRITE-STRING+++ (STRING XP START END) (LET ((NEW-BUFFER-END (+ (BUFFER-PTR XP) (- END START))))
 (CHECK-SIZE XP BUFFER NEW-BUFFER-END) (DO ((BUFFER (BUFFER XP)) (I (BUFFER-PTR XP) (1+ I)) (J START (
1+ J))) ((= J END)) (LET ((CHAR (CHAR STRING J))) (IF (CHAR-MODE XP) (SETQ CHAR (HANDLE-CHAR-MODE XP 
CHAR))) (SETF (CHAR BUFFER I) CHAR))) (SETF (BUFFER-PTR XP) NEW-BUFFER-END)))
(DEFUN PPRINT-TAB+ (KIND COLNUM COLINC XP) (LET ((INDENTED? IL:NIL) (RELATIVE? IL:NIL)) (CASE KIND (
:SECTION (SETQ INDENTED? T)) (:LINE-RELATIVE (SETQ RELATIVE? T)) (:SECTION-RELATIVE (SETQ INDENTED? T 
RELATIVE? T))) (LET* ((CURRENT (IF (NOT INDENTED?) (LP<-BP XP) (- (TP<-BP XP) (SECTION-START XP)))) (
NEW (IF (ZEROP COLINC) (IF RELATIVE? (+ CURRENT COLNUM) (MAX COLNUM CURRENT)) (COND (RELATIVE? (* 
COLINC (FLOOR (+ CURRENT COLNUM COLINC -1) COLINC))) ((> COLNUM CURRENT) COLNUM) (T (+ COLNUM (* 
COLINC (FLOOR (+ CURRENT (- COLNUM) COLINC) COLINC))))))) (LENGTH (- NEW CURRENT))) (WHEN (PLUSP 
LENGTH) (IF (CHAR-MODE XP) (HANDLE-CHAR-MODE XP #\Space)) (LET ((END (+ (BUFFER-PTR XP) LENGTH))) (
CHECK-SIZE XP BUFFER END) (FILL (BUFFER XP) #\Space :START (BUFFER-PTR XP) :END END) (SETF (BUFFER-PTR
 XP) END))))))
(DEFUN PPRINT-NEWLINE+ (KIND XP) (ENQUEUE XP :NEWLINE KIND) (DO ((PTR (QLEFT XP) (QNEXT PTR))) (IL:* 
IL:\; "find sections we are ending") ((NOT (< PTR (QRIGHT XP)))) (IL:* IL:\; "all but last") (WHEN (
AND (NULL (QEND XP PTR)) (NOT (> (DEPTH-IN-BLOCKS XP) (QDEPTH XP PTR))) (MEMBER (QTYPE XP PTR) (QUOTE 
(:NEWLINE :START-BLOCK)))) (SETF (QEND XP PTR) (- (QRIGHT XP) PTR)))) (SETF (SECTION-START XP) (TP<-BP
 XP)) (WHEN (AND (MEMBER KIND (QUOTE (:FRESH :UNCONDITIONAL))) (CHAR-MODE XP)) (HANDLE-CHAR-MODE XP 
#\Newline)) (WHEN (MEMBER KIND (QUOTE (:FRESH :UNCONDITIONAL :MANDATORY))) (ATTEMPT-TO-OUTPUT XP T 
IL:NIL)))
(DEFUN START-BLOCK (XP PREFIX-STRING ON-EACH-LINE? SUFFIX-STRING) (WHEN PREFIX-STRING (WRITE-STRING++ 
PREFIX-STRING XP 0 (LENGTH PREFIX-STRING))) (IF (AND (CHAR-MODE XP) ON-EACH-LINE?) (SETQ PREFIX-STRING
 (SUBSEQ (BUFFER XP) (- (BUFFER-PTR XP) (LENGTH PREFIX-STRING)) (BUFFER-PTR XP)))) (PUSH-BLOCK-STACK 
XP) (ENQUEUE XP :START-BLOCK IL:NIL (IF ON-EACH-LINE? (CONS SUFFIX-STRING PREFIX-STRING) SUFFIX-STRING
)) (INCF (DEPTH-IN-BLOCKS XP)) (IL:* IL:\; "must be after enqueue") (SETF (SECTION-START XP) (TP<-BP 
XP)))
(DEFUN END-BLOCK (XP SUFFIX) (UNLESS (EQ *ABBREVIATION-HAPPENED* (QUOTE *PRINT-LINES*)) (WHEN SUFFIX (
WRITE-STRING+ SUFFIX XP 0 (LENGTH SUFFIX))) (DECF (DEPTH-IN-BLOCKS XP)) (ENQUEUE XP :END-BLOCK IL:NIL 
SUFFIX) (DO ((PTR (QLEFT XP) (QNEXT PTR))) (IL:* IL:\; "looking for start of block we are ending") ((
NOT (< PTR (QRIGHT XP)))) (IL:* IL:\; "all but last") (WHEN (AND (= (DEPTH-IN-BLOCKS XP) (QDEPTH XP 
PTR)) (EQ (QTYPE XP PTR) :START-BLOCK) (NULL (QOFFSET XP PTR))) (SETF (QOFFSET XP PTR) (- (QRIGHT XP) 
PTR)) (RETURN IL:NIL))) (IL:* IL:\; "can only be 1") (POP-BLOCK-STACK XP)))
(DEFUN PPRINT-INDENT+ (KIND N XP) (ENQUEUE XP :IND KIND N))
(DEFMACRO MAYBE-TOO-LARGE (XP QENTRY) (IL:BQUOTE (LET ((LIMIT (LINEL (IL:\\\, XP)))) (WHEN (EQL (
LINE-LIMIT (IL:\\\, XP)) (LINE-NO (IL:\\\, XP))) (IL:* IL:\; "prevents suffix overflow") (DECF LIMIT 2
) (IL:* IL:|;;| "3 for \" ..\" minus 1 for space (heuristic)") (WHEN (NOT (MINUSP (PREFIX-STACK-PTR (
IL:\\\, XP)))) (DECF LIMIT (SUFFIX-PTR (IL:\\\, XP))))) (COND ((QEND (IL:\\\, XP) (IL:\\\, QENTRY)) (>
 (LP<-TP (IL:\\\, XP) (QPOS (IL:\\\, XP) (+ (IL:\\\, QENTRY) (QEND (IL:\\\, XP) (IL:\\\, QENTRY))))) 
LIMIT)) ((OR FORCE-NEWLINES? (> (LP<-BP (IL:\\\, XP)) LIMIT)) T) (T (RETURN IL:NIL))))))
(DEFMACRO MISERING? (XP) (IL:BQUOTE (AND *PRINT-MISER-WIDTH* (<= (- (LINEL (IL:\\\, XP)) (
INITIAL-PREFIX-PTR (IL:\\\, XP))) *PRINT-MISER-WIDTH*))))
(DEFUN ATTEMPT-TO-OUTPUT (XP FORCE-NEWLINES? FLUSH-OUT?) (DO IL:NIL ((> (QLEFT XP) (QRIGHT XP)) (SETF 
(QLEFT XP) 0) (SETF (QRIGHT XP) -7)) (IL:* IL:\; "saves shifting") (CASE (QTYPE XP (QLEFT XP)) (:IND (
UNLESS (MISERING? XP) (SET-INDENTATION-PREFIX XP (CASE (QKIND XP (QLEFT XP)) (:BLOCK (+ (
INITIAL-PREFIX-PTR XP) (QARG XP (QLEFT XP)))) (T (IL:* IL:\; ":current") (+ (LP<-TP XP (QPOS XP (QLEFT
 XP))) (QARG XP (QLEFT XP))))))) (SETF (QLEFT XP) (QNEXT (QLEFT XP)))) (:START-BLOCK (COND ((
MAYBE-TOO-LARGE XP (QLEFT XP)) (PUSH-PREFIX-STACK XP) (SETF (INITIAL-PREFIX-PTR XP) (PREFIX-PTR XP)) (
SET-INDENTATION-PREFIX XP (LP<-TP XP (QPOS XP (QLEFT XP)))) (LET ((ARG (QARG XP (QLEFT XP)))) (WHEN (
CONSP ARG) (SET-PREFIX XP (CDR ARG))) (SETF (INITIAL-PREFIX-PTR XP) (PREFIX-PTR XP)) (COND ((NOT (
LISTP ARG)) (SET-SUFFIX XP ARG)) ((CAR ARG) (SET-SUFFIX XP (CAR ARG))))) (SETF (SECTION-START-LINE XP)
 (LINE-NO XP))) (T (INCF (QLEFT XP) (QOFFSET XP (QLEFT XP))))) (SETF (QLEFT XP) (QNEXT (QLEFT XP)))) (
:END-BLOCK (POP-PREFIX-STACK XP) (SETF (QLEFT XP) (QNEXT (QLEFT XP)))) (T (IL:* IL:\; ":newline") (
WHEN (CASE (QKIND XP (QLEFT XP)) (:FRESH (NOT (ZEROP (LP<-BP XP)))) (:MISER (MISERING? XP)) (:FILL (OR
 (MISERING? XP) (> (LINE-NO XP) (SECTION-START-LINE XP)) (MAYBE-TOO-LARGE XP (QLEFT XP)))) (T T)) (IL:*
 IL:\; "(:linear :unconditional :mandatory) ") (OUTPUT-LINE XP (QLEFT XP)) (SETUP-FOR-NEXT-LINE XP (
QLEFT XP))) (SETF (QLEFT XP) (QNEXT (QLEFT XP)))))) (WHEN FLUSH-OUT? (FLUSH XP)))
(DEFUN FLUSH (XP) (UNLESS *LOCATING-CIRCULARITIES* (CL:WRITE-STRING (BUFFER XP) (BASE-STREAM XP) :END 
(BUFFER-PTR XP))) (INCF (BUFFER-OFFSET XP) (BUFFER-PTR XP)) (INCF (CHARPOS XP) (BUFFER-PTR XP)) (SETF 
(BUFFER-PTR XP) 0))
(DEFUN OUTPUT-LINE (XP QENTRY) (LET* ((OUT-POINT (BP<-TP XP (QPOS XP QENTRY))) (LAST-NON-BLANK (
POSITION #\Space (BUFFER XP) :TEST-NOT (FUNCTION CHAR=) :FROM-END T :END OUT-POINT)) (END (COND ((
MEMBER (QKIND XP QENTRY) (QUOTE (:FRESH :UNCONDITIONAL))) OUT-POINT) (LAST-NON-BLANK (1+ 
LAST-NON-BLANK)) (T 0))) (LINE-LIMIT-EXIT (AND (LINE-LIMIT XP) (NOT (> (LINE-LIMIT XP) (LINE-NO XP))))
)) (WHEN LINE-LIMIT-EXIT (SETF (BUFFER-PTR XP) END) (IL:* IL:\; "truncate pending output.") (
WRITE-STRING+++ " .." XP 0 3) (REVERSE-STRING-IN-PLACE (SUFFIX XP) 0 (SUFFIX-PTR XP)) (WRITE-STRING+++
 (SUFFIX XP) XP 0 (SUFFIX-PTR XP)) (SETF (QLEFT XP) (QNEXT (QRIGHT XP))) (SETQ *ABBREVIATION-HAPPENED*
 (QUOTE *PRINT-LINES*)) (THROW (QUOTE LINE-LIMIT-ABBREVIATION-EXIT) T)) (INCF (LINE-NO XP)) (UNLESS 
*LOCATING-CIRCULARITIES* (IL:* IL:|;;| "(CL:WRITE-LINE (BUFFER XP) (BASE-STREAM XP) :END END)") (IL:* 
IL:|;;| 
"The code below is equivalent assuming (BASE-STREAM XP) is not an XP-stream (I believe we can be sure this is the case)"
) (IL:WRITE-STRING* (BUFFER XP) (BASE-STREAM XP) 0 END) (IL:TERPRI (BASE-STREAM XP)))))
(DEFUN SETUP-FOR-NEXT-LINE (XP QENTRY) (LET* ((OUT-POINT (BP<-TP XP (QPOS XP QENTRY))) (PREFIX-END (
COND ((MEMBER (QKIND XP QENTRY) (QUOTE (:UNCONDITIONAL :FRESH))) (NON-BLANK-PREFIX-PTR XP)) (T (
PREFIX-PTR XP)))) (CHANGE (- PREFIX-END OUT-POINT))) (SETF (CHARPOS XP) 0) (IL:* IL:|;;| 
"(REPLACE (BUFFER XP) (BUFFER XP) :START1 PREFIX-END :START2 OUT-POINT :END2 (BUFFER-PTR XP))") (IL:* 
IL:|;;| "Equivalent code below; we could sure stand mega-optimizers on stuff like this...") (IF (PLUSP
 CHANGE) (PROGN (IL:* IL:\; "almost never happens") (CHECK-SIZE XP BUFFER (+ (BUFFER-PTR XP) CHANGE)) 
(REPLACE (BUFFER XP) (BUFFER XP) :START1 PREFIX-END :START2 OUT-POINT :END2 (BUFFER-PTR XP))) (DO ((S1
 PREFIX-END (INCF S1)) (S2 OUT-POINT (INCF S2)) (E2 (BUFFER-PTR XP)) (B (BUFFER XP))) ((IL:IGEQ S2 E2)
) (SETF (CHAR B S1) (CHAR B S2)))) (IL:* IL:|;;| "(REPLACE (BUFFER XP) (PREFIX XP) :END2 PREFIX-END)")
 (IL:* IL:|;;| "Equivalent code below; we could sure stand mega-optimizers on stuff like this...") (DO
 ((S1 0 (INCF S1)) (E2 PREFIX-END) (B (BUFFER XP)) (P (PREFIX XP))) ((IL:IGEQ S1 E2)) (SETF (CHAR B S1
) (CHAR P S1))) (INCF (BUFFER-PTR XP) CHANGE) (DECF (BUFFER-OFFSET XP) CHANGE) (WHEN (NOT (MEMBER (
QKIND XP QENTRY) (QUOTE (:UNCONDITIONAL :FRESH)))) (SETF (SECTION-START-LINE XP) (LINE-NO XP)))))
(DEFUN SET-INDENTATION-PREFIX (XP NEW-POSITION) (LET ((NEW-IND (MAX (NON-BLANK-PREFIX-PTR XP) 
NEW-POSITION))) (SETF (PREFIX-PTR XP) (INITIAL-PREFIX-PTR XP)) (CHECK-SIZE XP PREFIX NEW-IND) (WHEN (>
 NEW-IND (PREFIX-PTR XP)) (FILL (PREFIX XP) #\Space :START (PREFIX-PTR XP) :END NEW-IND)) (SETF (
PREFIX-PTR XP) NEW-IND)))
(DEFUN SET-PREFIX (XP PREFIX-STRING) (REPLACE (PREFIX XP) PREFIX-STRING :START1 (- (PREFIX-PTR XP) (
LENGTH PREFIX-STRING))) (SETF (NON-BLANK-PREFIX-PTR XP) (PREFIX-PTR XP)))
(DEFUN SET-SUFFIX (XP SUFFIX-STRING) (LET* ((END (LENGTH SUFFIX-STRING)) (NEW-END (+ (SUFFIX-PTR XP) 
END))) (CHECK-SIZE XP SUFFIX NEW-END) (DO ((I (1- NEW-END) (1- I)) (J 0 (1+ J))) ((= J END)) (SETF (
CHAR (SUFFIX XP) I) (CHAR SUFFIX-STRING J))) (SETF (SUFFIX-PTR XP) NEW-END)))
(DEFUN REVERSE-STRING-IN-PLACE (STRING START END) (DO ((I START (1+ I)) (J (1- END) (1- J))) ((NOT (< 
I J)) STRING) (LET ((C (CHAR STRING I))) (SETF (CHAR STRING I) (CHAR STRING J)) (SETF (CHAR STRING J) 
C))))
(DEFUN WRITE (OBJECT &REST PAIRS &KEY (STREAM *STANDARD-OUTPUT*) (ESCAPE *PRINT-ESCAPE*) (RADIX 
*PRINT-RADIX*) (BASE *PRINT-BASE*) (CIRCLE *PRINT-CIRCLE*) (PRETTY *PRINT-PRETTY*) (LEVEL 
*PRINT-LEVEL*) (LENGTH *PRINT-LENGTH*) (CASE *PRINT-CASE*) (GENSYM *PRINT-GENSYM*) (ARRAY 
*PRINT-ARRAY*) (PPRINT-DISPATCH *PRINT-PPRINT-DISPATCH*) (RIGHT-MARGIN *PRINT-RIGHT-MARGIN*) (LINES 
*PRINT-LINES*) (MISER-WIDTH *PRINT-MISER-WIDTH*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (LET ((
*PRINT-PPRINT-DISPATCH* PPRINT-DISPATCH) (*PRINT-RIGHT-MARGIN* RIGHT-MARGIN) (*PRINT-LINES* LINES) (
*PRINT-MISER-WIDTH* MISER-WIDTH)) (COND ((OR (XP-STRUCTURE-P STREAM) PRETTY) (LET ((*PRINT-ESCAPE* 
ESCAPE) (*PRINT-RADIX* RADIX) (*PRINT-BASE* BASE) (*PRINT-CIRCLE* CIRCLE) (*PRINT-PRETTY* PRETTY) (
*PRINT-LEVEL* LEVEL) (*PRINT-LENGTH* LENGTH) (*PRINT-CASE* CASE) (*PRINT-GENSYM* GENSYM) (
*PRINT-ARRAY* ARRAY)) (BASIC-WRITE OBJECT STREAM))) (T (REMF PAIRS :DISPATCH) (REMF PAIRS 
:RIGHT-MARGIN) (REMF PAIRS :LINES) (REMF PAIRS :MISER-WIDTH) (APPLY (FUNCTION CL:WRITE) OBJECT PAIRS))
)) OBJECT)
(DEFUN BASIC-WRITE (OBJECT STREAM) (COND ((XP-STRUCTURE-P STREAM) (WRITE+ OBJECT STREAM)) (
*PRINT-PRETTY* (MAYBE-INITIATE-XP-PRINTING (FUNCTION (LAMBDA (S O) (WRITE+ O S))) STREAM OBJECT)) (T (
CL:WRITE OBJECT :STREAM STREAM))))
(DEFUN MAYBE-INITIATE-XP-PRINTING (FN STREAM &REST ARGS) (IL:* IL:\; "Edited 10-Jul-92 11:51 by jrb:")
 (IF (XP-STRUCTURE-P STREAM) (APPLY FN STREAM ARGS) (LET ((*ABBREVIATION-HAPPENED* IL:NIL) (
*LOCATING-CIRCULARITIES* (IF *PRINT-CIRCLE* 0 IL:NIL)) (*CIRCULARITY-HASH-TABLE* (IF *PRINT-CIRCLE* (
GET-CIRCULARITY-HASH-TABLE) IL:NIL)) (*PARENTS* (WHEN (NOT *PRINT-SHARED*) (LIST IL:NIL))) (*RESULT* 
IL:NIL) (IL:\\THISFILELINELENGTH)) (DECLARE (SPECIAL IL:\\THISFILELINELENGTH)) (IL:* IL:|;;| 
"Common Lisp streams do not observe line length") (XP-PRINT FN (DECODE-STREAM-ARG STREAM) ARGS) (IF 
*CIRCULARITY-HASH-TABLE* (FREE-CIRCULARITY-HASH-TABLE *CIRCULARITY-HASH-TABLE*)) (WHEN 
*ABBREVIATION-HAPPENED* (SETQ *LAST-ABBREVIATED-PRINTING* (EVAL (IL:BQUOTE (FUNCTION (LAMBDA (
&OPTIONAL (STREAM (QUOTE (IL:\\\, STREAM)))) (LET ((*PACKAGE* (QUOTE (IL:\\\, *PACKAGE*)))) (APPLY (
FUNCTION MAYBE-INITIATE-XP-PRINTING) (QUOTE (IL:\\\, FN)) STREAM (QUOTE (IL:\\\, (COPY-LIST ARGS))))))
))))) *RESULT*)))
(DEFUN XP-PRINT (FN STREAM ARGS) (SETQ *RESULT* (DO-XP-PRINTING FN STREAM ARGS)) (WHEN 
*LOCATING-CIRCULARITIES* (SETQ *LOCATING-CIRCULARITIES* IL:NIL) (SETQ *ABBREVIATION-HAPPENED* IL:NIL) 
(SETQ *PARENTS* IL:NIL) (SETQ *RESULT* (DO-XP-PRINTING FN STREAM ARGS))))
(DEFUN DECODE-STREAM-ARG (STREAM) (COND ((NULL STREAM) *STANDARD-OUTPUT*) ((EQ STREAM T) *TERMINAL-IO*
) (T STREAM)))
(DEFUN DO-XP-PRINTING (FN STREAM ARGS) (LET ((XP (GET-PRETTY-PRINT-STREAM STREAM)) (*CURRENT-LEVEL* 0)
 (RESULT IL:NIL)) (CATCH (QUOTE LINE-LIMIT-ABBREVIATION-EXIT) (START-BLOCK XP IL:NIL IL:NIL IL:NIL) (
SETQ RESULT (APPLY FN XP ARGS)) (END-BLOCK XP IL:NIL)) (WHEN (AND *LOCATING-CIRCULARITIES* (ZEROP 
*LOCATING-CIRCULARITIES*) (IL:* IL:\; "No circularities.") (= (LINE-NO XP) 1) (IL:* IL:\; 
"Didn't suppress line.") (ZEROP (BUFFER-OFFSET XP))) (IL:* IL:\; "Didn't suppress partial line.") (
SETQ *LOCATING-CIRCULARITIES* IL:NIL)) (IL:* IL:\; "print what you have got.") (WHEN (CATCH (QUOTE 
LINE-LIMIT-ABBREVIATION-EXIT) (ATTEMPT-TO-OUTPUT XP IL:NIL T) IL:NIL) (ATTEMPT-TO-OUTPUT XP T T)) (
FREE-PRETTY-PRINT-STREAM XP) RESULT))
(DEFUN WRITE+ (OBJECT XP) (IL:* IL:\; "Edited  7-Jan-92 14:31 by jrb:") (LET ((*PARENTS* *PARENTS*)) (
UNLESS (AND *CIRCULARITY-HASH-TABLE* (EQ (CIRCULARITY-PROCESS XP OBJECT IL:NIL) :SUBSEQUENT)) (WHEN (
AND *CIRCULARITY-HASH-TABLE* (CONSP OBJECT)) (IL:* IL:|;;| 
"avoid possible double check in handle-logical-block.") (SETQ OBJECT (CONS (CAR OBJECT) (CDR OBJECT)))
) (LET ((PRINTER (IF *PRINT-PRETTY* (GET-PRINTER OBJECT *PRINT-PPRINT-DISPATCH*) IL:NIL)) TYPE) (COND 
(PRINTER (FUNCALL PRINTER XP OBJECT)) ((MAYBE-PRINT-FAST XP OBJECT)) ((AND *PRINT-PRETTY* (SYMBOLP (
SETQ TYPE (TYPE-OF OBJECT))) (SETQ PRINTER (GET TYPE (QUOTE CL::STRUCTURE-PRINTER))) (NOT (EQ PRINTER 
:NONE))) (FUNCALL PRINTER XP OBJECT)) ((AND *PRINT-PRETTY* *PRINT-ARRAY* (ARRAYP OBJECT) (NOT (STRINGP
 OBJECT)) (NOT (BIT-VECTOR-P OBJECT)) (NOT (STRUCTURE-TYPE-P (TYPE-OF OBJECT)))) (PRETTY-ARRAY XP 
OBJECT)) (T (IL:* IL:|;;| 
"OK, we're going to do it the new, strange way; just print it to XP, which SHOULD, through the magic of stream functions, hose the characters into the XP buffer"
) (NON-PRETTY-PRINT OBJECT XP)))))))
(DEFUN NON-PRETTY-PRINT (OBJECT S) (IL:* IL:|;;| 
"(CL:WRITE OBJECT :LEVEL (IF *PRINT-LEVEL* (- *PRINT-LEVEL* *CURRENT-LEVEL*)) :PRETTY NIL :STREAM S)")
 (LET (*PRINT-PRETTY* (*PRINT-LEVEL* (IF *PRINT-LEVEL* (- *PRINT-LEVEL* *CURRENT-LEVEL*)))) (IL:\\WRITE1
 OBJECT S)))
(DEFUN CIRCULARITY-PROCESS (XP OBJECT INTERIOR-CDR?) (UNLESS (OR (NUMBERP OBJECT) (CHARACTERP OBJECT) 
(AND (SYMBOLP OBJECT) (IL:* IL:\; "Reader takes care of sharing.") (OR (NULL *PRINT-GENSYM*) (
SYMBOL-PACKAGE OBJECT)))) (LET ((ID (GETHASH OBJECT *CIRCULARITY-HASH-TABLE*))) (IF 
*LOCATING-CIRCULARITIES* (COND ((NULL ID) (IL:* IL:\; "never seen before") (WHEN *PARENTS* (PUSH 
OBJECT *PARENTS*)) (SETF (GETHASH OBJECT *CIRCULARITY-HASH-TABLE*) 0) IL:NIL) ((ZEROP ID) (IL:* IL:\; 
"possible second occurrence") (COND ((OR (NULL *PARENTS*) (MEMBER OBJECT *PARENTS*)) (SETF (GETHASH 
OBJECT *CIRCULARITY-HASH-TABLE*) (INCF *LOCATING-CIRCULARITIES*)) :SUBSEQUENT) (T IL:NIL))) (T 
:SUBSEQUENT)) (IL:* IL:\; "third or later occurrence") (COND ((OR (NULL ID) (IL:* IL:\; 
"never seen before (note ~@* etc. conses)") (ZEROP ID)) (IL:* IL:\; "no duplicates") IL:NIL) ((PLUSP 
ID) (COND (INTERIOR-CDR? (DECF *CURRENT-LEVEL*) (WRITE-STRING++ ". #" XP 0 3)) (T (WRITE-CHAR++ #\# XP
))) (PRINT-FIXNUM XP ID) (WRITE-CHAR++ #\= XP) (SETF (GETHASH OBJECT *CIRCULARITY-HASH-TABLE*) (- ID))
 :FIRST) (T (IF INTERIOR-CDR? (WRITE-STRING++ ". #" XP 0 3) (WRITE-CHAR++ #\# XP)) (PRINT-FIXNUM XP (-
 ID)) (WRITE-CHAR++ #\# XP) :SUBSEQUENT))))))
(DEFUN MAYBE-PRINT-FAST (XP OBJECT) (COND ((SYMBOLP OBJECT) (IL:* IL:|;;| 
"The \"fast case\" for us is to print the atom to XP; our atom printer is tuned at a lower-than CLtL level so it should be fast enough.  Besides, it observes READTABLE-CASE, which the portable code does not; it could be made to, but why bother?"
) (NON-PRETTY-PRINT OBJECT XP) T) ((STRINGP OBJECT) (COND ((NULL *PRINT-ESCAPE*) (WRITE-STRING+ OBJECT
 XP 0 (LENGTH OBJECT)) T) ((EVERY (FUNCTION (LAMBDA (C) (NOT (OR (CHAR= C #\") (CHAR= C #\\))))) 
OBJECT) (WRITE-CHAR++ #\" XP) (WRITE-STRING+ OBJECT XP 0 (LENGTH OBJECT)) (WRITE-CHAR++ #\" XP) T))) (
(TYPEP OBJECT (QUOTE FIXNUM)) (WHEN (AND (NULL *PRINT-RADIX*) (= *PRINT-BASE* 10)) (WHEN (MINUSP 
OBJECT) (WRITE-CHAR++ #\- XP) (SETQ OBJECT (- OBJECT))) (PRINT-FIXNUM XP OBJECT) T))))
(DEFUN PRINT-FIXNUM (XP FIXNUM) (MULTIPLE-VALUE-BIND (DIGITS D) (TRUNCATE FIXNUM 10) (UNLESS (ZEROP 
DIGITS) (PRINT-FIXNUM XP DIGITS)) (WRITE-CHAR++ (CODE-CHAR (+ 48 D)) XP)))
(DEFUN NO-ESCAPES-NEEDED (S) (LET ((N (LENGTH S))) (AND (NOT (ZEROP N)) (LET ((C (SCHAR S 0))) (OR (
AND (ALPHA-CHAR-P C) (UPPER-CASE-P C)) (FIND C "*<>"))) (DO ((I 1 (1+ I))) ((= I N) T) (LET ((C (SCHAR
 S I))) (IF (NOT (OR (DIGIT-CHAR-P C) (AND (ALPHA-CHAR-P C) (UPPER-CASE-P C)) (FIND C "*+<>-"))) (
RETURN IL:NIL)))))))
(DEFUN PRINT (OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (
TERPRI STREAM) (LET ((*PRINT-ESCAPE* T)) (BASIC-WRITE OBJECT STREAM)) (WRITE-CHAR #\Space STREAM) 
OBJECT)
(DEFUN PRIN1 (OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (
LET ((*PRINT-ESCAPE* T)) (BASIC-WRITE OBJECT STREAM)) OBJECT)
(DEFUN PRINC (OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (
LET ((*PRINT-ESCAPE* IL:NIL)) (BASIC-WRITE OBJECT STREAM)) OBJECT)
(DEFUN PPRINT (OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (
TERPRI STREAM) (LET ((*PRINT-ESCAPE* T) (*PRINT-PRETTY* T)) (BASIC-WRITE OBJECT STREAM)) (VALUES))
(DEFUN WRITE-TO-STRING (OBJECT &REST PAIRS &KEY &ALLOW-OTHER-KEYS) (WITH-OUTPUT-TO-STRING (S) (APPLY (
FUNCTION WRITE) OBJECT :STREAM S PAIRS)))
(DEFUN PRINC-TO-STRING (OBJECT) (WITH-OUTPUT-TO-STRING (STREAM) (LET ((*PRINT-ESCAPE* IL:NIL)) (
BASIC-WRITE OBJECT STREAM))))
(DEFUN PRIN1-TO-STRING (OBJECT) (WITH-OUTPUT-TO-STRING (STREAM) (LET ((*PRINT-ESCAPE* T)) (BASIC-WRITE
 OBJECT STREAM))))
(DEFUN FORMAT (STREAM STRING-OR-FN &REST ARGS) (COND ((STRINGP STREAM) (CL:FORMAT STREAM "~A" (
WITH-OUTPUT-TO-STRING (STREAM) (APPLY (FUNCTION FORMAT) STREAM STRING-OR-FN ARGS))) IL:NIL) ((NULL 
STREAM) (WITH-OUTPUT-TO-STRING (STREAM) (APPLY (FUNCTION FORMAT) STREAM STRING-OR-FN ARGS))) (T (IF (
EQ STREAM T) (SETQ STREAM *STANDARD-OUTPUT*)) (WHEN (STRINGP STRING-OR-FN) (SETQ STRING-OR-FN (
PROCESS-FORMAT-STRING STRING-OR-FN IL:NIL))) (COND ((NOT (STRINGP STRING-OR-FN)) (APPLY STRING-OR-FN 
STREAM ARGS)) ((XP-STRUCTURE-P STREAM) (APPLY (FUNCTION USING-FORMAT) STREAM STRING-OR-FN ARGS)) (T (
APPLY (FUNCTION CL:FORMAT) STREAM STRING-OR-FN ARGS))) IL:NIL)))
(DEFVAR *FORMAT-STRING-CACHE* T)
(DEFUN PROCESS-FORMAT-STRING (STRING-OR-FN FORCE-FN?) (COND ((NOT (STRINGP STRING-OR-FN)) STRING-OR-FN
) (IL:* IL:\; "called from ~? too.") ((NOT *FORMAT-STRING-CACHE*) (MAYBE-COMPILE-FORMAT-STRING 
STRING-OR-FN FORCE-FN?)) (T (WHEN (NOT (HASH-TABLE-P *FORMAT-STRING-CACHE*)) (SETQ 
*FORMAT-STRING-CACHE* (MAKE-HASH-TABLE :TEST (FUNCTION EQ)))) (LET ((VALUE (GETHASH STRING-OR-FN 
*FORMAT-STRING-CACHE*))) (WHEN (OR (NOT VALUE) (AND FORCE-FN? (STRINGP VALUE))) (SETQ VALUE (
MAYBE-COMPILE-FORMAT-STRING STRING-OR-FN FORCE-FN?)) (SETF (GETHASH STRING-OR-FN *FORMAT-STRING-CACHE*
) VALUE)) VALUE))))
(DEFUN WRITE-LINE (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*) &KEY (START 0) (END (LENGTH STRING))) (
SETQ STREAM (DECODE-STREAM-ARG STREAM)) (IF (XP-STRUCTURE-P STREAM) (PROGN (WRITE-STRING+ STRING 
STREAM START END) (PPRINT-NEWLINE+ :UNCONDITIONAL STREAM)) (CL:WRITE-LINE STRING STREAM :START START 
:END END)) STRING)
(DEFUN WRITE-STRING (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*) &KEY (START 0) (END (LENGTH STRING)))
 (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (IF (XP-STRUCTURE-P STREAM) (WRITE-STRING+ STRING STREAM 
START END) (CL:WRITE-STRING STRING STREAM :START START :END END)) STRING)
(DEFUN WRITE-CHAR (CHAR &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM))
 (IF (XP-STRUCTURE-P STREAM) (WRITE-CHAR+ CHAR STREAM) (CL:WRITE-CHAR CHAR STREAM)) CHAR)
(DEFUN TERPRI (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (IF (
XP-STRUCTURE-P STREAM) (PPRINT-NEWLINE+ :UNCONDITIONAL STREAM) (CL:TERPRI STREAM)) IL:NIL)
(DEFUN FRESH-LINE (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (
COND ((XP-STRUCTURE-P STREAM) (ATTEMPT-TO-OUTPUT STREAM T T) (IL:* IL:\; "ok because we want newline")
 (WHEN (NOT (ZEROP (LP<-BP STREAM))) (PPRINT-NEWLINE+ :FRESH STREAM) T)) (T (CL:FRESH-LINE STREAM))))
(DEFUN FINISH-OUTPUT (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (
IF (XP-STRUCTURE-P STREAM) (ATTEMPT-TO-OUTPUT STREAM T T) (CL:FINISH-OUTPUT STREAM)) IL:NIL)
(DEFUN FORCE-OUTPUT (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (
IF (XP-STRUCTURE-P STREAM) (ATTEMPT-TO-OUTPUT STREAM T T) (CL:FORCE-OUTPUT STREAM)) IL:NIL)
(DEFUN CLEAR-OUTPUT (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (
IF (XP-STRUCTURE-P STREAM) (LET ((*LOCATING-CIRCULARITIES* 0)) (IL:* IL:\; 
"hack to prevent visible output") (ATTEMPT-TO-OUTPUT STREAM T T)) (CL:CLEAR-OUTPUT STREAM)) IL:NIL)
(DEFMACRO DEFSTRUCT (NAME &BODY BODY) (LET* ((STRUCT-NAME (IF (CONSP NAME) (CAR NAME) NAME)) (PRINTER 
(CADR (SAFE-ASSOC :PRINT-FUNCTION NAME))) (XP-PRINT-FN (INTERN (CONCATENATE (QUOTE STRING) "PRINT-" (
STRING (PACKAGE-NAME (SYMBOL-PACKAGE STRUCT-NAME))) ":" (STRING STRUCT-NAME)) (FIND-PACKAGE "XP")))) (
COND (PRINTER (IL:BQUOTE (EVAL-WHEN (EVAL LOAD COMPILE) (CL:DEFSTRUCT (IL:\\\, NAME) (IL:\\\,@ BODY)) 
(DEFUN (IL:\\\, XP-PRINT-FN) (XP OBJ) (FUNCALL (FUNCTION (IL:\\\, PRINTER)) OBJ XP *CURRENT-LEVEL*)) (
SETF (GET (QUOTE (IL:\\\, STRUCT-NAME)) (QUOTE CL::STRUCTURE-PRINTER)) (FUNCTION (IL:\\\, XP-PRINT-FN)
)) (QUOTE (IL:\\\, (IF (CONSP NAME) (CAR NAME) NAME)))))) ((AND (NOT (SAFE-ASSOC :TYPE NAME)) (NOT (
SAFE-ASSOC :INCLUDE NAME))) (LET* ((CONC-NAME-SPEC (SAFE-ASSOC :CONC-NAME NAME)) (CONC-NAME (COND ((
NULL CONC-NAME-SPEC) (CONCATENATE (QUOTE STRING) (STRING STRUCT-NAME) "-")) ((NULL (CADR 
CONC-NAME-SPEC)) "") (T (STRING (CADR CONC-NAME-SPEC))))) (SLOTS (MAPCAR (FUNCTION (LAMBDA (X) (IF (
CONSP X) (CAR X) X))) BODY))) (IL:BQUOTE (EVAL-WHEN (EVAL LOAD COMPILE) (CL:DEFSTRUCT (IL:\\\, NAME) (
IL:\\\,@ BODY)) (DEFUN (IL:\\\, XP-PRINT-FN) (XP OBJ) (FUNCALL (FORMATTER 
"~@<#S(~;~W ~:I~@_~@{:~A ~W~^ ~:_~}~;)~:>") XP (QUOTE (IL:\\\, STRUCT-NAME)) (IL:\\\,@ (MAPCAN (
FUNCTION (LAMBDA (SLOT) (IL:BQUOTE ((IL:\\\, (STRING SLOT)) ((IL:\\\, (INTERN (CONCATENATE (QUOTE 
STRING) CONC-NAME (STRING SLOT)))) OBJ))))) SLOTS)))) (SETF (GET (QUOTE (IL:\\\, STRUCT-NAME)) (QUOTE 
CL::STRUCTURE-PRINTER)) (FUNCTION (IL:\\\, XP-PRINT-FN))) (QUOTE (IL:\\\, (IF (CONSP NAME) (CAR NAME) 
NAME))))))) (T (IL:BQUOTE (EVAL-WHEN (EVAL LOAD COMPILE) (SETF (GET (QUOTE (IL:\\\, STRUCT-NAME)) (
QUOTE CL::STRUCTURE-PRINTER)) :NONE) (CL:DEFSTRUCT (IL:\\\, NAME) (IL:\\\,@ BODY))))))))
(DEFUN SAFE-ASSOC (ITEM LIST) (DO ((L LIST (CDR L))) ((NOT (CONSP L)) IL:NIL) (IF (AND (CONSP (CAR L))
 (EQ (CAAR L) ITEM)) (RETURN (CAR L)))))
(DEFUN CL::STRUCTURE-WITH-USER-PRINTER (CL::XP CL::OBJ) (IL:* IL:\; "Edited  7-Jan-92 14:27 by jrb:") 
(FUNCALL (CL::PS-PRINT-FUNCTION (CL::PARSED-STRUCTURE (TYPE-OF CL::OBJ))) CL::OBJ CL::XP 
*CURRENT-LEVEL*))
(DEFUN CL::STRUCTURE-WITH-DEFAULT-PRINTER (&REST CL::STUFF-TO-PRINT) (IL:* IL:\; 
"Edited  7-Jan-92 14:27 by jrb:") (APPLY (FORMATTER "~@<#S(~;~W ~:I~@_~@{:~A ~W~^ ~:_~}~;)~:>") 
CL::STUFF-TO-PRINT))
(DEFMACRO PPRINT-LOGICAL-BLOCK ((STREAM-SYMBOL LIST &KEY (PREFIX IL:NIL) (PER-LINE-PREFIX IL:NIL) (
SUFFIX "")) &BODY BODY) (COND ((EQ STREAM-SYMBOL IL:NIL) (SETQ STREAM-SYMBOL (QUOTE *STANDARD-OUTPUT*)
)) ((EQ STREAM-SYMBOL T) (SETQ STREAM-SYMBOL (QUOTE *TERMINAL-IO*)))) (WHEN (NOT (SYMBOLP 
STREAM-SYMBOL)) (WARN "STREAM-SYMBOL arg ~S to PPRINT-LOGICAL-BLOCK is not a bindable symbol" 
STREAM-SYMBOL) (SETQ STREAM-SYMBOL (QUOTE *STANDARD-OUTPUT*))) (WHEN (AND PREFIX PER-LINE-PREFIX) (
WARN "prefix ~S and per-line-prefix ~S cannot both be specified in PPRINT-LOGICAL-BLOCK" PREFIX 
PER-LINE-PREFIX) (SETQ PER-LINE-PREFIX IL:NIL)) (IL:BQUOTE (MAYBE-INITIATE-XP-PRINTING (FUNCTION (
LAMBDA ((IL:\\\, STREAM-SYMBOL)) (LET ((+L (IL:\\\, LIST)) (+P (IL:\\\, (OR PREFIX PER-LINE-PREFIX "")
)) (+S (IL:\\\, SUFFIX))) (PPRINT-LOGICAL-BLOCK+ ((IL:\\\, STREAM-SYMBOL) +L +P +S (IL:\\\, (NOT (NULL
 PER-LINE-PREFIX))) T IL:NIL) (IL:\\\,@ BODY) IL:NIL)))) (DECODE-STREAM-ARG (IL:\\\, STREAM-SYMBOL))))
)
(DEFMACRO PPRINT-LOGICAL-BLOCK+ ((VAR ARGS PREFIX SUFFIX PER-LINE? CIRCLE-CHECK? ATSIGN?) &BODY BODY) 
(WHEN (AND CIRCLE-CHECK? ATSIGN?) (SETQ CIRCLE-CHECK? (QUOTE NOT-FIRST-P))) (IL:BQUOTE (LET ((
*CURRENT-LEVEL* (1+ *CURRENT-LEVEL*)) (*CURRENT-LENGTH* -1) (*PARENTS* *PARENTS*) (IL:\\\,@ (IF (AND 
CIRCLE-CHECK? ATSIGN?) (IL:BQUOTE ((NOT-FIRST-P (PLUSP *CURRENT-LENGTH*))))))) (UNLESS (
CHECK-BLOCK-ABBREVIATION (IL:\\\, VAR) (IL:\\\, ARGS) (IL:\\\, CIRCLE-CHECK?)) (BLOCK LOGICAL-BLOCK (
START-BLOCK (IL:\\\, VAR) (IL:\\\, PREFIX) (IL:\\\, PER-LINE?) (IL:\\\, SUFFIX)) (UNWIND-PROTECT (
MACROLET ((PPRINT-POP IL:NIL (IL:BQUOTE (PPRINT-POP+ (IL:\\\, (QUOTE (IL:\\\, ARGS))) (IL:\\\, (QUOTE 
(IL:\\\, VAR)))))) (PPRINT-EXIT-IF-LIST-EXHAUSTED IL:NIL (IL:BQUOTE (IF (NULL (IL:\\\, (QUOTE (IL:\\\,
 ARGS)))) (RETURN-FROM LOGICAL-BLOCK IL:NIL))))) (IL:\\\,@ BODY)) (END-BLOCK (IL:\\\, VAR) (IL:\\\, 
SUFFIX))))))))
(DEFUN PPRINT-NEWLINE (KIND &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG 
STREAM)) (WHEN (NOT (MEMBER KIND (QUOTE (:LINEAR :MISER :FILL :MANDATORY)))) (ERROR 
"Invalid KIND argument ~A to PPRINT-NEWLINE" KIND)) (WHEN (XP-STRUCTURE-P STREAM) (PPRINT-NEWLINE+ 
KIND STREAM)) IL:NIL)
(DEFUN PPRINT-INDENT (RELATIVE-TO N &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (
DECODE-STREAM-ARG STREAM)) (WHEN (NOT (MEMBER RELATIVE-TO (QUOTE (:BLOCK :CURRENT)))) (ERROR 
"Invalid KIND argument ~A to PPRINT-INDENT" RELATIVE-TO)) (WHEN (XP-STRUCTURE-P STREAM) (
PPRINT-INDENT+ RELATIVE-TO N STREAM)) IL:NIL)
(DEFUN PPRINT-TAB (KIND COLNUM COLINC &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (
DECODE-STREAM-ARG STREAM)) (WHEN (NOT (MEMBER KIND (QUOTE (:LINE :SECTION :LINE-RELATIVE 
:SECTION-RELATIVE)))) (ERROR "Invalid KIND argument ~A to PPRINT-TAB" KIND)) (WHEN (XP-STRUCTURE-P 
STREAM) (PPRINT-TAB+ KIND COLNUM COLINC STREAM)) IL:NIL)
(PROCLAIM (QUOTE (SPECIAL *STRING* *USED-ARGS* *USED-OUTER-ARGS* *USED-INITIAL* *GET-ARG-CAREFULLY* 
*INNER-END* *OUTER-END* *AT-TOP* *DEFAULT-PACKAGE*)))
(DEFVAR *FN-TABLE* (MAKE-HASH-TABLE) "used to access fns for commands")
(XCL:DEF-DEFINE-TYPE FORMAT-HANDLERS "XP pretty-printer FORMAT handlers" :UNDEFINER 
FORMAT-HANDLER-UNDEFINE)
(XCL:DEFDEFINER DEF-FORMAT-HANDLER FORMAT-HANDLERS (CHAR ARGS &BODY BODY) (IL:BQUOTE (EVAL-WHEN (EVAL 
LOAD COMPILE) (LET ((HANDLER (FUNCTION (LAMBDA (IL:\\\, ARGS) (IL:\\\,@ BODY))))) (SETF (GETHASH (
CHAR-UPCASE (IL:\\\, CHAR)) *FN-TABLE*) HANDLER) (SETF (GETHASH (CHAR-DOWNCASE (IL:\\\, CHAR)) 
*FN-TABLE*) HANDLER)))))
(DEFUN FORMAT-HANDLER-UNDEFINE (CHAR) (SETF (GETHASH (CHAR-UPCASE CHAR) *FN-TABLE*) IL:NIL (GETHASH (
CHAR-DOWNCASE CHAR) *FN-TABLE*) IL:NIL))
(DEFUN INITIAL IL:NIL (SETQ *USED-INITIAL* T) (QUOTE INIT))
(DEFMACRO BIND-INITIAL (&BODY CODE) (IL:BQUOTE (LET* ((*USED-INITIAL* IL:NIL) (BODY (PROGN (IL:\\\,@ 
CODE)))) (IF *USED-INITIAL* (MAKE-BINDING (QUOTE INIT) (ARGS) BODY) BODY))))
(DEFMACRO MAYBE-BIND-INITIAL (DOIT? &BODY CODE) (IL:* IL:|;;| 
"Hacked to use *USED-INITIAL* bound higher up in ~{ handler") (IL:BQUOTE (LET ((BODY (PROGN (IL:\\\,@ 
CODE)))) (IF (AND (IL:\\\, DOIT?) *USED-INITIAL*) (MAKE-BINDING (QUOTE INIT) (ARGS) BODY) BODY))))
(DEFUN ARGS IL:NIL (SETQ *USED-ARGS* T) (QUOTE ARGS))
(DEFMACRO BIND-ARGS (DOIT? VAL &BODY CODE) (IF (EQ DOIT? T) (IL:BQUOTE (LET* ((VAL (IL:\\\, VAL)) (
*USED-ARGS* IL:NIL) (BODY (PROGN (IL:\\\,@ CODE)))) (IF *USED-ARGS* (MAKE-BINDING (QUOTE ARGS) VAL 
BODY) (CONS VAL BODY)))) (IL:BQUOTE (FLET ((CODE IL:NIL (IL:\\\,@ CODE))) (IF (NOT (IL:\\\, DOIT?)) (
CODE) (IL:* IL:\; "important bindings not done if not doit?") (LET* ((VAL (IL:\\\, VAL)) (*USED-ARGS* 
IL:NIL) (BODY (CODE))) (IF *USED-ARGS* (MAKE-BINDING (QUOTE ARGS) VAL BODY) (CONS VAL BODY))))))))
(DEFUN OUTER-ARGS IL:NIL (SETQ *USED-OUTER-ARGS* T) (QUOTE OUTER-ARGS))
(DEFMACRO BIND-OUTER-ARGS (&BODY CODE) (IL:BQUOTE (LET* ((*USED-OUTER-ARGS* IL:NIL) (BODY (PROGN (
IL:\\\,@ CODE)))) (IF *USED-OUTER-ARGS* (MAKE-BINDING (QUOTE OUTER-ARGS) (ARGS) BODY) BODY))))
(DEFMACRO MAYBE-BIND (DOIT? VAR VAL &BODY CODE) (IL:BQUOTE (LET ((BODY (PROGN (IL:\\\,@ CODE)))) (IF (
IL:\\\, DOIT?) (MAKE-BINDING (IL:\\\, VAR) (IL:\\\, VAL) BODY) BODY))))
(DEFUN MAKE-BINDING (VAR VALUE BODY) (IL:BQUOTE ((LET (((IL:\\\, VAR) (IL:\\\, VALUE))) (IL:\\\,@ BODY
)))))
(DEFUN NUM-ARGS IL:NIL (IL:BQUOTE (LENGTH (IL:\\\, (ARGS)))))
(DEFUN GET-ARG IL:NIL (IF *GET-ARG-CAREFULLY* (IF *AT-TOP* (IL:BQUOTE (PPRINT-POP+TOP (IL:\\\, (ARGS))
 XP)) (IL:BQUOTE (PPRINT-POP+ (IL:\\\, (ARGS)) XP))) (IL:BQUOTE (POP (IL:\\\, (ARGS))))))
(DEFMACRO PPRINT-POP+ (ARGS XP) (IL:BQUOTE (IF (PPRINT-POP-CHECK+ (IL:\\\, ARGS) (IL:\\\, XP)) (
RETURN-FROM LOGICAL-BLOCK IL:NIL) (POP (IL:\\\, ARGS)))))
(DEFUN PPRINT-POP-CHECK+ (ARGS XP) (INCF *CURRENT-LENGTH*) (COND ((NOT (LISTP ARGS)) (IL:* IL:|;;| 
"must be first so supersedes length abbrev") (WRITE-STRING++ ". " XP 0 2) (WRITE+ ARGS XP) T) ((AND 
*PRINT-LENGTH* (IL:* IL:\; "must supersede circle check") (NOT (< *CURRENT-LENGTH* *PRINT-LENGTH*))) (
WRITE-STRING++ "..." XP 0 3) (SETQ *ABBREVIATION-HAPPENED* T) T) ((AND *CIRCULARITY-HASH-TABLE* (NOT (
ZEROP *CURRENT-LENGTH*))) (CASE (CIRCULARITY-PROCESS XP ARGS T) (:FIRST (IL:* IL:|;;| 
"note must inhibit rechecking of circularity for args.") (WRITE+ (CONS (CAR ARGS) (CDR ARGS)) XP) T) (
:SUBSEQUENT T) (T IL:NIL)))))
(DEFMACRO PPRINT-POP+TOP (ARGS XP) (IL:BQUOTE (IF (PPRINT-POP-CHECK+TOP (IL:\\\, ARGS) (IL:\\\, XP)) (
RETURN-FROM LOGICAL-BLOCK IL:NIL) (POP (IL:\\\, ARGS)))))
(DEFUN PPRINT-POP-CHECK+TOP (ARGS XP) (INCF *CURRENT-LENGTH*) (COND ((NOT (LISTP ARGS)) (IL:* IL:|;;| 
"must be first so supersedes length abbrev") (WRITE-STRING++ ". " XP 0 2) (WRITE+ ARGS XP) T) ((AND 
*PRINT-LENGTH* (IL:* IL:\; "must supersede circle check") (NOT (< *CURRENT-LENGTH* *PRINT-LENGTH*))) (
WRITE-STRING++ "..." XP 0 3) (SETQ *ABBREVIATION-HAPPENED* T) T)))
(DEFUN LITERAL (START END) (LET ((SUB-END IL:NIL) NEXT-NEWLINE (RESULT IL:NIL)) (LOOP (SETQ 
NEXT-NEWLINE (POSITION #\Newline *STRING* :START START :END END)) (SETQ SUB-END (IF NEXT-NEWLINE 
NEXT-NEWLINE END)) (WHEN (< START SUB-END) (PUSH (IF (= START (1- SUB-END)) (IL:BQUOTE (WRITE-CHAR++ (
IL:\\\, (AREF *STRING* START)) XP)) (IL:BQUOTE (WRITE-STRING++ (IL:\\\, (SUBSEQ *STRING* START SUB-END
)) XP (IL:\\\, 0) (IL:\\\, (- SUB-END START))))) RESULT)) (WHEN (NULL NEXT-NEWLINE) (RETURN IL:NIL)) (
PUSH (IL:BQUOTE (PPRINT-NEWLINE+ :UNCONDITIONAL XP)) RESULT) (SETQ START (1+ SUB-END))) (IF (NULL (CDR
 RESULT)) (CAR RESULT) (CONS (QUOTE PROGN) (NREVERSE RESULT)))))
(DEFUN FORMAT-STRING-READER (STREAM SUB-CHAR ARG) (DECLARE (IGNORE ARG)) (UNREAD-CHAR SUB-CHAR STREAM)
 (IL:BQUOTE (FORMATTER-IN-PACKAGE (IL:\\\, (READ STREAM)) (IL:\\\, (PACKAGE-NAME *PACKAGE*)))))
(DEFMACRO FORMATTER-IN-PACKAGE (STRING READER-PACKAGE) (FORMATTER-FN STRING READER-PACKAGE))
(DEFMACRO FORMATTER (STRING) (FORMATTER-FN STRING "USER"))
(DEFUN FORMATTER-FN (*STRING* *DEFAULT-PACKAGE*) (OR (CATCH :FORMAT-COMPILATION-ERROR (IL:BQUOTE (
FUNCTION (LAMBDA (S &REST ARGS) (APPLY (FUNCTION MAYBE-INITIATE-XP-PRINTING) (FUNCTION (LAMBDA (XP 
&REST ARGS) (IL:\\\,@ (BIND-INITIAL (IL:BQUOTE ((BLOCK TOP (IL:\\\,@ (LET ((*GET-ARG-CAREFULLY* IL:NIL
) (*AT-TOP* T) (*INNER-END* (QUOTE TOP)) (*OUTER-END* (QUOTE TOP))) (COMPILE-FORMAT 0 (LENGTH *STRING*
))))))))) (IF (IL:\\\, (ARGS)) (COPY-LIST (IL:\\\, (ARGS)))))) (IL:* IL:\; "needed by symbolics.") S 
ARGS))))) *STRING*))
(DEFUN MAYBE-COMPILE-FORMAT-STRING (STRING FORCE-FN?) (IF (NOT (OR FORCE-FN? (FANCY-DIRECTIVES-P 
STRING))) STRING (EVAL (IL:BQUOTE (FORMATTER (IL:\\\, STRING))))))
(DEFVAR *TESTING-ERRORS* IL:NIL "Used only when testing XP")
(DEFUN ERR (ID MSG I) (IF *TESTING-ERRORS* (THROW :TESTING-ERRORS (LIST ID I))) (WARN 
"XP: cannot compile format string ~%~A~%~S~%~V@T|" MSG *STRING* (1+ I)) (THROW 
:FORMAT-COMPILATION-ERROR IL:NIL))
(DEFUN POSITION-IN (SET START) (POSITION-IF (FUNCTION (LAMBDA (C) (FIND C SET))) *STRING* :START START
))
(DEFUN POSITION-NOT-IN (SET START) (POSITION-IF-NOT (FUNCTION (LAMBDA (C) (FIND C SET))) *STRING* 
:START START))
(DEFUN NEXT-DIRECTIVE1 (START END) (LET ((I (POSITION #\~ *STRING* :START START :END END)) J) (WHEN I 
(SETQ J (PARAMS-END (1+ I))) (WHEN (CHAR= (AREF *STRING* J) #\/) (SETQ J (POSITION #\/ *STRING* :START
 (1+ J) :END END)) (WHEN (NULL J) (ERR 3 "Matching / missing" (POSITION #\/ *STRING* :START START)))))
 (VALUES I J)))
(DEFUN PARAMS-END (START) (IL:* IL:\; "start points just after ~") (LET ((J START) (END (LENGTH 
*STRING*))) (LOOP (SETQ J (POSITION-NOT-IN "+-0123456789,Vv@" J)) (WHEN (NULL J) (ERR 1 
"missing directive" (1- START))) (WHEN (NOT (EQ (AREF *STRING* J) #\')) (RETURN J)) (INCF J) (IF (= J 
END) (ERR 2 "No character after '" (1- J))) (INCF J))))
(DEFUN DIRECTIVE-START (END) (IL:* IL:\; "end points at characters after params") (LOOP (SETQ END (
POSITION #\~ *STRING* :END END :FROM-END T)) (WHEN (OR (ZEROP END) (NOT (EQ (AREF *STRING* (1- END)) 
#\'))) (RETURN END)) (DECF END)))
(DEFUN NEXT-DIRECTIVE (START END) (LET (I J II K COUNT C CLOSE (PAIRS (QUOTE ((#\( . #\)) (#\[ . #\]) 
(#\< . #\>) (#\{ . #\}))))) (MULTIPLE-VALUE-SETQ (I J) (NEXT-DIRECTIVE1 START END)) (WHEN I (SETQ C (
AREF *STRING* J)) (SETQ CLOSE (CDR (ASSOC C PAIRS))) (WHEN CLOSE (SETQ K J COUNT 0) (LOOP (
MULTIPLE-VALUE-SETQ (II K) (NEXT-DIRECTIVE1 K END)) (WHEN (NULL II) (ERR 4 
"No matching close directive" J)) (WHEN (EQL (AREF *STRING* K) C) (INCF COUNT)) (WHEN (EQL (AREF 
*STRING* K) CLOSE) (DECF COUNT) (WHEN (MINUSP COUNT) (SETQ J K) (RETURN IL:NIL)))))) (VALUES C I J)))
(DEFUN CHUNK-UP (START END) (LET ((POSITIONS (LIST START)) (SPOT START)) (LOOP (MULTIPLE-VALUE-BIND (C
 I J) (NEXT-DIRECTIVE SPOT END) (DECLARE (IGNORE I)) (WHEN (NULL C) (RETURN (NREVERSE (CONS END 
POSITIONS)))) (WHEN (EQL C #\;) (PUSH (1+ J) POSITIONS)) (SETQ SPOT J)))))
(DEFUN FANCY-DIRECTIVES-P (*STRING*) (LET (I (J 0) (END (LENGTH *STRING*)) C) (LOOP (
MULTIPLE-VALUE-SETQ (I J) (NEXT-DIRECTIVE1 J END)) (WHEN (NOT I) (RETURN IL:NIL)) (SETQ C (AREF 
*STRING* J)) (WHEN (OR (FIND C "_Ii/Ww") (AND (FIND C ">Tt") (COLONP J))) (RETURN T)))))
(DEFUN NUM-ARGS-IN-ARGS (START &OPTIONAL (ERR IL:NIL)) (LET ((N 0) (I (1- START)) C) (LOOP (SETQ I (
POSITION-NOT-IN "+-0123456789," (1+ I))) (SETQ C (AREF *STRING* I)) (COND ((OR (CHAR= C #\V) (CHAR= C 
#\v)) (INCF N)) ((CHAR= C #\#) (WHEN ERR (ERR 21 "# not allowed in ~~<...~~> by (formatter \"...\")" 
START)) (RETURN IL:NIL)) ((CHAR= C #\') (INCF I)) (T (RETURN N))))))
(DEFUN COMPILE-FORMAT (START END) (LET ((RESULT IL:NIL)) (PROG (C I J FN) L (MULTIPLE-VALUE-SETQ (C I 
J) (NEXT-DIRECTIVE START END)) (WHEN (IF (NULL C) (< START END) (< START I)) (PUSH (LITERAL START (IF 
I I END)) RESULT)) (WHEN (NULL C) (RETURN (NREVERSE RESULT))) (WHEN (CHAR= C #\Newline) (
MULTIPLE-VALUE-BIND (COLON ATSIGN) (PARSE-PARAMS (1+ I) IL:NIL :NOCOLONATSIGN T) (WHEN ATSIGN (PUSH (
IL:BQUOTE (PPRINT-NEWLINE+ :UNCONDITIONAL XP)) RESULT)) (INCF J) (WHEN (NOT COLON) (SETQ J (
POSITION-IF-NOT (FUNCTION (LAMBDA (C) (OR (CHAR= C #\Tab) (CHAR= C #\Space)))) *STRING* :START J :END 
END)) (WHEN (NULL J) (SETQ J END))) (SETQ START J) (GO L))) (SETQ FN (GETHASH C *FN-TABLE*)) (WHEN (
NULL FN) (ERR 5 "Unknown format directive" J)) (INCF J) (PUSH (FUNCALL FN (1+ I) J) RESULT) (SETQ 
START J) (GO L))))
(DEFUN PARSE-PARAMS (START DEFAULTS &KEY (MAX (LENGTH DEFAULTS)) (NOCOLON IL:NIL) (NOATSIGN IL:NIL) (
NOCOLONATSIGN IL:NIL)) (LET ((COLON IL:NIL) (ATSIGN IL:NIL) (PARAMS IL:NIL) (I START) J C) (LOOP (SETQ
 C (AREF *STRING* I)) (COND ((OR (CHAR= C #\V) (CHAR= C #\v)) (PUSH (GET-ARG) PARAMS) (INCF I)) ((
CHAR= C #\#) (PUSH (NUM-ARGS) PARAMS) (INCF I)) ((CHAR= C #\') (INCF I) (PUSH (AREF *STRING* I) PARAMS
) (INCF I)) ((CHAR= C #\,) (PUSH IL:NIL PARAMS)) (T (SETQ J (POSITION-NOT-IN "+-0123456789" I)) (IF (=
 I J) (RETURN IL:NIL)) (PUSH (PARSE-INTEGER *STRING* :START I :END J :RADIX 10) PARAMS) (SETQ I J))) (
IF (CHAR= (AREF *STRING* I) #\,) (INCF I) (RETURN IL:NIL))) (SETQ PARAMS (NREVERSE PARAMS)) (DO ((PS 
PARAMS (CDR PS)) (DS DEFAULTS (CDR DS)) (NPS IL:NIL)) ((NULL DS) (SETQ PARAMS (NRECONC NPS PS))) (PUSH
 (COND ((OR (NULL PS) (NULL (CAR PS))) (CAR DS)) ((NOT (CONSP (CAR PS))) (CAR PS)) (T (IL:BQUOTE (COND
 ((IL:\\\, (CAR PS))) (T (IL:\\\, (CAR DS))))))) NPS)) (IF (AND MAX (< MAX (LENGTH PARAMS))) (ERR 6 
"Too many parameters" I)) (LOOP (SETQ C (AREF *STRING* I)) (COND ((CHAR= C #\:) (IF COLON (ERR 7 
"Two colons specified" I)) (SETQ COLON T)) ((CHAR= C #\@) (IF ATSIGN (ERR 8 "Two atsigns specified" I)
) (SETQ ATSIGN T)) (T (RETURN IL:NIL))) (INCF I)) (IF (AND COLON NOCOLON) (ERR 9 "Colon not permitted"
 I)) (IF (AND ATSIGN NOATSIGN) (ERR 10 "Atsign not permitted" I)) (IF (AND COLON ATSIGN NOCOLONATSIGN)
 (ERR 11 "Colon and atsign together not permitted" I)) (VALUES COLON ATSIGN PARAMS)))
(DEFUN COLONP (J) (IL:* IL:\; "j points to directive name") (OR (EQL (AREF *STRING* (1- J)) #\:) (AND 
(EQL (AREF *STRING* (1- J)) #\@) (EQL (AREF *STRING* (- J 2)) #\:))))
(DEFUN ATSIGNP (J) (IL:* IL:\; "j points to directive name") (OR (EQL (AREF *STRING* (1- J)) #\@) (AND
 (EQL (AREF *STRING* (1- J)) #\:) (EQL (AREF *STRING* (- J 2)) #\@))))
(DEFVAR *FAST-FORMATTER-SLASH-CALL* (QUOTE (PPRINT-LINEAR PPRINT-FILL PPRINT-TABULAR MAYBELAB 
BLOCK-LIKE BIND-LIST)) "Functions to make hard links to in ~/.../ FORMATTER code.")
(DEFVAR *FORMATTER-SLASH-PARANOIA* T 
"If non-NIL, formatter calls to ~/.../ functions check for forms whose CAR is on *formatter-slash-paranoia-list*; those forms do NOT call the ~/.../ function but instead get printed by WRITE+"
)
(DEFVAR *FORMATTER-SLASH-PARANOIA-LIST* (QUOTE (IL:BQUOTE IL:\\\, IL:\\\,@)) 
"Initially paranoia is only applied to backquote operators.")
(DEF-FORMAT-HANDLER #\/ (START END) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START 
IL:NIL :MAX IL:NIL) (LET* ((WHOLE-NAME-START (1+ (PARAMS-END START))) (COLON-POS (POSITION #\: 
*STRING* :START WHOLE-NAME-START :END (1- END))) (PKG (FIND-PACKAGE (IF COLON-POS (STRING-UPCASE (
SUBSEQ *STRING* WHOLE-NAME-START COLON-POS)) *DEFAULT-PACKAGE*))) (NAME-START (COND ((NULL COLON-POS) 
WHOLE-NAME-START) ((AND (< COLON-POS (1- END)) (CHAR= #\: (AREF *STRING* (1+ COLON-POS)))) (+ 
COLON-POS 2)) (T (1+ COLON-POS)))) (FN (INTERN (STRING-UPCASE (SUBSEQ *STRING* NAME-START (1- END))) 
PKG)) (FN-NAME (IF (MEMBER FN *FAST-FORMATTER-SLASH-CALL*) (IL:BQUOTE (FUNCTION (IL:\\\, FN))) (
IL:BQUOTE (SYMBOL-FUNCTION (QUOTE (IL:\\\, FN))))))) (IL:* IL:|;;;| "Hacks of interest below:") (IL:* 
IL:|;;;| 
"*FAST-FORMATTER-SLASH-CALL* makes ~/.../ calls to functions on that list turn into #'... rather than (SYMBOL-FUNCTION '...) which should improve performance a bit."
) (IL:* IL:|;;;| 
"*FORMATTER-SLASH-PARANOIA* tells ~/.../ to check for forms whose CAR is on *FORMATTER-SLASH-PARANOIA-LIST*, and to NOT call the ... function for those.  This is currently used to catch our back-quote wrappers."
) (IF *FORMATTER-SLASH-PARANOIA* (IF (NOT (FIND-IF (FUNCTION CONSP) PARAMS)) (IL:BQUOTE (LET ((
LOCAL-ARG (IL:\\\, (GET-ARG)))) (IF (AND (CONSP LOCAL-ARG) (MEMBER (CAR LOCAL-ARG) 
*FORMATTER-SLASH-PARANOIA-LIST*)) (WRITE+ LOCAL-ARG XP) (FUNCALL (IL:\\\, FN-NAME) XP LOCAL-ARG (IL:\\\,
 COLON) (IL:\\\, ATSIGN) (IL:\\\,@ PARAMS))))) (LET ((VARS (MAPCAR (FUNCTION (LAMBDA (ARG) (DECLARE (
IGNORE ARG)) (GENTEMP))) PARAMS))) (IL:BQUOTE (LET ((IL:\\\,@ (MAPCAR (FUNCTION LIST) VARS PARAMS)) (
LOCAL-ARG (IL:\\\, (GET-ARG)))) (IF (AND (CONSP LOCAL-ARG) (MEMBER (CAR LOCAL-ARG) 
*FORMATTER-SLASH-PARANOIA-LIST*)) (WRITE+ LOCAL-ARG XP) (FUNCALL (IL:\\\, FN-NAME) XP LOCAL-ARG (IL:\\\,
 COLON) (IL:\\\, ATSIGN) (IL:\\\,@ VARS))))))) (IF (NOT (FIND-IF (FUNCTION CONSP) PARAMS)) (IL:BQUOTE 
(FUNCALL (IL:\\\, FN-NAME) XP (IL:\\\, (GET-ARG)) (IL:\\\, COLON) (IL:\\\, ATSIGN) (IL:\\\,@ PARAMS)))
 (LET ((VARS (MAPCAR (FUNCTION (LAMBDA (ARG) (DECLARE (IGNORE ARG)) (GENTEMP))) PARAMS))) (IL:BQUOTE (
LET (IL:\\\, (MAPCAR (FUNCTION LIST) VARS PARAMS)) (FUNCALL (IL:\\\, FN-NAME) XP (IL:\\\, (GET-ARG)) (
IL:\\\, COLON) (IL:\\\, ATSIGN) (IL:\\\,@ VARS))))))))))
(DEF-FORMAT-HANDLER #\A (START END) (IF (NOT (= END (1+ START))) (SIMPLE-DIRECTIVE START END) (IL:BQUOTE
 (LET ((*PRINT-ESCAPE* IL:NIL)) (WRITE+ (IL:\\\, (GET-ARG)) XP)))))
(DEF-FORMAT-HANDLER #\S (START END) (IF (NOT (= END (1+ START))) (SIMPLE-DIRECTIVE START END) (IL:BQUOTE
 (LET ((*PRINT-ESCAPE* T)) (WRITE+ (IL:\\\, (GET-ARG)) XP)))))
(DEF-FORMAT-HANDLER #\D (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\B (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\O (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\X (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\R (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\C (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\F (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\E (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\G (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\$ (START END) (SIMPLE-DIRECTIVE START END))
(DEFUN SIMPLE-DIRECTIVE (START END) (LET ((N (NUM-ARGS-IN-ARGS START))) (IF N (IL:BQUOTE (USING-FORMAT
 XP (IL:\\\, (SUBSEQ *STRING* (1- START) END)) (IL:\\\,@ (COPY-TREE (MAKE-LIST (1+ N) :INITIAL-ELEMENT
 (GET-ARG)))))) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START IL:NIL :MAX 8) (LET* ((
ARG-STR (SUBSEQ "v,v,v,v,v,v,v,v" 0 (MAX 0 (1- (* 2 (LENGTH PARAMS)))))) (STR (CONCATENATE (QUOTE 
STRING) "~" ARG-STR (IF COLON ":" "") (IF ATSIGN "@" "") (SUBSEQ *STRING* (1- END) END)))) (IL:BQUOTE 
(USING-FORMAT XP (IL:\\\, STR) (IL:\\\,@ PARAMS) (IL:\\\, (GET-ARG)))))))))
(DEFUN USING-FORMAT (XP STRING &REST ARGS) (IL:* IL:|;;| 
"The code below is bogus in our merged world; we can just print the damned thing.  The clear intent of this code is to non-pretty-print something; the way we're doing it, it should be sufficient to turn *print-pretty* off"
) (IL:* IL:|;;| 
"(LET ((RESULT (APPLY #'CL:FORMAT NIL STRING ARGS))) (WRITE-STRING+ RESULT XP 0 (LENGTH RESULT)))") (
IL:* IL:|;;| 
"This should \"really\" be a macro, except that it is APPLYed several places in XP.  I suspect an optimizer is in order here..."
) (LET (*PRINT-PRETTY*) (APPLY (FUNCTION CL:FORMAT) XP STRING ARGS)))
(DEF-FORMAT-HANDLER #\P (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (
PARSE-PARAMS START IL:NIL) (LET ((ARG (IF COLON (IL:BQUOTE (CAR (BACKUP-IN-LIST 1 (IL:\\\, (INITIAL)) 
(IL:\\\, (ARGS))))) (GET-ARG)))) (IF ATSIGN (IL:BQUOTE (IF (NOT (EQL (IL:\\\, ARG) 1)) (WRITE-STRING++
 "ies" XP 0 3) (WRITE-CHAR++ #\y XP))) (IL:BQUOTE (IF (NOT (EQL (IL:\\\, ARG) 1)) (WRITE-CHAR++ #\s XP
)))))))
(DEF-FORMAT-HANDLER #\% (START END) (DECLARE (IGNORE END)) (MULTIPLE-NEWLINES START :UNCONDITIONAL))
(DEF-FORMAT-HANDLER #\& (START END) (DECLARE (IGNORE END)) (MULTIPLE-NEWLINES START :FRESH))
(DEFUN MULTIPLE-NEWLINES (START KIND) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (
QUOTE (1)) :NOCOLON T :NOATSIGN T) (DECLARE (IGNORE COLON ATSIGN)) (IF (EQL (CAR PARAMS) 1) (IL:BQUOTE
 (PPRINT-NEWLINE+ (IL:\\\, KIND) XP)) (IL:BQUOTE (MULTIPLE-NEWLINES1 XP (IL:\\\, KIND) (IL:\\\, (CAR 
PARAMS)))))))
(DEFUN MULTIPLE-NEWLINES1 (XP KIND NUM) (DO ((N NUM (1- N))) ((NOT (PLUSP N))) (PPRINT-NEWLINE+ KIND 
XP) (SETQ KIND :UNCONDITIONAL)))
(DEF-FORMAT-HANDLER #\| (START END) (DECLARE (IGNORE END)) (MULTIPLE-CHARS START #\Page))
(DEF-FORMAT-HANDLER #\~ (START END) (DECLARE (IGNORE END)) (MULTIPLE-CHARS START #\~))
(DEFUN MULTIPLE-CHARS (START CHAR) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (
QUOTE (1)) :NOCOLON T :NOATSIGN T) (DECLARE (IGNORE COLON ATSIGN)) (IF (EQL (CAR PARAMS) 1) (IL:BQUOTE
 (WRITE-CHAR++ (IL:\\\, CHAR) XP)) (IL:BQUOTE (MULTIPLE-CHARS1 XP (IL:\\\, (CAR PARAMS)) (IL:\\\, CHAR
))))))
(DEFUN MULTIPLE-CHARS1 (XP NUM CHAR) (DO ((N NUM (1- N))) ((NOT (PLUSP N))) (WRITE-CHAR++ CHAR XP)))
(DEF-FORMAT-HANDLER #\T (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) 
(PARSE-PARAMS START (QUOTE (1 1))) (IL:BQUOTE (PPRINT-TAB+ (IL:\\\, (IF COLON (IF ATSIGN 
:SECTION-RELATIVE :SECTION) (IF ATSIGN :LINE-RELATIVE :LINE))) (IL:\\\, (POP PARAMS)) (IL:\\\, (POP 
PARAMS)) XP))))
(DEF-FORMAT-HANDLER #\* (START END) (DECLARE (IGNORE END)) (IF (ATSIGNP (PARAMS-END START)) (
MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (QUOTE (0)) :NOCOLON T) (DECLARE (IGNORE
 COLON ATSIGN)) (IL:BQUOTE (SETQ ARGS (BACKUP-TO (IL:\\\, (CAR PARAMS)) (IL:\\\, (INITIAL)) (IL:\\\, (
ARGS)))))) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (QUOTE (1))) (DECLARE (
IGNORE ATSIGN)) (IL:BQUOTE (SETQ ARGS (IL:\\\, (IF COLON (IL:BQUOTE (BACKUP-IN-LIST (IL:\\\, (CAR 
PARAMS)) (IL:\\\, (INITIAL)) (IL:\\\, (ARGS)))) (IL:BQUOTE (NTHCDR (IL:\\\, (CAR PARAMS)) (IL:\\\, (
ARGS)))))))))))
(DEFUN BACKUP-IN-LIST (NUM LIST SOME-TAIL) (BACKUP-TO (- (TAIL-POS LIST SOME-TAIL) NUM) LIST SOME-TAIL
))
(DEFUN BACKUP-TO (NUM LIST SOME-TAIL) (IF (NOT *CIRCULARITY-HASH-TABLE*) (NTHCDR NUM LIST) (
MULTIPLE-VALUE-BIND (POS SHARE) (TAIL-POS LIST SOME-TAIL) (DECLARE (IGNORE POS)) (IF (NOT (< NUM SHARE
)) (NTHCDR NUM LIST) (DO ((L (NTHCDR NUM LIST) (CDR L)) (N (- SHARE NUM) (1- N)) (R IL:NIL (CONS (CAR 
L) R))) ((ZEROP N) (NRECONC R L)))))))
(DEFUN TAIL-POS (LIST SOME-TAIL) (BLOCK OUTER (DO ((N 0 (1+ N)) (L LIST (CDR L))) (IL:NIL) (DO ((M N (
1- M)) (ST SOME-TAIL (CDR ST))) (IL:NIL) (IF (MINUSP M) (RETURN IL:NIL)) (IF (EQ ST L) (RETURN-FROM 
OUTER (VALUES M N)))))))
(DEF-FORMAT-HANDLER #\? (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (
PARSE-PARAMS START IL:NIL :NOCOLON T) (DECLARE (IGNORE COLON)) (IF (NOT ATSIGN) (IL:BQUOTE (APPLY (
FUNCTION FORMAT) XP (IL:\\\, (GET-ARG)) (IL:\\\, (GET-ARG)))) (IL:BQUOTE (LET ((FN (
PROCESS-FORMAT-STRING (IL:\\\, (GET-ARG)) T))) (SETQ ARGS (APPLY FN XP (IL:\\\, (ARGS)))))))))
(DEF-FORMAT-HANDLER #\^ (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) 
(PARSE-PARAMS START IL:NIL :MAX 3 :NOATSIGN T) (DECLARE (IGNORE ATSIGN)) (IL:BQUOTE (IF (IL:\\\, (COND
 ((NULL PARAMS) (IL:BQUOTE (NULL (IL:\\\, (IF COLON (IL:BQUOTE (CDR (IL:\\\, (OUTER-ARGS)))) (ARGS))))
)) (T (IL:BQUOTE (DO-COMPLEX-^-TEST (IL:\\\,@ PARAMS)))))) (RETURN-FROM (IL:\\\, (IF COLON *OUTER-END*
 *INNER-END*)) IL:NIL)))))
(DEFUN DO-COMPLEX-^-TEST (A1 &OPTIONAL (A2 IL:NIL) (A3 IL:NIL)) (COND (A3 (AND (<= A1 A2) (<= A2 A3)))
 (A2 (= A1 A2)) (T (= 0 A1))))
(DEF-FORMAT-HANDLER #\[ (START END) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START 
IL:NIL :MAX 1 :NOCOLONATSIGN T) (SETQ START (1+ (PARAMS-END START))) (LET* ((CHUNKS (CHUNK-UP START 
END)) (INNARDS (DO ((NS CHUNKS (CDR NS)) (MS (CDR CHUNKS) (CDR MS)) (RESULT IL:NIL)) ((NULL MS) (
RETURN (NREVERSE RESULT))) (PUSH (COMPILE-FORMAT (CAR NS) (DIRECTIVE-START (CAR MS))) RESULT)))) (COND
 (COLON (WHEN (NOT (= (LENGTH INNARDS) 2)) (ERR 13 "Wrong number of clauses in ~~:[...~~]" (1- START))
) (IL:BQUOTE (COND ((NULL (IL:\\\, (GET-ARG))) (IL:\\\,@ (CAR INNARDS))) (T (IL:\\\,@ (CADR INNARDS)))
))) (ATSIGN (WHEN (NOT (= (LENGTH INNARDS) 1)) (ERR 14 "Too many clauses in ~~@[...~~]" (1- START))) (
IL:BQUOTE (COND ((CAR ARGS) (IL:\\\,@ (CAR INNARDS))) (T (IL:\\\, (GET-ARG)))))) (T (LET* ((J -1) (LEN
 (- (LENGTH CHUNKS) 2)) (ELSE? (COLONP (1- (NTH LEN CHUNKS))))) (IL:BQUOTE (CASE (IL:\\\, (IF PARAMS (
CAR PARAMS) (GET-ARG))) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (UNIT) (INCF J) (IL:BQUOTE ((IL:\\\, (IF (
AND ELSE? (= J LEN)) T J)) (IL:\\\,@ UNIT))))) INNARDS))))))))))
(DEF-FORMAT-HANDLER #\( (START END) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (PARSE-PARAMS START IL:NIL) (
SETQ START (1+ (PARAMS-END START))) (SETQ END (DIRECTIVE-START END)) (IL:BQUOTE (PROGN (PUSH-CHAR-MODE
 XP (IL:\\\, (COND ((AND COLON ATSIGN) :UP) (COLON :CAP1) (ATSIGN :CAP0) (T :DOWN)))) (IL:\\\,@ (
COMPILE-FORMAT START END)) (POP-CHAR-MODE XP)))))
(DEF-FORMAT-HANDLER #\; (START END) (DECLARE (IGNORE START)) (ERR 15 "~~; appears out of context" (1- 
END)))
(DEF-FORMAT-HANDLER #\] (START END) (DECLARE (IGNORE START)) (ERR 16 "Unmatched closing directive" (1-
 END)))
(DEF-FORMAT-HANDLER #\) (START END) (DECLARE (IGNORE START)) (ERR 17 "Unmatched closing directive" (1-
 END)))
(DEF-FORMAT-HANDLER #\> (START END) (DECLARE (IGNORE START)) (ERR 18 "Unmatched closing directive" (1-
 END)))
(DEF-FORMAT-HANDLER #\} (START END) (DECLARE (IGNORE START)) (ERR 19 "Unmatched closing directive" (1-
 END)))
(DEF-FORMAT-HANDLER #\{ (START END) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (
QUOTE (-1)) :MAX 1) (LET* ((FORCE-ONCE (COLONP (1- END))) (N (CAR PARAMS)) (BOUNDED (NOT (EQL N -1))) 
(*USED-INITIAL* IL:NIL)) (SETQ START (1+ (PARAMS-END START))) (SETQ END (DIRECTIVE-START END)) (CAR (
MAYBE-BIND BOUNDED (QUOTE N) N (IL:* IL:\; "must be outermost if is V or #") (MAYBE-BIND (NOT (> END 
START)) (QUOTE FN) (IL:* IL:\; "must be second") (IL:BQUOTE (PROCESS-FORMAT-STRING (IL:\\\, (GET-ARG))
 T)) (BIND-ARGS (NOT ATSIGN) (GET-ARG) (IL:BQUOTE ((IL:\\\,@ (MAYBE-BIND-INITIAL (OR (NOT ATSIGN) (NOT
 COLON)) (IL:BQUOTE ((PROG IL:NIL (IL:\\\,@ (IF FORCE-ONCE (QUOTE ((GO S))))) L (IF (NULL (IL:\\\, (
ARGS))) (RETURN IL:NIL)) (IL:\\\,@ (IF FORCE-ONCE (QUOTE (S)))) (IL:\\\,@ (IF BOUNDED (QUOTE ((IF (= N
 0) (RETURN IL:NIL) (DECF N)))))) (IL:\\\,@ (BIND-OUTER-ARGS (BIND-ARGS COLON (GET-ARG) (IL:BQUOTE ((
IL:\\\,@ (MAYBE-BIND-INITIAL COLON (LET ((*GET-ARG-CAREFULLY* (AND *GET-ARG-CAREFULLY* ATSIGN)) (
*AT-TOP* (AND *AT-TOP* ATSIGN)) (*OUTER-END* IL:NIL) (*INNER-END* IL:NIL)) (IF (NOT COLON) (IF (NOT (>
 END START)) (IL:BQUOTE ((SETQ ARGS (APPLY FN XP (IL:\\\, (ARGS)))))) (COMPILE-FORMAT START END)) (LET
 ((*INNER-END* (QUOTE INNER))) (IL:BQUOTE ((BLOCK INNER (IL:\\\,@ (IF (NOT (> END START)) (IL:BQUOTE (
(SETQ ARGS (APPLY FN XP (IL:\\\, (ARGS)))))) (COMPILE-FORMAT START END)))))))))))))))) (GO L))))))))))
)))))
(DEF-FORMAT-HANDLER #\< (START END) (IF (COLONP (1- END)) (HANDLE-LOGICAL-BLOCK START END) (
HANDLE-STANDARD-< START END)))
(DEFUN HANDLE-STANDARD-< (START END) (LET ((N (NUM-ARGS-IN-DIRECTIVE START END))) (IL:BQUOTE (
USING-FORMAT XP (IL:\\\, (SUBSEQ *STRING* (1- START) END)) (IL:\\\,@ (COPY-TREE (MAKE-LIST N 
:INITIAL-ELEMENT (GET-ARG))))))))
(DEFUN NUM-ARGS-IN-DIRECTIVE (START END) (LET ((N 0) C I J) (INCF N (NUM-ARGS-IN-ARGS START T)) (
MULTIPLE-VALUE-SETQ (J I) (NEXT-DIRECTIVE1 START END)) (LOOP (MULTIPLE-VALUE-SETQ (C I J) (
NEXT-DIRECTIVE J END)) (WHEN (NULL C) (RETURN N)) (COND ((EQL C #\;) (IF (COLONP J) (ERR 22 
"~~:; not supported in ~~<...~~> by (formatter \"...\")." J))) ((FIND C "*[^<_IiWw{Tt") (ERR 23 
"~~<...~~> too complicated to be supported by (formatter \"...\")." J)) ((EQL C #\() (INCF N (
NUM-ARGS-IN-DIRECTIVE (1+ I) J))) ((FIND C "%&|~") (INCF N (NUM-ARGS-IN-ARGS (1+ I) T))) ((EQL C #\?) 
(WHEN (ATSIGNP J) (ERR 23 "~~<...~~> too complicated to be supported by (formatter \"...\")." J)) (
INCF N 2)) ((FIND C "AaSsDdBbOoXxRrCcFfEeGg$Pp") (INCF N (1+ (NUM-ARGS-IN-ARGS (1+ I) T))))))))
(DEF-FORMAT-HANDLER #\_ (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (
PARSE-PARAMS START IL:NIL) (IL:BQUOTE (PPRINT-NEWLINE+ (IL:\\\, (COND ((AND COLON ATSIGN) :MANDATORY) 
(COLON :FILL) (ATSIGN :MISER) (T :LINEAR))) XP))))
(DEF-FORMAT-HANDLER #\I (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) 
(PARSE-PARAMS START (QUOTE (0)) :NOATSIGN T) (DECLARE (IGNORE ATSIGN)) (IL:BQUOTE (PPRINT-INDENT+ (
IL:\\\, (IF COLON :CURRENT :BLOCK)) (IL:\\\, (CAR PARAMS)) XP))))
(DEF-FORMAT-HANDLER #\W (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (
PARSE-PARAMS START IL:NIL) (COND ((NOT (OR COLON ATSIGN)) (IL:BQUOTE (WRITE+ (IL:\\\, (GET-ARG)) XP)))
 (T (IL:BQUOTE (LET ((IL:\\\,@ (IF COLON (QUOTE ((*PRINT-PRETTY* T))))) (IL:\\\,@ (IF ATSIGN (QUOTE ((
*PRINT-LEVEL* IL:NIL) (*PRINT-LENGTH* IL:NIL)))))) (WRITE+ (IL:\\\, (GET-ARG)) XP)))))))
(DEFUN HANDLE-LOGICAL-BLOCK (START END) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (PARSE-PARAMS START IL:NIL
) (SETQ START (1+ (PARAMS-END START))) (LET* ((CHUNKS (CHUNK-UP START END)) (ON-EACH-LINE? (AND (CDDR 
CHUNKS) (ATSIGNP (1- (CADR CHUNKS))))) (PREFIX (COND ((CDDR CHUNKS) (POP CHUNKS) (SUBSEQ *STRING* 
START (DIRECTIVE-START (CAR CHUNKS)))) (COLON "("))) (SUFFIX (COND ((CDDR CHUNKS) (SUBSEQ *STRING* (
CADR CHUNKS) (DIRECTIVE-START (CADDR CHUNKS)))) (COLON ")")))) (WHEN (CDDDR CHUNKS) (ERR 24 
"Too many subclauses in ~~<...~~:>" (1- START))) (WHEN (AND PREFIX (OR (FIND #\~ PREFIX) (FIND 
#\Newline PREFIX))) (ERR 25 "Prefix in ~~<...~~:> must be a literal string without newline" START)) (
WHEN (AND SUFFIX (OR (FIND #\~ SUFFIX) (FIND #\Newline SUFFIX))) (ERR 26 
"Suffix in ~~<...~~:> must be a literal string without newline" (CADR CHUNKS))) (CAR (BIND-ARGS T (IF 
ATSIGN (IL:BQUOTE (PROG1 (IL:\\\, (ARGS)) (SETQ (IL:\\\, (ARGS)) IL:NIL))) (GET-ARG)) (BIND-INITIAL (
IL:BQUOTE ((PPRINT-LOGICAL-BLOCK+ (XP (IL:\\\, (ARGS)) (IL:\\\, PREFIX) (IL:\\\, SUFFIX) (IL:\\\, 
ON-EACH-LINE?) (IL:\\\, (NOT (AND *AT-TOP* ATSIGN))) (IL:\\\, ATSIGN)) (IL:\\\,@ (FILL-TRANSFORM (
ATSIGNP (1- END)) (LET ((*GET-ARG-CAREFULLY* T) (*AT-TOP* (AND *AT-TOP* ATSIGN)) (*INNER-END* (QUOTE 
LOGICAL-BLOCK)) (*OUTER-END* (QUOTE LOGICAL-BLOCK))) (COMPILE-FORMAT (CAR CHUNKS) (DIRECTIVE-START (
CADR CHUNKS)))))))))))))))
(DEFUN CHECK-BLOCK-ABBREVIATION (XP ARGS CIRCLE-CHECK?) (COND ((NOT (LISTP ARGS)) (WRITE+ ARGS XP) T) 
((AND *PRINT-LEVEL* (> *CURRENT-LEVEL* *PRINT-LEVEL*)) (WRITE-CHAR++ #\# XP) (SETQ 
*ABBREVIATION-HAPPENED* T) T) ((AND *CIRCULARITY-HASH-TABLE* CIRCLE-CHECK? (EQ (CIRCULARITY-PROCESS XP
 ARGS IL:NIL) :SUBSEQUENT)) T) (T IL:NIL)))
(DEFUN FILL-TRANSFORM (DOIT? BODY) (IF (NOT DOIT?) BODY (MAPCAN (FUNCTION (LAMBDA (FORM) (COND ((EQ (
CAR FORM) (QUOTE WRITE-STRING++)) (FILL-TRANSFORM-LITERAL (CADR FORM))) ((EQ (CAR FORM) (QUOTE 
WRITE-CHAR++)) (FILL-TRANSFORM-CHAR (CADR FORM))) (T (LIST FORM))))) BODY)))
(DEFUN FILL-TRANSFORM-CHAR (CHAR) (IF (OR (CHAR= CHAR #\Space) (CHAR= CHAR #\Tab)) (LIST (IL:BQUOTE (
WRITE-CHAR++ (IL:\\\, CHAR) XP)) (QUOTE (PPRINT-NEWLINE+ :FILL XP))) (IL:BQUOTE ((WRITE-CHAR++ (IL:\\\,
 CHAR) XP)))))
(DEFUN FILL-TRANSFORM-LITERAL (STRING) (FLET ((WHITE-SPACE (C) (OR (CHAR= C #\Space) (CHAR= C #\Tab)))
) (DO ((INDEX 0 END) (RESULT) (END IL:NIL IL:NIL)) (IL:NIL) (LET ((WHITE (POSITION-IF (FUNCTION 
WHITE-SPACE) STRING :START INDEX))) (WHEN WHITE (SETQ END (POSITION-IF-NOT (FUNCTION WHITE-SPACE) 
STRING :START (1+ WHITE)))) (WHEN (NULL END) (SETQ END (LENGTH STRING))) (PUSH (IL:BQUOTE (
WRITE-STRING++ (IL:\\\, (SUBSEQ STRING INDEX END)) XP (IL:\\\, 0) (IL:\\\, (- END INDEX)))) RESULT) (
IF WHITE (PUSH (QUOTE (PPRINT-NEWLINE+ :FILL XP)) RESULT)) (IF (NULL WHITE) (RETURN (NREVERSE RESULT))
)))))
(DEFUN PRETTY-ARRAY (XP ARRAY) (COND ((VECTORP ARRAY) (PRETTY-VECTOR XP ARRAY)) ((ZEROP (ARRAY-RANK 
ARRAY)) (WRITE-STRING++ "#0A " XP 0 4) (WRITE+ (AREF ARRAY) XP)) (T (PRETTY-NON-VECTOR XP ARRAY))))
(DEFUN PRETTY-VECTOR (XP V) (PPRINT-LOGICAL-BLOCK (XP IL:NIL :PREFIX "#(" :SUFFIX ")") (LET ((END (
LENGTH V)) (I 0)) (WHEN (PLUSP END) (LOOP (PPRINT-POP) (WRITE+ (AREF V I) XP) (IF (= (INCF I) END) (
RETURN IL:NIL)) (WRITE-CHAR++ #\Space XP) (PPRINT-NEWLINE+ :FILL XP))))))
(DEFUN PRETTY-NON-VECTOR (XP ARRAY) (LET* ((BOTTOM (1- (ARRAY-RANK ARRAY))) (INDICES (MAKE-LIST (1+ 
BOTTOM) :INITIAL-ELEMENT 0)) (DIMS (ARRAY-DIMENSIONS ARRAY))) (FUNCALL (FORMATTER "#~DA") XP (1+ 
BOTTOM)) (LABELS ((PRETTY-SLICE (SLICE) (PPRINT-LOGICAL-BLOCK (XP IL:NIL :PREFIX "(" :SUFFIX ")") (LET
 ((END (NTH SLICE DIMS)) (SPOT (NTHCDR SLICE INDICES)) (I 0)) (WHEN (PLUSP END) (LOOP (PPRINT-POP) (
SETF (CAR SPOT) I) (IF (= SLICE BOTTOM) (WRITE+ (APPLY (FUNCTION AREF) ARRAY INDICES) XP) (
PRETTY-SLICE (1+ SLICE))) (IF (= (INCF I) END) (RETURN IL:NIL)) (WRITE-CHAR++ #\Space XP) (
PPRINT-NEWLINE+ (IF (= SLICE BOTTOM) :FILL :LINEAR) XP))))))) (PRETTY-SLICE 0))))
(DEFUN PPRINT-LINEAR (S LIST &OPTIONAL (COLON? T) ATSIGN?) (DECLARE (IGNORE ATSIGN?)) (
PPRINT-LOGICAL-BLOCK (S LIST :PREFIX (IF COLON? "(" "") :SUFFIX (IF COLON? ")" "")) (
PPRINT-EXIT-IF-LIST-EXHAUSTED) (LOOP (WRITE+ (PPRINT-POP) S) (PPRINT-EXIT-IF-LIST-EXHAUSTED) (
WRITE-CHAR++ #\Space S) (PPRINT-NEWLINE+ :LINEAR S))))
(DEFUN PPRINT-FILL (S LIST &OPTIONAL (COLON? T) ATSIGN?) (DECLARE (IGNORE ATSIGN?)) (
PPRINT-LOGICAL-BLOCK (S LIST :PREFIX (IF COLON? "(" "") :SUFFIX (IF COLON? ")" "")) (
PPRINT-EXIT-IF-LIST-EXHAUSTED) (LOOP (WRITE+ (PPRINT-POP) S) (PPRINT-EXIT-IF-LIST-EXHAUSTED) (
WRITE-CHAR++ #\Space S) (PPRINT-NEWLINE+ :FILL S))))
(DEFUN PPRINT-TABULAR (S LIST &OPTIONAL (COLON? T) ATSIGN? (TABSIZE IL:NIL)) (DECLARE (IGNORE ATSIGN?)
) (WHEN (NULL TABSIZE) (SETQ TABSIZE 16)) (PPRINT-LOGICAL-BLOCK (S LIST :PREFIX (IF COLON? "(" "") 
:SUFFIX (IF COLON? ")" "")) (PPRINT-EXIT-IF-LIST-EXHAUSTED) (LOOP (WRITE+ (PPRINT-POP) S) (
PPRINT-EXIT-IF-LIST-EXHAUSTED) (WRITE-CHAR++ #\Space S) (PPRINT-TAB+ :SECTION-RELATIVE 0 TABSIZE S) (
PPRINT-NEWLINE+ :FILL S))))
(DEFUN FN-CALL (XP LIST) (FUNCALL (FORMATTER "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") XP LIST))
(DEFUN ALTERNATIVE-FN-CALL (XP LIST) (IF (> (LENGTH (SYMBOL-NAME (CAR LIST))) 12) (FUNCALL (FORMATTER 
"~:<~1I~@{~W~^ ~_~}~:>") XP LIST) (FUNCALL (FORMATTER "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") XP LIST)))
(DEFUN BIND-LIST (XP LIST &REST ARGS) (DECLARE (IGNORE ARGS)) (IF (DO ((I 50 (1- I)) (LS LIST (CDR LS)
)) ((NULL LS) T) (WHEN (OR (NOT (CONSP LS)) (NOT (SYMBOLP (CAR LS))) (MINUSP I)) (RETURN IL:NIL))) (
PPRINT-FILL XP LIST) (FUNCALL (FORMATTER "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>") XP LIST)))
(DEFUN BLOCK-LIKE (XP LIST &REST ARGS) (DECLARE (IGNORE ARGS)) (FUNCALL (FORMATTER 
"~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>") XP LIST))
(DEFUN DEFUN-LIKE (XP LIST &REST ARGS) (DECLARE (IGNORE ARGS)) (FUNCALL (FORMATTER 
"~:<~1I~W~^ ~@_~W~^ ~@_~:/xp:pprint-fill/~^~@{ ~_~W~^~}~:>") XP LIST))
(DEFUN PRINT-FANCY-FN-CALL (XP LIST TEMPLATE) (LET ((I 0) (IN-FIRST-SECTION T)) (PPRINT-LOGICAL-BLOCK+
 (XP LIST "(" ")" IL:NIL T IL:NIL) (WRITE+ (PPRINT-POP) XP) (PPRINT-INDENT+ :CURRENT 1 XP) (LOOP (
PPRINT-EXIT-IF-LIST-EXHAUSTED) (WRITE-CHAR++ #\Space XP) (WHEN (EQ I (CAR TEMPLATE)) (PPRINT-INDENT+ 
:BLOCK (CADR TEMPLATE) XP) (SETQ TEMPLATE (CDDR TEMPLATE)) (SETQ IN-FIRST-SECTION IL:NIL)) (
PPRINT-NEWLINE (COND ((AND (ZEROP I) IN-FIRST-SECTION) :MISER) (IN-FIRST-SECTION :FILL) (T :LINEAR)) 
XP) (WRITE+ (PPRINT-POP) XP) (INCF I)))))
(DEFUN MAYBELAB (XP ITEM &REST ARGS) (DECLARE (IGNORE ARGS) (SPECIAL NEED-NEWLINE INDENTATION)) (WHEN 
NEED-NEWLINE (PPRINT-NEWLINE+ :MANDATORY XP)) (COND ((AND ITEM (SYMBOLP ITEM)) (WRITE+ ITEM XP) (SETQ 
NEED-NEWLINE IL:NIL)) (T (PPRINT-TAB+ :SECTION INDENTATION 0 XP) (WRITE+ ITEM XP) (SETQ NEED-NEWLINE T
))))
(DEFUN FUNCTION-CALL-P (X) (AND (CONSP X) (SYMBOLP (CAR X)) (FBOUNDP (CAR X))))
(DEFUN LET-PRINT (XP OBJ) (FUNCALL (FORMATTER "~:<~1I~W~^ ~@_~/xp:bind-list/~^~@{ ~_~W~^~}~:>") XP OBJ
))
(DEFUN COND-PRINT (XP OBJ) (FUNCALL (FORMATTER "~:<~W~^ ~:I~@_~@{~:/xp:pprint-linear/~^ ~_~}~:>") XP 
OBJ))
(DEFUN DMM-PRINT (XP LIST) (PRINT-FANCY-FN-CALL XP LIST (QUOTE (3 1))))
(DEFUN DEFSETF-PRINT (XP LIST) (PRINT-FANCY-FN-CALL XP LIST (QUOTE (3 1))))
(DEFUN DO-PRINT (XP OBJ) (FUNCALL (FORMATTER 
"~:<~W~^ ~:I~@_~/xp:bind-list/~^ ~_~:/xp:pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>") XP OBJ))
(DEFUN FLET-PRINT (XP OBJ) (FUNCALL (FORMATTER 
"~:<~1I~W~^ ~@_~:<~@{~/xp:block-like/~^ ~_~}~:>~^~@{ ~_~W~^~}~:>") XP OBJ))
(DEFUN FUNCTION-PRINT (XP LIST) (IF (AND (CONSP (CDR LIST)) (NULL (CDDR LIST))) (FUNCALL (FORMATTER 
"#'~W") XP (CADR LIST)) (FN-CALL XP LIST)))
(DEFUN MVB-PRINT (XP LIST) (PRINT-FANCY-FN-CALL XP LIST (QUOTE (1 3 2 1))))
(DEFUN PROG-PRINT (XP LIST) (LET ((NEED-NEWLINE T) (INDENTATION (1+ (LENGTH (SYMBOL-NAME (CAR LIST))))
)) (DECLARE (SPECIAL NEED-NEWLINE INDENTATION)) (FUNCALL (FORMATTER 
"~:<~W~^ ~:/xp:pprint-fill/~^ ~@{~/xp:maybelab/~^ ~}~:>") XP LIST)))
(DEFUN SETQ-PRINT (XP OBJ) (FUNCALL (FORMATTER "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>") XP OBJ))
(DEFUN QUOTE-PRINT (XP LIST) (IF (AND (CONSP (CDR LIST)) (NULL (CDDR LIST))) (FUNCALL (FORMATTER "'~W"
) XP (CADR LIST)) (PPRINT-FILL XP LIST)))
(DEFUN TAGBODY-PRINT (XP LIST) (LET ((NEED-NEWLINE (AND (CONSP (CDR LIST)) (SYMBOLP (CADR LIST)) (CADR
 LIST))) (INDENTATION (1+ (LENGTH (SYMBOL-NAME (CAR LIST)))))) (DECLARE (SPECIAL NEED-NEWLINE 
INDENTATION)) (FUNCALL (FORMATTER "~:<~W~^ ~@{~/xp:maybelab/~^ ~}~:>") XP LIST)))
(DEFUN UP-PRINT (XP LIST) (PRINT-FANCY-FN-CALL XP LIST (QUOTE (0 3 1 1))))
(DEFUN TOKEN-TYPE (TOKEN &AUX STRING) (COND ((NOT (SYMBOLP TOKEN)) :EXPR) ((STRING= (SETQ STRING (
STRING TOKEN)) "FINALLY") :FINALLY) ((MEMBER STRING (QUOTE ("IF" "WHEN" "UNLESS")) :TEST (FUNCTION 
STRING=)) :COND-HEAD) ((MEMBER STRING (QUOTE ("DO" "DOING" "INITIALLY")) :TEST (FUNCTION STRING=)) 
:LINEAR-HEAD) ((MEMBER STRING (QUOTE ("FOR" "AS" "WITH" "AND" "END" "ELSE" "REPEAT" "NAMED" "WHILE" 
"UNTIL" "ALWAYS" "NEVER" "THEREIS" "RETURN" "COLLECT" "COLLECTING" "APPEND" "APPENDING" "NCONC" 
"NCONCING" "COUNT" "COUNTING" "SUM" "SUMMING" "MAXIMIZE" "MAXIMIZING" "MINIMIZE" "MINIMIZING")) :TEST 
(FUNCTION STRING=)) :BLOCK-HEAD) (T :EXPR)))
(DEFUN PRETTY-LOOP (XP LOOP) (IF (NOT (AND (CONSP (CDR LOOP)) (SYMBOLP (CADR LOOP)))) (IL:* IL:\; 
"old-style loop") (FUNCTION-PRINT XP LOOP) (PPRINT-LOGICAL-BLOCK (XP LOOP :PREFIX "(" :SUFFIX ")") (
LET (TOKEN TYPE) (LABELS ((NEXT-TOKEN IL:NIL (PPRINT-EXIT-IF-LIST-EXHAUSTED) (SETQ TOKEN (PPRINT-POP))
 (SETQ TYPE (TOKEN-TYPE TOKEN))) (PRINT-CLAUSE (XP) (CASE TYPE (:LINEAR-HEAD (PRINT-EXPRS XP IL:NIL 
:MANDATORY)) (:COND-HEAD (PRINT-COND XP)) (:FINALLY (PRINT-EXPRS XP T :MANDATORY)) (OTHERWISE (
PRINT-EXPRS XP IL:NIL :FILL)))) (PRINT-EXPRS (XP SKIP-FIRST-NON-EXPR NEWLINE-TYPE) (LET ((FIRST TOKEN)
) (NEXT-TOKEN) (IL:* IL:\; "so always happens no matter what") (PPRINT-LOGICAL-BLOCK (XP IL:NIL) (
WRITE FIRST :STREAM XP) (WHEN (AND SKIP-FIRST-NON-EXPR (NOT (EQ TYPE :EXPR))) (WRITE-CHAR #\Space XP) 
(WRITE TOKEN :STREAM XP) (NEXT-TOKEN)) (WHEN (EQ TYPE :EXPR) (WRITE-CHAR #\Space XP) (PPRINT-INDENT 
:CURRENT 0 XP) (LOOP (WRITE TOKEN :STREAM XP) (NEXT-TOKEN) (WHEN (NOT (EQ TYPE :EXPR)) (RETURN IL:NIL)
) (WRITE-CHAR #\Space XP) (PPRINT-NEWLINE NEWLINE-TYPE XP)))))) (PRINT-COND (XP) (LET ((FIRST TOKEN)) 
(NEXT-TOKEN) (IL:* IL:\; "so always happens no matter what") (PPRINT-LOGICAL-BLOCK (XP IL:NIL) (WRITE 
FIRST :STREAM XP) (WHEN (EQ TYPE :EXPR) (WRITE-CHAR #\Space XP) (WRITE TOKEN :STREAM XP) (NEXT-TOKEN))
 (WRITE-CHAR #\Space XP) (PPRINT-INDENT :BLOCK 2 XP) (PPRINT-NEWLINE :LINEAR XP) (PRINT-CLAUSE XP) (
PRINT-AND-LIST XP) (WHEN (STRING= (STRING TOKEN) "ELSE") (PRINT-ELSE-OR-END XP) (WRITE-CHAR #\Space XP
) (PPRINT-NEWLINE :LINEAR XP) (PRINT-CLAUSE XP) (PRINT-AND-LIST XP)) (WHEN (STRING= (STRING TOKEN) 
"END") (PRINT-ELSE-OR-END XP))))) (PRINT-AND-LIST (XP) (LOOP (WHEN (NOT (STRING= (STRING TOKEN) "AND")
) (RETURN IL:NIL)) (WRITE-CHAR #\Space XP) (PPRINT-NEWLINE :MANDATORY XP) (WRITE TOKEN :STREAM XP) (
NEXT-TOKEN) (WRITE-CHAR #\Space XP) (PRINT-CLAUSE XP))) (PRINT-ELSE-OR-END (XP) (WRITE-CHAR #\Space XP
) (PPRINT-INDENT :BLOCK 0 XP) (PPRINT-NEWLINE :LINEAR XP) (WRITE TOKEN :STREAM XP) (NEXT-TOKEN) (
PPRINT-INDENT :BLOCK 2 XP))) (PPRINT-EXIT-IF-LIST-EXHAUSTED) (WRITE (PPRINT-POP) :STREAM XP) (
NEXT-TOKEN) (WRITE-CHAR #\Space XP) (PPRINT-INDENT :CURRENT 0 XP) (LOOP (PRINT-CLAUSE XP) (WRITE-CHAR 
#\Space XP) (PPRINT-NEWLINE :LINEAR XP)))))))
(DEFUN BQ-PRINT (XP LIST) (IF (AND (CONSP (CDR LIST)) (NULL (CDDR LIST))) (FUNCALL (FORMATTER "`~W") 
XP (CADR LIST)) (PPRINT-FILL XP LIST)))
(DEFUN BQ-COMMA-PRINT (XP LIST) (IF (AND (CONSP (CDR LIST)) (NULL (CDDR LIST))) (FUNCALL (FORMATTER 
",~W") XP (CADR LIST)) (PPRINT-FILL XP LIST)))
(DEFUN BQ-COMMA@-PRINT (XP LIST) (IF (AND (CONSP (CDR LIST)) (NULL (CDDR LIST))) (FUNCALL (FORMATTER 
",@~W") XP (CADR LIST)) (PPRINT-FILL XP LIST)))
(DEFUN IL-COMMENT (XP THING) (IL:* IL:\; "Edited  8-Jul-92 13:44 by jrb:") (POP THING) (IL:* IL:\; 
"Flush the IL:*") (FLET ((HOSE-COMMENT-STRING (S) (DO ((START (POSITION #\Space S :TEST (QUOTE IL:NEQ)
)) (END)) ((NULL START)) (IF (SETQ END (POSITION #\Space S :START START)) (PROGN (CL:WRITE-STRING S XP
 :START START :END (1+ END)) (WHEN (SETQ START (POSITION #\Space S :START END :TEST (QUOTE IL:NEQ))) (
PPRINT-NEWLINE :FILL XP))) (PROGN (CL:WRITE-STRING S XP :START START) (SETQ START IL:NIL)))))) (IL:* 
IL:|;;| 
"This method of handling Interlisp comments sucks, BUT there is no way under XP to temporarily ignore an existing per-line-prefix, which is what you would have to do to get ;;; and ;;;; comments to go to the left margin.  Phooey!"
) (LET (PER-LINE-PREFIX) (CASE (CAR THING) ((IL:\; IL:|;;| IL:|;;;| IL:|;;;;|) (SETQ PER-LINE-PREFIX (
CONCATENATE (QUOTE STRING) (SYMBOL-NAME (CAR THING) " ")))) (IL:* IL:|;;| 
"Last two cases have their own logical blocks, since they either have weird :PREFIX/:SUFFIXes or aren't strings"
) (IL:\| (IL:* IL:\; "a #|ignore everything|#") (CL:FRESH-LINE XP) (PPRINT-LOGICAL-BLOCK (XP IL:NIL 
:PREFIX "#|" :SUFFIX "|#") (HOSE-COMMENT-STRING (CADR THING)))) (T (IL:* IL:|;;| 
"an OLD-style comment; punt and use ;;, but just use PPRINT-FILL since the body of the comment is not a string"
) (PPRINT-LOGICAL-BLOCK (XP IL:NIL :PER-LINE-PREFIX ";; ") (PPRINT-FILL XP THING IL:NIL)))) (WHEN 
PER-LINE-PREFIX (PPRINT-LOGICAL-BLOCK (XP IL:NIL :PER-LINE-PREFIX PER-LINE-PREFIX) (
HOSE-COMMENT-STRING (CADR THING)))) (PPRINT-NEWLINE :MANDATORY XP) (IL:* IL:\; 
"ALWAYS end comments with a newline"))))
(SETQ *IPD* (MAKE-PPRINT-DISPATCH))
(XCL:DEF-DEFINE-TYPE INITIAL-DISPATCH "XP initial pretty-print dispatch entries")
(XCL:DEFDEFINER SET-PPD-IPD INITIAL-DISPATCH (TYPE-SPECIFIER FUNCTION &OPTIONAL (PRIORITY (QUOTE (0)))
) (IL:BQUOTE (SET-PPRINT-DISPATCH+ (QUOTE (IL:\\\, TYPE-SPECIFIER)) (IL:\\\, FUNCTION) (IL:\\\, 
PRIORITY) *IPD*)))
(SET-PPD-IPD (SATISFIES FUNCTION-CALL-P) (FUNCTION FN-CALL) (QUOTE (-5)))
(SET-PPD-IPD CONS (FUNCTION PPRINT-FILL) (QUOTE (-10)))
(SET-PPD-IPD (CONS (MEMBER DEFSTRUCT)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER BLOCK)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER CASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER CATCH)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER CCASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER COMPILER-LET)) (FUNCTION LET-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER COND)) (FUNCTION COND-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER CTYPECASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFCONSTANT)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFINE-SETF-METHOD)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFMACRO)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFINE-MODIFY-MACRO)) (FUNCTION DMM-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFPARAMETER)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFSETF)) (FUNCTION DEFSETF-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFINE-SETF-METHOD)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER CL:DEFSTRUCT)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFTYPE)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFUN)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFVAR)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DO)) (FUNCTION DO-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DO*)) (FUNCTION DO-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DO-ALL-SYMBOLS)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DO-EXTERNAL-SYMBOLS)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DO-SYMBOLS)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DOLIST)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DOTIMES)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER ECASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER ETYPECASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER EVAL-WHEN)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER FLET)) (FUNCTION FLET-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER FUNCTION)) (FUNCTION FUNCTION-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER LABELS)) (FUNCTION FLET-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER LAMBDA)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER LET)) (FUNCTION LET-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER LET*)) (FUNCTION LET-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER LOCALLY)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER LOOP)) (FUNCTION PRETTY-LOOP) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER MACROLET)) (FUNCTION FLET-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER MULTIPLE-VALUE-BIND)) (FUNCTION MVB-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER MULTIPLE-VALUE-SETQ)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER PROG)) (FUNCTION PROG-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER PROG*)) (FUNCTION PROG-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER PROGV)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER PSETF)) (FUNCTION SETQ-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER PSETQ)) (FUNCTION SETQ-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER QUOTE)) (FUNCTION QUOTE-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER RETURN-FROM)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER SETF)) (FUNCTION SETQ-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER SETQ)) (FUNCTION SETQ-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER TAGBODY)) (FUNCTION TAGBODY-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER THROW)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER TYPECASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER UNLESS)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER UNWIND-PROTECT)) (FUNCTION UP-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER WHEN)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER WITH-INPUT-FROM-STRING)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER WITH-OPEN-FILE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER WITH-OPEN-STREAM)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER WITH-OUTPUT-TO-STRING)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER IL:*)) (FUNCTION IL-COMMENT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER IL:BQUOTE)) (FUNCTION BQ-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER IL:\\\,)) (FUNCTION BQ-COMMA-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER IL:\\\,@)) (FUNCTION BQ-COMMA@-PRINT) (QUOTE (0)))
(DEFUN PPRINT-DISPATCH-PRINT (XP TABLE) (DECLARE (IGNORE LEVEL)) (LET ((STUFF (COPY-LIST (OTHERS TABLE
)))) (MAPHASH (FUNCTION (LAMBDA (KEY VAL) (DECLARE (IGNORE KEY)) (PUSH VAL STUFF))) (CONSES-WITH-CARS 
TABLE)) (MAPHASH (FUNCTION (LAMBDA (KEY VAL) (DECLARE (IGNORE KEY)) (PUSH VAL STUFF))) (STRUCTURES 
TABLE)) (SETQ STUFF (SORT STUFF (FUNCTION PRIORITY->) :KEY (FUNCTION (LAMBDA (X) (CAR (FULL-SPEC X))))
)) (PPRINT-LOGICAL-BLOCK (XP STUFF :PREFIX "#<" :SUFFIX ">") (FORMAT XP (FORMATTER 
"pprint dispatch table containing ~A entries: ") (LENGTH STUFF)) (LOOP (PPRINT-EXIT-IF-LIST-EXHAUSTED)
 (LET ((ENTRY (PPRINT-POP))) (FORMAT XP (FORMATTER "~{~_P=~4D ~W~} F=~W ") (FULL-SPEC ENTRY) (FN ENTRY
)))))))
(SETF (GET (QUOTE PPRINT-DISPATCH) (QUOTE CL::STRUCTURE-PRINTER)) (FUNCTION PPRINT-DISPATCH-PRINT))
(SET-PPD-IPD PPRINT-DISPATCH (FUNCTION PPRINT-DISPATCH-PRINT) (QUOTE (0)))
(WHEN (EQ *PRINT-PPRINT-DISPATCH* T) (SETQ *PRINT-PPRINT-DISPATCH* (COPY-PPRINT-DISPATCH IL:NIL)))
(IL:PUTPROPS IL:XP IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "XP" (:USE "LISP") (
:SHADOW "CLEAR-OUTPUT" "FORCE-OUTPUT" "FINISH-OUTPUT" "DEFSTRUCT" "FRESH-LINE" "TERPRI" "WRITE-CHAR" 
"WRITE-STRING" "WRITE-LINE" "PRIN1-TO-STRING" "PRINC-TO-STRING" "WRITE-TO-STRING" "FORMAT" "PPRINT" 
"PRINC" "PRIN1" "PRINT" "WRITE") (:IMPORT-FROM "COMMON-LISP" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" 
"*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT" "PPRINT-NEWLINE" 
"PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR" "PPRINT-LINEAR" 
"PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" "FORMATTER") (:EXPORT 
"*PRINT-SHARED*" "*LAST-ABBREVIATED-PRINTING*" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" 
"*DEFAULT-RIGHT-MARGIN*" "*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT"
 "PPRINT-NEWLINE" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR"
 "PPRINT-LINEAR" "PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" 
"FORMATTER")) :BASE 10))
(IL:PUTPROPS IL:XP IL:FILETYPE :COMPILE-FILE)
(IL:PUTPROPS IL:XP IL:COPYRIGHT ("Venue Corporation" 1990 1991 1992 1993))
IL:NIL
\ No newline at end of file
diff --git a/bin/intclinux/lde b/bin/intclinux/lde
new file mode 100644
index 00000000..76ee1b93
Binary files /dev/null and b/bin/intclinux/lde differ
diff --git a/bin/intclinux/ldeether b/bin/intclinux/ldeether
new file mode 100644
index 00000000..1b618fe2
Binary files /dev/null and b/bin/intclinux/ldeether differ
diff --git a/bin/intclinux/ldex b/bin/intclinux/ldex
new file mode 100644
index 00000000..ba712bda
Binary files /dev/null and b/bin/intclinux/ldex differ
diff --git a/bin/lde b/bin/lde
new file mode 100644
index 00000000..6fc2a24e
Binary files /dev/null and b/bin/lde differ
diff --git a/bin/ldeether b/bin/ldeether
new file mode 100644
index 00000000..04f3916e
Binary files /dev/null and b/bin/ldeether differ
diff --git a/bin/ldemulti b/bin/ldemulti
new file mode 100644
index 00000000..215d391c
Binary files /dev/null and b/bin/ldemulti differ
diff --git a/bin/ldesingle b/bin/ldesingle
new file mode 100644
index 00000000..a902dff2
Binary files /dev/null and b/bin/ldesingle differ
diff --git a/bin/ldex b/bin/ldex
new file mode 100644
index 00000000..ed29be25
Binary files /dev/null and b/bin/ldex differ
diff --git a/bin/medley b/bin/medley
new file mode 100644
index 00000000..8d205252
--- /dev/null
+++ b/bin/medley
@@ -0,0 +1,217 @@
+#! /bin/csh -f
+#
+# Run Medley
+#
+# Syntax: medley [-nogreet][-xns][-noxns] [-geometry pixelgeometry] [-display xdisplay-device]
+#                [-raw] [-t xtimeout][-prog executable-program] [-vmem savevmemfilename] |
+#                [-m memorylimit] [-kbd keyboardtype]  [-key key]
+#                [sysoutfilename | -lfg | -lisp | -full | -xlfg
+#                -{name of any sysout on the public sysout directory} ]
+#
+# -xns means leave unix xns running
+# -noxns means suppress Lisp xns.
+
+onintr cleanup
+limit coredumpsize 0
+setenv HOSTNAME `hostname`
+setenv OSVERSION `uname -r`
+\
+# Directory variables are accessible from Lisp via UNIX-GETENV
+# Shell should set MEDLEYDIR to point to the Medley3.5 directory
+setenv lispcore $MEDLEYDIR/lispcore
+setenv LDEINIT "$lispcore/greetfiles/local-init.lcom"
+
+set mem="-m 256"   # Default, has to be set
+#set geometry="-g 1060x790"
+# MBA screensize
+set geometry="-g 1440x900"
+setenv LDEKBDTYPE x
+set ICONSPEC=" "
+
+setenv LDEFILETIMEOUT 60
+setenv TAKEXNSDOWN 0
+setenv LDELISPXNS 0
+#default is no lispxns
+
+if ($#argv != 0) then
+   while ("$1" != "")
+	 switch ($1)
+	    case "-m":
+		set  mem="-m $2"
+		shift
+		breaksw
+	    case "-makefull":
+	    setenv LDEINIT $lispcore/makesysout/makefullsysout.lcom
+	    setenv LOADUPDIR $lispcore
+	    case "-xlisp":
+	    setenv LDESRCESYSOUT "$lispcore/loadups/xlisp.sysout"
+		breaksw
+		case "-venuelisp":
+		case "-lisp":
+	    setenv LDESRCESYSOUT "$lispcore/loadups/lisp.venuesysout"
+		breaksw
+		case "-venuefull":
+		setenv LDESRCESYSOUT "$lispcore/full.venuesysout"
+		breaksw
+		case "-makelfg":
+	    setenv LDEINIT $lfghome/parser/makelfgsysout.lcom
+	    setenv LOADUPDIR $lfghome/parser
+	    case "-xfull":
+		setenv LDESRCESYSOUT "$lispcore/loadups/xfull35.sysout"
+		breaksw
+	    case "-lfg":
+	    case "-lfg35":
+		setenv LDESRCESYSOUT "$lfghome/parser/release/lfg.sysout"
+		set ICONSPEC = "-iconbitmap $lfghome/release/lfg.xbm -icontitle Xerox"
+		breaksw
+		case "-oldlfg":
+		setenv LDESRCESYSOUT "$lfghome/parser/oldrelease/lfg35.sysout"
+		set ICONSPEC = "-iconbitmap $lfghome/release/lfg.xbm -icontitle Xerox"
+		breaksw
+	    case "-xlfg35":
+	    case "-xlfg":
+		setenv LDESRCESYSOUT "$lfghome/parser/xlfg35.sysout"
+		set ICONSPEC = "-iconbitmap $lfghome/release/lfg.xbm -icontitle Xerox"
+		breaksw
+		case "-makelisp":
+	    setenv LDEINIT $lispcore/makesysout/synclispfiles.lcom
+	    setenv LOADUPDIR $lispcore
+	    setenv LDESRCESYSOUT "$lispcore/loadups/lisp.venuesysout"	    		
+		breaksw
+		case "-xlisp":
+	    setenv LDESRCESYSOUT "$lispcore/loadups/xlisp.sysout"	    	
+	    breaksw
+		case "-makeinit":
+		setenv LDESRCESYSOUT "$MEDLEYDIR/basics/next/INIT.DLINIT"
+		setenv LDEINIT ""
+	    breaksw
+	    case "-nogreet":
+		setenv LDEINIT ""
+		breaksw
+	    case "-greet":
+		setenv LDEINIT "$2"
+		shift
+		breaksw
+	    case "-xns":
+		setenv TAKEXNSDOWN 1
+		setenv LDELISPXNS 1
+		breaksw
+	    case "-noxns":
+		setenv TAKEXNSDOWN 0
+		setenv LDELISPXNS 0
+		breaksw
+	    case "-raw":
+		unsetenv DISPLAY
+		breaksw
+	    case "-geometry":
+		set geometry="-g $2"
+		shift
+		breaksw
+	    case "-display":
+		setenv DISPLAY $2
+		shift
+		breaksw
+	    case "-t":
+		set xtimeout=$2
+		shift
+		breaksw
+	    case "-prog":
+		set progparam=$2
+		shift
+		breaksw
+	    case "-vmem":
+		setenv LDEDESTSYSOUT $2
+		shift
+		breaksw
+	    case "-kbd":
+		setenv LDEKBDTYPE $2
+		shift
+		breaksw
+
+	    default:
+		   if (`expr index "$1" "[-]"` ==  1) then
+		      # public sysout name
+                set name=`expr substr $1 2 999`
+			 	setenv LDESRCESYSOUT "$MEDLEYDIR/basics/${name}.sysout"
+		   else # not an option so must be a private sysout name
+				setenv LDESRCESYSOUT $1
+		   endif
+		breaksw
+	 endsw
+     shift
+   end
+else
+# no options specified
+endif
+
+if ($?LDEDESTSYSOUT) then
+else if (-f /$HOSTNAME/$LOGNAME/lisp.virtualmem) then
+   setenv LDEDESTSYSOUT /$HOSTNAME/$LOGNAME/lisp.virtualmem
+else if (-f ~/lisp.virtualmem) then
+   setenv LDEDESTSYSOUT ~/lisp.virtualmem
+else if (-d /$HOSTNAME/$LOGNAME) then
+   setenv LDEDESTSYSOUT /$HOSTNAME/$LOGNAME/lisp.virtualmem
+endif
+
+if (! $?LDESRCESYSOUT) then
+   setenv LDESRCESYSOUT $LDEDESTSYSOUT
+endif
+
+
+if (! $?LDEKBDTYPE) then
+#   switch (`/usr/bin/hostinfo keyboardtype`)
+#	endsw
+endif
+echo "keyboard type is " $LDEKBDTYPE
+
+#set hostid = `hostid`
+setenv INMEDLEY 1
+echo "sysout is " $LDESRCESYSOUT
+#set version = `medley-lisp-version $LDESRCESYSOUT`
+set version = "35010"
+if ($status) exit
+
+if ($LDELISPXNS) then
+	     set prog="ldeether"
+	 else
+	     set prog="lde"
+	     echo "running without xns protocols"
+endif
+switch ("$version")
+  case "35000":
+	set version = "3.5"
+	breaksw
+  case "35010":
+	set version = "3.501"
+	breaksw
+  default:
+	set version = "3.5"
+endsw
+echo "using emulator version $version"
+
+ switch ("$version")
+   case "3.5":
+   case "3.501":
+    set path = ($lispcore/bin/ $path)
+#	if ${?DISPLAY} then	 # we are running under X
+	     $prog $mem $geometry $ICONSPEC
+#	else $prog $mem
+	endif
+	breaksw
+
+endsw
+#
+# Now we are done, so clean up after ourselves
+#
+cleanup:
+
+if ${?DISPLAY} then
+	# do X cleanup
+else
+#	reset
+endif
+#clear		; this obscures error messages
+
+
+
+
diff --git a/bin/solaris/3501/keymaker b/bin/solaris/3501/keymaker
new file mode 100644
index 00000000..c6a16956
Binary files /dev/null and b/bin/solaris/3501/keymaker differ
diff --git a/bin/solaris/3501/keymaker.~1~ b/bin/solaris/3501/keymaker.~1~
new file mode 100644
index 00000000..c83b4d9c
Binary files /dev/null and b/bin/solaris/3501/keymaker.~1~ differ
diff --git a/bin/solaris/3501/keymaker.~2~ b/bin/solaris/3501/keymaker.~2~
new file mode 100644
index 00000000..c6a16956
Binary files /dev/null and b/bin/solaris/3501/keymaker.~2~ differ
diff --git a/bin/solaris/3501/lde b/bin/solaris/3501/lde
new file mode 100644
index 00000000..cf512551
Binary files /dev/null and b/bin/solaris/3501/lde differ
diff --git a/bin/solaris/3501/lde.~2~ b/bin/solaris/3501/lde.~2~
new file mode 100644
index 00000000..aaba8655
Binary files /dev/null and b/bin/solaris/3501/lde.~2~ differ
diff --git a/bin/solaris/3501/lde.~3~ b/bin/solaris/3501/lde.~3~
new file mode 100644
index 00000000..cf512551
Binary files /dev/null and b/bin/solaris/3501/lde.~3~ differ
diff --git a/bin/solaris/3501/ldeether b/bin/solaris/3501/ldeether
new file mode 100644
index 00000000..83875408
Binary files /dev/null and b/bin/solaris/3501/ldeether differ
diff --git a/bin/solaris/3501/ldeether.~2~ b/bin/solaris/3501/ldeether.~2~
new file mode 100644
index 00000000..db923ef7
Binary files /dev/null and b/bin/solaris/3501/ldeether.~2~ differ
diff --git a/bin/solaris/3501/ldeether.~3~ b/bin/solaris/3501/ldeether.~3~
new file mode 100644
index 00000000..83875408
Binary files /dev/null and b/bin/solaris/3501/ldeether.~3~ differ
diff --git a/bin/solaris/3501/ldex b/bin/solaris/3501/ldex
new file mode 100644
index 00000000..9ef78226
Binary files /dev/null and b/bin/solaris/3501/ldex differ
diff --git a/bin/solaris/3501/ldex.~2~ b/bin/solaris/3501/ldex.~2~
new file mode 100644
index 00000000..41047215
Binary files /dev/null and b/bin/solaris/3501/ldex.~2~ differ
diff --git a/bin/solaris/3501/ldex.~3~ b/bin/solaris/3501/ldex.~3~
new file mode 100644
index 00000000..9ef78226
Binary files /dev/null and b/bin/solaris/3501/ldex.~3~ differ
diff --git a/bin/solaris/3501/mkvdate b/bin/solaris/3501/mkvdate
new file mode 100644
index 00000000..d73e35db
Binary files /dev/null and b/bin/solaris/3501/mkvdate differ
diff --git a/bin/solaris/3501/setsout b/bin/solaris/3501/setsout
new file mode 100644
index 00000000..c3b728ef
Binary files /dev/null and b/bin/solaris/3501/setsout differ
diff --git a/bin/solaris/3501/setsout.~1~ b/bin/solaris/3501/setsout.~1~
new file mode 100644
index 00000000..e80d6d93
Binary files /dev/null and b/bin/solaris/3501/setsout.~1~ differ
diff --git a/bin/solaris/3501/setsout.~2~ b/bin/solaris/3501/setsout.~2~
new file mode 100644
index 00000000..c3b728ef
Binary files /dev/null and b/bin/solaris/3501/setsout.~2~ differ
diff --git a/bin/solaris/3501/tstsout b/bin/solaris/3501/tstsout
new file mode 100644
index 00000000..2e15be7f
Binary files /dev/null and b/bin/solaris/3501/tstsout differ
diff --git a/bin/solaris/3501/tstsout.~1~ b/bin/solaris/3501/tstsout.~1~
new file mode 100644
index 00000000..6478fa08
Binary files /dev/null and b/bin/solaris/3501/tstsout.~1~ differ
diff --git a/bin/solaris/3501/tstsout.~2~ b/bin/solaris/3501/tstsout.~2~
new file mode 100644
index 00000000..2e15be7f
Binary files /dev/null and b/bin/solaris/3501/tstsout.~2~ differ
diff --git a/bin/solaris/keymaker b/bin/solaris/keymaker
new file mode 100644
index 00000000..fac0e917
Binary files /dev/null and b/bin/solaris/keymaker differ
diff --git a/bin/solaris/keymaker.~2~ b/bin/solaris/keymaker.~2~
new file mode 100644
index 00000000..fac0e917
Binary files /dev/null and b/bin/solaris/keymaker.~2~ differ
diff --git a/bin/solaris/lde b/bin/solaris/lde
new file mode 100644
index 00000000..6772856a
Binary files /dev/null and b/bin/solaris/lde differ
diff --git a/bin/solaris/lde.~1~ b/bin/solaris/lde.~1~
new file mode 100644
index 00000000..6772856a
Binary files /dev/null and b/bin/solaris/lde.~1~ differ
diff --git a/bin/solaris/ldex b/bin/solaris/ldex
new file mode 100644
index 00000000..bb85907e
Binary files /dev/null and b/bin/solaris/ldex differ
diff --git a/bin/solaris/ldex.~1~ b/bin/solaris/ldex.~1~
new file mode 100644
index 00000000..bb85907e
Binary files /dev/null and b/bin/solaris/ldex.~1~ differ
diff --git a/bin/solaris/mkvdate b/bin/solaris/mkvdate
new file mode 100644
index 00000000..4b3afb70
Binary files /dev/null and b/bin/solaris/mkvdate differ
diff --git a/bin/solaris/resource.frk/3501 b/bin/solaris/resource.frk/3501
new file mode 100644
index 00000000..e13d8988
Binary files /dev/null and b/bin/solaris/resource.frk/3501 differ
diff --git a/bin/solaris/setsout b/bin/solaris/setsout
new file mode 100644
index 00000000..a199284c
Binary files /dev/null and b/bin/solaris/setsout differ
diff --git a/bin/solaris/setsout.~3~ b/bin/solaris/setsout.~3~
new file mode 100644
index 00000000..a199284c
Binary files /dev/null and b/bin/solaris/setsout.~3~ differ
diff --git a/bin/solaris/tstsout b/bin/solaris/tstsout
new file mode 100644
index 00000000..3545fe61
Binary files /dev/null and b/bin/solaris/tstsout differ
diff --git a/bin/solaris/tstsout.~3~ b/bin/solaris/tstsout.~3~
new file mode 100644
index 00000000..3545fe61
Binary files /dev/null and b/bin/solaris/tstsout.~3~ differ
diff --git a/bin/tstsout b/bin/tstsout
new file mode 100644
index 00000000..b606f475
Binary files /dev/null and b/bin/tstsout differ
diff --git a/clos/2.0/CLOS-BROWSER.TEDIT.Z b/clos/2.0/CLOS-BROWSER.TEDIT.Z
new file mode 100644
index 00000000..337dd792
Binary files /dev/null and b/clos/2.0/CLOS-BROWSER.TEDIT.Z differ
diff --git a/clos/2.0/NEW-CLOS-BROWSER b/clos/2.0/NEW-CLOS-BROWSER
new file mode 100644
index 00000000..fbc4c912
--- /dev/null
+++ b/clos/2.0/NEW-CLOS-BROWSER
@@ -0,0 +1,1634 @@
+(DEFINE-FILE-INFO PACKAGE (LET ((*PACKAGE*)) (CLIN-PACKAGE "CLOS-BROWSER") (CLUSE-PACKAGE "CLOS") (
+CLFIND-PACKAGE "USER")) READTABLE "XCL" BASE 10)
+(IL:FILECREATED " 4-Dec-91 12:16:19" 
+IL:|{DSK}<usr>local>users>welch>lisp>clos>browser>NEW-CLOS-BROWSER.;22| 91732  
+
+      IL:|previous| IL:|date:| "19-Nov-91 14:14:15" 
+IL:|{DSK}<usr>local>users>welch>lisp>clos>browser>NEW-CLOS-BROWSER.;21|)
+
+
+; Copyright (c) 1991 by Venue.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:NEW-CLOS-BROWSERCOMS)
+
+(IL:RPAQQ IL:NEW-CLOS-BROWSERCOMS 
+          (
+
+(IL:* IL:|;;;| "***************************************")
+
+           
+
+(IL:* IL:|;;;| "")
+
+           
+
+(IL:* IL:|;;;| "Print out a copyright notice when loading")
+
+           
+           (IL:* IL:|;;| "")
+
+           (IL:P (FORMAT T 
+                      "~&;CLOS-BROWSER Copyright (c) 1991 VENUE Corporation.  All rights reserved.~%"
+                        ))
+           
+
+(IL:* IL:|;;;| "LOAD DEPENDENT MODULES")
+
+           
+           (IL:* IL:|;;| "Note: before compiling clos-browser:")
+
+           
+           (IL:* IL:|;;| "    (load 'web-editor.dfasl)")
+
+           
+           (IL:* IL:|;;| "    (load 'clos-browser.dfasl)")
+
+           
+           (IL:* IL:|;;| "    (load 'clos-browser 'prop)")
+
+           
+           (IL:* IL:|;;| "")
+
+           
+
+(IL:* IL:|;;;| "PACKAGE STUFF ")
+
+           (IL:PROPS (IL:NEW-CLOS-BROWSER IL:MAKEFILE-ENVIRONMENT)
+                  (IL:NEW-CLOS-BROWSER IL:FILETYPE))
+           
+           (IL:* IL:|;;| "(IL:P IL:* USER::CLOS-BROWSER-PACKAGE-COMMANDS)")
+
+           
+           (IL:* IL:|;;| "")
+
+           
+
+(IL:* IL:|;;;| "SYSTEM PATCHES")
+
+           
+           (IL:* IL:|;;| "")
+
+           
+           (IL:* IL:|;;| "")
+
+           
+           (IL:* IL:|;;| "")
+
+           
+
+(IL:* IL:|;;;| "CLOS-ICON CLASS & INSTANCE INITIALIZATION")
+
+           (CLOS::CLASSES CLOS-BROWSER:CLOS-ICON)
+           (IL:VARIABLES CLOS-BROWSER:CLOS-ICON)
+           
+           (IL:* IL:|;;| "")
+
+           
+
+(IL:* IL:|;;;| "CLOS-BROWSER CLASS")
+
+           (IL:FUNCTIONS CLOS-BROWSER:BROWSE-CLASS CLOS-BROWSER::COLLECT-FAMILY 
+                  CLOS-BROWSER::MAKE-NODES CLOS-BROWSER::CLOS-BROWSER-CLOSE-FN 
+                  CLOS-BROWSER::BROWSER-CONTAINS-P)
+           (CLOS::CLASSES CLOS-BROWSER::CLOS-BROWSER)
+           (CLOS::METHODS (CLOS-BROWSER::ADD-ROOT (CLOS-BROWSER::CLOS-BROWSER))
+                  (CLOS-BROWSER::ADD-ROOTS (CLOS-BROWSER::CLOS-BROWSER))
+                  (WEB:BOX-NODE (CLOS-BROWSER::CLOS-BROWSER))
+                  (WEB:BROWSE (CLOS-BROWSER::CLOS-BROWSER))
+                  (CLOS-BROWSER::CLEAR-METHOD-MENU-CACHES (CLOS-BROWSER::CLOS-BROWSER))
+                  (WEB:ICON-TITLE (CLOS-BROWSER::CLOS-BROWSER))
+                  (WEB:INITIALIZE-EDITOR (CLOS-BROWSER::CLOS-BROWSER))
+                  (CLOS-BROWSER::NEW-ITEM (CLOS-BROWSER::CLOS-BROWSER))
+                  (WEB:RECOMPUTE (CLOS-BROWSER::CLOS-BROWSER))
+                  (CLOS-BROWSER::REAL-ADD-ROOT (CLOS-BROWSER::CLOS-BROWSER))
+                  (WEB:SHAPE-TO-HOLD (CLOS-BROWSER::CLOS-BROWSER))
+                                                             (IL:* IL:\; "multi-method")
+                  (CLOS-BROWSER::SUBCLASSES-OF NIL)
+                  (CLOS-BROWSER::CONTAINS-P (T CLOS-BROWSER::CLOS-BROWSER)))
+           
+           (IL:* IL:|;;| "")
+
+           
+
+(IL:* IL:|;;;| "CLOS-BROWSER-NODE CLASS")
+
+           (CLOS::CLASSES CLOS-BROWSER::CLOS-BROWSER-NODE)
+           (CLOS::METHODS (CLOS-BROWSER::OBJECT-NAME (CLOS-BROWSER::CLOS-BROWSER-NODE))
+                  (CLOS-BROWSER::OVERRIDE (CLOS-BROWSER::CLOS-BROWSER-NODE))
+                  (CLOS-BROWSER::CACHE (T CLOS-BROWSER::CLOS-BROWSER-NODE))
+                  (CLOS-BROWSER::UNCACHE (CLOS-BROWSER::CLOS-BROWSER-NODE)))
+           (IL:VARS (CLOS-BROWSER::*METHOD-PROMPT-STRING* (CONCATENATE 'STRING 
+                                                                 "Left button to edit the method." 
+                                                                 "
+" "Middle button provides a menu of operations.")))
+           (IL:FUNCTIONS CLOS-BROWSER::EDIT CLOS-BROWSER::MAKE-METHOD-MENU-ITEMS 
+                  CLOS-BROWSER::MAKE-TOP-LEVEL-METHOD-MENU-ITEMS 
+                  CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU)
+           
+           (IL:* IL:|;;| "")
+
+           
+           (IL:* IL:|;;| "OPERATORS (via CLOS-BROWSER-NODE) ON CLOS::STANDARD-CLASS")
+
+           (CLOS::METHODS (CLOS-BROWSER:ADD-BROWSER-METHOD (CLOS-BROWSER::CLOS-BROWSER-NODE))
+                  (CLOS-BROWSER::BROWSE-SUBS (CLOS-BROWSER::CLOS-BROWSER-NODE))
+                  (CLOS-BROWSER::EDIT-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE))
+                  (CLOS-BROWSER::INSPECT-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE))
+                  (CLOS-BROWSER::MENU-METHODS (CLOS-BROWSER::CLOS-BROWSER-NODE))
+                  (CLOS-BROWSER::MAKE-WHENSELECTEDFN (CLOS-BROWSER::CLOS-BROWSER-NODE))
+                  (CLOS-BROWSER::DESCRIBE-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE))
+                  (CLOS-BROWSER::DOCUMENTATION-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE))
+                  (CLOS-BROWSER::PRINT-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE))
+                  (CLOS-BROWSER::SPECIALIZE-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE)))
+           (IL:FUNCTIONS CLOS-BROWSER::COMPLETE-ADD-METHOD CLOS-BROWSER::COMPLETE-SPECIALIZE 
+                  CLOS-BROWSER::LYRIC-COMPLETE-SPECIALIZE CLOS-BROWSER::THIS-CLASS-NODE-P 
+                  CLOS::CLASS-DIRECT-METHODS)
+           
+           (IL:* IL:|;;| "")
+
+           
+           (IL:* IL:|;;| "OPERATORS ON CLOS::STANDARD-CLASS (directly)")
+
+           (CLOS::METHODS (CLOS::COMPUTE-INHERITED-METHODS (STANDARD-CLASS))
+                  (CLOS-BROWSER::SPECIALIZE (STANDARD-CLASS))
+                  (CLOS-BROWSER::SUBCLASSES-OF (STANDARD-CLASS)))
+           
+           (IL:* IL:|;;| "")
+
+           
+           (IL:* IL:|;;| "OPERATORS ON CLOS::STANDARD-METHOD")
+
+           (CLOS::METHODS (CLOS-BROWSER::DELETE-METHOD (STANDARD-METHOD))
+                  (CLOS-BROWSER::COPY (STANDARD-METHOD STANDARD-CLASS))
+                  (CLOS-BROWSER::MOVE (STANDARD-METHOD STANDARD-CLASS))
+                                                             (IL:* IL:\; 
+                                                           "web:move is shadowed above")
+                  (CLOS-BROWSER::PRINT-DEFINITION (STANDARD-METHOD))
+                  (CLOS-BROWSER::DESCRIBE-METHOD (CLOS::METHOD))
+                  (CLOS-BROWSER::RENAME (STANDARD-METHOD))
+                  (CLOS-BROWSER::UPDATE-CACHED-MENUES (STANDARD-METHOD))
+                  (CLOS-BROWSER::WHO-OWNS (STANDARD-METHOD))
+                  
+                  (IL:* IL:|;;| 
+                "update-cached-menues must appear before add-method :after in the coms")
+
+                  (ADD-METHOD :AFTER (STANDARD-GENERIC-FUNCTION STANDARD-METHOD)))
+           (IL:FUNCTIONS CLOS-BROWSER::REPLACE-SPECIALIZERS)
+           
+           (IL:* IL:|;;| "")
+
+           
+
+(IL:* IL:|;;;| "SETUP RELEASE INFO")
+
+           (IL:VARS (CLOS-BROWSER::RELEASE-ID "0.02")
+                  (CLOS-BROWSER::SYSTEM-DATE (CAAR (IL:GETPROP 'IL:CLOS-BROWSER 'IL:FILEDATES))))
+           
+           (IL:* IL:|;;| "")
+
+           
+           (IL:* IL:|;;| "")
+
+           
+           (IL:* IL:|;;| "SETUP BACKGROUND MENU")
+
+           (IL:FUNCTIONS CLOS-BROWSER::IN-SELECT-PACKAGE CLOS-BROWSER::CLASSES-IN-PACKAGE)
+           (IL:P 
+                 (IL:* IL:|;;| "pushnew should eliminate this")
+
+                 (SETQ IL:|BackgroundMenuCommands| (REMOVE 'IL:|BrowseClass| 
+                                                          IL:|BackgroundMenuCommands| :KEY
+                                                          #'CAR))
+                 (PUSH '(IL:|BrowseClass| (CLOS-BROWSER:BROWSE-CLASS)
+                               "Bring up a class browser."
+                               (IL:SUBITEMS (IL:|all in a package| (CLOS-BROWSER:BROWSE-CLASS
+                                                                    (CLOS-BROWSER::CLASSES-IN-PACKAGE
+                                                                     (CLOS-BROWSER::IN-SELECT-PACKAGE
+                                                                      )))
+                                                   
+                               "Select a package and browse all the classes defined in that package."
+                                                   )))
+                       IL:|BackgroundMenuCommands|)
+                 (SETQ IL:|BackgroundMenu| NIL))))
+
+
+
+(IL:* IL:|;;;| "***************************************")
+
+
+
+
+(IL:* IL:|;;;| "")
+
+
+
+
+(IL:* IL:|;;;| "Print out a copyright notice when loading")
+
+
+
+
+(IL:* IL:|;;| "")
+
+
+(FORMAT T "~&;CLOS-BROWSER Copyright (c) 1991 VENUE Corporation.  All rights reserved.~%")
+
+
+
+(IL:* IL:|;;;| "LOAD DEPENDENT MODULES")
+
+
+
+
+(IL:* IL:|;;| "Note: before compiling clos-browser:")
+
+
+
+
+(IL:* IL:|;;| "    (load 'web-editor.dfasl)")
+
+
+
+
+(IL:* IL:|;;| "    (load 'clos-browser.dfasl)")
+
+
+
+
+(IL:* IL:|;;| "    (load 'clos-browser 'prop)")
+
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;;| "PACKAGE STUFF ")
+
+
+(IL:PUTPROPS IL:NEW-CLOS-BROWSER IL:MAKEFILE-ENVIRONMENT (:PACKAGE (LET ((*PACKAGE*))
+                                                                            (IN-PACKAGE 
+                                                                                   "CLOS-BROWSER")
+                                                                            (USE-PACKAGE "CLOS")
+                                                                            (FIND-PACKAGE "USER"))
+                                                                    :READTABLE "XCL" :BASE 10))
+
+(IL:PUTPROPS IL:NEW-CLOS-BROWSER IL:FILETYPE :COMPILE-FILE)
+
+
+
+(IL:* IL:|;;| "(IL:P IL:* USER::CLOS-BROWSER-PACKAGE-COMMANDS)")
+
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;;| "SYSTEM PATCHES")
+
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;;| "CLOS-ICON CLASS & INSTANCE INITIALIZATION")
+
+
+(DEFCLASS CLOS-BROWSER:CLOS-ICON (STANDARD-OBJECT)
+    ((CLOS-BROWSER::CLASS-BROWSERS :ALLOCATION :CLASS :INITFORM NIL)
+                                                             (IL:* IL:\; 
+                                                           "list of all open browsers")
+     (CLOS-BROWSER::DESTINATION-BROWSER :ALLOCATION :CLASS :INITFORM NIL)
+                                                             (IL:* IL:\; 
+                                                           "browser containing boxed node")
+     (CLOS-BROWSER::MENU-CACHE-SWITCH :ALLOCATION :CLASS :INITFORM :LAZY 
+
+            (IL:* IL:|;;| "valid values:")
+
+            (IL:* IL:|;;| ":none for never use cache")
+
+            (IL:* IL:|;;| ":lazy for invalidate cache at method create or remove time causing re-compute and cache at menu request time.")
+
+            (IL:* IL:|;;| 
+   ":eager (not implemented) for re-compute and cache menu whenever a method is created or removed")
+
+            )))
+
+(XCL:DEFGLOBALPARAMETER CLOS-BROWSER:CLOS-ICON (MAKE-INSTANCE 'CLOS-BROWSER:CLOS-ICON))
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;;| "CLOS-BROWSER CLASS")
+
+
+(DEFUN CLOS-BROWSER:BROWSE-CLASS (&OPTIONAL CLOS-BROWSER::CLASS-NAME-OR-LIST &KEY (
+                                                                              CLOS-BROWSER::DIRECTION
+                                                                                       :SUB)
+                                            (CLOS-BROWSER::WINDOW-OR-TITLE "CLOS-browser")
+                                            CLOS-BROWSER::GOOD-CLASSES POSITION)
+   (LET* ((CLOS-BROWSER::ROOT-CLASSES (WHEN CLOS-BROWSER::CLASS-NAME-OR-LIST
+                                          (IF (LISTP CLOS-BROWSER::CLASS-NAME-OR-LIST)
+                                              (MAPCAR #'FIND-CLASS CLOS-BROWSER::CLASS-NAME-OR-LIST)
+                                              (CONS (FIND-CLASS CLOS-BROWSER::CLASS-NAME-OR-LIST)))))
+          (CLOS-BROWSER::NODES (CLOS-BROWSER::MAKE-NODES (CLOS-BROWSER::COLLECT-FAMILY NIL 
+                                                                    CLOS-BROWSER::ROOT-CLASSES)))
+          (CLOS-BROWSER::CLOS-BROWSER (MAKE-INSTANCE 'CLOS-BROWSER::CLOS-BROWSER)))
+         (WEB:INITIALIZE-EDITOR CLOS-BROWSER::CLOS-BROWSER)
+         (SETF (SLOT-VALUE CLOS-BROWSER::CLOS-BROWSER 'CLOS-BROWSER::ROOT-CLASSES)
+               CLOS-BROWSER::ROOT-CLASSES)
+         (SETF (SLOT-VALUE CLOS-BROWSER::CLOS-BROWSER 'CLOS-BROWSER::TITLE)
+               CLOS-BROWSER::CLASS-NAME-OR-LIST)
+         (WEB:BROWSE CLOS-BROWSER::CLOS-BROWSER CLOS-BROWSER::NODES CLOS-BROWSER::WINDOW-OR-TITLE 
+                CLOS-BROWSER::GOOD-CLASSES POSITION)
+         (UNLESS CLOS-BROWSER::NODES (CLOS-BROWSER::ADD-ROOT CLOS-BROWSER::CLOS-BROWSER))
+         CLOS-BROWSER::CLOS-BROWSER))
+
+(DEFUN CLOS-BROWSER::COLLECT-FAMILY (CLOS-BROWSER::FAMILY CLOS-BROWSER::CLASS-LIST)
+   "gather all of the sub-classes of the class passed as family"
+
+   (IL:* IL:|;;| "for efficiency, to avoid gathering and filtering subclasses more than once, we assume family only contains classes whose family has already been gathered.")
+
+   (IF CLOS-BROWSER::CLASS-LIST
+       (LET ((CLOS-BROWSER::FIRST-CLASS (CAR CLOS-BROWSER::CLASS-LIST))
+             (REST (CDR CLOS-BROWSER::CLASS-LIST)))
+            (IF (MEMBER CLOS-BROWSER::FIRST-CLASS CLOS-BROWSER::FAMILY)
+                (PROGN 
+                       (IL:* IL:|;;| "skip gathering class-direct-subclasses ")
+
+                       (CLOS-BROWSER::COLLECT-FAMILY CLOS-BROWSER::FAMILY REST))
+                (PROGN (PUSH CLOS-BROWSER::FIRST-CLASS CLOS-BROWSER::FAMILY)
+                       (CLOS-BROWSER::COLLECT-FAMILY CLOS-BROWSER::FAMILY (APPEND REST
+                                                                                     (
+                                                                        CLOS::CLASS-DIRECT-SUBCLASSES
+                                                                                      
+                                                                            CLOS-BROWSER::FIRST-CLASS
+                                                                                      ))))))
+       CLOS-BROWSER::FAMILY))
+
+(DEFUN CLOS-BROWSER::MAKE-NODES (CLOS-BROWSER::CLASS-LIST)
+   (LET* ((CLOS-BROWSER::NODE-HASH (MAKE-HASH-TABLE))
+          (CLOS-BROWSER::NODE-LIST (MAP 'LIST #'(LAMBDA (CLOS-BROWSER::CLASS
+                                                         &AUX
+                                                         (CLOS-BROWSER::NODE (MAKE-INSTANCE
+                                                                              
+                                                                              '
+                                                                      CLOS-BROWSER::CLOS-BROWSER-NODE
+                                                                              )))
+                                                       (SETF (SLOT-VALUE CLOS-BROWSER::NODE
+                                                                    'CLOS-BROWSER::CLASS)
+                                                             CLOS-BROWSER::CLASS)
+                                                       (SETF (WEB:NODE-NAME CLOS-BROWSER::NODE)
+                                                             (CLASS-NAME CLOS-BROWSER::CLASS))
+                                                       (SETF (GETHASH CLOS-BROWSER::CLASS 
+                                                                    CLOS-BROWSER::NODE-HASH)
+                                                             CLOS-BROWSER::NODE)
+                                                       CLOS-BROWSER::NODE)
+                                        CLOS-BROWSER::CLASS-LIST)))
+         (DOLIST (CLOS-BROWSER::NODE CLOS-BROWSER::NODE-LIST)
+             (SETF (WEB:NODE-LINKS CLOS-BROWSER::NODE)
+                   (MAP 'LIST #'(LAMBDA (CLOS-BROWSER::SUB)
+                                       (GETHASH CLOS-BROWSER::SUB CLOS-BROWSER::NODE-HASH))
+                        (CLOS::CLASS-DIRECT-SUBCLASSES (SLOT-VALUE CLOS-BROWSER::NODE 
+                                                              'CLOS-BROWSER::CLASS)))))
+         CLOS-BROWSER::NODE-LIST))
+
+(DEFUN CLOS-BROWSER::CLOS-BROWSER-CLOSE-FN (CLOS-BROWSER::WINDOW)
+   (LET ((CLOS-BROWSER::BROWSER (IL:WINDOWPROP CLOS-BROWSER::WINDOW 'WEB:WEB-EDITOR)))
+        (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::CLASS-BROWSERS)
+              (REMOVE CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 
+                                                   'CLOS-BROWSER::CLASS-BROWSERS)))
+        (WHEN (EQ CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 
+                                               'CLOS-BROWSER::DESTINATION-BROWSER))
+            (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER)
+                  NIL))))
+
+(DEFUN CLOS-BROWSER::BROWSER-CONTAINS-P (CLOS-BROWSER::CLASS CLOS-BROWSER::BROWSER)
+   "created because too slow to call contains-p method inside a tight loop"
+   (LET ((CLOS-BROWSER::NODE (CAR (MEMBER CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::BROWSER
+                                                                     'WEB::STARTING-LIST)
+                                         :TEST
+                                         #'CLOS-BROWSER::THIS-CLASS-NODE-P))))
+        (WHEN (AND CLOS-BROWSER::NODE (NOT (MEMBER CLOS-BROWSER::CLASS (SLOT-VALUE 
+                                                                              CLOS-BROWSER::BROWSER
+                                                                              'WEB::BAD-LIST)
+                                                  :TEST
+                                                  #'CLOS-BROWSER::THIS-CLASS-NODE-P)))
+              CLOS-BROWSER::NODE)))
+
+(DEFCLASS CLOS-BROWSER::CLOS-BROWSER (WEB:WEB-EDITOR)
+    ((CLOS-BROWSER::ROOT-CLASSES)
+     (WEB:TITLE-ITEMS :ALLOCATION :INSTANCE 
+
+            (IL:* IL:|;;| "Items for menu of selections in title of window")
+
+            :INITFORM
+            '(("Recompute" WEB:RECOMPUTE "Recompute lattice from starting objects"
+                     (IL:SUBITEMS ("Recompute" WEB:RECOMPUTE 
+                                         "Recompute lattice from starting objects")
+                            ("Recompute labels" WEB:RECOMPUTE-LABELS "Recomputes the labels")
+                            ("Recompute in place" WEB:RECOMPUTE-IN-PLACE 
+                                   "Recompute keeping current view in window")
+                            ("Clear caches" CLOS-BROWSER::CLEAR-METHOD-MENU-CACHES 
+                                   "Clear cached menues of methods.")))
+              ("Browser looks" NIL "" (IL:SUBITEMS ("Shape to hold" WEB:SHAPE-TO-HOLD 
+                                               "Make window large or small enough to just hold graph"
+                                                          )
+                                             ("Change font size" WEB:CHANGE-FONT-SIZE 
+                                                    "Choose a new size Font")
+                                             ("Change format" WEB:CHANGE-FORMAT 
+                                                    "Change format between lattice and tree")))
+              ("Add root " CLOS-BROWSER::ADD-ROOT "Add named item to startingList for browser."
+                     (IL:SUBITEMS ("all in a package" CLOS-BROWSER::ADD-ROOTS 
+                                         "Add all the classes in a package to this browser.")))
+
+              (IL:* IL:|;;| 
+         "(\"Unhide class\" remove-from-bad-list \"Restore item previously deleted from browser\")")
+
+              ))
+     (WEB:LEFT-BUTTON-ITEMS :ALLOCATION :CLASS 
+
+            (IL:* IL:|;;| "Menu items for LeftButton seletion -- Value sent as message to object or browser -- see local-commands")
+
+            :INITFORM
+            'WEB:BOX-NODE)
+     (WEB:MIDDLE-BUTTON-ITEMS :ALLOCATION :INSTANCE 
+
+            (IL:* IL:|;;| "Menu items for MiddleButton seletion -- Value sent as message to object or browser -- see local-commands")
+
+            :INITFORM
+            '(("Edit" CLOS-BROWSER::EDIT-CLASS "Edit the class." (IL:SUBITEMS ("Edit" 
+                                                                             CLOS-BROWSER::EDIT-CLASS
+                                                                                     
+                                                                                    "Edit the class."
+                                                                                     )
+                                                                        ("Inspect" 
+                                                                          CLOS-BROWSER::INSPECT-CLASS
+                                                                               
+                                                                "Bring up an inspector on the class."
+                                                                               )))
+              ("Add method" CLOS-BROWSER:ADD-BROWSER-METHOD "Add a method to the class.")
+              ("Browse" CLOS-BROWSER::BROWSE-SUBS "Bring up a browser on this class."
+                     (WHEN NIL                               (IL:* IL:\; 
+                                                           "superclasses not implemented")
+                         (IL:SUBITEMS ("sub classes" CLOS-BROWSER::BROWSE-SUBS 
+                                             "Bring up a browser on this class.")
+                                ("super classes" CLOS-BROWSER::BROWSE-SUPERS "Not Implemented"))))
+              ("Print" CLOS-BROWSER::PRINT-CLASS "Print the form defining the class."
+                     (IL:SUBITEMS ("Print" CLOS-BROWSER::PRINT-CLASS 
+                                         "Print the form defining the class.")
+                            ("Describe" CLOS-BROWSER::DESCRIBE-CLASS 
+                                   "Print a description of the class.")
+                            ("Documentation" CLOS-BROWSER::DOCUMENTATION-CLASS 
+                                   "Display the documentation for the class.")))
+              ("Specialize" CLOS-BROWSER::SPECIALIZE-CLASS "Create a new sub-class of this class.")
+              ("------" CLOS-BROWSER::EDIT-CLASS 
+   "Above this line operates on the class.
+Below this line operates on individual slots and methods.")
+              ("slots" CLOS-BROWSER::EDIT-CLASS "Edit the defclass definition.")
+              ("methods" (CLOS-BROWSER::MENU-METHODS)
+                     "Build a menu of methods local to this class."
+                     (IL:SUBITEMS ("local" (CLOS-BROWSER::MENU-METHODS)
+                                         "Show a menu of methods specialized on this class.."
+                                         (IL:SUBITEMS ("Use cached menu" (CLOS-BROWSER::MENU-METHODS)
+                                                             "Do not recompute the menu of methods")
+                                                ("Recompute menu" (CLOS-BROWSER::MENU-METHODS NIL NIL
+                                                                         NIL T)
+                                                       "Recompute the menu of methods")))
+                            ("inherited" (CLOS-BROWSER::MENU-METHODS :INHERITED)
+                                   "Show only methods inherited by this class."
+                                   (IL:SUBITEMS ("Use cached menu" (CLOS-BROWSER::MENU-METHODS 
+                                                                          :INHERITED)
+                                                       "Do not recompute the menu of methods")
+                                          ("Recompute menu" (CLOS-BROWSER::MENU-METHODS :INHERITED 
+                                                                   NIL NIL T)
+                                                 "Recompute the menu of methods")))
+                            ("all" (CLOS-BROWSER::MENU-METHODS :ALL)
+                                   "Show all methods understood by this class."
+                                   (IL:SUBITEMS ("Use cached menu" (CLOS-BROWSER::MENU-METHODS :ALL)
+                                                       "Do not recompute the menu of methods")
+                                          ("Recompute menu" (CLOS-BROWSER::MENU-METHODS :ALL NIL NIL
+                                                                   T)
+                                                 "Recompute the menu of methods")))))))
+     (CLOS-BROWSER::TITLE :INITFORM "CLOS Browser"           (IL:* IL:\; 
+                                                           "Title passed to GRAPHER package"))))
+
+(DEFMETHOD CLOS-BROWSER::ADD-ROOT ((CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER)
+                                       &OPTIONAL
+                                       (CLOS-BROWSER::NEW-ITEM (CLOS-BROWSER::NEW-ITEM 
+                                                                      CLOS-BROWSER::BROWSER)))
+   "Add a named item to the starting list of the browser "
+   (IF (CLOS-BROWSER::REAL-ADD-ROOT CLOS-BROWSER::BROWSER CLOS-BROWSER::NEW-ITEM)
+       (WEB:RECOMPUTE CLOS-BROWSER::BROWSER)
+
+       (IL:* IL:|;;| "otherwise warn the user")
+
+       (WEB:PROMPT-PRINT CLOS-BROWSER::BROWSER (FORMAT NIL "~A not added to browser." 
+                                                      CLOS-BROWSER::NEW-ITEM))))
+
+(DEFMETHOD CLOS-BROWSER::ADD-ROOTS ((CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER)
+                                        &OPTIONAL
+                                        (CLOS-BROWSER::NEW-ITEMS (CLOS-BROWSER::CLASSES-IN-PACKAGE
+                                                                  (CLOS-BROWSER::IN-SELECT-PACKAGE
+                                                                   ))))
+   "Add all classes in a package to the starting list of the browser"
+   (DOLIST (CLOS-BROWSER::CLASS CLOS-BROWSER::NEW-ITEMS)
+       (UNLESS (CLOS-BROWSER::REAL-ADD-ROOT CLOS-BROWSER::BROWSER CLOS-BROWSER::CLASS)
+           (WEB:PROMPT-PRINT CLOS-BROWSER::BROWSER (FORMAT NIL "~A not added to browser." 
+                                                          CLOS-BROWSER::CLASS))))
+   (WEB:RECOMPUTE CLOS-BROWSER::BROWSER))
+
+(DEFMETHOD WEB:BOX-NODE ((CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER)
+                             CLOS-BROWSER::OBJECT &OPTIONAL CLOS-BROWSER::KEEP-PREVIOUS-BOX)
+   (CALL-NEXT-METHOD)
+   (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER)
+         CLOS-BROWSER::BROWSER))
+
+(DEFMETHOD WEB:BROWSE ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER)
+                           &OPTIONAL CLOS-BROWSER::BROWSE-LIST CLOS-BROWSER::WINDOW-OR-TITLE 
+                           CLOS-BROWSER::GOOD-LIST POSITION)
+   (LET ((CLOS-BROWSER::BROWSER (CALL-NEXT-METHOD)))
+        (PUSHNEW CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 
+                                              'CLOS-BROWSER::CLASS-BROWSERS))))
+
+(DEFMETHOD CLOS-BROWSER::CLEAR-METHOD-MENU-CACHES ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER
+                                                              ))
+   (DOLIST (CLOS-BROWSER::NODE (SLOT-VALUE CLOS-BROWSER::SELF 'WEB::STARTING-LIST 
+                                                             (IL:* IL:\; 
+                                            "starting-list is really all the nodes in the browser.")
+                                      ))
+       (SETF (SLOT-VALUE CLOS-BROWSER::NODE WEB::MENU-CACHE)
+             NIL)))
+
+(DEFMETHOD WEB:ICON-TITLE ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER))
+   (WEB:NODE-NAME (CAR (LAST (SLOT-VALUE CLOS-BROWSER::SELF `WEB::STARTING-LIST)))))
+
+(DEFMETHOD WEB:INITIALIZE-EDITOR ((CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER))
+   "initialize and setup closefn"
+   (CALL-NEXT-METHOD)
+   (PUSHNEW CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::CLASS-BROWSERS))
+   (LET ((CLOS-BROWSER::WINDOW (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::WINDOW)))
+        (IL:WINDOWADDPROP CLOS-BROWSER::WINDOW 'IL:CLOSEFN 'CLOS-BROWSER::CLOS-BROWSER-CLOSE-FN T))
+   CLOS-BROWSER::BROWSER)
+
+(DEFMETHOD CLOS-BROWSER::NEW-ITEM ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER)
+                                       &OPTIONAL CLOS-BROWSER::NEW-ITEM)
+   (UNLESS CLOS-BROWSER::NEW-ITEM
+       (SETQ CLOS-BROWSER::NEW-ITEM (WEB:PROMPT-READ CLOS-BROWSER::SELF "Class"))))
+
+(DEFMETHOD WEB:RECOMPUTE ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER)
+                              &OPTIONAL CLOS-BROWSER::DONT-RESHAPE-FLG)
+
+   (IL:* IL:|;;| "this should be moved to a more intelligent recompute-nodes function that does not have to re-build every single node.")
+
+   (SETF (SLOT-VALUE CLOS-BROWSER::SELF 'WEB::STARTING-LIST)
+         (CLOS-BROWSER::MAKE-NODES (CLOS-BROWSER::COLLECT-FAMILY
+                                        NIL
+                                        (IL:FOR CLOS-BROWSER::EACH
+                                           IL:IN (REVERSE 
+                                                             (IL:* IL:\; 
+                                                           "so they come out in the original order")
+                                                            (SLOT-VALUE CLOS-BROWSER::SELF
+                                                                   'WEB::STARTING-LIST)) IL:WHEN
+                                                                                         
+                                                                                   CLOS-BROWSER::EACH
+                                           IL:COLLECT (SLOT-VALUE CLOS-BROWSER::EACH 
+                                                                 `CLOS-BROWSER::CLASS)))))
+   (CALL-NEXT-METHOD)
+   (WHEN (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER)
+
+       (IL:* IL:|;;| "Node has been invalidated, so get rid of this pointer to it. ")
+
+       (SETF (SLOT-VALUE (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER)
+                    'WEB:BOXED-NODE)
+             NIL)
+       (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER)
+             NIL)))
+
+(DEFMETHOD CLOS-BROWSER::REAL-ADD-ROOT ((CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER)
+                                            CLOS-BROWSER::CLASS)
+   "Add a class to the starting list of the browser"
+   (WHEN CLOS-BROWSER::CLASS
+       (LET* ((CLOS-BROWSER::CLASS (IF (TYPEP CLOS-BROWSER::CLASS 'STANDARD-CLASS)
+                                       CLOS-BROWSER::CLASS
+                                       (FIND-CLASS CLOS-BROWSER::CLASS)))
+              (CLOS-BROWSER::NEW-NODE (CAR (CLOS-BROWSER::MAKE-NODES (LIST CLOS-BROWSER::CLASS)))
+                     ))
+             (IF CLOS-BROWSER::NEW-NODE
+                 (PROGN (PUSHNEW CLOS-BROWSER::NEW-NODE (SLOT-VALUE CLOS-BROWSER::BROWSER
+                                                               'WEB::STARTING-LIST))
+                        (IF (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::GOOD-LIST)
+                            (PUSHNEW CLOS-BROWSER::NEW-NODE (SLOT-VALUE CLOS-BROWSER::BROWSER
+                                                                   'WEB::GOOD-LIST)))
+                        (SETF (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::BAD-LIST)
+                              (IL:DREMOVE CLOS-BROWSER::NEW-NODE (SLOT-VALUE CLOS-BROWSER::BROWSER
+                                                                        'WEB::BAD-LIST)))
+                        CLOS-BROWSER::BROWSER)
+
+                 (IL:* IL:|;;| "otherwise return nil")
+
+                 NIL))))
+
+(DEFMETHOD WEB:SHAPE-TO-HOLD ((WEB::SELF CLOS-BROWSER::CLOS-BROWSER))
+   "give a larger width for empty browsers so add-node will have room"
+   (LET* ((WEB::WINDOW (SLOT-VALUE WEB::SELF 'WEB::WINDOW))
+          (WEB::NODES (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP WEB::WINDOW
+                                                                       'IL:GRAPH))))
+         (IF WEB::NODES
+             (CALL-NEXT-METHOD)
+             (LET ((WEB::REGION (IL:WINDOWPROP WEB::WINDOW 'IL:REGION))
+                   (WEB::MIN-HEIGHT (IL:FONTHEIGHT (IL:DSPFONT NIL WEB::WINDOW)))
+                   (WEB::MIN-WIDTH (MAX 250 (IL:IPLUS 5 (IL:STRINGWIDTH (SLOT-VALUE WEB::SELF
+                                                                               'WEB::TITLE)
+                                                               (IL:DSPFONT NIL 
+                                                                      IL:|WindowTitleDisplayStream|))
+                                                   ))))
+                  (WEB::SET-REGION WEB::SELF (IL:CREATEREGION (IL:|fetch| IL:LEFT IL:|of|
+                                                                                      WEB::REGION)
+                                                    (IL:|fetch| IL:BOTTOM IL:|of| WEB::REGION
+                                                           )
+                                                    WEB::MIN-WIDTH WEB::MIN-HEIGHT))))))
+
+(DEFMETHOD CLOS-BROWSER::SUBCLASSES-OF ((CLOS-BROWSER::CLASS T))
+   (APPEND (LIST CLOS-BROWSER::CLASS)
+          (IL:FOR CLOS-BROWSER::SUBCLASS IL:IN (SLOT-VALUE CLOS-BROWSER::CLASS 
+                                                              'CLOS::DIRECT-SUBCLASSES)
+             IL:JOIN (IF (SLOT-VALUE CLOS-BROWSER::SUBCLASS 'CLOS::DIRECT-SUBCLASSES)
+                             (CLOS-BROWSER::SUBCLASSES-OF CLOS-BROWSER::SUBCLASS)
+                             (LIST CLOS-BROWSER::SUBCLASS)))))
+
+(DEFMETHOD CLOS-BROWSER::CONTAINS-P ((CLOS-BROWSER::CLASS T)
+                                         (CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER))
+   (LET ((CLOS-BROWSER::NODE (CAR (MEMBER CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::BROWSER
+                                                                     'WEB::STARTING-LIST)
+                                         :TEST
+                                         #'CLOS-BROWSER::THIS-CLASS-NODE-P))))
+        (WHEN (AND CLOS-BROWSER::NODE (NOT (MEMBER CLOS-BROWSER::CLASS (SLOT-VALUE 
+                                                                              CLOS-BROWSER::BROWSER
+                                                                              'WEB::BAD-LIST)
+                                                  :TEST
+                                                  #'CLOS-BROWSER::THIS-CLASS-NODE-P)))
+              CLOS-BROWSER::NODE)))
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;;| "CLOS-BROWSER-NODE CLASS")
+
+
+(DEFCLASS CLOS-BROWSER::CLOS-BROWSER-NODE (WEB:WEB-NODE)
+    ((CLOS-BROWSER::CLASS                                    (IL:* IL:\; 
+                                                           "The class represented by this node")
+            )
+     (CLOS-BROWSER::MENU-CACHE :INITFORM NIL)                (IL:* IL:\; 
+  "Menus of methods and slots.  See clos-icon for the switch that controls when this gets updated.")
+     (CLOS-BROWSER::LARGE-MENU-SIZE :ALLOCATION :CLASS :INITFORM 22)
+     (CLOS-BROWSER::LARGE-MENU-FONT :ALLOCATION :INSTANCE :INITFORM (IL:FONTCREATE
+                                                                     `(IL:HELVETICA 8)))
+     (CLOS-BROWSER::LOCAL-METHOD-OPERATIONS :ALLOCATION :INSTANCE :INITFORM
+            '(("Edit" 'CLOS-BROWSER::EDIT "Bring up the editor on this method's definition."
+                     (IL:SUBITEMS ("Inspect" 'INSPECT "Inspect this method")))
+              ("Print" 'CLOS-BROWSER::PRINT-DEFINITION "Pretty Print this method's definition."
+                     (IL:SUBITEMS ("Print" 'PRINT "Print this method's definition.")
+                            ("Describe" 'CLOS-BROWSER::DESCRIBE-METHOD "Describe this method.")
+                            ("Documentation" 'DOCUMENTATION "Print this method's documentation.")))
+              ("Delete" 'CLOS-BROWSER::DELETE-METHOD "Remove this method.")
+              ("Copy" 'CLOS-BROWSER::COPY "Copy this method to boxed class.")
+              ("Move" 'CLOS-BROWSER::MOVE "Move this method to boxed class.")
+              ("Rename" 'CLOS-BROWSER::RENAME 
+                     "Change the name of this method to new name you specify")
+              ("Break" 'CLOS::BREAK-METHOD "Cause a break window whenever this method is invoked.")
+              ("Trace" 'CLOS::TRACE-METHOD "Trace this method.")
+              ("UnBreak" 'CLOS::UNBREAK-METHOD "Unbreak this method.")
+              ("Who owns" 'CLOS-BROWSER::WHO-OWNS 
+                     "Show the classes on which this method is specialized.")))
+     (CLOS-BROWSER::INHERITED-METHOD-OPERATIONS :ALLOCATION :INSTANCE :INITFORM
+            '(("Edit" 'CLOS-BROWSER::EDIT "Bring up the editor on this method's definition."
+                     (IL:SUBITEMS ("Inspect" 'INSPECT "Inspect this method")))
+              ("Print" 'CLOS-BROWSER::PRINT-DEFINITION "Pretty Print this method's definition."
+                     (IL:SUBITEMS ("Print" 'PRINT "Print this method's definition.")
+                            ("Describe" 'CLOS-BROWSER::DESCRIBE-METHOD "Describe this method.")
+                            ("Documentation" 'DOCUMENTATION "Print this method's documentation.")))
+              ("Override" 'CLOS-BROWSER::OVERRIDE "Create a local method with this name.")
+              ("Break" 'CLOS::BREAK-METHOD "Cause a break window whenever this method is invoked.")
+              ("Trace" 'CLOS::TRACE-METHOD "Trace this method.")
+              ("UnBreak" 'CLOS::UNBREAK-METHOD "Unbreak this method.")
+              ("Who owns" 'CLOS-BROWSER::WHO-OWNS 
+                     "Show the classes on which this method is specialized.")))
+     (CLOS-BROWSER::ALL-METHOD-OPERATIONS :ALLOCATION :INSTANCE :INITFORM
+            '(("Edit" 'CLOS-BROWSER::EDIT "Bring up the editor on this method's definition."
+                     (IL:SUBITEMS ("Inspect" 'INSPECT "Inspect this method")))
+              ("Print" 'CLOS-BROWSER::PRINT-DEFINITION "Pretty Print this method's definition."
+                     (IL:SUBITEMS ("Print" 'PRINT "Print this method's definition.")
+                            ("Describe" 'CLOS-BROWSER::DESCRIBE-METHOD "Describe this method.")
+                            ("Documentation" 'DOCUMENTATION "Print this method's documentation.")))
+              ("Delete" 'DELETE "Remove this method.")
+              ("Copy" 'CLOS-BROWSER::COPY "Copy this method to boxed class.")
+              ("Move" 'CLOS-BROWSER::MOVE "Move this method to boxed class.")
+              ("Rename" 'CLOS-BROWSER::RENAME 
+                     "Change the name of this method to new name you specify")
+              ("Override" 'CLOS-BROWSER::OVERRIDE "Create a local method with this name.")
+              ("Break" 'CLOS::BREAK-METHOD "Cause a break window whenever this method is invoked.")
+              ("Trace" 'CLOS::TRACE-METHOD "Trace this method.")
+              ("UnBreak" 'CLOS::UNBREAK-METHOD "Unbreak this method.")
+              ("Who owns" 'CLOS-BROWSER::WHO-OWNS 
+                     "Show the classes on which this method is specialized.")))))
+
+(DEFMETHOD CLOS-BROWSER::OBJECT-NAME ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER-NODE))
+   (WEB:NODE-NAME CLOS-BROWSER::SELF))
+
+(DEFMETHOD CLOS-BROWSER::OVERRIDE ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE)
+                                       CLOS-BROWSER::METHOD)
+   "Create a method specialized on the class."
+   (ADD-METHOD CLOS-BROWSER::NODE NIL (SLOT-VALUE (CLOS::METHOD-GENERIC-FUNCTION CLOS-BROWSER::METHOD
+                                                         )
+                                             'CLOS::NAME)))
+
+(DEFMETHOD CLOS-BROWSER::CACHE (CLOS-BROWSER::MENU (CLOS-BROWSER::NODE 
+                                                              CLOS-BROWSER::CLOS-BROWSER-NODE)
+                                          &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL)
+   (LET ((CLOS-BROWSER::MENU-TYPE (CASE CLOS-BROWSER::INHERITED-OR-ALL
+                                      ((NIL :LOCAL) 'CLOS-BROWSER::LOCAL-METHODS-MENU)
+                                      (:INHERITED 'CLOS-BROWSER::IHHERITED-METHODS-MENU)
+                                      (:ALL 'CLOS-BROWSER::ALL-METHODS-MENU))))
+        (IF (NOT (ASSOC CLOS-BROWSER::MENU-TYPE (SLOT-VALUE CLOS-BROWSER::NODE 
+                                                       'CLOS-BROWSER::MENU-CACHE)))
+
+            (IL:* IL:|;;| "then initialize alist")
+
+            (SETF (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::MENU-CACHE)
+                  (ACONS CLOS-BROWSER::MENU-TYPE CLOS-BROWSER::MENU (SLOT-VALUE CLOS-BROWSER::NODE
+                                                                           'CLOS-BROWSER::MENU-CACHE)
+                         ))
+
+            (IL:* IL:|;;| "otherwise replace what is already there")
+
+            (RPLACD (ASSOC CLOS-BROWSER::MENU-TYPE (SLOT-VALUE CLOS-BROWSER::NODE 
+                                                          'CLOS-BROWSER::MENU-CACHE))
+                   CLOS-BROWSER::MENU))))
+
+(DEFMETHOD CLOS-BROWSER::UNCACHE ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE)
+                                      &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL)
+   (RPLACD (ASSOC (CASE CLOS-BROWSER::INHERITED-OR-ALL
+                      ((NIL :LOCAL) 'CLOS-BROWSER::LOCAL-METHODS-MENU)
+                      (:INHERITED 'CLOS-BROWSER::IHHERITED-METHODS-MENU)
+                      (:ALL 'CLOS-BROWSER::ALL-METHODS-MENU))
+                  (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::MENU-CACHE))
+          NIL))
+
+(IL:RPAQ CLOS-BROWSER::*METHOD-PROMPT-STRING* (CONCATENATE 'STRING 
+                                                         "Left button to edit the method." "
+" "Middle button provides a menu of operations."))
+
+(DEFUN CLOS-BROWSER::EDIT (CLOS-BROWSER::METHOD)
+   (LET ((*PACKAGE* (SYMBOL-PACKAGE (CLOS::GENERIC-FUNCTION-NAME (CLOS::METHOD-GENERIC-FUNCTION
+                                                                  CLOS-BROWSER::METHOD)))))
+        (ED (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD)
+            ':DONTWAIT)))
+
+(DEFUN CLOS-BROWSER::MAKE-METHOD-MENU-ITEMS (CLOS::METHODS CLOS-BROWSER::CLASS &OPTIONAL 
+                                                       CLOS-BROWSER::INHERITED-OR-ALL)
+   "gather method-list into menu items list"
+   (LET ((CLOS-BROWSER::METHOD-MENU-ITEMS (CLOS-BROWSER::MAKE-TOP-LEVEL-METHOD-MENU-ITEMS 
+                                                 CLOS::METHODS CLOS-BROWSER::INHERITED-OR-ALL))
+         (CLOS-BROWSER::EXTRA-MENU-ITEM-POSITIONS))
+        (LET ((CLOS-BROWSER::PREVIOUS.ITEM NIL)
+              (CLOS-BROWSER::THIS.POSITION 0)
+              CLOS-BROWSER::GF-NAME)
+             (DOLIST (CLOS-BROWSER::THIS.ITEM CLOS-BROWSER::METHOD-MENU-ITEMS)
+                 (SETQ CLOS-BROWSER::GF-NAME (CAR CLOS-BROWSER::THIS.ITEM))
+                 (INCF CLOS-BROWSER::THIS.POSITION)
+                 (IF (NOT (AND CLOS-BROWSER::PREVIOUS.ITEM (IF (NOT (FIRST CLOS-BROWSER::THIS.ITEM))
+
+                                                               (IL:* IL:|;;| 
+                                                 "then look for different gf objects with nil name")
+
+                                                               (EQ (CLOS::METHOD-GENERIC-FUNCTION
+                                                                    (SECOND 
+                                                                          CLOS-BROWSER::PREVIOUS.ITEM
+                                                                           ))
+                                                                   (CLOS::METHOD-GENERIC-FUNCTION
+                                                                    (SECOND CLOS-BROWSER::THIS.ITEM))
+                                                                   )
+
+                                                               (IL:* IL:|;;| 
+                                           "otherwise use slightly more efficient test for same gf")
+
+                                                               (EQ (FIRST CLOS-BROWSER::PREVIOUS.ITEM
+                                                                          )
+                                                                   (FIRST CLOS-BROWSER::THIS.ITEM))))
+                          )
+
+                     (IL:* IL:|;;| "then go on to the next")
+
+                     (SETQ CLOS-BROWSER::PREVIOUS.ITEM CLOS-BROWSER::THIS.ITEM)
+
+                     (IL:* IL:|;;| "otherwise we have multi-methods")
+
+                     (PROGN 
+                            (IL:* IL:|;;| "build a sub-menu of all the multi-methods")
+
+                            (IF (NOT (FOURTH CLOS-BROWSER::PREVIOUS.ITEM))
+
+                                (IL:* IL:|;;| "then create the sub-menu")
+
+                                (NCONC CLOS-BROWSER::PREVIOUS.ITEM (LIST (LIST 'IL:SUBITEMS
+                                                                               (
+                                                           CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU
+                                                                                (SECOND 
+                                                                          CLOS-BROWSER::PREVIOUS.ITEM
+                                                                                       )
+                                                                                CLOS-BROWSER::CLASS)
+                                                                               (
+                                                           CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU
+                                                                                (SECOND 
+                                                                              CLOS-BROWSER::THIS.ITEM
+                                                                                       )
+                                                                                CLOS-BROWSER::CLASS))
+                                                                         ))
+
+                                (IL:* IL:|;;| "otherwise add another item to the sub-menu")
+
+                                (NCONC (FOURTH CLOS-BROWSER::PREVIOUS.ITEM)
+                                       (LIST (CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU
+                                              (SECOND CLOS-BROWSER::THIS.ITEM)
+                                              CLOS-BROWSER::CLASS))))
+
+                            (IL:* IL:|;;| 
+                          "collect the position of the extra multi-method menu item")
+
+                            (PUSH CLOS-BROWSER::THIS.POSITION CLOS-BROWSER::EXTRA-MENU-ITEM-POSITIONS
+                                  )))))
+
+        (IL:* IL:|;;| "remove extra multi-method menu items last first.")
+
+        (DOLIST (CLOS-BROWSER::EACH.POSITION CLOS-BROWSER::EXTRA-MENU-ITEM-POSITIONS)
+            (SETQ CLOS-BROWSER::METHOD-MENU-ITEMS (DELETE-IF #'XCL:TRUE 
+                                                         CLOS-BROWSER::METHOD-MENU-ITEMS :START
+                                                         (- CLOS-BROWSER::EACH.POSITION 1)
+                                                         :END CLOS-BROWSER::EACH.POSITION)))
+
+        (IL:* IL:|;;| "prepend the Add method item")
+
+        (APPEND '(("Add method" NIL 
+                         "Bring up an editor containing a template for a new method on this class."))
+               CLOS-BROWSER::METHOD-MENU-ITEMS)))
+
+(DEFUN CLOS-BROWSER::MAKE-TOP-LEVEL-METHOD-MENU-ITEMS (CLOS::METHODS &OPTIONAL 
+                                                                 CLOS-BROWSER::INHERITED-OR-ALL)
+   "gather local-methods into menu items list"
+   (DECLARE (SPECIAL CLOS-BROWSER::*METHOD-PROMPT-STRING*))
+   (SORT (IL:FOR CLOS-BROWSER::EACH.METHOD IL:IN CLOS::METHODS IL:BIND 
+                                                                            CLOS-BROWSER::METHOD-NAME
+            IL:UNLESS (AND (NOT (EQL CLOS-BROWSER::INHERITED-OR-ALL :ALL))
+                               (CLOS::*TYPEP CLOS-BROWSER::EACH.METHOD 
+                                      'CLOS::STANDARD-ACCESSOR-METHOD)) 
+
+                  (IL:* IL:|;;| "weed out auto-generated slot access methods ")
+ IL:|eachtime| (SETQ CLOS-BROWSER::METHOD-NAME (CAR (CLOS::FULL-METHOD-NAME 
+                                                               CLOS-BROWSER::EACH.METHOD NIL)))
+            IL:|collect| (LIST CLOS-BROWSER::METHOD-NAME CLOS-BROWSER::EACH.METHOD 
+                                   CLOS-BROWSER::*METHOD-PROMPT-STRING*))
+         #'IL:ALPHORDER :KEY #'CAR))
+
+(DEFUN CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU (CLOS-BROWSER::METHOD CLOS-BROWSER::CLASS)
+   "make a menu item to distinguish methods on the same gf"
+   (LET (CLOS-BROWSER::SUB-ITEM-NAME)
+        (DECLARE (SPECIAL CLOS-BROWSER::*METHOD-PROMPT-STRING*))
+
+        (IL:* IL:|;;| "first put out the qualifiers if any")
+
+        (DOLIST (CLOS-BROWSER::QUALIFIER (SLOT-VALUE CLOS-BROWSER::METHOD 'CLOS::SPECIALIZERS))
+            (SETQ CLOS-BROWSER::SUB-ITEM-NAME (CONCATENATE 'STRING CLOS-BROWSER::SUB-ITEM-NAME
+                                                     (WHEN CLOS-BROWSER::SUB-ITEM-NAME " ")
+                                                     (PRIN1-TO-STRING CLOS-BROWSER::QUALIFIER))))
+
+        (IL:* IL:|;;| "then do the specializers ")
+
+        (IL:* IL:|;;| "(DOLIST (TYPE-SPECIFIER (SLOT-VALUE METHOD 'CLOS::TYPE-SPECIFIERS)) (SETQ SUB-ITEM-NAME (CONCATENATE 'STRING SUB-ITEM-NAME (WHEN SUB-ITEM-NAME \" \") (IF (EQ CLASS TYPE-SPECIFIER) ;; then lets just do a plus sign \"+\" ;; else print the name (PRIN1-TO-STRING ;; test until class-name works properly (IF (TYPEP TYPE-SPECIFIER 'STANDARD-CLASS) (CLASS-NAME TYPE-SPECIFIER) TYPE-SPECIFIER))))))")
+
+        (LIST CLOS-BROWSER::SUB-ITEM-NAME CLOS-BROWSER::METHOD CLOS-BROWSER::*METHOD-PROMPT-STRING*)))
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;| "OPERATORS (via CLOS-BROWSER-NODE) ON CLOS::STANDARD-CLASS")
+
+
+(DEFMETHOD CLOS-BROWSER:ADD-BROWSER-METHOD ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE)
+                                                &OPTIONAL CLOS-BROWSER::FORM 
+                                                CLOS-BROWSER::METHOD-NAME)
+   "bring up sedit on a template to add a method to this class"
+   (DECLARE (SPECIAL SEDIT::BASIC-GAP SEDIT::BODY-GAP SEDIT::ARGS-GAP))
+   (LET* ((CLASS-NAME (CLASS-NAME (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS)))
+          CLOS-BROWSER::CONTEXT
+          (CLOS-BROWSER::NAME (FORMAT NIL "New method on ~A" CLASS-NAME))
+          (*PACKAGE* (SYMBOL-PACKAGE CLASS-NAME)))
+         (UNLESS CLOS-BROWSER::FORM
+             (SETQ CLOS-BROWSER::FORM (LIST 'DEFMETHOD (OR CLOS-BROWSER::METHOD-NAME SEDIT::BASIC-GAP
+                                                           )
+                                            (LIST (LIST (INTERN "SELF")
+                                                        CLASS-NAME)
+                                                  SEDIT::ARGS-GAP)
+                                            SEDIT::BODY-GAP)))
+         (SEDIT:SEDIT CLOS-BROWSER::FORM (LIST :NAME CLOS-BROWSER::NAME :COMPLETION-FN 
+                                               #'CLOS-BROWSER::COMPLETE-ADD-METHOD)
+                :DONTWAIT)))
+
+(DEFMETHOD CLOS-BROWSER::BROWSE-SUBS ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE))
+   (CLOS-BROWSER:BROWSE-CLASS (SLOT-VALUE (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS)
+                                         'CLOS::NAME)))
+
+(DEFMETHOD CLOS-BROWSER::EDIT-CLASS ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE))
+   (LET* ((CLOS-BROWSER::CLASS (CLASS-NAME (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS)))
+          (*PACKAGE* (SYMBOL-PACKAGE CLOS-BROWSER::CLASS)))
+         (ED CLOS-BROWSER::CLASS '(CLOS-BROWSER::CLASSES :DONTWAIT))))
+
+(DEFMETHOD CLOS-BROWSER::INSPECT-CLASS ((CLOS::OBJECT CLOS-BROWSER::CLOS-BROWSER-NODE))
+   (INSPECT (SLOT-VALUE CLOS::OBJECT 'CLOS-BROWSER::CLASS)))
+
+(DEFMETHOD CLOS-BROWSER::MENU-METHODS ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE)
+                                           &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL 
+                                           CLOS-BROWSER::ITEMS CLOS-BROWSER::FIX-FLAG 
+                                           CLOS-BROWSER::RECOMPUTE-FLAG)
+   "pops up a menu of the methods for the class representing the node."
+
+   (IL:* IL:|;;| "If INHERITED-OR-ALL is NIL or :local only local methods are menued.")
+
+   (IL:* IL:|;;| "If INHERITED-OR-ALL is :inherited only inherited methods are menued.")
+
+   (IL:* IL:|;;| "If INHERITED-OR-ALL is :all all methods are menued.")
+
+   (IL:* IL:|;;| "If items are present, the list of methods is not re-generated.")
+
+   (IL:* IL:|;;| 
+ "If the fix-flag is t, the user is asked to position the menu and no \"Fix menu\" item appears.")
+
+   (IL:* IL:|;;| "The whenselectedfn can call this again to generate a fixed menu.")
+
+   (LET* ((CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS))
+          (*PACKAGE* (SYMBOL-PACKAGE (SLOT-VALUE CLOS-BROWSER::CLASS 'CLOS::NAME)))
+          (CLOS-BROWSER::MENU (UNLESS (OR CLOS-BROWSER::RECOMPUTE-FLAG (EQ (SLOT-VALUE 
+                                                                               CLOS-BROWSER:CLOS-ICON
+                                                                                  
+                                                                                  '
+                                                                      CLOS-BROWSER::MENU-CACHE-SWITCH
+                                                                                  )
+                                                                           :NONE))
+                                  (REST                      (IL:* IL:\; "use the cached menu")
+                                        (ASSOC (CASE CLOS-BROWSER::INHERITED-OR-ALL
+                                                   ((NIL :LOCAL) 'CLOS-BROWSER::LOCAL-METHODS-MENU)
+                                                   (:INHERITED 'CLOS-BROWSER::IHHERITED-METHODS-MENU)
+                                                   (:ALL 'CLOS-BROWSER::ALL-METHODS-MENU))
+                                               (SLOT-VALUE CLOS-BROWSER::NODE 
+                                                      'CLOS-BROWSER::MENU-CACHE))))))
+
+         (IL:* IL:|;;| "unless it was cached, make the menu")
+
+         (UNLESS (AND CLOS-BROWSER::MENU (IL:TYPE? IL:MENU CLOS-BROWSER::MENU))
+
+             (IL:* IL:|;;| "unless the menu items were passed in, compute them")
+
+             (UNLESS CLOS-BROWSER::ITEMS
+                 (SETQ CLOS-BROWSER::ITEMS (CLOS-BROWSER::MAKE-METHOD-MENU-ITEMS
+                                            (CASE CLOS-BROWSER::INHERITED-OR-ALL
+                                                ((NIL :LOCAL) (CAR (SLOT-VALUE CLOS-BROWSER::CLASS
+                                                                          'CLOS::DIRECT-METHODS)))
+                                                (:INHERITED (CLOS::COMPUTE-INHERITED-METHODS 
+                                                                   CLOS-BROWSER::CLASS))
+                                                (:ALL (CLOS::COMPUTE-INHERITED-METHODS 
+                                                             CLOS-BROWSER::CLASS :ALL)))
+                                            CLOS-BROWSER::CLASS)))
+
+             (IL:* IL:|;;| "create the menu using whenselectedfn")
+
+             (SETQ CLOS-BROWSER::MENU (IL:CREATE IL:MENU
+                                             IL:TITLE IL:_ (IF CLOS-BROWSER::FIX-FLAG
+                                                               (CLASS-NAME CLOS-BROWSER::CLASS)
+                                                               "methods")
+                                             IL:MENUFONT IL:_ (WHEN (> (LENGTH CLOS-BROWSER::ITEMS)
+                                                                       (SLOT-VALUE CLOS-BROWSER::NODE
+                                                                              
+                                                                              '
+                                                                        CLOS-BROWSER::LARGE-MENU-SIZE
+                                                                              ))
+                                                                  (SLOT-VALUE CLOS-BROWSER::NODE
+                                                                         
+                                                                         '
+                                                                        CLOS-BROWSER::LARGE-MENU-FONT
+                                                                         ))
+                                             IL:MENUUSERDATA IL:_ '(:ESCAPE T)
+                                                             (IL:* IL:\; 
+                                   "cause symbols to print in mouse process's read-table & package")
+                                             IL:WHENSELECTEDFN IL:_ (
+                                                                    CLOS-BROWSER::MAKE-WHENSELECTEDFN
+                                                                     CLOS-BROWSER::NODE 
+                                                                     CLOS-BROWSER::INHERITED-OR-ALL 
+                                                                     CLOS-BROWSER::ITEMS)
+                                             IL:ITEMS IL:_ (APPEND CLOS-BROWSER::ITEMS
+                                                                  (UNLESS CLOS-BROWSER::FIX-FLAG
+                                                                      '(("Fix menu" NIL 
+                     "Place this menu on the screen.  WARNING: cached menues are not kept up-to-date"
+                                                                               ))))))
+
+             (IL:* IL:|;;| "cache the menu on the node")
+
+             (CLOS-BROWSER::CACHE CLOS-BROWSER::MENU CLOS-BROWSER::NODE 
+                    CLOS-BROWSER::INHERITED-OR-ALL))
+         (IF CLOS-BROWSER::FIX-FLAG
+
+             (IL:* IL:|;;| "ask user to position menu")
+
+             (IL:MOVEW (IL:ADDMENU CLOS-BROWSER::MENU))
+
+             (IL:* IL:|;;| "otherwise just pop it up")
+
+             (IL:MENU CLOS-BROWSER::MENU))))
+
+(DEFMETHOD CLOS-BROWSER::MAKE-WHENSELECTEDFN ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE
+                                                         )
+                                                  &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL 
+                                                  CLOS-BROWSER::ITEMS)
+   `(LAMBDA
+     (CLOS-BROWSER::MENU-ITEM IGNORE CLOS-BROWSER::MOUSE-KEY)
+     (LET
+      ((CLOS-BROWSER::METHOD-NAME (FIRST CLOS-BROWSER::MENU-ITEM))
+       (CLOS-BROWSER::METHOD (SECOND CLOS-BROWSER::MENU-ITEM)))
+      (IF (NULL CLOS-BROWSER::METHOD)
+
+          (IL:* IL:|;;| "do the non-method items")
+
+          (COND
+             ((STRING= CLOS-BROWSER::METHOD-NAME "Add method")
+              (CLOS-BROWSER:ADD-BROWSER-METHOD ',CLOS-BROWSER::NODE NIL))
+             ((STRING= CLOS-BROWSER::METHOD-NAME "Fix menu")
+
+              (IL:* IL:|;;| "call MENU-LOCAL-METHODS again to create fixed menu ")
+
+              (CLOS-BROWSER::MENU-METHODS ',CLOS-BROWSER::NODE ',CLOS-BROWSER::INHERITED-OR-ALL
+                     ',CLOS-BROWSER::ITEMS T))
+             (T CLOS-BROWSER::OPERATION))
+
+          (IL:* IL:|;;| "got a method, lets get an operation")
+
+          (LET ((CLOS-BROWSER::OPERATION
+                 (CASE CLOS-BROWSER::MOUSE-KEY
+                     (IL:LEFT 'CLOS-BROWSER::EDIT)
+                     (IL:MIDDLE (IL:MENU (IL:CREATE
+                                          IL:MENU
+                                          IL:TITLE IL:_ CLOS-BROWSER::METHOD-NAME
+                                          IL:ITEMS IL:_
+                                          (SLOT-VALUE ',CLOS-BROWSER::NODE
+                                                 ',(CASE CLOS-BROWSER::INHERITED-OR-ALL
+                                                       ((NIL :LOCAL) 
+                                                                     '
+                                                                CLOS-BROWSER::LOCAL-METHOD-OPERATIONS)
+                                                       (:INHERITED 
+                                                                   '
+                                                            CLOS-BROWSER::INHERITED-METHOD-OPERATIONS)
+                                                       (:ALL 'CLOS-BROWSER::ALL-METHOD-OPERATIONS))))
+                                       )))))
+
+               (IL:* IL:|;;| "got an operation, lets use it on the method")
+
+               (CASE CLOS-BROWSER::OPERATION
+                   ((NIL) NIL)
+                   ((CLOS-BROWSER::COPY CLOS-BROWSER::MOVE)  (IL:* IL:\; 
+                                                           "need to supply destination")
+                      (FUNCALL CLOS-BROWSER::OPERATION CLOS-BROWSER::METHOD 
+
+                             (IL:* IL:|;;| "to class")
+
+                             (PROGN (UNLESS (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 
+                                                   'CLOS-BROWSER::DESTINATION-BROWSER)
+                                           (ERROR "Please box a destination class, then say OK."))
+                                    (SLOT-VALUE (SLOT-VALUE (SLOT-VALUE CLOS-BROWSER:CLOS-ICON
+                                                                   
+                                                                   'CLOS-BROWSER::DESTINATION-BROWSER
+                                                                   )
+                                                       `WEB:BOXED-NODE)
+                                           `CLOS-BROWSER::CLASS))
+
+                             (IL:* IL:|;;| "from class")
+
+                             (SLOT-VALUE ',CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS)))
+                   ((DELETE)                                 (IL:* IL:\; 
+                                                           "need to supply extra confirm")
+                      (WHEN (IL:MOUSECONFIRM (FORMAT NIL 
+                                                    "Are you sure you wish to delete the ~A method?"
+                                                    (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD)))
+                            (FUNCALL CLOS-BROWSER::OPERATION CLOS-BROWSER::METHOD)))
+                   ((CLOS-BROWSER::OVERRIDE)                 (IL:* IL:\; "use add-method ")
+                      (FUNCALL CLOS-BROWSER::OPERATION ',CLOS-BROWSER::NODE CLOS-BROWSER::METHOD))
+                   (OTHERWISE (FUNCALL CLOS-BROWSER::OPERATION CLOS-BROWSER::METHOD))))))))
+
+(DEFMETHOD CLOS-BROWSER::DESCRIBE-CLASS ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER-NODE))
+   (CLOS::DESCRIBE-OBJECT (SLOT-VALUE CLOS-BROWSER::SELF 'CLOS-BROWSER::CLASS)
+          *TRACE-OUTPUT*))
+
+(DEFMETHOD CLOS-BROWSER::DOCUMENTATION-CLASS ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER-NODE
+                                                         ))
+   (DOCUMENTATION (SLOT-VALUE CLOS-BROWSER::SELF 'CLOS-BROWSER::CLASS)))
+
+(DEFMETHOD CLOS-BROWSER::PRINT-CLASS ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER-NODE))
+   (PPRINT (IL:GETDEF (SLOT-VALUE (SLOT-VALUE CLOS-BROWSER::SELF `CLOS-BROWSER::CLASS)
+                             'CLOS::NAME)
+                  'CLOS-BROWSER::CLASSES)))
+
+(DEFMETHOD CLOS-BROWSER::SPECIALIZE-CLASS ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE)
+                                               &OPTIONAL CLOS-BROWSER::FORM 
+                                               CLOS-BROWSER::NEW-CLASS-NAME)
+   (CLOS-BROWSER::SPECIALIZE (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS)
+          CLOS-BROWSER::FORM CLOS-BROWSER::NEW-CLASS-NAME))
+
+(DEFUN CLOS-BROWSER::COMPLETE-ADD-METHOD (CLOS-BROWSER::CONTEXT STRUCTURE &OPTIONAL (
+                                                                               CLOS-BROWSER::CHANGED?
+                                                                                         T))
+   (DECLARE (IGNORE CLOS-BROWSER::CONTEXT))
+   (CASE CLOS-BROWSER::CHANGED?
+       ((:ABORT NIL) NIL)
+       (OTHERWISE (EVAL (COPY-TREE                           (IL:* IL:\; 
+                                 "to ensure the original list does not get destructively clobbered")
+                               STRUCTURE)))))
+
+(DEFUN CLOS-BROWSER::COMPLETE-SPECIALIZE (IGNORE STRUCTURE CLOS-BROWSER::CHANGED?)
+   (DECLARE (IGNORE CLOS-BROWSER::CONTEXT))
+   (CASE CLOS-BROWSER::CHANGED?
+       ((:ABORT NIL) NIL)
+       (T (LET ((CLOS-BROWSER::ORIGINALCURSOR (IL:CURSOR)))
+               (UNWIND-PROTECT
+                   (PROGN (IL:SETCURSOR IL:WAITINGCURSOR)
+                          (LET ((CLOS-BROWSER::SUB-CLASS (EVAL (COPY-TREE 
+                                                             (IL:* IL:\; 
+                             "so original list does not get clobbered if this class's name changes")
+                                                                      STRUCTURE)))
+                                CLOS-BROWSER::SUPER-CLASS)
+
+                               (IL:* IL:|;;| "check for bug")
+
+                               (WHEN (SYMBOLP CLOS-BROWSER::SUB-CLASS)
+                                   (SETQ CLOS-BROWSER::SUB-CLASS (FIND-CLASS CLOS-BROWSER::SUB-CLASS)
+                                         ))
+                               (DOLIST (CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON
+                                                                     'CLOS-BROWSER::CLASS-BROWSERS))
+                                   (DOLIST (CLOS-BROWSER::SUPER-CLASS (SLOT-VALUE 
+                                                                             CLOS-BROWSER::SUB-CLASS
+                                                                             
+                                                                             '
+                                                                            CLOS::DIRECT-SUPERCLASSES
+                                                                             ))
+                                       (WHEN (CLOS-BROWSER::CONTAINS-P CLOS-BROWSER::SUPER-CLASS 
+                                                    CLOS-BROWSER::BROWSER)
+                                           (CLOS-BROWSER::ADD-ROOT CLOS-BROWSER::BROWSER 
+                                                  CLOS-BROWSER::SUB-CLASS)
+                                           (RETURN))))))
+                   (IL:SETCURSOR CLOS-BROWSER::ORIGINALCURSOR))))))
+
+(DEFUN CLOS-BROWSER::LYRIC-COMPLETE-SPECIALIZE (IGNORE STRUCTURE)
+   (LET ((CLOS-BROWSER::ORIGINALCURSOR (IL:CURSOR)))
+        (UNWIND-PROTECT
+            (PROGN (IL:SETCURSOR IL:WAITINGCURSOR)
+                   (LET ((CLOS-BROWSER::SUB-CLASS (EVAL (COPY-TREE 
+                                                             (IL:* IL:\; 
+                             "so original list does not get clobbered if this class's name changes")
+                                                               STRUCTURE)))
+                         CLOS-BROWSER::SUPER-CLASS)
+
+                        (IL:* IL:|;;| "check for bug")
+
+                        (WHEN (SYMBOLP CLOS-BROWSER::SUB-CLASS)
+                            (SETQ CLOS-BROWSER::SUB-CLASS (CLOS::SYMBOL-CLASS CLOS-BROWSER::SUB-CLASS
+                                                                 )))
+                        (DOLIST (CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON
+                                                              'CLOS-BROWSER::CLASS-BROWSERS))
+                            (DOLIST (CLOS-BROWSER::SUPER-CLASS (SLOT-VALUE CLOS-BROWSER::SUB-CLASS
+                                                                      'CLOS::LOCAL-SUPERS))
+                                (WHEN (CLOS-BROWSER::CONTAINS-P CLOS-BROWSER::SUPER-CLASS 
+                                             CLOS-BROWSER::BROWSER)
+                                    (CLOS-BROWSER::ADD-ROOT CLOS-BROWSER::BROWSER 
+                                           CLOS-BROWSER::SUB-CLASS)
+                                    (RETURN))))))
+            (IL:SETCURSOR CLOS-BROWSER::ORIGINALCURSOR))))
+
+(DEFUN CLOS-BROWSER::THIS-CLASS-NODE-P (CLOS-BROWSER::CLASS CLOS-BROWSER::NODE)
+   (EQ CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS)))
+
+(DEFUN CLOS::CLASS-DIRECT-METHODS (CLOS::CLASS)
+   (SLOT-VALUE CLOS::CLASS 'CLOS::DIRECT-METHODS))
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;| "OPERATORS ON CLOS::STANDARD-CLASS (directly)")
+
+
+(DEFMETHOD CLOS::COMPUTE-INHERITED-METHODS ((CLOS::SELF STANDARD-CLASS)
+                                                &OPTIONAL CLOS::ALL-FLAG)
+   "Compute and return all inherited methods of a class.  If all-flag eq :all then methods on t and the passed class are included."
+
+   (IL:* IL:|;;| "The following does not use generic function dispatch-orders, discriminating-functions, or classical-method-tables.")
+
+   (IL:* IL:|;;| "For each method in the direct-methods of each inherited class in the class-precedence-list for the class of interest, in class precedence order check to see if we have already analyzed its generic function.")
+
+   (IL:* IL:|;;| "If it is a new gf then if there is exactly one type specifier then add the direct method to the list of inherited methods.")
+
+   (IL:* IL:|;;| "If there is more than one type specifier then for every method in the gf for each specializer if the specializing class is equal to or later than the current class in the class precedence list, ignoring t, pushnew the method on the list of inherited methods.��")
+
+   (LET
+    ((CLOS::FILTERED-CLASSES NIL)
+     (CLOS::MY-GFS NIL)
+     (CLOS::CLASS-PRECEDENCE-LIST (SLOT-VALUE CLOS::SELF 'CLOS::CLASS-PRECEDENCE-LIST))
+     (CLOS::INHERITED-METHODS NIL)
+     (CLOS::DIRECT-METHODS (CAR (SLOT-VALUE CLOS::SELF 'CLOS::DIRECT-METHODS)))
+     (CLOS::T-CLASS (FIND-CLASS 'T)))
+    (UNLESS (EQ CLOS::ALL-FLAG :ALL)                         (IL:* IL:\; 
+                                                           "ignore t and the bottom class ")
+        (PUSH CLOS::T-CLASS CLOS::FILTERED-CLASSES)
+        (PUSH CLOS::SELF CLOS::FILTERED-CLASSES)
+        (SETQ CLOS::MY-GFS (MAPCAR #'CLOS::METHOD-GENERIC-FUNCTION CLOS::DIRECT-METHODS)))
+    (DOLIST (CLOS::CLASS CLOS::CLASS-PRECEDENCE-LIST)
+        (UNLESS (MEMBER CLOS::CLASS CLOS::FILTERED-CLASSES)
+            (DOLIST (CLOS::DIRECT-METHOD (CAR (CLOS::CLASS-DIRECT-METHODS CLOS::CLASS)))
+                (LET ((CLOS::GF (CLOS::METHOD-GENERIC-FUNCTION CLOS::DIRECT-METHOD)))
+                     (UNLESS (MEMBER CLOS::GF CLOS::MY-GFS :TEST #'EQ)
+                         (IF (= 1 (LENGTH (SLOT-VALUE CLOS::DIRECT-METHOD 'CLOS::SPECIALIZERS))
+                                                             (IL:* IL:\; "Note: this check relies on guaranteed congruent lambda lists.  There should be some way to query the gf directly.")
+                                )
+
+                             (IL:* IL:|;;| 
+                           "then only one specializer so this method must be inherited. ")
+
+                             (PUSH CLOS::DIRECT-METHOD CLOS::INHERITED-METHODS)
+
+                             (IL:* IL:|;;| "otherwise more than one so must look at specializers ")
+
+                             (DOLIST (CLOS::GF-METHOD (SLOT-VALUE CLOS::GF 'CLOS::METHODS))
+                                 (DOLIST (CLOS::SPECIFIER (SLOT-VALUE CLOS::GF-METHOD 
+                                                                 'CLOS::SPECIALIZERS))
+                                     (UNLESS (OR (EQ CLOS::T-CLASS CLOS::SPECIFIER)
+                                                 (NOT (MEMBER CLOS::SPECIFIER 
+                                                             CLOS::CLASS-PRECEDENCE-LIST :TEST
+                                                             #'EQ)))
+                                         (PUSHNEW CLOS::GF-METHOD CLOS::INHERITED-METHODS)
+                                         (RETURN))))))
+                     (PUSH CLOS::GF CLOS::MY-GFS)))))
+    CLOS::INHERITED-METHODS))
+
+(DEFMETHOD CLOS-BROWSER::SPECIALIZE ((CLOS-BROWSER::CLASS STANDARD-CLASS)
+                                         &OPTIONAL CLOS-BROWSER::FORM CLOS-BROWSER::NEW-CLASS-NAME)
+   (DECLARE (SPECIAL SEDIT::BASIC-GAP))
+   (LET* ((CLASS-NAME (CLASS-NAME CLOS-BROWSER::CLASS))
+          CLOS-BROWSER::CONTEXT
+          (CLOS-BROWSER::NAME (FORMAT NIL "New sub-class of ~A" CLASS-NAME))
+          (*PACKAGE* (SYMBOL-PACKAGE CLASS-NAME)))
+         (UNLESS CLOS-BROWSER::FORM
+             (SETQ CLOS-BROWSER::FORM (LIST 'DEFCLASS (OR CLOS-BROWSER::NEW-CLASS-NAME 
+                                                          SEDIT::BASIC-GAP)
+                                            (LIST CLASS-NAME)
+                                            (LIST SEDIT::BODY-GAP))))
+
+         (IL:* IL:|;;| "call sedit")
+
+         (SEDIT:SEDIT CLOS-BROWSER::FORM (LIST :NAME CLOS-BROWSER::NAME :COMPLETION-FN 
+                                               #'CLOS-BROWSER::COMPLETE-SPECIALIZE)
+                :DONTWAIT)))
+
+(DEFMETHOD CLOS-BROWSER::SUBCLASSES-OF ((CLOS-BROWSER::CLASS STANDARD-CLASS))
+   (APPEND (LIST CLOS-BROWSER::CLASS)
+          (IL:FOR CLOS-BROWSER::SUBCLASS IL:IN (SLOT-VALUE CLOS-BROWSER::CLASS 
+                                                              'CLOS::DIRECT-SUBCLASSES)
+             IL:JOIN (IF (SLOT-VALUE CLOS-BROWSER::SUBCLASS 'CLOS::DIRECT-SUBCLASSES)
+                             (CLOS-BROWSER::SUBCLASSES-OF CLOS-BROWSER::SUBCLASS)
+                             (LIST CLOS-BROWSER::SUBCLASS)))))
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;| "OPERATORS ON CLOS::STANDARD-METHOD")
+
+
+(DEFMETHOD CLOS-BROWSER::DELETE-METHOD ((CLOS-BROWSER::METHOD STANDARD-METHOD))
+   (REMOVE-METHOD (SLOT-VALUE CLOS-BROWSER::METHOD 'CLOS::GENERIC-FUNCTION)
+          CLOS-BROWSER::METHOD))
+
+(DEFMETHOD CLOS-BROWSER::COPY ((CLOS-BROWSER::METHOD STANDARD-METHOD)
+                                   (CLOS-BROWSER::TO-CLASS STANDARD-CLASS)
+                                   &OPTIONAL CLOS-BROWSER::FROM-CLASS)
+   (WHEN (EQ CLOS-BROWSER::TO-CLASS CLOS-BROWSER::FROM-CLASS)
+         (RETURN-FROM CLOS-BROWSER::COPY))
+
+   (IL:* IL:|;;| "if we have the source code, find all the references to the from class, change them to the to-class, and evaluate the new form.   If from-class is not provided, if method is specialized on just one class, use it, otherwise ask the user.")
+
+   (IL:* IL:|;;| "If we dont have source code, we could ask if you want to just move the method object, but instead we print a complaint and punt.")
+
+   (LET ((CLOS-BROWSER::METHOD-DEFINITION (COPY-TREE (XCL:IGNORE-ERRORS (IL:GETDEF (
+                                                                               CLOS::FULL-METHOD-NAME
+                                                                                    
+                                                                                 CLOS-BROWSER::METHOD
+                                                                                    )
+                                                                               
+                                                                               'CLOS-BROWSER::METHODS
+                                                                               ))))
+         (CLOS-BROWSER::NON-T-CLASSES (MAPCAR #'(LAMBDA (CLOS-BROWSER::CLASS)
+                                                       (UNLESS (EQ CLOS-BROWSER::CLASS 'T)
+                                                              CLOS-BROWSER::CLASS))
+                                             (CLOS::METHOD-SPECIALIZERS CLOS-BROWSER::METHOD))))
+        (UNLESS CLOS-BROWSER::METHOD-DEFINITION
+            (FORMAT T "The definition for ~A is not loaded" (CLOS::FULL-METHOD-NAME 
+                                                                   CLOS-BROWSER::METHOD NIL))
+            (RETURN-FROM CLOS-BROWSER::COPY NIL))
+        (IF CLOS-BROWSER::FROM-CLASS
+
+            (IL:* IL:|;;| "method should be specialized on from-class.")
+
+            (UNLESS (MEMBER CLOS-BROWSER::FROM-CLASS CLOS-BROWSER::NON-T-CLASSES)
+                (ERROR "The ~A method is not specialized on the ~A class" (CLOS::FULL-METHOD-NAME
+                                                                           CLOS-BROWSER::METHOD NIL)
+                       (CLASS-NAME CLOS-BROWSER::FROM-CLASS)))
+
+            (IL:* IL:|;;| "otherwise see if we can deduce FROM-CLASS ")
+
+            (CASE (LENGTH CLOS-BROWSER::NON-T-CLASSES)
+                (0 (FORMAT T "Unspecialized methods cannot be copied. ~A" (CLOS::FULL-METHOD-NAME
+                                                                           CLOS-BROWSER::METHOD NIL)))
+                (1 (SETQ CLOS-BROWSER::FROM-CLASS (CAR CLOS-BROWSER::NON-T-CLASSES)))
+                (OTHERWISE (SETQ CLOS-BROWSER::FROM-CLASS (CLOS::SYMBOL-CLASS
+                                                           (IL:PROMPTFORWORD (FORMAT NIL 
+                                                        "Which class in ~A do you wish to move from?"
+                                                                                    (
+                                                                               CLOS::FULL-METHOD-NAME
+                                                                                     
+                                                                                 CLOS-BROWSER::METHOD
+                                                                                     NIL))))))))
+
+        (IL:* IL:|;;| "should contain from-class.  If it is not the same, abort.")
+
+        (CLOS-BROWSER::REPLACE-SPECIALIZERS CLOS-BROWSER::METHOD-DEFINITION (CLASS-NAME 
+                                                                             CLOS-BROWSER::FROM-CLASS
+                                                                                       )
+               (CLASS-NAME CLOS-BROWSER::TO-CLASS))
+        (PRINT (EVAL CLOS-BROWSER::METHOD-DEFINITION))))
+
+(DEFMETHOD CLOS-BROWSER::MOVE ((CLOS-BROWSER::METHOD STANDARD-METHOD)
+                                   (CLOS-BROWSER::TO-CLASS STANDARD-CLASS)
+                                   &OPTIONAL CLOS-BROWSER::FROM-CLASS)
+   (WHEN (EQ CLOS-BROWSER::TO-CLASS CLOS-BROWSER::FROM-CLASS)
+         (RETURN-FROM CLOS-BROWSER::MOVE))
+   (IF (CLOS-BROWSER::COPY CLOS-BROWSER::METHOD CLOS-BROWSER::TO-CLASS CLOS-BROWSER::FROM-CLASS)
+       (CLOS-BROWSER::DELETE-METHOD CLOS-BROWSER::METHOD)
+       (FORMAT T "copy of ~A to ~A failed" (XCL:IGNORE-ERRORS (CLOS::FULL-METHOD-NAME 
+                                                                     CLOS-BROWSER::METHOD))
+              (XCL:IGNORE-ERRORS (CLASS-NAME CLOS-BROWSER::TO-CLASS)))))
+
+(DEFMETHOD CLOS-BROWSER::PRINT-DEFINITION ((CLOS-BROWSER::SELF STANDARD-METHOD))
+   (PPRINT (IL:GETDEF (CLOS::FULL-METHOD-NAME CLOS-BROWSER::SELF)
+                  'CLOS-BROWSER::METHODS)))
+
+(DEFMETHOD CLOS-BROWSER::DESCRIBE-METHOD ((CLOS-BROWSER::METHOD CLOS::METHOD))
+   (CLOS::DESCRIBE-OBJECT CLOS-BROWSER::METHOD *TRACE-OUTPUT*))
+
+(DEFMETHOD CLOS-BROWSER::RENAME ((CLOS-BROWSER::METHOD STANDARD-METHOD)
+                                     &OPTIONAL CLOS-BROWSER::NEW-NAME)
+   (UNLESS CLOS-BROWSER::NEW-NAME
+       (SETQ CLOS-BROWSER::NEW-NAME (READ (MAKE-STRING-INPUT-STREAM (IL:PROMPTFORWORD
+                                                                     (FORMAT NIL "~%New name for ~A"
+                                                                            (CLOS::FULL-METHOD-NAME
+                                                                             CLOS-BROWSER::METHOD))))
+                                          )))
+   (LET ((CLOS-BROWSER::METHOD-DEFINITION (XCL:IGNORE-ERRORS (IL:GETDEF CLOS-BROWSER::METHOD))))
+        (UNLESS CLOS-BROWSER::METHOD-DEFINITION
+            (FORMAT T "The definition for ~A is not loaded" (CLOS::FULL-METHOD-NAME 
+                                                                   CLOS-BROWSER::METHOD NIL))
+            (RETURN-FROM CLOS-BROWSER::RENAME NIL))
+        (IF (AND (SETF (SECOND CLOS-BROWSER::METHOD-DEFINITION)
+                       CLOS-BROWSER::NEW-NAME)
+                 (PRINT (EVAL CLOS-BROWSER::METHOD-DEFINITION)))
+            (DELETE CLOS-BROWSER::METHOD)
+            (FORMAT T "~%Rename of ~A to ~A failed" (XCL:IGNORE-ERRORS (CLOS::FULL-METHOD-NAME 
+                                                                              CLOS-BROWSER::METHOD))
+                   CLOS-BROWSER::NEW-NAME))))
+
+(DEFMETHOD CLOS-BROWSER::UPDATE-CACHED-MENUES ((CLOS-BROWSER::METHOD STANDARD-METHOD)
+                                                   &OPTIONAL
+                                                   (CLOS-BROWSER::CACHE-SWITCH (SLOT-VALUE
+                                                                                
+                                                                               CLOS-BROWSER:CLOS-ICON
+                                                                                
+                                                                                '
+                                                                      CLOS-BROWSER::MENU-CACHE-SWITCH
+                                                                                )))
+   "set cached menues for this method's class to nil"
+   (LET
+    ((CLOS-BROWSER::ORIGINALCURSOR (IL:CURSOR)))
+    (UNWIND-PROTECT
+        (PROGN (IL:SETCURSOR IL:WAITINGCURSOR)
+               (DOLIST (CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 
+                                                     'CLOS-BROWSER::CLASS-BROWSERS))
+                   (DOLIST (CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::METHOD 'CLOS::SPECIALIZERS)
+                                  )
+
+                       (IL:* IL:|;;| 
+    "fix bug in the inconsistent way CLOS objects store T class specializers and do method lookup.")
+
+                       (WHEN (EQ CLOS-BROWSER::CLASS T)
+                           (SETQ CLOS-BROWSER::CLASS (CLOS::SYMBOL-CLASS T)))
+                       (LET ((CLOS-BROWSER::NODE (CLOS-BROWSER::BROWSER-CONTAINS-P 
+                                                        CLOS-BROWSER::CLASS CLOS-BROWSER::BROWSER)))
+                            (WHEN CLOS-BROWSER::NODE
+                                (CASE CLOS-BROWSER::CACHE-SWITCH
+                                    (:LAZY 
+                                       (CLOS-BROWSER::UNCACHE CLOS-BROWSER::NODE)
+                                       (CLOS-BROWSER::UNCACHE CLOS-BROWSER::NODE :ALL)
+                                       (DOLIST (CLOS-BROWSER::SUB-CLASS (CLOS-BROWSER::SUBCLASSES-OF
+                                                                         (SLOT-VALUE 
+                                                                                CLOS-BROWSER::NODE
+                                                                                'CLOS-BROWSER::CLASS)
+                                                                         ))
+                                           (WHEN (SETQ CLOS-BROWSER::NODE (CLOS-BROWSER::CONTAINS-P
+                                                                           CLOS-BROWSER::SUB-CLASS 
+                                                                           CLOS-BROWSER::BROWSER))
+                                               (CLOS-BROWSER::UNCACHE CLOS-BROWSER::NODE :INHERITED)
+                                               (CLOS-BROWSER::UNCACHE CLOS-BROWSER::NODE :ALL))))
+                                    (:EAGER (PRINT ":eager method menu cacheing not yet implemented."
+                                                   ))
+                                    (OTHERWISE 
+                                       NIL                   (IL:* IL:\; "do nothing")
+                                       )))))))
+        (IL:SETCURSOR CLOS-BROWSER::ORIGINALCURSOR))))
+
+(DEFMETHOD CLOS-BROWSER::WHO-OWNS ((CLOS-BROWSER::METHOD STANDARD-METHOD))
+   (PRINT (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD)))
+
+(DEFMETHOD ADD-METHOD :AFTER
+   ((CLOS-BROWSER::GENERIC-FUNCTION STANDARD-GENERIC-FUNCTION)
+    (CLOS-BROWSER::METHOD STANDARD-METHOD))
+   "Update cached menues."
+   (LET (CLOS-BROWSER::CACHE-SWITCH)
+        (WHEN (AND CLOS-BROWSER::METHOD (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 
+                                               'CLOS-BROWSER::CLASS-BROWSERS)
+                                                             (IL:* IL:\; "there are some browsers")
+                   (NOT (EQ (SETQ CLOS-BROWSER::CACHE-SWITCH (SLOT-VALUE CLOS-BROWSER:CLOS-ICON
+                                                                    'CLOS-BROWSER::MENU-CACHE-SWITCH)
+                                  )
+                            :NONE))                          (IL:* IL:\; 
+                                                           "we want auto cache updating")
+                   )
+              (CLOS-BROWSER::UPDATE-CACHED-MENUES CLOS-BROWSER::METHOD CLOS-BROWSER::CACHE-SWITCH))
+        CLOS-BROWSER::GENERIC-FUNCTION))
+
+(DEFUN CLOS-BROWSER::REPLACE-SPECIALIZERS (CLOS-BROWSER::METHOD-DEFINITION 
+                                                     CLOS-BROWSER::FROM-CLASS-NAME 
+                                                     CLOS-BROWSER::TO-CLASS-NAME &KEY 
+                                                     CLOS-BROWSER::IN-LAMDA-LIST-ONLY-FLAG)
+   (NSUBST CLOS-BROWSER::TO-CLASS-NAME CLOS-BROWSER::FROM-CLASS-NAME
+          (IF CLOS-BROWSER::IN-LAMDA-LIST-ONLY-FLAG
+
+              (IL:* IL:|;;| "get the lamba list")
+
+              (THIRD (MULTIPLE-VALUE-LIST (CLOS::PARSE-DEFMETHOD (CDR CLOS-BROWSER::METHOD-DEFINITION
+                                                                      ))))
+                                                             (IL:* IL:\; "note this gets argument names as well as specializers.  Usually not what you want.  Needs to be made smarter to just get specializers.")
+
+              (IL:* IL:|;;| "otherwise do the whole method")
+
+              CLOS-BROWSER::METHOD-DEFINITION)))
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;;| "SETUP RELEASE INFO")
+
+
+(IL:RPAQ CLOS-BROWSER::RELEASE-ID "0.02")
+
+(IL:RPAQ CLOS-BROWSER::SYSTEM-DATE (CAAR (IL:GETPROP 'IL:CLOS-BROWSER 'IL:FILEDATES)))
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;| "SETUP BACKGROUND MENU")
+
+
+(DEFUN CLOS-BROWSER::IN-SELECT-PACKAGE ()
+   "pops up a menu of packages"                     (IL:* IL:\; "Edited 18-Mar-87 13:13 by smL")
+                                                             (IL:* IL:\; "")
+
+   (IL:* IL:|;;| "kirk: 16Mar88 modified for clos-browser")
+
+   (LET ((PACKAGE (IL:MENU
+                   (IL:|create|
+                    IL:MENU
+                    IL:TITLE IL:_ "Select package"
+                    IL:ITEMS IL:_
+                    (IL:SORT (IL:|for| PACKAGE IL:|in| (LIST-ALL-PACKAGES) IL:|bind|
+                                                                                   IL:PACKAGE-NAME
+                                IL:|collect| (IL:SETQ IL:PACKAGE-NAME (PACKAGE-NAME PACKAGE))
+                                      `(,(IL:CONCAT (OR (CAR (PACKAGE-NICKNAMES PACKAGE))
+                                                        IL:PACKAGE-NAME)
+                                                ":")
+                                        ',IL:PACKAGE-NAME
+                                        ,(IL:CONCAT "Set the current package to " IL:PACKAGE-NAME ":"
+                                                )))
+                           (IL:FUNCTION (IL:LAMBDA (IL:X IL:Y)
+                                          (IL:ALPHORDER (CAR IL:X)
+                                                 (CAR IL:Y)))))
+                    IL:CENTERFLG IL:_ T))))
+        (IL:|if| PACKAGE
+            IL:|then| (IN-PACKAGE PACKAGE))))
+
+(DEFUN CLOS-BROWSER::CLASSES-IN-PACKAGE (PACKAGE &OPTIONAL CLOS-BROWSER::MAP-ON-PACKAGE)
+   "Retrieves a list of all the classes for a given package.  When map-on-package is t this can be very slow."
+
+   (IL:* IL:|;;| "The maphash is always fast, whereas for some strange reason map-on-package varys among packages greatly.")
+
+   (LET ((CLOS-BROWSER::CLASSES))
+        (UNLESS (TYPEP PACKAGE 'PACKAGE)
+            (SETQ PACKAGE (FIND-PACKAGE PACKAGE)))
+        (IF CLOS-BROWSER::MAP-ON-PACKAGE
+            (DO-SYMBOLS (CLOS-BROWSER::SYM PACKAGE)
+                   (IF (AND (EQ (SYMBOL-PACKAGE CLOS-BROWSER::SYM)
+                                PACKAGE)
+                            (CLOS::SYMBOL-CLASS CLOS-BROWSER::SYM T))
+                       (PUSH CLOS-BROWSER::SYM CLOS-BROWSER::CLASSES)))
+            (MAPHASH #'(LAMBDA (CLOS-BROWSER::KEY CLOS-BROWSER::VAL)
+                              (IF (EQ (SYMBOL-PACKAGE CLOS-BROWSER::KEY)
+                                      PACKAGE)
+                                  (PUSH CLOS-BROWSER::KEY CLOS-BROWSER::CLASSES)))
+                   CLOS::*FIND-CLASS*))
+        CLOS-BROWSER::CLASSES))
+
+
+(IL:* IL:|;;| "pushnew should eliminate this")
+
+
+(SETQ IL:|BackgroundMenuCommands| (REMOVE 'IL:|BrowseClass| IL:|BackgroundMenuCommands| :KEY
+                                         #'CAR))
+
+(PUSH '(IL:|BrowseClass| (CLOS-BROWSER:BROWSE-CLASS)
+              "Bring up a class browser."
+              (IL:SUBITEMS (IL:|all in a package| (CLOS-BROWSER:BROWSE-CLASS (
+                                                                   CLOS-BROWSER::CLASSES-IN-PACKAGE
+                                                                                  (
+                                                                    CLOS-BROWSER::IN-SELECT-PACKAGE
+                                                                                   )))
+                                  
+                               "Select a package and browse all the classes defined in that package."
+                                  )))
+      IL:|BackgroundMenuCommands|)
+
+(SETQ IL:|BackgroundMenu| NIL)
+(IL:PUTPROPS IL:NEW-CLOS-BROWSER IL:COPYRIGHT ("Venue" 1991))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/clos/2.0/WEB-EDITOR b/clos/2.0/WEB-EDITOR
new file mode 100644
index 00000000..581d6cf7
--- /dev/null
+++ b/clos/2.0/WEB-EDITOR
@@ -0,0 +1,2338 @@
+(DEFINE-FILE-INFO PACKAGE (LET ((*PACKAGE*)) (* ;; 
+"Put IN Seven EXtremely Random USEr Interface COmmands ") (CLPROVIDE "WEB-EDITOR") (CLIN-PACKAGE 
+"WEB" NICKNAMES (QUOTE ("WEB-EDITOR"))) (* ;; "EXPORT") (CLFLET ((XCL-USEREXPORT-FROM-WEB (&REST 
+XCL-USERSYMBOL-NAMES) (LET ((XCL-USERPKG (CLFIND-PACKAGE "WEB"))) (CLDOLIST (XCL-USERNAME 
+XCL-USERSYMBOL-NAMES) (EXPORT (CLINTERN XCL-USERNAME XCL-USERPKG) XCL-USERPKG))))) (* ;; 
+"Class Definitions and Slot Access") (XCL-USEREXPORT-FROM-WEB "WEB-EDITOR" "WEB-NODE" "NODE-NAME" 
+"NODE-LINKS" "NODE-BACK-LINKS" "LOCAL-COMMANDS" "NODE-MOVER-P" "TITLE-ITEMS" "LEFT-BUTTON-ITEMS" 
+"MIDDLE-BUTTON-ITEMS" "RIGHT-BUTTON-ITEMS" "BROWSE-FONT") (* ;; "For Subclassing") (XCL-USEREXPORT-FROM-WEB
+ "GET-LABEL" "GET-SUBS" "ICON-TITLE" "NODE-MENU-ITEMS" "REORDER-TREE" "MOVE-NODE") (* ;; "Top Level") 
+(XCL-USEREXPORT-FROM-WEB "MAKE-WEB-EDITOR" "INITIALIZE-EDITOR" "BROWSE" "DISPLAY-BROWSER" "DESTROY" 
+"ADD-NODE" "NOTICE-NODE" "REMOVE-NODE" "RENAME-NODE") (* ;; "Window Operations") (XCL-USEREXPORT-FROM-WEB
+ "SHRINK" "MOVE" "CLEAR" "PROMPT-PRINT" "PROMPT-READ" "PROMPT-FOR-LIST" "PROMPT-FOR-STRING" 
+"PROMPT-FOR-WORD") (* ;; "Recomputing and Changing parameters") (XCL-USEREXPORT-FROM-WEB "RECOMPUTE"
+ "RECOMPUTE-IN-PLACE" "RECOMPUTE-LABELS" "RECOMPUTE-IF-OPEN" "CLEAR-LABEL-CACHE" "CHANGE-FONT-SIZE" 
+"CHANGE-FORMAT" "SHAPE-TO-HOLD") (* ;; "For CLOS-BROWSER???") (XCL-USEREXPORT-FROM-WEB "BOXED-NODE" 
+"BOX-NODE")) (* ;; "USE") (CLUSE-PACKAGE (QUOTE ("CLOS" "LISP" "XCL")) "WEB") (* ;; "IMPORT") (CLFLET
+ ((XCL-USERIMPORT-FROM-PACKAGE (XCL-USERNAMES XCL-USERFROM &OPTIONAL XCL-USERSHADOW-P) (LET ((
+XCL-USERFROM-PACKAGE (CLFIND-PACKAGE XCL-USERFROM))) (CLFUNCALL (CLIF XCL-USERSHADOW-P (
+CLFUNCTION CLSHADOWING-IMPORT) (CLFUNCTION IMPORT)) (CLMAPCAR (CLFUNCTION (CLLAMBDA (XCL-USERNAME
+) (CLINTERN XCL-USERNAME XCL-USERFROM-PACKAGE))) XCL-USERNAMES))))) (XCL-USERIMPORT-FROM-PACKAGE
+ (QUOTE ("CLASSES" "METHODS")) "CLOS") (XCL-USERIMPORT-FROM-PACKAGE (QUOTE ("FALSE")) "XCL") (
+XCL-USERIMPORT-FROM-PACKAGE (QUOTE ("FUNCTIONS" "FNS" "VARIABLES" "VARS" "BITMAPS" "COMS")) "IL")) (
+CLFIND-PACKAGE "WEB")) READTABLE "XCL" BASE 10)
+(IL:FILECREATED " 5-Nov-91 08:07:23" 
+IL:|{DSK}<usr>local>users>welch>lisp>clos>browser>WEB-EDITOR.;8| 132667 
+
+      IL:|changes| IL:|to:|  (IL:TYPES WEB-NODE WEB-EDITOR)
+
+      IL:|previous| IL:|date:| "30-Sep-91 23:36:34" 
+IL:|{DSK}<usr>local>users>welch>lisp>clos>browser>WEB-EDITOR.;6|)
+
+
+; Copyright (c) 1987, 1988, 1989, 1991 by Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:WEB-EDITORCOMS)
+
+(IL:RPAQQ IL:WEB-EDITORCOMS ((COMS IL:* FILE-HEADER-COMS)
+                                 
+                                 (IL:* IL:|;;| "")
+
+                                 
+
+(IL:* IL:|;;;| "WEB EDITOR ")
+
+                                 
+                                 (IL:* IL:|;;| "")
+
+                                 
+                                 (IL:* IL:|;;| "Package Setup")
+
+                                 (IL:DECLARE\: IL:DONTCOPY (IL:PROPS (IL:WEB-EDITOR 
+                                                                            IL:MAKEFILE-ENVIRONMENT)
+                                                                  (IL:WEB-EDITOR IL:FILETYPE)))
+                                 
+                                 (IL:* IL:|;;| "Global Variables")
+
+                                 
+                                 (IL:* IL:|;;| "global for cross-editor boxed node destination (like caret for current tty process copy and move destinations)")
+
+                                 (VARIABLES DESTINATION-BROWSER)
+                                 (COMS                       (IL:* IL:\; "Client Interface")
+                                       
+                                       (IL:* IL:|;;| "Web Node Class")
+
+                                       (CLASSES WEB-NODE)
+                                       
+                                       (IL:* IL:|;;| " Web Editor  Class")
+
+                                       (CLASSES WEB-EDITOR)
+                                       
+                                       (IL:* IL:|;;| "Top Level")
+
+                                       (FUNCTIONS MAKE-WEB-EDITOR)
+                                       (METHODS (INITIALIZE-EDITOR (WEB-EDITOR))
+                                              (DESTROY (WEB-EDITOR))
+                                              (BROWSE (WEB-EDITOR)))
+                                       (METHODS 
+
+                                              (IL:* IL:|;;| "For Subclassing")
+
+                                              (GET-LABEL (WEB-EDITOR WEB-NODE))
+                                              (GET-SUBS (WEB-EDITOR WEB-NODE))
+                                              (ICON-TITLE (WEB-EDITOR))
+                                              
+                                              (IL:* IL:|;;| "Adding, Removing, Hiding Nodes.")
+
+                                              (ADD-NODE (WEB-EDITOR WEB-NODE))
+                                              (NOTICE-NODE (WEB-EDITOR WEB-NODE WEB-NODE))
+                                              (REMOVE-NODE (WEB-EDITOR WEB-NODE))
+                                              (DELETE-FROM-BROWSER (WEB-EDITOR))
+                                              (REMOVE-FROM-BAD-LIST (WEB-EDITOR))
+                                              
+                                              (IL:* IL:|;;| "")
+
+                                              (RENAME-NODE (WEB-EDITOR WEB-NODE)))
+                                                             (IL:* IL:\; ""))
+                                 (COMS                       (IL:* IL:\; "Window System Interface")
+                                       (METHODS (UPDATE (WEB-EDITOR))
+                                              (CREATE-WINDOW (WEB-EDITOR))
+                                              (SETUP-WINDOW (WEB-EDITOR))
+                                              (DETACH-LISP-WINDOW (WEB-EDITOR))
+                                              (SHRINK (WEB-EDITOR))
+                                              (SET-OUTER-REGION (WEB-EDITOR))
+                                              (SET-REGION (WEB-EDITOR))
+                                              (MOVE (WEB-EDITOR))
+                                              (MOVE1 (WEB-EDITOR))
+                                              (AFTER-MOVE (WEB-EDITOR))
+                                              (AFTER-RESHAPE (WEB-EDITOR))
+                                              (SCROLL-WINDOW (WEB-EDITOR))
+                                              (CLEAR (WEB-EDITOR))
+                                              
+                                              (IL:* IL:|;;| "Prompt Window Interactions ")
+
+                                              (GET-PROMPT-WINDOW (WEB-EDITOR))
+                                              (REMOVE-PROMPT-WINDOW (WEB-EDITOR))
+                                              (PROMPT-PRINT (WEB-EDITOR))
+                                              (PROMPT-READ (WEB-EDITOR))
+                                              (PROMPT-FOR-LIST (WEB-EDITOR))
+                                              (PROMPT-FOR-STRING (WEB-EDITOR))
+                                              (PROMPT-FOR-WORD (WEB-EDITOR)))
+                                       (FUNCTIONS MOVE-DOWN-P)
+                                       (FNS WEB-WINDOW-AFTER-MOVE-FN WEB-WINDOW-BUTTON-EVENT-FN 
+                                            WEB-WINDOW-RESHAPE-FN WEB-WINDOW-CLOSE-FN IL:|PromptRead|
+                                            )
+                                       (FNS WEB-WINDOW-EXPAND-FN)
+                                       (FUNCTIONS WEB-WINDOW-ICON-FN)
+                                       (BITMAPS *WEB-EDITOR-ICON-BM* *WEB-EDITOR-ICON-MASK*)
+                                       (VARIABLES *WEB-EDITOR-TEMPLATE*)
+                                       (VARS (IL:*D-WINDOW-DEFAULT-STREAM* IL:PROMPTWINDOW)
+                                             (WEB-STREAM IL:PROMPTWINDOW)))
+                                 (COMS                       (IL:* IL:\; 
+                                                           "Layout and Display Engine")
+                                       (VARS IL:|BrowserMargin| IL:|MaxLatticeHeight| 
+                                             IL:|MaxLatticeWidth|)
+                                       (IL:SPECVARS IL:|MaxLatticeHeight| IL:|MaxLatticeWidth|)
+                                       (VARS IL:GRAYSHADE1 IL:GRAYSHADE2 IL:GRAYSHADE3 IL:GRAYSHADE4)
+                                       (FNS TREE-ROOTS CHILD-NODES REACHABLE-NODES!)
+                                       (METHODS (DISPLAY-BROWSER (WEB-EDITOR))
+                                              (BROWSER-OBJECTS (WEB-EDITOR))
+                                              (GET-NODE-LIST (WEB-EDITOR))
+                                              (OBJ-NAME-PAIR (WEB-EDITOR))
+                                              (GRAPH-FITS (WEB-EDITOR))
+                                              (NODE-REGION (WEB-EDITOR))
+                                                             (IL:* IL:\; "")
+                                              (RECOMPUTE (WEB-EDITOR))
+                                              (RECOMPUTE-IN-PLACE (WEB-EDITOR))
+                                              (RECOMPUTE-LABELS (WEB-EDITOR))
+                                              (RECOMPUTE-IF-OPEN (WEB-EDITOR))
+                                              (CLEAR-LABEL-CACHE (WEB-EDITOR))
+                                              (OBJECT-FROM-LABEL (WEB-EDITOR))
+                                              (CHANGE-FONT-SIZE (WEB-EDITOR))
+                                              (CHANGE-FORMAT (WEB-EDITOR))
+                                              (CHANGE-MAX-LABEL-SIZE (WEB-EDITOR))
+                                              (SHAPE-TO-HOLD (WEB-EDITOR))
+                                                             (IL:* IL:\; "")
+                                                             (IL:* IL:\; 
+                                                           "Node Marking and Selecting")
+                                              (GET-DISPLAY-LABEL (WEB-EDITOR))
+                                              (BOX-NODE (WEB-EDITOR))
+                                              (UNMARK-NODES (WEB-EDITOR))
+                                              (HIGHLIGHT-NODE (WEB-EDITOR))
+                                              (SHADE-NODE (WEB-EDITOR))
+                                              (DISPLAY-NODE-HIGHTLIGHTS (WEB-EDITOR))
+                                              (DISPLAY-NODE-SHADING (WEB-EDITOR))
+                                              (REMOVE-HIGHLIGHTS (WEB-EDITOR))
+                                              (REMOVE-SHADING (WEB-EDITOR))
+                                              (FLASH-NODE (WEB-EDITOR))
+                                              (FLIP-NODE (WEB-EDITOR))
+                                              (POSITION-NODE (WEB-EDITOR)))
+                                       (FNS BOX-PRINT-STRING BREAK-STRING-FOR-BOXING BOX-WINDOW-NODE)
+                                       )
+                                 (COMS                       (IL:* IL:\; "Button Events")
+                                       (FNS FIND-SELECTED-NODE)
+                                       (METHODS (BUTTON-EVENT-FN (WEB-EDITOR))
+                                              (LEFT-SELECTION (WEB-EDITOR))
+                                              (MIDDLE-SELECTION (WEB-EDITOR))
+                                              (RIGHT-SELECTION (WEB-EDITOR))
+                                              (TITLE-SELECTION (WEB-EDITOR))
+                                              (NODE-SELECTION (WEB-EDITOR))
+                                              (NODE-ACTION (WEB-EDITOR))
+                                              (NODE-MENU-ITEMS (WEB-NODE))
+                                              
+                                              (IL:* IL:|;;| "")
+
+                                              (CHOICE-MENU (WEB-EDITOR))
+                                              (DO-SELECTED-COMMAND (WEB-EDITOR))
+                                              (WHEN-MENU-ITEM-HELD (WEB-EDITOR))
+                                              (ITEM-MENU (WEB-EDITOR))
+                                              (GET-MENU-ITEMS (WEB-EDITOR))
+                                              (CLEAR-MENU-CACHE (WEB-EDITOR)))
+                                       (FNS WEB-MENU-WHENSELECTEDFN WINDOW-WHEN-HELD-FN)
+                                       (FNS SUB-ITEM-SELECTION DUAL-SUB-ITEMS WINDOW-WHEN-HELD-FN 
+                                            DO-MENU-METHOD DUAL-MENU DUAL-SELECTION)
+                                                             (IL:* IL:\; "Node Moving Protocol")
+                                       (METHODS (NODE-MOVE (WEB-EDITOR))
+                                              (NODE-MOVE-SHALLOW (WEB-EDITOR))
+                                              (SCIONS (WEB-NODE))
+                                              (MAKE-REG-ASSOC (WEB-EDITOR))
+                                              (REORDER-TREE (WEB-EDITOR))
+                                              (MOVE-NODE (WEB-NODE))))
+                                                             (IL:* IL:\; "")
+                                 
+                                 (IL:* IL:|;;| "")
+
+                                 (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY 
+                                        IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA)
+                                                               (IL:NLAML)
+                                                               (IL:LAMA WINDOW-WHEN-HELD-FN 
+                                                                      WINDOW-WHEN-HELD-FN)))))
+
+(IL:RPAQQ FILE-HEADER-COMS ((IL:P (FORMAT T 
+                       "~&;WEB-EDITOR Copyright (c) 1987, VENUE Corporation.  All rights reserved.~%"
+                                             )
+                                      (PROVIDE "WEB-EDITOR"))))
+
+(FORMAT T "~&;WEB-EDITOR Copyright (c) 1987, VENUE Corporation.  All rights reserved.~%")
+
+(PROVIDE "WEB-EDITOR")
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;;| "WEB EDITOR ")
+
+
+
+
+(IL:* IL:|;;| "")
+
+
+
+
+(IL:* IL:|;;| "Package Setup")
+
+(IL:DECLARE\: IL:DONTCOPY 
+
+(IL:PUTPROPS IL:WEB-EDITOR IL:MAKEFILE-ENVIRONMENT 
+             (:PACKAGE (LET ((*PACKAGE*))
+                            
+                            (IL:* IL:|;;| "Put IN Seven EXtremely Random USEr Interface COmmands ")
+
+                            (PROVIDE "WEB-EDITOR")
+                            (IN-PACKAGE "WEB" :NICKNAMES '("WEB-EDITOR"))
+                            
+                            (IL:* IL:|;;| "EXPORT")
+
+                            (FLET ((XCL-USER::EXPORT-FROM-WEB (&REST XCL-USER::SYMBOL-NAMES)
+                                          (LET ((XCL-USER::PKG (FIND-PACKAGE "WEB")))
+                                               (DOLIST (XCL-USER::NAME XCL-USER::SYMBOL-NAMES)
+                                                   (EXPORT (INTERN XCL-USER::NAME XCL-USER::PKG)
+                                                          XCL-USER::PKG)))))
+                                  
+                                  (IL:* IL:|;;| "Class Definitions and Slot Access")
+
+                                  (XCL-USER::EXPORT-FROM-WEB "WEB-EDITOR" "WEB-NODE" "NODE-NAME" 
+                                         "NODE-LINKS" "NODE-BACK-LINKS" "LOCAL-COMMANDS" 
+                                         "NODE-MOVER-P" "TITLE-ITEMS" "LEFT-BUTTON-ITEMS" 
+                                         "MIDDLE-BUTTON-ITEMS" "RIGHT-BUTTON-ITEMS" "BROWSE-FONT")
+                                  
+                                  (IL:* IL:|;;| "For Subclassing")
+
+                                  (XCL-USER::EXPORT-FROM-WEB "GET-LABEL" "GET-SUBS" "ICON-TITLE" 
+                                         "NODE-MENU-ITEMS" "REORDER-TREE" "MOVE-NODE")
+                                  
+                                  (IL:* IL:|;;| "Top Level")
+
+                                  (XCL-USER::EXPORT-FROM-WEB "MAKE-WEB-EDITOR" "INITIALIZE-EDITOR" 
+                                         "BROWSE" "DISPLAY-BROWSER" "DESTROY" "ADD-NODE" 
+                                         "NOTICE-NODE" "REMOVE-NODE" "RENAME-NODE")
+                                  
+                                  (IL:* IL:|;;| "Window Operations")
+
+                                  (XCL-USER::EXPORT-FROM-WEB "SHRINK" "MOVE" "CLEAR" "PROMPT-PRINT" 
+                                         "PROMPT-READ" "PROMPT-FOR-LIST" "PROMPT-FOR-STRING" 
+                                         "PROMPT-FOR-WORD")
+                                  
+                                  (IL:* IL:|;;| "Recomputing and Changing parameters")
+
+                                  (XCL-USER::EXPORT-FROM-WEB "RECOMPUTE" "RECOMPUTE-IN-PLACE" 
+                                         "RECOMPUTE-LABELS" "RECOMPUTE-IF-OPEN" "CLEAR-LABEL-CACHE" 
+                                         "CHANGE-FONT-SIZE" "CHANGE-FORMAT" "SHAPE-TO-HOLD")
+                                  
+                                  (IL:* IL:|;;| "For CLOS-BROWSER???")
+
+                                  (XCL-USER::EXPORT-FROM-WEB "BOXED-NODE" "BOX-NODE"))
+                            
+                            (IL:* IL:|;;| "USE")
+
+                            (USE-PACKAGE '("CLOS" "LISP" "XCL")
+                                   "WEB")
+                            
+                            (IL:* IL:|;;| "IMPORT")
+
+                            (FLET ((XCL-USER::IMPORT-FROM-PACKAGE
+                                    (XCL-USER::NAMES XCL-USER::FROM &OPTIONAL XCL-USER::SHADOW-P)
+                                    (LET ((XCL-USER::FROM-PACKAGE (FIND-PACKAGE XCL-USER::FROM)))
+                                         (FUNCALL (IF XCL-USER::SHADOW-P
+                                                      #'SHADOWING-IMPORT
+                                                      #'IMPORT)
+                                                (MAPCAR #'(LAMBDA (XCL-USER::NAME)
+                                                                 (INTERN XCL-USER::NAME 
+                                                                        XCL-USER::FROM-PACKAGE))
+                                                       XCL-USER::NAMES)))))
+                                  (XCL-USER::IMPORT-FROM-PACKAGE '("CLASSES" "METHODS")
+                                         "CLOS")
+                                  (XCL-USER::IMPORT-FROM-PACKAGE '("FALSE")
+                                         "XCL")
+                                  (XCL-USER::IMPORT-FROM-PACKAGE '("FUNCTIONS" "FNS" "VARIABLES" 
+                                                                         "VARS" "BITMAPS" "COMS")
+                                         "IL"))
+                            (FIND-PACKAGE "WEB"))
+                    :READTABLE "XCL" :BASE 10))
+
+(IL:PUTPROPS IL:WEB-EDITOR IL:FILETYPE :COMPILE-FILE)
+)
+
+
+
+(IL:* IL:|;;| "Global Variables")
+
+
+
+
+(IL:* IL:|;;| 
+"global for cross-editor boxed node destination (like caret for current tty process copy and move destinations)"
+)
+
+
+(DEFGLOBALPARAMETER DESTINATION-BROWSER NIL
+   "global for cross-editor boxed node destination (like caret for current tty process copy and move destinations)"
+)
+
+
+
+(IL:* IL:\; "Client Interface")
+
+
+
+
+(IL:* IL:|;;| "Web Node Class")
+
+
+(DEFCLASS WEB-NODE ()
+    ((NAME :INITFORM NIL                                     (IL:* IL:\; "Name of Node")
+           :ACCESSOR NODE-NAME)
+     (TO-LINKS :INITFORM NIL                                 (IL:* IL:\; 
+                                                           "Nodes that this Node has Links TO")
+            :ACCESSOR GET-TO-LINKS :ACCESSOR NODE-LINKS)
+     (PARENT :INITFORM NIL :ACCESSOR NODE-BACK-LINKS)))
+
+
+
+(IL:* IL:|;;| " Web Editor  Class")
+
+
+(DEFCLASS WEB-EDITOR ()
+    (
+     (IL:* IL:|;;| "NODES ")
+
+     (STARTING-LIST :INITFORM NIL                            (IL:* IL:\; 
+                                                     "list of objects used to compute this browser")
+            )
+     (GOOD-LIST :INITFORM NIL                                (IL:* IL:\; 
+                                                           "limit choices to this set"))
+     (BAD-LIST :INITFORM NIL                                 (IL:* IL:\; 
+                                                           "Don't put in any items on this set")
+            )
+
+     (IL:* IL:|;;| "GRAPHER FORMAT")
+
+     (TOP-ALIGN :INITFORM NIL)
+     (BROWSE-FONT :INITFORM (IL:FONTCREATE '(IL:HELVETICA 10 IL:BOLD)))
+     (BROWSE-FONT-FAMILY :INITFORM 'IL:HELVETICA)
+     (BROWSE-FONT-FACE :INITFORM 'IL:BOLD)
+     (GRAPH-FORMAT :INITFORM '(IL:LATTICE))
+     (GRAPH-FORMAT-CHOICES :ALLOCATION :CLASS :INITFORM '((IL:HORIZONTAL/LATTICE '(IL:LATTICE))
+                                                          (IL:VERTICAL/LATTICE '(IL:VERTICAL 
+                                                                                       IL:LATTICE))
+                                                          (IL:HORIZONTAL/TREE '(IL:COPIES/ONLY))
+                                                          (IL:VERTICAL/TREE '(IL:VERTICAL 
+                                                                                    IL:COPIES/ONLY)))
+            )
+
+     (IL:* IL:|;;| "WINDOW Interface")
+
+     (WINDOW :INITFORM NIL)
+     (TITLE :INITFORM "Web Editor"                           (IL:* IL:\; 
+                                                        "If not NIL will be put in title of window")
+            )
+     (LEFT :INITFORM 0                                       (IL:* IL:\; "left position of window")
+           )
+     (BOTTOM :INITFORM 0                                     (IL:* IL:\; 
+                                                           "bottom position of window"))
+     (WIDTH :INITFORM 64)
+     (HEIGHT :INITFORM 32)
+
+     (IL:* IL:|;;| "NODE Labels")
+
+     (LABEL-CACHE :INITFORM NIL)
+     (LABEL-MAX-LINES :INITFORM NIL 
+
+            (IL:* IL:|;;| "the maximum number of lines to use in 'boxed' labels -- note that if the label wont fit within the LabelMaxLines and LabelMaxCharsWidth restrictions, it will be truncated")
+)
+     (LABEL-MAX-CHARS-WIDTH :INITFORM NIL 
+
+            (IL:* IL:|;;| "the maximum width for labels -- if label is too big, it will be 'boxed'")
+)
+     (IL:* IL:|;;| "NODE Operations")
+
+     (LAST-SELECTED-OBJECT :INITFORM NIL                     (IL:* IL:\; "last object selected"))
+     (BOXED-NODE :INITFORM NIL                               (IL:* IL:\; "last item Boxed, if any")
+            )
+     (BOX-LINE-WIDTH :ALLOCATION :CLASS 
+
+            (IL:* IL:|;;| "width to make box for BoxNode")
+
+            :INITFORM 1)
+     (NODE-MOVER-P :ALLOCATION :CLASS :INITFORM NIL)
+
+     (IL:* IL:|;;| "MENUS")
+
+     (CACHE-MENU-P :INITFORM T)
+     (MENU-CACHE :INITFORM NIL                               (IL:* IL:\; 
+                                                       "Will Cache Menus only if CACHE-MENU-P is T")
+            )
+     (LOCAL-COMMANDS :ALLOCATION :CLASS 
+
+            (IL:* IL:|;;| "messages that should be sent to browser when item seleted in menu, even if object does understand them")
+
+            :INITFORM
+            '(BOX-NODE RECOMPUTE ADD-ROOT))
+     (TITLE-ITEMS :ALLOCATION :CLASS 
+
+            (IL:* IL:|;;| "Items for menu of selections in title of window")
+
+            :INITFORM
+            '(("Recompute" RECOMPUTE "" (IL:SUBITEMS ("Recompute" RECOMPUTE 
+                                                            "Recompute lattice from starting objects"
+                                                            )
+                                               ("Recompute Labels" RECOMPUTE-LABELS 
+                                                      "Recomputes the labels")
+                                               ("Recompute In Place" RECOMPUTE-IN-PLACE 
+                                                      "Recompute keeping current view in window")))
+              ("Shape To Hold" SHAPE-TO-HOLD "Make window large or small enough to just hold graph")
+              ("Change Font Size" CHANGE-FONT-SIZE "Choose a new size Font")
+              ("Change Format" CHANGE-FORMAT "Change format between lattice and tree")))
+     (LEFT-BUTTON-ITEMS :ALLOCATION :CLASS 
+
+            (IL:* IL:|;;| "Menu items for LeftButton seletion -- Value sent as message to object or browser -- see LocalCommands")
+
+            :INITFORM
+            '(("Box Node" BOX-NODE "Draw box around selected node.
+Unboxed by another BoxNode")
+              ("Pretty Print" PP "Prettyprint selected item")))
+     (MIDDLE-BUTTON-ITEMS :ALLOCATION :CLASS 
+
+            (IL:* IL:|;;| "Menu items for MiddleButton seletion -- Value sent as message to object or browser -- see LocalCommands")
+
+            :INITFORM
+            '(("Inspect" IL:|Inspect| INSPECT "Inspect selected item")
+              ("Edit" EDIT-OBJECT "Edit selected item")
+              ("Delete From Browser" DELETE-FROM-BROWSER "Do not show item or its subs")))
+     (RIGHT-BUTTON-ITEMS :ALLOCATION :CLASS :INITFORM '(("Close" (CLOSEW (("Close" CLOSEW)
+                                                                          ("Destroy" DESTROY))))
+                                                        ("Snap" SNAP)
+                                                        ("Paint" PAINT)
+                                                        ("Clear" CLEAR)
+                                                        ("Bury" BURY)
+                                                        ("Repaint" REPAINT)
+                                                        ("Hardcopy" (HARDCOPY (("Hardcopy to File"
+                                                                                HARDCOPY-TO-FILE)
+                                                                               ("Hardcopy to Printer"
+                                                                                HARDCOPY-TO-PRINTER))
+                                                                           ))
+                                                        ("Move" MOVE)
+                                                        ("Shape" SHAPE)
+                                                        ("Shrink" SHRINK))
+                                                             (IL:* IL:\; 
+                                                     "Items to be done if Right button is selected")
+            )))
+
+
+
+(IL:* IL:|;;| "Top Level")
+
+
+(DEFUN MAKE-WEB-EDITOR ()
+   (LET ((EDITOR (MAKE-INSTANCE 'WEB-EDITOR)))
+        (INITIALIZE-EDITOR EDITOR)))
+
+(DEFMETHOD INITIALIZE-EDITOR ((SELF WEB-EDITOR))
+   (LET NIL (CREATE-WINDOW SELF)
+        SELF))
+
+(DEFMETHOD DESTROY ((SELF WEB-EDITOR))
+   (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW))
+          (ICON-WINDOW (IL:WINDOWPROP WINDOW 'IL:ICONWINDOW)))
+         (IL:CLOSEW WINDOW)
+         (IF ICON-WINDOW (IL:CLOSEW ICON-WINDOW))
+         (DETACH-LISP-WINDOW SELF)))
+
+(DEFMETHOD BROWSE ((SELF WEB-EDITOR)
+                       &OPTIONAL BROWSE-LIST WINDOW-OR-TITLE GOOD-LIST POSITION)
+                                                             (IL:* IL:\; "11-Sep-84 07:24")
+                                                             (IL:* IL:\; 
+                                         "Call Show and then shape to hold and move for first time")
+   (COND
+      ((IL:WINDOWP WINDOW-OR-TITLE)
+       (SETF (SLOT-VALUE SELF 'WINDOW)
+             WINDOW-OR-TITLE))
+      (WINDOW-OR-TITLE (SETF (SLOT-VALUE SELF 'TITLE)
+                             WINDOW-OR-TITLE)))
+   (COND
+      ((AND BROWSE-LIST (IL:NLISTP BROWSE-LIST))
+       (IL:SETQ BROWSE-LIST (LIST BROWSE-LIST))))
+   (SETF (SLOT-VALUE SELF 'STARTING-LIST)
+         BROWSE-LIST)
+   (SETF (SLOT-VALUE SELF 'GOOD-LIST)
+         GOOD-LIST)
+   (DISPLAY-BROWSER SELF)
+   (SHAPE-TO-HOLD SELF)
+   (MOVE SELF POSITION)
+   SELF)
+
+(DEFMETHOD GET-LABEL ((WEB-EDITOR WEB-EDITOR)
+                          (NODE WEB-NODE))                   (IL:* IL:\; 
+                                        "Get a label for an object to be displayed in the browser.")
+   (NODE-NAME NODE))
+
+(DEFMETHOD GET-SUBS ((EDITOR WEB-EDITOR)
+                         (NODE WEB-NODE))                    (IL:* IL:\; 
+                                                   "Gets a set of subs from an object for browsing")
+   (NODE-LINKS NODE))
+
+(DEFMETHOD ICON-TITLE ((SELF WEB-EDITOR))                (IL:* IL:\; "18-Jan-85 15:35")
+
+   (IL:* IL:|;;| "Compute the icont title for this browser")
+
+   '|Web Editor|)
+
+(DEFMETHOD ADD-NODE ((WEB-EDITOR WEB-EDITOR)
+                         (NEW-NODE WEB-NODE))                (IL:* IL:\; "11-Dec-86 10:23")
+
+   (IL:* IL:|;;| "Add a new node to the browser.")
+
+   (PUSHNEW NEW-NODE (SLOT-VALUE WEB-EDITOR 'STARTING-LIST))
+   (IF (SLOT-VALUE WEB-EDITOR 'GOOD-LIST)
+       (PUSHNEW NEW-NODE (SLOT-VALUE WEB-EDITOR 'GOOD-LIST))))
+
+(DEFMETHOD NOTICE-NODE ((WEB-EDITOR WEB-EDITOR)
+                            (WEB-NODE WEB-NODE)
+                            (PARENT-NODE WEB-NODE))
+   (PUSH WEB-NODE (SLOT-VALUE PARENT-NODE 'TO-LINKS))
+   (ADD-NODE WEB-EDITOR WEB-NODE))
+
+(DEFMETHOD REMOVE-NODE ((WEB-EDITOR WEB-EDITOR)
+                            (BYE-NODE WEB-NODE))
+   (WITH-SLOTS (STARTING-LIST GOOD-LIST BAD-LIST)
+       WEB-EDITOR
+
+     (IL:* IL:|;;| "")
+
+     (SETF STARTING-LIST (DELETE BYE-NODE STARTING-LIST))
+     (IF GOOD-LIST
+         (SETF GOOD-LIST (DELETE BYE-NODE GOOD-LIST)))
+     (IF BAD-LIST
+         (SETF BAD-LIST (DELETE BYE-NODE BAD-LIST)))
+     (SETF (NODE-LINKS (NODE-BACK-LINKS BYE-NODE))
+           (DELETE BYE-NODE (NODE-LINKS (NODE-BACK-LINKS BYE-NODE))))))
+
+(DEFMETHOD DELETE-FROM-BROWSER ((SELF WEB-EDITOR)
+                                    OBJ OBJ-NAME)            (IL:* IL:\; " 5-Aug-86 16:50")
+
+   (IL:* IL:|;;| "Place on badList for Browser")
+
+   (PUSHNEW OBJ (SLOT-VALUE SELF 'BAD-LIST))
+   (RECOMPUTE SELF))
+
+(DEFMETHOD REMOVE-FROM-BAD-LIST ((SELF WEB-EDITOR))      (IL:* IL:\; "28-Dec-85 10:04")
+                                                             (IL:* IL:\; 
+                               "Remove an item from BadList to allow it to be displayed once again")
+   (COND
+      ((NULL (SLOT-VALUE SELF 'BAD-LIST))
+       (IL:CLRPROMPT)
+       (IL:PROMPTPRINT "No BadList items."))
+      (T (PROG ((IL:|item| (IL:MENU (IL:|create| IL:MENU
+                                           IL:TITLE IL:_ "BadList Items"
+                                           IL:ITEMS IL:_ (SLOT-VALUE SELF 'BAD-LIST)))))
+               (COND
+                  (IL:|item| (SETF (SLOT-VALUE SELF 'BAD-LIST)
+                                   '(IL:DREMOVE IL:|item| (SLOT-VALUE SELF 'BAD-LIST)))
+                         (RECOMPUTE SELF))
+                  (T (IL:CLRPROMPT)
+                     (IL:PROMPTPRINT "Nothing Selected")))))))
+
+(DEFMETHOD RENAME-NODE ((WEB-EDITOR WEB-EDITOR)
+                            (WEB-NODE WEB-NODE)
+                            NEW-NAME)
+   (SETF (NODE-NAME WEB-NODE)
+         NEW-NAME)
+   (CLEAR-LABEL-CACHE WEB-EDITOR WEB-NODE))
+
+
+
+(IL:* IL:\; "")
+
+
+
+
+(IL:* IL:\; "Window System Interface")
+
+
+(DEFMETHOD UPDATE ((SELF WEB-EDITOR))                    (IL:* IL:\; "29-Sep-86 11:56")
+
+   (IL:* IL:|;;| "make the Lisp window be consistent with ivs")
+
+   (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW))
+          (REGION (AND (SLOT-VALUE SELF 'WIDTH)
+                       (SLOT-VALUE SELF 'HEIGHT)
+                       (IL:|create| IL:REGION
+                              IL:LEFT IL:_ (OR (SLOT-VALUE SELF 'LEFT)
+                                               (SETF (SLOT-VALUE SELF 'LEFT)
+                                                     IL:LASTMOUSEX))
+                              IL:BOTTOM IL:_ (OR (SLOT-VALUE SELF 'BOTTOM)
+                                                 (SETF (SLOT-VALUE SELF 'BOTTOM)
+                                                       IL:LASTMOUSEY))
+                              IL:WIDTH IL:_ (SLOT-VALUE SELF 'WIDTH)
+                              IL:HEIGHT IL:_ (SLOT-VALUE SELF 'HEIGHT)))))
+         (COND
+            ((AND REGION (NOT (IL:EQUAL REGION (IL:WINDOWPROP WINDOW 'IL:REGION))))
+                                                             (IL:* IL:\; 
+                      "The shape has changed.  --- This is complicated because of ATTACHEDWINDOWS.")
+             (LET* ((ATTACHED-WINDOWS (IL:WINDOWPROP WINDOW 'IL:ATTACHEDWINDOWS))
+                    (ATTACHMENT-SPECS (IL:|for| IL:\w IL:|in| ATTACHED-WINDOWS
+                                         IL:|collect| (LIST (IL:WINDOWPROP IL:\w 
+                                                                       'IL:DOWINDOWCOMFN)
+                                                                (IL:WINDOWPROP IL:\w 
+                                                                       'IL:WHEREATTACHED)
+                                                                (IL:WINDOWPROP IL:\w 
+                                                                       'IL:PASSTOMAINCOMS)))))
+                   (IL:|for| IL:\w IL:|in| ATTACHED-WINDOWS IL:|do| (IL:DETACHWINDOW
+                                                                                 IL:\w))
+                   (IL:SHAPEW WINDOW REGION)
+                   (IL:|for| IL:\w IL:|in| ATTACHED-WINDOWS IL:|as| IL:|spec|
+                      IL:|in| ATTACHMENT-SPECS IL:|do| (IL:ATTACHWINDOW IL:\w WINDOW
+                                                                      (CAADR IL:|spec|)
+                                                                      (CDADR IL:|spec|))
+                                                         (IL:WINDOWPROP IL:\w 'IL:DOWINDOWCOMFN
+                                                                (CAR IL:|spec|))
+                                                         (IL:WINDOWPROP IL:\w 'IL:PASSTOMAINCOMS
+                                                                (CADDR IL:|spec|))))))
+         (AND (NOT (IL:EQUAL (SLOT-VALUE SELF 'TITLE)
+                          (IL:WINDOWPROP WINDOW 'IL:TITLE)))
+              (IL:WINDOWPROP WINDOW 'IL:TITLE (SLOT-VALUE SELF 'TITLE)))))
+
+(DEFMETHOD CREATE-WINDOW ((SELF WEB-EDITOR))             (IL:* IL:\; "10-Apr-86 14:32")
+                                                             (IL:* IL:\; 
+                                        "Create the Lisp window for this window but don't open it.")
+   (LET ((WINDOW (IL:CREATEW (IL:CREATEREGION IL:LASTMOUSEX IL:LASTMOUSEY 25 25)
+                        (SLOT-VALUE SELF 'TITLE)
+                        NIL T)))
+        (SETF (SLOT-VALUE SELF 'WINDOW)
+              WINDOW)
+        (SETUP-WINDOW SELF)
+        WINDOW))
+
+(DEFMETHOD SETUP-WINDOW ((SELF WEB-EDITOR))              (IL:* IL:\; "10-Apr-86 14:32")
+                                                             (IL:* IL:\; 
+                                        "Create the Lisp window for this window but don't open it.")
+   (LET ((WINDOW (SLOT-VALUE SELF 'WINDOW)))
+        (IL:WINDOWPROP WINDOW 'WEB-EDITOR SELF)
+        (IL:WINDOWPROP WINDOW 'IL:ICONFN 'WEB-WINDOW-ICON-FN)
+        (IL:WINDOWPROP WINDOW 'IL:BUTTONEVENTFN 'WEB-WINDOW-BUTTON-EVENT-FN)
+        (IL:WINDOWADDPROP WINDOW 'IL:AFTERMOVEFN 'WEB-WINDOW-AFTER-MOVE-FN)
+        (IL:WINDOWADDPROP WINDOW 'IL:RESHAPEFN 'WEB-WINDOW-RESHAPE-FN)
+        (IL:WINDOWADDPROP WINDOW 'IL:CLOSEFN 'WEB-WINDOW-CLOSE-FN)
+        (IL:WINDOWPROP WINDOW 'IL:ICONFN 'WEB-WINDOW-ICON-FN)(IL:* IL:\; 
+                                        "window should be invert so that links etc.  can be erased")
+        (IL:DSPOPERATION 'IL:INVERT WINDOW)                  (IL:* IL:\; 
+                                           "kludge: because GRAPHER adds its own COPYBUTTONEVENTFN")
+        (IL:WINDOWPROP WINDOW 'IL:COPYBUTTONEVENTFN NIL)
+        (IL:WINDOWPROP WINDOW 'IL:TITLE (SLOT-VALUE SELF 'TITLE))
+        WINDOW))
+
+(DEFMETHOD DETACH-LISP-WINDOW ((SELF WEB-EDITOR))        (IL:* IL:\; " 8-Apr-87 17:25")
+
+(IL:* IL:|;;;| "Forget about the current lisp window")
+
+   (LET ((VAL (SLOT-VALUE SELF 'WINDOW)))
+        (IL:|if| (IL:WINDOWP VAL)
+            IL:|then| (SETF (SLOT-VALUE SELF 'WINDOW)
+                                NIL)
+                  (IL:WINDOWPROP VAL 'WEB-EDITOR NIL)
+                  (IL:WINDOWPROP VAL 'IL:RIGHTBUTTONFN NIL)
+                  (IL:WINDOWPROP VAL 'IL:BUTTONEVENTFN NIL)
+                  NIL
+          IL:|else| NIL)))
+
+(DEFMETHOD SHRINK ((SELF WEB-EDITOR)
+                       &OPTIONAL TOWHAT POS EXPANDFN)
+   (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW)))
+         (IF (IL:WINDOWP WINDOW)
+             (IL:SHRINKW WINDOW TOWHAT POS EXPANDFN))))
+
+(DEFMETHOD SET-OUTER-REGION ((SELF WEB-EDITOR)
+                                 REGION NO-UPDATE-FLG)       (IL:* IL:\; "16-Apr-86 13:21")
+
+(IL:* IL:|;;;| "Make Loops Window have region parameters")
+
+   (SETF (SLOT-VALUE SELF 'LEFT)
+         (IL:|fetch| IL:LEFT IL:|of| REGION))
+   (SETF (SLOT-VALUE SELF 'BOTTOM)
+         (IL:|fetch| IL:BOTTOM IL:|of| REGION))
+   (SETF (SLOT-VALUE SELF 'WIDTH)
+         (IL:|fetch| IL:WIDTH IL:|of| REGION))
+   (SETF (SLOT-VALUE SELF 'HEIGHT)
+         (IL:|fetch| IL:HEIGHT IL:|of| REGION))
+   (IL:|if| (NOT NO-UPDATE-FLG)
+       IL:|then| (UPDATE SELF))
+   REGION)
+
+(DEFMETHOD SET-REGION ((SELF WEB-EDITOR)
+                           REGION &OPTIONAL NO-UPDATE-FLG)   (IL:* IL:\; "16-Apr-86 13:22")
+
+(IL:* IL:|;;;| "Make Loops Window have region parameters")
+
+   (SET-OUTER-REGION SELF (IL:CREATEREGION (IL:|fetch| IL:LEFT IL:|of| REGION)
+                                 (IL:|fetch| IL:BOTTOM IL:|of| REGION)
+                                 (IL:WIDTHIFWINDOW (IL:|fetch| IL:WIDTH IL:|of| REGION)
+                                        (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW)
+                                               'IL:BORDER))
+                                 (IL:HEIGHTIFWINDOW (IL:|fetch| IL:HEIGHT IL:|of| REGION)
+                                        (SLOT-VALUE SELF 'TITLE)
+                                        (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW)
+                                               'IL:BORDER)))
+          NO-UPDATE-FLG))
+
+(DEFMETHOD MOVE ((SELF WEB-EDITOR)
+                     X-OR-POS &OPTIONAL Y)                   (IL:* IL:\; "11-Sep-86 13:24")
+
+(IL:* IL:|;;;| "Move the window")
+
+   (MOVE1 SELF (OR X-OR-POS (LET* ((ENTIRE-REGION (IL:WINDOWREGION (SLOT-VALUE SELF 'WINDOW)))
+                                   (POS (IL:GETBOXPOSITION (IL:|fetch| IL:WIDTH IL:|of|
+                                                                                    ENTIRE-REGION)
+                                               (IL:|fetch| IL:HEIGHT IL:|of| ENTIRE-REGION)
+                                               (IL:|fetch| IL:LEFT IL:|of| ENTIRE-REGION)
+                                               (IL:|fetch| IL:BOTTOM IL:|of| ENTIRE-REGION)))
+                                   )
+                                  (IL:|create| IL:POSITION
+                                         IL:XCOORD IL:_ (IL:PLUS (IL:|fetch| IL:XCOORD
+                                                                    IL:|of| POS)
+                                                               (IL:DIFFERENCE (SLOT-VALUE
+                                                                               SELF
+                                                                               'LEFT)
+                                                                      (IL:|fetch| IL:LEFT
+                                                                         IL:|of| ENTIRE-REGION)))
+                                         IL:YCOORD IL:_ (IL:PLUS (IL:|fetch| IL:YCOORD
+                                                                    IL:|of| POS)
+                                                               (IL:DIFFERENCE (SLOT-VALUE
+                                                                               SELF
+                                                                               'BOTTOM)
+                                                                      (IL:|fetch| IL:BOTTOM
+                                                                         IL:|of| ENTIRE-REGION)))
+                                         )))
+          Y))
+
+(DEFMETHOD MOVE1 ((SELF WEB-EDITOR)
+                      X-OR-POS &OPTIONAL Y)                  (IL:* IL:\; "13-Aug-86 19:10")
+
+   (IL:* IL:|;;| "Move the window")
+
+   (LET ((NEEDS-UPDATE? (NOT (IL:SUBREGIONP (IL:CONSTANT (IL:CREATEREGION 0 0 IL:SCREENWIDTH 
+                                                                IL:SCREENHEIGHT))
+                                    (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW)
+                                           'IL:REGION)))))
+        (PROG1 (IL:MOVEW (SLOT-VALUE SELF 'WINDOW)
+                      X-OR-POS Y)                            (IL:* IL:\; 
+                                      "The left and right IVs are updated by the message AfterMove")
+            (COND
+               (NEEDS-UPDATE? (UPDATE SELF))))))
+
+(DEFMETHOD AFTER-MOVE ((SELF WEB-EDITOR))                (IL:* IL:\; "10-Apr-86 16:10")
+
+(IL:* IL:|;;;| "The window has been moved.  Update the left and bottom")
+
+   (LET ((REGION (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW)
+                        'IL:REGION)))
+        (SETF (SLOT-VALUE SELF 'LEFT)
+              (IL:|fetch| IL:LEFT IL:|of| REGION))
+        (SETF (SLOT-VALUE SELF 'BOTTOM)
+              (IL:|fetch| IL:BOTTOM IL:|of| REGION))))
+
+(DEFMETHOD AFTER-RESHAPE ((SELF WEB-EDITOR)
+                              OLD-BITMAP-IMAGE OLD-REGION OLD-SCREEN-REGION)
+                                                             (IL:* IL:\; "10-Apr-86 16:12")
+
+(IL:* IL:|;;;| "The window has been reshaped")
+
+   (LET ((REGION (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW)
+                        'IL:REGION)))
+        (SETF (SLOT-VALUE SELF 'LEFT)
+              (IL:|fetch| IL:LEFT IL:|of| REGION))
+        (SETF (SLOT-VALUE SELF 'BOTTOM)
+              (IL:|fetch| IL:BOTTOM IL:|of| REGION))
+        (SETF (SLOT-VALUE SELF 'WIDTH)
+              (IL:|fetch| IL:WIDTH IL:|of| REGION))
+        (SETF (SLOT-VALUE SELF 'HEIGHT)
+              (IL:|fetch| IL:HEIGHT IL:|of| REGION))
+        (IL:RESHAPEBYREPAINTFN (SLOT-VALUE SELF 'WINDOW)
+               OLD-BITMAP-IMAGE OLD-REGION OLD-SCREEN-REGION)))
+
+(DEFMETHOD SCROLL-WINDOW ((SELF WEB-EDITOR)
+                              DSP-X DSP-Y WINDOW-X WINDOW-Y) (IL:* IL:\; "10-Apr-86 14:58")
+
+(IL:* IL:|;;;| "scroll the window to set the point dspX,dspY in the given window position -- default is the lower left corner.  If any x or y is a FIXP, it is treated as a absolute position.  If FLOATP, it is treated as a relative position.  Return the position of the new lower left corner.")
+
+   (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW))
+          (VISIBLE-REGION (IL:DSPCLIPPINGREGION NIL WINDOW))
+          (EXTENT (IL:WINDOWPROP WINDOW 'IL:EXTENT)))        (IL:* IL:\; 
+                                          "figure out what to do with default and relative offsets")
+         (IL:SETQ WINDOW-X (IL:|if| (NULL WINDOW-X)
+                               IL:|then| 0
+                             IL:|elseif| (IL:FLOATP WINDOW-X)
+                               IL:|then| (IL:FIX (IL:TIMES WINDOW-X (IL:WINDOWPROP WINDOW
+                                                                               'IL:WIDTH)))
+                             IL:|else| WINDOW-X))
+         (IL:SETQ WINDOW-Y (IL:|if| (NULL WINDOW-Y)
+                               IL:|then| 0
+                             IL:|elseif| (IL:FLOATP WINDOW-Y)
+                               IL:|then| (IL:FIX (IL:TIMES WINDOW-Y (IL:WINDOWPROP WINDOW
+                                                                               'IL:HEIGHT)))
+                             IL:|else| WINDOW-Y))
+         (IL:SETQ DSP-X (IL:|if| (NULL DSP-X)
+                            IL:|then| (IL:|fetch| IL:LEFT IL:|of| VISIBLE-REGION)
+                          IL:|elseif| (IL:FLOATP DSP-X)
+                            IL:|then| (IL:FIX (IL:TIMES DSP-X (IL:|fetch| IL:WIDTH
+                                                                     IL:|of| EXTENT)))
+                          IL:|else| DSP-X))
+         (IL:SETQ DSP-Y (IL:|if| (NULL DSP-Y)
+                            IL:|then| (IL:IMINUS (IL:|fetch| IL:BOTTOM IL:|of| 
+                                                                                     VISIBLE-REGION))
+                          IL:|elseif| (IL:FLOATP DSP-Y)
+                            IL:|then| (IL:FIX (IL:TIMES DSP-Y (IL:|fetch| IL:HEIGHT
+                                                                     IL:|of| EXTENT)))
+                          IL:|else| DSP-Y))
+         (IL:SCROLLW WINDOW (IL:IPLUS WINDOW-X (IL:IDIFFERENCE (IL:|fetch| IL:LEFT IL:|of|
+                                                                                       VISIBLE-REGION
+                                                                      )
+                                                      DSP-X))
+                (IL:IPLUS WINDOW-Y (IL:IDIFFERENCE (IL:|fetch| IL:BOTTOM IL:|of| 
+                                                                                   VISIBLE-REGION)
+                                          DSP-Y)))           (IL:* IL:\; 
+                                                           "return the resulting position")
+         (IL:SETQ VISIBLE-REGION (IL:DSPCLIPPINGREGION NIL WINDOW))
+         (IL:|create| IL:POSITION
+                IL:XCOORD IL:_ (IL:|fetch| IL:LEFT IL:|of| VISIBLE-REGION)
+                IL:YCOORD IL:_ (IL:|fetch| IL:BOTTOM IL:|of| VISIBLE-REGION))))
+
+(DEFMETHOD CLEAR ((SELF WEB-EDITOR))                     (IL:* IL:\; 
+                                            "empty the window of active regions, return the window")
+   (LET ((WINDOW (SLOT-VALUE SELF 'WINDOW)))
+        (IL:WINDOWPROP WINDOW 'IL:GRAPH NIL)
+        (IL:CLEARW WINDOW)
+        WINDOW))
+
+(DEFMETHOD GET-PROMPT-WINDOW ((SELF WEB-EDITOR)
+                                  &OPTIONAL LINES FONT-DEF)  (IL:* IL:\; " 8-Apr-87 15:43")
+
+   (IL:* IL:|;;| "Return the current prompt window")
+
+   (LET ((W (IL:GETPROMPTWINDOW (SLOT-VALUE SELF 'WINDOW)
+                   (OR LINES 2)
+                   (OR (IL:FONTCREATE FONT-DEF)))))
+        (IF FONT-DEF
+            (IL:DSPFONT (IL:FONTCREATE FONT-DEF)
+                   W))
+        W))
+
+(DEFMETHOD REMOVE-PROMPT-WINDOW ((SELF WEB-EDITOR))      (IL:* IL:\; " 8-Apr-87 15:43")
+   (IL:REMOVEPROMPTWINDOW (SLOT-VALUE SELF 'WINDOW)))
+
+(DEFMETHOD PROMPT-PRINT ((SELF WEB-EDITOR)
+                             PROMPT)                         (IL:* IL:\; "13-Aug-86 18:46")
+
+   (IL:* IL:|;;| "Prints out a prompt in an attached prompt window")
+
+   (IL:PRIN1 PROMPT (GET-PROMPT-WINDOW SELF)))
+
+(DEFMETHOD PROMPT-READ ((SELF WEB-EDITOR)
+                            MSG)                             (IL:* IL:\; "13-Aug-86 19:15")
+
+   (IL:* IL:|;;| "Prompt the user for some input, using an attached prompt window")
+
+   (LET ((P-WINDOW (GET-PROMPT-WINDOW SELF)))
+        (IL:CLEARW P-WINDOW)
+        (PROG1 (IL:|PromptRead| MSG P-WINDOW T)
+            (IL:CLEARW P-WINDOW)
+            (IL:DETACHWINDOW P-WINDOW)
+            (IL:CLOSEW P-WINDOW))))
+
+(DEFMETHOD PROMPT-FOR-LIST ((SELF WEB-EDITOR)
+                                PROMPT-STR INITIAL-STRING)   (IL:* IL:\; " 8-Apr-87 16:44")
+
+(IL:* IL:|;;;| "Prompt user in prompt window for a list of words.")
+
+   (LET ((P-WINDOW (GET-PROMPT-WINDOW SELF)))
+        (IL:RESETFORM (IL:TTYDISPLAYSTREAM P-WINDOW)
+               (IL:CLEARW P-WINDOW)
+               (IL:TTYIN PROMPT-STR NIL NIL '(IL:NORAISE)
+                      NIL NIL INITIAL-STRING))))
+
+(DEFMETHOD PROMPT-FOR-STRING ((SELF WEB-EDITOR)
+                                  PROMPT-STR INITIAL-STR)    (IL:* IL:\; "13-Aug-86 18:42")
+
+(IL:* IL:|;;;| "Prompt user in prompt window for a string.")
+
+   (LET ((P-WINDOW (GET-PROMPT-WINDOW SELF))
+         VALUE)
+        (IL:RESETFORM (IL:TTYDISPLAYSTREAM P-WINDOW)
+               (IL:CLEARW P-WINDOW)
+               (SETQ VALUE (IL:TTYIN PROMPT-STR NIL NIL '(STRING IL:NORAISE)
+                                  NIL NIL INITIAL-STR))
+               (IL:CLEARW P-WINDOW))
+        (REMOVE-PROMPT-WINDOW SELF)
+        VALUE))
+
+(DEFMETHOD PROMPT-FOR-WORD ((SELF WEB-EDITOR)
+                                &OPTIONAL PROMPT-STR INITIAL-WORD)
+                                                             (IL:* IL:\; " 8-Apr-87 16:43")
+
+(IL:* IL:|;;;| "Prompt user in prompt window for a word.")
+
+   (CAR (PROMPT-FOR-LIST SELF PROMPT-STR INITIAL-WORD)))
+
+(DEFMACRO MOVE-DOWN-P ()
+   '(OR (IL:KEYDOWNP 'IL:MOVE)
+        (IL:SHIFTDOWNP 'IL:CTRL)))
+(IL:DEFINEQ
+
+(WEB-WINDOW-AFTER-MOVE-FN
+  (LAMBDA (WINDOW)                                  (IL:* IL:\; "Edited 13-Jul-87 15:59 by Rao")
+                                                             (IL:* IL:\; "10-Apr-86 16:16")
+
+(IL:* IL:|;;;| "The SimpleWindow AFTERMOVEFN")
+
+         (LET ((W (IL:WINDOWPROP WINDOW 'WEB-EDITOR)))
+              (AND W (AFTER-MOVE W)))))
+
+(WEB-WINDOW-BUTTON-EVENT-FN
+  (LAMBDA (WINDOW)                                  (IL:* IL:\; "Edited 13-Jul-87 13:38 by Rao")
+                                                             (IL:* IL:\; "11-Sep-86 13:50")
+         (LET ((WINDOW-FOR-MENU (IL:WINDOWPROP WINDOW 'WEB-EDITOR)))
+              (DECLARE (IL:SPECVARS WINDOW-FOR-MENU))
+              (IL:TOTOPW WINDOW)
+              (BUTTON-EVENT-FN WINDOW-FOR-MENU))))
+
+(WEB-WINDOW-RESHAPE-FN
+  (LAMBDA (WINDOW IL:|oldBitmapImage| IL:|oldRegion| IL:|oldScreenRegion|)
+                                                        (IL:* IL:\; "Edited 12-Jun-87 15:56 by Rao")
+                                                             (IL:* IL:\; " 9-May-86 10:07")
+
+(IL:* IL:|;;;| "The RESHAPEFN for a Window")
+
+         (LET ((IL:\w (IL:WINDOWPROP WINDOW 'WEB-EDITOR)))
+              (AND IL:\w (AFTER-RESHAPE IL:\w IL:|oldBitmapImage| IL:|oldRegion| IL:|oldScreenRegion|
+                                )))))
+
+(WEB-WINDOW-CLOSE-FN
+  (IL:LAMBDA (WINDOW)                               (IL:* IL:\; "Edited 12-Jun-87 11:42 by Rao")
+                                                             (IL:* IL:\; 
+                                                           "Remove link back to LoopsWindow")
+    (IL:WINDOWPROP WINDOW 'WEB-EDITOR NIL)))
+
+(IL:|PromptRead|
+  (IL:LAMBDA (PROMPT-STRING WINDOW SAME-LINE?)      (IL:* IL:\; "Edited 20-Jul-87 16:20 by Rao")
+                                                             (IL:* IL:\; 
+                  "Printout promptString in promptwindow and return value of expression read there")
+    (PROG (NEWVALUE)
+          (IL:RESETLST
+              (IL:RESETSAVE (IL:TTYDISPLAYSTREAM (OR WINDOW IL:PROMPTWINDOW)))
+              (IL:RESETSAVE (IL:TTY.PROCESS (IL:THIS.PROCESS)))
+              (IL:CLRPROMPT)
+              (IL:RESETSAVE (IL:PRINTLEVEL 4 3))
+              (IL:|printout| T PROMPT-STRING)
+              (IL:|if| SAME-LINE?
+                  IL:|then| (IL:|printout| T "> ")
+                IL:|else| (IL:|printout| T T "> "))
+              (IL:CLEARBUF T T)                              (IL:* IL:\; 
+                                            "clear tty buffer because it sometimes has stuff left.")
+              (IL:ALLOW.BUTTON.EVENTS)
+              (IL:SETQ NEWVALUE (CAR (IL:ERSETQ (IL:TTYINREAD T T)))))
+          (RETURN NEWVALUE))))
+)
+(IL:DEFINEQ
+
+(WEB-WINDOW-EXPAND-FN
+  (LAMBDA (WINDOW)                                  (IL:* IL:\; "Edited 13-Nov-87 12:58 by Rao")
+                                                             (IL:* IL:\; "19-Feb-85 13:58")
+
+         (IL:* IL:|;;| "When a browser window is expanded, it should be recomputed")
+
+         (LET ((SELF (IL:WINDOWPROP WINDOW 'WEB-EDITOR)))
+              (RECOMPUTE-IN-PLACE SELF))))
+)
+
+(DEFUN WEB-WINDOW-ICON-FN (WINDOW ICON DUMMY)
+   (LET NIL (OR ICON (IL:TITLEDICONW *WEB-EDITOR-TEMPLATE* (ICON-TITLE (IL:WINDOWPROP WINDOW
+                                                                              'WEB-EDITOR))
+                            NIL
+                            '(0 . 0)
+                            T
+                            'IL:BOTTOM
+                            (IL:CONSTANT (LIST (IL:CHARCODE "-")
+                                               (IL:CHARCODE IL:SPACE)
+                                               (IL:CHARCODE IL:EOL)))))))
+
+(IL:RPAQQ *WEB-EDITOR-ICON-BM* #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@L@@@@@@@@@@AL@@@L@@@@@@@@@@AF@@@L@@@@@@@@@@AC@@@L@@@@@@@@@@AAH@@L@@@@@@@@@@A@L@@L@@@@@@@@@@A@F@@LOON@@@@@@OO@C@@LOON@@@@@@OO@AH@LOOO@@@@@@OO@@L@LOONH@@@@AOO@@F@LOOND@@@@BOOOOO@L@@@B@@@@DOOOHC@L@@@ACOOLH@@@@C@L@@@@KOOM@@@@@C@L@@@@GOON@@@@@C@L@@@@KOOM@@@@@C@L@@@ACOOLH@@@@C@LOOOB@@@@DOOOHC@LOOOD@@@@BOOOHC@LOOOH@@@@AOOOHC@LOOOD@@@@@OOOHC@LOOOB@@@@@OOOHC@L@@@ACOOO@@@@@C@L@@@@KOOO@@@@@C@L@@@@GOOO@@@@@C@L@@@@COOO@@@@@C@L@@@@COOO@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@
+)
+
+(IL:RPAQQ *WEB-EDITOR-ICON-MASK* #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOON@@@OOOOOOOOOOOOO@@@OOOOOOOOOOOOOH@@OOOOOOOOOOOOOL@@OOOOOOOOOOOOON@@OOOOOOOOOOOOOO@@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOL@OOOOOOOOOOOOOON@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@
+)
+
+(DEFVAR *WEB-EDITOR-TEMPLATE* (IL:|create| IL:TITLEDICON
+                                         IL:ICON IL:_ *WEB-EDITOR-ICON-BM*
+                                         IL:MASK IL:_ *WEB-EDITOR-ICON-MASK*
+                                         IL:TITLEREG IL:_ (IL:CREATEREGION 5 2 50 30)))
+
+(IL:RPAQ IL:*D-WINDOW-DEFAULT-STREAM* IL:PROMPTWINDOW)
+
+(IL:RPAQ WEB-STREAM IL:PROMPTWINDOW)
+
+
+
+(IL:* IL:\; "Layout and Display Engine")
+
+
+(IL:RPAQQ IL:|BrowserMargin| 0)
+
+(IL:RPAQQ IL:|MaxLatticeHeight| 750)
+
+(IL:RPAQQ IL:|MaxLatticeWidth| 900)
+(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
+
+(IL:SPECVARS IL:|MaxLatticeHeight| IL:|MaxLatticeWidth|)
+)
+
+(IL:RPAQQ IL:GRAYSHADE1 1)
+
+(IL:RPAQQ IL:GRAYSHADE2 1025)
+
+(IL:RPAQQ IL:GRAYSHADE3 64510)
+
+(IL:RPAQQ IL:GRAYSHADE4 65534)
+(IL:DEFINEQ
+
+(TREE-ROOTS
+  (IL:LAMBDA (NODE-LST)                             (IL:* IL:\; "Edited 10-Jul-87 19:22 by Rao")
+                                                             (IL:* IL:\; "29-Sep-86 19:46")
+
+    (IL:* IL:|;;| "Computes a minimal set of root nodes for a lattice --- those with no connections TO them in list of nodes, or a single node from a cycle of nodes.")
+
+    (PROG ((ROOT-NODES (IL:LDIFFERENCE NODE-LST (IL:|for| IL:|node| IL:|in| NODE-LST
+                                                   IL:|join| (CHILD-NODES IL:|node| NODE-LST)
+                                                       )))
+           REACHABLE-NODES NOT-REACHABLE-NODES)
+          (SETQ REACHABLE-NODES (IL:COPY ROOT-NODES))
+          (SETQ NOT-REACHABLE-NODES (IL:LDIFFERENCE NODE-LST REACHABLE-NODES))
+                                                             (IL:* IL:\; 
+                             "recompute the nodes that can't be reached from the current rootNodes")
+      IL:|RecomputeReachableNodes|
+          
+
+     (IL:* IL:|;;| "Compute the transitive closure of the set of reachableNodes --- updating the notReachableNodes at the same time")
+
+          (IL:|for| IL:|node| IL:|in| REACHABLE-NODES
+             IL:|do| (IL:|for| IL:|childNode| IL:|in| (CHILD-NODES IL:|node| NODE-LST
+                                                                         )
+                            IL:|when| (IL:MEMB IL:|childNode| NOT-REACHABLE-NODES)
+                            IL:|do| 
+
+                                  (IL:* IL:|;;| "put the newly found reachable node at the end of the list, so we will find it later on during this iteration")
+
+                                  (IL:NCONC1 REACHABLE-NODES IL:|childNode|)
+                                  (SETQ NOT-REACHABLE-NODES (IL:DREMOVE IL:|childNode| 
+                                                                   NOT-REACHABLE-NODES))))
+                                                             (IL:* IL:\; 
+                                                           "if we can reach all the nodes, fine...")
+          (IL:|if| (NULL NOT-REACHABLE-NODES)
+              IL:|then|                                  (IL:* IL:\; 
+                                                          "Now need to prune down to a minimal set")
+                    (IL:|bind| (IL:|stable?| IL:_ NIL) IL:|until| IL:|stable?|
+                       IL:|do| (SETQ IL:|stable?| T)
+                             (IL:|for| IL:|node| IL:|in| ROOT-NODES IL:|bind| 
+                                                                                  IL:|extraRoots|
+                                IL:|do| (SETQ IL:|extraRoots| (IL:DREMOVE IL:|node|
+                                                                         (IL:INTERSECTION
+                                                                          ROOT-NODES
+                                                                          (REACHABLE-NODES!
+                                                                           IL:|node| NODE-LST))))
+                                      (IL:|if| IL:|extraRoots|
+                                          IL:|then| (SETQ IL:|stable?| NIL)
+                                                (SETQ ROOT-NODES (IL:LDIFFERENCE ROOT-NODES 
+                                                                        IL:|extraRoots|))
+                                                (RETURN T)) IL:|finally| (RETURN NIL))) 
+                                                             (IL:* IL:\; 
+                                                          "return the node ids, not the GRAPHNODES")
+                    (RETURN (IL:|for| IL:|node| IL:|in| ROOT-NODES
+                               IL:|collect| (IL:|fetch| IL:NODEID IL:|of| IL:|node|)))
+            IL:|else|                                    (IL:* IL:\; 
+            "must be a cycle.  Select the least prolific node in the cycle as the a new root node.")
+                  (IL:|push| ROOT-NODES (LET ((PROLIFIC-NODE (IL:|for| IL:|node| IL:|in|
+                                                                                         
+                                                                                  NOT-REACHABLE-NODES
+                                                                    IL:|smallest|
+                                                                    (IL:LENGTH (IL:|fetch| 
+                                                                                      IL:TONODES
+                                                                                  IL:|of| 
+                                                                                        IL:|node|))))
+                                                  )
+                                                 (SETQ NOT-REACHABLE-NODES (IL:DREMOVE PROLIFIC-NODE
+                                                                                  NOT-REACHABLE-NODES
+                                                                                  ))
+                                                 PROLIFIC-NODE))
+                  (GO IL:|RecomputeReachableNodes|)))))
+
+(CHILD-NODES
+  (IL:LAMBDA (PARENT-NODE NODE-LIST)                (IL:* IL:\; "Edited 10-Jul-87 19:23 by Rao")
+                                                             (IL:* IL:\; " 8-Oct-85 14:15")
+                                                             (IL:* IL:\; 
+                                 "Find all GRAPHNODES that are immediatly reachable from this node")
+    (IL:|for| IL:|label| IL:|in| (IL:|fetch| IL:TONODES IL:|of| PARENT-NODE)
+       IL:|collect| (IL:|for| IL:|node| IL:|in| NODE-LIST
+                           IL:|thereis| (EQ IL:|label| (IL:|fetch| IL:NODEID IL:|of|
+                                                                                     IL:|node|))))))
+
+(REACHABLE-NODES!
+  (IL:LAMBDA (IL:|root| IL:|nodeList|)                       (IL:* IL:\; "30-Sep-86 10:22")
+                                                             (IL:* IL:\; IL:|Return| IL:\a 
+                                                           IL:|list| IL:|of| IL:|all| 
+                                                           IL:|nodes| IL:|that| IL:|are| 
+                                                           IL:|reachable| IL:|from| IL:|the| 
+                                                           IL:|root|)
+    (LET ((IL:|reachableNodes| (LIST IL:|root|)))
+         (IL:|for| IL:|node| IL:|in| IL:|reachableNodes|
+            IL:|do| (IL:|for| IL:|childNode| IL:|in| (CHILD-NODES IL:|node| 
+                                                                        IL:|nodeList|)
+                           IL:|when| (NOT (IL:MEMB IL:|childNode| IL:|reachableNodes|))
+                           IL:|do| 
+
+         (IL:* IL:\; IL:|put| IL:|the| IL:|newly| IL:|found| IL:|reachable| IL:|node| 
+       IL:|at| IL:|the| IL:|end| IL:|of| IL:|the| IL:|list,| IL:|so| IL:|we| IL:|will| 
+       IL:|find| IL:|it| IL:|later| IL:|on| IL:|during| IL:|this| IL:|iteration|)
+
+                                 (IL:NCONC1 IL:|reachableNodes| IL:|childNode|)))
+         IL:|reachableNodes|)))
+)
+
+(DEFMETHOD DISPLAY-BROWSER ((SELF WEB-EDITOR))           (IL:* IL:\; "29-Sep-86 12:15")
+                                                             (IL:* IL:\; "New method template")
+   (LET ((NODELST (AND (SLOT-VALUE SELF 'STARTING-LIST)
+                       (GET-NODE-LIST SELF (SLOT-VALUE SELF 'STARTING-LIST)
+                              (SLOT-VALUE SELF 'GOOD-LIST)))))
+        (COND
+           (NODELST (IL:SHOWGRAPH (IL:LAYOUTGRAPH NODELST (TREE-ROOTS NODELST)
+                                         (SLOT-VALUE SELF 'GRAPH-FORMAT)
+                                         (SLOT-VALUE SELF 'BROWSE-FONT))
+                           (SLOT-VALUE SELF 'WINDOW)
+                           NIL NIL (SLOT-VALUE SELF 'TOP-ALIGN))
+                                                             (IL:* IL:\; 
+                                                           "kludge to reset the window props")
+                  (SETUP-WINDOW SELF))
+           (T (CLEAR SELF)))))
+
+(DEFMETHOD BROWSER-OBJECTS ((IL:|self| WEB-EDITOR))      (IL:* IL:\; "28-May-84 12:58")
+                                                             (IL:* IL:\; 
+                                            "Return a list of all the objects shown in the browser")
+   (IL:|for| IL:|node| IL:|in| (IL:|fetch| IL:GRAPHNODES
+                                          IL:|of| (IL:WINDOWPROP (SLOT-VALUE IL:|self|
+                                                                            'WINDOW)
+                                                             'IL:GRAPH))
+      IL:|when| (IL:NLISTP (CAR IL:|node|)) IL:|collect| (CAR IL:|node|)))
+
+(DEFMETHOD GET-NODE-LIST ((SELF WEB-EDITOR)
+                              BROWSE-LIST GOOD-LIST)         (IL:* IL:\; "21-Mar-85 14:09")
+
+   (IL:* IL:|;;| "Compute the node data structures of the tree starting at browseList.  If goodList is given, only include elements of it.  If goodList=T make it be browseList.")
+
+   (DECLARE (IL:GLOBALVARS IL:WHITESHADE))
+   (COND
+      ((EQ GOOD-LIST T)
+       (IL:SETQ GOOD-LIST BROWSE-LIST)))
+   (PROG (SUBS PAIR NODE (OLD-NODES (IL:|fetch| IL:GRAPHNODES IL:|of|
+                                                                  (IL:WINDOWPROP (SLOT-VALUE
+                                                                                  SELF
+                                                                                  'WINDOW)
+                                                                         'IL:GRAPH)))
+               (OBJ-LIST (CONS)))
+
+    (IL:* IL:|;;| "first make objList which is a list of pairs (object  . objName).  objName will be used as a title for a node in the browser.  This structure will be replaced by a graphNode when it is processed.  The nodeID of the graphNode will be the object, and the label will be the name.")
+
+         (IL:|for| IL:|objOrName| IL:|in| BROWSE-LIST
+            IL:|do| (AND (IL:SETQ PAIR (OBJ-NAME-PAIR SELF IL:|objOrName|))
+                             (NOT (IL:FASSOC (CAR PAIR)
+                                         (CAR OBJ-LIST)))
+                             (IL:TCONC OBJ-LIST PAIR)))
+
+    (IL:* IL:|;;| "Now MAP ON list so pair can be replaced by graphNode")
+
+         (IL:|for| PAIR IL:|name| IL:|obj| IL:|subObjs| IL:|on| (CAR OBJ-LIST)
+            IL:|when| (IL:NLISTP (IL:SETQ IL:|name| (CDAR PAIR)))
+            IL:|do| (IL:SETQ IL:|subObjs| (CONS))
+                  (IL:|for| IL:|sub| IL:|objPair| IL:|obj1| IL:|in| (GET-SUBS SELF
+                                                                                   (IL:SETQ IL:|obj|
+                                                                                    (CAAR PAIR)))
+                     IL:|do| 
+
+                           (IL:* IL:|;;| "ObjNamePair returns NIL for destroyed objects.  include only members of goodList in subs if given.  Add to objList only once")
+
+                           (IL:SETQ IL:|obj1| (COND
+                                                 ((EQ (CAR IL:|sub|)
+                                                      'IL:|Link Parameters|)
+                                                  (CADR IL:|sub|))
+                                                 (T IL:|sub|)))
+                           (COND
+                              ((IL:SETQ IL:|objPair| (OBJ-NAME-PAIR SELF IL:|obj1|))
+                               (COND
+                                  ((NOT (IL:FASSOC IL:|obj1| (CAR OBJ-LIST)))
+                                   (IL:TCONC OBJ-LIST IL:|objPair|)))
+                               (IL:TCONC IL:|subObjs| IL:|sub|))))
+                  (RPLACA PAIR (IL:SETQ NODE (OR (IL:FASSOC IL:|obj| OLD-NODES)
+                                                 (IL:|create| IL:GRAPHNODE
+                                                        IL:NODEID IL:_ IL:|obj|
+                                                        IL:NODEBORDER IL:_
+                                                        (LIST (IL:ADD1 (SLOT-VALUE SELF 
+                                                                              'BOX-LINE-WIDTH))
+                                                              IL:WHITESHADE)))))
+                  (IL:|replace| IL:TONODES IL:|of| NODE IL:|with| (CAR IL:|subObjs|))
+                  (IL:|replace| IL:NODELABEL IL:|of| NODE IL:|with| IL:|name|)
+                  (IL:|replace| IL:NODEFONT IL:|of| NODE IL:|with| (SLOT-VALUE
+                                                                                SELF
+                                                                                'BROWSE-FONT))
+                  (IL:|replace| IL:NODEWIDTH IL:|of| NODE IL:|with| NIL)
+                  (IL:|replace| IL:NODEHEIGHT IL:|of| NODE IL:|with| NIL))
+         (RETURN (CAR OBJ-LIST))))
+
+(DEFMETHOD OBJ-NAME-PAIR ((IL:|self| WEB-EDITOR)
+                              IL:|obj|)
+
+   (IL:* IL:|;;| "Make a pair (object  . objName) where objName is label to be used in browser")
+
+   (LET NIL (IL:|if| (NULL IL:|obj|)
+                IL:|then| NIL
+              IL:|elseif| (AND (SLOT-VALUE IL:|self| 'GOOD-LIST)
+                                   (NOT (IL:FMEMB IL:|obj| (SLOT-VALUE IL:|self| 'GOOD-LIST))))
+                IL:|then| NIL
+              IL:|elseif| (IL:FMEMB IL:|obj| (SLOT-VALUE IL:|self| 'BAD-LIST))
+                IL:|then| NIL
+              IL:|else| (CONS IL:|obj| (GET-DISPLAY-LABEL IL:|self| IL:|obj|)))))
+
+(DEFMETHOD GRAPH-FITS ((|self| WEB-EDITOR))              (IL:* IL:\; "24-Apr-86 15:00")
+
+(IL:* IL:|;;;| "Tests if graph fits in region")
+
+   (LET ((|window| (SLOT-VALUE |self| 'WINDOW)))
+        (LET ((|width| 0)
+              (|height| 0)
+              (|region| (IL:WINDOWPROP |window| 'IL:REGION))
+              (|nodes| (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP |window| 'IL:GRAPH)))
+              )
+             (COND
+                (|nodes| (IL:SETQ |width| (IL:WIDTHIFWINDOW (IL:IDIFFERENCE (IL:MAX/RIGHT |nodes|)
+                                                                   (IL:MIN/LEFT |nodes|))
+                                                 (IL:WINDOWPROP |window| 'IL:BORDER)))
+                       (IL:SETQ |height| (IL:HEIGHTIFWINDOW (IL:IDIFFERENCE (IL:MAX/TOP |nodes|)
+                                                                   (IL:MIN/BOTTOM |nodes|))
+                                                (IL:WINDOWPROP |window| 'IL:TITLE)
+                                                (IL:WINDOWPROP |window| 'IL:BORDER)))))
+             (NOT (OR (IL:IGREATERP |width| (IL:|fetch| IL:WIDTH IL:|of| |region|))
+                      (IL:IGREATERP |height| (IL:|fetch| IL:HEIGHT IL:|of| |region|)))))))
+
+(DEFMETHOD NODE-REGION ((IL:|self| WEB-EDITOR)
+                            IL:|object|)                     (IL:* IL:\; "10-Dec-84 18:26")
+
+   (IL:* IL:|;;| "what region does the object occupy in the display stream?")
+
+   (LET ((IL:|node| (IL:FASSOC (COND
+                                  ((IL:LITATOM IL:|object|)
+                                   (IL:SETQ IL:|object| (IL:|GetObjectRec| IL:|object|)))
+                                  (T IL:|object|))
+                           (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP
+                                                                      (SLOT-VALUE IL:|self|
+                                                                             'WINDOW)
+                                                                      'IL:GRAPH)))))
+        (IL:|if| IL:|node|
+            IL:|then| (IL:|create| IL:REGION
+                                 IL:LEFT IL:_ (IL:IDIFFERENCE (IL:|fetch| IL:XCOORD
+                                                                 IL:|of| (IL:|fetch| 
+                                                                                    IL:NODEPOSITION
+                                                                                IL:|of| IL:|node|
+                                                                                    ))
+                                                     (IL:IQUOTIENT (IL:|fetch| IL:NODEWIDTH
+                                                                      IL:|of| IL:|node|)
+                                                            2))
+                                 IL:BOTTOM IL:_ (IL:IDIFFERENCE (IL:|fetch| IL:YCOORD
+                                                                   IL:|of| (IL:|fetch| 
+                                                                                      IL:NODEPOSITION
+                                                                                  IL:|of| 
+                                                                                        IL:|node|))
+                                                       (IL:IQUOTIENT (IL:|fetch| IL:NODEHEIGHT
+                                                                        IL:|of| IL:|node|)
+                                                              2))
+                                 IL:WIDTH IL:_ (IL:|fetch| IL:NODEWIDTH IL:|of| IL:|node|)
+                                 IL:HEIGHT IL:_ (IL:|fetch| IL:NODEHEIGHT IL:|of| IL:|node|))
+               )))
+
+(DEFMETHOD RECOMPUTE ((SELF WEB-EDITOR)
+                          &OPTIONAL DONT-RESHAPE-FLG)        (IL:* IL:\; " 8-Apr-87 14:42")
+                                                             (IL:* IL:\; 
+                                                     "Recompute the browseGraph in the same window")
+   (PROG ((GRAPH-FITS (GRAPH-FITS SELF)))
+         (DISPLAY-BROWSER SELF)
+         (COND
+            ((OR DONT-RESHAPE-FLG (NULL GRAPH-FITS))         (IL:* IL:\; 
+                             "Dont Reshape or rescroll.  Assume window wants to stay the same size")
+             )
+            (T (SHAPE-TO-HOLD SELF))))
+   SELF)
+
+(DEFMETHOD RECOMPUTE-IN-PLACE ((IL:|self| WEB-EDITOR))   (IL:* IL:\; "10-Dec-84 18:27")
+
+(IL:* IL:|;;;| "recompute the graph, maintaining the current position")
+
+   (LET* ((IL:|visibleRegion| (IL:DSPCLIPPINGREGION NIL (SLOT-VALUE IL:|self| 'WINDOW)))
+          (IL:\x (IL:|fetch| IL:LEFT IL:|of| IL:|visibleRegion|))
+          (IL:\y (IL:|fetch| IL:BOTTOM IL:|of| IL:|visibleRegion|)))
+                                                             (IL:* IL:\; 
+                      "if we want to RecomputeInPlace, we must want the window to be kept the same")
+         (RECOMPUTE IL:|self| T)                             (IL:* IL:\; 
+               "we had to save x and y because visibleRegion gets clobbered by Recompute! Suprise!")
+         (SCROLL-WINDOW IL:|self| IL:\x IL:\y)))
+
+(DEFMETHOD RECOMPUTE-LABELS ((|self| WEB-EDITOR))        (IL:* IL:\; "27-Feb-85 11:27")
+                                                             (IL:* IL:\; 
+                                                        "recompute the graph, including the labels")
+   (CLEAR-LABEL-CACHE |self| T)
+   (RECOMPUTE |self|))
+
+(DEFMETHOD RECOMPUTE-IF-OPEN ((WEB-EDITOR WEB-EDITOR))   (IL:* IL:\; "27-Aug-86 12:37")
+   (IF (IL:OPENWP (SLOT-VALUE WEB-EDITOR 'WINDOW))
+       (RECOMPUTE WEB-EDITOR)))
+
+(DEFMETHOD CLEAR-LABEL-CACHE ((WEB-EDITOR WEB-EDITOR)
+                                  OBJECTS)                   (IL:* IL:\; " 5-Dec-85 12:02")
+   (LET (CACHED-LABEL)
+
+        (IL:* IL:|;;| "Delete the cached label for these items")
+
+        (COND
+           ((EQ OBJECTS T)
+            (SETF (SLOT-VALUE WEB-EDITOR 'LABEL-CACHE)
+                  NIL))
+           (T (IF (ATOM OBJECTS)
+                  (SETQ OBJECTS (CONS OBJECTS)))
+              (DOLIST (OBJ OBJECTS)
+                  (IF (SETQ CACHED-LABEL (IL:ASSOC OBJ (SLOT-VALUE WEB-EDITOR 'LABEL-CACHE)))
+                      (SETF (SLOT-VALUE WEB-EDITOR 'LABEL-CACHE)
+                            (IL:DREMOVE CACHED-LABEL (SLOT-VALUE WEB-EDITOR 'LABEL-CACHE)))))))))
+
+(DEFMETHOD OBJECT-FROM-LABEL ((SELF WEB-EDITOR)
+                                  LABEL)                     (IL:* IL:\; " 4-Jan-85 18:20")
+
+   (IL:* IL:|;;| "What object has this label?")
+
+   (LET ((OBJECT-NODE (IL:|for| IL:|node| IL:|in| (IL:|fetch| IL:GRAPHNODES
+                                                             IL:|of| (IL:WINDOWPROP
+                                                                          (SLOT-VALUE SELF
+                                                                                 'WINDOW)
+                                                                          'IL:GRAPH))
+                         IL:|thereis| (IL:EQUAL LABEL (IL:|fetch| IL:NODELABEL IL:|of|
+                                                                                       IL:|node|)))))
+        (IL:|if| (IL:NLISTP (CAR OBJECT-NODE))
+            IL:|then| (CAR OBJECT-NODE)
+          IL:|else| NIL)))
+
+(DEFMETHOD CHANGE-FONT-SIZE ((WEB-EDITOR WEB-EDITOR)
+                                 &OPTIONAL SIZE)             (IL:* IL:\; "13-Dec-84 13:04")
+                                                             (IL:* IL:\; 
+                                                 "Change the font size from whatever it is to size")
+   (WHEN (OR SIZE (SETQ SIZE (IL:MENU (IL:|create| IL:MENU
+                                             IL:TITLE IL:_ "Select Desired Size"
+                                             IL:CHANGEOFFSETFLG IL:_ T
+                                             IL:ITEMS IL:_ '(("Abort" NIL)
+                                                             8 10 12 16)))))
+       (SETF (SLOT-VALUE WEB-EDITOR 'BROWSE-FONT)
+             (IL:FONTCREATE `(,(SLOT-VALUE WEB-EDITOR 'BROWSE-FONT-FAMILY)
+                              ,SIZE
+                              ,(SLOT-VALUE WEB-EDITOR 'BROWSE-FONT-FACE))))
+                                                             (IL:* IL:\; 
+                                                           "clear out the label cache!")
+       (RECOMPUTE-LABELS WEB-EDITOR)))
+
+(DEFMETHOD CHANGE-FORMAT ((|self| WEB-EDITOR)
+                              &OPTIONAL |format|)            (IL:* IL:\; "21-Apr-84 19:52")
+                                                             (IL:* IL:\; 
+                                                           "Change format between Lattice and Tree")
+   (COND
+      ((IL:LISTP |format|)
+       (SETF (SLOT-VALUE |self| 'GRAPH-FORMAT)
+             |format|))
+      ((SETQ |format| (IL:MENU (IL:|create| IL:MENU
+                                      IL:ITEMS IL:_ (SLOT-VALUE |self| 'GRAPH-FORMAT-CHOICES))))
+       (SETF (SLOT-VALUE |self| 'GRAPH-FORMAT)
+             |format|)))
+   (RECOMPUTE |self|))
+
+(DEFMETHOD CHANGE-MAX-LABEL-SIZE ((SELF WEB-EDITOR)
+                                      NEW-MAX-WIDTH NEW-MAX-LINES)
+                                                             (IL:* IL:\; "13-Dec-84 13:05")
+                                                             (IL:* IL:\; 
+     "change the max label dimensions and redisplay the nodes -- if new size is NULL, don't change")
+   (IL:|if| NEW-MAX-LINES
+       IL:|then| (SETF (SLOT-VALUE SELF 'LABEL-MAX-LINES)
+                           NEW-MAX-LINES))
+   (IL:|if| NEW-MAX-WIDTH
+       IL:|then| (SETF (SLOT-VALUE SELF 'LABEL-MAX-CHARS-WIDTH)
+                           NEW-MAX-WIDTH))                   (IL:* IL:\; 
+                                                           "clear out the label cache")
+   (RECOMPUTE-LABELS SELF))
+
+(DEFMETHOD SHAPE-TO-HOLD ((SELF WEB-EDITOR))             (IL:* IL:\; "13-Jan-87 16:52")
+
+   (IL:* IL:|;;| "Shape the browse window to just hold the nodes with BrowserMargin to spare")
+
+   (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW))
+          (REGION (IL:WINDOWPROP WINDOW 'IL:REGION))
+          (NODES (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP WINDOW 'IL:GRAPH)))
+          (MIN-WIDTH (IL:IPLUS 5 (IL:STRINGWIDTH (SLOT-VALUE SELF 'TITLE)
+                                        (IL:DSPFONT NIL IL:|WindowTitleDisplayStream|))))
+          (MIN-HEIGHT (IL:FONTHEIGHT (IL:DSPFONT NIL WINDOW)))
+          LEFT BOTTOM HEIGHT WIDTH RIGHT TOP)
+         (IF NODES
+             (PROGN (SETQ LEFT (IL:MIN/LEFT NODES))
+                    (SETQ BOTTOM (IL:MIN/BOTTOM NODES))
+                    (SETQ RIGHT (IL:MAX/RIGHT NODES))
+                    (SETQ TOP (IL:MAX/TOP NODES))
+                    (SETQ WIDTH (IL:IMAX MIN-WIDTH (IL:IMIN IL:|MaxLatticeWidth|
+                                                          (IL:WIDTHIFWINDOW (IL:PLUS 
+                                                                                   IL:|BrowserMargin|
+                                                                                   (IL:IDIFFERENCE
+                                                                                    RIGHT LEFT))
+                                                                 (IL:WINDOWPROP WINDOW 'IL:BORDER))))
+                          )
+                    (SETQ HEIGHT (IL:IMAX MIN-HEIGHT (IL:IMIN IL:|MaxLatticeHeight|
+                                                            (IL:PLUS IL:|BrowserMargin|
+                                                                   (IL:IDIFFERENCE TOP BOTTOM)))))
+                    (UNLESS (AND (IL:EQP WIDTH (IL:|fetch| IL:WIDTH IL:|of| REGION))
+                                 (IL:EQP (IL:HEIGHTIFWINDOW HEIGHT (IL:WINDOWPROP WINDOW 'IL:TITLE)
+                                                (IL:WINDOWPROP WINDOW 'IL:BORDER))
+                                        (IL:|fetch| IL:HEIGHT IL:|of| REGION)))
+                        (SET-REGION SELF (IL:CREATEREGION (IL:|fetch| IL:LEFT IL:|of| REGION)
+                                                (IL:|fetch| IL:BOTTOM IL:|of| REGION)
+                                                WIDTH HEIGHT)
+                               NIL)))
+
+             (IL:* IL:|;;| "ELSE")
+
+             (SET-REGION SELF (IL:CREATEREGION (IL:|fetch| IL:LEFT IL:|of| REGION)
+                                     (IL:|fetch| IL:BOTTOM IL:|of| REGION)
+                                     MIN-WIDTH MIN-HEIGHT)))))
+
+(DEFMETHOD GET-DISPLAY-LABEL ((SELF WEB-EDITOR)
+                                  OBJECT)
+
+(IL:* IL:|;;;| "get the display label.  use the cache if it provides the answer;  if not, and maxLabelWidth is set, use it to compute the appropriate bit map and then cache the result.")
+
+   (LET ((CACHED-LABEL (IL:ASSOC OBJECT (SLOT-VALUE SELF 'LABEL-CACHE))))
+        (IF CACHED-LABEL
+            (CDR CACHED-LABEL)
+            (LET ((NEW-LABEL (BOX-PRINT-STRING (GET-LABEL SELF OBJECT)
+                                    (SLOT-VALUE SELF 'LABEL-MAX-CHARS-WIDTH)
+                                    (SLOT-VALUE SELF 'LABEL-MAX-LINES)
+                                    (SLOT-VALUE SELF 'BROWSE-FONT))))
+                 (IL:|if| (IL:LISTP NEW-LABEL)
+                     IL:|then|                           (IL:* IL:\; 
+                                                           "GRAPHER dies if the label is a list")
+                           (IL:SETQ NEW-LABEL (IL:MKSTRING NEW-LABEL)))
+                 (PUSH (CONS OBJECT NEW-LABEL)
+                       (SLOT-VALUE SELF 'LABEL-CACHE))
+                 NEW-LABEL))))
+
+(DEFMETHOD BOX-NODE ((SELF WEB-EDITOR)
+                         OBJECT &OPTIONAL KEEP-PREVIOUS-BOX) (IL:* IL:\; " 8-Apr-87 18:34")
+   "Puts a box around the node in the graph representing the object"
+
+   (IL:* IL:|;;| 
+ "If there was a previously boxed node, remove the box from around it and set it to nil")
+
+   (WHEN (AND (NOT KEEP-PREVIOUS-BOX)
+              DESTINATION-BROWSER
+              (SLOT-VALUE DESTINATION-BROWSER 'BOXED-NODE))
+       (HIGHLIGHT-NODE DESTINATION-BROWSER (SLOT-VALUE DESTINATION-BROWSER 'BOXED-NODE)
+              (SLOT-VALUE SELF 'BOX-LINE-WIDTH)
+              IL:WHITESHADE)
+       (SETF (SLOT-VALUE DESTINATION-BROWSER 'BOXED-NODE)
+             NIL))
+   (SETQ DESTINATION-BROWSER SELF)                           (IL:* IL:\; "update the global")
+   (HIGHLIGHT-NODE SELF OBJECT (SLOT-VALUE SELF 'BOX-LINE-WIDTH)
+          IL:BLACKSHADE)
+   (SETF (SLOT-VALUE SELF 'BOXED-NODE)
+         OBJECT))
+
+(DEFMETHOD UNMARK-NODES ((IL:|self| WEB-EDITOR))         (IL:* IL:\; "10-Dec-84 12:27")
+                                                             (IL:* IL:\; 
+                                     "clear the graph nodes, removing all shading and highlighting")
+   (REMOVE-HIGHLIGHTS IL:|self|)
+   (REMOVE-SHADING IL:|self|))
+
+(DEFMETHOD HIGHLIGHT-NODE ((SELF WEB-EDITOR)
+                               OBJECT WIDTH SHADE)           (IL:* IL:\; "13-Dec-85 15:16")
+
+(IL:* IL:|;;;| "highlight a node by surronding it with a shaded box")
+
+   (LET ((NODE (IL:FASSOC OBJECT (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP
+                                                                            (SLOT-VALUE SELF
+                                                                                   'WINDOW)
+                                                                            'IL:GRAPH)))))
+        (AND NODE (DISPLAY-NODE-HIGHTLIGHTS SELF NODE SHADE WIDTH))))
+
+(DEFMETHOD SHADE-NODE ((IL:|self| WEB-EDITOR)
+                           IL:|object| IL:|shade|)           (IL:* IL:\; "15-Jan-87 18:34")
+
+   (IL:* IL:|;;| "shade the background of a node")
+
+   (LET ((IL:|node| (IL:FASSOC (COND
+                                  ((IL:LITATOM IL:|object|)
+                                   (IL:SETQ IL:|object| (IL:|GetObjectRec| IL:|object|)))
+                                  (T IL:|object|))
+                           (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP
+                                                                      (SLOT-VALUE IL:|self|
+                                                                             'WINDOW)
+                                                                      'IL:GRAPH)))))
+        (IL:|if| IL:|node|
+            IL:|then| (IL:|if| (IL:BITMAPP (IL:|fetch| IL:NODELABEL IL:|of| IL:|node|
+                                                          ))
+                              IL:|then| 
+
+                                 (IL:* IL:|;;| "Need to forget the old bitmap, in case it already has a shade blt'ed into it.  This will fail if the GetDisplayLabel msg returns something different from the previous value, but what can you do?")
+
+                                    (CLEAR-LABEL-CACHE IL:|self| IL:|object|)
+                                    (LET ((IL:|newLabel| (GET-DISPLAY-LABEL IL:|self| IL:|object|)))
+                                         (IL:|replace| IL:NODELABEL IL:|of| IL:|node|
+                                            IL:|with| IL:|newLabel|)
+                                         (IL:|if| (AND IL:|shade| (IL:BITMAPP IL:|newLabel|))
+                                             IL:|then| (IL:BITBLT NIL NIL NIL IL:|newLabel| NIL 
+                                                                  NIL NIL NIL 'IL:TEXTURE
+                                                                  'IL:PAINT IL:|shade|))))
+                  (DISPLAY-NODE-SHADING IL:|self| IL:|node| IL:|shade|))))
+
+(DEFMETHOD DISPLAY-NODE-HIGHTLIGHTS ((SELF WEB-EDITOR)
+                                         NODE SHADE BOX-WIDTH)
+   (IL:RESET/NODE/BORDER NODE (COND
+                                 (SHADE (LIST BOX-WIDTH SHADE))
+                                 (T BOX-WIDTH))
+          (SLOT-VALUE SELF 'WINDOW)))
+
+(DEFMETHOD DISPLAY-NODE-SHADING ((SELF WEB-EDITOR)
+                                     NODE SHADE)             (IL:* IL:\; "13-Dec-85 15:13")
+                                                             (IL:* IL:\; "New method template")
+   (IL:RESET/NODE/LABELSHADE NODE (OR SHADE IL:WHITESHADE)
+          (SLOT-VALUE SELF 'WINDOW)))
+
+(DEFMETHOD REMOVE-HIGHLIGHTS ((IL:|self| WEB-EDITOR))    (IL:* IL:\; "13-Dec-85 15:16")
+
+(IL:* IL:|;;;| "gets rid of all highlighting in the lattice")
+
+   (IL:|for| IL:|node| IL:|in| (IL:|fetch| IL:GRAPHNODES
+                                          IL:|of| (IL:WINDOWPROP (SLOT-VALUE IL:|self|
+                                                                            'WINDOW)
+                                                             'IL:GRAPH))
+      IL:|do| (DISPLAY-NODE-HIGHTLIGHTS IL:|self| IL:|node| NIL))
+   (SETF (SLOT-VALUE IL:|self| 'BOXED-NODE)
+         NIL))
+
+(DEFMETHOD REMOVE-SHADING ((IL:|self| WEB-EDITOR))       (IL:* IL:\; "13-Dec-85 15:14")
+
+(IL:* IL:|;;;| "gets rid of all shading in the lattice")
+
+   (IL:|for| IL:|node| IL:|in| (IL:|fetch| IL:GRAPHNODES
+                                          IL:|of| (IL:WINDOWPROP (SLOT-VALUE IL:|self|
+                                                                            'WINDOW)
+                                                             'IL:GRAPH))
+      IL:|do| (DISPLAY-NODE-SHADING IL:|self| IL:|node| IL:WHITESHADE)))
+
+(DEFMETHOD FLASH-NODE ((IL:|self| WEB-EDITOR)
+                           IL:|node| IL:N IL:|flashTime| IL:|leaveFlipped?|)
+                                                             (IL:* IL:\; "12-Dec-84 16:09")
+                                                             (IL:* IL:\; "Flip node N times")
+   (IL:SETQ IL:|node| (IL:FASSOC (COND
+                                    ((IL:LITATOM IL:|node|)
+                                     (IL:SETQ IL:|node| (IL:|GetObjectRec| IL:|node|)))
+                                    (T IL:|node|))
+                             (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP
+                                                                        (SLOT-VALUE IL:|self|
+                                                                               'WINDOW)
+                                                                        'IL:GRAPH))))
+   (IL:|if| IL:|node|
+       IL:|then| (IL:|for| IL:\i IL:|from| 1 IL:|to| (OR IL:N 3)
+                        IL:|do| (IL:FLIPNODE IL:|node| (SLOT-VALUE IL:|self| 'WINDOW))
+                              (IL:DISMISS (OR IL:|flashTime| 300))
+                              (IL:FLIPNODE IL:|node| (SLOT-VALUE IL:|self| 'WINDOW))
+                              (IL:DISMISS (OR IL:|flashTime| 300)))
+             (IL:|if| IL:|leaveFlipped?|
+                 IL:|then| (IL:FLIPNODE IL:|node| (SLOT-VALUE IL:|self| 'WINDOW)))))
+
+(DEFMETHOD FLIP-NODE ((SELF WEB-EDITOR)
+                          OBJECT)                            (IL:* IL:\; "13-Dec-85 15:18")
+                                                             (IL:* IL:\; 
+                           "Inverts the video around the node in the graph representing the object")
+   (LET ((NODE (IL:FASSOC OBJECT (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP
+                                                                            (SLOT-VALUE SELF
+                                                                                   'WINDOW)
+                                                                            'IL:GRAPH)))))
+        (AND NODE (DISPLAY-NODE-SHADING SELF NODE (IL:INVERTED/SHADE/FOR/GRAPHER (IL:|fetch|
+                                                                                  IL:NODELABELSHADE
+                                                                                    IL:|of|
+                                                                                    NODE))))))
+
+(DEFMETHOD POSITION-NODE ((SELF WEB-EDITOR)
+                              OBJECT WINDOW-X WINDOW-Y)      (IL:* IL:\; "10-Dec-84 18:24")
+
+(IL:* IL:|;;;| "scrolls the window so that the node is in the given position of the window.  If windowX or windowY is a FLOATP, it it taken to be a window-relative postion;  if a FIXP, it is a window-absolute position.")
+
+   (LET ((REGION (NODE-REGION SELF OBJECT)))
+        (IL:|if| REGION
+            IL:|then| (SCROLL-WINDOW SELF (IL:|fetch| IL:LEFT IL:|of| REGION)
+                                 (IL:|fetch| IL:BOTTOM IL:|of| REGION)
+                                 WINDOW-X WINDOW-Y))))
+(IL:DEFINEQ
+
+(BOX-PRINT-STRING
+  (IL:LAMBDA (STRING MAX-CHARS-WIDTH MAX-LINES FONT OLD-BITMAP)
+                                                        (IL:* IL:\; "Edited 29-Jan-88 15:06 by Rao")
+
+    (IL:* IL:|;;| 
+  "return a bitmap containing the string, in the given font, with MAX-WIDTH at most width")
+                                                             (IL:* IL:\; 
+                                                           "sizes of NULL or 0 mean no max size")
+    (IL:SETQ MAX-CHARS-WIDTH (OR MAX-CHARS-WIDTH 0))
+    (IL:SETQ MAX-LINES (OR MAX-LINES 0))
+    (IL:|if| (IL:ZEROP MAX-CHARS-WIDTH)
+        IL:|then|                                        (IL:* IL:\; 
+                                                        "no max width, then just return the STRING")
+              STRING
+      IL:|else|
+      (PROG ((MAX-WIDTH (IL:ITIMES MAX-CHARS-WIDTH (IL:STRINGWIDTH "A" FONT)))
+             (NCHARS (IL:NCHARS STRING))
+             (NLINES 0)
+             (SPOS 0)
+             (REGION (IL:CONSTANT (IL:|create| IL:REGION)))
+             (TRUE-MAX-WIDTH 0)
+             NEXTPOS DSP SUBSTR)
+            (IL:SETQ STRING (IL:MKSTRING STRING))            (IL:* IL:\; 
+                                                 "we need to find the size of the resultant bitmap")
+        IL:NEXTBREAK
+            (IL:|if| (IL:ILESSP SPOS NCHARS)
+                IL:|then| (IL:|add| NLINES 1)        (IL:* IL:\; 
+                                                 "at least one character, even if exceed MAX-WIDTH")
+                      (IL:SETQ NEXTPOS (IL:IMAX 1 (CAR (BREAK-STRING-FOR-BOXING
+                                                        (IL:SUBSTRING STRING (IL:ADD1 SPOS)
+                                                               -1)
+                                                        MAX-WIDTH FONT))))
+                      (IL:SETQ TRUE-MAX-WIDTH (IL:IMAX TRUE-MAX-WIDTH (IL:STRINGWIDTH
+                                                                       (IL:SUBSTRING STRING
+                                                                              (IL:ADD1 SPOS)
+                                                                              (IL:IPLUS SPOS NEXTPOS)
+                                                                              )
+                                                                       FONT)))
+                      (IL:|add| SPOS NEXTPOS)
+                      (GO IL:NEXTBREAK))
+            (IL:|if| (NOT (IL:ZEROP MAX-LINES))
+                IL:|then| (IL:SETQ NLINES (IL:IMIN MAX-LINES NLINES)))
+                                                             (IL:* IL:\; 
+                                                           "that we have the size, lets build it")
+            (IL:SETQ DSP (IL:DSPCREATE
+                          (IL:|if| (AND OLD-BITMAP
+                                            (NOT (OR (IL:GREATERP TRUE-MAX-WIDTH (IL:BITMAPWIDTH
+                                                                                  OLD-BITMAP))
+                                                     (IL:GREATERP (IL:ITIMES NLINES
+                                                                         (IL:FONTPROP FONT
+                                                                                'IL:HEIGHT))
+                                                            (IL:BITMAPHEIGHT OLD-BITMAP)))))
+                              IL:|then| OLD-BITMAP
+                            IL:|else| (IL:BITMAPCREATE TRUE-MAX-WIDTH (IL:ITIMES
+                                                                           NLINES
+                                                                           (IL:FONTPROP FONT
+                                                                                  'IL:HEIGHT))))))
+            (IL:DSPFONT FONT DSP)
+            (IL:DSPRESET DSP)
+            (IL:SETQ SPOS 0)
+            (IL:|replace| IL:LEFT IL:|of| REGION IL:|with| 0)
+            (IL:|replace| IL:WIDTH IL:|of| REGION IL:|with| TRUE-MAX-WIDTH)
+            (IL:|replace| IL:HEIGHT IL:|of| REGION IL:|with| (IL:FONTPROP FONT
+                                                                                'IL:HEIGHT))
+            (IL:|replace| IL:BOTTOM IL:|of| REGION IL:|with| (IL:ITIMES
+                                                                          NLINES
+                                                                          (IL:FONTPROP FONT
+                                                                                 'IL:HEIGHT)))
+        IL:NEXTPIECE
+            (IL:|add| NLINES -1)
+            (IL:|if| (IL:ILESSP SPOS NCHARS)
+                IL:|then| (IL:SETQ NEXTPOS (IL:IMAX 1 (CAR (BREAK-STRING-FOR-BOXING
+                                                                (IL:SUBSTRING STRING (IL:ADD1 SPOS)
+                                                                       -1)
+                                                                TRUE-MAX-WIDTH FONT))))
+                      (IL:SETQ SUBSTR (IL:SUBSTRING STRING (IL:ADD1 SPOS)
+                                             (IL:IPLUS NEXTPOS SPOS)))
+                      (IL:|replace| IL:BOTTOM IL:|of| REGION
+                         IL:|with| (IL:IDIFFERENCE (IL:|fetch| IL:BOTTOM IL:|of| REGION)
+                                              (IL:|fetch| IL:HEIGHT IL:|of| REGION)))
+                      (IL:|if| (AND (IL:ZEROP NLINES)
+                                        (IL:ILESSP (IL:IPLUS NEXTPOS SPOS)
+                                               NCHARS))
+                          IL:|then|                      (IL:* IL:\; "we need to abbreviate!")
+                                (IL:CENTERPRINTINREGION (IL:CONCAT (IL:SUBSTRING SUBSTR 1 -3)
+                                                               "...")
+                                       REGION DSP)
+                                (GO IL:ALLDONE)
+                        IL:|else|                        (IL:* IL:\; "out this piece")
+                              (IL:CENTERPRINTINREGION SUBSTR REGION DSP)
+                              (IL:|add| SPOS NEXTPOS)
+                              (GO IL:NEXTPIECE)))
+        IL:ALLDONE
+            (RETURN (IL:DSPDESTINATION NIL DSP))))))
+
+(BREAK-STRING-FOR-BOXING
+  (IL:LAMBDA (IL:MSG IL:WIDTH IL:FONT)                       (IL:* IL:\; "11-Dec-84 10:29")
+
+         (IL:* IL:\; IL:|Stolen| IL:|from| IL:|the| IL:|function| IL:ICONW.FORMATLINE 
+       IL:-- IL:|modified| IL:|to| IL:|try| IL:|to| IL:|break| IL:|at| "word" 
+       IL:|boundaries,| IL:|whatever| IL:|they| IL:|are|)
+
+         (IL:* IL:\; IL:\a IL:|list| IL:|of| IL:|the| IL:|char#| IL:|relative| IL:|to| 
+       IL:|char| 1 IL:|of| IL:|where| IL:|to| IL:|break| IL:|next| IL:|line,| IL:|and| 
+       IL:|how| IL:|much| IL:|space| IL:|was| LEFT IL:|over|
+       (IL:|for| IL:|centering| IL:&\c))
+
+    (COND
+       (IL:MSG                                               (IL:* IL:\; IL:|there| IL:|really| 
+                                                           IL:|is| IL:\a IL:|title,| IL:|go| 
+                                                           IL:|ahead| IL:|and| IL:|format| 
+                                                           IL:|the| IL:|next| IL:|line.|)
+              (IL:|bind| (IL:TX IL:_ 0)
+                     (IL:LASTB IL:_ 0)
+                     (IL:CH IL:_ 0)
+                     (IL:TMSG IL:_ (IL:OPENSTRINGSTREAM IL:MSG))
+                     (IL:MSGLEN IL:_ (IL:NCHARS IL:MSG)) IL:|for| IL:I IL:|from| 1
+                 IL:|by| 1
+                 IL:|do|                                 (IL:* IL:\; IL:|thru| IL:|the| 
+                                                           IL:|characters| IL:|one| IL:|by| 
+                                                           IL:|one.|)
+                       (COND
+                          ((IL:IGREATERP IL:TX IL:WIDTH)     (IL:* IL:\; IL:|past| IL:|the| 
+                                                           IL:|right| IL:|margin.|
+                                                           IL:|Time| IL:|to| IL:|stop.|)
+                           (IL:CLOSEF? IL:TMSG)
+                           (RETURN (COND
+                                      ((IL:LISTP IL:LASTB)   (IL:* IL:\; IL:|is| IL:\a IL:|space| 
+                                                           IL:|we| IL:|can| IL:|break| IL:|the| 
+                                                           IL:|line| IL:|at.|
+                                                           IL:|Break| IL:|there.|)
+                                       IL:LASTB)
+                                      (T 
+
+         (IL:* IL:\; IL:|were| IL:|no| IL:|spaces| IL:|on| IL:|this| IL:|line.|
+       IL:|Break| IL:|after| IL:|the| IL:|last| IL:|character| IL:|that| IL:|did| 
+       IL:|fit.|)
+
+                                         (CONS (IL:IDIFFERENCE IL:I 2)
+                                               (IL:IDIFFERENCE IL:WIDTH (IL:IDIFFERENCE IL:TX
+                                                                               (IL:CHARWIDTH IL:CH 
+                                                                                      IL:FONT))))))))
+                          ((IL:EOFP IL:TMSG)                 (IL:* IL:\; IL:|was| IL:|the| 
+                                                           IL:|last| IL:|character.|)
+                           (IL:CLOSEF? IL:TMSG)
+                           (RETURN (CONS (IL:SUB1 IL:I)
+                                         (IL:IDIFFERENCE IL:WIDTH IL:TX))))
+                          (T                                 (IL:* IL:\; IL:|at| IL:|the| 
+                                                           IL:|next| IL:|character.|)
+                             (IL:SETQ IL:CH (IL:BIN IL:TMSG))
+                             (IL:SELCHARQ IL:CH
+                                   ((IL:SPACE IL:\. IL:\: IL:\; IL:\, / IL:\\ IL:* - IL:\#) 
+
+         (IL:* IL:\; IL:|where| IL:|word| IL:|breaks| IL:|are,| IL:|so| IL:|we| IL:|can| 
+       IL:|back| IL:|up| IL:|and| IL:|split| IL:|lines| IL:|there| IL:|if| 
+       IL:|possible.|)
+
+                                          (IL:SETQ IL:LASTB (CONS IL:I (IL:IDIFFERENCE IL:WIDTH IL:TX
+                                                                              ))))
+                                   (IL:CR                    (IL:* IL:\; IL:|forces| IL:\a 
+                                                           IL:|new| IL:|line.|)
+                                          (RETURN (CONS (IL:IMINUS IL:I)
+                                                        (IL:IDIFFERENCE IL:WIDTH IL:TX))))
+                                   (IL:|if| (AND (NOT (IL:U-CASEP (IL:CHARACTER IL:CH)))
+                                                     (NOT (IL:EOFP IL:TMSG))
+                                                     (IL:U-CASEP (IL:PEEKC IL:TMSG)))
+                                       IL:|then|         (IL:* IL:\; IL:|from| IL:|upper| 
+                                                           IL:|to| IL:|lower| IL:|case| IL:|is| 
+                                                           IL:|also| IL:\a IL:|word| IL:|break|)
+                                             (IL:SETQ IL:LASTB (CONS IL:I (IL:IDIFFERENCE IL:WIDTH 
+                                                                                 IL:TX)))))
+                             (IL:SETQ IL:TX (IL:IPLUS IL:TX (IL:CHARWIDTH IL:CH IL:FONT)))))))
+       (T                                                    (IL:* IL:\; IL:|isn't| IL:\a 
+                                                           IL:|title;| IL:|return| IL:\a 
+                                                           IL:|dummy| IL:|entry| IL:|for| 
+                                                           IL:|the| IL:|line| IL:|formatter.|)
+          (CONS 0 IL:WIDTH)))))
+
+(BOX-WINDOW-NODE
+  (IL:LAMBDA (IL:|nodeLabel| WINDOW)                (IL:* IL:\; "Edited 29-Jan-88 11:31 by Rao")
+                                                             (IL:* IL:\; " 7-Sep-84 14:36")
+
+    (IL:* IL:|;;| "a box around the node with nodeLabel in the graph.  A nodeLabel in browsers is an object.  Does nothing if node not found.")
+
+    (PROG (IL:|node| IL:|nodes|)
+          (COND
+             ((AND (IL:WINDOWP WINDOW)
+                   (IL:SETQ IL:|nodes| (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP
+                                                                                  WINDOW
+                                                                                  'IL:GRAPH)))
+                   (IL:SETQ IL:|node| (IL:FASSOC IL:|nodeLabel| IL:|nodes|)))
+              (IL:DRAWAREABOX (IL:GN/LEFT IL:|node|)
+                     (IL:GN/BOTTOM IL:|node|)
+                     (IL:|fetch| IL:NODEWIDTH IL:|of| IL:|node|)
+                     (IL:|fetch| IL:NODEHEIGHT IL:|of| IL:|node|)
+                     1
+                     'IL:INVERT WINDOW))))))
+)
+
+
+
+(IL:* IL:\; "Button Events")
+
+(IL:DEFINEQ
+
+(FIND-SELECTED-NODE
+  (IL:LAMBDA (WINDOW)                               (IL:* IL:\; "Edited 12-Nov-87 01:30 by Rao")
+                                                             (IL:* IL:\; "10-Dec-84 17:53")
+
+    (IL:* IL:|;;| "Used in BUTTONEVENTFN and gets called whenever cursor moves or button is down.  Adapted from APPLYTOSELECTEDNODE in GRAPHER package;  returns the selected item rather than applying a function on the inside of the button event fn.")
+
+    (IL:* IL:|;;| 
+  "Also this was modified to pop up the middle button menu on button down rather than button up.")
+
+    (PROG ((LOOPS-WINDOW (IL:WINDOWPROP WINDOW 'WEB-EDITOR))
+           (NODELST (IL:|fetch| (IL:GRAPH IL:GRAPHNODES) IL:|of| (IL:WINDOWPROP WINDOW
+                                                                                'IL:GRAPH)))
+           (DS (IL:WINDOWPROP WINDOW 'IL:DSP))
+           BUTTON OLDPOS REG NOW NEAR)                       (IL:* IL:\; 
+                                                           "note which button is down.")
+                                                             (IL:* IL:\; 
+                                                           "get the region of this window.")
+          (IL:SETQ REG (IL:WINDOWPROP WINDOW 'IL:REGION))
+          (IL:|until| (IL:LASTMOUSESTATE (OR IL:LEFT IL:MIDDLE)) IL:|do| (IL:GETMOUSESTATE))
+          (IL:SETQ NEAR (IL:NODELST/AS/MENU NODELST (IL:SETQ OLDPOS (IL:CURSORPOSITION NIL DS))))
+      IL:FLIP
+          
+
+     (IL:* IL:|;;| "This is kirk's quick hack to get middle button to bring up immediately.")
+
+          (WHEN (IL:LASTMOUSESTATE IL:MIDDLE)
+              (RETURN (IL:|fetch| IL:NODEID IL:|of| NEAR)))
+          (AND NOW (IL:FLIPNODE NOW DS))
+          (AND NEAR (IL:FLIPNODE NEAR DS))
+          (IL:SETQ NOW NEAR)
+      IL:LP
+                                                             (IL:* IL:\; 
+                                                       "wait for a button up or move out of region")
+          (IL:GETMOUSESTATE)
+          (COND
+             ((IL:LASTMOUSESTATE (AND (NOT IL:LEFT)
+                                      (NOT IL:MIDDLE)))      (IL:* IL:\; 
+                                                           "left button up, process it.")
+              (AND NOW (IL:FLIPNODE NOW DS))                 (IL:* IL:\; 
+                                                           "NOW node has been selected.")
+              (RETURN (IL:|fetch| IL:NODEID IL:|of| NOW)))
+             ((NOT (IL:INSIDE? (IL:WINDOWPROP WINDOW 'IL:REGION)
+                          IL:LASTMOUSEX IL:LASTMOUSEY))      (IL:* IL:\; 
+                                                           "outside of region, return")
+              (AND NOW (IL:FLIPNODE NOW DS))
+              (RETURN))
+             ((EQ NOW (IL:SETQ NEAR (IL:NODELST/AS/MENU NODELST (IL:CURSORPOSITION NIL DS OLDPOS))))
+              (GO IL:LP))
+             (T (GO IL:FLIP))))))
+)
+
+(DEFMETHOD BUTTON-EVENT-FN ((SELF WEB-EDITOR))           (IL:* IL:\; " 2-Jan-86 16:41")
+                                                             (IL:* IL:\; 
+                                            "Called when there is a button event in a Loops Window")
+   (LET ((WINDOW (SLOT-VALUE SELF 'WINDOW)))
+        (OR (IL:ERSETQ (COND
+                          ((NULL (IL:INSIDEP (IL:DSPCLIPPINGREGION NIL WINDOW)
+                                        (IL:LASTMOUSEX WINDOW)
+                                        (IL:LASTMOUSEY WINDOW)))
+                           (TITLE-SELECTION SELF))
+                          ((IL:MOUSESTATE IL:LEFT)
+                           (LEFT-SELECTION SELF))
+                          ((IL:MOUSESTATE IL:MIDDLE)
+                           (MIDDLE-SELECTION SELF))
+                          ((IL:MOUSESTATE IL:RIGHT)
+                           (RIGHT-SELECTION SELF)))))))
+
+(DEFMETHOD LEFT-SELECTION ((SELF WEB-EDITOR))
+   (IF (MOVE-DOWN-P)
+       (IF (SLOT-VALUE SELF 'NODE-MOVER-P)
+           (NODE-MOVE SELF)
+           (NODE-MOVE-SHALLOW SELF))
+       (NODE-SELECTION SELF 'IL:LEFT)))
+
+(DEFMETHOD MIDDLE-SELECTION ((SELF WEB-EDITOR))          (IL:* IL:\; "15-May-85 19:04")
+
+   (IL:* IL:|;;| "This function called from the GRAPHER package when a node is selected with the middle mouse button.  If no node is selected then just returns.")
+
+   (PROG (SELECTION OBJECT (WINDOW (SLOT-VALUE SELF 'WINDOW))
+                (WEB-EDITOR SELF))
+         (DECLARE (IL:SPECVARS OBJECT WEB-EDITOR))
+         (COND
+            ((NULL (IL:SETQ OBJECT (FIND-SELECTED-NODE WINDOW)))
+             (RETURN)))
+         (SETF (SLOT-VALUE WEB-EDITOR 'LAST-SELECTED-OBJECT)
+               OBJECT)
+         (IL:GETMOUSESTATE)
+         (FLIP-NODE SELF OBJECT)
+         (IL:SETQ SELECTION (OR (NODE-ACTION SELF OBJECT 'IL:MIDDLE)
+                                (PROGN (FLIP-NODE SELF OBJECT)
+                                       (RETURN NIL))))
+         (FLIP-NODE SELF OBJECT)
+         (DO-SELECTED-COMMAND WEB-EDITOR SELECTION OBJECT)))
+
+(DEFMETHOD RIGHT-SELECTION ((SELF WEB-EDITOR))           (IL:* IL:\; "17-Apr-84 15:46")
+                                                             (IL:* IL:\; 
+                                                           "Do RightButtonItems on selection.")
+   (LET* ((CHOICE (CHOICE-MENU SELF 'RIGHT-BUTTON-ITEMS)))
+         (IF CHOICE (FUNCALL CHOICE SELF))))
+
+(DEFMETHOD TITLE-SELECTION ((SELF WEB-EDITOR))           (IL:* IL:\; "17-Apr-84 15:35")
+
+   (IL:* IL:|;;| " Do TitleItems if selected in title area.  Replaces TitleSelection in Window because this one does evaluation in TTY process, and saves events on history")
+
+   (LET* ((CHOICE (CHOICE-MENU SELF 'TITLE-ITEMS)))
+         (IF CHOICE (FUNCALL CHOICE SELF))))
+
+(DEFMETHOD NODE-SELECTION ((SELF WEB-EDITOR)
+                               BUTTON)
+   (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW))
+          (OBJECT (FIND-SELECTED-NODE WINDOW)))
+         (DECLARE (IL:SPECVARS OBJECT))                  (IL:* IL:\; "SPECVARS for whenHeldFn")
+         (IF (LISTP OBJECT)
+             (SETQ OBJECT (CAR OBJECT)))
+         (COND
+            ((NOT (NULL OBJECT))
+             (SETF (SLOT-VALUE SELF 'LAST-SELECTED-OBJECT)
+                   OBJECT)))
+         (IL:GETMOUSESTATE)
+         (WHEN OBJECT
+             (LET ((SELECTOR (NODE-ACTION SELF OBJECT BUTTON)))
+                  (COND
+                     (SELECTOR (DO-SELECTED-COMMAND SELF SELECTOR OBJECT)))))))
+
+(DEFMETHOD NODE-ACTION ((SELF WEB-EDITOR)
+                            NODE BUTTON)                     (IL:* IL:\; " 8-Apr-87 17:11")
+   (DECLARE (IL:SPECVARS WINDOW-FOR-MENU))
+   (LET ((WINDOW-FOR-MENU SELF))
+        (IL:GETMOUSESTATE)
+        (CHOICE-MENU SELF 
+
+               (IL:* IL:|;;| " A Hook for letting nodes tailor menu items.")
+
+               (NODE-MENU-ITEMS NODE BUTTON))))
+
+(DEFMETHOD NODE-MENU-ITEMS ((NODE WEB-NODE)
+                                BUTTON)
+   (CASE BUTTON
+       (IL:LEFT 'LEFT-BUTTON-ITEMS)
+       (IL:MIDDLE 'MIDDLE-BUTTON-ITEMS)))
+
+(DEFMETHOD CHOICE-MENU ((SELF WEB-EDITOR)
+                            ITEM-CV)                         (IL:* IL:\; "29-Dec-85 13:54")
+
+   (IL:* IL:|;;| 
+ "Create a menu which allows subitems to be displayed.  Cache it in  the web-editor ")
+
+   (LET (ITEMS MENU)
+        (SETQ MENU (REST (ASSOC ITEM-CV (SLOT-VALUE SELF 'MENU-CACHE))))
+        (COND
+           ((AND MENU (IL:TYPE? IL:MENU MENU))
+            (IL:MENU MENU))
+           ((NOT (LISTP (SETQ ITEMS (GET-MENU-ITEMS SELF ITEM-CV))))
+            ITEMS)
+           (T (IL:SETQ MENU (IL:CREATE IL:MENU
+                                   IL:ITEMS IL:_ ITEMS
+                                   IL:MENUOFFSET IL:_ (IL:CREATEPOSITION -1 0)
+                                   IL:WHENSELECTEDFN IL:_ 'WEB-MENU-WHENSELECTEDFN
+                                   IL:WHENHELDFN IL:_ 'WINDOW-WHEN-HELD-FN
+                                   IL:CHANGEOFFSETFLG IL:_ T
+                                   IL:CENTERFLG IL:_ T))     (IL:* IL:\; "Cache menu if menus is T")
+              (IF (SLOT-VALUE SELF 'CACHE-MENU-P)
+                  (SETF (SLOT-VALUE SELF 'MENU-CACHE)
+                        (ACONS ITEM-CV MENU (SLOT-VALUE SELF 'MENU-CACHE))))
+              (IL:MENU MENU)))))
+
+(DEFMETHOD DO-SELECTED-COMMAND ((WEB-EDITOR WEB-EDITOR)
+                                    COMMAND OBJ &OPTIONAL NODE)
+                                                             (IL:* IL:\; "17-Sep-86 17:49")
+
+   (IL:* IL:|;;| "Do the selected command or forwards it to the object")
+
+   (IF COMMAND
+
+       (IL:* IL:|;;| "Take care of being passed in a dummy node from browser in Lattice mode.  --- Dummy nodes are indicated by having the object in a list")
+
+       (LET ((ARGS (IF (IL:LISTP COMMAND)
+                       (CDR COMMAND)
+                       NIL))
+             (COMMAND (IF (IL:LISTP COMMAND)
+                          (CAR COMMAND)
+                          COMMAND))
+             (OBJ (IF (IL:LISTP OBJ)
+                      (CAR OBJ)
+                      OBJ)))
+            (WHEN (IL:FMEMB COMMAND (SLOT-VALUE WEB-EDITOR 'LOCAL-COMMANDS))
+                (SETQ ARGS (CONS OBJ ARGS))
+                (SETQ OBJ WEB-EDITOR))
+
+            (IL:* IL:|;;| 
+   "Grays out the node at the beginning of the command, and ungrays it when the command completes.")
+
+            (SETQ NODE OBJ)
+            (IF NODE
+                (PROGN (SHADE-NODE WEB-EDITOR NODE IL:GRAYSHADE2)
+                       (IL:BLOCK 500)
+                       (SHADE-NODE WEB-EDITOR NODE IL:WHITESHADE)
+                       (APPLY COMMAND OBJ ARGS))
+                (APPLY COMMAND OBJ ARGS)))))
+
+(DEFMETHOD WHEN-MENU-ITEM-HELD ((SELF WEB-EDITOR)
+                                    ITEM MENU KEY)           (IL:* IL:\; " 8-Apr-87 17:13")
+
+(IL:* IL:|;;;| "What to do when the menu item is held")
+
+   (IL:PROMPTPRINT (OR (COND
+                          ((IL:NLISTP ITEM)
+                           NIL)
+                          (T (CADDR ITEM)))
+                       "When released this item will be selected")))
+
+(DEFMETHOD ITEM-MENU ((SELF WEB-EDITOR)
+                          ITEMS TITLE)                       (IL:* IL:\; "21-Apr-84 09:31")
+                                                             (IL:* IL:\; 
+                       "Create a simnple (one level) menu which will not overflow height of screen")
+   (IL:|create| IL:MENU
+          IL:ITEMS IL:_ ITEMS
+          IL:MENUCOLUMNS IL:_ (IL:ADD1 (IL:IQUOTIENT (IL:ITIMES (IL:FONTHEIGHT IL:MENUFONT)
+                                                            (IL:LENGTH ITEMS))
+                                              750))
+          IL:TITLE IL:_ TITLE
+          IL:CHANGEOFFSETFLG IL:_ T))
+
+(DEFMETHOD GET-MENU-ITEMS ((SELF WEB-EDITOR)
+                               ITEM-CV)                      (IL:* IL:\; "23-Oct-84 12:36")
+                                                             (IL:* IL:\; "Get item list for menu")
+   (SLOT-VALUE SELF ITEM-CV))
+
+(DEFMETHOD CLEAR-MENU-CACHE ((SELF WEB-EDITOR))          (IL:* IL:\; "11-Apr-86 14:46")
+                                                             (IL:* IL:\; 
+                                                           "Delete Menus saved on menus")
+   (SETF (SLOT-VALUE SELF 'MENU-CACHE)
+         NIL)
+   SELF)
+(IL:DEFINEQ
+
+(WEB-MENU-WHENSELECTEDFN
+  (IL:LAMBDA (ITEM MENU BUTTON)                     (IL:* IL:\; "Edited 14-Jul-87 17:43 by Rao")
+                                                             (IL:* IL:\; "13-DEC-83 21:03")
+    (PROG (SECOND-ELEMENT)
+          (RETURN (COND
+                     ((IL:NLISTP ITEM)
+                      ITEM)
+                     ((IL:NLISTP (IL:SETQ SECOND-ELEMENT (CADR ITEM)))
+                      SECOND-ELEMENT)
+                     ((EQ (CAR SECOND-ELEMENT)
+                          'PROGN)
+                      (IL:EVAL SECOND-ELEMENT))
+                     (T SECOND-ELEMENT))))))
+
+(WINDOW-WHEN-HELD-FN
+  (LAMBDA (ITEM MENU KEY)                           (IL:* IL:\; "Edited  9-Jul-87 11:58 by Rao")
+                                                             (IL:* IL:\; "29-Dec-85 15:28")
+                                                             (IL:* IL:\; 
+                                        "Send to window the message to respond to time out on menu")
+         (DECLARE (IL:SPECVARS WINDOW-FOR-MENU))
+         (WHEN-MENU-ITEM-HELD WINDOW-FOR-MENU ITEM MENU KEY)))
+)
+(IL:DEFINEQ
+
+(SUB-ITEM-SELECTION
+  (IL:LAMBDA (ITEM MENU BUTTON)                     (IL:* IL:\; "Edited 14-Jul-87 17:13 by Rao")
+                                                             (IL:* IL:\; "13-DEC-83 21:03")
+
+    (IL:* IL:|;;| "menu WHENSELECTEDFN which allows differential selection on LEFT and middle button.  For such differential selection item should be of form --- (itemSeenInMenu (leftValue midValue)) --- where midValue can be an atom which is directly returned when item is selected with middle, or midValue can be an itemList, which will be displayed in a subselection menu")
+
+    (PROG (IT IT1)
+          (RETURN (COND
+                     ((IL:NLISTP ITEM)
+                      ITEM)
+                     ((IL:NLISTP (IL:SETQ IT (CADR ITEM)))
+                      IT)
+                     ((EQ (IL:SETQ IT1 (CAR IT))
+                          'QUOTE)
+                      (CADR IT))
+                     ((EQ IT1 'PROGN)
+                      (IL:EVAL IT))
+                     ((IL:LISTP IT1)
+                      (IL:EVAL IT1))
+                     (T IT1))))))
+
+(DUAL-SUB-ITEMS
+  (IL:LAMBDA (MENU ITEM)                            (IL:* IL:\; "Edited 14-Jul-87 17:14 by Rao")
+                                                             (IL:* IL:\; "13-DEC-83 21:07")
+
+    (IL:* IL:|;;| "menu WHENSELECTEDFN which allows differential selection on LEFT and middle button.  For such differential selection item should be of form --- (itemSeenInMenu (leftValue midValue)) --- where midValue can be an atom which is directly returned when item is selected with middle, or midValue can be an itemList, which will be displayed in a subselection menu")
+
+    (PROG (IT IT1)
+          (RETURN (COND
+                     ((OR (IL:NLISTP ITEM)
+                          (IL:NLISTP (IL:SETQ IT (CADR ITEM)))
+                          (EQ (IL:SETQ IT1 (CAR IT))
+                              'QUOTE)
+                          (EQ IT1 'PROGN)
+                          (IL:NLISTP (IL:SETQ IT1 (CADR IT))))
+                      NIL)
+                     (T IT1))))))
+
+(WINDOW-WHEN-HELD-FN
+  (LAMBDA (ITEM MENU KEY)                           (IL:* IL:\; "Edited  9-Jul-87 11:58 by Rao")
+                                                             (IL:* IL:\; "29-Dec-85 15:28")
+                                                             (IL:* IL:\; 
+                                        "Send to window the message to respond to time out on menu")
+         (DECLARE (IL:SPECVARS WINDOW-FOR-MENU))
+         (WHEN-MENU-ITEM-HELD WINDOW-FOR-MENU ITEM MENU KEY)))
+
+(DO-MENU-METHOD
+  (IL:LAMBDA (OBJECT ITEMS)                         (IL:* IL:\; "Edited 14-Jul-87 17:15 by Rao")
+                                                             (IL:* IL:\; "13-NOV-83 16:20")
+    (PROG ((SELECTOR (AND ITEMS (DUAL-MENU ITEMS))))
+          (AND SELECTOR (RETURN (FUNCALL SELECTOR OBJECT))))))
+
+(DUAL-MENU
+  (IL:LAMBDA (ITEMS WHEN-HELD-FN)                   (IL:* IL:\; "Edited 14-Jul-87 17:16 by Rao")
+                                                             (IL:* IL:\; " 9-FEB-84 16:17")
+                                                             (IL:* IL:\; 
+                 "and pops up a menu which allows differential selection on LEFT an middle buttons")
+    (IL:MENU (IL:|create| IL:MENU
+                    IL:ITEMS IL:_ ITEMS
+                    IL:WHENSELECTEDFN IL:_ 'SUB-ITEM-SELECTION
+                    IL:SUBITEMFN IL:_ 'DUAL-SUB-ITEMS
+                    IL:WHENHELDFN IL:_ WHEN-HELD-FN
+                    IL:CHANGEOFFSETFLG IL:_ T))))
+
+(DUAL-SELECTION
+  (IL:LAMBDA (ITEM MENU BUTTON)                     (IL:* IL:\; "Edited 14-Jul-87 17:28 by Rao")
+                                                             (IL:* IL:\; "29-MAR-83 17:57")
+
+    (IL:* IL:|;;| "MENU WHENSELECTEDFN which allows differential selection on LEFT and middle button.  For such differential selection ITEM should be of form --- (itemSeenInMenu (leftValue midValue)) --- where midValue can be an atom which is directly returned when ITEM is selected with middle, or midValue can be an itemList, which will be displayed in a subselection MENU")
+
+    (PROG (IT IT1)
+          (RETURN (COND
+                     ((IL:NLISTP ITEM)
+                      ITEM)
+                     ((IL:NLISTP (IL:SETQ IT (CADR ITEM)))
+                      IT)
+                     ((EQ (IL:SETQ IT1 (CAR IT))
+                          'QUOTE)
+                      (CADR IT))
+                     ((EQ IT1 'PROGN)
+                      (IL:EVAL IT))
+                     ((EQ BUTTON 'IL:LEFT)
+                      (COND
+                         ((IL:LISTP IT1)
+                          (IL:EVAL IT1))
+                         (T IT1)))
+                     ((IL:NLISTP (IL:SETQ IT1 (CADR IT)))
+                      IT1)
+                     (T (DUAL-MENU IT1)))))))
+)
+
+
+
+(IL:* IL:\; "Node Moving Protocol")
+
+
+(DEFMETHOD NODE-MOVE ((SELF WEB-EDITOR))
+   (LET ((OLD-REGIONS (MAKE-REG-ASSOC SELF))
+         NEW-REGIONS MOVED-PAIR NEW-FATHER CLOSEST-PAIR)
+        (NODE-MOVE-SHALLOW SELF)
+        (SETQ NEW-REGIONS (MAKE-REG-ASSOC SELF))
+        (SETQ MOVED-PAIR (IL:|for| |npair| IL:|in| NEW-REGIONS IL:|as| |opair|
+                            IL:|in| OLD-REGIONS IL:|thereis| (NOT (IL:EQUAL (CAR |opair|)
+                                                                                 (CAR |npair|)))))
+        (WHEN (AND MOVED-PAIR 
+
+                   (IL:* IL:|;;| "The moved guy has a parent")
+
+                   (SLOT-VALUE (CDR MOVED-PAIR)
+                          'PARENT))
+            (IL:DREMOVE MOVED-PAIR NEW-REGIONS)
+            (SETQ NEW-REGIONS 
+
+                  (IL:* IL:|;;| "Collect the pairs that havn't changed.")
+
+                  (IL:|bind| (SCIONS-OF-MOVED IL:_ (SCIONS (CDR MOVED-PAIR))) IL:|for| PAIR
+                     IL:|in| NEW-REGIONS IL:|unless| (IL:MEMBER (CDR PAIR)
+                                                                    SCIONS-OF-MOVED) IL:|collect|
+                                                                                     PAIR))
+            (SETQ CLOSEST-PAIR (IL:|bind| (\b IL:_ (IL:|fetch| IL:BOTTOM IL:|of|
+                                                                                 (CAR MOVED-PAIR)))
+                                      (\l IL:_ (IL:|fetch| IL:LEFT IL:|of| (CAR MOVED-PAIR)))
+                                  IL:|for| |pair| IL:|in| NEW-REGIONS
+                                  IL:|smallest| (IL:PLUS (ABS (IL:IDIFFERENCE (IL:|fetch|
+                                                                                   IL:BOTTOM
+                                                                                     IL:|of|
+                                                                                     (CAR |pair|))
+                                                                         \b))
+                                                           (ABS (IL:IDIFFERENCE (IL:|fetch|
+                                                                                 IL:LEFT
+                                                                                   IL:|of|
+                                                                                   (CAR |pair|))
+                                                                       \l)))))
+
+            (IL:* IL:|;;| 
+          "Either make moved node a sibling or a child of the node it is now closest to.")
+
+            (IL:|if| (IL:IGREATERP (IL:IDIFFERENCE (IL:|fetch| IL:LEFT IL:|of|
+                                                                               (CAR MOVED-PAIR))
+                                              (IL:|fetch| IL:LEFT IL:|of| (CAR CLOSEST-PAIR))
+                                              )
+                                15)
+                IL:|then| (IL:SETQ NEW-FATHER (CDR CLOSEST-PAIR))
+              IL:|else| (IL:SETQ NEW-FATHER (OR (SLOT-VALUE (CDR CLOSEST-PAIR)
+                                                           'PARENT)
+                                                    (CDR CLOSEST-PAIR))))
+            (MOVE-NODE (CDR MOVED-PAIR)
+                   NEW-FATHER)
+            (REORDER-TREE SELF NEW-FATHER))
+        (RECOMPUTE SELF)))
+
+(DEFMETHOD NODE-MOVE-SHALLOW ((SELF WEB-EDITOR))
+
+   (IL:* IL:|;;| "Just moves the node graphically with no deep impact")
+
+   (LET ((WINDOW (SLOT-VALUE SELF 'WINDOW)))
+        (IL:RESETLST
+            (IL:RESETSAVE NIL (LIST (IL:FUNCTION IL:DSPOPERATION)
+                                    (IL:DSPOPERATION 'IL:INVERT WINDOW)
+                                    WINDOW))
+            (IL:GETMOUSESTATE)                               (IL:* IL:\; "Here to move a node.")
+            (IL:DSPOPERATION 'IL:INVERT WINDOW)
+            (IL:EDITMOVENODE WINDOW))))
+
+(DEFMETHOD SCIONS ((SELF WEB-NODE))                      (IL:* IL:\; "14-Nov-86 03:01")
+                                                             (IL:* IL:\; "Used by the Node Mover")
+   (LET ((TO-LINKS (GET-TO-LINKS SELF)))
+        (APPEND TO-LINKS (IL:|for| IL:|child| IL:|in| TO-LINKS IL:|join| (SCIONS 
+                                                                                           IL:|child|
+                                                                                            )))))
+
+(DEFMETHOD MAKE-REG-ASSOC ((SELF WEB-EDITOR))            (IL:* IL:\; "14-Nov-86 02:08")
+                                                             (IL:* IL:\; "Ho hum")
+   (IL:|for| X IL:|in| (SLOT-VALUE SELF 'STARTING-LIST) IL:|collect| (CONS (NODE-REGION
+                                                                                        SELF X)
+                                                                                       X)))
+
+(DEFMETHOD REORDER-TREE ((SELF WEB-EDITOR)
+                             ROOT)                           (IL:* IL:\; "14-Nov-86 02:35")
+   (LET ((CHILDREN (GET-TO-LINKS ROOT)))
+        (IF CHILDREN
+            (IL:SORT CHILDREN #'(IL:LAMBDA (C1 C2)
+                                  (LET ((R1 (NODE-REGION SELF C1))
+                                        (R2 (NODE-REGION SELF C2)))
+                                       (IL:LESSP (IL:|fetch| IL:BOTTOM IL:|of| R1)
+                                              (IL:|fetch| IL:BOTTOM IL:|of| R2))))))))
+
+(DEFMETHOD MOVE-NODE ((SELF WEB-NODE)
+                          NEW-PARENT)                        (IL:* IL:\; "29-Jan-87 17:55")
+   (LET ((OLD-PARENT (SLOT-VALUE SELF 'PARENT)))
+        (UNLESS (EQ OLD-PARENT NEW-PARENT)
+            (SETF (SLOT-VALUE SELF 'PARENT)
+                  NEW-PARENT)
+            (SETF (SLOT-VALUE OLD-PARENT 'TO-LINKS)
+                  (IL:DREMOVE SELF (SLOT-VALUE OLD-PARENT 'TO-LINKS)))
+            (SETF (SLOT-VALUE NEW-PARENT 'TO-LINKS)
+                  (IL:NCONC1 (SLOT-VALUE NEW-PARENT 'TO-LINKS)
+                         SELF))
+            T)))
+
+
+
+(IL:* IL:\; "")
+
+
+
+
+(IL:* IL:|;;| "")
+
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA )
+
+(IL:ADDTOVAR IL:NLAML )
+
+(IL:ADDTOVAR IL:LAMA WINDOW-WHEN-HELD-FN WINDOW-WHEN-HELD-FN)
+)
+(IL:PUTPROPS IL:WEB-EDITOR IL:COPYRIGHT ("Xerox Corporation" 1987 1988 1989 1991))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL (50310 53152 (WEB-WINDOW-AFTER-MOVE-FN 50323 . 50701) (WEB-WINDOW-BUTTON-EVENT-FN 
+50703 . 51146) (WEB-WINDOW-RESHAPE-FN 51148 . 51704) (WEB-WINDOW-CLOSE-FN 51706 . 52056) (
+IL:|PromptRead| 52058 . 53150)) (53153 53586 (WEB-WINDOW-EXPAND-FN 53166 . 53584)) (57488 65032 (
+TREE-ROOTS 57501 . 62883) (CHILD-NODES 62885 . 63646) (REACHABLE-NODES! 63648 . 65030)) (94827 108235 
+(BOX-PRINT-STRING 94840 . 101302) (BREAK-STRING-FOR-BOXING 101304 . 107100) (BOX-WINDOW-NODE 107102 . 
+108233)) (108273 111315 (FIND-SELECTED-NODE 108286 . 111313)) (119862 121033 (WEB-MENU-WHENSELECTEDFN 
+119875 . 120505) (WINDOW-WHEN-HELD-FN 120507 . 121031)) (121034 126038 (SUB-ITEM-SELECTION 121047 . 
+122147) (DUAL-SUB-ITEMS 122149 . 123158) (WINDOW-WHEN-HELD-FN 123160 . 123684) (DO-MENU-METHOD 123686
+ . 124026) (DUAL-MENU 124028 . 124723) (DUAL-SELECTION 124725 . 126036)))))
+IL:STOP
diff --git a/clos/2.0/boot.lisp b/clos/2.0/boot.lisp
new file mode 100644
index 00000000..5385f6ff
--- /dev/null
+++ b/clos/2.0/boot.lisp
@@ -0,0 +1,1297 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on  2-Apr-91 16:40:32 from source bood
+
+
+
+(in-package "CLOS")
+
+;;; Shadow, Export, Require, Use-package, and Import forms should follow here
+
+
+
+;;; ************************************************************************* Copyright (c) 1985,
+;;; 1986, 1987, 1988, 1989, 1990 Xerox Corporation. All rights reserved. Use and copying of this
+;;; software and preparation of derivative works based upon this software are permitted.  Any
+;;; distribution of this software or derivative works must comply with all applicable United States
+;;; export control laws. This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any specification. Any person
+;;; obtaining a copy of this software is requested to send their name and post office or electronic
+;;; mail address to: CommonLoops Coordinator Xerox PARC 3333 Coyote Hill Rd. Palo Alto, CA 94304 (or
+;;; send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) Suggestions, comments and requests
+;;; for improvements are also welcome.
+;;; ************************************************************************* 
+
+
+#|
+
+The CommonLoops evaluator is meta-circular.  
+
+Most of the code in CLOS is methods on generic functions, including most of
+the code that actually implements generic functions and method lookup.
+
+So, we have a classic bootstrapping problem.   The solution to this is to
+first get a cheap implementation of generic functions running, these are
+called early generic functions.  These early generic functions and the
+corresponding early methods and early method lookup are used to get enough
+of the system running that it is possible to create real generic functions
+and methods and implement real method lookup.  At that point (done in the
+file FIXUP) the function fix-early-generic-functions is called to convert
+all the early generic functions to real generic functions.
+
+The cheap generic functions are built using the same funcallable-instance
+objects real generic-functions are made out of.  This means that as CLOS
+is being bootstrapped, the cheap generic function objects which are being
+created are the same objects which will later be real generic functions.
+This is good because:
+  - we don't cons garbage structure
+  - we can keep pointers to the cheap generic function objects
+    during booting because those pointers will still point to
+    the right object after the generic functions are all fixed
+    up
+
+
+
+This file defines the defmethod macro and the mechanism used to expand it.
+This includes the mechanism for processing the body of a method.  defmethod
+basically expands into a call to load-defmethod, which basically calls
+add-method to add the method to the generic-function.  These expansions can
+be loaded either during bootstrapping or when CLOS is fully up and running.
+
+An important effect of this structure is it means we can compile files with
+defmethod forms in them in a completely running CLOS, but then load those files
+back in during bootstrapping.  This makes development easier.  It also means
+there is only one set of code for processing defmethod.  Bootstrapping works
+by being sure to have load-method be careful to call only primitives which
+work during bootstrapping.
+
+|#
+
+(proclaim '(notinline make-a-method add-named-method ensure-generic-function-using-class add-method 
+                  remove-method))
+
+(defvar *early-functions* '((make-a-method early-make-a-method real-make-a-method)
+                            (add-named-method early-add-named-method real-add-named-method)))
+
+
+;;; For each of the early functions, arrange to have it point to its early definition.  Do this in a
+;;; way that makes sure that if we redefine one of the early definitions the redefinition will take
+;;; effect.  This makes development easier. The function which generates the redirection closure is
+;;; pulled out into a separate piece of code because of a bug in ExCL which causes this not to work
+;;; if it is inlined. 
+
+
+(eval-when (load eval)
+       (defun redirect-early-function-internal (to)
+              #'(lambda (&rest args)
+                       (apply (symbol-function to)
+                              args))) 
+	 (dolist (fns *early-functions*)
+    (let ((name (car fns))
+	  (early-name (cadr fns)))
+      (setf (symbol-function name)
+	    (redirect-early-function-internal early-name))))
+)
+
+
+;;; *generic-function-fixups* is used by fix-early-generic-functions to convert the few functions in
+;;; the bootstrap which are supposed to be generic functions but can't be early on. 
+
+
+(defvar *generic-function-fixups* '((add-method ((generic-function method)
+                                                             ; lambda-list
+                                                 (standard-generic-function method)
+                                                             ; specializers
+                                                 real-add-method))
+                                                             ; method-function
+                                    (remove-method ((generic-function method)
+                                                    (standard-generic-function method)
+                                                    real-remove-method))
+                                    (get-method ((generic-function qualifiers specializers &optional
+                                                        (errorp t))
+                                                 (standard-generic-function t t)
+                                                 real-get-method))
+                                    (ensure-generic-function-using-class ((generic-function 
+                                                                                 function-specifier 
+                                                                                 &key 
+                                                                               generic-function-class
+                                                                                 environment 
+                                                                                 &allow-other-keys)
+                                                                          (generic-function t)
+                                                                          
+                                                         real-ensure-gf-using-class--generic-function
+                                                                          )
+                                           ((generic-function function-specifier &key 
+                                                   generic-function-class environment 
+                                                   &allow-other-keys)
+                                            (null t)
+                                            real-ensure-gf-using-class--null))))
+
+
+;;; 
+
+
+(defmacro defgeneric (function-specifier lambda-list &body options)
+       (expand-defgeneric function-specifier lambda-list options))
+
+(defun expand-defgeneric (function-specifier lambda-list options)
+       (when (listp function-specifier)
+           (do-standard-defsetf-1 (cadr function-specifier)))
+       (let ((initargs nil))
+            (flet ((duplicate-option (name)
+                          (error "The option ~S appears more than once." name)))
+                  
+                  ;; INITARG takes this screwy new argument to get around a bad interaction between
+                  ;; lexical macros and setf in the Lucid compiler. 
+                  (macrolet ((initarg (key &optional new)
+                                    (if new
+                                        `(setf (getf initargs ,key)
+                                               ,new)
+                                        `(getf initargs ,key))))
+                         (dolist (option options)
+                             (ecase (car option)
+                                 (:argument-precedence-order 
+                                    (if (initarg :argument-precedence-order)
+                                        (duplicate-option :argument-precedence-order)
+                                        (initarg :argument-precedence-order
+                                               `',(cdr option))))
+                                 (declare (initarg :declarations (append (cdr option)
+                                                                        (initarg :declarations))))
+                                 (:documentation (if (initarg :documentation)
+                                                     (duplicate-option :documentation)
+                                                     (initarg :documentation
+                                                            `',(cadr option))))
+                                 (:method-combination 
+                                    (if (initarg :method-combination)
+                                        (duplicate-option :method-combination)
+                                        (initarg :method-combination
+                                               `',(cdr option))))
+                                 (:generic-function-class 
+                                    (if (initarg :generic-function-class)
+                                        (duplicate-option :generic-function-class)
+                                        (initarg :generic-function-class
+                                               `',(cadr option))))
+                                 (:method-class (if (initarg :method-class)
+                                                    (duplicate-option :method-class)
+                                                    (initarg :method-class
+                                                           `',(cadr option))))
+                                 (:method (error "DEFGENERIC doesn't support the :METHOD option yet."
+                                                 ))))
+                         (let ((declarations (initarg :declarations)))
+                              (when declarations
+                                  (initarg :declarations `',declarations)))))
+            (make-top-level-form `(defgeneric ,function-specifier)
+                   *defgeneric-times*
+                   `(load-defgeneric ',function-specifier ',lambda-list ,@initargs))))
+
+(defun load-defgeneric (function-specifier lambda-list &rest initargs)
+       (when (listp function-specifier)
+           (do-standard-defsetf-1 (cadr function-specifier)))
+       (apply #'ensure-generic-function function-specifier :lambda-list lambda-list 
+              :definition-source `((defgeneric ,function-specifier)
+                                   ,(load-truename))
+              initargs))
+
+
+;;; 
+
+
+(defmacro defmethod (&rest args &environment env)
+       (declare (arglist name {method-qualifier}* specialized-lambda-list &body body))
+       (multiple-value-bind (name qualifiers lambda-list body)
+              (parse-defmethod args)
+              (let ((proto-method (method-prototype-for-gf name)))
+                   (expand-defmethod proto-method name qualifiers lambda-list body env))))
+
+
+;;; takes a name which is either a generic function name or a list specifying a setf generic
+;;; function (like: (SETF <generic-function-name>)).  Returns the prototype instance of the
+;;; method-class for that generic function. If there is no generic function by that name, this
+;;; returns the default value, the prototype instance of the class STANDARD-METHOD.  This default
+;;; value is also returned if the spec names an ordinary function or even a macro.  In effect, this
+;;; leaves the signalling of the appropriate error until load time. NOTE that during bootstrapping,
+;;; this function is allowed to return NIL. 
+
+
+(defun method-prototype-for-gf (name)
+       (let ((gf? (and (gboundp name)
+                       (gdefinition name))))
+            (cond ((neq *boot-state* 'complete)
+                   nil)
+                  ((or (null gf?)
+                       (not (generic-function-p gf?)))
+                                                             ; Someone else MIGHT error at load
+                                                             ; time. 
+                   (class-prototype (find-class 'standard-method)))
+                  (t (class-prototype (or (generic-function-method-class gf?)
+                                          (find-class 'standard-method)))))))
+
+(defun expand-defmethod (proto-method name qualifiers lambda-list body env)
+  (when (listp name) (do-standard-defsetf-1 (cadr name)))
+  (multiple-value-bind (fn-form specializers doc plist)
+      (expand-defmethod-internal name qualifiers lambda-list body env)
+    `(load-defmethod
+      ',(if proto-method
+	    (class-name (class-of proto-method))
+	    'standard-method)
+      ',name
+      ',qualifiers
+      (list ,@(mapcar #'(lambda (specializer)
+			  (if (and (consp specializer)
+				   (eq (car specializer) 'eql))
+			      ``(eql ,,(cadr specializer))
+			      `',specializer))
+	       specializers))
+      ',(specialized-lambda-list-lambda-list lambda-list)
+      ',doc
+      ',(getf plist :isl-cache-symbol)	;Paper over a bug in KCL by
+					;passing the cache-symbol
+					;here in addition to in the
+					;plist.
+      ',plist
+      ,fn-form)))
+
+(defun
+ expand-defmethod-internal
+ (generic-function-name qualifiers specialized-lambda-list body env)
+ (declare (values fn-form specializers doc)
+        (ignore qualifiers))
+ (when (listp generic-function-name)
+     (do-standard-defsetf-1 (cadr generic-function-name)))
+ (multiple-value-bind
+  (documentation declarations real-body)
+  (extract-declarations body)
+  (multiple-value-bind
+   (parameters lambda-list specializers)
+   (parse-specialized-lambda-list specialized-lambda-list)
+   (let*
+    ((required-parameters (mapcar #'(lambda (r s)
+                                           (declare (ignore s))
+                                           r)
+                                 parameters specializers))
+     (parameters-to-reference (make-parameter-references specialized-lambda-list required-parameters
+                                     declarations generic-function-name specializers))
+     (class-declarations
+      `(declare ,@(remove nil (mapcar #'(lambda (a s)
+                                               (and (symbolp s)
+                                                    (neq s 't)
+                                                    `(class ,a ,s)))
+                                     parameters specializers))))
+     (method-lambda 
+
+            ;; Remove the documentation string and insert the appropriate class declarations.  The
+            ;; documentation string is removed to make it easy for us to insert new declarations
+            ;; later, they will just go after the cadr of the method lambda.  The class declarations
+            ;; are inserted to communicate the class of the method's arguments to the code walk. 
+            (let nil `(lambda ,lambda-list ,class-declarations ,@declarations (progn 
+                                                                                     ,@
+                                                                              parameters-to-reference
+                                                                                     )
+                             (block ,(if (listp generic-function-name)
+                                         (cadr generic-function-name)
+                                         generic-function-name)
+                                    ,@real-body))))
+     (call-next-method-p nil)
+                                                             ; flag indicating that call-next-method
+                                                             ; should be in the method definition 
+     (closurep nil)
+                                                             ; flag indicating that
+                                                             ; #'call-next-method was seen in the
+                                                             ; body of a method 
+     (next-method-p-p nil)
+                                                             ; flag indicating that next-method-p
+                                                             ; should be in the method definition 
+     (save-original-args nil)
+                                                             ; flag indicating whether or not the
+                                                             ; original arguments to the method must
+                                                             ; be preserved.  This happens for two
+                                                             ; reasons: - the method takes &mumble
+                                                             ; args, so one of the lexical functions
+                                                             ; might be used in a default value form
+                                                             ; - call-next-method is used without
+                                                             ; arguments at least once in the body
+                                                             ; of the method 
+     (original-args nil)
+     (applyp nil)
+                                                             ; flag indicating whether or not the
+                                                             ; method takes &mumble arguments. If it
+                                                             ; does, it means call-next-method
+                                                             ; without arguments must be APPLY'd to
+                                                             ; original-args.  If this gets set
+                                                             ; true, save-original-args is set so as
+                                                             ; well 
+     (aux-bindings nil)
+                                                             ; Suffice to say that &aux is one of
+                                                             ; damndest things to have put in a
+                                                             ; language. 
+     (slots (mapcar #'list required-parameters))
+     (plist nil)
+     (walked-lambda nil))
+    (flet ((walk-function (form context env)
+                  (cond ((not (eq context ':eval))
+                         form)
+                        ((not (listp form))
+                         form)
+                        ((eq (car form)
+                             'call-next-method)
+                         (setq call-next-method-p 't)
+                         (unless (cdr form)
+                                (setq save-original-args t))
+                         form)
+                        ((eq (car form)
+                             'next-method-p)
+                         (setq next-method-p-p 't)
+                         form)
+                        ((and (eq (car form)
+                                  'function)
+                              (cond ((eq (cadr form)
+                                         'call-next-method)
+                                     (setq call-next-method-p 't)
+                                     (setq save-original-args 't)
+                                     (setq closurep t)
+                                     form)
+                                    ((eq (cadr form)
+                                         'next-method-p)
+                                     (setq next-method-p-p 't)
+                                     (setq closurep t)
+                                     form)
+                                    (t nil))))
+                        ((and (or (eq (car form)
+                                      'slot-value)
+                                  (eq (car form)
+                                      'set-slot-value))
+                              (symbolp (cadr form))
+                              (constantp (caddr form)))
+                         (let ((parameter (can-optimize-access (cadr form)
+                                                 required-parameters env)))
+                              (if (null parameter)
+                                  form
+                                  (ecase (car form)
+                                      (slot-value (optimize-slot-value slots parameter form))
+                                      (set-slot-value (optimize-set-slot-value slots parameter form)))
+)))
+                        (t form))))
+          (setq walked-lambda (walk-form method-lambda env #'walk-function))
+          
+          ;; Add &allow-other-keys to the lambda list as an interim way of implementing lambda list
+          ;; congruence rules. 
+          (when (and (memq '&key lambda-list)
+                     (not (memq '&allow-other-keys lambda-list)))
+              (let* ((rll (reverse lambda-list))
+                     (aux (memq '&aux rll)))
+                    (setq lambda-list (if aux
+                                          (progn (setf (cdr aux)
+                                                       (cons '&allow-other-keys (cdr aux)))
+                                                 (nreverse rll))
+                                          (nconc (nreverse rll)
+                                                 (list '&allow-other-keys))))))
+          
+          ;; Scan the lambda list to determine whether this method takes &mumble arguments.  If it
+          ;; does, we set applyp and save-original-args true. This is also the place where we
+          ;; construct the original arguments lambda list if there has to be one. 
+          (dolist (p lambda-list)
+              (if (memq p lambda-list-keywords)
+                  (if (eq p '&aux)
+                      (progn (setq aux-bindings (cdr (memq '&aux lambda-list)))
+                             (return nil))
+                      (progn (setq applyp t save-original-args t)
+                             (push '&rest original-args)
+                             (push (make-symbol "AMPERSAND-ARGS")
+                                   original-args)
+                             (return nil)))
+                  (push (make-symbol (symbol-name p))
+                        original-args)))
+          (setq original-args (if save-original-args
+                                  (nreverse original-args)
+                                  nil))
+          (multiple-value-bind (ignore walked-declarations walked-lambda-body)
+                 (extract-declarations (cddr walked-lambda))
+                 (declare (ignore ignore))
+                 (when (some #'cdr slots)
+                     (setq slots (slot-name-lists-from-slots slots))
+                     (setq plist (list* :isl slots plist))
+                     (setq walked-lambda-body (add-pv-binding walked-lambda-body plist 
+                                                     required-parameters)))
+                 (when (or next-method-p-p call-next-method-p)
+                     (setq plist (list* :needs-next-methods-p 't plist)))
+                 
+
+;;; changes are here... (mt)
+
+                 (let ((fn-body (if (or call-next-method-p next-method-p-p)
+                                    (add-lexical-functions-to-method-lambda
+                                     walked-declarations walked-lambda-body
+                                     `(lambda ,lambda-list ,@walked-declarations 
+                                             ,.walked-lambda-body)
+                                     original-args lambda-list save-original-args applyp aux-bindings
+                                     call-next-method-p next-method-p-p closurep)
+                                    `(lambda ,lambda-list ,@walked-declarations ,.walked-lambda-body))
+                              ))
+                      (values `#',fn-body specializers documentation plist))))))))
+
+(defun
+ add-lexical-functions-to-method-lambda
+ (walked-declarations walked-lambda-body walked-lambda original-args lambda-list save-original-args 
+        applyp aux-bindings call-next-method-p next-method-p-p closurep)
+ (cond
+  ((and (null closurep)
+        (null applyp)
+        (null save-original-args))
+   
+   ;; OK to use MACROLET, CALL-NEXT-METHOD is always passed some args, and all args are mandatory
+   ;; (else APPLYP would be true). 
+   `(lambda ,lambda-list ,@walked-declarations
+           (let ((.next-method. (car *next-methods*))
+                 (.next-methods. (cdr *next-methods*)))
+                (macrolet ((call-next-method ,lambda-list '(if .next-method.
+                                                               (let ((*next-methods* .next-methods.))
+                                                                    (funcall .next-method.
+                                                                           ,@lambda-list))
+                                                               (error "No next method.")))
+                           (next-method-p nil `(not (null .next-method.))))
+                       ,@walked-lambda-body))))
+  ((and (null closurep)
+        (null applyp)
+        save-original-args)
+   
+   ;; OK to use MACROLET.  CALL-NEXT-METHOD is sometimes called in the body with zero args, so we
+   ;; have to save the original args. 
+   (if save-original-args
+       
+       ;; CALL-NEXT-METHOD is sometimes called with no args
+       `(lambda ,original-args
+               (let ((.next-method. (car *next-methods*))
+                     (.next-methods. (cdr *next-methods*)))
+                    (macrolet ((call-next-method
+                                (&rest cnm-args)
+                                `(if .next-method.
+                                     (let ((*next-methods* .next-methods.))
+                                          (funcall .next-method. ,@(if cnm-args
+                                                                       cnm-args
+                                                                       ',original-args)))
+                                     (error "No next method.")))
+                               (next-method-p nil `(not (null .next-method.))))
+                           (let* (,@(mapcar #'list lambda-list original-args)
+                                  ,@aux-bindings)
+                                 ,@walked-declarations
+                                 ,@walked-lambda-body))))))
+  ((and (null save-original-args)
+        (null applyp))
+   
+   ;; We don't have to save the original arguments.  In addition, this method doesn't take any
+   ;; &mumble arguments (this means that there is no way the lexical functions can be used inside of
+   ;; the default value form for an &mumble argument). We can expand this into a simple lambda
+   ;; expression with an FLET to define the lexical functions. 
+   `(lambda ,lambda-list ,@walked-declarations
+           (let ((.next-method. (car *next-methods*))
+                 (.next-methods. (cdr *next-methods*)))
+                (flet (,@(and call-next-method-p '((call-next-method (&rest cnm-args)
+                                                          (if .next-method.
+                                                              (let ((*next-methods* .next-methods.))
+                                                                   (apply .next-method. cnm-args))
+                                                              (error "No next method.")))))
+                       ,@(and next-method-p-p '((next-method-p nil (not (null .next-method.))))))
+                      ,@walked-lambda-body))))
+  ((null applyp)
+   
+   ;; This method doesn't accept any &mumble arguments.  But we do have to save the original
+   ;; arguments (this is because call-next-method is being called with no arguments). Have to be
+   ;; careful though, there may be multiple calls to call-next-method, all we know is that at least
+   ;; one of them is with no arguments. 
+   `(lambda ,original-args
+           (let ((.next-method. (car *next-methods*))
+                 (.next-methods. (cdr *next-methods*)))
+                (flet (,@(and call-next-method-p
+                              `((call-next-method (&rest cnm-args)
+                                       (if .next-method.
+                                           (let ((*next-methods* .next-methods.))
+                                                (if cnm-args
+                                                    (apply .next-method. cnm-args)
+                                                    (funcall .next-method. ,@original-args)))
+                                           (error "No next method.")))))
+                       ,@(and next-method-p-p '((next-method-p nil (not (null .next-method.))))))
+                      (let* (,@(mapcar #'list (remtail lambda-list (memq '&aux lambda-list))
+                                      original-args)
+                             ,@aux-bindings)
+                            ,@walked-declarations
+                            ,@walked-lambda-body)))))
+  (t
+   
+   ;; This is the fully general case. We must allow for the lexical functions being used inside the
+   ;; default value forms of &mumble arguments, and if must allow for call-next-method being called
+   ;; with no arguments. 
+   `(lambda
+     ,original-args
+     (let
+      ((.next-method. (car *next-methods*))
+       (.next-methods. (cdr *next-methods*)))
+      (flet (,@(and call-next-method-p
+                    `((call-next-method (&rest cnm-args)
+                             (if .next-method.
+                                 (let ((*next-methods* .next-methods.))
+                                      (if cnm-args
+                                          (apply .next-method. cnm-args)
+                                          (apply .next-method. ,@(remove '&rest original-args))))
+                                 (error "No next method.")))))
+             ,@(and next-method-p-p '((next-method-p nil (not (null .next-method.))))))
+            (apply #',walked-lambda ,@(remove '&rest original-args))))))))
+
+(defun make-parameter-references (specialized-lambda-list required-parameters declarations 
+                                        generic-function-name specializers)
+       (flet ((ignoredp (symbol)
+                     (dolist (decl (cdar declarations))
+                         (when (and (eq (car decl)
+                                        'ignore)
+                                    (memq symbol (cdr decl)))
+                               (return t)))))
+             (gathering ((references (collecting)))
+                    (iterate ((s (list-elements specialized-lambda-list))
+                              (p (list-elements required-parameters)))
+                           (progn p)
+                           (cond ((not (listp s)))
+                                 ((ignoredp (car s))
+                                  (warn "In defmethod ~S ~S, there is a~%~
+                      redundant ignore declaration for the parameter ~S." generic-function-name 
+                                        specializers (car s)))
+                                 (t (gather (car s)
+                                           references)))))))
+
+(defvar *method-function-plist* (make-hash-table :test #'eq))
+
+(defun method-function-plist (method-function)
+       (gethash method-function *method-function-plist*))
+
+(defun |SETF CLOS METHOD-FUNCTION-PLIST| (val method-function)
+       (setf (gethash method-function *method-function-plist*)
+             val))
+
+(defun method-function-get (method-function key)
+       (getf (method-function-plist method-function)
+             key))
+
+(defun |SETF CLOS METHOD-FUNCTION-GET| (val method-function key)
+       (setf (getf (method-function-plist method-function)
+                   key)
+             val))
+
+(defun method-function-isl (method-function)
+       (method-function-get method-function :isl))
+
+(defun method-function-needs-next-methods-p (method-function)
+       (method-function-get method-function :needs-next-methods-p))
+
+(defun load-defmethod (class name quals specls ll doc isl-cache-symbol plist fn)
+       (when (listp name)
+           (do-standard-defsetf-1 (cadr name)))
+       (let ((method-spec (make-method-spec name quals specls)))
+            (record-definition 'method method-spec)
+            (setq fn (set-function-name fn method-spec))
+            (load-defmethod-internal name quals specls ll doc isl-cache-symbol plist fn class)))
+
+(defun load-defmethod-internal (gf-spec qualifiers specializers lambda-list doc isl-cache-symbol 
+                                      plist fn method-class)
+       (when (listp gf-spec)
+           (do-standard-defsetf-1 (cadr gf-spec)))
+       (when plist
+           (setq plist (copy-list plist))
+                                                             ; Do this to keep from affecting the
+                                                             ; plist that is about to be dumped when
+                                                             ; we are compiling. 
+           (let ((uisl (getf plist :isl))
+                 (isl nil))
+                (when uisl
+                    (setq isl (intern-slot-name-lists uisl))
+                    (setf (getf plist :isl)
+                          isl))
+                (when isl-cache-symbol
+                    (setf (getf plist :isl-cache-symbol)
+                          isl-cache-symbol)
+                    (set isl-cache-symbol isl)))
+           (setf (method-function-plist fn)
+                 plist))
+       (let ((method (add-named-method gf-spec qualifiers specializers lambda-list fn :documentation
+                            doc :definition-source `((defmethod ,gf-spec ,@qualifiers ,specializers)
+                                                     ,(load-truename)))))
+            (unless (or (eq method-class 'standard-method)
+                        (eq (find-class method-class nil)
+                            (class-of method)))
+                (format *error-output* "At the time the method with qualifiers ~:~S and~%~
+               specializers ~:S on the generic function ~S~%~
+               was compiled, the method-class for that generic function was~%~
+               ~S.  But, the method class is now ~S, this~%~
+               may mean that this method was compiled improperly." qualifiers specializers gf-spec 
+                       method-class (class-name (class-of method))))
+            method))
+
+(defun make-method-spec (gf-spec qualifiers unparsed-specializers)
+       `(method ,gf-spec ,@qualifiers ,unparsed-specializers))
+
+                                                             ; Early generic-function support
+
+
+
+;;; 
+
+
+(defvar *early-generic-functions* nil)
+
+(defun ensure-generic-function (function-specifier &rest all-keys &key environment &allow-other-keys)
+       (declare (ignore environment))
+       (let ((existing (and (gboundp function-specifier)
+                            (gdefinition function-specifier))))
+            (if (and existing (eq *boot-state* 'complete)
+                     (null (generic-function-p existing)))
+                (generic-clobbers-function function-specifier)
+                (apply #'ensure-generic-function-using-class existing function-specifier all-keys))))
+
+(defun generic-clobbers-function (function-specifier)
+       (error "~S already names an ordinary function or a macro,~%~
+                  you may want to replace it with a generic function, but doing so~%~
+                  will require that you decide what to do with the existing function~%~
+                  definition.~%~
+                  The CLOS-specific function MAKE-SPECIALIZABLE may be useful to you." 
+              function-specifier))
+
+
+;;; This is the early definition of ensure-generic-function-using-class. The static-slots field of
+;;; the funcallable instances used as early generic functions is used to store the early methods and
+;;; early discriminator code for the early generic function.  The static slots field of the fins
+;;; contains a list whose: CAR    -   a list of the early methods on this early gf CADR   -   the
+;;; early discriminator code for this method 
+
+
+(defun ensure-generic-function-using-class (existing spec &rest keys)
+       (declare (ignore keys))
+       (if* existing existing (pushnew spec *early-generic-functions* :test #'equal)
+            (let ((fin (allocate-funcallable-instance-1)))
+                 (setf (gdefinition spec)
+                       fin)
+                 (setf (fsc-instance-slots fin)
+                       (list nil nil))
+                 fin)))
+
+(defun early-gf-p (x)
+       (and (fsc-instance-p x)
+            (listp (fsc-instance-slots x))))
+
+(defmacro early-gf-methods (early-gf)
+                                                             ; These are macros so that
+       `(car (fsc-instance-slots ,early-gf)))
+
+                                                             ; they can be setf'd. 
+
+
+(defmacro early-gf-discriminator-code (early-gf)
+                                                             ; 
+       `(cadr (fsc-instance-slots ,early-gf)))
+
+                                                             ; 
+
+
+(defmacro real-ensure-gf-internal (gf-class all-keys env)
+       `(progn (cond ((symbolp ,gf-class)
+                      (setq ,gf-class (find-class ,gf-class t ,env)))
+                     ((classp ,gf-class))
+                     (t (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
+                    class nor a symbol that names a class." ,gf-class)))
+               (remf ,all-keys :generic-function-class)
+               (remf ,all-keys :environment)
+               (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
+                    (unless (eq combin '.shes-not-there.)
+                        (setf (getf ,all-keys :method-combination)
+                              (find-method-combination (class-prototype ,gf-class)
+                                     (car combin)
+                                     (cdr combin)))))))
+
+(defun real-ensure-gf-using-class--generic-function (existing function-specifier &rest all-keys &key
+                                                           environment (generic-function-class
+                                                                        'standard-generic-function 
+                                                                        gf-class-p)
+                                                           &allow-other-keys)
+       (declare (ignore function-specifier))
+       (real-ensure-gf-internal generic-function-class all-keys environment)
+       (unless (or (null gf-class-p)
+                   (eq (class-of existing)
+                       generic-function-class))
+              (change-class existing generic-function-class))
+       (apply #'reinitialize-instance existing all-keys))
+
+(defun real-ensure-gf-using-class--null (existing function-specifier &rest all-keys &key environment
+                                               (generic-function-class 'standard-generic-function)
+                                               &allow-other-keys)
+       (declare (ignore existing))
+       (real-ensure-gf-internal generic-function-class all-keys environment)
+       (setf (gdefinition function-specifier)
+             (apply #'make-instance generic-function-class :name function-specifier all-keys)))
+
+(defun early-make-a-method (class qualifiers arglist specializers function doc &optional slot-name)
+       (let ((parsed nil)
+             (unparsed nil))
+            
+            ;; Figure out whether we got class objects or class names as the specializers and set
+            ;; parsed and unparsed appropriately.  If we got class objects, then we can compute
+            ;; unparsed, but if we got class names we don't try to compute parsed. Note that the use
+            ;; of not symbolp in this call to every should be read as 'classp' we can't use classp
+            ;; itself because it doesn't exist yet. 
+            (if (every #'(lambda (s)
+                                (not (symbolp s)))
+                       specializers)
+                (setq parsed specializers unparsed (mapcar #'(lambda (s)
+                                                                    (if (eq s 't)
+                                                                        't
+                                                                        (class-name s)))
+                                                          specializers))
+                (setq unparsed specializers parsed nil))
+            (list :early-method                              ; This is an early method dammit!
+                  function
+                                                             ; Function is here for the benefit of
+                                                             ; early-lookup-method. 
+                  parsed
+                                                             ; The parsed specializers.  This is
+                                                             ; used by early-method-specializers to
+                                                             ; cache the parse.  Note that this only
+                                                             ; comes into play when there is more
+                                                             ; than one early method on an early gf.
+                  (list class                                ; A list to which real-make-a-method
+                        qualifiers
+                                                             ; can be applied to make a real method
+                        arglist
+                                                             ; corresponding to this early one.
+                        unparsed function doc slot-name))))
+
+(defun real-make-a-method (class qualifiers lambda-list specializers function doc &optional slot-name
+                                 )
+       
+       ;; Hmm what is this use of when buying me??
+       (when (some #'(lambda (x)
+                            (and (neq x 't)
+                                 (symbolp x)))
+                   specializers)
+           (setq specializers (parse-specializers specializers)))
+       (make-instance class :qualifiers qualifiers :lambda-list lambda-list :specializers 
+              specializers :function function :documentation doc :slot-name slot-name 
+              :allow-other-keys t))
+
+(defun early-method-function (early-method)
+       (cadr early-method))
+
+
+;;; Fetch the specializers of an early method.  This is basically just a simple accessor except that
+;;; when the second argument is t, this converts the specializers from symbols into class objects. 
+;;; The class objects are cached in the early method, this makes bootstrapping faster because the
+;;; class objects only have to be computed once. NOTE: the second argument should only be passed as
+;;; T by early-lookup-method. this is to implement the rule that only when there is more than one
+;;; early method on a generic function is the conversion from class names to class objects done. the
+;;; corresponds to the fact that we are only allowed to have one method on any generic function up
+;;; until the time classes exist. 
+
+
+(defun early-method-specializers (early-method &optional objectsp)
+       (if (and (listp early-method)
+                (eq (car early-method)
+                    :early-method))
+           (cond ((eq objectsp 't)
+                  (or (caddr early-method)
+                      (setf (caddr early-method)
+                            (mapcar #'find-class (cadddr (cadddr early-method))))))
+                 (t (cadddr (cadddr early-method))))
+           (error "~S is not an early-method." early-method)))
+
+(defun early-method-qualifiers (early-method)
+       (cadr (cadddr early-method)))
+
+(defun early-add-named-method (generic-function-name qualifiers specializers arglist function &rest 
+                                     options)
+       (declare (ignore options))
+       (let* ((gf (ensure-generic-function generic-function-name))
+              (existing (dolist (m (early-gf-methods gf))
+                            (when (and (equal (early-method-specializers m)
+                                              specializers)
+                                       (equal (early-method-qualifiers m)
+                                              qualifiers))
+                                  (return m))))
+              (new (make-a-method 'standard-method qualifiers arglist specializers function nil)))
+             (when existing (remove-method gf existing))
+             (add-method gf new)))
+
+
+;;; This is the early version of add-method.  Later this will become a generic function.  See
+;;; fix-early-generic-functions which has special knowledge about add-method. 
+
+
+(defun add-method (generic-function method)
+       (when (not (fsc-instance-p generic-function))
+             (error "Early add-method didn't get a funcallable instance."))
+       (when (not (and (listp method)
+                       (eq (car method)
+                           :early-method)))
+             (error "Early add-method didn't get an early method."))
+       (push method (early-gf-methods generic-function))
+       (early-update-discriminator-code generic-function))
+
+
+;;; This is the early version of remove method. 
+
+
+(defun remove-method (generic-function method)
+       (when (not (fsc-instance-p generic-function))
+             (error "Early remove-method didn't get a funcallable instance."))
+       (when (not (and (listp method)
+                       (eq (car method)
+                           :early-method)))
+             (error "Early remove-method didn't get an early method."))
+       (setf (early-gf-methods generic-function)
+             (remove method (early-gf-methods generic-function)))
+       (early-update-discriminator-code generic-function))
+
+
+;;; And the early version of get-method. 
+
+
+(defun get-method (generic-function qualifiers specializers &optional (errorp t))
+       (if (early-gf-p generic-function)
+           (or (dolist (m (early-gf-methods generic-function))
+                   (when (and (or (equal (early-method-specializers m nil)
+                                         specializers)
+                                  (equal (early-method-specializers m 't)
+                                         specializers))
+                              (equal (early-method-qualifiers m)
+                                     qualifiers))
+                         (return m)))
+               (if errorp
+                   (error "Can't get early method.")
+                   nil))
+           (real-get-method generic-function qualifiers specializers errorp)))
+
+(defun early-update-discriminator-code (generic-function)
+       (let* ((methods (early-gf-methods generic-function))
+              (early-dfun (cond ((null methods)
+                                 #'(lambda (&rest ignore)
+                                          (declare (ignore ignore))
+                                          (error 
+              "Called an early generic-function that ~
+                              has no methods?")))
+                                ((null (cdr methods))
+                                 
+                                 ;; If there is only one method, just use that method's function. 
+                                 ;; This corresponds to the important fact that early
+                                 ;; generic-functions with only one method always call that method
+                                 ;; when they are called.  If there is more than one method, we have
+                                 ;; to install a simple little discriminator-code for this generic
+                                 ;; function. 
+                                 (cadr (car methods)))
+                                (t #'(lambda (&rest args)
+                                            (early-dfun methods args))))))
+             (set-funcallable-instance-function generic-function early-dfun)
+             (setf (early-gf-discriminator-code generic-function)
+                   early-dfun)))
+
+(defun early-get-cpl (object)
+       (bootstrap-get-slot 'std-class                        ; HMMM? should be CLOS-CLASS
+              (class-of object)
+              'class-precedence-list))
+
+(defun early-sort-methods (list args)
+       (if (null (cdr list))
+           list
+           (sort list #'(lambda (specls-1 specls-2)
+                               (iterate ((s1 (list-elements specls-1))
+                                         (s2 (list-elements specls-2))
+                                         (a (list-elements args)))
+                                      (cond ((eq s1 s2))
+                                            ((eq s2 *the-class-t*)
+                                             (return t))
+                                            ((eq s1 *the-class-t*)
+                                             (return nil))
+                                            (t (return (memq s2 (memq s1 (early-get-cpl a))))))))
+                 :key
+                 #'(lambda (em)
+                          (early-method-specializers em t)))))
+
+(defun early-dfun (methods args)
+       (let ((primary nil)
+             (before nil)
+             (after nil)
+             (around nil))
+            (dolist (method methods)
+                (let* ((specializers (early-method-specializers method t))
+                       (qualifiers (early-method-qualifiers method))
+                       (args args)
+                       (specs specializers))
+                      (when (loop (when (or (null args)
+                                            (null specs))
+                                      
+
+                                 ;; If we are out of specs, then we must be in the optional, rest or
+                                 ;; keywords arguments.  This method is applicable to these
+                                 ;; arguments.  Return T. 
+                                      (return t))
+                                  (let ((arg (pop args))
+                                        (spec (pop specs)))
+                                       (unless (or (eq spec *the-class-t*)
+                                                   (memq spec (early-get-cpl arg)))
+                                              (return nil))))
+                          (cond ((null qualifiers)
+                                 (push method primary))
+                                ((equal qualifiers '(:before))
+                                 (push method before))
+                                ((equal qualifiers '(:after))
+                                 (push method after))
+                                ((equal qualifiers '(:around))
+                                 (push method around))
+                                (t (error "Unrecognized qualifer in early method."))))))
+            (setq primary (early-sort-methods primary args)
+                  before
+                  (early-sort-methods before args)
+                  after
+                  (early-sort-methods after args)
+                  around
+                  (early-sort-methods around args))
+            (flet ((do-main-combined-method (arguments)
+                          (dolist (m before)
+                              (apply (cadr m)
+                                     arguments))
+                          (multiple-value-prog1 (let ((*next-methods* (mapcar #'car (cdr primary))))
+                                                     (apply (cadar primary)
+                                                            arguments))
+                                 (dolist (m after)
+                                     (apply (cadr m)
+                                            arguments)))))
+                  (if (null around)
+                      (do-main-combined-method args)
+                      (let ((*next-methods* (append (mapcar #'cadr (cdr around))
+                                                   #'do-main-combined-method)))
+                           (apply (caar around)
+                                  args))))))
+
+(defun
+ fix-early-generic-functions
+ (&optional noisyp)
+ (allocate-instance (find-class 'standard-generic-function))
+                                                             ; Be sure this class has an instance. 
+ (let* ((class (find-class 'standard-generic-function))
+        (wrapper (class-wrapper class))
+        (n-static-slots (class-no-of-instance-slots class))
+        (default-initargs (default-initargs class nil))
+        (*invalidate-discriminating-function-force-p* t))
+       (flet ((fix-structure (gf)
+                     (let ((static-slots (%allocate-static-slot-storage--class n-static-slots)))
+                          (setf (fsc-instance-wrapper gf)
+                                wrapper
+                                (fsc-instance-slots gf)
+                                static-slots))))
+             (dolist (early-gf-spec *early-generic-functions*)
+                 (when noisyp (format t "~&~S..." early-gf-spec))
+                 (let* ((early-gf (gdefinition early-gf-spec))
+                        (early-static-slots (fsc-instance-slots early-gf))
+                        (early-discriminator-code nil)
+                        (early-methods nil)
+                        (methods nil)
+                        (aborted t))
+                       (flet ((trampoline (&rest args)
+                                     (apply early-discriminator-code args)))
+                             (if (not (listp early-static-slots))
+                                 (when noisyp (format t "already fixed?"))
+                                 (unwind-protect
+                                     (progn (setq early-discriminator-code (
+                                                                          early-gf-discriminator-code
+                                                                            early-gf))
+                                            (setq early-methods (early-gf-methods early-gf))
+                                            (setf (gdefinition early-gf-spec)
+                                                  #'trampoline)
+                                            (when noisyp (format t "trampoline..."))
+                                            (fix-structure early-gf)
+                                            (when noisyp (format t "fixed..."))
+                                            (apply #'initialize-instance early-gf :name early-gf-spec
+                                                   default-initargs)
+                                            (dolist (early-method early-methods)
+                                                (destructuring-bind (class quals lambda-list specs fn
+                                                                           doc slot-name)
+                                                       (cadddr early-method)
+                                                       (setq specs (early-method-specializers 
+                                                                          early-method t))
+                                                       (let ((method (real-make-a-method class quals
+                                                                            lambda-list specs fn doc
+                                                                            slot-name)))
+                                                            (real-add-method early-gf method)
+                                                            (push method methods)
+                                                            (when noisyp (format t "m")))))
+                                            (setf (slot-value early-gf 'name)
+                                                  early-gf-spec)
+                                            (fixup-magic-generic-function early-gf-spec early-methods
+                                                   early-gf (reverse methods))
+                                            (setq aborted nil))
+                                     (setf (gdefinition early-gf-spec)
+                                           early-gf)
+                                     (when noisyp (format t "."))
+                                     (when aborted
+                                         (setf (fsc-instance-slots early-gf)
+                                               early-static-slots)))))))
+             (dolist (fns *early-functions*)
+                 (setf (symbol-function (car fns))
+                       (symbol-function (caddr fns))))
+             (dolist (fixup *generic-function-fixups*)
+                 (let ((fspec (car fixup))
+                       (methods (cdr fixup))
+                       (gf (make-instance 'standard-generic-function)))
+                      (set-function-name gf fspec)
+                      (setf (generic-function-name gf)
+                            fspec)
+                      (dolist (method methods)
+                          (destructuring-bind (lambda-list specializers method-fn-name)
+                                 method
+                                 (let* ((fn (if method-fn-name
+                                                (symbol-function method-fn-name)
+                                                (symbol-function fspec)))
+                                        (method (make-a-method 'standard-method nil lambda-list 
+                                                       specializers fn nil)))
+                                       (real-add-method gf method))))
+                      (setf (gdefinition fspec)
+                            gf))))))
+
+
+;;; parse-defmethod is used by defmethod to parse the &rest argument into the 'real' arguments. 
+;;; This is where the syntax of defmethod is really implemented. 
+
+
+(defun parse-defmethod (cdr-of-form)
+       (declare (values name qualifiers specialized-lambda-list body))
+       (let ((name (pop cdr-of-form))
+             (qualifiers nil)
+             (spec-ll nil))
+            (loop (if (and (car cdr-of-form)
+                           (atom (car cdr-of-form)))
+                      (push (pop cdr-of-form)
+                            qualifiers)
+                      (return (setq qualifiers (nreverse qualifiers)))))
+            (setq spec-ll (pop cdr-of-form))
+            (values name qualifiers spec-ll cdr-of-form)))
+
+(defun parse-specializers (specializers)
+       (flet ((parse (spec)
+                     (cond ((symbolp spec)
+                            (or (find-class spec nil)
+                                (error 
+              "~S used as a specializer,~%~
+                         but is not the name of a class." spec)))
+                           ((and (listp spec)
+                                 (eq (car spec)
+                                     'eql)
+                                 (null (cddr spec)))
+                            (make-instance 'eql-specializer :object (cadr spec))
+                                                             ; *EQL* spec 
+                            )
+                           (t (error "~S is not a legal specializer." spec)))))
+             (mapcar #'parse specializers)))
+
+(defun unparse-specializers (specializers-or-method)
+       (if (listp specializers-or-method)
+           (flet ((unparse (spec)
+                         (cond ((classp spec)
+                                (or (class-name spec)
+                                    spec))
+                               ((eql-specializer-p spec)
+                                                             ; *EQL*
+                                (eql-specializer-object spec)
+                                                             ; (and (listp spec) (eq (car spec)
+                                                             ; 'eql)) spec 
+                                )
+                               (t (error "~S is not a legal specializer." spec)))))
+                 (mapcar #'unparse specializers-or-method))
+           (unparse-specializers (method-specializers specializers-or-method))))
+
+(defun parse-method-or-spec (spec &optional (errorp t))
+       (declare (values generic-function method method-name))
+       (let (gf method name temp)
+            (if (method-p spec)
+                (setq method spec gf (method-generic-function method)
+                      temp
+                      (and gf (generic-function-name gf))
+                      name
+                      (if temp
+                          (intern-function-name (make-method-spec temp (method-qualifiers method)
+                                                       (unparse-specializers (method-specializers
+                                                                              method))))
+                          (make-symbol (format nil "~S" method))))
+                (multiple-value-bind (gf-spec quals specls)
+                       (parse-defmethod spec)
+                       (and (setq gf (and (or errorp (gboundp gf-spec))
+                                          (gdefinition gf-spec)))
+                            (let ((nreq (compute-discriminating-function-arglist-info gf)))
+                                 (setq specls (append (parse-specializers specls)
+                                                     (make-list (- nreq (length specls))
+                                                            :initial-element *the-class-t*)))
+                                 (and (setq method (get-method gf quals specls errorp))
+                                      (setq name (intern-function-name (make-method-spec gf-spec 
+                                                                              quals specls))))))))
+            (values gf method name)))
+
+(defun specialized-lambda-list-parameters (specialized-lambda-list)
+       (multiple-value-bind (parameters ignore1 ignore2)
+              (parse-specialized-lambda-list specialized-lambda-list)
+              (declare (ignore ignore1 ignore2))
+              parameters))
+
+(defun specialized-lambda-list-lambda-list (specialized-lambda-list)
+       (multiple-value-bind (ignore1 lambda-list ignore2)
+              (parse-specialized-lambda-list specialized-lambda-list)
+              (declare (ignore ignore1 ignore2))
+              lambda-list))
+
+(defun specialized-lambda-list-specializers (specialized-lambda-list)
+       (multiple-value-bind (ignore1 ignore2 specializers)
+              (parse-specialized-lambda-list specialized-lambda-list)
+              (declare (ignore ignore1 ignore2))
+              specializers))
+
+(defun specialized-lambda-list-required-parameters (specialized-lambda-list)
+       (multiple-value-bind (ignore1 ignore2 ignore3 required-parameters)
+              (parse-specialized-lambda-list specialized-lambda-list)
+              (declare (ignore ignore1 ignore2 ignore3))
+              required-parameters))
+
+(defun parse-specialized-lambda-list (arglist &optional post-keyword)
+       (declare (values parameters lambda-list specializers required-parameters))
+       (let ((arg (car arglist)))
+            (cond ((null arglist)
+                   (values nil nil nil nil))
+                  ((eq arg '&aux)
+                   (values nil arglist nil))
+                  ((memq arg lambda-list-keywords)
+                   (unless (memq arg '(&optional &rest &key &allow-other-keys &aux))
+                       
+                       ;; Warn about non-standard lambda-list-keywords, but then go on to treat them
+                       ;; like a standard lambda-list-keyword what with the warning its probably ok.
+                       (warn "Unrecognized lambda-list keyword ~S in arglist.~%~
+                    Assuming that the symbols following it are parameters,~%~
+                    and not allowing any parameter specializers to follow~%~
+                    to follow it." arg))
+                   
+                   ;; When we are at a lambda-list-keyword, the parameters don't include the
+                   ;; lambda-list-keyword; the lambda-list does include the lambda-list-keyword; and
+                   ;; no specializers are allowed to follow the lambda-list-keywords (at least for
+                   ;; now). 
+                   (multiple-value-bind (parameters lambda-list)
+                          (parse-specialized-lambda-list (cdr arglist)
+                                 t)
+                          (values parameters (cons arg lambda-list)
+                                 nil nil)))
+                  (post-keyword 
+
+                         ;; After a lambda-list-keyword there can be no specializers.
+                         (multiple-value-bind (parameters lambda-list)
+                                (parse-specialized-lambda-list (cdr arglist)
+                                       t)
+                                (values (cons (if (listp arg)
+                                                  (car arg)
+                                                  arg)
+                                              parameters)
+                                       (cons arg lambda-list)
+                                       nil nil)))
+                  (t (multiple-value-bind (parameters lambda-list specializers required)
+                            (parse-specialized-lambda-list (cdr arglist))
+                            (values (cons (if (listp arg)
+                                              (car arg)
+                                              arg)
+                                          parameters)
+                                   (cons (if (listp arg)
+                                             (car arg)
+                                             arg)
+                                         lambda-list)
+                                   (cons (if (listp arg)
+                                             (cadr arg)
+                                             't)
+                                         specializers)
+                                   (cons (if (listp arg)
+                                             (car arg)
+                                             arg)
+                                         required)))))))
+
+(eval-when (load eval)
+       (setq *boot-state* 'early))
+
+(defmacro with-slots (slots instance &body body &environment env)
+       (let ((gensym (gensym))
+             (specs (mapcar #'(lambda (ss)
+                                     (if (consp ss)
+                                         (list (car ss)
+                                               (variable-lexical-p (car ss)
+                                                      env)
+                                               (cadr ss))
+                                         (list ss (variable-lexical-p ss env)
+                                               ss)))
+                           slots)))
+            (expand-with-slots specs body env gensym instance
+                   #'(lambda (s)
+                            `(slot-value ,gensym ',s)))))
+
+(defmacro with-accessors (slot-accessor-pairs instance &body body &environment env)
+       (let ((gensym (gensym))
+             (specs (mapcar #'(lambda (ss)
+                                     (list (car ss)
+                                           (variable-lexical-p (car ss)
+                                                  env)
+                                           (cadr ss)))
+                           slot-accessor-pairs)))
+            (expand-with-slots specs body env gensym instance #'(lambda (a)
+                                                                       `(,a ,gensym)))))
+
+(defun expand-with-slots (specs body env gensym instance translate-fn)
+       `(let ((,gensym ,instance))
+             ,@(and (symbolp instance)
+                    `((declare (variable-rebinding ,gensym ,instance))))
+             ,gensym
+             ,@(cdr (walk-form `(progn ,@body)
+                           env
+                           #'(lambda (f c e)
+                                    (expand-with-slots-internal specs f c translate-fn e))))))
+
+(defun expand-with-slots-internal (specs form context translate-fn env)
+       (let ((entry nil))
+            (cond ((not (eq context :eval))
+                   form)
+                  ((symbolp form)
+                   (if (and (setq entry (assoc form specs))
+                            (eq (cadr entry)
+                                (variable-lexical-p form env)))
+                       (funcall translate-fn (caddr entry))
+                       form))
+                  ((not (listp form))
+                   form)
+                  ((member (car form)
+                          '(setq setf))
+                   
+                   ;; Have to be careful.  We must only convert the form to a SETF form when we
+                   ;; convert one of the 'logical' variables to a form Otherwise we will get looping
+                   ;; in implementations where setf is a macro which expands into setq. 
+                   (let ((kind (car form)))
+                        (labels ((scan-setf (tail)
+                                        (if (null tail)
+                                            nil
+                                            (walker::relist* tail
+                                                   (if (and (setq entry (assoc (car tail)
+                                                                               specs))
+                                                            (eq (cadr entry)
+                                                                (variable-lexical-p (car tail)
+                                                                       env)))
+                                                       (progn (setq kind 'setf)
+                                                              (funcall translate-fn (caddr entry)))
+                                                       (car tail))
+                                                   (cadr tail)
+                                                   (scan-setf (cddr tail))))))
+                               (let (new-tail)
+                                    (setq new-tail (scan-setf (cdr form)))
+                                    (walker::recons form kind new-tail)))))
+                  ((eq (car form)
+                       'multiple-value-setq)
+                   (let* ((vars (cadr form))
+                          (gensyms (mapcar #'(lambda (i)
+                                                    (declare (ignore i))
+                                                    (gensym))
+                                          vars)))
+                         `(multiple-value-bind ,gensyms ,(caddr form)
+                                 . ,(reverse (mapcar #'(lambda (v g)
+                                                              `(setf ,v ,g))
+                                                    vars gensyms)))))
+                  (t form))))
diff --git a/clos/2.0/braid.lisp b/clos/2.0/braid.lisp
new file mode 100644
index 00000000..80424b6a
--- /dev/null
+++ b/clos/2.0/braid.lisp
@@ -0,0 +1,503 @@
+;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;; Bootstrapping the meta-braid.
+;;;
+;;; The code in this file takes the early definitions that have been saved
+;;; up and actually builds those class objects.  This work is largely driven
+;;; off of those class definitions, but the fact that STANDARD-CLASS is the
+;;; class of all metaclasses in the braid is built into this code pretty
+;;; deeply.
+;;;
+;;; 
+
+(in-package 'clos)
+
+(defun early-class-definition (class-name)
+  (or (find class-name *early-class-definitions* :key #'ecd-class-name)
+      (error "~S is not a class in *early-class-definitions*." class-name)))
+
+(defun canonical-slot-name (canonical-slot)
+  (getf canonical-slot :name))
+
+(defun early-collect-inheritance (class-name)
+  (declare (values slots cpl default-initargs direct-subclasses))
+  (let ((cpl (early-collect-cpl class-name)))
+    (values (early-collect-slots cpl)
+	    cpl
+	    (early-collect-default-initargs cpl)
+	    (gathering1 (collecting)
+	      (dolist (definition *early-class-definitions*)
+		(when (memq class-name (ecd-superclass-names definition))
+		  (gather1 (ecd-class-name definition))))))))
+
+(defun early-collect-cpl (class-name)
+  (labels ((walk (c)
+	     (let* ((definition (early-class-definition c))
+		    (supers (ecd-superclass-names definition)))
+	       (cons c
+		     (apply #'append (mapcar #'early-collect-cpl supers))))))
+    (remove-duplicates (walk class-name) :from-end nil :test #'eq)))
+
+(defun early-collect-slots (cpl)
+  (let* ((definitions (mapcar #'early-class-definition cpl))
+	 (super-slots (mapcar #'ecd-canonical-slots definitions))
+	 (slots (apply #'append (reverse super-slots))))
+    (dolist (s1 slots)
+      (let ((name1 (canonical-slot-name s1)))
+	(dolist (s2 (cdr (memq s1 slots)))
+	  (when (eq name1 (canonical-slot-name s2))
+	    (error "More than one early class defines a slot with the~%~
+                    name ~S.  This can't work because the bootstrap~%~
+                    object system doesn't know how to compute effective~%~
+                    slots."
+		   name1)))))
+    slots))
+
+(defun early-collect-default-initargs (cpl)
+  (let ((default-initargs ()))
+    (dolist (class-name cpl)
+      (let ((definition (early-class-definition class-name)))
+	(dolist (option (ecd-other-initargs definition))
+	  (unless (eq (car option) :default-initargs)
+	    (error "The defclass option ~S is not supported by the bootstrap~%~
+                    object system."
+		   (car option)))
+	  (setq default-initargs
+		(nconc default-initargs (reverse (cdr option)))))))
+    (reverse default-initargs)))
+
+
+;;;
+;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change
+;;; the values of slots during bootstrapping.  During bootstrapping, there
+;;; are only two kinds of objects whose slots we need to access, CLASSes
+;;; and SLOTDs.  The first argument to these functions tells whether the
+;;; object is a CLASS or a SLOTD.
+;;;
+;;; Note that the way this works it stores the slot in the same place in
+;;; memory that the full object system will expect to find it later.  This
+;;; is critical to the bootstrapping process, the whole changeover to the
+;;; full object system is predicated on this.
+;;;
+;;; One important point is that the layout of standard classes and standard
+;;; slots must be computed the same way in this file as it is by the full
+;;; object system later.
+;;; 
+(defun bootstrap-get-slot (type object slot-name)
+  (let ((index (bootstrap-slot-index type slot-name)))
+    (svref (std-instance-slots object) index)))
+
+(defun bootstrap-set-slot (type object slot-name new-value)
+  (let ((index (bootstrap-slot-index type slot-name)))
+    (setf (svref (std-instance-slots object) index) new-value)))
+
+(defvar *std-class-slots*
+	(mapcar #'canonical-slot-name
+		(early-collect-inheritance 'standard-class)))
+
+(defvar *bin-class-slots*
+	(mapcar #'canonical-slot-name
+		(early-collect-inheritance 'built-in-class)))
+
+(defvar *std-slotd-slots*
+	(mapcar #'canonical-slot-name
+		(early-collect-inheritance 'standard-slot-definition)))
+
+(defun bootstrap-slot-index (type slot-name)
+  (or (position slot-name (ecase type
+			    (std-class *std-class-slots*)
+			    (bin-class *bin-class-slots*)
+			    (std-slotd *std-slotd-slots*)))
+      (error "~S not found" slot-name)))
+
+
+;;;
+;;; bootstrap-meta-braid
+;;;
+;;; This function builds the base metabraid from the early class definitions.
+;;;   
+(defun bootstrap-meta-braid ()
+  (let* ((std-class-size (length *std-class-slots*))
+         (std-class (%allocate-instance--class std-class-size))
+         (std-class-wrapper (make-wrapper std-class))
+	 (built-in-class (%allocate-instance--class std-class-size))
+	 (built-in-class-wrapper (make-wrapper built-in-class))
+	 (direct-slotd    (%allocate-instance--class std-class-size))
+	 (effective-slotd (%allocate-instance--class std-class-size))
+	 (direct-slotd-wrapper    (make-wrapper direct-slotd))
+	 (effective-slotd-wrapper (make-wrapper effective-slotd)))
+    ;;
+    ;; First, make a class metaobject for each of the early classes.  For
+    ;; each metaobject we also set its wrapper.  Except for the class T,
+    ;; the wrapper is always that of STANDARD-CLASS.
+    ;; 
+    (dolist (definition *early-class-definitions*)
+      (let* ((name (ecd-class-name definition))
+	     (meta (ecd-metaclass definition))
+             (class (case name
+                      (standard-class                     std-class)
+                      (standard-direct-slot-definition    direct-slotd)
+		      (standard-effective-slot-definition effective-slotd)
+		      (built-in-class                     built-in-class)
+                      (otherwise
+			(%allocate-instance--class std-class-size)))))
+	(unless (eq name t)
+	  (inform-type-system-about-class class name))
+	(setf (std-instance-wrapper class)
+	      (ecase meta
+		(standard-class std-class-wrapper)
+		(built-in-class built-in-class-wrapper)))
+        (setf (find-class name) class)))
+    ;;
+    ;;
+    ;;
+    (dolist (definition *early-class-definitions*)
+      (let ((name (ecd-class-name definition))
+	    (source (ecd-source definition))
+	    (direct-supers (ecd-superclass-names definition))
+	    (direct-slots  (ecd-canonical-slots definition))
+	    (other-initargs (ecd-other-initargs definition)))
+	(let ((direct-default-initargs
+		(getf other-initargs :default-initargs)))
+	  (multiple-value-bind (slots cpl default-initargs direct-subclasses)
+	      (early-collect-inheritance name)
+	    (let* ((class (find-class name))
+		   (wrapper
+		     (cond
+		       ((eq class std-class)       std-class-wrapper)
+		       ((eq class direct-slotd)    direct-slotd-wrapper)
+		       ((eq class effective-slotd) effective-slotd-wrapper)
+		       ((eq class built-in-class)  built-in-class-wrapper)
+		       (t (make-wrapper class))))
+		   (proto nil))
+	      (cond ((eq name 't)
+		     (setq *the-wrapper-of-t* wrapper
+			   *the-class-t* class))
+		    ((memq name '(standard-object 
+				  standard-class
+				  standard-effective-slot-definition))
+		     (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
+				  *the-clos-package*)
+			  class)))
+	      (dolist (slot slots)
+		(unless (eq (getf slot :allocation :instance) :instance)
+		  (error "Slot allocation ~S not supported in bootstrap.")))
+	      
+	      (setf (wrapper-instance-slots-layout wrapper)
+		    (mapcar #'canonical-slot-name slots))
+	      (setf (wrapper-class-slots wrapper)
+		    ())
+	      
+	      (setq proto (%allocate-instance--class (length slots)))
+	      (setf (std-instance-wrapper proto) wrapper)
+	    
+	      (setq direct-slots
+		    (bootstrap-make-slot-definitions name direct-slots
+						     direct-slotd-wrapper nil))
+	      (setq slots
+		    (bootstrap-make-slot-definitions name slots
+						     effective-slotd-wrapper t))
+	      
+	      (bootstrap-initialize-std-class
+		class name source
+		direct-supers direct-subclasses cpl wrapper
+		direct-slots slots direct-default-initargs default-initargs
+		proto)
+	      
+	      (dolist (slotd direct-slots)
+		(bootstrap-accessor-definitions
+		  name
+		  (bootstrap-get-slot 'std-slotd slotd 'name)
+		  (bootstrap-get-slot 'std-slotd slotd 'readers)
+		  (bootstrap-get-slot 'std-slotd slotd 'writers))))))))))
+
+(defun bootstrap-accessor-definitions (class-name slot-name readers writers)
+  (flet ((do-reader-definition (reader)
+	   (add-method
+	     (ensure-generic-function reader)
+	     (make-a-method
+	       'standard-reader-method
+	       ()
+	       (list class-name)
+	       (list class-name)
+	       (make-std-reader-method-function slot-name)
+	       "automatically generated reader method"
+	       slot-name)))
+	 (do-writer-definition (writer)
+	   (add-method
+	     (ensure-generic-function writer)
+	     (make-a-method
+	       'standard-writer-method
+	       ()
+	       (list 'new-value class-name)
+	       (list 't class-name)
+	       (make-std-writer-method-function slot-name)
+	       "automatically generated writer method"
+	       slot-name))))
+    (dolist (reader readers) (do-reader-definition reader))
+    (dolist (writer writers) (do-writer-definition writer))))
+
+;;;
+;;; Initialize a standard class metaobject.
+;;;
+(defun bootstrap-initialize-std-class
+       (class
+	name definition-source direct-supers direct-subclasses cpl wrapper
+	direct-slots slots direct-default-initargs default-initargs proto)
+  (flet ((classes (names) (mapcar #'find-class names))
+	 (set-slot (slot-name value)
+	   (bootstrap-set-slot 'std-class class slot-name value)))
+    
+    (set-slot 'name name)
+    (set-slot 'source definition-source)
+    (set-slot 'class-precedence-list (classes cpl))
+    (set-slot 'direct-superclasses (classes direct-supers))
+    (set-slot 'direct-slots direct-slots)
+    (set-slot 'direct-subclasses (classes direct-subclasses))
+    (set-slot 'direct-methods (cons nil nil))
+    (set-slot 'no-of-instance-slots (length slots))
+    (set-slot 'slots slots)
+    (set-slot 'wrapper wrapper)
+    (set-slot 'prototype proto)
+    (set-slot 'plist
+	      `(,@(and direct-default-initargs
+		       `(direct-default-initargs ,direct-default-initargs))
+		,@(and default-initargs
+		       `(default-initargs ,default-initargs))))
+    ))
+
+;;;
+;;; Initialize a built-in-class metaobject.
+;;;
+(defun bootstrap-initialize-bin-class
+       (class
+	name definition-source direct-supers direct-subclasses cpl wrapper)
+  (flet ((classes (names) (mapcar #'find-class names))
+	 (set-slot (slot-name value)
+	   (bootstrap-set-slot 'bin-class class slot-name value)))
+    
+    (set-slot 'name name)
+    (set-slot 'source definition-source)
+    (set-slot 'direct-superclasses (classes direct-supers))
+    (set-slot 'direct-subclasses (classes direct-subclasses))
+    (set-slot 'direct-methods (cons nil nil))
+    (set-slot 'class-precedence-list (classes cpl))
+    (set-slot 'wrapper wrapper)))
+
+(defun bootstrap-make-slot-definitions (name slots wrapper e-p)
+  (mapcar #'(lambda (slot) (bootstrap-make-slot-definition name slot wrapper e-p))
+          slots))
+
+(defun bootstrap-make-slot-definition (name slot wrapper e-p)  
+  (let ((slotd (%allocate-instance--class (length *std-slotd-slots*))))
+    (setf (std-instance-wrapper slotd) wrapper)
+    (flet ((get-val (name) (getf slot name))
+	   (set-val (name val) (bootstrap-set-slot 'std-slotd slotd name val)))
+      (set-val 'name         (get-val :name))
+      (set-val 'initform     (get-val :initform))
+      (set-val 'initfunction (get-val :initfunction))      
+      (set-val 'initargs     (get-val :initargs))
+      (set-val 'readers      (get-val :readers))
+      (set-val 'writers      (get-val :writers))
+      (set-val 'allocation   :instance)
+      (set-val 'type         (get-val :type))
+      (set-val 'class        nil)
+      (set-val 'instance-index nil)
+      (when (and (eq name 'standard-class) (eq (get-val :name) 'slots) e-p)
+	(setq *the-eslotd-standard-class-slots* slotd))
+      slotd)))
+
+(defun bootstrap-built-in-classes ()
+  ;;
+  ;; First make sure that all the supers listed in *built-in-class-lattice*
+  ;; are themselves defined by *built-in-class-lattice*.  This is just to
+  ;; check for typos and other sorts of brainos.
+  ;; 
+  (dolist (e *built-in-classes*)
+    (dolist (super (cadr e))
+      (unless (or (eq super 't)
+		  (assq super *built-in-classes*))
+	(error "In *built-in-classes*: ~S has ~S as a super,~%~
+                but ~S is not itself a class in *built-in-classes*."
+	       (car e) super super))))
+
+  ;;
+  ;; In the first pass, we create a skeletal object to be bound to the
+  ;; class name.
+  ;;
+  (let* ((built-in-class (find-class 'built-in-class))
+	 (built-in-class-wrapper (class-wrapper built-in-class))
+	 (bin-class-size (length *bin-class-slots*)))
+    (dolist (e *built-in-classes*)
+      (let ((class (%allocate-instance--class bin-class-size)))
+	(setf (std-instance-wrapper class) built-in-class-wrapper)
+	(setf (find-class (car e)) class))))
+
+  ;;
+  ;; In the second pass, we initialize the class objects.
+  ;;
+  (dolist (e *built-in-classes*)
+    (destructuring-bind (name supers subs cpl) e
+      (let* ((class (find-class name))
+	     (wrapper (make-wrapper class)))
+	(set (get-built-in-class-symbol name) class)
+	(set (get-built-in-wrapper-symbol name) wrapper)
+
+	(setf (wrapper-instance-slots-layout wrapper) ()
+	      (wrapper-class-slots wrapper) ())
+
+	(bootstrap-initialize-bin-class class
+					name nil
+					supers subs
+					(cons name cpl) wrapper)
+	))))
+
+
+;;;
+;;;
+;;;
+
+(defun class-of (x) (wrapper-class (wrapper-of x)))
+
+(defun wrapper-of (x) 
+  (or (and (std-instance-p x)
+	   (std-instance-wrapper x))
+      (and (fsc-instance-p x)
+	   (fsc-instance-wrapper x))
+      (built-in-wrapper-of x)
+      (error "Can't determine wrapper of ~S" x)))
+
+
+(eval-when (compile eval)
+
+(defun make-built-in-class-subs ()
+  (mapcar #'(lambda (e)
+	      (let ((class (car e))
+		    (class-subs ()))
+		(dolist (s *built-in-classes*)
+		  (when (memq class (cadr s)) (pushnew (car s) class-subs)))
+		(cons class class-subs)))
+	  (cons '(t) *built-in-classes*)))
+
+(defun make-built-in-class-tree ()
+  (let ((subs (make-built-in-class-subs)))
+    (labels ((descend (class)
+	       (cons class (mapcar #'descend (cdr (assq class subs))))))
+      (descend 't))))
+
+(defun make-built-in-wrapper-of-body ()
+  (make-built-in-wrapper-of-body-1 (make-built-in-class-tree)
+				   'x
+				   #'get-built-in-wrapper-symbol))
+
+(defun make-built-in-wrapper-of-body-1 (tree var get-symbol)
+  (let ((*specials* ()))
+    (declare (special *specials*))
+    (let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol)))
+      `(locally (declare (special .,*specials*)) ,inner))))
+
+(defun make-built-in-wrapper-of-body-2 (tree var get-symbol)
+  (declare (special *specials*))
+  (let ((symbol (funcall get-symbol (car tree))))
+    (push symbol *specials*)
+    (let ((sub-tests
+	    (mapcar #'(lambda (x)
+			(make-built-in-wrapper-of-body-2 x var get-symbol))
+		    (cdr tree))))
+      `(and (typep ,var ',(car tree))
+	    ,(if sub-tests
+		 `(or ,.sub-tests ,symbol)
+		 symbol)))))
+)
+
+(defun built-in-wrapper-of (x)
+  #.(make-built-in-wrapper-of-body))
+
+
+
+
+(eval-when (load eval)
+  (clrhash *find-class*)
+  (bootstrap-meta-braid)
+  (bootstrap-built-in-classes)
+  (setq *boot-state* 'braid)
+  (setf (symbol-function 'load-defclass) #'real-load-defclass)
+  )
+
+
+;;;
+;;; All of these method definitions must appear here because the bootstrap
+;;; only allows one method per generic function until the braid is fully
+;;; built.
+;;;
+(defmethod print-object (instance stream)
+  (printing-random-thing (instance stream)
+    (let ((name (class-name (class-of instance))))
+      (if name
+	  (format stream "~S" name)
+	  (format stream "Instance")))))
+
+(defmethod print-object ((class class) stream)
+  (named-object-print-function class stream))
+
+(defmethod print-object ((slotd standard-slot-definition) stream)
+  (named-object-print-function slotd stream))
+
+(defun named-object-print-function (instance stream
+				    &optional (extra nil extra-p))
+  (printing-random-thing (instance stream)
+    (if extra-p					
+	(format stream "~A ~S ~:S"
+		(capitalize-words (class-name (class-of instance)))
+		(slot-value-or-default instance 'name)
+		extra)
+	(format stream "~A ~S"
+		(capitalize-words (class-name (class-of instance)))
+		(slot-value-or-default instance 'name)))))
+
+
+;;;
+;;;
+;;;
+;(defmethod shared-initialize :after ((class class) slot-names &key name)
+;  (declare (ignore slot-names))
+;  (setf (slot-value class 'name) name))
+;
+;
+;(defmethod shared-initialize :after ((class std-class)
+;				     slot-names
+;				     &key direct-superclasses
+;					  direct-slots)
+; (declare (ignore slot-names))
+; (setf (slot-value class 'direct-superclasses) direct-superclasses
+;	(slot-value class 'direct-slots) direct-slots))
+
+;;;
+;;;
+;;;
+(defmethod shared-initialize :after ((slotd standard-slot-definition)
+				     slot-names
+				     &key class
+					  name
+					  initform
+					  initfunction
+					  initargs 
+					  (allocation :instance)
+					  (type t)
+					  readers
+					  writers)
+  (declare (ignore slot-names))
+  (setf (slot-value slotd 'name) name
+	(slot-value slotd 'initform) initform
+	(slot-value slotd 'initfunction) initfunction
+	(slot-value slotd 'initargs) initargs 
+	(slot-value slotd 'allocation) (if (eq allocation :class) class allocation)
+	(slot-value slotd 'type) type
+	(slot-value slotd 'readers) readers
+	(slot-value slotd 'writers) writers))
+
diff --git a/clos/2.0/cache.lisp b/clos/2.0/cache.lisp
new file mode 100644
index 00000000..068ab817
--- /dev/null
+++ b/clos/2.0/cache.lisp
@@ -0,0 +1,1089 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;; The basics of the CLOS wrapper cache mechanism.
+;;;
+
+(in-package 'clos)
+;;;
+;;; The caching algorithm implemented:
+;;;
+;;; << put a paper here >>
+;;;
+;;; For now, understand that as far as most of this code goes, a cache has
+;;; two important properties.  The first is the number of wrappers used as
+;;; keys in each cache line.  Throughout this code, this value is always
+;;; called NKEYS.  The second is whether or not the cache lines of a cache
+;;; store a value.  Throughout this code, this always called VALUEP.
+;;;
+;;; Depending on these values, there are three kinds of caches.
+;;;
+;;; NKEYS = 1, VALUEP = NIL
+;;;
+;;; In this kind of cache, each line is 1 word long.  No cache locking is
+;;; needed since all read's in the cache are a single value.  Nevertheless
+;;; line 0 (location 0) is reserved, to ensure that invalid wrappers will
+;;; not get a first probe hit.
+;;;
+;;; To keep the code simpler, a cache lock count does appear in location 0
+;;; of these caches, that count is incremented whenever data is written to
+;;; the cache.  But, the actual lookup code (see make-dlap) doesn't need to
+;;; do locking when reading the cache.
+;;; 
+;;;
+;;; NKEYS = 1, VALUEP = T
+;;;
+;;; In this kind of cache, each line is 2 words long.  Cache locking must
+;;; be done to ensure the synchronization of cache reads.  Line 0 of the
+;;; cache (location 0) is reserved for the cache lock count.  Location 1
+;;; of the cache is unused (in effect wasted).
+;;; 
+;;; NKEYS > 1
+;;;
+;;; In this kind of cache, the 0 word of the cache holds the lock count.
+;;; The 1 word of the cache is line 0.  Line 0 of these caches is not
+;;; reserved.
+;;;
+;;; This is done because in this sort of cache, the overhead of doing the
+;;; cache probe is high enough that the 1+ required to offset the location
+;;; is not a significant cost.  In addition, because of the larger line
+;;; sizes, the space that would be wasted by reserving line 0 to hold the
+;;; lock count is more significant.
+;;;
+
+
+;;;
+;;; Caches
+;;;
+;;; A cache is essentially just a vector.  The use of the individual `words'
+;;; in the vector depends on particular properties of the cache as described
+;;; above.
+;;;
+;;; This defines an abstraction for caches in terms of their most obvious
+;;; implementation as simple vectors.  But, please notice that part of the
+;;; implementation of this abstraction, is the function lap-out-cache-ref.
+;;; This means that most port-specific modifications to the implementation
+;;; of caches will require corresponding port-specific modifications to the
+;;; lap code assembler.
+;;;
+(defmacro cache-ref (cache location)
+  `(svref (the simple-vector ,cache) (the fixnum ,location)))
+
+(defun emit-cache-ref (cache-operand location-operand)
+  (operand :iref cache-operand location-operand))
+
+
+(defun cache-size (cache)
+  (array-dimension (the simple-vector cache) 0))
+
+(defun allocate-cache (size)
+  (make-array size :adjustable nil))
+
+(defmacro cache-lock-count (cache)
+  `(cache-ref ,cache 0))
+
+(defun flush-cache-internal (cache)
+  (without-interrupts  
+    (fill (the simple-vector cache) nil)
+    (setf (cache-lock-count cache) 0))
+  cache)
+
+(defmacro modify-cache (cache &body body)
+  `(without-interrupts
+     (multiple-value-prog1
+       (progn ,@body)
+       (let ((old-count (cache-lock-count ,cache)))
+	 (setf (cache-lock-count ,cache)
+	       (if (= old-count most-positive-fixnum) 1 (1+ old-count)))))))
+
+
+
+;;;
+;;; Some facilities for allocation and freeing caches as they are needed.
+;;; This is done on the assumption that a better port of CLOS will arrange
+;;; to cons these all the same static area.  Given that, the fact that
+;;; CLOS tries to reuse them should be a win.
+;;; 
+(defvar *free-caches* (make-hash-table :size 16))
+
+;;;
+;;; Return a cache that has had flush-cache-internal called on it.  This
+;;; returns a cache of exactly the size requested, it won't ever return a
+;;; larger cache.
+;;; 
+(defun get-cache (size)
+  (let ((entry (gethash size *free-caches*)))
+    (without-interrupts
+      (cond ((null entry)
+	     (setf (gethash size *free-caches*) (cons 0 nil))
+	     (get-cache size))
+	    ((null (cdr entry))
+	     (incf (car entry))
+	     (flush-cache-internal (allocate-cache size)))
+	    (t
+	     (let ((cache (cdr entry)))
+	       (setf (cdr entry) (cache-ref cache 0))
+	       (flush-cache-internal cache)))))))
+
+(defun free-cache (cache)
+  (let ((entry (gethash (cache-size cache) *free-caches*)))
+    (without-interrupts
+      (if (null entry)
+	  (error "Attempt to free a cache not allocated by GET-CACHE.")
+	  (let ((thread (cdr entry)))
+	    (loop (unless thread (return))
+		  (when (eq thread cache) (error "Freeing a cache twice."))
+		  (setq thread (cache-ref thread 0)))	  
+	    (flush-cache-internal cache)		;Help the GC
+	    (setf (cache-ref cache 0) (cdr entry))
+	    (setf (cdr entry) cache)
+	    nil)))))
+
+;;;
+;;; This is just for debugging and analysis.  It shows the state of the free
+;;; cache resource.
+;;; 
+(defun show-free-caches ()
+  (let ((elements ()))
+    (maphash #'(lambda (s e) (push (list s e) elements)) *free-caches*)
+    (setq elements (sort elements #'< :key #'car))
+    (dolist (e elements)
+      (let* ((size (car e))
+	     (entry (cadr e))
+	     (allocated (car entry))
+	     (head (cdr entry))
+	     (free 0))
+	(loop (when (null head) (return t))
+	      (setq head (cache-ref head 0))
+	      (incf free))
+	(format t
+		"~&There  ~4D are caches of size ~4D. (~D free  ~3D%)"
+		allocated
+		size
+		free
+		(floor (* 100 (/ free (float allocated)))))))))
+
+
+;;;
+;;; Wrapper cache numbers
+;;; 
+
+;;;
+;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of non-zero
+;;; bits wrapper cache numbers will have.
+;;;
+;;; The value of this constant is the number of wrapper cache numbers which
+;;; can be added and still be certain the result will be a fixnum.  This is
+;;; used by all the code that computes primary cache locations from multiple
+;;; wrappers.
+;;;
+;;; The value of this constant is used to derive the next two which are the
+;;; forms of this constant which it is more convenient for the runtime code
+;;; to use.
+;;; 
+(eval-when (compile load eval)
+
+(defconstant wrapper-cache-number-adds-ok 4)
+
+(defconstant wrapper-cache-number-length
+	     (- (integer-length most-positive-fixnum)
+		wrapper-cache-number-adds-ok))
+
+(defconstant wrapper-cache-number-mask
+	     (1- (expt 2 wrapper-cache-number-length)))
+
+
+(defvar *get-wrapper-cache-number* (make-random-state))
+
+(defun get-wrapper-cache-number ()
+  (let ((n 0))
+    (loop
+      (setq n
+	    (logand wrapper-cache-number-mask
+		    (random most-positive-fixnum *get-wrapper-cache-number*)))
+      (unless (zerop n) (return n)))))
+
+
+(unless (> wrapper-cache-number-length 8)
+  (error "In this implementation of Common Lisp, fixnums are so small that~@
+          wrapper cache numbers end up being only ~D bits long.  This does~@
+          not actually keep CLOS from running, but it may degrade cache~@
+          performance.~@
+          You may want to consider changing the value of the constant~@
+          WRAPPER-CACHE-NUMBER-ADDS-OK.")))
+
+
+;;;
+;;; wrappers themselves
+;;;
+;;; This caching algorithm requires that wrappers have more than one wrapper
+;;; cache number.  You should think of these multiple numbers as being in
+;;; columns.  That is, for a given cache, the same column of wrapper cache
+;;; numbers will be used.
+;;;
+;;; If at some point the cache distribution of a cache gets bad, the cache
+;;; can be rehashed by switching to a different column.
+;;;
+;;; The columns are referred to by field number which is that number which,
+;;; when used as a second argument to wrapper-ref, will return that column
+;;; of wrapper cache number.
+;;;
+;;; This code is written to allow flexibility as to how many wrapper cache
+;;; numbers will be in each wrapper, and where they will be located.  It is
+;;; also set up to allow port specific modifications to `pack' the wrapper
+;;; cache numbers on machines where the addressing modes make that a good
+;;; idea.
+;;; 
+(eval-when (compile load eval)
+(defconstant wrapper-layout
+	     '(number
+	       number
+	       number
+	       number
+	       number
+	       number
+	       number
+	       number
+	       state
+	       instance-slots-layout
+	       class-slots
+	       class))
+)
+
+(eval-when (compile load eval)
+
+(defun wrapper-field (type)
+  (position type wrapper-layout))
+
+(defun next-wrapper-field (field-number)
+  (position (nth field-number wrapper-layout)
+	    wrapper-layout
+	    :start (1+ field-number)))
+
+);eval-when
+
+(defmacro wrapper-ref (wrapper n)
+  `(svref ,wrapper ,n))
+
+(defun emit-wrapper-ref (wrapper-operand field-operand)
+  (operand :iref wrapper-operand field-operand))
+
+	      
+(defmacro wrapper-state (wrapper)
+  `(wrapper-ref ,wrapper ,(wrapper-field 'state)))
+
+(defmacro wrapper-instance-slots-layout (wrapper)
+  `(wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout)))
+
+(defmacro wrapper-class-slots (wrapper)
+  `(wrapper-ref ,wrapper ,(wrapper-field 'class-slots)))
+
+(defmacro wrapper-class (wrapper)
+  `(wrapper-ref ,wrapper ,(wrapper-field 'class)))
+
+
+(defmacro make-wrapper-internal ()
+  `(let ((wrapper (make-array ,(length wrapper-layout) :adjustable nil)))
+     ,@(gathering1 (collecting)
+	 (iterate ((i (interval :from 0))
+		   (desc (list-elements wrapper-layout)))
+	   (ecase desc
+	     (number
+	      (gather1 `(setf (wrapper-ref wrapper ,i)
+			      (get-wrapper-cache-number))))
+	     ((state instance-slots-layout class-slots class)))))
+     (setf (wrapper-state wrapper) 't)     
+     wrapper))
+
+(defun make-wrapper (class)
+  (let ((wrapper (make-wrapper-internal)))
+    (setf (wrapper-class wrapper) class)
+    wrapper))
+
+;;;
+;;; The wrapper cache machinery provides general mechanism for trapping on
+;;; the next access to any instance of a given class.  This mechanism is
+;;; used to implement the updating of instances when the class is redefined
+;;; (make-instances-obsolete).  The same mechanism is also used to update
+;;; generic function caches when there is a change to the supers of a class.
+;;;
+;;; Basically, a given wrapper can be valid or invalid.  If it is invalid,
+;;; it means that any attempt to do a wrapper cache lookup using the wrapper
+;;; should trap.  Also, methods on slot-value-using-class check the wrapper
+;;; validity as well.  This is done by calling check-wrapper-validity.
+;;; 
+
+(defun invalid-wrapper-p (wrapper)
+  (neq (wrapper-state wrapper) 't))
+
+(defvar *previous-nwrappers* (make-hash-table))
+
+(defun invalidate-wrapper (owrapper state nwrapper)
+  (ecase state
+    ((flush obsolete)
+     (let ((new-previous ()))
+       ;;
+       ;; First off, a previous call to invalidate-wrapper may have recorded
+       ;; owrapper as an nwrapper to update to.  Since owrapper is about to
+       ;; be invalid, it no longer makes sense to update to it.
+       ;;
+       ;; We go back and change the previously invalidated wrappers so that
+       ;; they will now update directly to nwrapper.  This corresponds to a
+       ;; kind of transitivity of wrapper updates.
+       ;; 
+       (dolist (previous (gethash owrapper *previous-nwrappers*))
+	 (when (eq state 'obsolete)
+	   (setf (car previous) 'obsolete))
+	 (setf (cadr previous) nwrapper)
+	 (push previous new-previous))
+       
+       (iterate ((type (list-elements wrapper-layout))
+		 (i (interval :from 0)))
+	 (when (eq type 'number) (setf (wrapper-ref owrapper i) 0)))
+       (push (setf (wrapper-state owrapper) (list state nwrapper))
+	     new-previous)
+       
+       (setf (gethash owrapper *previous-nwrappers*) ()
+	     (gethash nwrapper *previous-nwrappers*) new-previous)))))
+
+(defun check-wrapper-validity (instance)
+  (let* ((owrapper (wrapper-of instance))
+	 (state (wrapper-state owrapper)))
+    (if (eq state  't)
+	owrapper
+	(let ((nwrapper
+		(ecase (car state)
+		  (flush
+		    (flush-cache-trap owrapper (cadr state) instance))
+		  (obsolete
+		    (obsolete-instance-trap owrapper (cadr state) instance)))))
+	  ;;
+	  ;; This little bit of error checking is superfluous.  It only
+	  ;; checks to see whether the person who implemented the trap
+	  ;; handling screwed up.  Since that person is hacking internal
+	  ;; CLOS code, and is not a user, this should be needless.  Also,
+	  ;; since this directly slows down instance update and generic
+	  ;; function cache refilling, feel free to take it out sometime
+	  ;; soon.
+	  ;; 
+	  (cond ((neq nwrapper (wrapper-of instance))
+		 (error "Wrapper returned from trap not wrapper of instance."))
+		((invalid-wrapper-p nwrapper)
+		 (error "Wrapper returned from trap invalid.")))
+	  nwrapper))))
+
+
+
+(defun compute-line-size (nelements) (expt 2 (ceiling (log nelements 2))))
+
+(defun compute-cache-parameters (nkeys valuep nlines-or-cache)
+  (declare (values cache-mask actual-size line-size nlines))
+  (flet ((compute-mask (cache-size line-size)
+	   (logxor (1- cache-size) (1- line-size))))
+    (if (= nkeys 1)
+	(let* ((line-size (if valuep 2 1))
+	       (cache-size (if (numberp nlines-or-cache)
+			       (* line-size
+				  (expt 2 (ceiling (log nlines-or-cache 2))))
+			       (cache-size nlines-or-cache))))
+	  (values (compute-mask cache-size line-size)
+		  cache-size
+		  line-size
+		  (/ cache-size line-size)))
+	(let* ((line-size (compute-line-size (+ nkeys (if valuep 1 0))))
+	       (cache-size (if (numberp nlines-or-cache)
+			       (* line-size 
+				  (expt 2 (ceiling (log nlines-or-cache 2))))
+			       (1- (cache-size nlines-or-cache)))))
+	  (values (compute-mask cache-size line-size)
+		  (1+ cache-size)
+		  line-size
+		  (/ cache-size line-size))))))
+
+
+
+;;;
+;;; The various implementations of computing a primary cache location from
+;;; wrappers.  Because some implementations of this must run fast there are
+;;; several implementations of the same algorithm.
+;;;
+;;; The algorithm is:
+;;;
+;;;  SUM       over the wrapper cache numbers,
+;;;  ENSURING  that the result is a fixnum
+;;;  MASK      the result against the mask argument.
+;;;
+;;;
+
+;;;
+;;; COMPUTE-PRIMARY-CACHE-LOCATION
+;;; 
+;;; The basic functional version.  This is used by the cache miss code to
+;;; compute the primary location of an entry.  
+;;;
+(defun compute-primary-cache-location (field mask wrappers)
+  (if (not (consp wrappers))
+      (logand mask (wrapper-ref wrappers field))
+      (let ((location 0))
+	(iterate ((wrapper (list-elements wrappers))
+		  (i (interval :from 0)))
+	  ;;
+	  ;; First add the cache number of this wrapper to location.
+	  ;; 
+	  (let ((wrapper-cache-number (wrapper-ref wrapper field)))
+	    (if (zerop wrapper-cache-number)
+		(return-from compute-primary-cache-location 0)
+		(setq location (+ location wrapper-cache-number))))
+	  ;;
+	  ;; Then, if we are working with lots of wrappers, deal with
+	  ;; the wrapper-cache-number-mask stuff.
+	  ;; 
+	  (when (and (not (zerop i))
+		     (zerop (mod i wrapper-cache-number-adds-ok)))
+	    (setq location
+		  (logand location wrapper-cache-number-mask))))
+	(1+ (logand mask location)))))
+
+;;;
+;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION
+;;;
+;;; This version is called on a cache line.  It fetches the wrappers from
+;;; the cache line and determines the primary location.  Various parts of
+;;; the cache filling code call this to determine whether it is appropriate
+;;; to displace a given cache entry.
+;;; 
+;;; If this comes across a wrapper whose cache-no is 0, it returns the symbol
+;;; invalid to suggest to its caller that it would be provident to blow away
+;;; the cache line in question.
+;;;
+(defun compute-primary-cache-location-from-location (field cache location mask nkeys)
+  (let ((result 0))
+    (dotimes (i nkeys)
+      (let* ((wrapper (cache-ref cache (+ i location)))
+	     (wcn (wrapper-ref wrapper field)))
+	(setq result (+ result wcn)))
+      (when (and (not (zerop i))
+		 (zerop (mod i wrapper-cache-number-adds-ok)))
+	(setq result (logand result wrapper-cache-number-mask)))
+      )    
+    (if (= nkeys 1)
+	(logand mask result)
+	(1+ (logand mask result)))))
+
+(defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no)
+  (with-lap-registers ((mask index))
+    (let ((field wrapper-cache-no))
+      (flatten-lap
+        (opcode :move (operand :cvar 'mask) mask)
+        (opcode :move (operand :cvar 'field) field)
+        (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
+        (opcode :move (operand :ilogand wrapper-cache-no mask) primary)))))
+
+(defun emit-n-wrapper-compute-primary-cache-location (wrappers primary miss-label)
+  (with-lap-registers ((field index)
+		       (mask index))
+    (let ((add-wrapper-cache-numbers
+	   (flatten-lap
+	    (gathering1 (flattening-lap)
+	       (iterate ((wrapper (list-elements wrappers))
+			 (i (interval :from 1)))
+		 (gather1
+		  (with-lap-registers ((wrapper-cache-no index))
+		    (flatten-lap
+		     (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
+		     (opcode :izerop wrapper-cache-no miss-label)
+		     (opcode :move (operand :i+ primary wrapper-cache-no) primary)
+		     (when (zerop (mod i wrapper-cache-number-adds-ok))
+		       (opcode :move (operand :ilogand primary mask) primary))))))))))
+      (flatten-lap
+       (opcode :move (operand :constant 0) primary)
+       (opcode :move (operand :cvar 'field) field)
+       (opcode :move (operand :cvar 'mask) mask)
+       add-wrapper-cache-numbers
+       (opcode :move (operand :ilogand primary mask) primary)
+       (opcode :move (operand :i1+ primary) primary)))))
+
+
+
+;;;
+;;;  NIL              means nothing so far, no actual arg info has NILs
+;;;                   in the metatype
+;;;  CLASS            seen all sorts of metaclasses
+;;;                   (specifically, more than one of the next 4 values)
+;;;  T                means everything so far is the class T
+;;;  STANDARD-CLASS   seen only standard classes
+;;;  BUILT-IN-CLASS   seen only built in classes
+;;;  STRUCTURE-CLASS  seen only structure classes
+;;;  
+(defun raise-metatype (metatype new-specializer)
+  (let ((standard  (find-class 'standard-class))
+	(fsc       (find-class 'funcallable-standard-class))
+;	(structure (find-class 'structure-class))
+	(built-in  (find-class 'built-in-class)))
+    (flet ((specializer->metatype (x)
+	     (let ((meta-specializer 
+		     (if (and (eq *boot-state* 'complete)
+			      (eql-specializer-p x))
+			 (class-of (class-of (eql-specializer-object x)))
+			 (class-of x))))
+	       (cond ((eq x *the-class-t*) t)
+		     ((*subtypep meta-specializer standard)  'standard-instance)
+		     ((*subtypep meta-specializer fsc)       'standard-instance)
+;                    ((*subtypep meta-specializer structure) 'structure-instance)
+		     ((*subtypep meta-specializer built-in)  'built-in-instance)
+		     (t (error "CLOS can not handle the specializer ~S (meta-specializer ~S)."
+			       new-specializer meta-specializer))))))
+      ;;
+      ;; We implement the following table.  The notation is
+      ;; that X and Y are distinct meta specializer names.
+      ;; 
+      ;;   NIL    <anything>    ===>  <anything>
+      ;;    X      X            ===>      X
+      ;;    X      Y            ===>    CLASS
+      ;;    
+      (let ((new-metatype (specializer->metatype new-specializer)))
+	(cond ((null metatype) new-metatype)
+	      ((eq metatype new-metatype) new-metatype)
+	      (t 'class))))))
+
+
+(defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot)
+  (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper")))
+    (with-lap-registers ((arg t))
+      (ecase metatype
+	(standard-instance
+	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
+		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")))
+	    (flatten-lap
+	      (opcode :move (operand :arg argument) arg)
+	      (opcode :std-instance-p arg get-std-inst-wrapper)	   ;is it a std wrapper?
+	      (opcode :fsc-instance-p arg get-fsc-inst-wrapper)	   ;is it a fsc wrapper?
+	      (opcode :go miss-label)
+	      (opcode :label get-fsc-inst-wrapper)
+	      (opcode :move (operand :fsc-wrapper arg) dest)	   ;get fsc wrapper
+	      (and slot
+		   (opcode :move (operand :fsc-slots arg) slot))
+	      (opcode :go exit-emit-fetch-wrapper)
+	      (opcode :label get-std-inst-wrapper)
+	      (opcode :move (operand :std-wrapper arg) dest)	   ;get std wrapper
+	      (and slot
+		   (opcode :move (operand :std-slots arg) slot))
+	      (opcode :label exit-emit-fetch-wrapper))))
+
+	(class
+	  (when slot (error "Can't do a slot reg for this metatype."))
+	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
+		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))
+		(get-built-in-wrapper (make-symbol "get-built-in-wrapper")))
+	    (flatten-lap
+	      (opcode :move (operand :arg argument) arg)
+	      (opcode :std-instance-p arg get-std-inst-wrapper)
+	      (opcode :fsc-instance-p arg get-fsc-inst-wrapper)
+	      (opcode :built-in-instance-p arg get-built-in-wrapper)
+	      ;; If the code falls through the checks above, there is a serious problem
+	      (opcode :label get-fsc-inst-wrapper)
+	      (opcode :move (operand :fsc-wrapper arg) dest)
+	      (opcode :go exit-emit-fetch-wrapper)
+	      (opcode :label get-built-in-wrapper)
+	      (opcode :move (operand :built-in-wrapper arg) dest)
+	      (opcode :go exit-emit-fetch-wrapper)
+	      (opcode :label get-std-inst-wrapper)
+	      (opcode :move (operand :std-wrapper arg) dest)
+	      (opcode :label exit-emit-fetch-wrapper))))
+	(structure-instance 
+	  (when slot (error "Can't do a slot reg for this metatype."))
+	  (error "Not yet implemented"))
+	(built-in-instance
+	  (when slot (error "Can't do a slot reg for this metatype."))
+	  (let ((get-built-in-wrapper (make-symbol "get-built-in-wrapper")))
+	    (flatten-lap
+	      (opcode :move (operand :arg argument) arg)
+	      (opcode :built-in-instance-p arg get-built-in-wrapper)
+	      (opcode :go miss-label)
+	      (opcode :label get-built-in-wrapper)
+	      (opcode :move (operand :built-in-wrapper arg) dest))))))))
+
+
+;;;
+;;; Some support stuff for getting a hold of symbols that we need when
+;;; building the discriminator codes.  Its ok for these to be interned
+;;; symbols because we don't capture any user code in the scope in which
+;;; these symbols are bound.
+;;; 
+
+(defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
+
+(defun dfun-arg-symbol (arg-number)
+  (or (nth arg-number (the list *dfun-arg-symbols*))
+      (intern (format nil ".ARG~A." arg-number) *the-clos-package*)))
+
+(defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
+
+(defun slot-vector-symbol (arg-number)
+  (or (nth arg-number (the list *slot-vector-symbols*))
+      (intern (format nil ".SLOTS~A." arg-number) *the-clos-package*)))
+
+(defun make-dfun-lambda-list (metatypes applyp)
+  (gathering1 (collecting)
+    (iterate ((i (interval :from 0))
+	      (s (list-elements metatypes)))
+      (progn s)
+      (gather1 (dfun-arg-symbol i)))
+    (when applyp
+      (gather1 '&rest)
+      (gather1 '.dfun-rest-arg.))))
+
+(defun make-dlap-lambda-list (metatypes applyp)
+  (gathering1 (collecting)
+    (iterate ((i (interval :from 0))
+	      (s (list-elements metatypes)))
+      (progn s)
+      (gather1 (dfun-arg-symbol i)))
+    (when applyp
+      (gather1 '&rest))))
+
+(defun make-dfun-call (metatypes applyp fn-variable)
+  (let ((required
+	  (gathering1 (collecting)
+	    (iterate ((i (interval :from 0))
+		      (s (list-elements metatypes)))
+	      (progn s)
+	      (gather1 (dfun-arg-symbol i))))))
+    (if applyp
+	`(apply   ,fn-variable ,@required .dfun-rest-arg.)
+	`(funcall ,fn-variable ,@required))))
+
+
+;;;
+;;; Here is where we actually fill, recache and expand caches.
+;;;
+;;; The function FILL-CACHE is the ONLY external entrypoint into this code.
+;;; It returns 4 values:
+;;;   a wrapper field number
+;;;   a cache
+;;;   a mask
+;;;   an absolute cache size (the size of the actual vector)
+;;;
+;;;
+(defun fill-cache (field cache nkeys valuep limit-fn wrappers value)
+  (declare (values field cache mask size))
+  (fill-cache-internal field cache nkeys valuep limit-fn wrappers value))
+
+(defun default-limit-fn (nlines)
+  (case nlines
+    ((1 2 4) 1)
+    ((8 16)  4)
+    (otherwise 6)))
+
+
+;;;
+;;; Its too bad Common Lisp compilers freak out when you have a defun with
+;;; a lot of LABELS in it.  If I could do that I could make this code much
+;;; easier to read and work with.
+;;;
+;;; Ahh Scheme...
+;;; 
+;;; In the absence of that, the following little macro makes the code that
+;;; follows a little bit more reasonable.  I would like to add that having
+;;; to practically write my own compiler in order to get just this simple
+;;; thing is something of a drag.
+;;;
+(eval-when (compile load eval)
+
+(proclaim '(special *nkeys* *valuep* *limit-fn*))
+
+;;; This patch avoids a bug in the ENVCALL instruction. Lookup of free
+;;; variables under ENVCALL always results in nil. In particular, the
+;;; compiler generates such code for flet and friends. Therefore, some
+;;; macros must be defined at top-level.
+
+;(defmacro cache     () '.cache.)
+;(defmacro nkeys () '*nkeys*)
+;(defmacro valuep    () '*valuep*)
+;(defmacro limit-fn  () '*limit-fn*)
+;(defmacro line-size () '.line-size.)
+;(defmacro mask      () '.mask.)
+;(defmacro size      () '.size.)
+;(defmacro nlines    () '.nlines.)
+;(defmacro line-reserved-p (line)
+;            `(and (= (nkeys) 1)
+;                 (= ,line 0)))
+;(defmacro line-location (line)
+;            `(and (null (line-reserved-p ,line))
+;                 (if (= (nkeys) 1)
+;                     (* ,line (line-size))
+;                     (1+ (* ,line (line-size))))))
+;(defmacro location-line (location)
+;            `(if (= (nkeys) 1)
+;                (/ ,location (line-size))
+;                (/ (1- ,location) (line-size))))
+;end patch
+
+(defvar *local-cache-functions*
+	`((cache     () .cache.)
+	  (nkeys     () *nkeys*)
+	  (valuep    () *valuep*)
+	  (limit-fn  () *limit-fn*)
+	  (line-size () .line-size.)
+	  (mask      () .mask.)
+	  (size      () .size.)
+	  (nlines    () .nlines.)
+	  ;;
+	  ;; Return T IFF this cache location is reserved.  The only time
+	  ;; this is true is for line number 0 of an nkeys=1 cache.  
+	  ;;
+	  (line-reserved-p (line)
+	    (and (= (nkeys) 1)
+		 (= line 0))) 
+	  ;;
+	  ;; Given a line number, return the cache location.  This is the
+	  ;; value that is the second argument to cache-ref.  Basically,
+	  ;; this deals with the offset of nkeys>1 caches and multiplies
+	  ;; by line size.  This returns nil if the line is reserved.
+	  ;; 	  
+	  (line-location (line)
+	    (and (null (line-reserved-p line))
+		 (if (= (nkeys) 1)
+		     (* line (line-size))
+		     (1+ (* line (line-size)))))) 
+	  ;;
+	  ;; Given a cache location, return the line.  This is the inverse
+	  ;; of LINE-LOCATION.
+	  ;; 	  
+	  (location-line (location)
+	    (if (= (nkeys) 1)
+		(/ location (line-size))
+		(/ (1- location) (line-size)))) 
+	  ;;
+	  ;; Given a line number, return the wrappers stored at that line.
+	  ;; As usual, if nkeys=1, this returns a single value.  Only when
+	  ;; nkeys>1 does it return a list.  An error is signalled if the
+	  ;; line is reserved.
+	  ;;
+	  (line-wrappers (line)
+	    (when (line-reserved-p line) (error "Line is reserved."))
+	    (let ((location (line-location line)))
+	      (if (= (nkeys) 1)
+		  (cache-ref (cache) location)
+		  (gathering1 (collecting)
+		    (dotimes (i (nkeys))
+		      (gather1 (cache-ref (cache) (+ location i))))))))
+	  ;;
+	  ;; Given a line number, return the value stored at that line.
+	  ;; If valuep is NIL, this returns NIL.  As with line-wrappers,
+	  ;; an error is signalled if the line is reserved.
+	  ;; 
+	  (line-value (line)
+	    (when (line-reserved-p line) (error "Line is reserved."))
+	    (and (valuep)
+		 (cache-ref (cache) (+ (line-location line) (nkeys)))))
+	  ;;
+	  ;; Given a line number, return true IFF that line has data in
+	  ;; it.  The state of the wrappers stored in the line is not
+	  ;; checked.  An error is signalled if line is reserved.
+	  (line-full-p (line)
+	    (when (line-reserved-p line) (error "Line is reserved."))
+	    (not (null (cache-ref (cache) (line-location line)))))
+	  ;;
+	  ;; Given a line number, return true IFF the line is full and
+	  ;; there are no invalid wrappers in the line, and the line's
+	  ;; wrappers are different from wrappers.
+	  ;; An error is signalled if the line is reserved.
+	  ;;
+	  (line-valid-p (line wrappers)
+	    (when (line-reserved-p line) (error "Line is reserved."))
+	    (let ((loc (line-location line)))
+	      (dotimes (i (nkeys) t)
+		(let ((wrapper (cache-ref (cache) (+ loc i))))
+		  (when (or (null wrapper)
+;***					(numberp wrapper)
+					;Think of this as an optimized:
+					; (and (zerop i)
+					;      (= (nkeys) 1)
+					;      (null (valuep))
+					;      (numberp wrapper))
+                            (invalid-wrapper-p wrapper))
+                    (return nil))))))
+	  ;;
+	  ;; How many unreserved lines separate line-1 and line-2.
+	  ;;
+	  (line-separation (line-1 line-2)
+	    (let ((diff (- line-2 line-1)))
+	      (cond ((zerop diff) diff)
+		    ((plusp diff) diff)
+		    (t
+		     (if (line-reserved-p 0)
+			 (1- (+ (- (nlines) line-1) line-2))
+			 (+ (- (nlines) line-1) line-2))))))
+	  ;;
+	  ;; Given a cache line, get the next cache line.  This will not
+	  ;; return a reserved line.
+	  ;; 
+	  (next-line (line)
+	    (if (= line (1- (nlines)))
+		(if (line-reserved-p 0) 1 0)
+		(1+ line)))
+	  ;;
+	  ;; Given a line which has a valid entry in it, this will return
+	  ;; the primary cache line of the wrappers in that line.  We just
+	  ;; call COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this is an
+	  ;; easier packaging up of the call to it.
+	  ;; 
+	  (line-primary (field line)
+	    (location-line
+	      (compute-primary-cache-location-from-location
+		field (cache) (line-location line) (mask) (nkeys))))
+	  ;;
+	  ;;
+	  (fill-line (line wrappers value)
+	    (when (line-reserved-p line)
+	      (error "Attempt to fill a reserved line."))
+	    (let ((loc (line-location line)))
+	      (cond ((= (nkeys) 1)
+		     (setf (cache-ref (cache) loc) wrappers)
+		     (when (valuep) (setf (cache-ref (cache) (1+ loc)) value)))
+		    (t
+		     (iterate ((i (interval :from 0))
+			       (w (list-elements wrappers)))
+		       (setf (cache-ref (cache) (+ loc i)) w))
+		     (when (valuep) (setf (cache-ref (cache) (+ loc (nkeys))) value))))))
+	  ;;
+	  ;; Blindly copy the contents of one cache line to another.  The
+	  ;; contents of the <to> line are overwritten, so whatever was in
+	  ;; there should already have been moved out.
+	  ;;
+	  ;; For convenience in debugging, this also clears out the from
+	  ;; location after it has been copied.
+	  ;;
+	  (copy-line (from to)
+	    (if (line-reserved-p to)
+		(error "Copying something into a reserved cache line.")
+		(let ((from-loc (line-location from))
+		      (to-loc (line-location to)))
+		  (modify-cache (cache)
+		    (dotimes (i (line-size))
+		      (setf (cache-ref (cache) (+ to-loc i))
+			    (cache-ref (cache) (+ from-loc i)))
+		      (setf (cache-ref (cache) (+ from-loc i))
+			    nil))))))
+	  ;;
+	  ;;
+	  ;;
+	  (transfer-line (from-cache from-line to-cache to-line)
+	    (if (line-reserved-p to-line)
+		(error "transfering something into a reserved cache line.")
+		(let ((from-loc (line-location from-line))
+		      (to-loc (line-location to-line)))
+		  (modify-cache to-cache
+		    (dotimes (i (line-size))
+		      (setf (cache-ref to-cache (+ to-loc i))
+			    (cache-ref from-cache (+ from-loc i))))))))
+	  ))
+
+(defmacro with-local-cache-functions ((cache) &body body &environment env)
+  `(let ((.cache. ,cache))
+     (declare (type simple-vector .cache.))
+     (multiple-value-bind (.mask. .size. .line-size. .nlines.)
+	 (compute-cache-parameters *nkeys* *valuep* .cache.)
+       (declare (type fixnum .mask. .size. .line-size. .nlines.))
+       (progn .mask. .size. .line-size. .nlines.)
+       (labels ,(mapcar #'(lambda (fn) (assq fn *local-cache-functions*))
+			(pickup-local-cache-functions body env))
+	 ,@body))))
+
+(defun pickup-local-cache-functions (body env)
+  (let ((functions ())
+	(possible-functions (mapcar #'car *local-cache-functions*)))
+    (labels ((walk-function (form context env)
+	       (declare (ignore env))
+	       (when (and (eq context :eval)
+			  (consp form)
+			  (symbolp (car form)))
+		 (let ((name (car form)))
+		   (when (and (not (memq name functions))
+			      (memq name possible-functions))
+		     (pushnew name functions)
+		     (walk (cddr (assq name *local-cache-functions*))))))
+	       form)
+	     (walk (body)
+	       (walk-form `(progn . ,body) env #'walk-function)))
+      (walk body)
+      functions)))
+
+)
+
+
+;;;
+;;; returns 4 values, <field> <cache> <mask> <size>
+;;; It tries to re-adjust the cache every time it makes a new fill.  The
+;;; intuition here is that we want uniformity in the number of probes needed to
+;;; find an entry.  Furthermore, adjusting has the nice property of throwing out
+;;; any entries that are invalid.
+;;;
+(defun fill-cache-internal (field cache nkeys valuep limit-fn wrappers value)
+  (let ((*nkeys* nkeys)
+	(*valuep* valuep)
+	(*limit-fn* limit-fn))
+    (with-local-cache-functions (cache)
+      (flet ((4-values-please (f c)
+	       (multiple-value-bind (mask size)
+		   (compute-cache-parameters *nkeys* *valuep* c)
+		 (values f c mask size))))
+	(let ((easy-fill-p (fill-cache-p nil field cache wrappers value)))
+	  (if easy-fill-p
+	      (4-values-please field cache)
+	      (multiple-value-bind (adj-field adj-cache)
+		  (adjust-cache field cache wrappers value)
+		(if adj-field
+		    (4-values-please adj-field adj-cache)
+		    (multiple-value-bind (exp-field exp-cache)
+			(expand-cache field cache wrappers value)
+		      (4-values-please exp-field exp-cache))))))))))
+
+;;;
+;;; returns T or NIL
+;;;
+(defun fill-cache-p (forcep field cache wrappers value)
+  (with-local-cache-functions (cache)
+    (let* ((primary (location-line (compute-primary-cache-location field (mask) wrappers))))
+      (multiple-value-bind (free emptyp)
+	  (find-free-cache-line primary field cache wrappers)
+	(when (or forcep emptyp) (fill-line free wrappers value) t)))))
+
+(defun fill-cache-from-cache-p (forcep field cache from-cache from-line)
+  (with-local-cache-functions (from-cache)
+    (let ((primary (line-primary field from-line)))
+      (multiple-value-bind (free emptyp)
+	  (find-free-cache-line primary field cache)
+	(when (or forcep emptyp)
+	  (transfer-line from-cache from-line cache free)
+	  t)))))
+
+(defun entry-in-cache-p (field cache wrappers value)
+  (declare (ignore field value))
+  (with-local-cache-functions (cache)
+    (dotimes (i (nlines))
+      (unless (line-reserved-p i)
+	(when (equal (line-wrappers i) wrappers) (return t))))))
+
+;;;
+;;; Returns NIL or (values <field> <cache>)
+;;; 
+;;; This is only called when it isn't possible to put the entry in the cache
+;;; the easy way.  That is, this function assumes that FILL-CACHE-P has been
+;;; called as returned NIL.
+;;;
+;;; If this returns NIL, it means that it wasn't possible to find a wrapper
+;;; field for which all of the entries could be put in the cache (within the
+;;; limit).  
+;;;
+(defun adjust-cache (field cache wrappers value)
+  (with-local-cache-functions (cache)
+    (let ((ncache (get-cache (size))))
+      (do ((nfield field (next-wrapper-field nfield)))
+	  ((null nfield) (free-cache ncache) nil)
+	(labels ((try-one-fill-from-line (line)
+		   (fill-cache-from-cache-p nil nfield ncache cache line))
+		 (try-one-fill (wrappers value)
+		   (fill-cache-p nil nfield ncache wrappers value)))
+	  (if (and (dotimes (i (nlines) t)
+		     (when (and (null (line-reserved-p i))
+				(line-valid-p i wrappers))
+		       (unless (try-one-fill-from-line i) (return nil))))
+		   (try-one-fill wrappers value))
+	      (return (values nfield ncache))
+	      (flush-cache-internal ncache)))))))
+
+		       
+;;;
+;;; returns: (values <field> <cache>)
+;;;
+(defun expand-cache (field cache wrappers value)
+  (declare (values field cache) (ignore field))
+  (with-local-cache-functions (cache)
+    (multiple-value-bind (ignore size)
+	(compute-cache-parameters (nkeys) (valuep) (* (nlines) 2))
+      (let* ((ncache (get-cache size))
+	     (nfield (wrapper-field 'number)))
+	(labels ((do-one-fill-from-line (line)
+		   (unless (fill-cache-from-cache-p nil nfield ncache cache line)
+		     (do-one-fill (line-wrappers line) (line-value line))))
+		 (do-one-fill (wrappers value)
+		   (multiple-value-bind (adj-field adj-cache)
+		       (adjust-cache nfield ncache wrappers value)
+		     (if adj-field
+			 (setq nfield adj-field ncache adj-cache)
+			 (fill-cache-p t nfield ncache wrappers value))))
+		 (try-one-fill (wrappers value)
+		   (fill-cache-p nil nfield ncache wrappers value)))
+	  (dotimes (i (nlines))
+	    (when (and (null (line-reserved-p i))
+		       (line-valid-p i wrappers))
+	      (do-one-fill-from-line i)))
+	  (unless (try-one-fill wrappers value)
+	    (do-one-fill wrappers value))
+	  (values nfield ncache))))))
+
+
+;;;
+;;; This is the heart of the cache filling mechanism.  It implements the decisions
+;;; about where entries are placed.
+;;; 
+;;; Find a line in the cache at which a new entry can be inserted.
+;;;
+;;;   <line>
+;;;   <empty?>           is <line> in fact empty?
+;;;
+(defun find-free-cache-line (primary field cache &optional wrappers)
+  (declare (values line empty?))
+  (with-local-cache-functions (cache)
+    (let ((limit (funcall (limit-fn) (nlines)))
+	  (wrappedp nil))
+      (when (line-reserved-p primary) (setq primary (next-line primary)))
+      (labels (;;
+	       ;; Try to find a free line starting at <start>.  <primary>
+	       ;; is the primary line of the entry we are finding a free
+	       ;; line for, it is used to compute the seperations.
+	       ;;
+	       (find-free (p s)
+		 (do* ((line s (next-line line))
+		       (nsep (line-separation p s) (1+ nsep)))
+		      (())
+		   (if (null (line-valid-p line wrappers)) ;If this line is empty or
+		       (return (values line t))	           ;invalid, just use it.
+
+		       (let ((osep (line-separation (line-primary field line) line)))
+			 (if (and wrappedp (>= line primary))
+			     ;;
+			     ;; have gone all the way around the cache, time to quit
+			     ;; 
+			     (return (values line nil))
+			     
+			     (when (cond ((or (= nsep limit)) t)
+					 ((= nsep osep) (zerop (random 2)))
+					 ((> nsep osep) t)
+					 (t nil))
+			       ;;
+			       ;; Try to displace what is in this line so that we
+			       ;; can use the line.
+			       ;;
+			       (return (values line (displace line)))))))
+		   
+		   (if (= line (1- (nlines))) (setq wrappedp t))))
+	       ;;
+	       ;; Given a line, attempt to free up that line by moving its
+	       ;; contents elsewhere. Returns nil when it wasn't possible to
+	       ;; move the contents of the line without dumping something on
+	       ;; the floor.  
+	       ;; 
+	       (displace (line)
+		 (if (= line (1- (nlines))) (setq wrappedp t))
+		 (multiple-value-bind (dline dempty?)
+		     (find-free (line-primary field line) (next-line line))
+		   (when dempty? (copy-line line dline) t))))
+	
+	(find-free primary primary)))))
diff --git a/clos/2.0/clos-env-internal.lisp b/clos/2.0/clos-env-internal.lisp
new file mode 100644
index 00000000..6d720032
--- /dev/null
+++ b/clos/2.0/clos-env-internal.lisp
@@ -0,0 +1,260 @@
+(DEFINE-FILE-INFO PACKAGE "XCL" READTABLE "XCL")
+(il:filecreated "28-Aug-87 18:42:36" il:{phylum}<clos>clos-env-internal.\;1 8356   
+
+      il:|changes| il:|to:|  (il:vars il:clos-env-internalcoms)
+                             (il:props (il:clos-env-internal il:makefile-environment))
+                             (il:functions stack-eql stack-pointer-frame stack-frame-valid-p 
+                                    stack-frame-fn-header stack-frame-pc fnheader-debugging-info 
+                                    stack-frame-name compiled-closure-fnheader compiled-closure-env)
+)
+
+
+; Copyright (c) 1987 by Xerox Corporation.  All rights reserved.
+
+(il:prettycomprint il:clos-env-internalcoms)
+
+(il:rpaqq il:clos-env-internalcoms (
+
+(il:* il:|;;;| "***************************************")
+
+                                   
+
+(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation.  All rights reserved.")
+
+                                   
+
+(il:* il:|;;;| "")
+
+                                   
+
+(il:* il:|;;;| "Use and copying of this software and preparation of derivative works based upon this software are permitted.  Any distribution of this software or derivative works must comply with all applicable United States export control laws.")
+
+                                   
+
+(il:* il:|;;;| " ")
+
+                                   
+
+(il:* il:|;;;| "This software is made available AS IS, and Xerox Corporation makes no  warranty about the software, its performance or its conformity to any  specification.")
+
+                                   
+
+(il:* il:|;;;| " ")
+
+                                   
+
+(il:* il:|;;;| "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:")
+
+                                   
+
+(il:* il:|;;;| "   CommonLoops Coordinator")
+
+                                   
+
+(il:* il:|;;;| "   Xerox Artifical Intelligence Systems")
+
+                                   
+
+(il:* il:|;;;| "   2400 Hanover St.")
+
+                                   
+
+(il:* il:|;;;| "   Palo Alto, CA 94303")
+
+                                   
+
+(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)")
+
+                                   
+
+(il:* il:|;;;| "")
+
+                                   
+
+(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.")
+
+                                   
+
+(il:* il:|;;;| " *************************************************************************")
+
+                                   
+
+(il:* il:|;;;| "")
+
+                                   (il:declare\: il:dontcopy (il:prop il:makefile-environment 
+                                                                    il:clos-env-internal))
+                                                             (il:* il:\; 
+                                                             "We're off to hack the system...")
+
+                                   (il:declare\: il:eval@compile il:dontcopy (il:files clos::abc)
+                                          
+          
+          (il:* il:|;;| "The Deltas and The East and The Freeze")
+)
+                                   (il:functions stack-eql stack-pointer-frame stack-frame-valid-p 
+                                          stack-frame-fn-header stack-frame-pc 
+                                          fnheader-debugging-info stack-frame-name 
+                                          compiled-closure-fnheader compiled-closure-env)))
+
+
+
+(il:* il:|;;;| "***************************************")
+
+
+
+
+(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation.  All rights reserved.")
+
+
+
+
+(il:* il:|;;;| "")
+
+
+
+
+(il:* il:|;;;| 
+"Use and copying of this software and preparation of derivative works based upon this software are permitted.  Any distribution of this software or derivative works must comply with all applicable United States export control laws."
+)
+
+
+
+
+(il:* il:|;;;| " ")
+
+
+
+
+(il:* il:|;;;| 
+"This software is made available AS IS, and Xerox Corporation makes no  warranty about the software, its performance or its conformity to any  specification."
+)
+
+
+
+
+(il:* il:|;;;| " ")
+
+
+
+
+(il:* il:|;;;| 
+"Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:"
+)
+
+
+
+
+(il:* il:|;;;| "   CommonLoops Coordinator")
+
+
+
+
+(il:* il:|;;;| "   Xerox Artifical Intelligence Systems")
+
+
+
+
+(il:* il:|;;;| "   2400 Hanover St.")
+
+
+
+
+(il:* il:|;;;| "   Palo Alto, CA 94303")
+
+
+
+
+(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)")
+
+
+
+
+(il:* il:|;;;| "")
+
+
+
+
+(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.")
+
+
+
+
+(il:* il:|;;;| " *************************************************************************")
+
+
+
+
+(il:* il:|;;;| "")
+
+(il:declare\: il:dontcopy 
+
+(il:putprops il:clos-env-internal il:makefile-environment (:package "XCL" :readtable "XCL"))
+)
+
+
+
+(il:* il:\; "We're off to hack the system...")
+
+(il:declare\: il:eval@compile il:dontcopy 
+(il:filesload clos::abc)
+)
+
+(defun stack-eql (x y) "Test two stack pointers for equality" (and (il:stackp x)
+                                                                   (il:stackp y)
+                                                                   (eql (il:fetch (il:stackp il:edfxp
+                                                                                         )
+                                                                           il:of x)
+                                                                        (il:fetch (il:stackp il:edfxp
+                                                                                         )
+                                                                           il:of y))))
+
+
+(defun stack-pointer-frame (stack-pointer) (il:|fetch| (il:stackp il:edfxp) il:|of| stack-pointer))
+
+
+(defun stack-frame-valid-p (frame) (not (il:|fetch| (il:fx il:invalidp) il:|of| frame)))
+
+
+(defun stack-frame-fn-header (frame) (il:|fetch| (il:fx il:fnheader) il:|of| frame))
+
+
+(defun stack-frame-pc (frame) (il:|fetch| (il:fx il:pc) il:|of| frame))
+
+
+(defun fnheader-debugging-info (fnheader) (let* ((start-pc (il:fetch (il:fnheader il:startpc)
+                                                              il:of fnheader))
+                                                 (name-table-words
+                                                  (let ((size (il:fetch (il:fnheader il:ntsize)
+                                                                 il:of fnheader)))
+                                                       (if (zerop size)
+                                                           il:wordsperquad
+                                                           (* size 2))))
+                                                 (past-name-table-in-words (+ (il:fetch (il:fnheader
+                                                                                         
+                                                                                     il:overheadwords
+                                                                                         )
+                                                                                 il:of fnheader)
+                                                                              name-table-words)))
+                                                (and (= (- start-pc (* il:bytesperword 
+                                                                       past-name-table-in-words))
+                                                        il:bytespercell)
+          
+          (il:* il:|;;| "It's got a debugging-info list.")
+
+                                                     (il:\\getbaseptr fnheader 
+                                                            past-name-table-in-words))))
+
+
+(defun stack-frame-name (frame) (il:|fetch| (il:fx il:framename) il:|of| frame))
+
+
+(defun compiled-closure-fnheader (closure) (il:|fetch| (il:compiled-closure il:fnheader) il:|of|
+                                                                                         closure))
+
+
+(defun compiled-closure-env (closure) (il:fetch (il:compiled-closure il:environment) il:of closure))
+
+(il:putprops il:clos-env-internal il:copyright ("Xerox Corporation" 1987))
+(il:declare\: il:dontcopy
+  (il:filemap (nil)))
+il:stop
diff --git a/clos/2.0/clos-env.lisp b/clos/2.0/clos-env.lisp
new file mode 100644
index 00000000..be366810
--- /dev/null
+++ b/clos/2.0/clos-env.lisp
@@ -0,0 +1,1609 @@
+;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;; Medley-Lisp specific environment hacking for CLOS
+
+(in-package "CLOS")
+
+;; 
+;; Protect the Corporation
+;; 
+(eval-when (eval load)
+  (format *terminal-io*
+    "~&;CLOS-ENV Copyright (c) 1991 by ~
+        Venue Corporation.  All rights reserved.~%"))
+
+
+;;; Make funcallable instances (FINs) print by calling print-object.
+
+(eval-when (eval load)
+  (il:defprint 'il:compiled-closure 'il:print-closure))
+
+(defun il:print-closure (x &optional stream depth)
+  ;; See the IRM, section 25.3.3.  Unfortunatly, that documentation is
+  ;; not correct.  In particular, it makes no mention of the third argument.
+  (cond ((not (funcallable-instance-p x))
+	 ;; IL:\CCLOSURE.DEFPRINT is the orginal system function for
+	 ;; printing closures
+	 (il:\\cclosure.defprint x stream))
+	((streamp stream)
+	 ;; Use the standard CLOS printing method, then return T to tell
+	 ;; the printer that we have done the printing ourselves.
+	 (print-object x stream)
+	 t)
+	(t 
+	 ;; Internal printing (again, see the IRM section 25.3.3). 
+	 ;; Return a list containing the string of characters that
+	 ;; would be printed, if the object were being printed for
+	 ;; real.
+	 (with-output-to-string (stream)
+	   (list (print-object x stream))))))
+
+
+;;; Naming methods
+
+(defun gf-named (gf-name)
+  (let ((spec (cond ((symbolp gf-name) gf-name)
+		    ((and (consp gf-name)
+			  (eq (first gf-name) 'setf)
+			  (symbolp (second gf-name))
+			  (null (cddr gf-name)))
+		     (get-setf-function-name (second gf-name)))
+		    (t nil))))
+    (if (and (fboundp spec)
+	     (generic-function-p (symbol-function spec)))
+	(symbol-function spec)
+	nil)))
+
+(defun generic-function-method-names (gf-name hasdefp)
+  (if hasdefp
+      (let ((names nil))
+        (maphash #'(lambda (key value)
+                     (declare (ignore value))
+                     (when (and (consp key) (eql (car key) gf-name))
+                       (pushnew key names)))
+                 (gethash 'methods xcl:*definition-hash-table*))
+        names)
+      (let ((gf (gf-named gf-name)))
+        (when gf
+          (mapcar #'full-method-name (generic-function-methods gf))))))
+
+(defun full-method-name (method)
+  "Return the full name of the method"
+  (let ((specializers (mapcar #'(lambda (x)
+		                  (cond ((eq x 't) t)
+		                        ((and (consp x) (eq (car x) 'eql)) x)
+		                        (t (class-name x))))
+		       (method-specializers method))))
+    ;; Now go through some hair to make sure that specializer is
+    ;; really right.  Once CLOS returns the right value for
+    ;; specializers this can be taken out.
+    (let* ((arglist (method-lambda-list method))
+	   (number-required (or (position-if
+				  #'(lambda (x) (member x lambda-list-keywords))
+				  arglist)
+				(length arglist)))
+	   (diff (- number-required (length specializers))))
+      (when (> diff 0)
+	(setq specializers (nconc (copy-list specializers)
+				  (make-list diff :initial-element 't)))))
+    (make-full-method-name (generic-function-name
+			       (method-generic-function method))
+			   (method-qualifiers method)
+			   specializers)))
+
+(defun make-full-method-name (generic-function-name qualifiers arg-types)
+  "Return the full name of a method, given the generic-function name, the method
+qualifiers, and the arg-types"
+  ;; The name of the method is:
+  ;;      (<generic-function-name> <qualifier-1> .. 
+  ;;         (<arg-specializer-1>..))
+  (labels ((remove-trailing-ts (l)
+	     (if (null l)
+		 nil
+		 (let ((tail (remove-trailing-ts (cdr l))))
+		   (if (null tail)
+		       (if (eq (car l) 't)
+			   nil
+			   (list (car l)))
+		       (if (eq l tail)
+			   l
+			   (cons (car l) tail)))))))
+    `(,generic-function-name ,@qualifiers
+      ,(remove-trailing-ts arg-types))))
+
+(defun parse-full-method-name (method-name)
+  "Parse the method name, returning the gf-name, the qualifiers, and the
+arg-types."
+  (values (first method-name)
+	  (butlast (rest method-name))
+	  (car (last method-name))))
+
+(defun prompt-for-full-method-name (gf-name &optional has-def-p)
+  "Prompt the user for the full name of a method on the given generic function name"
+  (let ((method-names (generic-function-method-names gf-name has-def-p)))
+    (cond ((null method-names)
+	   nil)
+	  ((null (cdr method-names))
+	   (car method-names))
+	  (t (il:menu
+	      (il:create
+	       il:menu il:items il:_	;If HAS-DEF-P, include only
+					; those methods that have a
+					; symbolic def'n that we can
+					; find
+	       (remove-if #'null
+			  (mapcar #'(lambda (m)
+				      (if (or (not has-def-p)
+					      (il:hasdef m 'methods))
+					  `(,(with-output-to-string (s)
+					       (dolist (x m)
+						 (format s "~A " x))
+					       s)
+					    ',m)
+					  nil))
+				  method-names))
+	       il:title il:_ "Which method?"))))))
+
+
+;;; Converting generic defining macros into DEFDEFINER macros
+
+(defmacro make-defdefiner (definer-name definer-type type-description &body 
+					definer-options)
+  "Make the DEFINER-NAME use DEFDEFINER, defining items of type DEFINER-TYPE"
+  (let ((old-definer-macro-name (intern (string-append definer-name
+						       " old definition")
+					(symbol-package definer-name)))
+	(old-definer-macro-expander (intern (string-append definer-name 
+							   " old expander")
+					    (symbol-package definer-name))))
+    `(progn 
+      ;; First, move the current defining function off to some safe
+      ;; place
+      (unmake-defdefiner ',definer-name)
+      (cond ((not (fboundp ',definer-name))
+	     (error "~A has no definition!" ',definer-name))
+	    ((fboundp ',old-definer-macro-name))
+	    ((macro-function ',definer-name)
+					; We have to move the macro
+					; expansion function as well,
+					; so it won't get clobbered
+					; when the original macro is
+					; redefined.  See AR 7410.
+	     (let* ((expansion-function (macro-function ',definer-name)))
+	       (setf (symbol-function ',old-definer-macro-expander)
+		     (loop (if (symbolp expansion-function)
+			       (setq expansion-function
+				     (symbol-function expansion-function))
+			       (return expansion-function))))
+	       (setf (macro-function ',old-definer-macro-name)
+		     ',old-definer-macro-expander)
+	       (setf (get ',definer-name 'make-defdefiner) expansion-function)))
+	    (t (error "~A does not name a macro." ',definer-name)))
+      ;; Make sure the type is defined
+      (xcl:def-define-type ,definer-type ,type-description)
+      ;; Now redefine the definer, using DEFEDFINER and the original def'n
+      (xcl:defdefiner ,(if definer-options
+			   (cons definer-name definer-options)
+			   definer-name)
+	  ,definer-type	(&body b) `(,',old-definer-macro-name ,@,'b)))))
+
+(defun unmake-defdefiner (definer-name)
+  (let ((old-expander (get definer-name 'make-defdefiner)))
+    (when old-expander
+      (setf (macro-function definer-name old-expander))
+      (remprop definer-name 'make-defdefiner))))
+
+
+;;; For tricking ED into being able to use just the generic-function-name
+;;; instead of the full method name
+
+(defun source-manager-method-edit-fn (name type source editcoms options)
+  "Edit a method of the given name"
+  (let ((full-name (if (gf-named name)
+					;If given the name of a
+					; generic-function, try to get
+					; the full method name
+		       (prompt-for-full-method-name name t)
+					; Otherwise it should name the
+					; method
+		       name)))
+    (when (not (null full-name))
+      (il:default.editdef full-name type source editcoms options))
+    (or full-name name)))		;Return the name
+
+(defun source-manager-method-hasdef-fn (name type &optional source)
+  "Is there a method defined with the given name?"
+  (cond ((not (eq type 'methods)) nil)
+	((or (symbolp name)
+	     (and (consp name)
+		  (eq (first name) 'setf)
+		  (symbolp (second name))
+		  (null (cddr name))))
+	 ;; If passed in the name of a generic-function, pretend that
+	 ;; there is a method by that name if there is a generic function
+	 ;; by that name, and there is a method whose source we can find.
+	 (if (and (not (null (gf-named name)))
+		  (find-if #'(lambda (m)
+			       (il:hasdef m type source))
+			   (generic-function-method-names name t)))
+	     name
+	     nil))
+	((and (consp name) (>= (length name) 2))
+	 ;; Standard methods are named (gf-name {qualifiers}* ({specializers}*))
+	 (when (il:getdef name type source '(il:nocopy il:noerror))
+	   name))
+	(t
+	 ;; Nothing else can name a method
+	 nil)))
+
+;;; Initialize the CLOS env
+
+(defun initialize-clos-env nil
+  "Initialize the Medley CLOS environment" 
+  ;; Set up SourceManager DEFDEFINERS for classes and methods.
+  ;;
+  ;; Make sure to define methods before classes, so that (IL:FILES?) will build
+  ;; filecoms that have classes before methods. 
+  (unless (il:hasdef 'methods 'il:filepkgtype)
+    (make-defdefiner defmethod methods "methods"
+		     (:name (lambda (form)
+			      (multiple-value-bind (name qualifiers arglist)
+				  (parse-defmethod (cdr form))
+				(make-full-method-name name qualifiers
+				    (specialized-lambda-list-specializers
+					arglist)))))
+		     (:undefiner
+		      (lambda (method-name)
+			(multiple-value-bind
+			      (name qualifiers arg-types)
+			    (parse-full-method-name method-name)
+			  (let* ((gf (gf-named name))
+				 (method (when gf
+					   (get-method gf qualifiers
+						       (mapcar #'find-class 
+							       arg-types)))))
+			    (when method (remove-method gf method))))))))
+  ;; Include support for DEFGENERIC, if that is defined
+  (unless (or (not (fboundp 'defgeneric))
+	      (il:hasdef 'generic-functions 'il:filepkgtype))
+    (make-defdefiner defgeneric generic-functions "generic-function definitions"))
+  ;; DEFCLASS FileManager stuff
+  (unless (il:hasdef 'classes 'il:filepkgtype)
+    (make-defdefiner defclass classes "class definitions"
+		     (:undefiner (lambda (name)
+				   (when (find-class name t)
+				     (setf (find-class name) nil)))))
+    ;; CLASSES "include" TYPES.
+    (il:filepkgcom 'classes 'il:contents
+		   #'(lambda (com name type &optional reason)
+		       (declare (ignore name reason))
+		       (if (member type '(il:types classes) :test #'eq)
+			   (cdr com)
+			   nil))))
+  ;; Set up the hooks so that ED can be handed the name of a generic function,
+  ;; and end up editing a method instead
+  (il:filepkgtype 'methods 'il:editdef 'source-manager-method-edit-fn
+		  'il:hasdef 'source-manager-method-hasdef-fn)
+  ;; Set up the inspect macro.  The right way to do this is to
+  ;; (ENSURE-GENERIC-FUNCTION 'IL:INSPECT...), but for now...
+  (push '((il:function clos-object-p) . \\internal-inspect-object)
+	il:inspectmacros)
+  ;; Unmark any SourceManager changes caused by this loadup
+  (dolist (com (il:filepkgchanges))
+    (dolist (name (cdr com))
+      (when (and (symbolp name)
+		 (eq (symbol-package name) (find-package "CLOS")))
+	(il:unmarkaschanged name (car com))))))
+
+(eval-when (eval load)
+  (initialize-clos-env))
+
+
+;;; Inspecting CLOS objects
+
+(defun clos-object-p (x)
+  "Is the datum a CLOS object?"
+  (or (std-instance-p x)
+      (fsc-instance-p x)))
+
+(defun \\internal-inspect-object (x type where)
+  (inspect-object x type where))
+
+(defun \\internal-inspect-slot-names (x)
+  (inspect-slot-names x))
+
+(defun \\internal-inspect-slot-value (x slot-name)
+  (inspect-slot-value x slot-name))
+
+(defun \\internal-inspect-setf-slot-value (x slot-name value)
+  (inspect-setf-slot-value x slot-name value))
+
+(defun \\internal-inspect-slot-name-command (slot-name x window)
+  (inspect-slot-name-command slot-name x window))
+
+(defun \\internal-inspect-title (x y)
+  (inspect-title x y))
+
+(defmethod inspect-object (x type where)
+  "Open an insect window on the object x"
+  (il:inspectw.create x '\\internal-inspect-slot-names
+              '\\internal-inspect-slot-value
+              '\\internal-inspect-setf-slot-value
+              '\\internal-inspect-slot-name-command nil nil 
+              '\\internal-inspect-title nil where
+              #'(lambda (n v)		;Same effect as NIL, but avoids bug in
+		  (declare (ignore v))	; INSPECTW.CREATE
+		  n)))
+
+(defmethod inspect-slot-names (x)
+  "Return a list of names of slots of the object that should be shown in the
+inspector"
+  (mapcar #'(lambda (slotd) (slot-value slotd 'name))
+	  (slots-to-inspect (class-of x) x)))
+
+(defmethod inspect-slot-value (x slot-name)
+  (cond ((not (slot-exists-p x slot-name)) "** no such slot **")
+	((not (slot-boundp x slot-name)) "** slot not bound **")
+	(t (slot-value x slot-name))))
+
+(defmethod inspect-setf-slot-value (x slot-name value)
+  "Used by the inspector to set the value fo a slot"
+  ;; Make this UNDO-able
+  (il:undosave `(inspect-setf-slot-value ,x ,slot-name
+		 ,(slot-value x slot-name)))
+  ;; Then change the value
+  (setf (slot-value x slot-name) value))
+
+(defmethod inspect-slot-name-command (slot-name x window)
+  "Allows the user to select a menu item to change a slot value in an inspect
+window"
+  ;; This code is a very slightly hacked version of the system function
+  ;; DEFAULT.INSPECTW.PROPCOMMANDFN.  We have to do this because the
+  ;; standard version makes some nasty assumptions about
+  ;; structure-objects that are not true for CLOS objects.
+  (declare (special il:|SetPropertyMenu|))
+  (case (il:menu (cond ((typep il:|SetPropertyMenu| 'il:menu)
+			il:|SetPropertyMenu|)
+		       (t (il:setq il:|SetPropertyMenu|
+				   (il:|create| il:menu il:items il:_
+				       '((set 'set 
+					  "Allows a new value to be entered"
+					  )))))))
+    (set 
+     ;; The user want to set the value
+     (il:ersetq (prog ((il:oldvalueitem (il:itemofpropertyvalue slot-name 
+								window))
+		       il:newvalue il:pwindow)
+		   (il:ttydisplaystream (il:setq il:pwindow
+						 (il:getpromptwindow window 3)))
+		   (il:clearbuf t t)
+		   (il:resetlst
+		    (il:resetsave (il:\\itemw.flipitem il:oldvalueitem window)
+				  (list 'il:\\itemw.flipitem 
+					il:oldvalueitem window))
+		    (il:resetsave (il:tty.process (il:this.process)))
+		    (il:resetsave (il:printlevel 4 3))
+		    (il:|printout| t "Enter the new " 
+			slot-name " for " x t 
+			"The expression read will be EVALuated."
+			t "> ")
+		    (il:setq il:newvalue (il:lispx (il:lispxread t t)
+						   '>))
+					; clear tty buffer because it
+					; sometimes has stuff left.
+		    (il:clearbuf t t))
+		   (il:closew il:pwindow)
+		   (return (il:inspectw.replace window slot-name il:newvalue)))))))
+
+(defmethod inspect-title (x window)
+  "Return the title to use in an inspect window viewing x"
+  (format nil "Inspecting a ~A" (class-name (class-of x))))
+
+(defmethod inspect-title ((x standard-class) window)
+  (format nil "Inspecting the class ~A" (class-name x)))
+
+
+;;;  Debugger support for CLOS
+
+
+(il:filesload clos-env-internal)
+
+;; Non-CLOS specific changes to the debugger
+
+;; Redefining the standard INTERESTING-FRAME-P function.  Now functions can be
+;; declared uninteresting to BT by giving them an XCL::UNINTERESTINGP
+;; property.
+
+(dolist (fn '(si::*unwind-protect* il:*env*
+	      evalhook xcl::nohook xcl::undohook
+	      xcl::execa0001 xcl::execa0001a0002
+	      xcl::|interpret-UNDOABLY|
+	      cl::|interpret-IF| cl::|interpret-FLET|
+	      cl::|interpret-LET| cl::|interpret-LETA0001|
+	      cl::|interpret-BLOCK| cl::|interpret-BLOCKA0001|
+	      il:do-event il:eval-input
+	      apply t))
+  (setf (get fn 'xcl::uninterestingp) t))
+
+(defun xcl::interesting-frame-p (xcl::pos &optional xcl::interpflg)
+  "Return TRUE iff the frame should be visible for a short backtrace."
+  (declare (special il:openfns))
+  (let ((xcl::name (if (il:stackp xcl::pos) (il:stkname xcl::pos) xcl::pos)))
+    (typecase xcl::name
+      (symbol (case xcl::name
+		(il:*env*
+		 ;; *ENV* is used by ENVEVAL etc.
+		 nil)
+		(il:errorset
+		 (or (<= (il:stknargs xcl::pos) 1)
+		     (not (eq (il:stkarg 2 xcl::pos nil)
+			      'il:internal))))
+		(il:eval
+		 (or (<= (il:stknargs xcl::pos) 1)
+		     (not (eq (il:stkarg 2 xcl::pos nil)
+			      'xcl::internal))))
+		(il:apply
+		 (or (<= (il:stknargs xcl::pos) 2)
+		     (not (il:stkarg 3 xcl::pos nil))))
+		(otherwise
+		 (cond ((get xcl::name 'xcl::uninterestingp)
+			;; Explicitly declared uninteresting.
+			nil)
+		       ((eq (il:chcon1 xcl::name) (char-code #\\))
+			;; Implicitly declared uninteresting by starting the
+			;; name with a "\".
+			nil)
+		       ((or (member xcl::name il:openfns :test #'eq)
+			    (eq xcl::name 'funcall))
+			;;The function won't be seen when compiled, so only show
+			;;it if INTERPFLG it true
+			xcl::interpflg)
+		       (t 
+			;; Interesting by default.
+			t)))))
+       (cons (case (car xcl::name)
+	       (:broken t)
+	       (otherwise nil)))
+       (otherwise nil))))
+
+(setq il:*short-backtrace-filter* 'xcl::interesting-frame-p)
+
+
+(eval-when (eval compile)
+  (il:record il:bkmenuitem (il:label (il:bkmenuinfo il:frame-name))))
+
+
+;;  Change the frame inspector to open up lexical environments
+
+  ;; Since the DEFSTRUCT is going to build the accessors in the package that is
+  ;; current at read-time, and we want the accessors to reside in the IL
+  ;; package, we have got to make sure that the defstruct happens when the
+  ;; package is IL.
+
+(in-package "IL")
+
+(cl:defstruct (frame-prop-name (:type cl:list))
+  (label-fn 'nill)
+  (value-fn
+   (function
+    (lambda (prop-name framespec)
+     (frame-prop-name-data prop-name))))
+  (setf-fn 'nill)
+  (inspect-fn
+   (function
+    (lambda (value prop-name framespec window)
+     (default.inspectw.valuecommandfn value prop-name (car framespec) window))))
+  (data nil))
+
+(cl:in-package "CLOS")
+
+(defun il:debugger-stack-frame-prop-names (il:framespec) 
+  ;; Frame prop-names are structures of the form
+  ;; (LABEL-FN VALUE-FN SETF-FN EDIT-FN DATA)
+  (let ((il:pos (car il:framespec))
+	(il:backtrace-item (cadr il:framespec)))
+    (il:if (eq 'eval (il:stkname il:pos))
+     il:then
+     (let ((il:expression (il:stkarg 1 il:pos))
+	   (il:environment (il:stkarg 2 il:pos)))
+       `(,(il:make-frame-prop-name :inspect-fn
+	   (il:function
+	    (il:lambda (il:value il:prop-name il:framespec il:window)
+	      (il:inspect/as/function il:value (car il:framespec) il:window)))
+	   :data il:expression)
+	 ,(il:make-frame-prop-name :data "ENVIRONMENT")
+	 ,@(il:for il:aspect il:in
+	    `((,(and il:environment (il:environment-vars il:environment))
+	       "vars")
+	      (,(and il:environment (il:environment-functions il:environment))
+	       "functions")
+	      (,(and il:environment (il:environment-blocks il:environment))
+	       "blocks")
+	      (,(and il:environment (il:environment-tagbodies il:environment))
+	       "tag bodies"))
+	    il:bind il:group-name il:p-list
+	    il:eachtime (il:setq il:group-name (cadr il:aspect))
+	                (il:setq il:p-list (car il:aspect))
+	    il:when (not (null il:p-list))
+	    il:join
+	    `(,(il:make-frame-prop-name :data il:group-name)
+	      ,@(il:for il:p il:on il:p-list il:by cddr il:collect
+		 (il:make-frame-prop-name :label-fn
+		  (il:function (il:lambda (il:prop-name il:framespec)
+				 (car (il:frame-prop-name-data il:prop-name))))
+		  :value-fn
+		  (il:function (il:lambda (il:prop-name il:framespec)
+				 (cadr (il:frame-prop-name-data il:prop-name))))
+		  :setf-fn
+		  (il:function (il:lambda (il:prop-name il:framespec il:new-value)
+				 (il:change (cadr (il:frame-prop-name-data
+						   il:prop-name))
+					    il:new-value)))
+		  :data il:p))))))
+     il:else
+     (flet ((il:build-name (&key il:arg-name il:arg-number)
+	      (il:make-frame-prop-name :label-fn
+		  (il:function (il:lambda (il:prop-name il:framespec)
+				 (car (il:frame-prop-name-data il:prop-name))))
+		  :value-fn
+		  (il:function (il:lambda (il:prop-name il:framespec)
+				 (il:stkarg (cadr (il:frame-prop-name-data
+						   il:prop-name))
+					    (car il:framespec))))
+		  :setf-fn
+		  (il:function (il:lambda (il:prop-name il:framespec il:new-value)
+				 (il:setstkarg (cadr (il:frame-prop-name-data
+						      il:prop-name))
+					       (car il:framespec)
+					       il:new-value)))
+		  :data
+		  (list il:arg-name il:arg-number))))
+       (let ((il:nargs (il:stknargs il:pos t))
+	     (il:nargs1 (il:stknargs il:pos))
+	     (il:fnname (il:stkname il:pos))
+	     il:argname
+	     (il:arglist))
+	 (and (il:litatom il:fnname)
+	      (il:ccodep il:fnname)
+	      (il:setq il:arglist (il:listp (il:smartarglist il:fnname))))
+	 `(,(il:make-frame-prop-name :inspect-fn
+	     (il:function (il:lambda (il:value il:prop-name il:framespec
+					       il:window)
+			    (il:inspect/as/function il:value
+						    (car il:framespec)
+						    il:window)))
+	     :data
+	     (il:fetch (il:bkmenuitem il:frame-name) il:of il:backtrace-item))
+	   ,@(il:bind il:mode il:for il:i il:from 1 il:to il:nargs1 il:collect
+	      (progn (il:while (il:fmemb (il:setq il:argname (il:pop il:arglist))
+					 lambda-list-keywords)
+			       il:do
+			       (il:setq il:mode il:argname))
+		     (il:build-name :arg-name
+				    (or (il:stkargname il:i il:pos)
+					; special
+					(if (case il:mode
+					      ((nil &optional) il:argname)
+					      (t nil))
+					    (string il:argname)
+					    (il:concat "arg " (- il:i 1))))
+				    :arg-number il:i)))
+	   ,@(let* ((il:novalue "No value")
+		    (il:slots (il:for il:pvar il:from 0 il:as il:i il:from
+				      (il:add1 il:nargs1)
+				      il:to il:nargs il:by 1 il:when
+				      (and (il:neq il:novalue (il:stkarg il:i il:pos
+									 il:novalue))
+					   (or (il:setq il:argname (il:stkargname
+								    il:i il:pos))
+					       (il:setq il:argname (il:concat 
+								    "local " 
+								    il:pvar)))
+					   )
+				      il:collect
+				      (il:build-name :arg-name il:argname 
+						     :arg-number il:i))))
+               (and il:slots (cons (il:make-frame-prop-name :data "locals")
+                                   il:slots)))))))))
+
+(defun il:debugger-stack-frame-fetchfn (il:framespec il:prop-name)
+  (il:apply* (il:frame-prop-name-value-fn il:prop-name)
+	     il:prop-name il:framespec))
+
+(defun il:debugger-stack-frame-storefn (il:framespec il:prop-name il:newvalue)
+  (il:apply* (il:frame-prop-name-setf-fn il:prop-name)
+	     il:prop-name il:framespec il:newvalue))
+
+(defun il:debugger-stack-frame-value-command (il:datum il:prop-name 
+						       il:framespec il:window)
+  (il:apply* (il:frame-prop-name-inspect-fn il:prop-name)
+	     il:datum il:prop-name il:framespec il:window))
+
+(defun il:debugger-stack-frame-title (il:framespec &optional il:window)
+  (declare (ignore il:window))
+  (il:concat (il:stkname (car il:framespec)) "  Frame"))
+
+(defun il:debugger-stack-frame-property (il:prop-name il:framespec)
+  (il:apply* (il:frame-prop-name-label-fn il:prop-name)
+	     il:prop-name il:framespec))
+
+;; Teaching the debugger that there are other file-manager types that can
+;; appear on the stack
+
+(defvar xcl::*function-types* '(il:fns il:functions)
+  "Manager types that can appear on the stack")
+
+;; Redefine a couple of system functions to use the above stuff
+
+#+Xerox-Lyric
+(progn
+
+(defun il:attach-backtrace-menu (&optional (il:ttywindow
+					    (il:wfromds (il:ttydisplaystream)))
+					   il:skip)
+  (let ((il:bkmenu (il:|create| il:menu
+		       il:items il:_
+		       (il:collect-backtrace-items il:ttywindow il:skip)
+		       il:whenselectedfn il:_
+		       (il:function il:backtrace-item-selected)
+		       il:whenheldfn il:_
+		       #'(il:lambda (il:item il:menu il:button)
+			   (declare (ignore il:item il:menu))
+			   (case il:button
+			     (il:left (il:promptprint 
+				       "Open a frame inspector on this stack frame"
+				       ))
+			     (il:middle (il:promptprint 
+					 "Inspect/Edit this function"))
+			     ))
+		       il:menuoutlinesize il:_ 0
+		       il:menufont il:_ il:backtracefont
+		       il:menucolumns il:_ 1))
+	(il:ttyregion (il:windowprop il:ttywindow 'il:region))
+	il:btw)
+    (cond
+      ((il:setq il:btw (il:|for| il:atw il:|in| (il:attachedwindows il:ttywindow)
+			   il:|when| (and (il:setq il:btw (il:windowprop il:atw 'il:menu))
+					  (eql (il:|fetch| (il:menu il:whenselectedfn)
+						   il:|of| (car il:btw))
+					       (il:function il:backtrace-item-selected)))
+			   il:|do|                       
+			   (return il:atw)))       
+       (il:deletemenu (car (il:windowprop il:btw 'il:menu))
+		      nil il:btw)
+       (il:windowprop il:btw 'il:extent nil)
+       (il:clearw il:btw))
+      ((il:setq il:btw (il:createw (il:region-next-to (il:windowprop il:ttywindow 'il:region)
+						      (il:widthifwindow (il:imin (il:|fetch| (il:menu 
+											      il:imagewidth
+											      )
+										     il:|of| il:bkmenu)
+										 il:|MaxBkMenuWidth|))
+						      (il:|fetch| (il:region il:height) il:|of| il:ttyregion
+							  )
+						      'il:left)))   
+       (il:attachwindow il:btw il:ttywindow (cond
+					      ((il:igreaterp (il:|fetch| (il:region il:left)
+								 il:|of| (il:windowprop
+									  il:btw
+									  'il:region))
+							     (il:|fetch| (il:region il:left)
+								 il:|of| il:ttyregion))
+					       'il:right)
+					      (t 'il:left))
+			nil
+			'il:localclose)
+       (il:windowprop il:btw 'il:process (il:windowprop il:ttywindow 'il:process))
+
+       ))
+    (il:addmenu il:bkmenu il:btw (il:|create| il:_ il:position
+				     il:xcoord il:_ 0
+				     il:ycoord il:_ (il:idifference (il:windowprop
+								     il:btw
+								     'il:height)
+								    (il:|fetch| (il:menu il:imageheight
+											 ) il:|of| 
+											   il:bkmenu
+											   ))))))
+
+(defun il:backtrace-item-selected (il:item il:menu il:button)
+  (il:resetlst
+   (prog (il:olditem il:ttywindow il:bkpos il:pos il:positions il:framewindow
+		     (il:framespecn (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| il:item)
+
+				    ))
+      (cond
+	((il:setq il:olditem (il:|fetch| (il:menu il:menuuserdata) il:|of| il:menu))
+	 (il:menudeselect il:olditem il:menu)        
+	 ))
+      (il:setq il:ttywindow (il:windowprop (il:wfrommenu il:menu)
+					   'il:mainwindow))
+      (il:setq il:bkpos (il:windowprop il:ttywindow 'il:stack-position))
+      (il:setq il:pos (il:stknth (- il:framespecn)
+				 il:bkpos))
+      (let ((il:lp (il:windowprop il:ttywindow 'il:lastpos)))
+	(and il:lp (il:stknth 0 il:pos il:lp)))
+      (il:menuselect il:item il:menu)                
+      (if (eq il:button 'il:middle)
+	  (progn 
+
+
+	    (il:resetsave nil (list 'il:relstk il:pos))
+	    (il:inspect/as/function (il:|fetch| (il:bkmenuitem il:frame-name)
+					il:|of| il:item)
+				    il:pos il:ttywindow))
+	  (progn 
+
+
+	    (il:setq il:framewindow
+		     (xcl:with-profile (il:process.eval
+						  (il:windowprop il:ttywindow 'il:process)
+						  '(let ((il:profile (xcl:copy-profile (xcl:find-profile
+											"READ-PRINT"))))
+						    (setf (xcl::profile-entry-value '
+							   xcl:*eval-function* il:profile)
+						     xcl:*eval-function*)
+						    (xcl:save-profile il:profile))
+						  t)
+		       (il:inspectw.create (list il:pos il:item)
+				   'il:debugger-stack-frame-prop-names
+				   'il:debugger-stack-frame-fetchfn
+				   'il:debugger-stack-frame-storefn nil '
+				   il:debugger-stack-frame-value-command nil '
+				   il:debugger-stack-frame-title nil (
+								      il:make-frame-inspect-window
+								      il:ttywindow)
+				   'il:debugger-stack-frame-property)))
+	    (cond
+	      ((not (il:windowprop il:framewindow 'il:mainwindow))
+	       (il:attachwindow il:framewindow il:ttywindow
+				(cond
+				  ((il:igreaterp (il:|fetch| (il:region il:bottom)
+						     il:|of| (il:windowprop il:framewindow
+									    'il:region))
+						 (il:|fetch| (il:region il:bottom)
+						     il:|of| (il:windowprop il:ttywindow 'il:region)))
+				   'il:top)
+				  (t 'il:bottom))
+				nil
+				'il:localclose)
+	       (il:windowaddprop il:framewindow 'il:closefn (il:function il:detachwindow
+									 ))))))
+      (return))))
+
+(defun il:collect-backtrace-items (xcl::tty-window xcl::skip)
+   (let* ((xcl::items (cons nil nil))
+          (xcl::items-tail xcl::items))
+         (macrolet ((xcl::collect-item (xcl::new-item)
+                           `(progn (setf (rest xcl::items-tail)
+                                         (cons ,xcl::new-item nil))
+                                   (pop xcl::items-tail))))
+                (let* ((xcl::filter-fn (cond
+                                          ((null xcl::skip)
+                                           #'xcl:true)
+                                          ((eq xcl::skip t)
+                                           il:*short-backtrace-filter*)
+                                          (t xcl::skip)))
+                       (xcl::top-frame (il:stknth 0 (il:getwindowprop xcl::tty-window '
+                                                           il:stack-position)))
+                       (xcl::next-frame xcl::top-frame)
+                       (xcl::frame-number 0)
+                       xcl::interesting-p xcl::last-frame-consumed xcl::use-frame xcl::label)
+                      (loop (when (null xcl::next-frame)
+                                  (return))
+                            (multiple-value-setq (xcl::interesting-p xcl::last-frame-consumed 
+                                                        xcl::use-frame xcl::label)
+                                   (funcall xcl::filter-fn xcl::next-frame))
+                            (when (null xcl::last-frame-consumed)
+                                                            
+                                (setf xcl::last-frame-consumed xcl::next-frame))
+                            (when xcl::interesting-p        
+                                (when (null xcl::use-frame)
+                                      (setf xcl::use-frame xcl::last-frame-consumed))
+                                                             
+                                (when (null xcl::label)
+                                    (setf xcl::label (il:stkname xcl::use-frame))
+                                    (if (member xcl::label '(eval il:eval il:apply apply)
+                                               :test
+                                               'eq)
+                                        (setf xcl::label (il:stkarg 1 xcl::use-frame))))
+                                                            
+                                (loop (cond
+                                         ((not (typep xcl::next-frame 'il:stackp))
+                                          (error "~%Use-frame ~S not found" xcl::use-frame))
+                                         ((xcl::stack-eql xcl::next-frame xcl::use-frame)
+                                          (return))
+                                         (t (incf xcl::frame-number)
+                                            (setf xcl::next-frame (il:stknth -1 xcl::next-frame 
+                                                                         xcl::next-frame)))))
+                                                             
+                                (xcl::collect-item (il:|create| il:bkmenuitem
+                                                          il:label il:_ (let ((*print-level* 2)
+                                                                              (*print-length* 3)
+                                                                              (*print-escape* t)
+                                                                              (*print-gensym* t)
+                                                                              (*print-pretty* nil)
+                                                                              (*print-circle* nil)
+                                                                              (*print-radix* 10)
+                                                                              (*print-array* nil)
+                                                                              (il:*print-structure*
+                                                                               nil))
+                                                                             (prin1-to-string 
+                                                                                    xcl::label))
+                                                          il:bkmenuinfo il:_ xcl::frame-number
+                                                          il:frame-name il:_ xcl::label)))
+                                                             
+                            (loop (cond
+                                     ((not (typep xcl::next-frame 'il:stackp))
+                                      (error "~%Last-frame-consumed ~S not found" 
+                                             xcl::last-frame-consumed))
+                                     ((prog1 (xcl::stack-eql xcl::next-frame xcl::last-frame-consumed
+                                                    )
+                                          (incf xcl::frame-number)
+                                          (setf xcl::next-frame (il:stknth -1 xcl::next-frame 
+                                                             
+                                                                       xcl::next-frame)))
+                                      (return)))))))
+         (rest xcl::items)))
+
+)
+#+Xerox-Medley
+(progn
+
+(defun dbg::attach-backtrace-menu (&optional tty-window skip)
+  (declare (special il:\\term.ofd il:backtracefont))
+  (or tty-window (il:setq tty-window (il:wfromds (il:ttydisplaystream))))
+  (prog (btw bkmenu
+	     (tty-region (il:windowprop tty-window 'il:region))
+	     ;; And, for the FORMAT below...
+	     (*print-level* 2)
+	     (*print-length* 3)
+	     (*print-escape* t)
+	     (*print-gensym* t)
+	     (*print-pretty* nil)
+	     (*print-circle* nil)
+	     (*print-radix* 10)
+	     (*print-array* nil)
+	     (il:*print-structure* nil))
+     (setq bkmenu
+	   (il:|create| il:menu
+	       il:items il:_ (dbg::collect-backtrace-items tty-window skip)
+	       il:whenselectedfn il:_ 'dbg::backtrace-item-selected
+	       il:menuoutlinesize il:_ 0
+	       il:menufont il:_ il:backtracefont 
+	       il:menucolumns il:_ 1
+	       il:whenheldfn il:_
+	       #'(il:lambda (item menu button)
+		   (declare (ignore item menu))
+		   (case button
+		     (il:left
+		      (il:promptprint
+		       "Open a frame inspector on this stack frame"))
+		     (il:middle
+		      (il:promptprint "Inspect/Edit this function"))))))
+     (cond ((setq btw
+		  (dolist (atw  (il:attachedwindows tty-window))
+		    ;; Test for an attached window that has a backtrace menu in
+		    ;; it.
+		    (when (and (setq btw (il:windowprop atw 'il:menu))
+			   (eq (il:|fetch| (il:menu il:whenselectedfn)
+				   il:|of| (car btw))
+			       'dbg::backtrace-item-selected))
+		      (return atw))))
+	    ;; If there is alread a backtrace window, delete the old menu from
+	    ;; it.
+	    (il:deletemenu (car (il:windowprop btw 'il:menu)) nil btw)
+	    (il:windowprop btw 'il:extent nil)
+	    (il:clearw btw))
+	   ((setq btw
+		  (il:createw (dbg::region-next-to
+			       (il:windowprop tty-window 'il:region)
+			       (il:widthifwindow
+				(il:imin (il:|fetch| (il:menu il:imagewidth)
+					     il:|of| bkmenu)
+					 il:|MaxBkMenuWidth|))
+			       (il:|fetch| (il:region il:height)
+				   il:|of| tty-region)
+			       :left)))
+					; put bt window at left of TTY
+					; window unless ttywindow is
+					; near left edge.
+	    (il:attachwindow btw tty-window
+			     (if (il:igreaterp (il:|fetch| (il:region il:left)
+						   il:|of|
+						   (il:windowprop btw
+								  'il:region))
+					       (il:|fetch| (il:region il:left)
+						   il:|of| tty-region))
+				 'il:right
+				 'il:left)
+			     nil
+			     'il:localclose)
+	    ;; So that button clicks will switch the TTY
+	    (il:windowprop btw 'il:process
+			   (il:windowprop tty-window 'il:process))))
+     (il:addmenu bkmenu btw (il:|create| il:position
+				il:xcoord il:_ 0 
+				il:ycoord il:_ (- (il:windowprop btw 'il:height)
+						  (il:|fetch| (il:menu 
+							       il:imageheight)
+						      il:|of| bkmenu))))
+     ;; IL:ADDMENU sets up buttoneventfn for window that we don't
+     ;; want.  We want to catch middle button events before the menu
+     ;; handler, so that we can pop up edit/inspect menu for the frame
+     ;; currently selected.  So replace the buttoneventfn, and can
+     ;; nuke the cursorin and cursormoved guys, cause don't need them.
+     (il:windowprop btw 'il:buttoneventfn 'dbg::backtrace-menu-buttoneventfn)
+     (il:windowprop btw 'il:cursorinfn nil)
+     (il:windowprop btw 'il:cursormovedfn nil)))
+
+(defun dbg::collect-backtrace-items (tty-window skip)
+  (xcl:with-collection
+      ;;
+      ;; There are a number of possibilities for the values returned by the
+      ;; filter-fn.
+      ;;
+      ;; (1) INTERESTING-P is false, and the other values are all NIL.  This
+      ;; is the simple case where the stack frame NEXT-POS should be ignored
+      ;; completly, and processing should continue with the next frame.
+      ;;
+      ;; (2) INTERESTING-P is true, and the other values are all NIL.  This
+      ;; is the simple case where the stack frame NEXT-POS should appear in
+      ;; the backtrace as is, and processing should continue with the next
+      ;; frame.
+      ;;
+      ;; [Note that these two cases take care of old values of the
+      ;; filter-fn.]
+      ;;
+      ;; (3) INTERESTING-P is false, and LAST-FRAME-CONSUMED is a stack
+      ;; frame.  In that case, ignore all stack frames from NEXT-POS to
+      ;; LAST-FRAME-CONSUMED, inclusive.
+      ;;
+      ;; (4) INTERESTING-P is true, and LAST-FRAME-CONSUMED is a stack
+      ;; frame.  In this case, the backtrace should include a single entry
+      ;; coresponding to the frame USE-FRAME (which defaults to
+      ;; LAST-FRAME-CONSUMED), and processing should continue with the next
+      ;; frame after LAST-FRAME-CONSUMED.  If LABEL is non-NIL, it will be
+      ;; the label that appears in the backtrace menu; otherwise the name of
+      ;; USE-FRAME will be used (or the form being EVALed if the frame is an
+      ;; EVAL frame).
+      ;;
+      (let* ((filter (cond ((null skip) #'xcl:true)
+			   ((eq skip t) il:*short-backtrace-filter*)
+			   (t skip)))
+	     (top-frame (il:stknth 0 (il:getwindowprop tty-window
+					      'dbg::stack-position)))
+	     (next-frame top-frame)
+	     (frame-number 0)
+	     interestingp last-frame-consumed frame-to-use label-to-use)
+	(loop (when (null next-frame) (return))
+	      ;; Get the values of INTERSTINGP, LAST-FRAME-CONSUMED,
+	      ;; FRAME-TO-USE, and LABEL-TO-USE
+	      (multiple-value-setq (interestingp last-frame-consumed 
+						 frame-to-use label-to-use)
+		(funcall filter next-frame))
+	      (when (null last-frame-consumed)
+		(setf last-frame-consumed next-frame))
+	      (when interestingp
+		(when (null frame-to-use)
+		  (setf frame-to-use last-frame-consumed))
+		(when (null label-to-use)
+		  (setf label-to-use (il:stkname frame-to-use))
+		  (if (member label-to-use '(eval il:eval il:apply apply)
+			      :test 'eq)
+		      (setf label-to-use (il:stkarg 1 frame-to-use))))
+
+		;; Walk the stack until we find the frame to use
+		(loop (cond ((not (typep next-frame 'il:stackp))
+			     (error "~%Use-frame ~S not found" frame-to-use))
+			    ((xcl::stack-eql next-frame frame-to-use)
+			     (return))
+			    (t (incf frame-number)
+			       (setf next-frame
+				     (il:stknth -1 next-frame next-frame)))))
+
+		;; Add the menu item to the list under construction
+		(xcl:collect (il:|create| il:bkmenuitem
+				 il:label il:_ (let ((*print-level* 2)
+						     (*print-length* 3)
+						     (*print-escape* t)
+						     (*print-gensym* t)
+						     (*print-pretty* nil)
+						     (*print-circle* nil)
+						     (*print-radix* 10)
+						     (*print-array* nil)
+						     (il:*print-structure* nil))
+						 (prin1-to-string label-to-use))
+				 il:bkmenuinfo il:_ frame-number
+				 il:frame-name il:_ label-to-use)))
+
+	      ;; Update NEXT-POS
+	      (loop (cond ((not (typep next-frame 'il:stackp))
+			   (error "~%Last-frame-consumed ~S not found" 
+				  last-frame-consumed))
+			  ((prog1
+			       (xcl::stack-eql next-frame last-frame-consumed)
+			     (incf frame-number)
+			     (setf next-frame (il:stknth -1 next-frame
+							 next-frame)))
+			   (return))))))))
+
+(defun dbg::backtrace-menu-buttoneventfn (window &aux menu)
+  (setq menu (car (il:listp (il:windowprop window 'il:menu))))
+  (unless (or (il:lastmousestate il:up) (null menu))
+    (il:totopw window)
+    (cond ((il:lastmousestate il:middle)
+	   ;; look for a selected frame in this menu, and then pop up
+	   ;; the editor invoke menu for that frame.  don't change the
+	   ;; selection, just present the edit menu.
+	   (let* ((selection (il:menu.handler menu
+					  (il:windowprop window 'il:dsp)))
+		  (tty-window (il:windowprop window 'il:mainwindow))
+		  (last-pos (il:windowprop tty-window 'dbg::lastpos)))
+                        
+	     ;; don't have to worry about releasing POS because we
+	     ;; only look at it here (nobody here hangs on to it)
+	     ;; and we will be around for less time than LASTPOS. 
+	     ;; The debugger is responsible for releasing LASTPOS.
+	     (il:inspect/as/function (cond
+				       ((and selection
+					     (il:|fetch| (il:bkmenuitem il:frame-name)
+						 il:|of| (car selection))))
+				       ((and (symbolp (il:stkname last-pos))
+					     (il:getd (il:stkname last-pos)))
+					(il:stkname last-pos))
+				       (t 'il:nill))
+				     last-pos tty-window)))
+	  (t (let ((selection (il:menu.handler menu
+					   (il:windowprop window 'il:dsp))))
+	       (when selection
+		 (il:doselecteditem menu (car selection) (cdr selection))))))))
+
+;; This function isn't really redefined, but it needs to be recomiled since we
+;; changed the def'n of the BKMENUITEM record.
+
+(defun dbg::backtrace-item-selected (item menu button)
+  ;;When a frame name is selected in the backtrace menu, this is the function
+  ;;that gets called.
+  (declare (special il:brkenv) (ignore button))
+  (let* ((frame-spec (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| item))
+	 (tty-window (il:windowprop (il:wfrommenu menu) 'il:mainwindow))
+	 (bkpos (il:windowprop tty-window 'dbg::stack-position))
+	 (pos (il:stknth (- frame-spec) bkpos)))
+    (let ((lp (il:windowprop tty-window 'dbg::lastpos)))
+      (and lp (il:stknth 0 pos lp)))
+    ;; change the item selected from OLDITEM to ITEM.  Only do this on left
+    ;; buttons now.  Middle just pops up the edit menu, doesn't select. -woz
+    (let ((old-item (il:|fetch| (il:menu il:menuuserdata) il:|of| menu)))
+      (when old-item (il:menudeselect old-item menu))
+      (il:menuselect item menu))
+    ;; Change the lexical environment so it is the one in effect as of this
+    ;; frame.
+    (il:process.eval (il:windowprop tty-window (quote dbg::process))
+	       `(setq il:brkenv ',(il:find-lexical-environment pos))
+	       t)
+    (let ((frame-window (xcl:with-profile
+			    (il:process.eval (il:windowprop tty-window
+							    'il:process)
+				       `(let ((profile (xcl:copy-profile
+							(xcl:find-profile
+							 "READ-PRINT"))))
+					 (setf
+					  (xcl::profile-entry-value
+					   'xcl:*eval-function* profile)
+					  xcl:*eval-function*)
+					 (xcl:save-profile profile))
+				       t)
+			  (il:inspectw.create pos
+				      #'(lambda (pos)
+					  (dbg::stack-frame-properties pos t))
+				      'dbg::stack-frame-fetchfn
+				      'dbg::stack-frame-storefn
+				      nil
+				      'dbg::stack-frame-value-command
+				      nil
+				      (format nil "~S  Frame" (il:stkname pos))
+				      nil (dbg::make-frame-inspect-window
+					   tty-window)
+				      'dbg::stack-frame-property))))
+      (when (not (il:windowprop frame-window 'il:mainwindow))
+	(il:attachwindow frame-window tty-window
+			 (if (> (il:|fetch| (il:region il:bottom) il:|of|
+				    (il:windowprop frame-window 'il:region))
+				(il:|fetch| (il:region il:bottom) il:|of|
+				    (il:windowprop tty-window 'il:region)))
+			     'il:top 'il:bottom)
+			 nil 'il:localclose)
+	(il:windowaddprop frame-window 'il:closefn 'il:detachwindow)))))
+
+)					;end of Xerox-Medley
+
+(defun il:select.fns.editor (&optional function)
+    ;; gives the user a menu choice of editors.
+    (il:menu (il:|create| il:menu
+		 il:items il:_ (cond ((il:ccodep function)
+				      '((il:|InspectCode| 'il:inspectcode 
+					 "Shows the compiled code.")
+					(il:|DisplayEdit| 'ed 
+					 "Edit it with the display editor")
+					(il:|TtyEdit| 'il:ef 
+					 "Edit it with the standard editor")))
+				     ((il:closure-p function)
+				      '((il:|Inspect| 'inspect 
+					 "Inspect this object")))
+				     (t '((il:|DisplayEdit| 'ed 
+					   "Edit it with the display editor")
+					  (il:|TtyEdit| 'il:ef 
+					   "Edit it with the standard editor"))))
+		 il:centerflg il:_ t)))
+
+;; 
+
+
+;; CLOS specific extensions to the debugger
+
+
+;; There are some new things that act as functions, and that we want to be
+;; able to edit from a backtrace window
+
+(pushnew 'methods xcl::*function-types*)
+
+(eval-when (eval compile load)
+  (unless (generic-function-p (symbol-function 'il:inspect/as/function))
+    (make-specializable 'il:inspect/as/function)))
+
+(defmethod il:inspect/as/function (name stack-pointer debugger-window)
+  ;; Calls an editor on function NAME.  STKP and WINDOW are the stack pointer
+  ;; and window of the break in which this inspect command was called.
+  (declare (ignore debugger-window))
+  (let ((editor (il:select.fns.editor name)))
+    (case editor
+      ((nil) 
+       ;; No editor chosen, so don't do anything
+       nil)
+      (il:inspectcode 
+       ;; Inspect the compiled code
+       (let ((frame (xcl::stack-pointer-frame stack-pointer)))
+	 (if (and (il:stackp stack-pointer)
+		  (xcl::stack-frame-valid-p frame))
+	     (il:inspectcode (let ((code-base (xcl::stack-frame-fn-header frame)))
+			       (cond ((eq (il:\\get-compiled-code-base name)
+					  code-base)
+				      name)
+				     (t 
+				      ;; Function executing in this frame is not
+				      ;; the one in the definition cell of its
+				      ;; name, so fetch the real code.  Have to
+				      ;; pass a CCODEP
+				      (il:make-compiled-closure code-base))))
+                             nil nil nil (xcl::stack-frame-pc frame))
+	     (il:inspectcode name))))
+      (ed 
+       ;; Use the standard editor.
+       ;; This used to take care to apply the editor in the debugger
+       ;; process, so forms evaluated in the editor happen in the
+       ;; context of the break.  But that doesn't count for much any
+       ;; more, now that lexical variables are the way to go.  Better to
+       ;; use the LEX debugger command (thank you, Herbie) and
+       ;; shift-select pieces of code from the editor into the debugger
+       ;; window. 
+       (ed name `(,@xcl::*function-types* :display)))
+      (otherwise (funcall editor name)))))
+
+(defmethod il:inspect/as/function ((name standard-object) stkp window)
+  (when (il:menu (il:|create| il:menu
+		     il:items il:_ '(("Inspect" t "Inspect this object"))))
+    (inspect name)))
+
+(defmethod il:inspect/as/function ((x standard-method) stkp window)
+  (let* ((generic-function-name (slot-value (slot-value x 'generic-function)
+					    'name))
+	 (method-name (full-method-name x))
+	 (editor (il:select.fns.editor method-name)))
+    (il:allow.button.events)
+    (case editor
+      (ed (ed method-name '(:display methods)))
+      (il:inspectcode (il:inspectcode (slot-value x 'function)))
+      ((nil) nil)
+      (otherwise (funcall editor method-name)))))
+
+;; A replacement for the vanilla IL:INTERESTING-FRAME-P so we can see methods
+;; and generic-functions on the stack.
+
+(defun interesting-frame-p (stack-pos &optional interp-flag)
+  ;; Return up to four values:  INTERESTING-P LAST-FRAME-CONSUMED USE-FRAME and
+  ;; LABEL.  See the function IL:COLLECT-BACKTRACE-ITEMS for a full description
+  ;; of how these values are used.
+  (labels
+      ((function-matches-frame-p (function frame)
+	   "Is the function being called in this frame?"
+	   (let* ((frame-name (il:stkname frame))
+		  (code-being-run (cond
+				    ((typep frame-name 'il:closure)
+				     frame-name)
+				    ((and (consp frame-name)
+					  (eq 'il:\\interpreter
+					      (xcl::stack-frame-name
+					       (il:\\stackargptr frame))))
+				     frame-name)
+				    (t (xcl::stack-frame-fn-header
+					(il:\\stackargptr frame))))))
+	     (or (eq function code-being-run)
+		 (and (typep function 'il:compiled-closure)
+		      (eq (xcl::compiled-closure-fnheader function)
+			  code-being-run)))))
+       (generic-function-from-frame (frame)
+	 "If this the frame of a generic function return the gf, otherwise
+          return NIL."
+	 ;; Generic functions are implemented as compiled closures.  On the
+	 ;; stack, we only see the fnheader for the the closure.  This could
+	 ;; be a discriminator code, or in the default method only case it
+	 ;; will be the actual method function.  To tell if this is a generic
+	 ;; function frame, we have to check very carefully to see if the
+	 ;; right stuff is on the stack.  Specifically, the closure's ccode,
+	 ;; and the first local variable has to be a ptrhunk big enough to be
+	 ;; a FIN environment, and fin-env-fin of that ptrhunk has to point
+	 ;; to a generic function whose ccode and environment match. 
+	 (let ((n-args (il:stknargs frame))
+	       (env nil)
+	       (gf nil))
+	   (if (and ;; is there at least one local?
+		(> (il:stknargs frame t) n-args)
+		;; and does the local contain something that might be
+		;; the closure environment of a funcallable instance?
+		(setf env (il:stkarg (1+ n-args) frame))
+		;; and does the local contain something that might be
+		;; the closure environment of a funcallable instance?
+		(typep env *fin-env-type*)
+		(setf gf (fin-env-fin env))
+		;; whose fin-env-fin points to a generic function?
+		(generic-function-p gf)
+		;; whose environment is the same as env?
+		(eq (xcl::compiled-closure-env gf) env)
+		;; and whose code is the same as the code for this
+		;; frame? 
+		(function-matches-frame-p gf frame))
+	       gf
+	       nil))))
+    (let ((frame-name (il:stkname stack-pos)))
+      ;; See if there is a generic-function on the stack at this
+      ;; location.
+      (let ((gf (generic-function-from-frame stack-pos)))
+	(when gf
+	  (return-from interesting-frame-p (values t stack-pos stack-pos gf))))
+      ;; See if this is an interpreted method.  The method body is
+      ;; wrapped in a (BLOCK <function-name> ...).  We look for an
+      ;; interpreted call to BLOCK whose block-name is the name of
+      ;; generic-function.
+      (when (and (eq frame-name 'eval)
+		 (consp (il:stkarg 1 stack-pos))
+		 (eq (first (il:stkarg 1 stack-pos)) 'block)
+		 (symbolp (second (il:stkarg 1 stack-pos)))
+		 (fboundp (second (il:stkarg 1 stack-pos)))
+		 (generic-function-p
+		     (symbol-function (second (il:stkarg 1 stack-pos)))))
+	(let* ((form (il:stkarg 1 stack-pos))
+	       (block-name (second form))
+	       (generic-function (symbol-function block-name))
+	       (methods (generic-function-methods (symbol-function block-name))))
+	  ;; If this is really a method being called from a
+	  ;; generic-function, the g-f should be no more than a
+	  ;; few(?) frames up the stack.  Check for the method call
+	  ;; by looking for a call to APPLY, where the function
+	  ;; being applied is the code in one of the methods.
+	  (do ((i 100 (1- i))
+	       (previous-pos stack-pos current-pos)
+	       (current-pos (il:stknth -1 stack-pos) (il:stknth -1 current-pos))
+	       (found-method nil)
+	       (method-pos))
+	      ((or (null current-pos) (<= i 0)) nil)
+	    (cond ((equalp generic-function
+			   (generic-function-from-frame current-pos))
+		   (if found-method
+		       (return-from interesting-frame-p
+			 (values t previous-pos method-pos found-method))
+		       (return)))
+		  (found-method nil)
+		  ((eq (il:stkname current-pos) 'apply)
+		   (dolist (method methods)
+		     (when (eq (method-function method)
+			       (il:stkarg 1 current-pos))
+		       (setq method-pos current-pos)
+		       (setq found-method method)
+		       (return))))))))
+      ;; Try to handle compiled methods
+      (when (and (symbolp frame-name)
+		 (not (fboundp frame-name))
+		 (eq (il:chcon1 frame-name)
+		     (il:charcode il:\())
+		 (or (string-equal "(method " (symbol-name frame-name)
+			      :start2 0 :end2 13)
+		     (string-equal "(method " (symbol-name frame-name)
+			      :start2 0 :end2 12)
+		     (string-equal "(method " (symbol-name frame-name)
+			      :start2 0 :end2 8)))
+	;; Looks like a name that CLOS consed up.  See if there is a
+	;; GF nearby up the stack.  If there is, use it to help
+	;; determine which method we have.
+	(do ((i 30 (1- i))
+	     (current-pos (il:stknth -1 stack-pos)
+			  (il:stknth -1 current-pos))
+	     (gf))
+	    ((or (null current-pos)
+		 (<= i 0))
+	     nil)
+	  (setq gf (generic-function-from-frame current-pos))
+	  (when gf
+	    (dolist (method (generic-function-methods gf))
+	      (when (function-matches-frame-p (method-function method)
+					      stack-pos)
+		(return-from interesting-frame-p
+		  (values t stack-pos stack-pos method))))
+	    (return))))
+      ;; If we haven't already returned, use the default method.
+      (xcl::interesting-frame-p stack-pos interp-flag))))
+
+
+(setq il:*short-backtrace-filter* 'interesting-frame-p)
+
+;;; Support for undo
+
+ (defun undoable-setf-slot-value (object slot-name new-value)
+    (if (slot-boundp object slot-name)
+      (il:undosave (list 'undoable-setf-slot-value
+                         object slot-name (slot-value object slot-name)))
+      (il:undosave (list 'slot-makunbound object slot-name)))
+    (setf (slot-value object slot-name) new-value))
+
+  (setf (get 'slot-value :undoable-setf-inverse) 'undoable-setf-slot-value)
+
+
+;;; Support for ?= and friends
+
+;; The arglists for generic-functions are built using gensyms, and don't reflect
+;; any keywords (they are all included in an &REST arg).  Rather then use the
+;; arglist in the code, we use the one that CLOS kindly keeps in the generic-function.
+
+(xcl:advise-function 'il:smartarglist
+  '(if (and il:explainflg
+	(symbolp il:fn)
+	(fboundp il:fn)
+	(generic-function-p (symbol-function il:fn)))
+    (generic-function-pretty-arglist (symbol-function il:fn))
+    (xcl:inner))
+  :when :around :priority :last)
+
+(setf (get 'defclass 'il:argnames)
+      '(nil (class-name (#\{ superclass-name #\} #\*)
+	     (#\{ slot-specifier #\} #\*)
+	     #\{ slot-option #\} #\*)))
+
+(setf (get 'defmethod 'il:argnames)
+      '(nil (#\{ name #\| (setf name) #\} #\{ method-qualifier #\} #\*
+	     specialized-lambda-list #\{ declaration #\| doc-string #\} #\*
+	     #\{ form #\} #\*)))
+
+;;; Prettyprinting support, the result of Harley Davis.
+
+;; Support the standard Prettyprinter.  This is really minimal right now.  If
+;; anybody wants to fix this, I'd be happy to include their code.  In fact,
+;; there is almost no support for Commonlisp in the standard Prettyprinter, so
+;; the field is wide open to hackers with time on their hands.
+
+
+(setf (get 'defmethod :definition-print-template) ;Not quite right, since it
+      '(:name :arglist :body))		          ; doesn't handle qualifiers,
+		          		          ; but it will have to do.
+
+(defun defclass-prettyprint (form)
+  (let ((left (il:dspxposition))
+	(char-width (il:charwidth (il:charcode x) *standard-output*)))
+    (xcl:destructuring-bind (defclass name supers slots . options) form
+      (princ "(")
+      (prin1 defclass)
+      (princ " ")
+      (prin1 name)
+      (princ " ")
+      (if (null supers)
+	  (princ "()")			;Print "()" instead of "nil"
+	  (il:sequential.prettyprint (list supers) (il:dspxposition)))
+      (if (null slots)
+	  (progn (il:prinendline (+ left (* 4 char-width)) *standard-output*)
+		 (princ "()"))
+	  (il:sequential.prettyprint (list slots) (+ left (* 4 char-width))))
+      (when options
+	(il:sequential.prettyprint options (+ left (* 2 char-width))))
+      (princ ")")
+      nil)))
+
+(let ((pprint-macro (assoc 'defclass il:prettyprintmacros)))
+  (if (null pprint-macro)
+      (push (cons 'defclass 'defclass-prettyprint)
+	    il:prettyprintmacros)
+      (setf (cdr pprint-macro) 'defclass-prettyprint)))
+
+(defun binder-prettyprint (form)
+  ;; Prettyprints expressions like MULTIPLE-VALUE-BIND and WITH-SLOTS
+  ;; that are of the form (fn (var ...) form &rest body).
+  ;; This code is far from correct, but it's better than nothing.
+  (if (and (consp form)
+	   (not (null (cdddr form))))
+      ;; I have no idea what I'm doing here.  Seems I can copy and edit somebody
+      ;; elses code without understanding it.
+      (let ((body-indent (+ (il:dspxposition)
+			    (* 2 (il:charwidth (il:charcode x)
+					       *standard-output*))))
+	    (form-indent (+ (il:dspxposition)
+			    (* 4 (il:charwidth (il:charcode x)
+					       *standard-output*)))))
+	(princ "(")
+	(prin1 (first form))
+	(princ " ")
+	(il:superprint (second form) form nil *standard-output*)
+	(il:sequential.prettyprint (list (third form)) form-indent)
+	(il:sequential.prettyprint (cdddr form) body-indent)
+	(princ ")")
+	nil)				;Return NIL to indicate that we did
+					; the printing
+      t))				;Return true to use default printing
+
+
+(dolist (fn '(multiple-value-bind with-accessors with-slots))
+  (let ((pprint-macro (assoc fn 'il:prettyprintmacros)))
+    (if (null pprint-macro)
+	(push (cons fn 'binder-prettyprint)
+	      il:prettyprintmacros)
+	(setf (cdr pprint-macro) 'binder-prettyprint))))
+
+
+
+;; SEdit has its own prettyprinter, so we need to support that too.  This is due
+;; to Harley Davis.  Really.
+
+(push (cons :slot-spec
+	    '(((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
+		break sedit::from-indent . 0)
+	       (sedit::set-indent . 1)
+	       (sedit::next-inline? 1 break sedit::from-indent . 1)
+	       (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
+		break sedit::from-indent . 0))
+	      ((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
+		break sedit::from-indent . 0)
+	       (sedit::set-indent . 1)
+	       (sedit::next-inline? 1 break sedit::from-indent . 1)
+	       (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
+		break sedit::from-indent . 0))))
+    sedit:*indent-alist*)
+
+(setf (sedit:get-format :slot-spec)
+      '(:indent :slot-spec :inline t))
+
+(setf (sedit:get-format :slot-spec-list)
+      '(:indent :binding-list :args (:slot-spec) :inline nil))
+
+(setf (sedit:get-format 'defclass)
+      '(:indent ((2) 1)
+	:args (:keyword nil nil :slot-spec-list nil)
+	:sublists (4)))
+
+(setf (sedit:get-format 'defmethod)
+      '(:indent ((2))
+	:args (:keyword nil :lambda-list nil)
+	:sublists (3)))
+
+(setf (sedit:get-format 'defgeneric) 'defun)
+
+(setf (sedit:get-format 'generic-flet) 'flet)
+
+(setf (sedit:get-format 'generic-labels) 'flet)
+
+(setf (sedit:get-format 'call-next-method)
+      '(:indent (1) :args (:keyword nil)))
+
+(setf (sedit:get-format 'symbol-macrolet) 'let)
+
+(setf (sedit:get-format 'with-accessors)
+      '(:indent ((1) 1)
+	:args (:keyword :binding-list nil)
+	:sublists (2)
+	:miser :never))
+
+(setf (sedit:get-format 'with-slots) 'with-accessors)
+
+(setf (sedit:get-format 'make-instance)
+      '(:indent ((1))
+	:args (:keyword nil :slot-spec-list)))
+
+(setf (sedit:get-format '*make-instance) 'make-instance)
+
+;;; PrettyFileIndex stuff, the product of Harley Davis.
+
+(defvar *pfi-class-type* '(class defclass pfi-class-namer))
+
+(defvar *pfi-method-type* '(method defmethod pfi-method-namer)
+  "Handles method for prettyfileindex")
+
+(defvar *pfi-index-accessors* nil
+  "t -> each slot accessor gets a listing in the index.")
+
+(defvar *pfi-method-index* :group
+  ":group, :separate, :both, or nil")
+
+(defun pfi-add-class-type ()
+  (pushnew *pfi-class-type* il:*pfi-types*))
+
+(defun pfi-add-method-type ()
+  (pushnew *pfi-method-type* il:*pfi-types*))
+
+(defun pfi-class-namer (expression entry)
+  (let ((class-name (second expression)))
+    ;; Following adds all slot readers/writers/accessors as separate entries in
+    ;; the index.  Probably a mistake.
+    (if *pfi-index-accessors*
+	(let ((slot-list (fourth expression))
+	      (accessor-names nil))
+	  (labels ((add-accessor (method-index name-index)
+		     (push (case *pfi-method-index*
+			     (:group method-index)
+			     (:separate name-index)
+			     ((t :both) (list method-index name-index))
+			     ((nil) nil)
+			     (otherwise (error "Illegal value for *pfi-method-index*: ~S"
+					       *pfi-method-index*)))
+			   accessor-names))
+		   (add-reader (reader-name)
+		     (add-accessor `(method (,reader-name (,class-name)))
+				   `(,reader-name (,class-name))))
+		   (add-writer (writer-name)
+		     (add-accessor `(method ((setf ,writer-name) (t ,class-name)))
+				   `((setf ,writer-name) (t ,class-name)))))
+	    (dolist (slot-def slot-list)
+	      (do* ((rest-slot-args (cdr slot-def) (cddr rest-slot-args))
+		    (slot-arg (first  rest-slot-args)  (first rest-slot-args)))
+		   ((null rest-slot-args))
+ 		(case slot-arg
+		  (:reader (add-reader (second rest-slot-args)))
+		  (:writer (add-writer (second rest-slot-args)))
+		  (:accessor (add-reader (second rest-slot-args))
+			     (add-writer (second rest-slot-args)))
+		  (otherwise nil))))
+	    (cons `(class (,class-name)) accessor-names)))
+	class-name)))
+
+(defun pfi-method-namer (expression entry)
+  (let ((method-name (second expression))
+	(specializers nil)
+	(qualifiers nil)
+	lambda-list)
+    (do* ((rest-qualifiers (cddr expression) (cdr rest-qualifiers))
+	  (qualifier (first rest-qualifiers) (first rest-qualifiers)))
+	 ((listp qualifier) (setq lambda-list qualifier)
+	                    (setq qualifiers (reverse qualifiers)) qualifiers)
+      (push qualifier qualifiers))
+    (do* ((rest-lambda-list lambda-list (cdr rest-lambda-list))
+	  (arg (first rest-lambda-list) (first rest-lambda-list)))
+	 ((or (member arg lambda-list-keywords) (null rest-lambda-list))
+	  (setq specializers (reverse specializers)))
+      (push (if (listp arg) (second arg) t) specializers))
+    (let ((method-index `(method (,method-name ,@qualifiers ,specializers)))
+	  (name-index `(,method-name ,@qualifiers ,specializers)))
+      (case *pfi-method-index*
+	(:group method-index)
+	(:separate name-index)
+	((t :both) (list method-index name-index))
+	((nil) nil)
+	(otherwise (error "Illegal value for *pfi-method-index*: ~S" *pfi-method-index*))))))
+
+(defun pfi-install-clos ()
+  (pfi-add-method-type)
+  (pfi-add-class-type))
+
+(eval-when (eval load)
+  (when (boundp (quote il:*pfi-types*))
+    (pfi-install-clos))
+  )
diff --git a/clos/2.0/combin.lisp b/clos/2.0/combin.lisp
new file mode 100644
index 00000000..f76ba815
--- /dev/null
+++ b/clos/2.0/combin.lisp
@@ -0,0 +1,254 @@
+;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+(defun make-effective-method-function (generic-function form)
+  (flet ((name-function (fn) (set-function-name fn 'a-combined-method) fn))
+    (if (and (listp form)
+	     (eq (car form) 'call-method)
+	     (method-p (cadr form))
+	     (every #'method-p (caddr form)))
+	;;
+	;; The effective method is just a call to call-method.  This opens up
+	;; the possibility of just using the method function of the method as
+	;; as the effective method function.
+	;;
+	;; But we have to be careful.  If that method function will ask for
+	;; the next methods we have to provide them.  We do not look to see
+	;; if there are next methods, we look at whether the method function
+	;; asks about them.  If it does, we must tell it whether there are
+	;; or aren't to prevent the leaky next methods bug.
+	;; 
+	(let* ((method-function (method-function (cadr form)))
+	       (arg-info (gf-arg-info generic-function))
+	       (metatypes (arg-info-metatypes arg-info))
+	       (applyp (arg-info-applyp arg-info)))
+	  (if (not (method-function-needs-next-methods-p method-function))
+	      method-function
+	      (let ((next-method-functions (mapcar #'method-function (caddr form))))
+		(name-function
+		  (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp)
+				   (let ((*next-methods* .next-method-functions.))
+				     ,(make-dfun-call metatypes applyp '.method-function.)))
+		    #'default-test-converter	;This could be optimized by making
+						;the interface from here to the
+						;walker more clear so that the
+						;form wouldn't get walked at all.
+		    #'(lambda (form)
+			(if (memq form '(.next-method-functions. .method-function.))
+			    (values form (list form))
+			    form))
+		    #'(lambda (form)
+			(cond ((eq form '.next-method-functions.)
+			       (list next-method-functions))
+			      ((eq form '.method-function.)
+			       (list method-function)))))))))
+	;;
+	;; We have some sort of `real' effective method.  Go off and get a
+	;; compiled function for it.  Most of the real hair here is done by
+	;; the GET-FUNCTION mechanism.
+	;; 
+	(name-function (make-effective-method-function-internal generic-function form)))))
+
+(defvar *global-effective-method-gensyms* ())
+(defvar *rebound-effective-method-gensyms*)
+
+(defun get-effective-method-gensym ()
+  (or (pop *rebound-effective-method-gensyms*)
+      (let ((new (make-symbol "EFFECTIVE-METHOD-GENSYM-")))
+	(push new *global-effective-method-gensyms*)
+	new)))
+
+(eval-when (load)
+  (let ((*rebound-effective-method-gensyms* ()))
+    (dotimes (i 10) (get-effective-method-gensym))))
+
+(defun make-effective-method-function-internal (generic-function effective-method)
+  (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)
+	 (arg-info (gf-arg-info generic-function))
+	 (metatypes (arg-info-metatypes arg-info))
+	 (applyp (arg-info-applyp arg-info)))
+    (labels ((test-converter (form)
+	       (if (and (consp form) (eq (car form) 'call-method))
+		   '.call-method.
+		   (default-test-converter form)))
+	     (code-converter (form)
+	       (if (and (consp form) (eq (car form) 'call-method))
+		   ;;
+		   ;; We have a `call' to CALL-METHOD.  There may or may not be next methods
+		   ;; and the two cases are a little different.  It controls how many gensyms
+		   ;; we will generate.
+		   ;;
+		   (let ((gensyms
+			   (if (cddr form)
+			       (list (get-effective-method-gensym)
+				     (get-effective-method-gensym))
+			       (list (get-effective-method-gensym)
+				     ()))))
+		     (values `(let ((*next-methods* ,(cadr gensyms)))
+				,(make-dfun-call metatypes applyp (car gensyms)))
+			     gensyms))
+		   (default-code-converter form)))
+	     (constant-converter (form)
+	       (if (and (consp form) (eq (car form) 'call-method))
+		   (if (cddr form)
+		       (list (check-for-make-method (cadr form))
+			     (mapcar #'check-for-make-method (caddr form)))
+		       (list (check-for-make-method (cadr form))
+			     ()))
+		   (default-constant-converter form)))
+	     (check-for-make-method (effective-method)
+	       (cond ((method-p effective-method)
+		      (method-function effective-method))
+		     ((and (listp effective-method)
+			   (eq (car effective-method) 'make-method))
+		      (make-effective-method-function generic-function
+						      (make-progn (cadr effective-method))))
+		     (t
+		      (error "Effective-method form is malformed.")))))
+      (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp) ,effective-method)
+		  #'test-converter
+		  #'code-converter
+		  #'constant-converter))))
+
+
+
+(defvar *invalid-method-error*
+	#'(lambda (&rest args)
+	    (declare (ignore args))
+	    (error
+	      "INVALID-METHOD-ERROR was called outside the dynamic scope~%~
+               of a method combination function (inside the body of~%~
+               DEFINE-METHOD-COMBINATION or a method on the generic~%~
+               function COMPUTE-EFFECTIVE-METHOD).")))
+
+(defvar *method-combination-error*
+	#'(lambda (&rest args)
+	    (declare (ignore args))
+	    (error
+	      "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
+               of a method combination function (inside the body of~%~
+               DEFINE-METHOD-COMBINATION or a method on the generic~%~
+               function COMPUTE-EFFECTIVE-METHOD).")))
+
+;(defmethod compute-effective-method :around        ;issue with magic
+;	   ((generic-function generic-function)     ;generic functions
+;	    (method-combination method-combination)
+;	    applicable-methods)
+;  (declare (ignore applicable-methods))
+;  (flet ((real-invalid-method-error (method format-string &rest args)
+;	   (declare (ignore method))
+;	   (apply #'error format-string args))
+;	 (real-method-combination-error (format-string &rest args)
+;	   (apply #'error format-string args)))
+;    (let ((*invalid-method-error* #'real-invalid-method-error)
+;	  (*method-combination-error* #'real-method-combination-error))
+;      (call-next-method))))
+
+(defun invalid-method-error (&rest args)
+  (declare (arglist method format-string &rest format-arguments))
+  (apply *invalid-method-error* args))
+
+(defun method-combination-error (&rest args)
+  (declare (arglist format-string &rest format-arguments))
+  (apply *method-combination-error* args))
+
+
+
+;;;
+;;; The STANDARD method combination type.  This is coded by hand (rather than
+;;; with define-method-combination) for bootstrapping and efficiency reasons.
+;;; Note that the definition of the find-method-combination-method appears in
+;;; the file defcombin.lisp, this is because EQL methods can't appear in the
+;;; bootstrap.
+;;;
+;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
+;;; classes has to appear here for this reason.  This code must conform to
+;;; the code in the file defcombin, look there for more details.
+;;;
+
+(defclass method-combination () ())
+
+(define-gf-predicate method-combination-p method-combination)
+
+(defclass standard-method-combination
+	  (definition-source-mixin method-combination)
+     ((type          :reader method-combination-type
+	             :initarg :type)
+      (documentation :reader method-combination-documentation
+		     :initarg :documentation)
+      (options       :reader method-combination-options
+	             :initarg :options)))
+
+(defmethod print-object ((mc method-combination) stream)
+  (printing-random-thing (mc stream)
+    (format stream
+	    "Method-Combination ~S ~S"
+	    (method-combination-type mc)
+	    (method-combination-options mc))))
+
+(eval-when (load eval)
+  (setq *standard-method-combination*
+	(make-instance 'standard-method-combination
+		       :type 'standard
+		       :documentation "The standard method combination."
+		       :options ())))
+
+;This definition appears in defcombin.lisp.
+;
+;(defmethod find-method-combination ((generic-function generic-function)
+;				     (type (eql 'standard))
+;				     options)
+;  (when options
+;    (method-combination-error
+;      "The method combination type STANDARD accepts no options."))
+;  *standard-method-combination*)
+
+(defun make-call-methods (methods)
+  (mapcar #'(lambda (method) `(call-method ,method ())) methods))
+
+(defmethod compute-effective-method ((generic-function generic-function)
+				     (combin standard-method-combination)
+				     applicable-methods)
+  (let ((before ())
+	(primary ())
+	(after ())
+	(around ()))
+    (dolist (m applicable-methods)
+      (let ((qualifiers (method-qualifiers m)))
+	(cond ((member ':before qualifiers)  (push m before))
+	      ((member ':after  qualifiers)  (push m after))
+	      ((member ':around  qualifiers) (push m around))
+	      (t
+	       (push m primary)))))
+    (setq before  (reverse before)
+	  after   (reverse after)
+	  primary (reverse primary)
+	  around  (reverse around))
+    (cond ((null primary)
+	   `(error "No primary method for the generic function ~S." ',generic-function))
+	  ((and (null before) (null after) (null around))
+	   ;;
+	   ;; By returning a single call-method `form' here we enable an important
+	   ;; implementation-specific optimization.
+	   ;; 
+	   `(call-method ,(first primary) ,(rest primary)))
+	  (t
+	   (let ((main-effective-method
+		   (if (or before after (rest primary))
+		       `(multiple-value-prog1
+			  (progn ,@(make-call-methods before)
+				 (call-method ,(first primary) ,(rest primary)))
+			  ,@(make-call-methods (reverse after)))
+		       `(call-method ,(first primary) ()))))
+	     (if around
+		 `(call-method ,(first around)
+			       (,@(rest around) (make-method ,main-effective-method)))
+		 main-effective-method))))))
+
diff --git a/clos/2.0/compat.lisp b/clos/2.0/compat.lisp
new file mode 100644
index 00000000..ca390f84
--- /dev/null
+++ b/clos/2.0/compat.lisp
@@ -0,0 +1,11 @@
+;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp; -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+()
diff --git a/clos/2.0/construct.lisp b/clos/2.0/construct.lisp
new file mode 100644
index 00000000..7d740475
--- /dev/null
+++ b/clos/2.0/construct.lisp
@@ -0,0 +1,1090 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;;
+;;; This file defines the defconstructor and other make-instance optimization
+;;; mechanisms.
+;;; 
+
+(in-package 'clos)
+
+;;;
+;;; defconstructor is used to define special purpose functions which just
+;;; call make-instance with a symbol as the first argument.  The semantics
+;;; of defconstructor is that it is equivalent to defining a function which
+;;; just calls make-instance. The purpose of defconstructor is to provide
+;;; CLOS with a way of noticing these calls to make-instance so that it can
+;;; optimize them.  Specific ports of CLOS could just have their compiler
+;;; spot these calls to make-instance and then call this code.  Having the
+;;; special defconstructor facility is the best we can do portably.
+;;; 
+;;;
+;;; A call to defconstructor like:
+;;;
+;;;  (defconstructor make-foo foo (a b &rest r) a a :mumble b baz r)
+;;;
+;;; Is equivalent to a defun like:
+;;;
+;;;  (defun make-foo (a b &rest r)
+;;;    (make-instance 'foo 'a a ':mumble b 'baz r))
+;;;
+;;; Calls like the following are also legal:
+;;;
+;;;  (defconstructor make-foo foo ())
+;;;  (defconstructor make-bar bar () :x *x* :y *y*)
+;;;  (defconstructor make-baz baz (a b c) a-b (list a b) b-c (list b c))
+;;;
+;;;
+;;; The general idea of this implementation is that the expansion of the
+;;; defconstructor form includes the creation of closure generators which
+;;; can be called to create constructor code for the class.  The ways that
+;;; a constructor can be optimized depends not only on the defconstructor
+;;; form, but also on the state of the class and the generic functions in
+;;; the initialization protocol.  Because of this, the determination of the
+;;; form of constructor code to be used is a two part process.
+;;;
+;;; At compile time, make-constructor-code-generators looks at the actual
+;;; defconstructor form and makes a list of appropriate constructor code
+;;; generators.  All that is really taken into account here is whether
+;;; any initargs are supplied in the call to make-instance, and whether
+;;; any of those are constant.
+;;;
+;;; At constructor code generation time (see note about lazy evaluation)
+;;; compute-constructor-code calls each of the constructor code generators
+;;; to try to get code for this constructor.  Each generator looks at the
+;;; state of the class and initialization protocol generic functions and
+;;; decides whether its type of code is appropriate.  This depends on things
+;;; like whether there are any applicable methods on initialize-instance,
+;;; whether class slots are affected by initialization etc.
+;;; 
+;;;
+;;; Constructor objects are funcallable instances, the protocol followed to
+;;; to compute the constructor code for them is quite similar to the protocol
+;;; followed to compute the discriminator code for a generic function.  When
+;;; the constructor is first loaded, we install as its code a function which
+;;; will compute the actual constructor code the first time it is called.
+;;; 
+;;; If there is an update to the class structure which might invalidate the
+;;; optimized constructor, the special lazy constructor installer is put back
+;;; so that it can compute the appropriate constructor when it is called.
+;;; This is the same kind of lazy evaluation update strategy used elswhere
+;;; in CLOS.
+;;;
+;;; To allow for flexibility in the CLOS implementation and to allow CLOS users
+;;; to specialize this constructor facility for their own metaclasses, there
+;;; is an internal protocol followed by the code which loads and installs
+;;; the constructors.  This is documented in the comments in the code.
+;;;
+;;; This code is also designed so that one of its levels, can be used to
+;;; implement optimization of calls to make-instance which can't go through
+;;; the defconstructor facility.  This has not been implemented yet, but the
+;;; hooks are there.
+;;;
+;;;
+
+(defmacro defconstructor
+	  (name class lambda-list &rest initialization-arguments)
+  (expand-defconstructor class
+			 name
+			 lambda-list
+			 (copy-list initialization-arguments)))
+
+(defun expand-defconstructor (class-name name lambda-list supplied-initargs)
+  (let ((class (find-class class-name nil))
+	(supplied-initarg-names
+	  (gathering1 (collecting)
+	    (iterate ((name (*list-elements supplied-initargs :by #'cddr)))
+	      (gather1 name)))))
+    (when (null class)
+      (error "defconstructor form being compiled (or evaluated) before~@
+              class ~S is defined."
+	     class-name))
+    `(progn
+       ;; In order to avoid undefined function warnings, we want to tell
+       ;; the compile time environment that a function with this name and
+       ;; this argument list has been defined.  The portable way to do this
+       ;; is with defun.
+       (proclaim '(notinline ,name))
+       (defun ,name ,lambda-list
+	 (declare (ignore ,@(specialized-lambda-list-parameters lambda-list)))
+	 (error "Constructor ~S not loaded." ',name))
+
+       ,(make-top-level-form `(defconstructor ,name)
+			     '(load eval)
+	  `(load-constructor
+	     ',class-name
+	     ',(class-name (class-of class))
+	     ',name
+	     ',supplied-initarg-names
+	     ;; make-constructor-code-generators is called to return a list
+	     ;; of constructor code generators.  The actual interpretation
+	     ;; of this list is left to compute-constructor-code, but the
+	     ;; general idea is that it should be an plist where the keys
+	     ;; name a kind of constructor code and the values are generator
+	     ;; functions which return the actual constructor code.  The
+	     ;; constructor code is usually a closures over the arguments
+	     ;; to the generator.
+	     ,(make-constructor-code-generators class
+						name
+						lambda-list
+						supplied-initarg-names
+						supplied-initargs))))))
+
+(defun load-constructor (class-name metaclass-name constructor-name
+			 supplied-initarg-names code-generators)
+  (let ((class (find-class class-name nil)))
+    (cond ((null class)
+	   (error "defconstructor form being loaded (or evaluated) before~@
+                   class ~S is defined."
+		  class-name))
+	  ((neq (class-name (class-of class)) metaclass-name)
+	   (error "When defconstructor ~S was compiled, the metaclass of the~@
+                   class ~S was ~S.  The metaclass is now ~S.~@
+                   The constructor must be recompiled."
+		  constructor-name
+		  class-name
+		  metaclass-name
+		  (class-name (class-of class))))
+	  (t
+	   (load-constructor-internal class
+				      constructor-name
+				      supplied-initarg-names
+				      code-generators)
+	   constructor-name))))
+
+;;;
+;;; The actual constructor objects.
+;;; 
+(defclass constructor ()			   
+     ((class					;The class with which this
+	:initarg :class				;constructor is associated.
+	:reader constructor-class)		;The actual class object,
+						;not the class name.
+						;      
+      (name					;The name of this constructor.
+	:initform nil				;This is the symbol in whose
+	:initarg :name				;function cell the constructor
+	:reader constructor-name)		;usually sits.  Of course, this
+						;is optional.  defconstructor
+						;makes named constructors, but
+						;it is possible to manipulate
+						;anonymous constructors also.
+						;
+      (code-type				;The type of code currently in
+	:initform nil				;use by this constructor.  This
+	:accessor constructor-code-type)	;is mostly for debugging and
+						;analysis purposes.
+						;The lazy installer sets this
+						;to LAZY.  The most basic and
+						;least optimized type of code
+						;is called FALLBACK.
+						;
+      (supplied-initarg-names			;The names of the initargs this
+	:initarg :supplied-initarg-names	;constructor supplies when it
+	:reader					;"calls" make-instance.
+	   constructor-supplied-initarg-names)	;
+						;
+      (code-generators				;Generators for the different
+	:initarg :code-generators		;types of code this constructor
+	:reader constructor-code-generators))	;could use.
+  (:metaclass funcallable-standard-class))
+
+
+;;;
+;;; Because the value in the code-type slot should always correspond to the
+;;; funcallable-instance-function of the constructor, this function should
+;;; always be used to set the both at the same time.
+;;;
+(defun set-constructor-code (constructor code type)
+  (set-funcallable-instance-function constructor code)
+  (set-function-name constructor (constructor-name constructor))
+  (setf (constructor-code-type constructor) type))
+
+
+(defmethod print-object ((constructor constructor) stream)
+  (printing-random-thing (constructor stream)
+    (format stream
+	    "~S ~S (~S)"
+	    (or (class-name (class-of constructor)) "Constructor")
+	    (or (constructor-name constructor) "Anonymous")
+	    (constructor-code-type constructor))))
+
+(defmethod describe-object ((constructor constructor) stream)
+  (format stream
+	  "~S is a constructor for the class ~S.~%~
+            The current code type is ~S.~%~
+            Other possible code types are ~S."
+	  constructor (constructor-class constructor)
+	  (constructor-code-type constructor)
+	  (gathering1 (collecting)
+	    (doplist (key val) (constructor-code-generators constructor)
+	      (gather1 key)))))
+
+;;;
+;;; I am not in a hairy enough mood to make this implementation be metacircular
+;;; enough that it can support a defconstructor for constructor objects.
+;;; 
+(defun make-constructor (class name supplied-initarg-names code-generators)
+  (make-instance 'constructor
+		 :class class
+		 :name name
+		 :supplied-initarg-names supplied-initarg-names
+		 :code-generators code-generators))
+
+; This definition actually appears in std-class.lisp.
+;(defmethod class-constructors ((class std-class))
+;  (with-slots (plist) class (getf plist 'constructors)))
+
+(defmethod add-constructor ((class std-class)
+			    (constructor constructor))
+  (with-slots (plist) class
+    (pushnew constructor (getf plist 'constructors))))
+
+(defmethod remove-constructor ((class std-class)
+			       (constructor constructor))
+  (with-slots (plist) class
+    (setf (getf plist 'constructors)
+	  (delete constructor (getf plist 'constructors)))))
+
+(defmethod get-constructor ((class std-class) name &optional (error-p t))
+  (or (dolist (c (class-constructors class))
+	(when (eq (constructor-name c) name) (return c)))
+      (if error-p
+	  (error "Couldn't find a constructor with name ~S for class ~S."
+		 name class)
+	  ())))
+
+;;;
+;;; This is called to actually load a defconstructor constructor.  It must
+;;; install the lazy installer in the function cell of the constructor name,
+;;; and also add this constructor to the list of constructors the class has.
+;;; 
+(defmethod load-constructor-internal
+	   ((class std-class) name initargs generators)
+  (let ((constructor (make-constructor class name initargs generators))
+	(old (get-constructor class name nil)))
+    (when old (remove-constructor class old))
+    (install-lazy-constructor-installer constructor)
+    (add-constructor class constructor)
+    (setf (symbol-function name) constructor)))
+
+(defmethod install-lazy-constructor-installer ((constructor constructor))
+  (let ((class (constructor-class constructor)))
+    (set-constructor-code constructor
+			  #'(lambda (&rest args)
+			      (multiple-value-bind (code type)
+				  (compute-constructor-code class constructor)
+				(prog1 (apply code args)
+				       (set-constructor-code constructor
+							     code
+							     type))))
+			  'lazy)))
+
+;;;
+;;; The interface to keeping the constructors updated.
+;;;
+;;; add-method and remove-method (for standard-generic-function and -method),
+;;; promise to call maybe-update-constructors on the generic function and
+;;; the method.
+;;; 
+;;; The class update code promises to call update-constructors whenever the
+;;; class is changed.  That is, whenever the supers, slots or options change.
+;;; If user defined classes of constructor needs to be updated in more than
+;;; these circumstances, they should use the dependent updating mechanism to
+;;; make sure update-constructors is called.
+;;;
+;;; Bootstrapping concerns force the definitions of maybe-update-constructors
+;;; and update-constructors to be in the file std-class.  For clarity, they
+;;; also appear below.  Be sure to keep the definition here and there in sync.
+;;; 
+;(defvar *initialization-generic-functions*
+;	 (list #'make-instance
+;	       #'default-initargs
+;	       #'allocate-instance
+;	       #'initialize-instance
+;	       #'shared-initialize))
+;
+;(defmethod maybe-update-constructors
+;	   ((generic-function generic-function)
+;	    (method method))
+;  (when (memq generic-function *initialization-generic-functions*)
+;    (labels ((recurse (class)
+;	       (update-constructors class)
+;	       (dolist (subclass (class-direct-subclasses class))
+;		 (recurse subclass))))
+;      (when (classp (car (method-specializers method)))
+;	(recurse (car (method-specializers method)))))))
+;
+;(defmethod update-constructors ((class std-class))
+;  (dolist (cons (class-constructors class))
+;    (install-lazy-constructor-installer cons)))
+;
+;(defmethod update-constructors ((class class))
+;  ())
+
+
+
+;;;
+;;; Here is the actual smarts for making the code generators and then trying
+;;; each generator to get constructor code. This extensible mechanism allows
+;;; new kinds of constructor code types to be added. A programmer defining a
+;;; specialization of the constructor class can either use this mechanism to
+;;; define new code types, or can override this mechanism by overriding the
+;;; methods on make-constructor-code-generators and compute-constructor-code.
+;;;
+;;; The function defined by define-constructor-code-type will receive the
+;;; class object, and the 4 original arguments to defconstructor. It can
+;;; return a constructor code generator, or return nil if this type of code
+;;; is determined to not be appropriate after looking at the defconstructor
+;;; arguments.
+;;;
+;;; When compute-constructor-code is called, it first performs basic checks
+;;; to make sure that the basic assumptions common to all the code types are
+;;; valid.  (For details see method definition).  If any of the tests fail,
+;;; the fallback constructor code type is used.  If none of the tests fail,
+;;; the constructor code generators are called in order.  They receive 5
+;;; arguments:
+;;;
+;;;   CLASS        the class the constructor is making instances of
+;;;   WRAPPER      that class's wrapper
+;;;   DEFAULTS     the result of calling class-default-initargs on class
+;;;   INITIALIZE   the applicable methods on initialize-instance
+;;;   SHARED       the applicable methosd on shared-initialize
+;;;
+;;; The first code generator to return code is used.  The code generators are
+;;; called in reverse order of definition, so define-constructor-code-type
+;;; forms which define better code should appear after ones that define less
+;;; good code.  The fallback code type appears first.  Note that redefining a
+;;; code type does not change its position in the list.  To do that,  define
+;;; a new type at the end with the behavior.
+;;; 
+
+(defvar *constructor-code-types* ())
+
+(defmacro define-constructor-code-type (type arglist &body body)
+  (let ((fn-name (intern (format nil
+				 "CONSTRUCTOR-CODE-GENERATOR ~A ~A"
+				 (package-name (symbol-package type))
+				 (symbol-name type))
+			 *the-clos-package*)))
+    `(progn
+       (defun ,fn-name ,arglist .,body)
+       (load-define-constructor-code-type ',type ',fn-name))))
+
+(defun load-define-constructor-code-type (type generator)
+  (let ((old-entry (assq type *constructor-code-types*)))
+    (if old-entry 
+	(setf (cadr old-entry) generator)
+	(push (list type generator) *constructor-code-types*))
+    type))
+
+(defmethod make-constructor-code-generators
+	   ((class std-class)
+	    name lambda-list supplied-initarg-names supplied-initargs)
+  (cons 'list
+	(gathering1 (collecting)
+	  (dolist (entry *constructor-code-types*)
+	    (let ((generator
+		    (funcall (cadr entry) class name lambda-list 
+					  supplied-initarg-names
+					  supplied-initargs)))
+	      (when generator
+		(gather1 `',(car entry))
+		(gather1 generator)))))))
+
+(defmethod compute-constructor-code ((class std-class)
+				     (constructor constructor))
+  (let* ((proto (class-prototype class))
+	 (wrapper (class-wrapper class))
+	 (defaults (class-default-initargs class))
+         (make
+           (compute-applicable-methods #'make-instance (list class)))
+	 (supplied-initarg-names
+	   (constructor-supplied-initarg-names constructor))
+         (default
+	   (compute-applicable-methods #'default-initargs
+				       (list class supplied-initarg-names))) ;?
+         (allocate
+           (compute-applicable-methods #'allocate-instance (list class)))
+         (initialize
+           (compute-applicable-methods #'initialize-instance (list proto)))
+         (shared
+           (compute-applicable-methods #'shared-initialize (list proto t)))
+         (code-generators
+           (constructor-code-generators constructor))
+	 (code-generators
+	   (constructor-code-generators constructor)))
+    (flet ((call-code-generator (generator)
+	     (when (null generator)
+	       (unless (setq generator (getf code-generators 'fallback))
+		 (error "No FALLBACK generator?")))
+	     (funcall generator class wrapper defaults initialize shared)))
+      (if (or (cdr make)
+	      (cdr default)
+	      (cdr allocate)
+	      (check-initargs class
+			      supplied-initarg-names
+			      defaults
+			      (append initialize shared)))
+	  ;; These are basic shared assumptions, if one of the
+	  ;; has been violated, we have to resort to the fallback
+	  ;; case.  Any of these assumptions could be moved out
+	  ;; of here and into the individual code types if there
+	  ;; was a need to do so.
+	  (values (call-code-generator nil) 'fallback)
+	  ;; Otherwise try all the generators until one produces
+	  ;; code for us.
+	  (doplist (type generator) code-generators
+	    (let ((code (call-code-generator generator)))
+	      (when code (return (values code type)))))))))
+
+;;;
+;;; The facilities are useful for debugging, and to measure the performance
+;;; boost from constructors.
+;;; 
+
+(defun map-constructors (fn)
+  (let ((nclasses 0)
+	(nconstructors 0))
+    (labels ((recurse (class)
+	       (incf nclasses)
+	       (dolist (constructor (class-constructors class))
+		 (incf nconstructors)
+		 (funcall fn constructor))
+	       (dolist (subclass (class-direct-subclasses class))
+		 (recurse subclass))))
+      (recurse (find-class 't))
+      (values nclasses nconstructors))))
+
+(defun reset-constructors ()
+  (multiple-value-bind (nclass ncons)
+      (map-constructors #'install-lazy-constructor-installer )
+    (format t "~&~D classes, ~D constructors." nclass ncons)))
+
+(defun disable-constructors ()
+  (multiple-value-bind (nclass ncons)
+      (map-constructors
+	#'(lambda (c)
+	    (let ((gen (getf (constructor-code-generators c) 'fallback)))
+	      (if (null gen)
+		  (error "No fallback constructor for ~S." c)
+		  (set-constructor-code c
+					(funcall gen
+						 (constructor-class c)
+						 () () () ())
+					'fallback)))))
+    (format t "~&~D classes, ~D constructors." nclass ncons)))
+
+(defun enable-constructors ()
+  (reset-constructors))
+
+
+;;;
+;;; Helper functions and utilities that are shared by all of the code types
+;;; and by the main compute-constructor-code method as well.
+;;; 
+
+(defvar *standard-initialize-instance-method*
+        (get-method #'initialize-instance
+		    ()
+		    (list *the-class-standard-object*)))
+
+(defvar *standard-shared-initialize-method*
+        (get-method #'shared-initialize
+		    ()
+		    (list *the-class-standard-object* *the-class-t*)))
+
+(defun non-clos-initialize-instance-methods-p (methods)
+  (notevery #'(lambda (m) (eq m *standard-initialize-instance-method*))
+	    methods))
+
+(defun non-clos-shared-initialize-methods-p (methods)
+  (notevery #'(lambda (m) (eq m *standard-shared-initialize-method*))
+	    methods))
+
+(defun non-clos-or-after-initialize-instance-methods-p (methods)
+  (notevery #'(lambda (m) (or (eq m *standard-initialize-instance-method*)
+			      (equal '(:after) (method-qualifiers m))))
+	    methods))
+
+(defun non-clos-or-after-shared-initialize-methods-p (methods)
+  (notevery #'(lambda (m) (or (eq m *standard-shared-initialize-method*)
+			      (equal '(:after) (method-qualifiers m))))
+	    methods))
+
+
+;;; 
+;;; if initargs are valid return nil, otherwise return t.
+;;;
+(defun check-initargs (class supplied-initarg-names defaults methods)
+  (let ((legal (apply #'append
+		      (mapcar #'slotd-initargs (class-slots class)))))
+    ;; Add to the set of slot-filling initargs the set of
+    ;; initargs that are accepted by the methods.  If at
+    ;; any point we come across &allow-other-keys, we can
+    ;; just quit.
+    (dolist (method methods)
+      (multiple-value-bind (keys allow-other-keys)
+	  (function-keywords method)
+	(when allow-other-keys
+	  (return-from check-initargs nil))
+	(setq legal (append keys legal))))
+    ;; Now check the supplied-initarg-names and the default initargs
+    ;; against the total set that we know are legal.
+    (dolist (key supplied-initarg-names)
+      (unless (memq key legal)
+	(return-from check-initargs t)))
+    (dolist (default defaults)
+      (unless (memq (car default) legal)
+	(return-from check-initargs t)))))
+
+
+;;;
+;;; This returns two values.  The first is a vector which can be used as the
+;;; initial value of the slots vector for the instance. The first is a symbol
+;;; describing the initforms this class has.  
+;;;
+;;;  If the first value is:
+;;;
+;;;    :unsupplied    no slot has an initform
+;;;    :constants     all slots have either a constant initform
+;;;                   or no initform at all
+;;;    t              there is at least one non-constant initform
+;;; 
+(defun compute-constant-vector (class)
+  (declare (values constants flag))
+  (let* ((wrapper (class-wrapper class))
+	 (layout (wrapper-instance-slots-layout wrapper))
+	 (flag :unsupplied)
+	 (constants ()))
+    (dolist (slotd (class-slots class))
+      (let ((name (slotd-name slotd))
+	    (initform (slotd-initform slotd))
+	    (initfn (slotd-initfunction slotd)))
+	(cond ((null (memq name layout)))
+	      ((or (eq initform *slotd-unsupplied*)
+		   (null initfn))
+	       (push (cons name *slot-unbound*) constants))
+	      ((constantp initform)
+	       (push (cons name (eval initform)) constants)
+	       (when (eq flag ':unsupplied) (setq flag ':constants)))
+	      (t
+	       (push (cons name *slot-unbound*) constants)
+	       (setq flag 't)))))
+    (values
+      (apply #'vector
+	     (mapcar #'cdr
+		     (sort constants #'(lambda (x y)
+					 (memq (car y)
+					       (memq (car x) layout))))))
+      flag)))
+
+(defmacro copy-constant-vector (constants)
+  `(copy-seq (the simple-vector ,constants)))
+
+
+;;;
+;;; This takes a class and a list of initarg-names, and returns an alist
+;;; indicating the positions of the slots those initargs may fill.  The
+;;; order of the initarg-names argument is important of course, since we
+;;; have to respect the rules about the leftmost initarg that fills a slot
+;;; having precedence.  This function allows initarg names to appear twice
+;;; in the list, it only considers the first appearance.
+;;;
+(defun compute-initarg-positions (class initarg-names)
+  (let* ((layout (wrapper-instance-slots-layout (class-wrapper class)))
+	 (positions
+	   (gathering1 (collecting)
+	     (iterate ((slot-name (list-elements layout))
+		       (position (interval :from 0)))
+	       (gather1 (cons slot-name position)))))
+	 (slot-initargs
+	   (mapcar #'(lambda (slotd)
+		       (list (slotd-initargs slotd)
+			     (or (cdr (assq (slotd-name slotd) positions))
+				 ':class)))
+		   (class-slots class))))
+    ;; Go through each of the initargs, and figure out what position
+    ;; it fills by replacing the entries in slot-initargs it fills.
+    (dolist (initarg initarg-names)
+      (dolist (slot-entry slot-initargs)
+	(let ((slot-initargs (car slot-entry)))
+	  (when (and (listp slot-initargs)
+		     (not (null slot-initargs))
+		     (memq initarg slot-initargs))
+	    (setf (car slot-entry) initarg)))))
+    (gathering1 (collecting)
+      (dolist (initarg initarg-names)
+	(let ((positions (gathering1 (collecting)
+			   (dolist (slot-entry slot-initargs)
+			     (when (eq (car slot-entry) initarg)
+			       (gather1 (cadr slot-entry)))))))
+	  (when positions
+	    (gather1 (cons initarg positions))))))))
+
+
+;;;
+;;; The FALLBACK case allows anything.  This always works, and always appears
+;;; as the last of the generators for a constructor.  It does a full call to
+;;; make-instance.
+;;;
+
+(define-constructor-code-type fallback
+        (class name arglist supplied-initarg-names supplied-initargs)
+  (declare (ignore name supplied-initarg-names))
+  `(function
+     (lambda (&rest ignore)
+       (declare (ignore ignore))
+       (function
+	 (lambda ,arglist
+	   (make-instance
+	     ',(class-name class)
+	     ,@(gathering1 (collecting)
+		 (iterate ((tail (*list-tails supplied-initargs :by #'cddr)))
+		   (gather1 `',(car tail))
+		   (gather1 (cadr tail))))))))))
+
+;;;
+;;; The GENERAL case allows:
+;;;   constant, unsupplied or non-constant initforms
+;;;   constant or non-constant default initargs
+;;;   supplied initargs
+;;;   slot-filling initargs
+;;;   :after methods on shared-initialize and initialize-instance
+;;;   
+(define-constructor-code-type general
+        (class name arglist supplied-initarg-names supplied-initargs)
+  (declare (ignore name))
+  (let ((raw-allocator (raw-instance-allocator class))
+	(slots-fetcher (slots-fetcher class))
+	(wrapper-fetcher (wrapper-fetcher class)))
+    `(function
+       (lambda (class .wrapper. defaults init shared)
+	 (multiple-value-bind (.constants.
+			       .constant-initargs.
+			       .initfns-initargs-and-positions.
+			       .supplied-initarg-positions.
+			       .shared-initfns.
+			       .initfns.)
+	     (general-generator-internal class
+					 defaults
+					 init
+					 shared
+					 ',supplied-initarg-names
+					 ',supplied-initargs)
+	   .supplied-initarg-positions.
+	   (when (and .constants.
+		      (null (non-clos-or-after-initialize-instance-methods-p
+			      init))
+		      (null (non-clos-or-after-shared-initialize-methods-p
+			      shared)))
+	     (function
+	       (lambda ,arglist
+		 (declare (optimize (speed 3) (safety 0)))
+		 (let ((.instance. (,raw-allocator))
+		       (.slots. (copy-constant-vector .constants.))
+		       (.positions. .supplied-initarg-positions.)
+		       (.initargs. .constant-initargs.))		   
+		   .positions.
+		   
+		   (setf (,slots-fetcher .instance.) .slots.)	     
+		   (setf (,wrapper-fetcher .instance.) .wrapper.)
+
+		   (dolist (entry .initfns-initargs-and-positions.)
+		     (let ((val (funcall (car entry)))
+			   (initarg (cadr entry)))
+		       (when initarg
+			 (push val .initargs.)
+			 (push initarg .initargs.))
+		       (dolist (pos (cddr entry))
+			 (setf (%svref .slots. pos) val))))
+
+		   ,@(gathering1 (collecting)
+		       (doplist (initarg value) supplied-initargs
+			 (unless (constantp value)
+			   (gather1 `(let ((.value. ,value))
+				       (push .value. .initargs.)
+				       (push ',initarg .initargs.)
+				       (dolist (.p. (pop .positions.))
+					 (setf (%svref .slots. .p.)
+					       .value.)))))))
+
+		   (dolist (fn .shared-initfns.)
+		     (apply fn .instance. t .initargs.))
+		   (dolist (fn .initfns.)
+		     (apply fn .instance. .initargs.))
+		     
+		   .instance.)))))))))
+
+(defun general-generator-internal
+       (class defaults init shared supplied-initarg-names supplied-initargs)
+  (flet ((bail-out () (return-from general-generator-internal nil)))
+    (let* ((constants (compute-constant-vector class))
+	   (layout (wrapper-instance-slots-layout (class-wrapper class)))
+	   (initarg-positions
+	     (compute-initarg-positions class
+					(append supplied-initarg-names
+						(mapcar #'car defaults))))
+	   (initfns-initargs-and-positions ())
+	   (supplied-initarg-positions ())
+	   (constant-initargs ())
+	   (used-positions ()))
+					       
+      ;;
+      ;; Go through each of the supplied initargs for three reasons.
+      ;;
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If its a constant form, fill the constant vector.
+      ;;   - Otherwise remember the positions no two initargs
+      ;;     will try to fill the same position, since compute
+      ;;     initarg positions already took care of that, but
+      ;;     we do need to know what initforms will and won't
+      ;;     be needed.
+      ;;   
+      (doplist (initarg val) supplied-initargs
+	(let ((positions (cdr (assq initarg initarg-positions))))
+	  (cond ((memq :class positions) (bail-out))
+		((constantp val)
+		 (setq val (eval val))
+		 (push val constant-initargs)
+		 (push initarg constant-initargs)
+		 (dolist (pos positions) (setf (svref constants pos) val)))
+		(t
+		 (push positions supplied-initarg-positions)))
+	  (setq used-positions (append positions used-positions))))
+      ;;
+      ;; Go through each of the default initargs, for three reasons.
+      ;;
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If it is a constant, and it does fill a slot, put that
+      ;;     into the constant vector.
+      ;;   - If it isn't a constant, record its initfn and position.
+      ;;   
+      (dolist (default defaults)
+	(let* ((name (car default))
+	       (initfn (cadr default))
+	       (form (caddr default))
+	       (value ())
+	       (positions (cdr (assq name initarg-positions))))
+	  (unless (memq name supplied-initarg-names)
+	    (cond ((memq :class positions) (bail-out))
+		  ((constantp form)
+		   (setq value (eval form))
+		   (push value constant-initargs)
+		   (push name constant-initargs)
+		   (dolist (pos positions)
+		     (setf (svref constants pos) value)))
+		  (t
+		   (push (list* initfn name positions)
+			 initfns-initargs-and-positions)))
+	    (setq used-positions (append positions used-positions)))))
+      ;;
+      ;; Go through each of the slot initforms:
+      ;;
+      ;;    - If its position has already been filled, do nothing.
+      ;;      The initfn won't need to be called, and the slot won't
+      ;;      need to be touched.
+      ;;    - If it is a class slot, and has an initform, bail out.
+      ;;    - If its a constant or unsupplied, ignore it, it is
+      ;;      already in the constant vector.
+      ;;    - Otherwise, record its initfn and position
+      ;;
+      (dolist (slotd (class-slots class))
+	(let* ((alloc (slotd-allocation slotd))
+	       (name (slotd-name slotd))
+	       (form (slotd-initform slotd))
+	       (initfn (slotd-initfunction slotd))
+	       (position (position name layout)))
+	  (cond ((neq alloc :instance)
+		 (unless (or (eq form *slotd-unsupplied*)
+			     (null initfn))
+		   (bail-out)))
+		((member position used-positions))
+		((or (constantp form)
+		     (eq form *slotd-unsupplied*)))
+		(t
+		 (push (list initfn nil position)
+		       initfns-initargs-and-positions)))))
+
+      (values constants
+	      constant-initargs
+	      (nreverse initfns-initargs-and-positions)
+	      (nreverse supplied-initarg-positions)
+	      (mapcar #'method-function
+		      (remove *standard-shared-initialize-method* shared))
+	      (mapcar #'method-function
+		      (remove *standard-initialize-instance-method* init))))))
+
+
+;;;
+;;; The NO-METHODS case allows:
+;;;   constant, unsupplied or non-constant initforms
+;;;   constant or non-constant default initargs
+;;;   supplied initargs that are arguments to constructor, or constants
+;;;   slot-filling initargs
+;;;
+
+(define-constructor-code-type no-methods
+        (class name arglist supplied-initarg-names supplied-initargs)
+  (declare (ignore name))
+  (let ((raw-allocator (raw-instance-allocator class))
+	(slots-fetcher (slots-fetcher class))
+	(wrapper-fetcher (wrapper-fetcher class)))
+    `(function
+       (lambda (class .wrapper. defaults init shared)
+	 (multiple-value-bind (.constants.
+			       .initfns-and-positions.
+			       .supplied-initarg-positions.)
+	     (no-methods-generator-internal class
+					    defaults
+					    ',supplied-initarg-names
+					    ',supplied-initargs)
+	   .initfns-and-positions.
+	   .supplied-initarg-positions.
+	   (when (and .constants.
+		      (null (non-clos-initialize-instance-methods-p init))
+		      (null (non-clos-shared-initialize-methods-p shared)))
+	     #'(lambda ,arglist
+		 (declare (optimize (speed 3) (safety 0)))
+		 (let ((.instance. (,raw-allocator))
+		       (.slots. (copy-constant-vector .constants.))
+		       (.positions. .supplied-initarg-positions.))
+		   .positions.
+		   (setf (,slots-fetcher .instance.) .slots.)
+		   (setf (,wrapper-fetcher .instance.) .wrapper.)
+
+		   (dolist (entry .initfns-and-positions.)
+		     (let ((val (funcall (car entry))))
+		       (dolist (pos (cdr entry))
+			 (setf (%svref .slots. pos) val))))
+		 
+		   ,@(gathering1 (collecting)
+		       (doplist (initarg value) supplied-initargs
+			 (unless (constantp value)
+			   (gather1
+			     `(let ((.value. ,value))
+				(dolist (.p. (pop .positions.))
+				  (setf (%svref .slots. .p.) .value.)))))))
+		     
+		   .instance.))))))))
+
+(defun no-methods-generator-internal
+       (class defaults supplied-initarg-names supplied-initargs)
+  (flet ((bail-out () (return-from no-methods-generator-internal nil)))
+    (let* ((constants	(compute-constant-vector class))
+	   (layout (wrapper-instance-slots-layout (class-wrapper class)))
+	   (initarg-positions
+	     (compute-initarg-positions class
+					(append supplied-initarg-names
+						(mapcar #'car defaults))))
+	   (initfns-and-positions ())
+	   (supplied-initarg-positions ())
+	   (used-positions ()))
+      ;;
+      ;; Go through each of the supplied initargs for three reasons.
+      ;;
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If its a constant form, fill the constant vector.
+      ;;   - Otherwise remember the positions, no two initargs
+      ;;     will try to fill the same position, since compute
+      ;;     initarg positions already took care of that, but
+      ;;     we do need to know what initforms will and won't
+      ;;     be needed.
+      ;;   
+      (doplist (initarg val) supplied-initargs
+	(let ((positions (cdr (assq initarg initarg-positions))))
+	  (cond ((memq :class positions) (bail-out))
+		((constantp val)
+		 (setq val (eval val))
+		 (dolist (pos positions)
+		   (setf (svref constants pos) val)))
+		(t
+		 (push positions supplied-initarg-positions)))
+	  (setq used-positions (append positions used-positions))))
+      ;;
+      ;; Go through each of the default initargs, for three reasons.
+      ;;
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If it is a constant, and it does fill a slot, put that
+      ;;     into the constant vector.
+      ;;   - If it isn't a constant, record its initfn and position.
+      ;;   
+      (dolist (default defaults)
+	(let* ((name (car default))
+	       (initfn (cadr default))
+	       (form (caddr default))
+	       (value ())
+	       (positions (cdr (assq name initarg-positions))))
+	  (unless (memq name supplied-initarg-names)
+	    (cond ((memq :class positions) (bail-out))
+		  ((constantp form)
+		   (setq value (eval form))
+		   (dolist (pos positions)
+		     (setf (svref constants pos) value)))
+		  (t
+		   (push (cons initfn positions)
+			 initfns-and-positions)))
+	    (setq used-positions (append positions used-positions)))))
+      ;;
+      ;; Go through each of the slot initforms:
+      ;;
+      ;;    - If its position has already been filled, do nothing.
+      ;;      The initfn won't need to be called, and the slot won't
+      ;;      need to be touched.
+      ;;    - If it is a class slot, and has an initform, bail out.
+      ;;    - If its a constant or unsupplied, do nothing, we know
+      ;;      that it is already in the constant vector.
+      ;;    - Otherwise, record its initfn and position
+      ;;
+      (dolist (slotd (class-slots class))
+	(let* ((alloc (slotd-allocation slotd))
+	       (name (slotd-name slotd))
+	       (form (slotd-initform slotd))
+	       (initfn (slotd-initfunction slotd))
+	       (position (position name layout)))
+	  (cond ((neq alloc :instance)
+		 (unless (or (eq form *slotd-unsupplied*) 
+			     (null initfn))
+		   (bail-out)))
+		((member position used-positions))
+		((or (constantp form)
+		     (eq form *slotd-unsupplied*)))
+		(t
+		 (push (list initfn position) initfns-and-positions)))))
+
+      (values constants
+	      (nreverse initfns-and-positions)
+	      (nreverse supplied-initarg-positions)))))
+
+
+;;;
+;;; The SIMPLE-SLOTS case allows:
+;;;   constant or unsupplied initforms
+;;;   constant default initargs
+;;;   supplied initargs
+;;;   slot filling initargs
+;;;
+
+(define-constructor-code-type simple-slots
+        (class name arglist supplied-initarg-names supplied-initargs)
+  (declare (ignore name))
+  (let ((raw-allocator (raw-instance-allocator class))
+	(slots-fetcher (slots-fetcher class))
+	(wrapper-fetcher (wrapper-fetcher class)))
+    `(function
+       (lambda (class .wrapper. defaults init shared)
+	 (when (and (null (non-clos-initialize-instance-methods-p init))
+		    (null (non-clos-shared-initialize-methods-p shared)))
+	   (multiple-value-bind (.constants. .supplied-initarg-positions.)
+	       (simple-slots-generator-internal class
+						defaults
+						',supplied-initarg-names
+						',supplied-initargs)
+	     (when .constants.
+	       (function
+		 (lambda ,arglist
+		   (declare (optimize (speed 3) (safety 0)))
+		   (let ((.instance. (,raw-allocator))
+			 (.slots. (copy-constant-vector .constants.))
+			 (.positions. .supplied-initarg-positions.))
+		     
+		     .positions.
+		     (setf (,slots-fetcher .instance.) .slots.)	     
+		     (setf (,wrapper-fetcher .instance.) .wrapper.)
+		 
+		     ,@(gathering1 (collecting)
+			 (doplist (initarg value) supplied-initargs
+			   (unless (constantp value)
+			     (gather1
+			       `(let ((.value. ,value))
+				  (dolist (.p. (pop .positions.))
+				    (setf (%svref .slots. .p.) .value.)))))))
+		     
+		     .instance.))))))))))
+
+(defun simple-slots-generator-internal
+       (class defaults supplied-initarg-names supplied-initargs)
+  (flet ((bail-out () (return-from simple-slots-generator-internal nil)))
+    (let* ((constants (compute-constant-vector class))
+	   (layout (wrapper-instance-slots-layout (class-wrapper class)))
+	   (initarg-positions
+	     (compute-initarg-positions class
+					(append supplied-initarg-names
+						(mapcar #'car defaults))))
+	   (supplied-initarg-positions ())
+	   (used-positions ()))
+      ;;
+      ;; Go through each of the supplied initargs for three reasons.
+      ;;
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If its a constant form, fill the constant vector.
+      ;;   - Otherwise remember the positions, no two initargs
+      ;;     will try to fill the same position, since compute
+      ;;     initarg positions already took care of that, but
+      ;;     we do need to know what initforms will and won't
+      ;;     be needed.
+      ;;   
+      (doplist (initarg val) supplied-initargs
+	(let ((positions (cdr (assq initarg initarg-positions))))
+	  (cond ((memq :class positions) (bail-out))
+		((constantp val)
+		 (setq val (eval val))
+		 (dolist (pos positions)
+		   (setf (svref constants pos) val)))
+		(t
+		 (push positions supplied-initarg-positions)))
+	  (setq used-positions (append used-positions positions))))
+      ;;
+      ;; Go through each of the default initargs for three reasons.
+      ;; 
+      ;;   - If it isn't a constant form, bail out.
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If it is a constant, and it does fill a slot, put that
+      ;;     into the constant vector.
+      ;;   
+      (dolist (default defaults)
+	(let* ((name (car default))
+	       (form (caddr default))
+	       (value ())
+	       (positions (cdr (assq name initarg-positions))))
+	  (unless (memq name supplied-initarg-names)
+	    (cond ((memq :class positions) (bail-out))
+		  ((not (constantp form))
+		   (bail-out))
+		  (t
+		   (setq value (eval form))
+		   (dolist (pos positions)
+		     (setf (svref constants pos) value)))))))
+      ;;
+      ;; Go through each of the slot initforms:
+      ;;
+      ;;    - If its position has already been filled, do nothing.
+      ;;      The initfn won't need to be called, and the slot won't
+      ;;      need to be touched, we are OK.
+      ;;    - If it has a non-constant initform, bail-out.  This
+      ;;      case doesn't handle those.
+      ;;    - If it has a constant or unsupplied initform we don't
+      ;;      really need to do anything, the value is in the
+      ;;      constants vector.
+      ;;
+      (dolist (slotd (class-slots class))
+	(let* ((alloc (slotd-allocation slotd))
+	       (name (slotd-name slotd))
+	       (form (slotd-initform slotd))
+	       (initfn (slotd-initfunction slotd))
+	       (position (position name layout)))
+	  (cond ((neq alloc :instance)
+		 (unless (or (eq form *slotd-unsupplied*)
+			     (null initfn))
+		   (bail-out)))
+		((member position used-positions))
+		((or (constantp form)
+		     (eq form *slotd-unsupplied*)))
+		(t
+		 (bail-out)))))
+      
+      (values constants (nreverse supplied-initarg-positions)))))
diff --git a/clos/2.0/cpl.lisp b/clos/2.0/cpl.lisp
new file mode 100644
index 00000000..9eda3018
--- /dev/null
+++ b/clos/2.0/cpl.lisp
@@ -0,0 +1,271 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+;;;. Copyright (c) 1991 by Venue
+
+
+(in-package "CLOS")
+
+
+;;; compute-class-precedence-list Knuth section 2.2.3 has some interesting notes on this. What
+;;; appears here is basically the algorithm presented there. The key idea is that we use
+;;; class-precedence-description (CPD) structures to store the precedence information as we proceed.
+;;; The CPD structure for a class stores two critical pieces of information: - a count of the number
+;;; of "reasons" why the class can't go into the class precedence list yet. - a list of the
+;;; "reasons" this class prevents others from going in until after it 
+
+
+
+;; 
+
+
+
+;;; A "reason" is essentially a single local precedence constraint.  If a constraint between two
+;;; classes arises more than once it generates more than one reason.  This makes things simpler,
+;;; linear, and isn't a problem as long as we make sure to keep track of each instance of a
+;;; "reason". This code is divided into three phases. - the first phase simply generates the CPD's
+;;; for each of the class and its superclasses.  The remainder of the code will manipulate these
+;;; CPDs rather than the class objects themselves.  At the end of this pass, the CPD-SUPERS field of
+;;; a CPD is a list of the CPDs of the direct superclasses of the class. - the second phase folds
+;;; all the local constraints into the CPD structure.  The CPD-COUNT of each CPD is built up, and
+;;; the CPD-AFTER fields are augmented to include precedence constraints from the CPD-SUPERS field
+;;; and from the order of classes in other CPD-SUPERS fields. After this phase, the CPD-AFTER field
+;;; of a class includes all the direct superclasses of the class plus any class that immediately
+;;; follows the class in the direct superclasses of another.  There can be duplicates in this list. 
+;;; The CPD-COUNT field is equal to the number of times this class appears in the CPD-AFTER field of
+;;; all the other CPDs. - In the third phase, classes are put into the precedence list one at a
+;;; time, with only those classes with a CPD-COUNT of 0 being candidates for insertion.  When a
+;;; class is inserted , every CPD in its CPD-AFTER field has its count decremented. In the usual
+;;; case, there is only one candidate for insertion at any point.  If there is more than one, the
+;;; specified tiebreaker rule is used to choose among them. 
+
+
+(defmethod compute-class-precedence-list ((root std-class)
+                                          direct-superclasses)
+       (compute-std-cpl root direct-superclasses))
+
+(defstruct (class-precedence-description (:conc-name nil)
+                  (:print-function (lambda (obj str depth)
+                                          (declare (ignore depth))
+                                          (format str "#<CPD ~S ~D>" (class-name (cpd-class obj))
+                                                 (cpd-count obj))))
+                  (:constructor make-cpd nil))
+       (cpd-class nil)
+       (cpd-supers nil)
+       (cpd-after nil)
+       (cpd-count 0))
+
+(defun compute-std-cpl (class supers)
+       (cond ((null supers)
+                                                             ; First two branches of COND
+              (list class))
+                                                             ; are implementing the single
+             ((null (cdr supers))
+                                                             ; inheritance optimization.
+              (cons class (compute-std-cpl (car supers)
+                                 (class-direct-superclasses (car supers)))))
+             (t (multiple-value-bind (all-cpds nclasses)
+                    (compute-std-cpl-phase-1 class supers)
+                  (compute-std-cpl-phase-2 all-cpds)
+                  (compute-std-cpl-phase-3 class all-cpds nclasses)))))
+
+(defvar *compute-std-cpl-class->entry-table-size* 60)
+
+(defun compute-std-cpl-phase-1 (class supers)
+       (let ((nclasses 0)
+             (all-cpds nil)
+             (table (make-hash-table :size *compute-std-cpl-class->entry-table-size* :test
+                           #'eq)))
+            (labels ((get-cpd (c)
+                            (or (gethash c table)
+                                (setf (gethash c table)
+                                      (make-cpd))))
+                     (walk (c supers)
+                           (if (forward-referenced-class-p c)
+                               (cpl-forward-referenced-class-error class c)
+                               (let ((cpd (get-cpd c)))
+                                    (unless (cpd-class cpd)
+                                                             ; If we have already done this class
+                                                             ; before, we can quit. 
+                                        (setf (cpd-class cpd)
+                                              c)
+                                        (incf nclasses)
+                                        (push cpd all-cpds)
+                                        (setf (cpd-supers cpd)
+                                              (mapcar #'get-cpd supers))
+                                        (dolist (super supers)
+                                            (walk super (class-direct-superclasses super))))))))
+                   (walk class supers)
+                   (values all-cpds nclasses))))
+
+(defun compute-std-cpl-phase-2 (all-cpds)
+       (dolist (cpd all-cpds)
+           (let ((supers (cpd-supers cpd)))
+                (when supers
+                    (setf (cpd-after cpd)
+                          (nconc (cpd-after cpd)
+                                 supers))
+                    (incf (cpd-count (car supers))
+                          1)
+                    (do* ((t1 supers t2)
+                          (t2 (cdr t1)
+                              (cdr t1)))
+                         ((null t2))
+                       (incf (cpd-count (car t2))
+                             2)
+                       (push (car t2)
+                             (cpd-after (car t1))))))))
+
+(defun
+ compute-std-cpl-phase-3
+ (class all-cpds nclasses)
+ (let ((candidates nil)
+       (next-cpd nil)
+       (rcpl nil))
+      
+      ;; We have to bootstrap the collection of those CPD's that have a zero count.  Once we get
+      ;; going, we will maintain this list incrementally. 
+      (dolist (cpd all-cpds)
+          (when (zerop (cpd-count cpd))
+                (push cpd candidates)))
+      (loop (when (null candidates)
+                
+                ;; If there are no candidates, and enough classes have been put into the precedence
+                ;; list, then we are all done.  Otherwise it means there is a consistency problem. 
+                (if (zerop nclasses)
+                    (return (reverse rcpl))
+                    (cpl-inconsistent-error class all-cpds)))
+            
+            ;; Try to find the next class to put in from among the candidates. If there is only one,
+            ;; its easy, otherwise we have to use the famous RPG tiebreaker rule.  There is some
+            ;; hair here to avoid having to call DELETE on the list of candidates.  I dunno if its
+            ;; worth it but what the hell. 
+            (setq next-cpd
+                  (if (null (cdr candidates))
+                      (prog1 (car candidates)
+                             (setq candidates nil))
+                      (block tie-breaker
+                          (dolist (c rcpl)
+                              (let ((supers (class-direct-superclasses c)))
+                                   (if (memq (cpd-class (car candidates))
+                                             supers)
+                                       (return-from tie-breaker (pop candidates))
+                                       (do ((loc candidates (cdr loc)))
+                                           ((null (cdr loc)))
+                                         (let ((cpd (cadr loc)))
+                                              (when (memq (cpd-class cpd)
+                                                          supers)
+                                                  (setf (cdr loc)
+                                                        (cddr loc))
+                                                  (return-from tie-breaker cpd))))))))))
+            (decf nclasses)
+            (push (cpd-class next-cpd)
+                  rcpl)
+            (dolist (after (cpd-after next-cpd))
+                (when (zerop (decf (cpd-count after)))
+                      (push after candidates))))))
+
+
+;;; Support code for signalling nice error messages. 
+
+
+(defun cpl-error (class format-string &rest format-args)
+       (error "While computing the class precedence list of the class ~A.~%~A"
+              (if (class-name class)
+                  (format nil "named ~S" (class-name class))
+                  class)
+              (apply #'format nil format-string format-args)))
+
+(defun cpl-forward-referenced-class-error (class forward-class)
+       (flet ((class-or-name (class)
+                     (if (class-name class)
+                         (format nil "named ~S" (class-name class))
+                         class)))
+             (let ((names (mapcar #'class-or-name (cdr (find-superclass-chain class forward-class))))
+                   )
+                  (cpl-error class 
+                "The class ~A is a forward referenced class.~@
+                  The class ~A is ~A." (class-or-name forward-class)
+                         (class-or-name forward-class)
+                         (if (null (cdr names))
+                             (format nil "a direct superclass of the class ~A" (class-or-name class))
+                             (format nil "reached from the class ~A by following~@
+                              the direct superclass chain through: ~A~
+                              ~%  ending at the class ~A" (class-or-name class)
+                                    (format nil "~{~%  the class ~A,~}" (butlast names))
+                                    (car (last names))))))))
+
+(defun find-superclass-chain (bottom top)
+       (labels ((walk (c chain)
+                      (if (eq c top)
+                          (return-from find-superclass-chain (nreverse chain))
+                          (dolist (super (class-direct-superclasses c))
+                              (walk super (cons super chain))))))
+              (walk bottom (list bottom))))
+
+(defun cpl-inconsistent-error (class all-cpds)
+       (let ((reasons (find-cycle-reasons all-cpds)))
+            (cpl-error class "It is not possible to compute the class precedence list because~@
+       there ~A in the local precedence relations.~@
+       ~A because:~{~%  ~A~}." (if (cdr reasons)
+                                   "are circularities"
+                                   "is a circularity")
+                   (if (cdr reasons)
+                       "These arise"
+                       "This arises")
+                   (format-cycle-reasons (apply #'append reasons)))))
+
+(defun format-cycle-reasons (reasons)
+       (flet ((class-or-name (cpd)
+                     (let ((class (cpd-class cpd)))
+                          (if (class-name class)
+                              (format nil "named ~S" (class-name class))
+                              class))))
+             (mapcar #'(lambda (reason)
+                              (ecase (caddr reason)
+                                  (:super (format nil 
+                                                 "the class ~A appears in the supers of the class ~A"
+                                                 (class-or-name (cadr reason))
+                                                 (class-or-name (car reason))))
+                                  (:in-supers (format nil 
+                                    "the class ~A follows the class ~A in the supers of the class ~A"
+                                                     (class-or-name (cadr reason))
+                                                     (class-or-name (car reason))
+                                                     (class-or-name (cadddr reason))))))
+                    reasons)))
+
+(defun find-cycle-reasons (all-cpds)
+       (let ((been-here nil)
+                                                             ; List of classes we have visited.
+             (cycle-reasons nil))
+            (labels ((chase (path)
+                            (if (memq (car path)
+                                      (cdr path))
+                                (record-cycle (memq (car path)
+                                                    (nreverse path)))
+                                (unless (memq (car path)
+                                              been-here)
+                                    (push (car path)
+                                          been-here)
+                                    (dolist (after (cpd-after (car path)))
+                                        (chase (cons after path))))))
+                     (record-cycle
+                      (cycle)
+                      (let ((reasons nil))
+                           (do* ((t1 cycle t2)
+                                 (t2 (cdr t1)
+                                     (cdr t1)))
+                                ((null t2))
+                              (let ((c1 (car t1))
+                                    (c2 (car t2)))
+                                   (if (memq c2 (cpd-supers c1))
+                                       (push (list c1 c2 :super)
+                                             reasons)
+                                       (dolist (cpd all-cpds)
+                                           (when (memq c2 (memq c1 (cpd-supers cpd)))
+                                               (return (push (list c1 c2 :in-supers cpd)
+                                                             reasons)))))))
+                           (push (nreverse reasons)
+                                 cycle-reasons))))
+                   (dolist (cpd all-cpds)
+                       (unless (zerop (cpd-count cpd))
+                           (chase (list cpd))))
+                   cycle-reasons)))
diff --git a/clos/2.0/ctypes.lisp b/clos/2.0/ctypes.lisp
new file mode 100644
index 00000000..1de6d3a4
--- /dev/null
+++ b/clos/2.0/ctypes.lisp
@@ -0,0 +1,25 @@
+;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+;;;
+;;; The built-in method combination types as taken from page 1-31 of 88-002R.
+;;; Note that the STANDARD method combination type is defined by hand in the
+;;; file combin.lisp.
+;;;
+
+(define-method-combination +      :identity-with-one-argument t)
+(define-method-combination and    :identity-with-one-argument t)
+(define-method-combination append :identity-with-one-argument nil)
+(define-method-combination list   :identity-with-one-argument nil)
+(define-method-combination max    :identity-with-one-argument t)
+(define-method-combination min    :identity-with-one-argument t)
+(define-method-combination nconc  :identity-with-one-argument t)
+(define-method-combination or     :identity-with-one-argument t)
+(define-method-combination progn  :identity-with-one-argument t)
diff --git a/clos/2.0/defclass.lisp b/clos/2.0/defclass.lisp
new file mode 100644
index 00000000..4aaf9791
--- /dev/null
+++ b/clos/2.0/defclass.lisp
@@ -0,0 +1,230 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;;. Copyright (c) 1991 by Venue
+(in-package "CLOS")
+
+;;; ************************************************************************* 
+
+
+
+;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'. The original
+;;; motiviation for this function was to deal with the bug in the Genera compiler that prevents
+;;; lambda expressions in top-level forms other than DEFUN from being compiled. Now this function is
+;;; used to grab other functionality as well.  This includes: - Preventing the grouping of top-level
+;;; forms.  For example, a DEFCLASS followed by a DEFMETHOD may not want to be grouped into the same
+;;; top-level form. - Telling the programming environment what the pretty version of the name of
+;;; this form is.  This is used by WARN. 
+
+
+(defun make-top-level-form (name times form)
+       (flet ((definition-name nil (if (and (listp name)
+                                            (memq (car name)
+                                                  '(defmethod defclass class method 
+                                                          method-combination)))
+                                       (format nil "~A~{ ~S~}" (capitalize-words (car name)
+                                                                      nil)
+                                              (cdr name))
+                                       (format nil "~S" name))))
+             (definition-name)
+             (make-progn `',name `(eval-when ,times ,form))))
+
+(defun make-progn (&rest forms)
+       (let ((progn-form nil))
+            (labels ((collect-forms (forms)
+                            (unless (null forms)
+                                (collect-forms (cdr forms))
+                                (if (and (listp (car forms))
+                                         (eq (caar forms)
+                                             'progn))
+                                    (collect-forms (cdar forms))
+                                    (push (car forms)
+                                          progn-form)))))
+                   (collect-forms forms)
+                   (cons 'progn progn-form))))
+
+
+;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed. DEFCLASS always expands
+;;; into a call to LOAD-DEFCLASS.  Until the meta- braid is set up, LOAD-DEFCLASS has a special
+;;; definition which simply collects all class definitions up, when the metabraid is initialized it
+;;; is done from those class definitions. After the metabraid has been setup, and the protocol for
+;;; defining classes has been defined, the real definition of LOAD-DEFCLASS is installed by the file
+;;; defclass.lisp 
+
+
+(defmacro defclass (name direct-superclasses direct-slots &rest options)
+       (declare (indentation 2 4 3 1))
+       (expand-defclass name direct-superclasses direct-slots options))
+
+(defun expand-defclass (name supers slots options)
+       (setq supers (copy-tree supers)
+             slots
+             (copy-tree slots)
+             options
+             (copy-tree options))
+       (let ((metaclass 'standard-class))
+            (dolist (option options)
+                (if (not (listp option))
+                    (error "~S is not a legal defclass option." option)
+                    (when (eq (car option)
+                              ':metaclass)
+                        (unless (legal-class-name-p (cadr option))
+                            (error 
+        "The value of the :metaclass option (~S) is not a~%~
+                      legal class name." (cadr option)))
+                        (setq metaclass (cadr option))
+                        (setf options (remove option options))
+                        (return t))))
+            (let ((*initfunctions* nil)
+                  (*accessors* nil))
+                                                             ; Truly a crock, but we got to have it
+                                                             ; to live nicely. 
+                 (declare (special *initfunctions* *accessors*))
+                 (let ((canonical-slots (mapcar #'(lambda (spec)
+                                                         (canonicalize-slot-specification name spec))
+                                               slots))
+                       (other-initargs (mapcar #'(lambda (option)
+                                                        (canonicalize-defclass-option name option))
+                                              options)))
+                      (do-standard-defsetfs-for-defclass *accessors*)
+;		      (load-defclass name metaclass supers
+;				     canonical-slots (apply #'append
+;							    other-initargs) *accessors*)))))
+                      (make-top-level-form `(defclass ,name nil nil)
+                             *defclass-times*
+                             `(let ,(mapcar #'cdr *initfunctions*)
+                                   (load-defclass ',name ',metaclass ',supers (list 
+                                                                                    ,@canonical-slots
+                                                                                    )
+                                          (list ,@(apply #'append other-initargs))
+                                          ',*accessors*)))))))
+
+(defun make-initfunction (initform)
+       (declare (special *initfunctions*))
+       (cond ((or (eq initform 't)
+                  (equal initform ''t))
+              '#'true)
+             ((or (eq initform 'nil)
+                  (equal initform ''nil))
+              '#'false)
+             ((or (eql initform '0)
+                  (equal initform ''0))
+              '#'zero)
+             (t (let ((entry (assoc initform *initfunctions* :test #'equal)))
+                     (unless entry
+                         (setq entry (list initform (gensym)
+                                           `#'(lambda nil ,initform)))
+                         (push entry *initfunctions*))
+                     (cadr entry)))))
+
+(defun canonicalize-slot-specification (class-name spec)
+       (declare (special *accessors*))
+       (cond ((and (symbolp spec)
+                   (not (keywordp spec))
+                   (not (memq spec '(t nil))))
+              `'(:name ,spec))
+             ((not (consp spec))
+              (error "~S is not a legal slot specification." spec))
+             ((null (cdr spec))
+              `'(:name ,(car spec)))
+             ((null (cddr spec))
+              (error 
+        "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~
+                 Convert it to ~S" class-name spec (list (car spec)
+                                                         :initform
+                                                         (cadr spec))))
+             (t (let* ((name (pop spec))
+                       (readers nil)
+                       (writers nil)
+                       (initargs nil)
+                       (unsupplied (list nil))
+                       (initform (getf spec :initform unsupplied)))
+                      (doplist (key val)
+                             spec
+                             (case key
+                                 (:accessor 
+                                    (push val *accessors*)
+                                    (push val readers)
+                                    (push `(setf ,val)
+                                          writers))
+                                 (:reader (push val readers))
+                                 (:writer (push val writers))
+                                 (:initarg (push val initargs))))
+                      (loop (unless (remf spec :accessor)
+                                   (return)))
+                      (loop (unless (remf spec :reader)
+                                   (return)))
+                      (loop (unless (remf spec :writer)
+                                   (return)))
+                      (loop (unless (remf spec :initarg)
+                                   (return)))
+                      (setq spec `(:name ',name :readers ',readers
+				   :writers ',writers :initargs
+                                         ',initargs
+                                         ',spec))
+                      (if (eq initform unsupplied)
+                          `(list* ,@spec)
+                          `(list* :initfunction ,(make-initfunction initform)
+                                  ,@spec))))))
+
+(defun canonicalize-defclass-option (class-name option)
+       (declare (ignore class-name))
+       (case (car option)
+           (:default-initargs (let ((canonical nil))
+                                   (let (key val (tail (cdr option)))
+                                        (loop (when (null tail)
+                                                    (return nil))
+                                              (setq key (pop tail)
+                                                    val
+                                                    (pop tail))
+                                              (push ``(,',key ,,(make-initfunction val)
+                                                             ,',val)
+                                                    canonical))
+                                        `(':direct-default-initargs (list ,@(nreverse canonical))))))
+           (otherwise `(',(car option)
+                        ',(cdr option)))))
+
+
+;;; This is the early definition of load-defclass.  It just collects up all the class definitions in
+;;; a list.  Later, in the file braid1.lisp, these are actually defined. Each entry in
+;;; *early-class-definitions* is an early-class-definition. 
+
+
+(defparameter *early-class-definitions* nil)
+
+(defun make-early-class-definition (name source metaclass superclass-names canonical-slots 
+                                         other-initargs)
+       (list 'early-class-definition name source metaclass superclass-names canonical-slots 
+             other-initargs))
+
+(defun ecd-class-name (ecd)
+       (nth 1 ecd))
+
+(defun ecd-source (ecd)
+       (nth 2 ecd))
+
+(defun ecd-metaclass (ecd)
+       (nth 3 ecd))
+
+(defun ecd-superclass-names (ecd)
+       (nth 4 ecd))
+
+(defun ecd-canonical-slots (ecd)
+       (nth 5 ecd))
+
+(defun ecd-other-initargs (ecd)
+       (nth 6 ecd))
+
+(proclaim '(notinline load-defclass))
+
+(defun load-defclass (name metaclass supers canonical-slots canonical-options accessor-names)
+       (setq supers (copy-tree supers)
+             canonical-slots
+             (copy-tree canonical-slots)
+             canonical-options
+             (copy-tree canonical-options))
+       (do-standard-defsetfs-for-defclass accessor-names)
+       (let ((ecd (make-early-class-definition name (load-truename)
+                         metaclass supers canonical-slots (apply #'append canonical-options)))
+             (existing (find name *early-class-definitions* :key #'ecd-class-name)))
+            (setq *early-class-definitions* (cons ecd (remove existing *early-class-definitions*)))
+            ecd))
diff --git a/clos/2.0/defcombin.lisp b/clos/2.0/defcombin.lisp
new file mode 100644
index 00000000..5bb69ebd
--- /dev/null
+++ b/clos/2.0/defcombin.lisp
@@ -0,0 +1,410 @@
+;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+;;;
+;;; DEFINE-METHOD-COMBINATION
+;;;
+
+(defmacro define-method-combination (&whole form &rest args)
+  (declare (ignore args))
+  (if (and (cddr form)
+	   (listp (caddr form)))
+      (expand-long-defcombin form)
+      (expand-short-defcombin form)))
+
+
+;;;
+;;; STANDARD method combination
+;;;
+;;; The STANDARD method combination type is implemented directly by the class
+;;; STANDARD-METHOD-COMBINATION.  The method on COMPUTE-EFFECTIVE-METHOD does
+;;; standard method combination directly and is defined by hand in the file
+;;; combin.lisp.  The method for FIND-METHOD-COMBINATION must appear in this
+;;; file for bootstrapping reasons.
+;;;
+;;; A commented out copy of this definition appears in combin.lisp.
+;;; If you change this definition here, be sure to change it there
+;;; also.
+;;;
+(defmethod find-method-combination ((generic-function generic-function)
+				    (type (eql 'standard))
+				    options)
+  (when options
+    (method-combination-error
+      "The method combination type STANDARD accepts no options."))
+  *standard-method-combination*)
+
+
+
+;;;
+;;; short method combinations
+;;;
+;;; Short method combinations all follow the same rule for computing the
+;;; effective method.  So, we just implement that rule once.  Each short
+;;; method combination object just reads the parameters out of the object
+;;; and runs the same rule.
+;;;
+;;;
+(defclass short-method-combination (standard-method-combination)
+     ((operator
+	:reader short-combination-operator
+	:initarg :operator)
+      (identity-with-one-argument
+	:reader short-combination-identity-with-one-argument
+	:initarg :identity-with-one-argument)))
+
+(define-gf-predicate short-method-combination-p short-method-combination)
+
+(defun expand-short-defcombin (whole)
+  (let* ((type (cadr whole))
+	 (documentation
+	   (getf (cddr whole) :documentation ""))
+	 (identity-with-one-arg
+	   (getf (cddr whole) :identity-with-one-argument nil))
+	 (operator 
+	   (getf (cddr whole) :operator type)))
+    (make-top-level-form `(define-method-combination ,type)
+			 '(load eval)
+      `(load-short-defcombin
+	 ',type ',operator ',identity-with-one-arg ',documentation))))
+
+(defun load-short-defcombin (type operator ioa doc)
+  (let* ((truename (load-truename))
+	 (specializers
+	   (list (find-class 'generic-function)
+		 (make-instance 'eql-specializer :object type)
+		 *the-class-t*))
+	 (old-method
+	   (get-method #'find-method-combination () specializers nil))
+	 (new-method nil))
+    (setq new-method
+	  (make-instance 'standard-method
+	    :qualifiers ()
+	    :specializers specializers
+	    :lambda-list '(generic-function type options)
+	    :function #'(lambda (gf type options)
+			  (declare (ignore gf))
+			  (do-short-method-combination
+			    type options operator ioa new-method doc))
+	    :definition-source `((define-method-combination ,type) ,truename)))
+    (when old-method
+      (remove-method #'find-method-combination old-method))
+    (add-method #'find-method-combination new-method)))
+
+(defun do-short-method-combination (type options operator ioa method doc)
+  (cond ((null options) (setq options '(:most-specific-first)))
+	((equal options '(:most-specific-first)))
+	((equal options '(:most-specific-last)))
+	(t
+	 (method-combination-error
+	   "Illegal options to a short method combination type.~%~
+            The method combination type ~S accepts one option which~%~
+            must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
+	   type)))
+  (make-instance 'short-method-combination
+		 :type type
+		 :options options
+		 :operator operator
+		 :identity-with-one-argument ioa
+		 :definition-source method
+		 :documentation doc))
+
+(defmethod compute-effective-method ((generic-function generic-function)
+				     (combin short-method-combination)
+				     applicable-methods)
+  (let ((type (method-combination-type combin))
+	(operator (short-combination-operator combin))
+	(ioa (short-combination-identity-with-one-argument combin))
+	(around ())
+	(primary ()))
+    (dolist (m applicable-methods)
+      (let ((qualifiers (method-qualifiers m)))
+	(flet ((lose (method why)
+		 (invalid-method-error
+		   method
+		   "The method ~S ~A.~%~
+                    The method combination type ~S was defined with the~%~
+                    short form of DEFINE-METHOD-COMBINATION and so requires~%~
+                    all methods have either the single qualifier ~S or the~%~
+                    single qualifier :AROUND."
+		   method why type type)))
+	  (cond ((null qualifiers)
+		 (lose m "has no qualifiers"))
+		((cdr qualifiers)
+		 (lose m "has more than one qualifier"))
+		((eq (car qualifiers) :around)
+		 (push m around))
+		((eq (car qualifiers) type)
+		 (push m primary))
+		(t
+		 (lose m "has an illegal qualifier"))))))
+    (setq around (nreverse around)
+	  primary (nreverse primary))
+    (let ((main-method
+	    (if (and (null (cdr primary))
+		     (not (null ioa)))
+		`(call-method ,(car primary) ())
+		`(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ()))
+				      primary)))))
+      (cond ((null primary)
+	     `(error "No ~S methods for the generic function ~S."
+		     ',type ',generic-function))
+	    ((null around) main-method)
+	    (t
+	     `(call-method ,(car around)
+			   (,@(cdr around) (make-method ,main-method))))))))
+
+
+;;;
+;;; long method combinations
+;;;
+;;;
+
+(defclass long-method-combination (standard-method-combination)
+     ((function :initarg :function
+		:reader long-method-combination-function)))
+
+(defun expand-long-defcombin (form)
+  (let ((type (cadr form))
+	(lambda-list (caddr form))
+	(method-group-specifiers (cadddr form))
+	(body (cddddr form))
+	(arguments-option ())
+	(gf-var nil))
+    (when (and (consp (car body)) (eq (caar body) :arguments))
+      (setq arguments-option (cdr (pop body))))
+    (when (and (consp (car body)) (eq (caar body) :generic-function))
+      (setq gf-var (cadr (pop body))))
+    (multiple-value-bind (documentation function)
+	(make-long-method-combination-function
+	  type lambda-list method-group-specifiers arguments-option gf-var
+	  body)
+      (make-top-level-form `(define-method-combination ,type)
+			   '(load eval)
+	`(load-long-defcombin ',type ',documentation #',function)))))
+
+(defvar *long-method-combination-functions* (make-hash-table :test #'eq))
+
+(defun load-long-defcombin (type doc function)
+  (let* ((specializers
+	   (list (find-class 'generic-function)
+		 (make-instance 'eql-specializer :object type)
+		 *the-class-t*))
+	 (old-method
+	   (get-method #'find-method-combination () specializers nil))
+	 (new-method
+	   (make-instance 'standard-method
+	     :qualifiers ()
+	     :specializers specializers
+	     :lambda-list '(generic-function type options)
+	     :function #'(lambda (generic-function type options)
+			   (declare (ignore generic-function))
+			   (make-instance 'long-method-combination
+			     :type type
+			     :documentation doc
+			     :options options))
+	     :definition-source `((define-method-combination ,type)
+				  ,(load-truename)))))
+    (setf (gethash type *long-method-combination-functions*) function)
+    (when old-method (remove-method #'find-method-combination old-method))
+    (add-method #'find-method-combination new-method)))
+
+(defmethod compute-effective-method ((generic-function generic-function)
+				     (combin long-method-combination)
+				     applicable-methods)
+  (funcall (gethash (method-combination-type combin)
+		    *long-method-combination-functions*)
+	   generic-function
+	   combin
+	   applicable-methods))
+
+;;;
+;;;
+;;;
+(defun make-long-method-combination-function
+       (type ll method-group-specifiers arguments-option gf-var body)
+  (declare (ignore type) (values documentation function))
+  (multiple-value-bind (documentation declarations real-body)
+      (extract-declarations body)
+
+    (let ((wrapped-body
+	    (wrap-method-group-specifier-bindings method-group-specifiers
+						  declarations
+						  real-body)))
+      (when gf-var
+	(push `(,gf-var .generic-function.) (cadr wrapped-body)))
+      
+      (when arguments-option
+	(setq wrapped-body (deal-with-arguments-option wrapped-body
+						       arguments-option)))
+
+      (when ll
+	(setq wrapped-body
+	      `(apply #'(lambda ,ll ,wrapped-body)
+		      (method-combination-options .method-combination.))))
+
+      (values
+	documentation
+	`(lambda (.generic-function. .method-combination. .applicable-methods.)
+	   (progn .generic-function. .method-combination. .applicable-methods.)
+	   (block .long-method-combination-function. ,wrapped-body))))))
+;;
+;; parse-method-group-specifiers parse the method-group-specifiers
+;;
+
+(defun wrap-method-group-specifier-bindings
+       (method-group-specifiers declarations real-body)
+  (with-gathering ((names (collecting))
+		   (specializer-caches (collecting))
+		   (cond-clauses (collecting))
+		   (required-checks (collecting))
+		   (order-cleanups (collecting)))
+      (dolist (method-group-specifier method-group-specifiers)
+	(multiple-value-bind (name tests description order required)
+	    (parse-method-group-specifier method-group-specifier)
+	  (declare (ignore description))
+	  (let ((specializer-cache (gensym)))
+	    (gather name names)
+	    (gather specializer-cache specializer-caches)
+	    (gather `((or ,@tests)
+		      (if  (equal ,specializer-cache .specializers.)
+			   (return-from .long-method-combination-function.
+			     '(error "More than one method of type ~S ~
+                                      with the same specializers."
+				     ',name))
+			   (setq ,specializer-cache .specializers.))
+		      (push .method. ,name))
+		    cond-clauses)
+	    (when required
+	      (gather `(when (null ,name)
+			 (return-from .long-method-combination-function.
+			   '(error "No ~S methods." ',name)))
+		      required-checks))
+	    (loop (unless (and (constantp order)
+			       (neq order (setq order (eval order))))
+		    (return t)))
+	    (gather (cond ((eq order :most-specific-first)
+			   `(setq ,name (nreverse ,name)))
+			  ((eq order :most-specific-last) ())
+			  (t
+			   `(ecase ,order
+			      (:most-specific-first
+				(setq ,name (nreverse ,name)))
+			      (:most-specific-last))))
+		    order-cleanups))))
+   `(let (,@names ,@specializer-caches)
+      ,@declarations
+      (dolist (.method. .applicable-methods.)
+	(let ((.qualifiers. (method-qualifiers .method.))
+	      (.specializers. (method-specializers .method.)))
+	  (progn .qualifiers. .specializers.)
+	  (cond ,@cond-clauses)))
+      ,@required-checks
+      ,@order-cleanups
+      ,@real-body)))
+   
+(defun parse-method-group-specifier (method-group-specifier)
+  (declare (values name tests description order required))
+  (let* ((name (pop method-group-specifier))
+	 (patterns ())
+	 (tests 
+	   (gathering1 (collecting)
+	     (block collect-tests
+	       (loop
+		 (if (or (null method-group-specifier)
+			 (memq (car method-group-specifier)
+			       '(:description :order :required)))
+		     (return-from collect-tests t)
+		     (let ((pattern (pop method-group-specifier)))
+		       (push pattern patterns)
+		       (gather1 (parse-qualifier-pattern name pattern)))))))))
+    (values name
+	    tests
+	    (getf method-group-specifier :description
+		  (make-default-method-group-description patterns))
+	    (getf method-group-specifier :order :most-specific-first)
+	    (getf method-group-specifier :required nil))))
+
+(defun parse-qualifier-pattern (name pattern)
+  (cond ((eq pattern '()) `(null .qualifiers.))
+	((eq pattern '*) 't)
+	((symbolp pattern) `(,pattern .qualifiers.))
+	((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.))
+	(t (error "In the method group specifier ~S,~%~
+                   ~S isn't a valid qualifier pattern."
+		  name pattern))))
+
+(defun qualifier-check-runtime (pattern qualifiers)
+  (loop (cond ((and (null pattern) (null qualifiers))
+	       (return t))
+	      ((eq pattern '*) (return t))
+	      ((and pattern qualifiers (eq (car pattern) (car qualifiers)))
+	       (pop pattern)
+	       (pop qualifiers))	      
+	      (t (return nil)))))
+
+(defun make-default-method-group-description (patterns)
+  (if (cdr patterns)
+      (format nil
+	      "methods matching one of the patterns: ~{~S, ~} ~S"
+	      (butlast patterns) (car (last patterns)))
+      (format nil
+	      "methods matching the pattern: ~S"
+	      (car patterns))))
+
+
+
+;;;
+;;; This baby is a complete mess.  I can't believe we put it in this
+;;; way.  No doubt this is a large part of what drives MLY crazy.
+;;;
+;;; At runtime (when the effective-method is run), we bind an intercept
+;;; lambda-list to the arguments to the generic function.
+;;; 
+;;; At compute-effective-method time, the symbols in the :arguments
+;;; option are bound to the symbols in the intercept lambda list.
+;;;
+(defun deal-with-arguments-option (wrapped-body arguments-option)
+  (let* ((intercept-lambda-list
+	   (gathering1 (collecting)
+	     (dolist (arg arguments-option)
+	       (if (memq arg lambda-list-keywords)
+		   (gather1 arg)
+		   (gather1 (gensym))))))
+	 (intercept-rebindings
+	   (gathering1 (collecting)
+	     (iterate ((arg (list-elements arguments-option))
+		       (int (list-elements intercept-lambda-list)))
+	       (unless (memq arg lambda-list-keywords)
+		 (gather1 `(,arg ',int)))))))
+    ;;
+    ;;
+    (setf (cadr wrapped-body)
+	  (append intercept-rebindings (cadr wrapped-body)))
+    ;;
+    ;; Be sure to fill out the intercept lambda list so that it can
+    ;; be too short if it wants to.
+    ;; 
+    (cond ((memq '&rest intercept-lambda-list))
+	  ((memq '&allow-other-keys intercept-lambda-list))
+	  ((memq '&key intercept-lambda-list)
+	   (setq intercept-lambda-list
+		 (append intercept-lambda-list '(&allow-other-keys))))
+	  (t
+	   (setq intercept-lambda-list
+		 (append intercept-lambda-list '(&rest .ignore.)))))
+
+    `(let ((inner-result. ,wrapped-body))
+       `(apply #'(lambda ,',intercept-lambda-list
+		   ,,(when (memq '.ignore. intercept-lambda-list)
+		       ''(declare (ignore .ignore.)))
+		   ,inner-result.)
+	       .combined-method-args.))))
+
diff --git a/clos/2.0/defs.lisp b/clos/2.0/defs.lisp
new file mode 100644
index 00000000..e0f2a047
--- /dev/null
+++ b/clos/2.0/defs.lisp
@@ -0,0 +1,570 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+;;;. Copyright (c) 1991 by Venue
+
+
+(in-package "CLOS")
+
+(eval-when (compile load eval)
+       (defvar *defclass-times* '(load eval compile))	;Probably have to change this
+						;if you use defconstructor.
+(defvar *defmethod-times*  '(load eval compile))
+(defvar *defgeneric-times* '(load eval compile))
+)
+
+
+;;; Convert a function name to its standard setf function name.  We have to do this hack because not
+;;; all Common Lisps have yet converted to having setf function specs. In a port that does have setf
+;;; function specs you can use those just by making the obvious simple changes to these functions. 
+;;; The rest of CLOS believes that there are function names like (SETF <foo>), this is the only place
+;;; that knows about this hack. 
+
+
+(eval-when (compile load eval)
+       (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq))
+(defun get-setf-function-name (name)
+  (or (gethash name *setf-function-names*)
+      (setf (gethash name *setf-function-names*)
+	    (intern (format nil
+			    "SETF ~A ~A"
+			    (package-name (symbol-package name))
+			    (symbol-name name))
+		    *the-clos-package*))))
+
+;;;
+;;; Call this to define a setf macro for a function with the same behavior as
+;;; specified by the SETF function cleanup proposal.  Specifically, this will
+;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
+;;;
+;;; do-standard-defsetf                  A macro interface for use at top level
+;;;                                      in files.  Unfortunately, users may
+;;;                                      have to use this for a while.
+;;;                                      
+;;; do-standard-defsetfs-for-defclass    A special version called by defclass.
+;;; 
+;;; do-standard-defsetf-1                A functional interface called by the
+;;;                                      above, defmethod and defgeneric.
+;;;                                      Since this is all a crock anyways,
+;;;                                      users are free to call this as well.
+;;;
+(defmacro do-standard-defsetf (&rest function-names)
+  `(eval-when (compile load eval)
+     (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))
+
+(defun do-standard-defsetfs-for-defclass (accessors)
+  (dolist (name accessors) (do-standard-defsetf-1 name)))
+
+(defun do-standard-defsetf-1 (function-name)
+  (unless (setfboundp function-name)
+    (let* ((setf-function-name (get-setf-function-name function-name)))
+    
+  (flet ((setf-expander (body env)
+	       (declare (ignore env))
+	       (let ((temps
+		       (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
+			       (cdr body)))
+		     (forms (cdr body))
+		     (vars (list (gensym))))
+		 (values temps
+			 forms
+			 vars
+			 `(,setf-function-name ,@vars ,@temps)
+			 `(,function-name ,@temps)))))
+	(let ((setf-method-expander (intern (concatenate 'string
+						         (symbol-name function-name)
+						         "-setf-expander")
+				     (symbol-package function-name))))
+	  (setf (get function-name :setf-method-expander) setf-method-expander
+		(symbol-function setf-method-expander) #'setf-expander)))
+
+     )))
+(defun setfboundp (symbol)
+(or (get symbol :setf-inverse)
+	       (get symbol 'il:setf-inverse)
+	       (get symbol 'il:setfn)
+	       (get symbol :shared-setf-inverse)
+	       (get symbol :setf-method-expander)
+	       (get symbol 'il:setf-method-expander)))
+)
+
+                                                             ; eval-when
+
+
+
+;;; CLOS, like user code, must endure the fact that we don't have a properly working setf.  Many
+;;; things work because they get mentioned by a defclass or defmethod before they are used, but
+;;; others have to be done by hand. 
+
+
+(do-standard-defsetf 
+	class-wrapper                           ; ***
+     generic-function-name 
+	method-function-plist 
+	method-function-get 
+	gdefinition 
+     slot-value-using-class)
+
+(defsetf slot-value set-slot-value)
+
+
+;;; This is like fdefinition on the Lispm.  If Common Lisp had something like function specs I
+;;; wouldn't need this.  On the other hand, I don't like the way this really works so maybe function
+;;; specs aren't really right either? I also don't understand the real implications of a Lisp-1 on
+;;; this sort of thing.  Certainly some of the lossage in all of this is because these SPECs name
+;;; global definitions. Note that this implementation is set up so that an implementation which has
+;;; a 'real' function spec mechanism can use that instead and in that way get rid of setf generic
+;;; function names. 
+
+
+(defmacro parse-gspec (spec (non-setf-var . non-setf-case)
+                            (setf-var . setf-case))
+              (once-only (spec)
+              `(cond ((symbolp ,spec)
+                      (let ((,non-setf-var ,spec))
+                           ,@non-setf-case))
+                     ((and (listp ,spec)
+                           (eq (car ,spec)
+                               'setf)
+                           (symbolp (cadr ,spec)))
+                      (let ((,setf-var (cadr ,spec)))
+                           ,@setf-case))
+                     (t (error "Can't understand ~S as a generic function specifier.~%~
+               It must be either a symbol which can name a function or~%~
+               a list like ~S, where the car is the symbol ~S and the cadr~%~
+               is a symbol which can name a generic function." ,spec '(setf <foo>)
+                               'setf)))))
+
+
+;;; If symbol names a function which is traced or advised, return the unadvised, traced etc.
+;;; definition.  This lets me get at the generic function object even when it is traced. 
+
+
+(defun unencapsulated-fdefinition (symbol)
+       (il:virginfn symbol))
+
+
+;;; If symbol names a function which is traced or advised, redefine the `real' definition without
+;;; affecting the advise. 
+
+
+(defun fdefine-carefully (symbol new-definition)
+       (let ((advisedp (member symbol il:advisedfns :test #'eq))
+             (brokenp (member symbol il:brokenfns :test #'eq)))
+            
+            ;; In XeroxLisp (late of envos) tracing is implemented as a special case of "breaking". 
+            ;; Advising, however, is treated specially. 
+            (xcl:unadvise-function symbol :no-error t)
+            (xcl:unbreak-function symbol :no-error t)
+            (setf (symbol-function symbol)
+                  new-definition)
+            (when brokenp (xcl:rebreak-function symbol))
+            (when advisedp (xcl:readvise-function symbol)))
+       new-definition)
+
+(defun gboundp (spec)
+       (parse-gspec spec (name (fboundp name))
+              (name (fboundp (get-setf-function-name name)))))
+
+(defun gmakunbound (spec)
+       (parse-gspec spec (name (fmakunbound name))
+              (name (fmakunbound (get-setf-function-name name)))))
+
+(defun gdefinition (spec)
+       (parse-gspec spec (name (or (macro-function name)
+                                                             ; ??
+                                   (unencapsulated-fdefinition name)))
+              (name (unencapsulated-fdefinition (get-setf-function-name name)))))
+
+(defun SETF\ CLOS\ GDEFINITION (new-value spec)
+       (parse-gspec spec (name (fdefine-carefully name new-value))
+              (name (fdefine-carefully (get-setf-function-name name)
+                           new-value))))
+
+
+;;; These functions are a pale imitiation of their namesake.  They accept class objects or types
+;;; where they should. 
+
+
+(defun *typep (object type)
+       (if (classp type)
+           (let ((class (class-of object)))
+                (if class
+                    (memq type (class-precedence-list class))
+                    nil))
+           (let ((class (find-class type nil)))
+                (if class
+                    (*typep object class)
+                    (typep object type)))))
+
+(defun *subtypep (type1 type2)
+       (let ((c1 (if (classp type1)
+                     type1
+                     (find-class type1 nil)))
+             (c2 (if (classp type2)
+                     type2
+                     (find-class type2 nil))))
+            (if (and c1 c2)
+                (memq c2 (class-precedence-list c1))
+                (if (or c1 c2)
+                    nil
+                                                             ; This isn't quite right, but...
+                    (subtypep type1 type2)))))
+
+(defun do-satisfies-deftype (name predicate)
+       (let* ((specifier `(satisfies ,predicate))
+              (expand-fn #'(lambda (&rest ignore)
+                                  (declare (ignore ignore))
+                                  specifier)))
+             
+             ;; Specific ports can insert their own way of doing this.  Many ports may find the
+             ;; expand-fn defined above useful. 
+             (or 
+                 ;; This is the default for ports for which we don't know any better.  Note that for
+                 ;; most ports, providing this definition should just speed up class definition.  It
+                 ;; shouldn't have an effect on performance of most user code. 
+                 (eval `(deftype ,name nil '(satisfies ,predicate))))))
+
+(defun make-type-predicate-name (name)
+       (intern (format nil "TYPE-PREDICATE ~A ~A" (package-name (symbol-package name))
+                      (symbol-name name))
+              *the-clos-package*))
+
+(proclaim '(special *the-class-t* *the-class-vector* *the-class-symbol* *the-class-string* 
+                  *the-class-sequence* *the-class-rational* *the-class-ratio* *the-class-number* 
+                  *the-class-null* *the-class-list* *the-class-integer* *the-class-float* 
+                  *the-class-cons* *the-class-complex* *the-class-character* *the-class-bit-vector* 
+                  *the-class-array* *the-class-standard-object* *the-class-class* *the-class-method*
+                  *the-class-generic-function* *the-class-standard-class* *the-class-standard-method*
+                  *the-class-standard-generic-function* 
+                  *the-class-standard-effective-slot-definition* *the-eslotd-standard-class-slots*))
+
+(proclaim '(special *the-wrapper-of-t* *the-wrapper-of-vector* *the-wrapper-of-symbol* 
+                  *the-wrapper-of-string* *the-wrapper-of-sequence* *the-wrapper-of-rational* 
+                  *the-wrapper-of-ratio* *the-wrapper-of-number* *the-wrapper-of-null* 
+                  *the-wrapper-of-list* *the-wrapper-of-integer* *the-wrapper-of-float* 
+                  *the-wrapper-of-cons* *the-wrapper-of-complex* *the-wrapper-of-character* 
+                  *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
+
+(defvar *built-in-class-symbols* nil)
+
+(defvar *built-in-wrapper-symbols* nil)
+
+(defun get-built-in-class-symbol (class-name)
+       (or (cadr (assq class-name *built-in-class-symbols*))
+           (let ((symbol (intern (format nil "*THE-CLASS-~A*" (symbol-name class-name))
+                                *the-clos-package*)))
+                (push (list class-name symbol)
+                      *built-in-class-symbols*)
+                symbol)))
+
+(defun get-built-in-wrapper-symbol (class-name)
+       (or (cadr (assq class-name *built-in-wrapper-symbols*))
+           (let ((symbol (intern (format nil "*THE-WRAPPER-OF-~A*" (symbol-name class-name))
+                                *the-clos-package*)))
+                (push (list class-name symbol)
+                      *built-in-wrapper-symbols*)
+                symbol)))
+
+(pushnew 'class *variable-declarations*)
+
+(pushnew 'variable-rebinding *variable-declarations*)
+
+(defun variable-class (var env)
+       (caddr (variable-declaration 'class var env)))
+
+(defvar *boot-state* nil)
+                                                             ; NIL EARLY BRAID COMPLETE 
+
+
+(eval-when (load eval)
+       (when (eq *boot-state* 'complete)
+             (error "Trying to load (or compile) CLOS in an environment in which it~%~
+            has already been loaded.  This doesn't work, you will have to~%~
+            get a fresh lisp (reboot) and then load CLOS."))
+       (when *boot-state* (cerror "Try loading (or compiling) CLOS anyways." "Trying to load (or compile) CLOS in an environment in which it~%~
+             has already been partially loaded.  This may not work, you may~%~
+             need to get a fresh lisp (reboot) and then load CLOS.")))
+
+
+;;; This is used by combined methods to communicate the next methods to the methods they call.  This
+;;; variable is captured by a lexical variable of the methods to give it the proper lexical scope. 
+
+
+(defvar *next-methods* nil)
+
+(defvar *not-an-eql-specializer* '(not-an-eql-specializer))
+
+(defvar *umi-gfs*)
+
+(defvar *umi-complete-classes*)
+
+(defvar *umi-reorder*)
+
+(defvar *invalidate-discriminating-function-force-p* nil)
+
+(defvar *invalid-dfuns-on-stack* nil)
+
+(defvar *standard-method-combination*)
+
+(defvar *slotd-unsupplied* (list '*slotd-unsupplied*))
+
+                                                             ; ***
+
+
+(defmacro define-gf-predicate (predicate &rest classes)
+       `(progn (defmethod ,predicate ((x t))
+                      nil)
+               ,@(mapcar #'(lambda (c)
+                                  `(defmethod ,predicate ((x ,c))
+                                          t))
+                        classes)))
+
+(defmacro plist-value (object name)
+       `(with-slots (plist)
+               ,object
+               (getf plist ,name)))
+
+(defsetf plist-value (object name)
+       (new-value)
+       (once-only (new-value)
+              `(with-slots (plist)
+                      ,object
+                      (if ,new-value
+                          (setf (getf plist ,name)
+                                ,new-value)
+                          (progn (remf plist ,name)
+                                 nil)))))
+
+(defvar *built-in-classes* 
+
+       ;; name       supers     subs                     cdr of cpl 
+       '((number (t) (complex float rational)
+                (t))
+         (complex (number)
+                nil
+                (number t))
+         (float (number)
+                nil
+                (number t))
+         (rational (number)
+                (integer ratio)
+                (number t))
+         (integer (rational)
+                nil
+                (rational number t))
+         (ratio (rational)
+                nil
+                (rational number t))
+         (sequence (t)
+                (list vector)
+                (t))
+         (list (sequence)
+               (cons null)
+               (sequence t))
+         (cons (list)
+               nil
+               (list sequence t))
+         (array (t)
+                (vector)
+                (t))
+         (vector (array sequence)
+                (string bit-vector)
+                (array sequence t))
+         (string (vector)
+                nil
+                (vector array sequence t))
+         (bit-vector (vector)
+                nil
+                (vector array sequence t))
+         (character (t)
+                nil
+                (t))
+         (symbol (t)
+                (null)
+                (t))
+         (null (symbol)
+               nil
+               (symbol list sequence t))))
+
+
+;;; The classes that define the kernel of the metabraid. 
+
+
+(defclass t nil nil (:metaclass built-in-class))
+
+(defclass standard-object (t)
+       nil)
+
+(defclass metaobject (standard-object)
+       nil)
+
+(defclass specializer (metaobject)
+       nil)
+
+(defclass definition-source-mixin (standard-object)
+       ((source :initform (load-truename)
+               :reader definition-source :initarg :definition-source)))
+
+(defclass plist-mixin (standard-object)
+       ((plist :initform nil)))
+
+(defclass documentation-mixin (plist-mixin)
+       nil)
+
+(defclass dependent-update-mixin (plist-mixin)
+       nil)
+
+
+;;; The class CLASS is a specified basic class.  It is the common superclass of any kind of class. 
+;;; That is any class that can be a metaclass must have the class CLASS in its class precedence
+;;; list. 
+
+
+(defclass class (documentation-mixin dependent-update-mixin definition-source-mixin specializer)
+       ((name :initform nil :initarg :name :accessor class-name)
+        (direct-superclasses :initform nil :reader class-direct-superclasses)
+        (direct-subclasses :initform nil :reader class-direct-subclasses)
+        (direct-methods :initform (cons nil nil))))
+
+
+;;; The class CLOS-CLASS is an implementation-specific common superclass of all specified subclasses
+;;; of the class CLASS. 
+
+
+(defclass clos-class (class)
+       ((class-precedence-list :initform nil)
+        (wrapper :initform nil)))
+
+
+;;; The class STD-CLASS is an implementation-specific common superclass of the classes
+;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. 
+
+
+(defclass std-class (clos-class)
+       ((direct-slots :initform nil :accessor class-direct-slots)
+        (slots :initform nil :accessor class-slots)
+        (no-of-instance-slots                                ; *** MOVE TO WRAPPER ***
+               :initform 0 :accessor class-no-of-instance-slots)
+        (prototype :initform nil)))
+
+(defclass standard-class (std-class)
+       nil)
+
+(defclass funcallable-standard-class (std-class)
+       nil)
+
+(defclass forward-referenced-class (clos-class)
+       nil)
+
+(defclass built-in-class (clos-class)
+       nil)
+
+
+;;; Slot definitions. Note that throughout CLOS, "SLOT-DEFINITION" is abbreviated as "SLOTD". 
+
+
+(defclass slot-definition (metaobject)
+       nil)
+
+(defclass direct-slot-definition (slot-definition)
+       nil)
+
+(defclass effective-slot-definition (slot-definition)
+       nil)
+;
+(defclass standard-slot-definition (slot-definition)
+       ((name :initform nil :accessor slotd-name)
+        (initform :initform *slotd-unsupplied* :accessor slotd-initform)
+        (initfunction :initform *slotd-unsupplied* :accessor slotd-initfunction)
+        (readers :initform nil :accessor slotd-readers)
+        (writers :initform nil :accessor slotd-writers)
+        (initargs :initform nil :accessor slotd-initargs)
+        (allocation :initform nil :accessor slotd-allocation)
+        (type :initform nil :accessor slotd-type)
+        (documentation :initform "" :initarg :documentation)
+        (class :initform nil :accessor slotd-class)
+        (instance-index :initform nil :accessor slotd-instance-index)))
+
+(defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition)
+       nil)
+
+                                                             ; Adding slots here may involve extra
+                                                             ; work to the code in braid.lisp 
+
+
+(defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition)
+       nil)
+
+                                                             ; Adding slots here may involve extra
+                                                             ; work to the code in braid.lisp 
+
+
+(defclass eql-specializer (specializer)
+       ((object :initarg :object :reader eql-specializer-object)))
+
+
+;;; 
+
+
+(defmacro dolist-carefully ((var list improper-list-handler)
+                            &body body)
+       `(let ((,var nil)
+              (.dolist-carefully. ,list))
+             (loop (when (null .dolist-carefully.)
+                         (return nil))
+                   (if (consp .dolist-carefully.)
+                       (progn (setq ,var (pop .dolist-carefully.))
+                              ,@body)
+                       (,improper-list-handler)))))
+
+(defun legal-std-documentation-p (x)
+       (if (or (null x)
+               (stringp x))
+           t
+           "a string or NULL"))
+
+(defun legal-std-lambda-list-p (x)
+       (declare (ignore x))
+       t)
+
+(defun legal-std-method-function-p (x)
+       (if (functionp x)
+           t
+           "a function"))
+
+(defun legal-std-qualifiers-p (x)
+       (flet ((improper-list nil (return-from legal-std-qualifiers-p "Is not a proper list.")))
+             (dolist-carefully (q x improper-list)
+                    (let ((ok (legal-std-qualifier-p q)))
+                         (unless (eq ok t)
+                             (return-from legal-std-qualifiers-p (format nil "Contains ~S which ~A" q
+                                                                        ok)))))
+             t))
+
+(defun legal-std-qualifier-p (x)
+       (if (and x (atom x))
+           t
+           "is not a non-null atom"))
+
+(defun legal-std-slot-name-p (x)
+       (cond ((not (symbolp x))
+              "is not a symbol and so cannot be bound")
+             ((keywordp x)
+              "is a keyword and so cannot be bound")
+             ((memq x '(t nil))
+              "cannot be bound")
+             (t t)))
+
+(defun legal-std-specializers-p (x)
+       (flet ((improper-list nil (return-from legal-std-specializers-p "Is not a proper list.")))
+             (dolist-carefully (s x improper-list)
+                    (let ((ok (legal-std-specializer-p s)))
+                         (unless (eq ok t)
+                             (return-from legal-std-specializers-p (format nil "Contains ~S which ~A"
+                                                                          s ok)))))
+             t))
+
+(defun legal-std-specializer-p (x)
+       (if (or (classp x)
+               (eql-specializer-p x))
+           t
+           "is neither a class object nor an eql specializer"))
diff --git a/clos/2.0/defsys.lisp b/clos/2.0/defsys.lisp
new file mode 100644
index 00000000..c8a5f6f7
--- /dev/null
+++ b/clos/2.0/defsys.lisp
@@ -0,0 +1,757 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;; Some support stuff for compiling and loading CLOS.  It would be nice if
+;;; there was some portable make-system we could all agree to share for a
+;;; while.  At least until people really get databases and stuff.
+;;;
+;;; ***                                                               ***
+;;; ***        DIRECTIONS FOR INSTALLING CLOS AT YOUR SITE             ***
+;;; ***                                                               ***
+;;;
+;;; To get CLOS working at your site you should:
+;;; 
+;;;  - Get all the CLOS source files from Xerox.  The complete list of source
+;;;    file names can be found in the defsystem for CLOS which appears towards
+;;;    the end of this file.
+;;; 
+;;;  - Edit the variable *clos-directory* below to specify the directory at
+;;;    your site where the clos sources and binaries will be.  This variable
+;;;    can be found by searching from this point for the string "***" in
+;;;    this file.
+;;; 
+;;;  - Use the function (clos::compile-clos) to compile CLOS for your site.
+;;; 
+;;;  - Once CLOS has been compiled it can be loaded with (clos::load-clos).
+;;;    Note that CLOS cannot be loaded on top of itself, nor can it be
+;;;    loaded into the same world it was compiled in.
+;;;
+
+(in-package "CLOS" :use (list (or (find-package :walker)
+				 (make-package :walker :use '(:lisp)))
+			     (or (find-package :iterate)
+				 (make-package :iterate
+					       :use '(:lisp :walker)))
+			     (find-package :lisp)))
+
+(export (intern (symbol-name :iterate)		;Have to do this here,
+		(find-package :iterate))	;because in the defsystem
+	(find-package :iterate))		;(later in this file)
+						;we use the symbol iterate
+						;to name the file
+
+;;;
+;;; Sure, its weird for this to be here, but in order to follow the rules
+;;; about order of export and all that stuff, we can't put it in PKG before
+;;; we want to use it.
+;;; 
+(defvar *the-clos-package* (find-package :clos))
+
+(defvar *clos-system-date* "5/10/91 Interim CLOS release")
+
+
+;;;
+;;; Various hacks to get people's *features* into better shape.
+;;; 
+(eval-when (compile load eval)
+  #+(and Symbolics Lispm)
+  (multiple-value-bind (major minor) (sct:get-release-version)
+    (etypecase minor
+      (integer)
+      (string (setf minor (parse-integer minor :junk-allowed t))))
+    (pushnew :genera *features*)
+    (ecase major
+      ((6)
+       (pushnew :genera-release-6 *features*))
+      ((7)
+       (pushnew :genera-release-7 *features*)
+       (ecase minor
+	 ((0 1) (pushnew :genera-release-7-1 *features*))
+	 ((2)   (pushnew :genera-release-7-2  *features*))
+	 ((3)   (pushnew :genera-release-7-3  *features*))
+	 ((4)   (pushnew :genera-release-7-4  *features*))))
+      ((8)
+       (pushnew :genera-release-8 *features*)
+       (ecase minor
+	 ((0) (pushnew :genera-release-8-0 *features*))
+	 ((1) (pushnew :genera-release-8-1 *features*))))))
+  
+  #+CLOE-Runtime
+  (let ((version (lisp-implementation-version)))
+    (when (string-equal version "2.0" :end1 (min 3 (length version)))
+      (pushnew :cloe-release-2 *features*)))
+
+  (dolist (feature *features*)
+    (when (and (symbolp feature)                ;3600!!
+               (equal (symbol-name feature) "CMU"))
+      (pushnew :CMU *features*)))
+  
+  #+TI
+  (if (eq (si:local-binary-file-type) :xld)
+      (pushnew ':ti-release-3 *features*)
+      (pushnew ':ti-release-2 *features*))
+
+  #+Lucid
+  (when (search "IBM RT PC" (machine-type))
+    (pushnew :ibm-rt-pc *features*))
+
+  #+ExCL
+  (cond ((search "sun3" (lisp-implementation-version))
+	 (push :sun3 *features*))
+	((search "sun4" (lisp-implementation-version))
+	 (push :sun4 *features*)))
+
+  #+(and HP Lucid)
+  (push :HP-Lucid *features*)
+  #+(and HP (not Lucid))
+  (push :HP-HPLabs *features*)
+
+  #+Xerox
+  (case il:makesysname
+    (:lyric (push :Xerox-Lyric *features*))
+    (otherwise (pushnew :Xerox-Medley *features*)))
+;;;
+;;; For KCL and IBCL, push the symbol :turbo-closure on the list *features*
+;;; if you have installed turbo-closure patch.  See the file kcl-mods.text
+;;; for details.
+;;;
+;;; The xkcl version of KCL has this fixed already.
+;;; 
+
+  #+xkcl(pushnew :turbo-closure *features*)
+
+  )
+
+
+
+;;; Yet Another Sort Of General System Facility and friends.
+;;;
+;;; The entry points are defsystem and operate-on-system.  defsystem is used
+;;; to define a new system and the files with their load/compile constraints.
+;;; Operate-on-system is used to operate on a system defined that has been
+;;; defined by defsystem.  For example:
+#||
+
+(defsystem my-very-own-system
+	   "/usr/myname/lisp/"
+  ((classes   (precom)           ()                ())
+   (methods   (precom classes)   (classes)         ())
+   (precom    ()                 (classes methods) (classes methods))))
+
+This defsystem should be read as follows:
+
+* Define a system named MY-VERY-OWN-SYSTEM, the sources and binaries
+  should be in the directory "/usr/me/lisp/".  There are three files
+  in the system, there are named classes, methods and precom.  (The
+  extension the filenames have depends on the lisp you are running in.)
+  
+* For the first file, classes, the (precom) in the line means that
+  the file precom should be loaded before this file is loaded.  The
+  first () means that no other files need to be loaded before this
+  file is compiled.  The second () means that changes in other files
+  don't force this file to be recompiled.
+
+* For the second file, methods, the (precom classes) means that both
+  of the files precom and classes must be loaded before this file
+  can be loaded.  The (classes) means that the file classes must be
+  loaded before this file can be compiled.  The () means that changes
+  in other files don't force this file to be recompiled.
+
+* For the third file, precom, the first () means that no other files
+  need to be loaded before this file is loaded.  The first use of
+  (classes methods)  means that both classes and methods must be
+  loaded before this file can be compiled.  The second use of (classes
+  methods) mean that whenever either classes or methods changes precom
+  must be recompiled.
+
+Then you can compile your system with:
+
+ (operate-on-system 'my-very-own-system :compile)
+
+and load your system with:
+
+ (operate-on-system 'my-very-own-system :load)
+
+||#
+
+;;; 
+(defvar *system-directory*)
+
+;;;
+;;; *port* is a list of symbols (in the CLOS package) which represent the
+;;; Common Lisp in which we are now running.  Many of the facilities in
+;;; defsys use the value of *port* rather than #+ and #- to conditionalize
+;;; the way they work.
+;;; 
+(defvar *port*
+        '(#+Genera               Genera
+;         #+Genera-Release-6     Rel-6
+;         #+Genera-Release-7-1   Rel-7
+          #+Genera-Release-7-2   Rel-7
+	  #+Genera-Release-7-3   Rel-7
+          #+Genera-Release-7-1   Rel-7-1
+          #+Genera-Release-7-2   Rel-7-2
+	  #+Genera-Release-7-3   Rel-7-2	;OK for now
+	  #+Genera-Release-7-4   Rel-7-2	;OK for now
+	  #+Genera-Release-8	 Rel-8
+	  #+imach                Ivory
+	  #+Cloe-Runtime	 Cloe
+          #+Lucid                Lucid
+          #+Xerox                Xerox
+	  #+Xerox-Lyric          Xerox-Lyric
+	  #+Xerox-Medley         Xerox-Medley
+          #+TI                   TI
+          #+(and dec vax common) Vaxlisp
+          #+KCL                  KCL
+          #+IBCL                 IBCL
+          #+excl                 excl
+	  #+(and excl sun4)      excl-sun4
+          #+:CMU                 CMU
+          #+HP-HPLabs            HP-HPLabs
+          #+:gclisp              gclisp
+          #+pyramid              pyramid
+          #+:coral               coral))
+
+;;;
+;;; When you get a copy of CLOS (by tape or by FTP), the sources files will
+;;; have extensions of ".lisp" in particular, this file will be defsys.lisp.
+;;; The preferred way to install clos is to rename these files to have the
+;;; extension which your lisp likes to use for its files.  Alternately, it
+;;; is possible not to rename the files.  If the files are not renamed to
+;;; the proper convention, the second line of the following defvar should
+;;; be changed to:
+;;;     (let ((files-renamed-p nil)
+;;;
+;;; Note: Something people installing CLOS on a machine running Unix
+;;;       might find useful.  If you want to change the extensions
+;;;       of the source files from ".lisp" to ".lsp", *all* you have
+;;;       to do is the following:
+;;;
+;;;       % foreach i (*.lisp)
+;;;       ? mv $i $i:r.lsp
+;;;       ? end
+;;;       %
+;;;
+;;;       I am sure that a lot of people already know that, and some
+;;;       Unix hackers may say, "jeez who doesn't know that".  Those
+;;;       same Unix hackers are invited to fix mv so that I can type
+;;;       "mv *.lisp *.lsp".
+;;;
+(defvar *pathname-extensions*
+  (let ((files-renamed-p t)
+        (proper-extensions
+          (car
+           '(#+(and Genera (not imach))          ("lisp"  . "bin")
+	     #+(and Genera imach)                ("lisp"  . "ibin")
+	     #+Cloe-Runtime			 ("l"	  . "fasl")
+             #+(and dec common vax (not ultrix)) ("LSP"   . "FAS")
+             #+(and dec common vax ultrix)       ("lsp"   . "fas")
+             #+KCL                               ("lsp"   . "o")
+             #+IBCL                              ("lsp"   . "o")
+             #+Xerox                             ("lisp"  . "dfasl")
+             #+(and Lucid MC68000)               ("lisp"  . "lbin")
+             #+(and Lucid VAX)                   ("lisp"  . "vbin")
+             #+(and Lucid Prime)                 ("lisp"  . "pbin")
+	     #+(and Lucid SUNRise)               ("lisp"  . "sbin")
+	     #+(and Lucid SPARC)                 ("lisp"  . "sbin")
+             #+(and Lucid IBM-RT-PC)             ("lisp"  . "bbin")
+             #+(and Lucid MIPS)                  ("lisp"  . "mbin")
+             #+(and Lucid PRISM)                 ("lisp"  . "abin")
+             #+(and Lucid PA)                    ("lisp"  . "hbin")
+	     #+excl                              ("cl"    . "fasl")
+             #+:CMU                              ("slisp" . "sfasl")
+             #+HP                                ("l"     . "b")
+             #+TI ("lisp" . #.(string (si::local-binary-file-type)))
+             #+:gclisp                           ("LSP"   . "F2S")
+             #+pyramid                           ("clisp" . "o")
+             #+:coral                            ("lisp"  . "fasl")
+             ))))
+    (cond ((null proper-extensions) '("l" . "lbin"))
+          ((null files-renamed-p) (cons "lisp" (cdr proper-extensions)))
+          (t proper-extensions))))
+
+(eval-when (compile load eval)
+
+(defun get-system (name)
+  (get name 'system-definition))
+
+(defun set-system (name new-value)
+  (setf (get name 'system-definition) new-value))
+
+(defmacro defsystem (name directory files)
+  `(set-system ',name (list #'(lambda () ,directory)
+			    (make-modules ',files)
+			    ',(mapcar #'car files))))
+
+)
+
+
+;;;
+;;; The internal datastructure used when operating on a system.
+;;; 
+(defstruct (module (:constructor make-module (name))
+                   (:print-function
+                     (lambda (m s d)
+                       (declare (ignore d))
+                       (format s "#<Module ~A>" (module-name m)))))
+  name
+  load-env
+  comp-env
+  recomp-reasons)
+
+(defun make-modules (system-description)
+  (let ((modules ()))
+    (labels ((get-module (name)
+               (or (find name modules :key #'module-name)
+                   (progn (setq modules (cons (make-module name) modules))
+                          (car modules))))
+             (parse-spec (spec)
+               (if (eq spec 't)
+                   (reverse (cdr modules))
+		   (case (car spec)
+		     (+ (append (reverse (cdr modules)) (mapcar #'get-module (cdr spec))))
+		     (- (let ((rem (mapcar #'get-module (cdr spec))))
+			  (remove-if #'(lambda (m) (member m rem)) (reverse (cdr modules)))))
+		     (otherwise (mapcar #'get-module spec))))))
+      (dolist (file system-description)
+        (let* ((name (car file))
+               (port (car (cddddr file)))
+               (module nil))
+          (when (or (null port)
+                    (member port *port*))
+            (setq module (get-module name))
+            (setf (module-load-env module) (parse-spec (cadr file))
+                  (module-comp-env module) (parse-spec (caddr file))
+                  (module-recomp-reasons module) (parse-spec
+                                                   (cadddr file))))))
+      (let ((filenames (mapcar #'car system-description)))
+	(sort modules #'(lambda (name1 name2)
+			  (member name2 (member name1 filenames)))
+	      :key #'module-name)))))
+
+
+(defun make-transformations (modules filter make-transform)
+  (let ((transforms (list nil)))
+    (dolist (m modules)
+      (when (funcall filter m transforms) (funcall make-transform m transforms)))
+    (reverse (cdr transforms))))
+
+(defun make-compile-transformation (module transforms)
+  (unless (dolist (trans transforms)
+	    (and (eq (car trans) ':compile)
+		 (eq (cadr trans) module)
+		 (return t)))
+    (dolist (c (module-comp-env module)) (make-load-transformation c transforms))
+    (setf (cdr transforms)
+	  (remove-if #'(lambda (trans) (and (eq (car trans) :load) (eq (cadr trans) module)))
+		     (cdr transforms)))
+    (push `(:compile ,module) (cdr transforms))))
+
+(defvar *being-loaded* ())
+
+(defun make-load-transformation (module transforms)
+  (if (assoc module *being-loaded*)
+      (throw module (setf (cdr transforms) (cdr (assoc module *being-loaded*))))
+      (let ((*being-loaded* (cons (cons module (cdr transforms)) *being-loaded*)))
+	(catch module
+	  (unless (dolist (trans transforms)
+		    (when (and (eq (car trans) ':load)
+			       (eq (cadr trans) module))
+		      (return t)))
+	    (dolist (l (module-load-env module)) (make-load-transformation l transforms))
+	    (push `(:load ,module) (cdr transforms)))))))
+
+(defun make-load-without-dependencies-transformation (module transforms)
+  (unless (dolist (trans transforms)
+            (and (eq (car trans) ':load)
+                 (eq (cadr trans) module)
+                 (return trans)))
+    (push `(:load ,module) (cdr transforms))))
+
+(defun compile-filter (module transforms)
+  (or (dolist (r (module-recomp-reasons module))
+        (when (dolist (transform transforms)
+                (when (and (eq (car transform) ':compile)
+                           (eq (cadr transform) r))
+                  (return t)))
+          (return t)))
+      (null (probe-file (make-binary-pathname (module-name module))))
+      (> (file-write-date (make-source-pathname (module-name module)))
+         (file-write-date (make-binary-pathname (module-name module))))))
+
+(defun operate-on-system (name mode &optional arg print-only)
+  (let ((system (get-system name)))
+    (unless system (error "Can't find system with name ~S." name))
+    (let ((*system-directory* (funcall (car system)))
+	  (modules (cadr system))
+	  (transformations ()))
+      (labels ((load-source (name pathname)
+		 (format t "~&Loading source of ~A..." name)
+		 (or print-only (load pathname)))
+	       (load-binary (name pathname)
+		 (format t "~&Loading binary of ~A..." name)
+		 (or print-only (load pathname)))	       
+	       (load-module (m)
+		 (let* ((name (module-name m))
+			(*load-verbose* nil)
+			(binary (make-binary-pathname name)))
+		   (load-binary name binary)))
+	       (compile-module (m)
+		 (format t "~&Compiling ~A..." (module-name m))
+		 (unless print-only
+		   (let  ((name (module-name m)))
+		     (compile-file (make-source-pathname name)
+				   :output-file
+				   (make-pathname :defaults
+						  (make-binary-pathname name)
+						  :version :newest)))))
+	       (xcl:true (&rest ignore) (declare (ignore ignore)) 't))
+	
+	(setq transformations
+	      (ecase mode
+		(:compile
+		  ;; Compile any files that have changed and any other files
+		  ;; that require recompilation when another file has been
+		  ;; recompiled.
+		  (make-transformations
+		    modules
+		    #'compile-filter
+		    #'make-compile-transformation))
+		(:recompile
+		  ;; Force recompilation of all files.
+		  (make-transformations
+		    modules
+		    #'xcl:true
+		    #'make-compile-transformation))
+		(:recompile-some
+		  ;; Force recompilation of some files.  Also compile the
+		  ;; files that require recompilation when another file has
+		  ;; been recompiled.
+		  (make-transformations
+		    modules
+		    #'(lambda (m transforms)
+			(or (member (module-name m) arg)
+			    (compile-filter m transforms)))
+		    #'make-compile-transformation))
+		(:query-compile
+		  ;; Ask the user which files to compile.  Compile those
+		  ;; and any other files which must be recompiled when
+		  ;; another file has been recompiled.
+		  (make-transformations
+		    modules
+		    #'(lambda (m transforms)
+			(or (compile-filter m transforms)
+			    (y-or-n-p "Compile ~A?"
+				      (module-name m))))
+		    #'make-compile-transformation))
+		(:confirm-compile
+		  ;; Offer the user a chance to prevent a file from being
+		  ;; recompiled.
+		  (make-transformations
+		    modules
+		    #'(lambda (m transforms)
+			(and (compile-filter m transforms)
+			     (y-or-n-p "Go ahead and compile ~A?"
+				       (module-name m))))
+		    #'make-compile-transformation))
+		(:load
+		  ;; Load the whole system.
+		  (make-transformations
+		    modules
+		    #'xcl:true
+		    #'make-load-transformation))
+		(:query-load
+		  ;; Load only those files the user says to load.
+		  (make-transformations
+		    modules
+		    #'(lambda (m transforms)
+			(declare (ignore transforms))
+			(y-or-n-p "Load ~A?" (module-name m)))
+		    #'make-load-without-dependencies-transformation))))
+	
+	(#+Genera
+	 compiler:compiler-warnings-context-bind
+	 #+TI
+	 COMPILER:COMPILER-WARNINGS-CONTEXT-BIND
+	 #+:LCL3.0
+	 lucid-common-lisp:with-deferred-warnings
+	 #-(or Genera TI :LCL3.0)
+	 progn
+	 (loop (when (null transformations) (return t))
+	       (let ((transform (pop transformations)))
+		 (ecase (car transform)
+		   (:compile (compile-module (cadr transform)))
+		   (:load (load-module (cadr transform)))))))))))
+
+
+(defun make-source-pathname (name) (make-pathname-internal name :source))
+(defun make-binary-pathname (name) (make-pathname-internal name :binary))
+
+(defun make-pathname-internal (name type)
+  (let* ((extension (ecase type
+                      (:source (car *pathname-extensions*))
+                      (:binary (cdr *pathname-extensions*))))
+         (directory (pathname
+		      (etypecase *system-directory*
+			(string *system-directory*)
+			(pathname *system-directory*)
+			(cons (ecase type
+				(:source (car *system-directory*))
+				(:binary (cdr *system-directory*)))))))
+         (pathname
+           (make-pathname
+             :name (string-downcase (string name))
+             :type extension
+             :defaults directory :version :newest)))
+
+    #+Genera
+    (setq pathname (zl:send pathname :new-raw-name (pathname-name pathname))
+          pathname (zl:send pathname :new-raw-type (pathname-type pathname)))
+
+    pathname))
+
+
+
+;;; ***                SITE SPECIFIC CLOS DIRECTORY                        ***
+;;;
+;;; *clos-directory* is a variable which specifies the directory clos is stored
+;;; in at your site.  If the value of the variable is a single pathname, the
+;;; sources and binaries should be stored in that directory.  If the value of
+;;; that directory is a cons, the CAR should be the source directory and the
+;;; CDR should be the binary directory.
+;;;
+;;; By default, the value of *clos-directory* is set to the directory that
+;;; this file is loaded from.  This makes it simple to keep multiple copies
+;;; of CLOS in different places, just load defsys from the same directory as
+;;; the copy of CLOS you want to use.
+;;;
+;;; Note that the value of *CLOS-DIRECTORY* is set using a DEFVAR.  This is
+;;; done to make it possible for users to set it in their init file and then
+;;; load this file.  The value set in the init file will override the value
+;;; here.
+;;;
+;;; ***                                                                   ***
+
+(defun load-truename (&optional (errorp nil))
+  (flet ((bad-time ()
+	   (when errorp
+	     (error "LOAD-TRUENAME called but a file isn't being loaded."))))
+    #+Lispm  (or sys:fdefine-file-pathname (bad-time))
+    #+excl   excl::*source-pathname*
+    #+Xerox  (pathname (or (il:fullname *standard-input*) (bad-time)))
+    #+(and dec vax common) (truename (sys::source-file #'load-truename))
+    ;;
+    ;; The following use of  `lucid::' is a kludge for 2.1 and 3.0
+    ;; compatibility.  In 2.1 it was in the SYSTEM package, and i
+    ;; 3.0 it's in the LUCID-COMMON-LISP package.
+    ;;
+    #+LUCID (or lucid::*source-pathname* (bad-time))
+    #-(or Lispm excl Xerox (and dec vax common) LUCID) nil))
+
+#-Symbolics
+(defvar *clos-directory*
+	(or (load-truename t)
+	    (error "Because load-truename is not implemented in this port~%~
+                    of CLOS, you must manually edit the definition of the~%~
+                    variable *clos-directory* in the file defsys.lisp.")))
+
+#+Genera
+(defvar *clos-directory*
+	(let ((source (load-truename t)))
+	  (flet ((subdir (name)
+		   (scl:send source :new-pathname :raw-directory
+			     (append (scl:send source :raw-directory)
+				     (list name)))))
+	    (cons source
+		  #+genera-release-7-2       (subdir "rel-7-2")
+		  #+genera-release-7-3       (subdir "rel-7-3") 
+		  #+genera-release-7-4       (subdir "rel-7-4")
+		  #+genera-release-8-0       (subdir "rel-8-0")
+		  #+genera-release-8-1       (subdir "rel-8-1")
+		  ))))
+
+#+Cloe-Runtime
+(defvar *clos-directory* (pathname "/usr3/hornig/clos/"))
+
+(defsystem clos	   
+           *clos-directory*
+  ;;
+  ;; file         load           compile      files which       port
+  ;;              environment    environment  force the of
+  ;;                                          recompilation
+  ;;                                          of this file
+  ;;                                          
+  (
+   (patch           t            t            ()                xerox)
+   (pkg             t            t            ())
+   (walk            (pkg)        (pkg)        ())
+   (iterate         t            t            ())
+   (macros          t            t            ())
+   (low             (pkg macros) t            (macros))
+   (low2          (low)         (low)        (low)            Xerox)
+   (fin         t                                   t (low))
+   (defclass    t                                   t (low))
+   (defs        t                                   t (defclass macros iterate))
+   (fngen       t                                   t (low))
+   (lap         t                                   t (low))
+   (plap        t                                   t (low))
+   (cache       t                                   t (low defs))
+   (dlap        t                                   t (defs low fin cache lap))
+   (boot        t                                   t (defs fin))
+   (vector      t                                   t (boot defs cache fin))
+   (slots       t                                   t (vector boot defs low cache fin))
+   (init        t                                   t (vector boot defs low cache fin))
+   (std-class   t                                   t (vector boot defs low cache fin slots))
+   (cpl         t                                   t (vector boot defs low cache fin slots))
+   (braid       t                                   t (boot defs low fin cache))
+   (fsc         t                                   t (defclass boot defs low fin cache))
+   (methods     t                                   t (defclass boot defs low fin cache))
+   (combin      t                                   t (defclass boot defs low fin cache))
+   (dfun        t                                   t (dlap))
+   (fixup       (+ precom1 precom2 precom4)         t (boot defs low fin))
+   (defcombin   t                                   t (defclass boot defs low fin))
+   (ctypes      t                                   t (defclass defcombin))
+   (construct   t                                   t (defclass boot defs low))
+   (env         t                                   t (defclass boot defs low fin))
+   (compat      t                                   t ())
+   (precom1     (dlap)                              t (defs low cache fin dfun))
+   (precom2     (dlap)                              t (defs low cache fin dfun))
+   (precom4     (dlap)                              t (defs low cache fin dfun))
+   ))
+
+(defun compile-clos (&optional m)
+  (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
+	#+Lucid (lcl:*redefinition-action* nil)
+	#+excl  (excl::*redefinition-warnings* nil)
+	#+Genera (sys:inhibit-fdefine-warnings t)
+	)
+    (cond ((null m)        (operate-on-system 'clos :compile))
+	  ((eq m :print)   (operate-on-system 'clos :compile () t))
+	  ((eq m :query)   (operate-on-system 'clos :query-compile))
+	  ((eq m :confirm) (operate-on-system 'clos :confirm-compile))
+	  ((eq m 't)       (operate-on-system 'clos :recompile))        
+	  ((listp m)       (operate-on-system 'clos :compile-from m))
+	  ((symbolp m)     (operate-on-system 'clos :recompile-some `(,m))))))
+
+(defun load-clos (&optional m)
+  (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
+	#+Lucid (lcl:*redefinition-action* nil)
+	#+excl  (excl::*redefinition-warnings* nil)
+	#+Genera (sys:inhibit-fdefine-warnings t)
+	)
+    (cond ((null m)      (operate-on-system 'clos :load))
+	  ((eq m :query) (operate-on-system 'clos :query-load)))
+    (pushnew :clos *features*)))
+
+#+Genera
+;;; Make sure Genera bug mail contains the CLOS bug data.  A little
+;;; kludgy, but what the heck.  If they didn't mean for people to do
+;;; this, they wouldn't have made private patch notes be flavored
+;;; objects, right?  Right.
+(progn
+  (scl:defflavor clos-private-patch-info ((description)) ())
+  (scl:defmethod (sct::private-patch-info-description clos-private-patch-info) ()
+    (or description
+	(setf description (string-append "CLOS version: " *clos-system-date*))))
+  (scl:defmethod (sct::private-patch-info-pathname clos-private-patch-info) ()
+    *clos-directory*)
+  (unless (find-if #'(lambda (x) (typep x 'clos-private-patch-info))
+		   sct::*private-patch-info*)
+    (push (scl:make-instance 'clos-private-patch-info)
+	  sct::*private-patch-info*)))
+
+(defun bug-report-info (&optional (stream *standard-output*))
+  (format stream "~&CLOS system date: ~A~
+                  ~&Lisp Implementation type: ~A~
+                  ~&Lisp Implementation version: ~A~
+                  ~&*features*: ~S"
+	  *clos-system-date*
+	  (lisp-implementation-type)
+	  (lisp-implementation-version)
+	  *features*))
+
+
+
+;;;;
+;;;
+;;; This stuff is not intended for external use.
+;;; 
+(defun rename-clos ()
+  (dolist (f (cadr (get-system 'clos)))
+    (let ((old nil)
+          (new nil))
+      (let ((*system-directory* *default-pathname-defaults*))
+        (setq old (make-source-pathname (car f))))
+      (setq new  (make-source-pathname (car f)))
+      (rename-file old new))))
+
+#+Genera
+(defun edit-clos ()
+  (dolist (f (cadr (get-system 'clos)))
+    (let ((*system-directory* *clos-directory*))
+      (zwei:find-file (make-source-pathname (car f))))))
+
+#+Genera
+(defun hardcopy-clos (&optional query-p)
+  (let ((files (mapcar #'(lambda (f)
+                           (setq f (car f))
+                           (and (or (not query-p)
+                                    (y-or-n-p "~A? " f))
+                                f))
+		       (cadr (get-system 'clos))))
+        (b zwei:*interval*))
+    (unwind-protect
+        (dolist (f files)
+          (when f
+            (multiple-value-bind (ignore b)
+                (zwei:find-file (make-source-pathname f))
+              (zwei:hardcopy-buffer b))))
+      (zwei:make-buffer-current b))))
+
+
+;;;
+;;; unido!ztivax!dae@seismo.css.gov
+;;; z30083%tansei.cc.u-tokyo.junet@utokyo-relay.csnet
+;;; Victor@carmen.uu.se
+;;; mcvax!harlqn.co.uk!chris@uunet.UU.NET
+;;; 
+#+Genera
+(defun mail-clos (to)
+  (let* ((original-buffer zwei:*interval*)
+	 (*system-directory* (pathname "vaxc:/user/ftp/pub/clos/")
+			    ;(funcall (car (get-system 'clos)))
+			     )
+         (files (list* 'defsys
+			'test
+			(caddr (get-system 'clos))))
+         (total-number (length files))
+         (file nil)
+	 (number-of-lines 0)
+         (i 0)
+         (mail-buffer nil))
+    (unwind-protect
+        (loop
+           (when (null files) (return nil))
+           (setq file (pop files))
+           (incf i)
+           (multiple-value-bind (ignore b)
+               (zwei:find-file (make-source-pathname file))
+	     (setq number-of-lines (zwei:count-lines b))
+             (zwei:com-mail-internal t
+                                     :initial-to to
+                                     :initial-body b
+				     :initial-subject
+                                     (format nil
+				       "CLOS file   ~A   (~A of ~A) ~D lines"
+				       file i total-number number-of-lines))
+             (setq mail-buffer zwei:*interval*)
+             (zwei:com-exit-com-mail)
+             (format t "~&Just sent ~A  (~A of ~A)." b i total-number)
+             (zwei:kill-buffer mail-buffer)))
+      (zwei:make-buffer-current original-buffer))))
+
+
diff --git a/clos/2.0/dfun.lisp b/clos/2.0/dfun.lisp
new file mode 100644
index 00000000..1e958a30
--- /dev/null
+++ b/clos/2.0/dfun.lisp
@@ -0,0 +1,606 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+                                                             
+                                                             ; ************************************************************************
+                                                             ; temporary for data gathering         
+                                                             ; temporary for data gathering
+                                                             ; ************************************************************************
+
+
+(defvar *dfun-states* (make-hash-table :test #'eq))
+
+(defun notice-dfun-state (generic-function state &optional nkeys valuep)
+       (setf (gethash generic-function *dfun-states*)
+             (cons state (when nkeys (list nkeys valuep)))))
+
+                                                             
+                                                             ; ************************************************************************
+                                                             ; temporary for data gathering         
+                                                             ; temporary for data gathering
+                                                             ; ************************************************************************
+
+
+(defvar *dfun-constructors* nil)
+
+                                                             ; An alist in which each entry is of
+                                                             ; the form (<generator> . (<subentry>
+                                                             ; ...)) Each subentry is of the form:
+                                                             ; (<args> <constructor> <system>) 
+
+
+(defvar *enable-dfun-constructor-caching* t)
+
+                                                             ; If this is NIL, then the whole
+                                                             ; mechanism for caching dfun
+                                                             ; constructors is turned off.  The only
+                                                             ; time that makes sense is when
+                                                             ; debugging LAP code. 
+
+
+(defun show-dfun-constructors nil (format t "~&DFUN constructor caching is ~A." (if 
+                                                                    *enable-dfun-constructor-caching*
+                                                                                    "enabled"
+                                                                                    "disabled"))
+       (dolist (generator-entry *dfun-constructors*)
+           (dolist (args-entry (cdr generator-entry))
+               (format t "~&~S ~S" (cons (car generator-entry)
+                                         (caar args-entry))
+                      (caddr args-entry)))))
+
+(defun get-dfun-constructor (generator &rest args)
+       (let* ((generator-entry (assq generator *dfun-constructors*))
+              (args-entry (assoc args (cdr generator-entry)
+                                 :test
+                                 #'equal)))
+             (if (null *enable-dfun-constructor-caching*)
+                 (apply (symbol-function generator)
+                        args)
+                 (or (cadr args-entry)
+                     (let ((new (apply (symbol-function generator)
+                                       args)))
+                          (if generator-entry
+                              (push (list (copy-list args)
+                                          new nil)
+                                    (cdr generator-entry))
+                              (push (list generator (list (copy-list args)
+                                                          new nil))
+                                    *dfun-constructors*))
+                          new)))))
+
+(defun load-precompiled-dfun-constructor (generator args system constructor)
+       (let* ((generator-entry (assq generator *dfun-constructors*))
+              (args-entry (assoc args (cdr generator-entry)
+                                 :test
+                                 #'equal)))
+             (unless args-entry
+                 (if generator-entry
+                     (push (list args constructor system)
+                           (cdr generator-entry))
+                     (push (list generator (list args constructor system))
+                           *dfun-constructors*)))))
+
+(defmacro
+ precompile-dfun-constructors
+ (&optional system)
+ (let
+  ((*precompiling-lap* t))
+  `(progn
+    ,@(gathering1 (collecting)
+             (dolist (generator-entry *dfun-constructors*)
+                 (dolist (args-entry (cdr generator-entry))
+                     (when (or (null (caddr args-entry))
+                               (eq (caddr args-entry)
+                                   system))
+                         (multiple-value-bind (closure-variables arguments iregs vregs tregs lap)
+                             (apply (symbol-function (car generator-entry))
+                                    (car args-entry))
+                           (gather1 (make-top-level-form `(precompile-dfun-constructor
+                                                           ,(car generator-entry))
+                                           '(load)
+                                           `(load-precompiled-dfun-constructor
+                                             ',(car generator-entry)
+                                             ',(car args-entry)
+                                             ',system
+                                             (precompile-lap-closure-generator ,closure-variables
+                                                    ,arguments
+                                                    ,iregs
+                                                    ,vregs
+                                                    ,tregs
+                                                    ,lap))))))))))))
+
+(defun make-initial-dfun (generic-function)
+       #'(lambda (&rest args)
+                (initial-dfun args generic-function)))
+
+
+;;; When all the methods of a generic function are automatically generated reader or writer methods
+;;; a number of special optimizations are possible. These are important because of the large number
+;;; of generic functions of this type. There are a number of cases: ONE-CLASS-ACCESSOR In this case,
+;;; the accessor generic function has only been called with one class of argument.  There is no
+;;; cache vector, the wrapper of the one class, and the slot index are stored directly as closure
+;;; variables of the discriminating function.  This case can convert to either of the next kind.
+;;; TWO-CLASS-ACCESSOR Like above, but two classes.  This is common enough to do specially. There is
+;;; no cache vector.  The two classes are stored a separate closure variables. ONE-INDEX-ACCESSOR In
+;;; this case, the accessor generic function has seen more than one class of argument, but the index
+;;; of the slot is the same for all the classes that have been seen.  A cache vector is used to
+;;; store the wrappers that have been seen, the slot index is stored directly as a closure variable
+;;; of the discriminating function.  This case can convert to the next kind. N-N-ACCESSOR This is
+;;; the most general case.  In this case, the accessor generic function has seen more than one class
+;;; of argument and more than one slot index.  A cache vector stores the wrappers and corresponding
+;;; slot indexes.  Because each cache line is more than one element long, a cache lock count is
+;;; used. ONE-CLASS-ACCESSOR 
+
+
+(defun update-to-one-class-readers-dfun (generic-function wrapper index)
+       (let ((constructor (get-dfun-constructor 'emit-one-class-reader (consp index))))
+            (notice-dfun-state generic-function `(one-class readers ,(consp index)))
+                                                             ; ***
+            (update-dfun generic-function (funcall constructor wrapper index
+                                                 #'(lambda (arg)
+                                                          (declare (clos-fast-call))
+                                                          (one-class-readers-miss arg 
+                                                                 generic-function index wrapper))))))
+
+(defun update-to-one-class-writers-dfun (generic-function wrapper index)
+       (let ((constructor (get-dfun-constructor 'emit-one-class-writer (consp index))))
+            (notice-dfun-state generic-function `(one-class writers ,(consp index)))
+                                                             ; ***
+            (update-dfun generic-function (funcall constructor wrapper index
+                                                 #'(lambda (new-value arg)
+                                                          (declare (clos-fast-call))
+                                                          (one-class-writers-miss new-value arg 
+                                                                 generic-function index wrapper))))))
+
+(defun one-class-readers-miss (arg generic-function index wrapper)
+       (accessor-miss generic-function 'one-class 'reader nil arg index wrapper nil nil nil))
+
+(defun one-class-writers-miss (new arg generic-function index wrapper)
+       (accessor-miss generic-function 'one-class 'writer new arg index wrapper nil nil nil))
+
+
+;;; TWO-CLASS-ACCESSOR 
+
+
+(defun update-to-two-class-readers-dfun (generic-function wrapper-0 wrapper-1 index)
+       (let ((constructor (get-dfun-constructor 'emit-two-class-reader (consp index))))
+            (notice-dfun-state generic-function `(two-class readers ,(consp index)))
+                                                             ; ***
+            (update-dfun generic-function (funcall constructor wrapper-0 wrapper-1 index
+                                                 #'(lambda (arg)
+                                                          (declare (clos-fast-call))
+                                                          (two-class-readers-miss arg 
+                                                                 generic-function index wrapper-0 
+                                                                 wrapper-1))))))
+
+(defun update-to-two-class-writers-dfun (generic-function wrapper-0 wrapper-1 index)
+       (let ((constructor (get-dfun-constructor 'emit-two-class-writer (consp index))))
+            (notice-dfun-state generic-function `(two-class writers ,(consp index)))
+                                                             ; ***
+            (update-dfun generic-function (funcall constructor wrapper-0 wrapper-1 index
+                                                 #'(lambda (new-value arg)
+                                                          (declare (clos-fast-call))
+                                                          (two-class-writers-miss new-value arg 
+                                                                 generic-function index wrapper-0 
+                                                                 wrapper-1))))))
+
+(defun two-class-readers-miss (arg generic-function index w0 w1)
+       (accessor-miss generic-function 'two-class 'reader nil arg index w0 w1 nil nil))
+
+(defun two-class-writers-miss (new arg generic-function index w0 w1)
+       (accessor-miss generic-function 'two-class 'writer new arg index w0 w1 nil nil))
+
+
+;;; std accessors same index dfun 
+
+
+(defun update-to-one-index-readers-dfun (generic-function index &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let ((constructor (get-dfun-constructor 'emit-one-index-readers (consp index))))
+            (multiple-value-bind (mask size)
+                (compute-cache-parameters 1 nil (or cache 4))
+              (unless cache
+                  (setq cache (get-cache size)))
+              (notice-dfun-state generic-function `(one-index readers ,(consp index)))
+                                                             ; ***
+              (update-dfun generic-function (funcall constructor field cache mask size index
+                                                   #'(lambda (arg)
+                                                            (declare (clos-fast-call))
+                                                            (one-index-readers-miss arg 
+                                                                   generic-function index field cache
+                                                                   )))
+                     cache))))
+
+(defun update-to-one-index-writers-dfun (generic-function index &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let ((constructor (get-dfun-constructor 'emit-one-index-writers (consp index))))
+            (multiple-value-bind (mask size)
+                (compute-cache-parameters 1 nil (or cache 4))
+              (unless cache
+                  (setq cache (get-cache size)))
+              (notice-dfun-state generic-function `(one-index writers ,(consp index)))
+                                                             ; ***
+              (update-dfun generic-function (funcall constructor field cache mask size index
+                                                   #'(lambda (new-value arg)
+                                                            (declare (clos-fast-call))
+                                                            (one-index-writers-miss new-value arg 
+                                                                   generic-function index field cache
+                                                                   )))
+                     cache))))
+
+(defun one-index-readers-miss (arg gf index field cache)
+       (accessor-miss gf 'one-index 'reader nil arg index nil nil field cache))
+
+(defun one-index-writers-miss (new arg gf index field cache)
+       (accessor-miss gf 'one-index 'writer new arg index nil nil field cache))
+
+(defun one-index-limit-fn (nlines)
+       (default-limit-fn nlines))
+
+(defun update-to-n-n-readers-dfun (generic-function &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let ((constructor (get-dfun-constructor 'emit-n-n-readers)))
+            (multiple-value-bind (mask size)
+                (compute-cache-parameters 1 t (or cache 2))
+              (unless cache
+                  (setq cache (get-cache size)))
+              (notice-dfun-state generic-function `(n-n readers))
+                                                             ; ***
+              (update-dfun generic-function (funcall constructor field cache mask size
+                                                   #'(lambda (arg)
+                                                            (declare (clos-fast-call))
+                                                            (n-n-readers-miss arg generic-function 
+                                                                   field cache)))
+                     cache))))
+
+(defun update-to-n-n-writers-dfun (generic-function &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let ((constructor (get-dfun-constructor 'emit-n-n-writers)))
+            (multiple-value-bind (mask size)
+                (compute-cache-parameters 1 t (or cache 2))
+              (unless cache
+                  (setq cache (get-cache size)))
+              (notice-dfun-state generic-function `(n-n writers))
+                                                             ; ***
+              (update-dfun generic-function (funcall constructor field cache mask size
+                                                   #'(lambda (new arg)
+                                                            (declare (clos-fast-call))
+                                                            (n-n-writers-miss new arg 
+                                                                   generic-function field cache)))
+                     cache))))
+
+(defun n-n-readers-miss (arg gf field cache)
+       (accessor-miss gf 'n-n 'reader nil arg nil nil nil field cache))
+
+(defun n-n-writers-miss (new arg gf field cache)
+       (accessor-miss gf 'n-n 'writer new arg nil nil nil field cache))
+
+(defun n-n-accessors-limit-fn (nlines)
+       (default-limit-fn nlines))
+
+
+;;; 
+
+
+(defun update-to-checking-dfun (generic-function function &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let* ((arg-info (gf-arg-info generic-function))
+              (metatypes (arg-info-metatypes arg-info))
+              (applyp (arg-info-applyp arg-info))
+              (nkeys (arg-info-nkeys arg-info)))
+             (if (every #'(lambda (mt)
+                                 (eq mt 't))
+                        metatypes)
+                 (progn (notice-dfun-state generic-function `(default-method-only))
+                                                             ; ***
+                        (update-dfun generic-function function))
+                 (multiple-value-bind (mask size)
+                     (compute-cache-parameters nkeys nil (or cache 2))
+                   (unless cache
+                       (setq cache (get-cache size)))
+                   (let ((constructor (get-dfun-constructor 'emit-checking metatypes applyp)))
+                        (notice-dfun-state generic-function '(checking)
+                               nkeys nil)
+                                                             ; ****
+                        (update-dfun generic-function
+                               (funcall constructor field cache mask size function
+                                      #'(lambda (&rest args)
+                                               (declare (clos-fast-call))
+                                               (checking-miss generic-function args function field 
+                                                      cache)))
+                               cache))))))
+
+(defun checking-limit-fn (nlines)
+       (default-limit-fn nlines))
+
+
+;;; 
+
+
+(defun update-to-caching-dfun (generic-function &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let* ((arg-info (gf-arg-info generic-function))
+              (metatypes (arg-info-metatypes arg-info))
+              (applyp (arg-info-applyp arg-info))
+              (nkeys (arg-info-nkeys arg-info))
+              (constructor (get-dfun-constructor 'emit-caching metatypes applyp)))
+             (multiple-value-bind (mask size)
+                 (compute-cache-parameters nkeys t (or cache 2))
+               (unless cache
+                   (setq cache (get-cache size)))
+               (notice-dfun-state generic-function '(caching)
+                      nkeys t)
+                                                             ; ****
+               (update-dfun generic-function (funcall constructor field cache mask size
+                                                    #'(lambda (&rest args)
+                                                             (declare (clos-fast-call))
+                                                             (caching-miss generic-function args 
+                                                                    field cache)))
+                      cache))))
+
+(defun caching-limit-fn (nlines)
+       (default-limit-fn nlines))
+
+
+;;; The dynamically adaptive method lookup algorithm is implemented is implemented as a kind of
+;;; state machine.  The kinds of discriminating function is the state, the various kinds of reasons
+;;; for a cache miss are the state transitions. The code which implements the transitions is all in
+;;; the miss handlers for each kind of dfun.  Those appear here. Note that within the states that
+;;; cache, there are dfun updates which simply select a new cache or cache field.  Those are not
+;;; considered as state transitions. 
+
+
+(defun initial-dfun (args generic-function)
+       (protect-cache-miss-code generic-function args
+              (multiple-value-bind (wrappers invalidp nfunction applicable)
+                  (cache-miss-values generic-function args)
+                (multiple-value-bind (ntype nindex)
+                    (accessor-miss-values generic-function applicable args)
+                  (cond ((null applicable)
+                         (apply #'no-applicable-method generic-function args))
+                        (invalidp (apply nfunction args))
+                        ((and ntype nindex)
+                         (ecase ntype
+                             (reader (update-to-one-class-readers-dfun generic-function wrappers 
+                                            nindex))
+                             (writer (update-to-one-class-writers-dfun generic-function wrappers 
+                                            nindex)))
+                         (apply nfunction args))
+                        (ntype (apply nfunction args))
+                        (t (update-to-checking-dfun generic-function nfunction)
+                           (apply nfunction args)))))))
+
+(defun
+ accessor-miss
+ (gf ostate otype new object oindex ow0 ow1 field cache)
+ (declare (ignore ow1))
+ (let ((args (ecase otype                                    ; The congruence rules assure
+                 (reader (list object))                      ; us that this is safe despite
+                 (writer (list new object)))))
+                                                             ; not knowing the new type yet.
+      (protect-cache-miss-code
+       gf args
+       (multiple-value-bind (wrappers invalidp nfunction applicable)
+           (cache-miss-values gf args)
+         (multiple-value-bind (ntype nindex)
+             (accessor-miss-values gf applicable args)
+           
+           ;; The following lexical functions change the state of the dfun to that which is their
+           ;; name.  They accept arguments which are the parameters of the new state, and get other
+           ;; information from the lexical variables bound above. 
+           (flet ((two-class (index w0 w1)
+                         (when (zerop (random 2))
+                               (psetf w0 w1 w1 w0))
+                         (ecase ntype
+                             (reader (update-to-two-class-readers-dfun gf w0 w1 index))
+                             (writer (update-to-two-class-writers-dfun gf w0 w1 index))))
+                  (one-index (index &optional field cache)
+                         (ecase ntype
+                             (reader (update-to-one-index-readers-dfun gf index field cache))
+                             (writer (update-to-one-index-writers-dfun gf index field cache))))
+                  (n-n (&optional field cache)
+                       (ecase ntype
+                           (reader (update-to-n-n-readers-dfun gf field cache))
+                           (writer (update-to-n-n-writers-dfun gf field cache))))
+                  (checking nil (update-to-checking-dfun gf nfunction))
+                  
+                  ;; 
+                  (do-fill (valuep limit-fn update-fn)
+                         (multiple-value-bind (nfield ncache)
+                             (fill-cache field cache 1 valuep limit-fn wrappers nindex)
+                           (unless (and (= nfield field)
+                                        (eq ncache cache))
+                                  (funcall update-fn nfield ncache)))))
+                 (cond ((null nfunction)
+                        (apply #'no-applicable-method gf args))
+                       ((null ntype)
+                        (checking)
+                        (apply nfunction args))
+                       ((or invalidp (null nindex))
+                        (apply nfunction args))
+                       ((not (or (std-instance-p object)
+                                 (fsc-instance-p object)))
+                        (checking)
+                        (apply nfunction args))
+                       ((neq ntype otype)
+                        (checking)
+                        (apply nfunction args))
+                       (t (ecase ostate
+                              (one-class (if (eql nindex oindex)
+                                             (two-class nindex ow0 wrappers)
+                                             (n-n)))
+                              (two-class (if (eql nindex oindex)
+                                             (one-index nindex)
+                                             (n-n)))
+                              (one-index (if (eql nindex oindex)
+                                             (do-fill nil #'one-index-limit-fn
+                                                    #'(lambda (nfield ncache)
+                                                             (one-index nindex nfield ncache)))
+                                             (n-n)))
+                              (n-n (unless (consp nindex)
+                                       (do-fill t #'n-n-accessors-limit-fn #'n-n))))
+                          (apply nfunction args)))))))))
+
+(defun checking-miss (generic-function args ofunction field cache)
+       (protect-cache-miss-code generic-function args
+              (let* ((arg-info (gf-arg-info generic-function))
+                     (nkeys (arg-info-nkeys arg-info)))
+                    (multiple-value-bind (wrappers invalidp nfunction)
+                        (cache-miss-values generic-function args)
+                      (cond (invalidp (apply nfunction args))
+                            ((null nfunction)
+                             (apply #'no-applicable-method generic-function args))
+                            ((eq ofunction nfunction)
+                             (multiple-value-bind (nfield ncache)
+                                 (fill-cache field cache nkeys nil #'checking-limit-fn wrappers nil)
+                               (unless (and (= nfield field)
+                                            (eq ncache cache))
+                                      (update-to-checking-dfun generic-function nfunction nfield 
+                                             ncache)))
+                             (apply nfunction args))
+                            (t (update-to-caching-dfun generic-function)
+                               (apply nfunction args)))))))
+
+(defun caching-miss (generic-function args ofield ocache)
+       (protect-cache-miss-code generic-function args
+              (let* ((arg-info (gf-arg-info generic-function))
+                     (nkeys (arg-info-nkeys arg-info)))
+                    (multiple-value-bind (wrappers invalidp function)
+                        (cache-miss-values generic-function args)
+                      (cond (invalidp (apply function args))
+                            ((null function)
+                             (apply #'no-applicable-method generic-function args))
+                            (t (multiple-value-bind (nfield ncache)
+                                   (fill-cache ofield ocache nkeys t #'caching-limit-fn wrappers 
+                                          function)
+                                 (unless (and (= nfield ofield)
+                                              (eq ncache ocache))
+                                        (update-to-caching-dfun generic-function nfield ncache)))
+                               (apply function args)))))))
+
+
+;;; Some useful support functions which are shared by the implementations of the different kinds of
+;;; dfuns. Given a generic function and a set of arguments to that generic function, returns a mess
+;;; of values. <wrappers>   Is a single wrapper if the generic function has only one key, that is
+;;; arg-info-nkeys of the arg-info is 1. Otherwise a list of the wrappers of the specialized
+;;; arguments to the generic function. Note that all these wrappers are valid.  This function does
+;;; invalid wrapper traps when it finds an invalid wrapper and then returns the new, valid wrapper.
+;;; <invalidp>   True if any of the specialized arguments had an invalid wrapper, false otherwise.
+;;; <function>   The compiled effective method function for this set of arguments.  Gotten from
+;;; get-secondary-dispatch-function so effective-method-function caching is in effect, and that is
+;;; important since it is what keeps us in checking dfun state when possible. <type>       READER or
+;;; WRITER when the only method that would be run is a standard reader or writer method.  To be
+;;; specific, the value is READER when the method combination is eq to
+;;; *standard-method-combination*; there are no applicable :before, :after or :around methods; and
+;;; the most specific primary method is a standard reader method. <index>      If <type> is READER
+;;; or WRITER, and the slot accessed is an :instance slot, this is the index number of that slot in
+;;; the object argument. <applicable> Sorted list of applicable methods. 
+
+
+(defun cache-miss-values (generic-function args)
+       (declare (values wrappers invalidp function applicable))
+       (multiple-value-bind (function appl arg-info)
+           (get-secondary-dispatch-function generic-function args)
+         (multiple-value-bind (wrappers invalidp)
+             (get-wrappers generic-function args arg-info)
+           (values wrappers invalidp (cache-miss-values-function generic-function function)
+                  appl))))
+
+(defun get-wrappers (generic-function args &optional arg-info)
+       (let* ((invalidp nil)
+              (wrappers nil)
+              (arg-info (or arg-info (gf-arg-info generic-function)))
+              (metatypes (arg-info-metatypes arg-info))
+              (nkeys (arg-info-nkeys arg-info)))
+             (flet ((get-valid-wrapper (x)
+                           (let ((wrapper (wrapper-of x)))
+                                (cond ((invalid-wrapper-p wrapper)
+                                       (setq invalidp t)
+                                       (check-wrapper-validity x))
+                                      (t wrapper)))))
+                   (setq wrappers (block collect-wrappers
+                                      (gathering1 (collecting)
+                                             (iterate ((arg (list-elements args))
+                                                       (metatype (list-elements metatypes)))
+                                                    (when (neq metatype 't)
+                                                        (if (= nkeys 1)
+                                                            (return-from collect-wrappers
+                                                                   (get-valid-wrapper arg))
+                                                            (gather1 (get-valid-wrapper arg))))))))
+                   (values wrappers invalidp))))
+
+(defun cache-miss-values-function (generic-function function)
+       (if (eq *generate-random-code-segments* generic-function)
+           (progn (setq *generate-random-code-segments* nil)
+                  #'(lambda (&rest args)
+                           (declare (ignore args))
+                           nil))
+           function))
+
+(defun generate-random-code-segments (generic-function)
+       (dolist (arglist (generate-arglists generic-function))
+           (let ((*generate-random-code-segments* generic-function))
+                (apply generic-function arglist))))
+
+(defun generate-arglists (generic-function)
+       
+       ;; Generate arglists using class-prototypes and eql-specializer-objects to get all the
+       ;; "different" values that could be returned by get-secondary-dispatch-function for this
+       ;; generic-function. 
+       (let ((methods (generic-function-methods generic-function)))
+            (mapcar #'(lambda (class-list)
+                             (mapcar #'(lambda (specializer)
+                                              (if (eql-specializer-p specializer)
+                                                  (eql-specializer-object specializer)
+                                                  (class-prototype specializer)))
+                                    (method-specializers (find class-list methods :test
+                                                               #'(lambda (class-list method)
+                                                                        (every 
+                                                                               #'
+                                                                 specializer-applicable-using-class-p
+                                                                               (method-specializers
+                                                                                method)
+                                                                               class-list))))))
+                   (generate-arglist-classes generic-function))))
+
+(defun generate-arglist-classes (generic-function)
+       (let ((methods (generic-function-methods generic-function)))
+            (declare (ignore methods))
+            
+            ;; Finish this sometime.
+            nil))
+
+(defun accessor-miss-values (generic-function applicable args)
+       (declare (values type index))
+       (let ((type (and (eq (generic-function-method-combination generic-function)
+                            *standard-method-combination*)
+                        (every #'(lambda (m)
+                                        (null (method-qualifiers m)))
+                               applicable)
+                        (let ((method (car applicable)))
+                             (cond ((standard-reader-method-p method)
+                                    (and (optimize-slot-value-by-class-p (class-of (car args))
+                                                (accessor-method-slot-name method)
+                                                nil)
+                                         'reader))
+                                   ((standard-writer-method-p method)
+                                    (and (optimize-slot-value-by-class-p (class-of (cadr args))
+                                                (accessor-method-slot-name method)
+                                                t)
+                                         'writer))
+                                   (t nil))))))
+            (values type (and type (let ((wrapper (wrapper-of (case type
+                                                                  (reader (car args))
+                                                                  (writer (cadr args)))))
+                                         (slot-name (accessor-method-slot-name (car applicable))))
+                                        (or (instance-slot-index wrapper slot-name)
+                                            (assq slot-name (wrapper-class-slots wrapper))))))))
diff --git a/clos/2.0/dlap.lisp b/clos/2.0/dlap.lisp
new file mode 100644
index 00000000..e50f0bb8
--- /dev/null
+++ b/clos/2.0/dlap.lisp
@@ -0,0 +1,492 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;; Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+;;;
+
+(defun emit-one-class-reader (class-slot-p)
+       (emit-reader/writer :reader 1 class-slot-p))
+
+(defun emit-one-class-writer (class-slot-p)
+       (emit-reader/writer :writer 1 class-slot-p))
+
+(defun emit-two-class-reader (class-slot-p)
+       (emit-reader/writer :reader 2 class-slot-p))
+
+(defun emit-two-class-writer (class-slot-p)
+       (emit-reader/writer :writer 2 class-slot-p))
+
+(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
+       (let ((instance nil)
+             (arglist nil)
+             (closure-variables nil)
+             (field (wrapper-field 'number)))
+                                                             ; we need some field to do the fast
+                                                             ; obsolete check 
+            (ecase reader/writer
+                (:reader (setq instance (dfun-arg-symbol 0)
+                               arglist
+                               (list instance)))
+                (:writer (setq instance (dfun-arg-symbol 1)
+                               arglist
+                               (list (dfun-arg-symbol 0)
+                                     instance))))
+            (ecase 1-or-2-class
+                (1 (setq closure-variables '(wrapper-0 index miss-fn)))
+                (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
+            (generating-lap
+             closure-variables arglist
+             (with-lap-registers ((inst t)
+                                                             ; reg for the instance
+                                  (wrapper vector)
+                                                             ; reg for the wrapper
+                                  (cache-no index))
+                                                             ; reg for the cache no
+                    (let ((index cache-no)
+                                                             ; This register is used for different
+                                                             ; values at different times. 
+                          (slots (and (null class-slot-p)
+                                      (allocate-register 'vector)))
+                          (csv (and class-slot-p (allocate-register t))))
+                         (prog1 (flatten-lap (opcode :move (operand :arg instance)
+                                                    inst)
+                                                             ; get the instance
+                                       (opcode :std-instance-p inst 'std-instance)
+                                                             ; if not either std-inst
+                                       (opcode :fsc-instance-p inst 'fsc-instance)
+                                                             ; or fsc-instance then
+                                       (opcode :go 'trap)
+                                                             ; we lose
+                                       (opcode :label 'fsc-instance)
+                                       (opcode :move (operand :fsc-wrapper inst)
+                                              wrapper)
+                                       (and slots (opcode :move (operand :fsc-slots inst)
+                                                         slots))
+                                       (opcode :go 'have-wrapper)
+                                       (opcode :label 'std-instance)
+                                       (opcode :move (operand :std-wrapper inst)
+                                              wrapper)
+                                       (and slots (opcode :move (operand :std-slots inst)
+                                                         slots))
+                                       (opcode :label 'have-wrapper)
+                                       (opcode :move (operand :cref wrapper field)
+                                              cache-no)
+                                       (opcode :izerop cache-no 'trap)
+                                                             ; obsolete wrapper?
+                                       (ecase 1-or-2-class
+                                           (1 (emit-check-1-class-wrapper wrapper 'wrapper-0
+                                                     'trap))
+                                           (2 (emit-check-2-class-wrapper wrapper 'wrapper-0
+                                                     'wrapper-1
+                                                     'trap)))
+                                       (if class-slot-p
+                                           (flatten-lap (opcode :move (operand :cvar 'index)
+                                                               csv)
+                                                  (ecase reader/writer
+                                                      (:reader (emit-get-class-slot csv 'trap inst))
+                                                      (:writer (emit-set-class-slot csv (car arglist)
+                                                                      inst))))
+                                           (flatten-lap (opcode :move (operand :cvar 'index)
+                                                               index)
+                                                  (ecase reader/writer
+                                                      (:reader (emit-get-slot slots index
+                                                                      'trap inst))
+                                                      (:writer (emit-set-slot slots index
+                                                                      (car arglist)
+                                                                      inst)))))
+                                       (opcode :label 'trap)
+                                       (emit-miss 'miss-fn))
+                             (when slots (deallocate-register slots))
+                             (when csv (deallocate-register csv))))))))
+
+(defun emit-one-index-readers (class-slot-p)
+       (let ((arglist (list (dfun-arg-symbol 0))))
+            (generating-lap '(field cache mask size index miss-fn)
+                   arglist
+                   (with-lap-registers ((slots vector))
+                          (emit-dlap arglist '(standard-instance)
+                                 'trap
+                                 (with-lap-registers ((index index))
+                                        (flatten-lap (opcode :move (operand :cvar 'index)
+                                                            index)
+                                               (if class-slot-p
+                                                   (emit-get-class-slot index 'trap slots)
+                                                   (emit-get-slot slots index 'trap))))
+                                 (flatten-lap (opcode :label 'trap)
+                                        (emit-miss 'miss-fn))
+                                 nil
+                                 (and (null class-slot-p)
+                                      (list slots)))))))
+
+(defun emit-one-index-writers (class-slot-p)
+       (let ((arglist (list (dfun-arg-symbol 0)
+                            (dfun-arg-symbol 1))))
+            (generating-lap '(field cache mask size index miss-fn)
+                   arglist
+                   (with-lap-registers ((slots vector))
+                          (emit-dlap arglist '(t standard-instance)
+                                 'trap
+                                 (with-lap-registers ((index index))
+                                        (flatten-lap (opcode :move (operand :cvar 'index)
+                                                            index)
+                                               (if class-slot-p
+                                                   (emit-set-class-slot index (dfun-arg-symbol 0)
+                                                          slots)
+                                                   (emit-set-slot slots index (dfun-arg-symbol 0)))))
+                                 (flatten-lap (opcode :label 'trap)
+                                        (emit-miss 'miss-fn))
+                                 nil
+                                 (and (null class-slot-p)
+                                      (list nil slots)))))))
+
+(defun emit-n-n-readers nil (let ((arglist (list (dfun-arg-symbol 0))))
+                                 (generating-lap '(field cache mask size miss-fn)
+                                        arglist
+                                        (with-lap-registers ((slots vector)
+                                                             (index index))
+                                               (emit-dlap arglist '(standard-instance)
+                                                      'trap
+                                                      (emit-get-slot slots index 'trap)
+                                                      (flatten-lap (opcode :label 'trap)
+                                                             (emit-miss 'miss-fn))
+                                                      index
+                                                      (list slots))))))
+
+(defun emit-n-n-writers nil (let ((arglist (list (dfun-arg-symbol 0)
+                                                 (dfun-arg-symbol 1))))
+                                 (generating-lap '(field cache mask size miss-fn)
+                                        arglist
+                                        (with-lap-registers ((slots vector)
+                                                             (index index))
+                                               (flatten-lap (emit-dlap arglist '(t standard-instance)
+                                                                   'trap
+                                                                   (emit-set-slot slots index
+                                                                          (dfun-arg-symbol 0))
+                                                                   (flatten-lap (opcode :label
+                                                                                       'trap)
+                                                                          (emit-miss 'miss-fn))
+                                                                   index
+                                                                   (list nil slots)))))))
+
+(defun emit-checking (metatypes applyp)
+       (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
+            (generating-lap '(field cache mask size function miss-fn)
+                   dlap-lambda-list
+                   (emit-dlap (remove '&rest dlap-lambda-list)
+                          metatypes
+                          'trap
+                          (with-lap-registers (#'t)
+                                 (flatten-lap (opcode :move (operand :cvar 'function)
+                                                     function)
+                                        (opcode :jmp function)))
+                          (with-lap-registers ((miss-function t))
+                                 (flatten-lap (opcode :label 'trap)
+                                        (opcode :move (operand :cvar 'miss-fn)
+                                               miss-function)
+                                        (opcode :jmp miss-function)))
+                          nil))))
+
+(defun emit-caching (metatypes applyp)
+       (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
+            (generating-lap '(field cache mask size miss-fn)
+                   dlap-lambda-list
+                   (with-lap-registers (#'t)
+                          (emit-dlap (remove '&rest dlap-lambda-list)
+                                 metatypes
+                                 'trap
+                                 (flatten-lap (opcode :jmp function))
+                                 (with-lap-registers ((miss-function t))
+                                        (flatten-lap (opcode :label 'trap)
+                                               (opcode :move (operand :cvar 'miss-fn)
+                                                      miss-function)
+                                               (opcode :jmp miss-function)))
+                                 function)))))
+
+(defun emit-check-1-class-wrapper (wrapper cwrapper-0 miss-label)
+       (with-lap-registers ((cwrapper vector))
+              (flatten-lap (opcode :move (operand :cvar cwrapper-0)
+                                  cwrapper)
+                     (opcode :neq wrapper cwrapper miss-label))))
+
+                                                             ; wrappers not eq, trap
+
+
+(defun emit-check-2-class-wrapper (wrapper cwrapper-0 cwrapper-1 miss-label)
+       (with-lap-registers ((cwrapper vector))
+              (flatten-lap (opcode :move (operand :cvar cwrapper-0)
+                                  cwrapper)
+                                                             ; This is an OR.  Isn't
+                     (opcode :eq wrapper cwrapper 'hit-internal)
+                                                             ; assembly code fun
+                     (opcode :move (operand :cvar cwrapper-1)
+                            cwrapper)
+                                                             ; 
+                     (opcode :neq wrapper cwrapper miss-label)
+                                                             ; 
+                     (opcode :label 'hit-internal))))
+
+(defun emit-get-slot (slots index trap-label &optional temp)
+       (let ((slot-unbound (operand :constant *slot-unbound*)))
+            (with-lap-registers ((val t :reuse temp))
+                   (flatten-lap (opcode :move (operand :iref slots index)
+                                       val)
+                                                             ; get slot value
+                          (opcode :eq val slot-unbound trap-label)
+                                                             ; is the slot unbound?
+                          (opcode :return val)))))
+
+                                                             ; return the slot value
+
+
+(defun emit-set-slot (slots index new-value-arg &optional temp)
+       (with-lap-registers ((new-val t :reuse temp))
+              (flatten-lap (opcode :move (operand :arg new-value-arg)
+                                  new-val)
+                                                             ; get new value into a reg
+                     (opcode :move new-val (operand :iref slots index))
+                                                             ; set slot value
+                     (opcode :return new-val))))
+
+(defun emit-get-class-slot (index trap-label &optional temp)
+       (let ((slot-unbound (operand :constant *slot-unbound*)))
+            (with-lap-registers ((val t :reuse temp))
+                   (flatten-lap (opcode :move (operand :cdr index)
+                                       val)
+                          (opcode :eq val slot-unbound trap-label)
+                          (opcode :return val)))))
+
+(defun emit-set-class-slot (index new-value-arg &optional temp)
+       (with-lap-registers ((new-val t :reuse temp))
+              (flatten-lap (opcode :move (operand :arg new-value-arg)
+                                  new-val)
+                     (opcode :move new-val (operand :cdr index))
+                     (opcode :return new-val))))
+
+(defun emit-miss (miss-fn)
+       (with-lap-registers ((miss-fn-reg t))
+              (flatten-lap (opcode :move (operand :cvar miss-fn)
+                                  miss-fn-reg)
+                                                             ; get the miss function
+                     (opcode :jmp miss-fn-reg))))
+
+                                                             ; and call it
+
+
+(defun dlap-wrappers (metatypes)
+       (mapcar #'(lambda (x)
+                        (and (neq x 't)
+                             (allocate-register 'vector)))
+              metatypes))
+
+(defun dlap-wrapper-moves (wrappers args metatypes miss-label slot-regs)
+       (gathering1 (collecting)
+              (iterate ((mt (list-elements metatypes))
+                        (arg (list-elements args))
+                        (wrapper (list-elements wrappers))
+                        (i (interval :from 0)))
+                     (when wrapper
+                         (gather1 (emit-fetch-wrapper mt arg wrapper miss-label (nth i slot-regs)))))
+              ))
+
+(defun emit-dlap (args metatypes miss-label hit miss value-reg &optional slot-regs)
+       (let* ((wrappers (dlap-wrappers metatypes))
+              (nwrappers (remove nil wrappers))
+              (wrapper-moves (dlap-wrapper-moves wrappers args metatypes miss-label slot-regs)))
+             (prog1 (emit-dlap-internal nwrappers wrapper-moves hit miss miss-label value-reg)
+                 (mapc #'deallocate-register nwrappers))))
+
+(defun emit-dlap-internal (wrapper-regs wrapper-moves hit miss miss-label value-reg)
+       (cond ((cdr wrapper-regs)
+              (emit-greater-than-1-dlap wrapper-regs wrapper-moves hit miss miss-label value-reg))
+             ((null value-reg)
+              (emit-1-nil-dlap (car wrapper-regs)
+                     (car wrapper-moves)
+                     hit miss miss-label))
+             (t (emit-1-t-dlap (car wrapper-regs)
+                       (car wrapper-moves)
+                       hit miss miss-label value-reg))))
+
+(defun emit-1-nil-dlap (wrapper wrapper-move hit miss miss-label)
+       (with-lap-registers ((location index)
+                            (primary index)
+                            (cache vector))
+              (flatten-lap wrapper-move (opcode :move (operand :cvar 'cache)
+                                               cache)
+                     (with-lap-registers ((wrapper-cache-no index))
+                            (flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper 
+                                                primary wrapper-cache-no)
+                                   (opcode :move primary location)
+                                   (emit-check-1-wrapper-in-cache cache location wrapper hit)
+                                                             ; inline hit code
+                                   (opcode :izerop wrapper-cache-no miss-label)))
+                     (with-lap-registers ((size index))
+                            (flatten-lap (opcode :move (operand :cvar 'size)
+                                                size)
+                                   (opcode :label 'loop)
+                                   (opcode :move (operand :i1+ location)
+                                          location)
+                                   (opcode :fix= location primary miss-label)
+                                   (opcode :fix= location size 'set-location-to-min)
+                                   (opcode :label 'continue)
+                                   (emit-check-1-wrapper-in-cache cache location wrapper hit)
+                                   (opcode :go 'loop)
+                                   (opcode :label 'set-location-to-min)
+                                   (opcode :izerop primary miss-label)
+                                   (opcode :move (operand :constant (index-value->index 0))
+                                          location)
+                                   (opcode :go 'continue)))
+                     miss)))
+
+
+;;; The function below implements CACHE-LOCK-COUNT as the first entry in a cache (svref cache 0). 
+;;; This should probably be abstracted. 
+
+
+(defun emit-1-t-dlap (wrapper wrapper-move hit miss miss-label value)
+       (with-lap-registers ((location index)
+                            (primary index)
+                            (cache vector)
+                            (initial-lock-count t))
+              (flatten-lap wrapper-move (opcode :move (operand :cvar 'cache)
+                                               cache)
+                     (with-lap-registers ((wrapper-cache-no index))
+                            (flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper 
+                                                primary wrapper-cache-no)
+                                   (opcode :move primary location)
+                                   (opcode :move (operand :cref cache 0)
+                                          initial-lock-count)
+                                                             ; get lock-count
+                                   (emit-check-cache-entry cache location wrapper 'hit-internal)
+                                   (opcode :izerop wrapper-cache-no miss-label)))
+                                                             ; check for obsolescence
+                     (with-lap-registers ((size index))
+                            (flatten-lap (opcode :move (operand :cvar 'size)
+                                                size)
+                                   (opcode :label 'loop)
+                                   (opcode :move (operand :i1+ location)
+                                          location)
+                                   (opcode :move (operand :i1+ location)
+                                          location)
+                                   (opcode :label 'continue)
+                                   (opcode :fix= location primary miss-label)
+                                   (opcode :fix= location size 'set-location-to-min)
+                                   (emit-check-cache-entry cache location wrapper 'hit-internal)
+                                   (opcode :go 'loop)
+                                   (opcode :label 'set-location-to-min)
+                                   (opcode :izerop primary miss-label)
+                                   (opcode :move (operand :constant (index-value->index 2))
+                                          location)
+                                   (opcode :go 'continue)))
+                     (opcode :label 'hit-internal)
+                     (opcode :move (operand :i1+ location)
+                            location)
+                                                             ; position for getting value
+                     (opcode :move (emit-cache-ref cache location)
+                            value)
+                     (emit-lock-count-test initial-lock-count cache 'hit)
+                     miss
+                     (opcode :label 'hit)
+                     hit)))
+
+(defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value)
+       (let ((cache-line-size (compute-line-size (+ (length wrappers)
+                                                    (if value
+                                                        1
+                                                        0)))))
+            (with-lap-registers ((location index)
+                                 (primary index)
+                                 (cache vector)
+                                 (initial-lock-count t)
+                                 (next-location index)
+                                 (line-size index))
+                                                             ; Line size holds a constant that can
+                                                             ; be folded in if there was a way to
+                                                             ; add a constant to an index register 
+                   (flatten-lap (apply #'flatten-lap wrapper-moves)
+                          (opcode :move (operand :constant cache-line-size)
+                                 line-size)
+                          (opcode :move (operand :cvar 'cache)
+                                 cache)
+                          (emit-n-wrapper-compute-primary-cache-location wrappers primary miss-label)
+                          (opcode :move primary location)
+                          (opcode :move location next-location)
+                          (opcode :move (operand :cref cache 0)
+                                 initial-lock-count)
+                                                             ; get the lock-count
+                          (with-lap-registers ((size index))
+                                 (flatten-lap (opcode :move (operand :cvar 'size)
+                                                     size)
+                                        (opcode :label 'continue)
+                                        (opcode :move (operand :i+ location line-size)
+                                               next-location)
+                                        (emit-check-cache-line cache location wrappers 'hit)
+                                        (emit-adjust-location location next-location primary size
+                                               'continue miss-label)
+                                        (opcode :label 'hit)
+                                        (and value (opcode :move (emit-cache-ref cache location)
+                                                          value))
+                                        (emit-lock-count-test initial-lock-count cache 'hit-internal)
+                                        miss
+                                        (opcode :label 'hit-internal)
+                                        hit))))))
+
+
+;;; Cache related lap code 
+
+
+(defun emit-check-1-wrapper-in-cache (cache location wrapper hit-code)
+       (let ((exit-emit-check-1-wrapper-in-cache (make-symbol "exit-emit-check-1-wrapper-in-cache")))
+            (with-lap-registers ((cwrapper vector))
+                   (flatten-lap (opcode :move (emit-cache-ref cache location)
+                                       cwrapper)
+                          (opcode :neq cwrapper wrapper exit-emit-check-1-wrapper-in-cache)
+                          hit-code
+                          (opcode :label exit-emit-check-1-wrapper-in-cache)))))
+
+(defun emit-check-cache-entry (cache location wrapper hit-label)
+       (with-lap-registers ((cwrapper vector))
+              (flatten-lap (opcode :move (emit-cache-ref cache location)
+                                  cwrapper)
+                     (opcode :eq cwrapper wrapper hit-label))))
+
+(defun emit-check-cache-line (cache location wrappers hit-label)
+       (let ((checks (flatten-lap (gathering1 (flattening-lap)
+                                         (iterate ((wrapper (list-elements wrappers)))
+                                                (with-lap-registers ((cwrapper vector))
+                                                       (gather1 (flatten-lap (opcode :move
+                                                                                    (emit-cache-ref
+                                                                                     cache location)
+                                                                                    cwrapper)
+                                                                       (opcode :neq cwrapper wrapper
+                                                                              
+                                                                              '
+                                                                           exit-emit-check-cache-line
+                                                                              )
+                                                                       (opcode :move (operand :i1+ 
+                                                                                            location)
+                                                                              location)))))))))
+            (flatten-lap checks (opcode :go hit-label)
+                   (opcode :label 'exit-emit-check-cache-line))))
+
+(defun emit-lock-count-test (initial-lock-count cache hit-label)
+       
+       ;; jumps to hit-label if cache-lock-count consistent, otherwise, continues 
+       (with-lap-registers ((new-lock-count t))
+              (flatten-lap (opcode :move (operand :cref cache 0)
+                                  new-lock-count)
+                                                             ; get new cache-lock-count
+                     (opcode :fix= new-lock-count initial-lock-count hit-label))))
+
+(defun emit-adjust-location (location next-location primary size cont-label miss-label)
+       (flatten-lap (opcode :move next-location location)
+              (opcode :fix= location size 'at-end-of-cache)
+              (opcode :fix= location primary miss-label)
+              (opcode :go cont-label)
+              (opcode :label 'at-end-of-cache)
+              (opcode :fix= primary (operand :constant (index-value->index 1))
+                     miss-label)
+              (opcode :move (operand :constant (index-value->index 1))
+                     location)
+              (opcode :go cont-label)))
diff --git a/clos/2.0/env.lisp b/clos/2.0/env.lisp
new file mode 100644
index 00000000..15bf87f2
--- /dev/null
+++ b/clos/2.0/env.lisp
@@ -0,0 +1,200 @@
+;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;; Basic environmental stuff.
+;;;
+
+(in-package 'clos)
+
+
+
+;;;
+;;;
+;;;
+
+(defgeneric describe-object (object stream))
+
+
+(defmethod describe-object ((object standard-object) stream)
+  (let* ((class (class-of object))
+	 (slotds (slots-to-inspect class object))
+	 (max-slot-name-length 0)
+	 (instance-slotds ())
+	 (class-slotds ())
+	 (other-slotds ()))
+    (flet ((adjust-slot-name-length (name)
+	     (setq max-slot-name-length
+		   (max max-slot-name-length
+			(length (the string (symbol-name name))))))
+	   (describe-slot (name value &optional (allocation () alloc-p))
+	     (if alloc-p
+		 (format stream
+			 "~% ~A ~S ~VT  ~S"
+			 name allocation (+ max-slot-name-length 7) value)
+		 (format stream
+			 "~% ~A~VT  ~S"
+			 name max-slot-name-length value))))
+      ;; Figure out a good width for the slot-name column.
+      (dolist (slotd slotds)
+	(adjust-slot-name-length (slotd-name slotd))
+	(case (slotd-allocation slotd)
+	  (:instance (push slotd instance-slotds))
+	  (:class  (push slotd class-slotds))
+	  (otherwise (push slotd other-slotds))))
+      (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))
+      (format stream "~%~S is an instance of class ~S:" object class)
+
+      (when instance-slotds
+	(format stream "~% The following slots have :INSTANCE allocation:")
+	(dolist (slotd (nreverse instance-slotds))
+	  (describe-slot (slotd-name slotd)
+			 (slot-value-or-default object (slotd-name slotd)))))
+
+      (when class-slotds
+	(format stream "~% The following slots have :CLASS allocation:")
+	(dolist (slotd (nreverse class-slotds))
+	  (describe-slot (slotd-name slotd)
+			 (slot-value-or-default object (slotd-name slotd)))))
+
+      (when other-slotds 
+	(format stream "~% The following slots have allocation as shown:")
+	(dolist (slotd (nreverse other-slotds))
+	  (describe-slot (slotd-name slotd)
+			 (slot-value-or-default object (slotd-name slotd))
+			 (slotd-allocation slotd))))
+      (values))))
+
+(defmethod slots-to-inspect ((class std-class) (object standard-object))
+  (class-slots class))
+
+;;;
+;;;
+;;;
+(defmethod describe-object ((class class) stream)
+  (flet ((pretty-class (c) (or (class-name c) c)))
+    (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
+      (ft "~&~S is a class, it is an instance of ~S.~%"
+	  class (pretty-class (class-of class)))
+      (let ((name (class-name class)))
+	(if name
+	    (if (eq class (find-class name nil))
+		(ft "Its proper name is ~S.~%" name)
+		(ft "Its name is ~S, but this is not a proper name.~%" name))
+	    (ft "It has no name (the name is NIL).~%")))
+      (ft "The direct superclasses are: ~:S, and the direct~%~
+           subclasses are: ~:S.  The class precedence list is:~%~S~%~
+           There are ~D methods specialized for this class."
+	  (mapcar #'pretty-class (class-direct-superclasses class))
+	  (mapcar #'pretty-class (class-direct-subclasses class))
+	  (mapcar #'pretty-class (class-precedence-list class))
+	  (length (specializer-methods class))))))
+
+
+
+;;;
+;;; trace-method and untrace-method accept method specs as arguments.  A
+;;; method-spec should be a list like:
+;;;   (<generic-function-spec> qualifiers* (specializers*))
+;;; where <generic-function-spec> should be either a symbol or a list
+;;; of (SETF <symbol>).
+;;;
+;;;   For example, to trace the method defined by:
+;;;
+;;;     (defmethod foo ((x spaceship)) 'ss)
+;;;
+;;;   You should say:
+;;;
+;;;     (trace-method '(foo (spaceship)))
+;;;
+;;;   You can also provide a method object in the place of the method
+;;;   spec, in which case that method object will be traced.
+;;;
+;;; For untrace-method, if an argument is given, that method is untraced.
+;;; If no argument is given, all traced methods are untraced.
+;;;
+(defclass traced-method (method)
+     ((method :initarg :method)
+      (function :initarg :function
+		:reader method-function)
+      (generic-function :initform nil
+			:accessor method-generic-function)))
+
+(defmethod method-lambda-list ((m traced-method))
+  (with-slots (method) m (method-lambda-list method)))
+
+(defmethod method-specializers ((m traced-method))
+  (with-slots (method) m (method-specializers method)))
+
+(defmethod method-qualifiers ((m traced-method))
+  (with-slots (method) m (method-qualifiers method)))
+
+(defmethod method-qualifiers ((m traced-method))
+  (with-slots (method) m (method-qualifiers method)))
+
+(defmethod accessor-method-slot-name ((m traced-method))
+  (with-slots (method) m (accessor-method-slot-name method)))
+
+(defvar *traced-methods* ())
+
+(defun trace-method (spec &rest options)
+  (multiple-value-bind (gf omethod name)
+      (parse-method-or-spec spec)
+    (let* ((tfunction (trace-method-internal (method-function omethod)
+					     name
+					     options))
+	   (tmethod (make-instance 'traced-method
+				   :method omethod
+				   :function tfunction)))
+      (remove-method gf omethod)
+      (add-method gf tmethod)
+      (pushnew tmethod *traced-methods*)
+      tmethod)))
+
+(defun untrace-method (&optional spec)  
+  (flet ((untrace-1 (m)
+	   (let ((gf (method-generic-function m)))
+	     (when gf
+	       (remove-method gf m)
+	       (add-method gf (slot-value m 'method))
+	       (setq *traced-methods* (remove m *traced-methods*))))))
+    (if (not (null spec))
+	(multiple-value-bind (gf method)	    
+	    (parse-method-or-spec spec)
+	  (declare (ignore gf))
+	  (if (memq method *traced-methods*)
+	      (untrace-1 method)
+	      (error "~S is not a traced method?" method)))
+	(dolist (m *traced-methods*) (untrace-1 m)))))
+
+(defun trace-method-internal (ofunction name options)
+  (eval `(untrace ,name))
+  (setf (symbol-function name) ofunction)
+  (eval `(trace ,name ,@options))
+  (symbol-function name))
+
+
+
+
+;(defun compile-method (spec)
+;  (multiple-value-bind (gf method name)
+;      (parse-method-or-spec spec)
+;    (declare (ignore gf))
+;    (compile name (method-function method))
+;    (setf (method-function method) (symbol-function name))))
+
+(defmacro undefmethod (&rest args)
+  #+(or (not :lucid) :lcl3.0)
+  (declare (arglist name {method-qualifier}* specializers))
+  `(undefmethod-1 ',args))
+
+(defun undefmethod-1 (args)
+  (multiple-value-bind (gf method)
+      (parse-method-or-spec args)
+    (when (and gf method)
+      (remove-method gf method)
+      method)))
+
diff --git a/clos/2.0/fin.lisp b/clos/2.0/fin.lisp
new file mode 100644
index 00000000..c8de5102
--- /dev/null
+++ b/clos/2.0/fin.lisp
@@ -0,0 +1,235 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 26-Mar-91 10:33:34 from source fin
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>fin.;3 created 19-Feb-91 16:21:49
+
+;;;. Copyright (c) 1991 by Venue
+
+
+
+
+(in-package "CLOS")
+
+;;; Shadow, Export, Require, Use-package, and Import forms should follow here
+
+
+
+
+
+
+;; 
+
+
+
+;;; FUNCALLABLE INSTANCES
+
+
+
+;; 
+
+
+
+;;; The first part of the file contains the implementation dependent code to implement funcallable
+;;; instances.  Each implementation must provide the following functions and macros:
+;;; ALLOCATE-FUNCALLABLE-INSTANCE-1 () should create and return a new funcallable instance.  The
+;;; funcallable-instance-data slots must be initialized to NIL. This is called by
+;;; allocate-funcallable-instance and by the bootstrapping code. FUNCALLABLE-INSTANCE-P (x) the
+;;; obvious predicate.  This should be an INLINE function. it must be funcallable, but it would be
+;;; nice if it compiled open. SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value) change the fin so
+;;; that when it is funcalled, the new-value function is called.  Note that it is legal for
+;;; new-value to be copied before it is installed in the fin, specifically there is no accessor for
+;;; a FIN's function so this function does not have to preserve the actual new value.  The new-value
+;;; argument can be any funcallable thing, a closure, lambda compiled code etc.  This function must
+;;; coerce those values if necessary. NOTE: new-value is almost always a compiled closure.  This is
+;;; the important case to optimize. FUNCALLABLE-INSTANCE-DATA-1 (fin data-name) should return the
+;;; value of the data named data-name in the fin. data-name is one of the symbols in the list which
+;;; is the value of funcallable-instance-data.  Since data-name is almost always a quoted symbol and
+;;; funcallable-instance-data is a constant, it is possible (and worthwhile) to optimize the
+;;; computation of data-name's offset in the data part of the fin. This must be SETF'able. 
+
+
+(defconstant funcallable-instance-data '(wrapper slots)
+       "These are the 'data-slots' which funcallable instances have so that
+   the meta-class funcallable-standard-class can store class, and static
+   slots in them.")
+
+(defmacro funcallable-instance-data-position (data)
+       (if (and (consp data)
+                (eq (car data)
+                    'quote)
+                (boundp 'funcallable-instance-data))
+           (or (position (cadr data)
+                      funcallable-instance-data :test #'eq)
+               (progn (warn "Unknown funcallable-instance data: ~S." (cadr data))
+                      `(error "Unknown funcallable-instance data: ~S." ',(cadr data))))
+           `(position ,data funcallable-instance-data :test #'eq)))
+
+(defun called-fin-without-function nil (error "Attempt to funcall a funcallable-instance without first~%~
+          setting its funcallable-instance-function."))
+
+
+;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and CCODEP.  The environment
+;;; is represented as a block.  There is space in the top 8 bits of the pointers to the CCODE and
+;;; the environment to use to mark the closure as being a FIN. To help the debugger figure out when
+;;; it has found a FIN on the stack, we reserve the last element of the closure environment to use
+;;; to point back to the actual fin. Note that there is code in xerox-low which lets us access the
+;;; fields of compiled-closures and which defines the closure-overlay record.  That code is there
+;;; because there are some clients of it in that file. 
+
+
+
+;; Don't be fooled.  We actually allocate one bigger than this to have a place to store the
+;; backpointer to the fin.  -smL 
+
+
+(defconstant funcallable-instance-closure-size 15)
+
+(defvar *fin-env-type* (type-of (il:\\allocblock (1+ funcallable-instance-closure-size)
+                                       t)))
+
+
+;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL
+
+
+(defstruct fin-env-pointer (pointer nil :type il:fullxpointer))
+
+(defun fin-env-fin (fin-env)
+       (fin-env-pointer-pointer (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2))))
+
+(defun |set fin-env-fin| (fin-env new-value)
+       (il:\\rplptr fin-env (* funcallable-instance-closure-size 2)
+              (make-fin-env-pointer :pointer new-value))
+       new-value)
+
+(defsetf fin-env-fin |set fin-env-fin|)
+
+
+;; The finalization function that will clean up the backpointer from the fin-env to the fin.  This
+;; needs to be careful to not cons at all.  This depends on there being no other finalization
+;; function on compiled-closures, since there is only one finalization function per datatype.  Too
+;; bad.  -smL 
+
+
+(defun finalize-fin (fin)
+       
+       ;; This could use the fn funcallable-instance-p, but if we get here we know that this is a
+       ;; closure, so we can skip that test. 
+       (when (il:fetch (closure-overlay funcallable-instance-p)
+                    il:of fin)
+           (let ((env (il:fetch (il:compiled-closure il:environment)
+                             il:of fin)))
+                (when env
+                    (setq env (il:\\getbaseptr env (* funcallable-instance-closure-size 2)))
+                    (when (typep env 'fin-env-pointer)
+                        (setf (fin-env-pointer-pointer env)
+                              nil)))))
+       nil)
+
+(eval-when (load)
+       
+       ;; Install the above finalization function.
+       (when (fboundp 'finalize-fin)
+           (il:\\set.finalization.function 'il:compiled-closure 'finalize-fin)))
+
+(defun allocate-funcallable-instance-1 nil (let* ((env (il:\\allocblock (1+ 
+                                                                    funcallable-instance-closure-size
+                                                                            )
+                                                              t))
+                                                  (fin (il:make-compiled-closure nil env)))
+                                                 (setf (fin-env-fin env)
+                                                       fin)
+                                                 (il:replace (closure-overlay funcallable-instance-p)
+                                                        il:of fin il:with 't)
+                                                 (set-funcallable-instance-function
+                                                  fin
+                                                  #'(lambda (&rest ignore)
+                                                           (declare (ignore ignore))
+                                                           (called-fin-without-function)))
+                                                 fin))
+
+(xcl:definline funcallable-instance-p (x)
+       (and (typep x 'il:compiled-closure)
+            (il:fetch (closure-overlay funcallable-instance-p)
+                   il:of x)))
+
+(defun set-funcallable-instance-function (fin new)
+       (cond ((not (funcallable-instance-p fin))
+              (error "~S is not a funcallable-instance" fin))
+             ((not (functionp new))
+              (error "~S is not a function." new))
+             ((typep new 'il:compiled-closure)
+              (let* ((fin-env (il:fetch (il:compiled-closure il:environment)
+                                     il:of fin))
+                     (new-env (il:fetch (il:compiled-closure il:environment)
+                                     il:of new))
+                     (new-env-size (if new-env
+                                       (il:\\#blockdatacells new-env)
+                                       0))
+                     (fin-env-size (- funcallable-instance-closure-size (length 
+                                                                            funcallable-instance-data
+                                                                               ))))
+                    (cond ((and new-env (<= new-env-size fin-env-size))
+                           (dotimes (i fin-env-size)
+                               (il:\\rplptr fin-env (* i 2)
+                                      (if (< i new-env-size)
+                                          (il:\\getbaseptr new-env (* i 2))
+                                          nil)))
+                           (setf (compiled-closure-fnheader fin)
+                                 (compiled-closure-fnheader new)))
+                          (t (set-funcallable-instance-function fin (make-trampoline new))))))
+             (t (set-funcallable-instance-function fin (make-trampoline new)))))
+
+(defun make-trampoline (function)
+       #'(lambda (&rest args)
+                (apply function args)))
+
+(defmacro funcallable-instance-data-1 (fin data)
+       `(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment)
+                                il:of
+                                ,fin)
+               (* (- funcallable-instance-closure-size (funcallable-instance-data-position
+                                                        ,data)
+                     1)
+                                                             ; Reserve last element to point back to
+                                                             ; actual FIN! 
+                  2)))
+
+(defsetf funcallable-instance-data-1 (fin data)
+       (new-value)
+       `(il:\\rplptr (il:fetch (il:compiled-closure il:environment)
+                            il:of
+                            ,fin)
+               (* (- funcallable-instance-closure-size (funcallable-instance-data-position
+                                                        ,data)
+                     1)
+                  2)
+               ,new-value))
+
+                                                             ; end of #+Xerox
+
+
+
+;;; 
+
+
+(defmacro fsc-instance-p (fin)
+       `(funcallable-instance-p ,fin))
+
+(defmacro fsc-instance-class (fin)
+       `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))
+
+(defmacro fsc-instance-wrapper (fin)
+       `(funcallable-instance-data-1 ,fin 'wrapper))
+
+(defmacro fsc-instance-slots (fin)
+       `(funcallable-instance-data-1 ,fin 'slots))
+
+(defun allocate-funcallable-instance (wrapper number-of-static-slots)
+       (let ((fin (allocate-funcallable-instance-1))
+             (slots (%allocate-static-slot-storage--class number-of-static-slots)))
+            (setf (fsc-instance-wrapper fin)
+                  wrapper
+                  (fsc-instance-slots fin)
+                  slots)
+            fin))
diff --git a/clos/2.0/fixup.lisp b/clos/2.0/fixup.lisp
new file mode 100644
index 00000000..13d1c52c
--- /dev/null
+++ b/clos/2.0/fixup.lisp
@@ -0,0 +1,15 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+
+(eval-when (compile load eval)
+       (fix-early-generic-functions)
+       (setq *boot-state* 'complete))
+
+(defun print-std-instance (instance stream depth)
+       (declare (ignore depth))
+       (print-object instance stream))
diff --git a/clos/2.0/fngen.lisp b/clos/2.0/fngen.lisp
new file mode 100644
index 00000000..09e6d0da
--- /dev/null
+++ b/clos/2.0/fngen.lisp
@@ -0,0 +1,172 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+
+
+;;; GET-FUNCTION is the main user interface to this code.  If it is called with a lambda expression
+;;; only, it will return a corresponding function. The optional constant-converter argument, can be
+;;; a function which will be called to convert each constant appearing in the lambda to whatever
+;;; value should appear in the function. Whether the returned function is actually compiled depends
+;;; on whether the compiler is present (see COMPILE-LAMBDA) and whether this shape of code was
+;;; precompiled. 
+
+
+(defun get-function (lambda &optional (test-converter #'default-test-converter)
+                           (code-converter #'default-code-converter)
+                           (constant-converter #'default-constant-converter))
+       (apply (get-function-generator lambda test-converter code-converter)
+              (compute-constants lambda constant-converter)))
+
+(defun default-test-converter (form)
+       (if (not (constantp form))
+           form
+           '.constant.))
+
+(defun default-code-converter (form)
+       (if (not (constantp form))
+           form
+           (let ((gensym (gensym)))
+                (values gensym (list gensym)))))
+
+(defun default-constant-converter (form)
+       (and (constantp form)
+            (list (if (and (consp form)
+                           (eq (car form)
+                               'quote))
+                                                             ; This had better
+                      (cadr form)
+                                                             ; do the same as
+                      form))))
+
+                                                             ; EVAL would have.
+
+
+
+;;; *fgens* is a list of all the function generators we have so far.  Each element is a FGEN
+;;; structure as implemented below.  Don't ever touch this list by hand, use STORE-FGEN. 
+
+
+(defvar *fgens* nil)
+
+(defun store-fgen (fgen)
+       (setq *fgens* (nconc *fgens* (list fgen))))
+
+(defun lookup-fgen (test)
+       (find test (the list *fgens*)
+             :key
+             #'fgen-test :test #'equal))
+
+(defun make-fgen (test gensyms generator generator-lambda system)
+       (let ((new (make-array 6)))
+            (setf (svref new 0)
+                  test
+                  (svref new 1)
+                  gensyms
+                  (svref new 2)
+                  generator
+                  (svref new 3)
+                  generator-lambda
+                  (svref new 4)
+                  system)
+            new))
+
+(defun fgen-test (fgen)
+       (svref fgen 0))
+
+(defun fgen-gensyms (fgen)
+       (svref fgen 1))
+
+(defun fgen-generator (fgen)
+       (svref fgen 2))
+
+(defun fgen-generator-lambda (fgen)
+       (svref fgen 3))
+
+(defun fgen-system (fgen)
+       (svref fgen 4))
+
+(defun get-function-generator (lambda test-converter code-converter)
+       (let* ((test (compute-test lambda test-converter))
+              (fgen (lookup-fgen test)))
+             (if fgen
+                 (fgen-generator fgen)
+                 (get-new-function-generator lambda test code-converter))))
+
+(defun get-new-function-generator (lambda test code-converter)
+       (multiple-value-bind (gensyms generator-lambda)
+              (get-new-function-generator-internal lambda code-converter)
+              (let* ((generator (compile-lambda generator-lambda))
+                     (fgen (make-fgen test gensyms generator generator-lambda nil)))
+                    (store-fgen fgen)
+                    generator)))
+
+(defun get-new-function-generator-internal (lambda code-converter)
+       (multiple-value-bind (code gensyms)
+              (compute-code lambda code-converter)
+              (values gensyms `(lambda ,gensyms #',code))))
+
+(defun compute-test (lambda test-converter)
+       (walk-form lambda nil #'(lambda (f c e)
+                                      (declare (ignore e))
+                                      (if (neq c :eval)
+                                          f
+                                          (let ((converted (funcall test-converter f)))
+                                               (values converted (neq converted f)))))))
+
+(defun compute-code (lambda code-converter)
+       (let ((gensyms nil))
+            (values (walk-form lambda nil #'(lambda (f c e)
+                                                   (declare (ignore e))
+                                                   (if (neq c :eval)
+                                                       f
+                                                       (multiple-value-bind
+                                                        (converted gens)
+                                                        (funcall code-converter f)
+                                                        (when gens
+                                                            (setq gensyms (append gensyms gens)))
+                                                        (values converted (neq converted f))))))
+                   gensyms)))
+
+(defun compute-constants (lambda constant-converter)
+       (macrolet ((appending nil `(let ((result nil))
+                                       (values #'(lambda (value)
+                                                        (setq result (append result value)))
+                                              #'(lambda nil result)))))
+              (gathering1 (appending)
+                     (walk-form lambda nil #'(lambda (f c e)
+                                                    (declare (ignore e))
+                                                    (if (neq c :eval)
+                                                        f
+                                                        (let ((consts (funcall constant-converter f))
+                                                              )
+                                                             (if consts
+                                                                 (progn (gather1 consts)
+                                                                        (values f t))
+                                                                 f))))))))
+
+
+;;; 
+
+
+(defmacro
+ precompile-function-generators
+ (&optional system)
+ (make-top-level-form
+  `(precompile-function-generators ,system)
+  '(load)
+  `(progn ,@(gathering1 (collecting)
+                   (dolist (fgen *fgens*)
+                       (when (or (null (fgen-system fgen))
+                                 (eq (fgen-system fgen)
+                                     system))
+                           (gather1 `(load-function-generator ',(fgen-test fgen)
+                                            ',(fgen-gensyms fgen)
+                                            #',(fgen-generator-lambda fgen)
+                                            ',(fgen-generator-lambda fgen)
+                                            ',system))))))))
+
+(defun load-function-generator (test gensyms generator generator-lambda system)
+       (store-fgen (make-fgen test gensyms generator generator-lambda system)))
diff --git a/clos/2.0/fsc.lisp b/clos/2.0/fsc.lisp
new file mode 100644
index 00000000..a2670af9
--- /dev/null
+++ b/clos/2.0/fsc.lisp
@@ -0,0 +1,72 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;;. Copyright (c) 1991 by Venue
+
+
+(in-package "CLOS")
+
+
+;;; This file contains the
+;;; definition of the FUNCALLABLE-STANDARD-CLASS metaclass.  Much of the implementation of this
+;;; metaclass is actually defined on the class STD-CLASS.  What appears in this file is a modest
+;;; number of simple methods related to the low-level differences in the implementation of standard
+;;; and funcallable-standard instances. As it happens, none of these differences are the ones
+;;; reflected in the MOP specification; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS share all
+;;; their specified methods at STD-CLASS. workings of this metaclass and the standard-class
+;;; metaclass. 
+
+
+(defmethod wrapper-fetcher ((class funcallable-standard-class))
+       'fsc-instance-wrapper)
+
+(defmethod slots-fetcher ((class funcallable-standard-class))
+       'fsc-instance-slots)
+
+(defmethod raw-instance-allocator ((class funcallable-standard-class))
+       'allocate-funcallable-instance-1)
+
+
+;;; 
+
+
+(defmethod check-super-metaclass-compatibility ((fsc funcallable-standard-class)
+                                                (class standard-class))
+       (null (wrapper-instance-slots-layout (class-wrapper class))))
+
+(defmethod allocate-instance ((class funcallable-standard-class)
+                              &rest initargs)
+       (declare (ignore initargs))
+       (unless (class-finalized-p class)
+              (finalize-inheritance class))
+       (let ((class-wrapper (class-wrapper class)))
+            (allocate-funcallable-instance class-wrapper (class-no-of-instance-slots class))))
+
+(defmethod make-reader-method-function ((class funcallable-standard-class)
+                                        slot-name)
+       (make-std-reader-method-function slot-name))
+
+(defmethod make-writer-method-function ((class funcallable-standard-class)
+                                        slot-name)
+       (make-std-writer-method-function slot-name))
+
+                                                             ; See the comment about
+                                                             ; reader-function--std and
+                                                             ; writer-function--sdt.
+                                                             ; (define-function-template
+                                                             ; reader-function--fsc () '(slot-name)
+                                                             ; `(function (lambda (instance)
+                                                             ; (slot-value-using-class
+                                                             ; (wrapper-class (get-wrapper
+                                                             ; instance)) instance slot-name))))
+                                                             ; (define-function-template
+                                                             ; writer-function--fsc () '(slot-name)
+                                                             ; `(function (lambda (nv instance)
+                                                             ; (setf (slot-value-using-class
+                                                             ; (wrapper-class (get-wrapper
+                                                             ; instance)) instance slot-name) nv))))
+                                                             ; (eval-when (load)
+                                                             ; (pre-make-templated-function-constructor
+                                                             ; reader-function--fsc)
+                                                             ; (pre-make-templated-function-constructor
+                                                             ; writer-function--fsc)) 
+
diff --git a/clos/2.0/init.lisp b/clos/2.0/init.lisp
new file mode 100644
index 00000000..d44e50ef
--- /dev/null
+++ b/clos/2.0/init.lisp
@@ -0,0 +1,183 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+;;; this file defines the
+;;; initialization and related protocols. 
+
+
+(defmethod make-instance ((class std-class)
+                          &rest initargs)
+       (unless (class-finalized-p class)
+              (finalize-inheritance class))
+       (setq initargs (default-initargs class initargs))
+       (when initargs
+           (when (and (eq *boot-state* 'complete)
+                      (let ((tail initargs))
+                           (loop (unless tail (return t))
+                                 (when (eq (car tail)
+                                           ':allow-other-keys)
+                                       (return nil))
+                                 (setq tail (cddr tail)))))
+               (check-initargs-1 class initargs (append (compute-applicable-methods 
+                                                               #'allocate-instance (list class))
+                                                       (compute-applicable-methods
+                                                        #'initialize-instance
+                                                        (list (class-prototype class)))
+                                                       (compute-applicable-methods
+                                                        #'shared-initialize
+                                                        (list (class-prototype class)
+                                                              t))))))
+       (let ((instance (apply #'allocate-instance class initargs)))
+            (apply #'initialize-instance instance initargs)
+            instance))
+
+(defmethod make-instance ((class-name symbol)
+                          &rest initargs)
+       (apply #'make-instance (find-class class-name)
+              initargs))
+
+(defvar *default-initargs-flag* (list nil))
+
+(defmethod default-initargs ((class std-class)
+                             supplied-initargs)
+       
+       ;; This implementation of default initargs is critically dependent on all-default-initargs
+       ;; not having any duplicate initargs in it. 
+       (let ((all-default (class-default-initargs class))
+             (miss *default-initargs-flag*))
+            (flet ((getf* (plist key)
+                          (do nil
+                              ((null plist)
+                               miss)
+                            (if (eq (car plist)
+                                    key)
+                                (return (cadr plist))
+                                (setq plist (cddr plist))))))
+                  (labels ((default-1 (tail)
+                                  (if (null tail)
+                                      nil
+                                      (if (eq (getf* supplied-initargs (caar tail))
+                                              miss)
+                                          (list* (caar tail)
+                                                 (funcall (cadar tail))
+                                                 (default-1 (cdr tail)))
+                                          (default-1 (cdr tail))))))
+                         (append supplied-initargs (default-1 all-default))))))
+
+(defmethod initialize-instance ((instance standard-object)
+                                &rest initargs)
+       (apply #'shared-initialize instance t initargs))
+
+(defmethod reinitialize-instance ((instance standard-object)
+                                  &rest initargs)
+       (when initargs
+           (when (eq *boot-state* 'complete)
+               (check-initargs-1 (class-of instance)
+                      initargs
+                      (append (compute-applicable-methods #'reinitialize-instance (list instance))
+                             (compute-applicable-methods #'shared-initialize (list instance t))))))
+       (apply #'shared-initialize instance nil initargs)
+       instance)
+
+(defmethod update-instance-for-different-class ((previous standard-object)
+                                                (current standard-object)
+                                                &rest initargs)
+       (when initargs
+           (check-initargs-1 (class-of current)
+                  initargs
+                  (append (compute-applicable-methods #'update-instance-for-different-class
+                                 (list previous current))
+                         (compute-applicable-methods #'shared-initialize (list current t)))))
+       
+       ;; First we must compute the newly added slots.  The spec defines newly added slots as "those
+       ;; local slots for which no slot of the same name exists in the previous class." 
+       (let ((added-slots 'nil)
+             (current-slotds (class-slots (class-of current)))
+             (previous-slot-names (mapcar #'slotd-name (class-slots (class-of previous)))))
+            (dolist (slotd current-slotds)
+                (if (and (not (memq (slotd-name slotd)
+                                    previous-slot-names))
+                         (eq (slotd-allocation slotd)
+                             ':instance))
+                    (push (slotd-name slotd)
+                          added-slots)))
+            (apply #'shared-initialize current added-slots initargs)))
+
+(defmethod update-instance-for-redefined-class ((instance standard-object)
+                                                added-slots discarded-slots property-list &rest 
+                                                initargs)
+       (declare (ignore discarded-slots property-list))
+       (when initargs
+           (check-initargs-1 (class-of instance)
+                  initargs
+                  (append (compute-applicable-methods #'update-instance-for-redefined-class
+                                 (list instance))
+                         (compute-applicable-methods #'shared-initialize (list instance nil)))))
+       (apply #'shared-initialize instance added-slots initargs))
+
+(defmethod shared-initialize ((instance standard-object)
+                              slot-names &rest initargs)
+       
+       ;; initialize the instance's slots in a two step process 1) A slot for which one of the
+       ;; initargs in initargs can set the slot, should be set by that initarg.  If more than one
+       ;; initarg in initargs can set the slot, the leftmost one should set it. 2) Any slot not set
+       ;; by step 1, may be set from its initform by step 2.  Only those slots specified by the
+       ;; slot-names argument are set.  If slot-names is: T any slot not set in step 1 is set from
+       ;; its initform <list of slot names> any slot in the list, and not set in step 1 is set from
+       ;; its initform () no slots are set from initforms 
+       (let* ((class (class-of instance))
+              (slotds (class-slots class)))
+             (dolist (slotd slotds)
+                 (let ((slot-name (slotd-name slotd))
+                       (slot-initargs (slotd-initargs slotd)))
+                      (flet ((from-initargs nil 
+
+                                    ;; Try to initialize the slot from one of the initargs. If we
+                                    ;; succeed return T, otherwise return nil. 
+                                    (doplist (initarg val)
+                                           initargs
+                                           (when (memq initarg slot-initargs)
+                                               (setf (slot-value instance slot-name)
+                                                     val)
+                                               (return 't))))
+                             (from-initforms nil 
+
+                                    ;; Try to initialize the slot from its initform.  This returns
+                                    ;; no meaningful value. 
+                                    (if (and slot-names (or (eq slot-names 't)
+                                                            (memq slot-name slot-names))
+                                             (not (slot-boundp instance slot-name)))
+                                        (let ((initfunction (slotd-initfunction slotd)))
+                                             (when initfunction
+                                                 (setf (slot-value instance slot-name)
+                                                       (funcall initfunction)))))))
+                            (or (from-initargs)
+                                (from-initforms))))))
+       instance)
+
+
+;;; if initargs are valid return nil, otherwise signal an error 
+
+
+(defun check-initargs-1 (class initargs methods)
+       (let ((legal (apply #'append (mapcar #'slotd-initargs (class-slots class)))))
+            (unless (getf initargs :allow-other-keys)
+                
+                ;; Add to the set of slot-filling initargs the set of initargs that are accepted by
+                ;; the methods.  If at any point we come across &allow-other-keys, we can just quit.
+                (dolist (method methods)
+                    (multiple-value-bind (keys allow-other-keys)
+                        (function-keywords method)
+                      (when allow-other-keys (return-from check-initargs-1 nil))
+                      (setq legal (append keys legal))))
+                
+                ;; Now check the supplied-initarg-names and the default initargs against the total
+                ;; set that we know are legal. 
+                (doplist (key val)
+                       initargs
+                       (unless (memq key legal)
+                           (error "Invalid initialization argument ~S for class ~S" key (class-name
+                                                                                         class)))))))
diff --git a/clos/2.0/iterate.lisp b/clos/2.0/iterate.lisp
new file mode 100644
index 00000000..212f819c
--- /dev/null
+++ b/clos/2.0/iterate.lisp
@@ -0,0 +1,1080 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (CLIN-PACKAGE ITERATE USE (QUOTE (LISP WALKER))) 
+BASE 10)
+(IL:FILECREATED "19-Feb-91 13:55:29" 
+IL:|{DSK}<usr>local>users>welch>lisp>clos>rev4>il-format>ITERATE.;2| 65656  
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:ITERATECOMS)
+
+      IL:|previous| IL:|date:| " 6-Feb-91 11:00:58" 
+IL:|{DSK}<usr>local>users>welch>lisp>clos>rev4>il-format>ITERATE.;1|)
+
+
+; Copyright (c) 1991 by Venue.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:ITERATECOMS)
+
+(IL:RPAQQ IL:ITERATECOMS 
+          (
+
+(IL:* IL:|;;;| "************************************************************************* Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. All rights reserved. Use and copying of this software and preparation of derivative works based upon this software are permitted.  Any distribution of this software or derivative works must comply with all applicable United States export control laws. This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification. Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to: CommonLoops Coordinator Xerox PARC 3333 Coyote Hill Rd. Palo Alto, CA 94304 (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) Suggestions, comments and requests for improvements are also welcome. ************************************************************************* Original source {pooh/n}<pooh>vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33 ")
+
+           (IL:P (IN-PACKAGE :ITERATE :USE '(:LISP :WALKER))
+                 (EXPORT '(ITERATE ITERATE* GATHERING GATHER WITH-GATHERING INTERVAL ELEMENTS 
+                                 LIST-ELEMENTS LIST-TAILS PLIST-ELEMENTS EACHTIME WHILE UNTIL 
+                                 COLLECTING JOINING MAXIMIZING MINIMIZING SUMMING *ITERATE-WARNINGS*)
+                        ))
+           (IL:VARIABLES *ITERATE-WARNINGS*)
+           
+
+(IL:* IL:|;;;| "ITERATE macro")
+
+           (IL:FUNCTIONS ITERATE SIMPLE-EXPAND-ITERATE-FORM)
+           (IL:VARIABLES *ITERATE-TEMP-VARS-LIST*)
+           (IL:FUNCTIONS OPTIMIZE-ITERATE-FORM EXPAND-INTO-LET VARIABLES-FROM-LET 
+                  ITERATE-TRANSFORM-BODY PARSE-DECLARATIONS EXTRACT-SPECIAL-BINDINGS 
+                  FUNCTION-LAMBDA-P RENAME-LET-BINDINGS RENAME-VARIABLES MV-SETQ VARIABLE-SAME-P 
+                  MAYBE-WARN)
+           
+           (IL:* IL:|;;| "Sample iterators")
+
+           (IL:FUNCTIONS INTERVAL LIST-ELEMENTS LIST-TAILS ELEMENTS PLIST-ELEMENTS SEQUENCE-ACCESSOR)
+           
+           (IL:* IL:|;;| "These \"iterators\" may be withdrawn")
+
+           (IL:FUNCTIONS EACHTIME WHILE UNTIL)
+                                                             (IL:* IL:\; "GATHERING macro")
+           (IL:FUNCTIONS GATHERING WITH-GATHERING SIMPLE-EXPAND-GATHERING-FORM)
+           (IL:VARIABLES *ACTIVE-GATHERERS* *ANONYMOUS-GATHERING-SITE*)
+           (IL:FUNCTIONS OPTIMIZE-GATHERING-FORM RENAME-AND-CAPTURE-VARIABLES WALK-GATHERING-BODY)
+           
+           (IL:* IL:|;;| "Sample gatherers")
+
+           (IL:FUNCTIONS COLLECTING JOINING MAXIMIZING MINIMIZING SUMMING)
+                                                             (IL:* IL:\; 
+                                           "Easier to read expanded code if PROG1 gets left alone ")
+           (XCL:FILE-ENVIRONMENTS "ITERATE")))
+
+
+
+(IL:* IL:|;;;| 
+"************************************************************************* Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. All rights reserved. Use and copying of this software and preparation of derivative works based upon this software are permitted.  Any distribution of this software or derivative works must comply with all applicable United States export control laws. This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification. Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to: CommonLoops Coordinator Xerox PARC 3333 Coyote Hill Rd. Palo Alto, CA 94304 (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) Suggestions, comments and requests for improvements are also welcome. ************************************************************************* Original source {pooh/n}<pooh>vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33 "
+)
+
+
+(IN-PACKAGE :ITERATE :USE '(:LISP :WALKER))
+
+(EXPORT '(ITERATE ITERATE* GATHERING GATHER WITH-GATHERING INTERVAL ELEMENTS LIST-ELEMENTS 
+                LIST-TAILS PLIST-ELEMENTS EACHTIME WHILE UNTIL COLLECTING JOINING MAXIMIZING 
+                MINIMIZING SUMMING *ITERATE-WARNINGS*))
+
+(DEFVAR *ITERATE-WARNINGS* :ANY "Controls whether warnings are issued for iterate/gather forms that aren't optimized.
+NIL => never; :USER => those resulting from user code; T => always, even if it's the iteration macro that's suboptimal."
+)
+
+
+
+(IL:* IL:|;;;| "ITERATE macro")
+
+
+(DEFMACRO ITERATE (CLAUSES &BODY BODY &ENVIRONMENT ENV)
+   (OPTIMIZE-ITERATE-FORM CLAUSES BODY ENV))
+
+(DEFUN SIMPLE-EXPAND-ITERATE-FORM (CLAUSES BODY)
+
+   (IL:* IL:|;;| 
+ "Expand ITERATE.  This is the \"formal semantics\" expansion, which we never use. ")
+
+   (LET*
+    ((BLOCK-NAME (GENSYM))
+     (BOUND-VAR-LISTS (MAPCAR #'(LAMBDA (CLAUSE)
+                                       (LET ((NAMES (FIRST CLAUSE)))
+                                            (IF (LISTP NAMES)
+                                                NAMES
+                                                (LIST NAMES))))
+                             CLAUSES))
+     (GENERATOR-VARS (MAPCAR #'(LAMBDA (CLAUSE)
+                                      (DECLARE (IGNORE CLAUSE))
+                                      (GENSYM))
+                            CLAUSES)))
+    `(BLOCK ,BLOCK-NAME
+         (LET*
+          ,(MAPCAN #'(LAMBDA (GVAR CLAUSE VAR-LIST)          (IL:* IL:\; 
+            "For each clause, bind a generator temp to the clause, then bind the specified var(s) ")
+                            (CONS (LIST GVAR (SECOND CLAUSE))
+                                  (COPY-LIST VAR-LIST)))
+                  GENERATOR-VARS CLAUSES BOUND-VAR-LISTS)
+
+          (IL:* IL:|;;| "Note bug in formal semantics: there can be declarations in the head of BODY; they go here, rather than inside loop ")
+
+          (LOOP ,@(MAPCAR #'(LAMBDA (VAR-LIST GEN-VAR)       (IL:* IL:\; 
+   "Set each bound variable (or set of vars) to the result of calling the corresponding generator ")
+                                   `(MULTIPLE-VALUE-SETQ ,VAR-LIST
+                                           (FUNCALL ,GEN-VAR #'(LAMBDA NIL (RETURN-FROM ,BLOCK-NAME))
+                                                  )))
+                         BOUND-VAR-LISTS GENERATOR-VARS)
+                ,@BODY)))))
+
+(DEFPARAMETER *ITERATE-TEMP-VARS-LIST* '(ITERATE-TEMP-1 ITERATE-TEMP-2 ITERATE-TEMP-3 
+                                                   ITERATE-TEMP-4 ITERATE-TEMP-5 ITERATE-TEMP-6 
+                                                   ITERATE-TEMP-7 ITERATE-TEMP-8)
+                                           "Temp var names used by ITERATE expansions.")
+
+(DEFUN OPTIMIZE-ITERATE-FORM (CLAUSES BODY ITERATE-ENV)
+   (LET*
+    ((TEMP-VARS *ITERATE-TEMP-VARS-LIST*)
+     (BLOCK-NAME (GENSYM))
+     (FINISH-FORM `(RETURN-FROM ,BLOCK-NAME))
+     (BOUND-VARS (MAPCAN #'(LAMBDA (CLAUSE)
+                                  (LET ((NAMES (FIRST CLAUSE)))
+                                       (IF (LISTP NAMES)
+                                           (COPY-LIST NAMES)
+                                           (LIST NAMES))))
+                        CLAUSES))
+     ITERATE-DECLS GENERATOR-DECLS UPDATE-FORMS BINDINGS LEFTOVER-BODY)
+    (DO ((TAIL BOUND-VARS (CDR TAIL)))
+        ((NULL TAIL))                                        (IL:* IL:\; "Check for duplicates")
+      (WHEN (MEMBER (CAR TAIL)
+                   (CDR TAIL))
+          (WARN "Variable appears more than once in ITERATE: ~S" (CAR TAIL))))
+    (FLET
+     ((GET-ITERATE-TEMP NIL 
+
+             (IL:* IL:|;;| "Make temporary var.  Note that it is ok to re-use these symbols in each iterate, because they are not used within BODY. ")
+
+             (OR (POP TEMP-VARS)
+                 (GENSYM))))
+     (DOLIST (CLAUSE CLAUSES)
+         (COND
+            ((OR (NOT (CONSP CLAUSE))
+                 (NOT (CONSP (CDR CLAUSE))))
+             (WARN "Bad syntax in ITERATE: clause not of form (var iterator): ~S" CLAUSE))
+            (T
+             (UNLESS (NULL (CDDR CLAUSE))
+                    (WARN "Probable parenthesis error in ITERATE clause--more than 2 elements: ~S" 
+                          CLAUSE))
+             (MULTIPLE-VALUE-BIND (LET-BODY BINDING-TYPE LET-BINDINGS LOCALDECLS OTHERDECLS 
+                                         EXTRA-BODY)
+                 (EXPAND-INTO-LET (SECOND CLAUSE)
+                        'ITERATE ITERATE-ENV)
+
+               (IL:* IL:|;;| 
+             "We have expanded the generator clause and parsed it into its LET pieces. ")
+
+               (PROG* ((VARS (FIRST CLAUSE))
+                       GEN-ARGS RENAMED-VARS)
+                      (SETQ VARS (IF (LISTP VARS)
+                                     (COPY-LIST VARS)
+                                     (LIST VARS)))           (IL:* IL:\; 
+                           "VARS is now a (fresh) list of all iteration vars bound in this clause ")
+                      (COND
+                         ((EQ LET-BODY :ABORT)               (IL:* IL:\; 
+                                                    "Already issued a warning about malformedness ")
+                          )
+                         ((NULL (SETQ LET-BODY (FUNCTION-LAMBDA-P LET-BODY 1)))
+                                                             (IL:* IL:\; "Not of the expected form")
+                          (LET ((GENERATOR (SECOND CLAUSE)))
+                               (COND
+                                  ((AND (CONSP GENERATOR)
+                                        (FBOUNDP (CAR GENERATOR)))
+                                                             (IL:* IL:\; "It looks ok--a macro or function here--so the guy who wrote it just didn't do it in an optimizable way ")
+                                   (MAYBE-WARN :DEFINITION "Could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))"
+                                          GENERATOR))
+                                  (T                         (IL:* IL:\; 
+                                           "Perhaps it's just a misspelling?  Probably user error ")
+                                     (MAYBE-WARN :USER 
+                                            "Iterate operator in clause ~S is not fboundp." GENERATOR
+                                            )))
+                               (SETQ LET-BODY :ABORT)))
+                         (T
+
+                          (IL:* IL:|;;| "We have something of the form #'(LAMBDA (finisharg) ...), possibly with some LET bindings around it.  LET-BODY = ((finisharg) ...). ")
+
+                          (SETQ LET-BODY (CDR LET-BODY))
+                          (SETQ GEN-ARGS (POP LET-BODY))
+                          (WHEN LET-BINDINGS
+
+                              (IL:* IL:|;;| "The first transformation we want to perform is \"LET-eversion\": turn (let* ((generator (let (..bindings..) #'(lambda ...)))) ..body..) into (let* (..bindings.. (generator #'(lambda ...))) ..body..).  This transformation is valid if nothing in body refers to any of the bindings, something we can assure by alpha-converting the inner let (substituting new names for each var).  Of course, none of those vars can be special, but we already checked for that above. ")
+
+                              (MULTIPLE-VALUE-SETQ (LET-BINDINGS RENAMED-VARS)
+                                     (RENAME-LET-BINDINGS LET-BINDINGS BINDING-TYPE ITERATE-ENV 
+                                            LEFTOVER-BODY #'GET-ITERATE-TEMP))
+                              (SETQ LEFTOVER-BODY NIL)       (IL:* IL:\; 
+                                     "If there was any leftover from previous, it is now consumed ")
+                              )
+
+                          (IL:* IL:|;;| "The second transformation is substituting the body of the generator (LAMBDA (finish-arg) . gen-body) for its appearance in the update form (funcall generator #'(lambda () finish-form)), then simplifying that form.  The requirement for this part is that the generator body not refer to any variables that are bound between the generator binding and the appearance in the loop body.  The only variables bound in that interval are generator temporaries, which have unique names so are no problem, and the iteration variables remaining for subsequent clauses.  We'll discover the story as we walk the body. ")
+
+                          (MULTIPLE-VALUE-BIND (FINISHDECL OTHER REST)
+                              (PARSE-DECLARATIONS LET-BODY GEN-ARGS)
+                            (DECLARE (IGNORE FINISHDECL))(IL:* IL:\; "Pull out declares, if any, separating out the one(s) referring to the finish arg, which we will throw away ")
+                            (WHEN OTHER                      (IL:* IL:\; 
+                               "Combine remaining decls with decls extracted from the LET, if any ")
+                                (SETQ OTHERDECLS (NCONC OTHERDECLS OTHER)))
+                            (SETQ LET-BODY (COND
+                                              (OTHERDECLS    (IL:* IL:\; 
+                                 "There are interesting declarations, so have to keep it wrapped. ")
+                                                     `(LET NIL (DECLARE ,@OTHERDECLS)
+                                                           ,@REST))
+                                              ((NULL (CDR REST))
+                                                             (IL:* IL:\; "Only one form left")
+                                               (FIRST REST))
+                                              (T `(PROGN ,@REST)))))
+                          (UNLESS (EQ (SETQ LET-BODY (ITERATE-TRANSFORM-BODY LET-BODY ITERATE-ENV
+                                                            RENAMED-VARS (FIRST GEN-ARGS)
+                                                            FINISH-FORM BOUND-VARS CLAUSE))
+                                      :ABORT)
+
+                              (IL:* IL:|;;| "Skip the rest if transformation failed.  Warning has already been issued. Note possible further optimization: if LET-BODY expanded into (prog1 oldvalue prepare-for-next-iteration), as so many do, then we could in most cases split the PROG1 into two pieces: do the (setq var oldvalue) here, and do the prepare-for-next-iteration at the bottom of the loop. This does a slight optimization of the PROG1 and also rearranges the code in a way that a reasonably clever compiler might detect how to get rid of redundant variables altogether (such as happens with INTERVAL and LIST-TAILS); that would make the whole thing closer to what you might have coded by hand.  However, to do this optimization, we need to assure that (a) the prepare-for-next-iteration refers freely to no vars other than the internal vars we have extracted from the LET, and (b) that the code has no side effects.  These are both true for all the iterators defined by this module, but how shall we represent side-effect info and/or tap into the compiler's knowledge of same? ")
+
+                              (WHEN LOCALDECLS               (IL:* IL:\; "There were declarations for the generator locals--have to keep them for later, and rename the vars mentioned ")
+                                  (SETQ
+                                   GENERATOR-DECLS
+                                   (NCONC
+                                    GENERATOR-DECLS
+                                    (MAPCAR
+                                     #'(LAMBDA (DECL)
+                                              (LET ((HEAD (CAR DECL)))
+                                                   (CONS HEAD (IF (EQ HEAD 'TYPE)
+                                                                  (CONS (SECOND DECL)
+                                                                        (SUBLIS RENAMED-VARS
+                                                                               (CDDR DECL)))
+                                                                  (SUBLIS RENAMED-VARS (CDR DECL)))))
+                                              )
+                                     LOCALDECLS)))))))
+
+                (IL:* IL:|;;| "Finished analyzing clause now.  LET-BODY is the form which, when evaluated, returns updated values for the iteration variable(s) VARS. ")
+
+                      (WHEN (EQ LET-BODY :ABORT)
+
+                          (IL:* IL:|;;| "Some punt case: go with the formal semantics: bind a var to the generator, then call it in the update section ")
+
+                          (LET ((GVAR (GET-ITERATE-TEMP))
+                                (GENERATOR (SECOND CLAUSE)))
+                               (SETQ LET-BINDINGS
+                                     (LIST (LIST GVAR
+                                                 (COND
+                                                    (LEFTOVER-BODY
+                                                             (IL:* IL:\; "Have to use this up")
+                                                     `(PROGN ,@(PROG1 LEFTOVER-BODY (SETQ 
+                                                                                        LEFTOVER-BODY
+                                                                                          NIL))
+                                                             GENERATOR))
+                                                    (T GENERATOR)))))
+                               (SETQ LET-BODY `(FUNCALL ,GVAR #'(LAMBDA NIL ,FINISH-FORM)))))
+                      (PUSH (MV-SETQ (COPY-LIST VARS)
+                                   LET-BODY)
+                            UPDATE-FORMS)
+                      (DOLIST (V VARS)
+                          (DECLARE (IGNORE V))           (IL:* IL:\; "Pop off the vars we have now bound from the list of vars to watch out for--we'll bind them right now ")
+                          (POP BOUND-VARS))
+                      (SETQ BINDINGS (NCONC BINDINGS LET-BINDINGS
+                                            (COND
+                                               (EXTRA-BODY   (IL:* IL:\; 
+                          "There was some computation to do after the bindings--here's our chance ")
+                                                      (CONS (LIST (FIRST VARS)
+                                                                  `(PROGN ,@EXTRA-BODY NIL))
+                                                            (REST VARS)))
+                                               (T VARS))))))))))
+    (DO ((TAIL BODY (CDR TAIL)))
+        ((NOT (AND (CONSP TAIL)
+                   (CONSP (CAR TAIL))
+                   (EQ (CAAR TAIL)
+                       'DECLARE)))
+
+         (IL:* IL:|;;| "TAIL now points at first non-declaration.  If there were declarations, pop them off so they appear in the right place ")
+
+         (UNLESS (EQ TAIL BODY)
+             (SETQ ITERATE-DECLS (LDIFF BODY TAIL))
+             (SETQ BODY TAIL))))
+    `(BLOCK ,BLOCK-NAME
+         (LET* ,BINDINGS ,@(AND GENERATOR-DECLS `((DECLARE ,@GENERATOR-DECLS)))
+               ,@ITERATE-DECLS
+               ,@LEFTOVER-BODY
+               (LOOP ,@(NREVERSE UPDATE-FORMS)
+                     ,@BODY)))))
+
+(DEFUN EXPAND-INTO-LET (CLAUSE PARENT-NAME ENV)
+
+   (IL:* IL:|;;| "Return values: Body, LET[*], bindings, localdecls, otherdecls, extra body, where BODY is a single form.  If multiple forms in a LET, the preceding forms are returned as extra body.  Returns :ABORT if it issued a punt warning. ")
+
+   (PROG ((EXPANSION CLAUSE)
+          EXPANDEDP BINDING-TYPE LET-BINDINGS LET-BODY)
+     EXPAND
+         (MULTIPLE-VALUE-SETQ (EXPANSION EXPANDEDP)
+                (MACROEXPAND-1 EXPANSION ENV))
+         (COND
+            ((NOT (CONSP EXPANSION))                         (IL:* IL:\; "Shouldn't happen")
+             )
+            ((SYMBOLP (SETQ BINDING-TYPE (FIRST EXPANSION)))
+             (CASE BINDING-TYPE
+                 ((LET LET*) 
+                    (SETQ LET-BINDINGS (SECOND EXPANSION))   (IL:* IL:\; 
+                                                           "List of variable bindings")
+                    (SETQ LET-BODY (CDDR EXPANSION))
+                    (GO HANDLE-LET))))
+            ((AND (CONSP BINDING-TYPE)
+                  (EQ (CAR BINDING-TYPE)
+                      'LAMBDA)
+                  (NOT (FIND-IF #'(LAMBDA (X)
+                                         (MEMBER X LAMBDA-LIST-KEYWORDS))
+                              (SETQ LET-BINDINGS (SECOND BINDING-TYPE))))
+                  (EQL (LENGTH (SECOND EXPANSION))
+                       (LENGTH LET-BINDINGS))
+                  (NULL (CDDR EXPANSION)))                   (IL:* IL:\; 
+                                                      "A simple LAMBDA form can be treated as LET ")
+             (SETQ LET-BODY (CDDR BINDING-TYPE))
+             (SETQ LET-BINDINGS (MAPCAR #'LIST LET-BINDINGS (SECOND EXPANSION)))
+             (SETQ BINDING-TYPE 'LET)
+             (GO HANDLE-LET)))
+
+    (IL:* IL:|;;| "Fall thru if not a LET")
+
+         (COND
+            (EXPANDEDP                                       (IL:* IL:\; "try expanding again")
+                   (GO EXPAND))
+            (T                                               (IL:* IL:\; 
+                                                           "Boring--return form as the body ")
+               (RETURN EXPANSION)))
+     HANDLE-LET
+         (RETURN (LET ((LOCALS (VARIABLES-FROM-LET LET-BINDINGS))
+                       EXTRA-BODY SPECIALS)
+                      (MULTIPLE-VALUE-BIND (LOCALDECLS OTHERDECLS LET-BODY)
+                          (PARSE-DECLARATIONS LET-BODY LOCALS)
+                        (COND
+                           ((SETQ SPECIALS (EXTRACT-SPECIAL-BINDINGS LOCALS LOCALDECLS))
+                            (MAYBE-WARN (COND
+                                               ((FIND-IF #'VARIABLE-GLOBALLY-SPECIAL-P SPECIALS)
+                                                             (IL:* IL:\; 
+                                                  "This could be the fault of a user proclamation ")
+                                                :USER)
+                                               (T :DEFINITION))
+                                   
+                                "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)"
+                                   PARENT-NAME CLAUSE SPECIALS)
+                            :ABORT)
+                           (T (VALUES (COND
+                                         ((NOT (CONSP LET-BODY))
+                                                             (IL:* IL:\; 
+                              "Null body of LET?  unlikely, but someone else will likely complain ")
+                                          NIL)
+                                         ((NULL (CDR LET-BODY))
+                                                             (IL:* IL:\; 
+                                    "A single expression, which we hope is (function (lambda...)) ")
+                                          (FIRST LET-BODY))
+                                         (T 
+
+                                 (IL:* IL:|;;| "More than one expression.  These are forms to evaluate after the bindings but before the generator form is returned.  Save them to evaluate in the next convenient place.  Note that this is ok, as there is no construct that can cause a LET to return prematurely (without returning also from some surrounding construct). ")
+
+                                            (SETQ EXTRA-BODY (BUTLAST LET-BODY))
+                                            (CAR (LAST LET-BODY))))
+                                     BINDING-TYPE LET-BINDINGS LOCALDECLS OTHERDECLS EXTRA-BODY))))))
+    ))
+
+(DEFUN VARIABLES-FROM-LET (BINDINGS)
+
+   (IL:* IL:|;;| "Return a list of the variables bound in the first argument to LET[*].")
+
+   (MAPCAR #'(LAMBDA (BINDING)
+                    (IF (CONSP BINDING)
+                        (FIRST BINDING)
+                        BINDING))
+          BINDINGS))
+
+(DEFUN ITERATE-TRANSFORM-BODY (LET-BODY ITERATE-ENV RENAMED-VARS FINISH-ARG FINISH-FORM 
+                                         BOUND-VARS CLAUSE)
+
+(IL:* IL:|;;;| "This is the second major transformation for a single iterate clause. LET-BODY is the body of the iterator after we have extracted its local variables and declarations.  We have two main tasks: (1) Substitute internal temporaries for occurrences of the LET variables; the alist RENAMED-VARS specifies this transformation.  (2) Substitute evaluation of FINISH-FORM for any occurrence of (funcall FINISH-ARG).  Along the way, we check for forms that would invalidate these transformations: occurrence of FINISH-ARG outside of a funcall, and free reference to any element of BOUND-VARS.  CLAUSE & TYPE are the original ITERATE clause and its type (ITERATE or ITERATE*), for purpose of error messages.  On success, we return the transformed body; on failure, :ABORT. ")
+
+   (WALK-FORM LET-BODY ITERATE-ENV #'(LAMBDA (FORM CONTEXT ENV)
+                                            (DECLARE (IGNORE CONTEXT))
+
+                                            (IL:* IL:|;;| 
+      "Need to substitute RENAMED-VARS, as well as turn (FUNCALL finish-arg) into the finish form ")
+
+                                            (COND
+                                               ((SYMBOLP FORM)
+                                                (LET (RENAMING)
+                                                     (COND
+                                                        ((AND (EQ FORM FINISH-ARG)
+                                                              (VARIABLE-SAME-P FORM ENV 
+                                                                     ITERATE-ENV))
+                                                             (IL:* IL:\; 
+                 "An occurrence of the finish arg outside of FUNCALL context--I can't handle this ")
+                                                         (MAYBE-WARN :DEFINITION "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it."
+                                                                (SECOND CLAUSE))
+                                                         (RETURN-FROM ITERATE-TRANSFORM-BODY :ABORT))
+                                                        ((AND (SETQ RENAMING (ASSOC FORM RENAMED-VARS
+                                                                                    ))
+                                                              (VARIABLE-SAME-P FORM ENV 
+                                                                     ITERATE-ENV))
+                                                             (IL:* IL:\; 
+                                                     "Reference to one of the vars we're renaming ")
+                                                         (CDR RENAMING))
+                                                        ((AND (MEMBER FORM BOUND-VARS)
+                                                              (VARIABLE-SAME-P FORM ENV 
+                                                                     ITERATE-ENV))
+                                                             (IL:* IL:\; "FORM is a var that is bound in this same ITERATE, or bound later in this ITERATE*. This is a conflict. ")
+                                                         (MAYBE-WARN :USER "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable."
+                                                                (SECOND CLAUSE)
+                                                                FORM)
+                                                         (RETURN-FROM ITERATE-TRANSFORM-BODY :ABORT))
+                                                        (T FORM))))
+                                               ((AND (CONSP FORM)
+                                                     (EQ (FIRST FORM)
+                                                         'FUNCALL)
+                                                     (EQ (SECOND FORM)
+                                                         FINISH-ARG)
+                                                     (VARIABLE-SAME-P (SECOND FORM)
+                                                            ENV ITERATE-ENV))
+                                                             (IL:* IL:\; 
+                                                           "(FUNCALL finish-arg) => finish-form ")
+                                                (UNLESS (NULL (CDDR FORM))
+                                                    (MAYBE-WARN :DEFINITION 
+                              "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored."
+                                                           (SECOND CLAUSE)
+                                                           (CDDR FORM)))
+                                                FINISH-FORM)
+                                               (T FORM)))))
+
+(DEFUN PARSE-DECLARATIONS (TAIL LOCALS)
+
+   (IL:* IL:|;;| "Extract the declarations from the head of TAIL and divide them into 2 classes: declares about variables in the list LOCALS, and all other declarations.  Returns 3 values: those 2 lists plus the remainder of TAIL. ")
+
+   (LET
+    (LOCALDECLS OTHERDECLS FORM)
+    (LOOP
+     (UNLESS (AND TAIL (CONSP (SETQ FORM (CAR TAIL)))
+                  (EQ (CAR FORM)
+                      'DECLARE))
+         (RETURN (VALUES LOCALDECLS OTHERDECLS TAIL)))
+     (MAPC
+      #'(LAMBDA (DECL)
+               (CASE (FIRST DECL)
+                   ((INLINE NOTINLINE OPTIMIZE)              (IL:* IL:\; 
+                                                           "These don't talk about vars")
+                      (PUSH DECL OTHERDECLS))
+                   (T                                        (IL:* IL:\; 
+                                                           "Assume all other kinds are for vars ")
+                      (LET* ((VARS (IF (EQ (FIRST DECL)
+                                           'TYPE)
+                                       (CDDR DECL)
+                                       (CDR DECL)))
+                             (L (INTERSECTION LOCALS VARS))
+                             OTHER)
+                            (COND
+                               ((NULL L)                     (IL:* IL:\; "None talk about LOCALS")
+                                (PUSH DECL OTHERDECLS))
+                               ((NULL (SETQ OTHER (SET-DIFFERENCE VARS L)))
+                                                             (IL:* IL:\; "All talk about LOCALS")
+                                (PUSH DECL LOCALDECLS))
+                               (T                            (IL:* IL:\; "Some of each")
+                                  (LET ((HEAD (CONS 'TYPE (AND (EQ (FIRST DECL)
+                                                                   'TYPE)
+                                                               (LIST (SECOND DECL))))))
+                                       (PUSH (APPEND HEAD OTHER)
+                                             OTHERDECLS)
+                                       (PUSH (APPEND HEAD L)
+                                             LOCALDECLS))))))))
+      (CDR FORM))
+     (POP TAIL))))
+
+(DEFUN EXTRACT-SPECIAL-BINDINGS (VARS DECLS)
+
+   (IL:* IL:|;;| 
+"Return the subset of VARS that are special, either globally or because of a declaration in DECLS ")
+
+   (LET ((SPECIALS (REMOVE-IF-NOT #'VARIABLE-GLOBALLY-SPECIAL-P VARS)))
+        (DOLIST (D DECLS)
+            (WHEN (EQ (CAR D)
+                      'SPECIAL)
+                (SETQ SPECIALS (UNION SPECIALS (INTERSECTION VARS (CDR D))))))
+        SPECIALS))
+
+(DEFUN FUNCTION-LAMBDA-P (FORM &OPTIONAL NARGS)
+
+   (IL:* IL:|;;| "If FORM is #'(LAMBDA bindings . body) and bindings is of length NARGS, return the lambda expression ")
+
+   (LET (ARGS BODY)
+        (AND (CONSP FORM)
+             (EQ (CAR FORM)
+                 'FUNCTION)
+             (CONSP (SETQ FORM (CDR FORM)))
+             (NULL (CDR FORM))
+             (CONSP (SETQ FORM (CAR FORM)))
+             (EQ (CAR FORM)
+                 'LAMBDA)
+             (CONSP (SETQ BODY (CDR FORM)))
+             (LISTP (SETQ ARGS (CAR BODY)))
+             (OR (NULL NARGS)
+                 (EQL (LENGTH ARGS)
+                      NARGS))
+             FORM)))
+
+(DEFUN RENAME-LET-BINDINGS (LET-BINDINGS BINDING-TYPE ENV LEFTOVER-BODY &OPTIONAL TEMPVARFN)
+
+   (IL:* IL:|;;| "Perform the alpha conversion required for \"LET eversion\" of (LET[*] LET-BINDINGS . body)--rename each of the variables to an internal name. Returns 2 values: a new set of LET bindings and the alist of old var names to new (so caller can walk the body doing the rest of the renaming). BINDING-TYPE is one of LET or LET*.  LEFTOVER-BODY is optional list of forms that must be eval'ed before the first binding happens.  ENV is the macro expansion environment, in case we have to walk a LET*.  TEMPVARFN is a function of no args to return a temporary var; if omitted, we use GENSYM. ")
+
+   (LET (RENAMED-VARS)
+        (VALUES (MAPCAR #'(LAMBDA (BINDING)
+                                 (LET ((VALUEFORM (COND
+                                                     ((NOT (CONSP BINDING))
+                                                             (IL:* IL:\; "No initial value")
+                                                      NIL)
+                                                     ((OR (EQ BINDING-TYPE 'LET)
+                                                          (NULL RENAMED-VARS))
+                                                             (IL:* IL:\; 
+                                       "All bindings are in parallel, so none can refer to others ")
+                                                      (SECOND BINDING))
+                                                     (T      (IL:* IL:\; 
+               "In a LET*, have to substitute vars in the 2nd and subsequent initialization forms ")
+                                                        (RENAME-VARIABLES (SECOND BINDING)
+                                                               RENAMED-VARS ENV))))
+                                       (NEWVAR (IF TEMPVARFN
+                                                   (FUNCALL TEMPVARFN)
+                                                   (GENSYM))))
+                                      (PUSH (CONS (IF (CONSP BINDING)
+                                                      (FIRST BINDING)
+                                                      BINDING)
+                                                  NEWVAR)
+                                            RENAMED-VARS)    (IL:* IL:\; 
+                        "Add new variable to the list AFTER we have walked the initial value form ")
+                                      (WHEN LEFTOVER-BODY
+
+                                          (IL:* IL:|;;| "Previous clause had some computation to do after its bindings.  Here is the first opportunity to do it ")
+
+                                          (SETQ VALUEFORM `(PROGN ,@LEFTOVER-BODY ,VALUEFORM))
+                                          (SETQ LEFTOVER-BODY NIL))
+                                      (LIST NEWVAR VALUEFORM)))
+                       LET-BINDINGS)
+               RENAMED-VARS)))
+
+(DEFUN RENAME-VARIABLES (FORM ALIST ENV)
+
+   (IL:* IL:|;;| "Walks FORM, renaming occurrences of the key variables in ALIST with their corresponding values.  ENV is FORM's environment, so we can make sure we are talking about the same variables. ")
+
+   (WALK-FORM FORM ENV #'(LAMBDA (FORM CONTEXT SUBENV)
+                                (DECLARE (IGNORE CONTEXT))
+                                (LET (PAIR)
+                                     (COND
+                                        ((AND (SYMBOLP FORM)
+                                              (SETQ PAIR (ASSOC FORM ALIST))
+                                              (VARIABLE-SAME-P FORM SUBENV ENV))
+                                         (CDR PAIR))
+                                        (T FORM))))))
+
+(DEFUN MV-SETQ (VARS EXPR)
+
+   (IL:* IL:|;;| "Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some of the simple cases for benefit of compilers that don't, and I don't care what the value is, and I know that the variables need not be set in parallel, since they can't be used free in EXPR ")
+
+   (COND
+      ((NULL VARS)                                           (IL:* IL:\; "EXPR is a side-effect")
+       EXPR)
+      ((NOT (CONSP VARS))                                    (IL:* IL:\; 
+                                    "This is an error, but I'll let MULTIPLE-VALUE-SETQ report it ")
+       `(MULTIPLE-VALUE-SETQ ,VARS ,EXPR))
+      ((AND (LISTP EXPR)
+            (EQ (CAR EXPR)
+                'VALUES))
+
+       (IL:* IL:|;;| "(mv-setq (a b c) (values x y z)) can be reduced to a parallel setq (psetq returns nil, but I don't care about returned value).  Do this even for the single variable case so that we catch (mv-setq (a) (values x y)) ")
+
+       (POP EXPR)                                            (IL:* IL:\; "VALUES")
+       `(SETQ ,@(MAPCON #'(LAMBDA (TAIL)
+                                 (LIST (CAR TAIL)
+                                       (COND
+                                          ((OR (CDR TAIL)
+                                               (NULL (CDR EXPR)))
+                                                             (IL:* IL:\; 
+                                                           "One result expression for this var ")
+                                           (POP EXPR))
+                                          (T                 (IL:* IL:\; 
+                            "More expressions than vars, so arrange to evaluate all the rest now. ")
+                                             (CONS 'PROG1 EXPR)))))
+                       VARS)))
+      ((NULL (CDR VARS))                                     (IL:* IL:\; "Simple one variable case")
+       `(SETQ ,(CAR VARS)
+              ,EXPR))
+      (T                                                     (IL:* IL:\; 
+                                                           "General case--I know nothing")
+         `(MULTIPLE-VALUE-SETQ ,VARS ,EXPR))))
+
+(DEFUN VARIABLE-SAME-P (VAR ENV1 ENV2)
+   (EQ (VARIABLE-LEXICAL-P VAR ENV1)
+       (VARIABLE-LEXICAL-P VAR ENV2)))
+
+(DEFUN MAYBE-WARN (TYPE &REST WARN-ARGS)
+
+   (IL:* IL:|;;| "Issue a warning about not being able to optimize this thing.  TYPE is one of :DEFINITION, meaning the definition is at fault, and :USER, meaning the user's code is at fault. ")
+
+   (WHEN (CASE *ITERATE-WARNINGS*
+             ((NIL) NIL)
+             ((:USER) (EQ TYPE :USER))
+             (T T))
+       (APPLY #'WARN WARN-ARGS)))
+
+
+
+(IL:* IL:|;;| "Sample iterators")
+
+
+(DEFMACRO INTERVAL (&WHOLE WHOLE &KEY FROM DOWNFROM TO DOWNTO ABOVE BELOW BY TYPE)
+   (COND
+      ((AND FROM DOWNFROM)
+       (ERROR "Can't use both FROM and DOWNFROM in ~S" WHOLE))
+      ((CDR (REMOVE NIL (LIST TO DOWNTO ABOVE BELOW)))
+       (ERROR "Can't use more than one limit keyword in ~S" WHOLE))
+      (T
+       (LET*
+        ((DOWN (OR DOWNFROM DOWNTO ABOVE))
+         (LIMIT (OR TO DOWNTO ABOVE BELOW))
+         (INC (COND
+                 ((NULL BY)
+                  1)
+                 ((CONSTANTP BY)                             (IL:* IL:\; 
+                                                           "Can inline this increment")
+                  BY))))
+        `(LET ((FROM ,(OR FROM DOWNFROM 0))
+               ,@(AND LIMIT `((TO ,LIMIT)))
+               ,@(AND (NULL INC)
+                      `((BY ,BY))))
+              ,@(AND TYPE `((DECLARE (TYPE ,TYPE FROM ,@(AND LIMIT '(TO))
+                                               ,@(AND (NULL INC)
+                                                      `(BY))))))
+              #'(LAMBDA (FINISH)
+                       ,@(COND
+                            ((NULL LIMIT)                    (IL:* IL:\; 
+                                                           "We won't use the FINISH arg")
+                             '((DECLARE (IGNORE FINISH)))))
+                       (PROG1 ,(COND
+                                  (LIMIT                     (IL:* IL:\; 
+                           "Test the limit.  If ok, return current value and increment, else quit ")
+                                         `(IF (,(COND
+                                                   (ABOVE '>)
+                                                   (BELOW '<)
+                                                   (DOWN '>=)
+                                                   (T '<=))
+                                               FROM TO)
+                                              FROM
+                                              (FUNCALL FINISH)))
+                                  (T                         (IL:* IL:\; "No test")
+                                     'FROM))
+                           (SETQ FROM (,(IF DOWN
+                                            '-
+                                            '+)
+                                       FROM
+                                       ,(OR INC 'BY))))))))))
+
+(DEFMACRO LIST-ELEMENTS (LIST &KEY (BY '#'CDR))
+   `(LET ((TAIL ,LIST))
+         #'(LAMBDA (FINISH)
+                  (PROG1 (IF (ENDP TAIL)
+                             (FUNCALL FINISH)
+                             (FIRST TAIL))
+                      (SETQ TAIL (FUNCALL ,BY TAIL))))))
+
+(DEFMACRO LIST-TAILS (LIST &KEY (BY '#'CDR))
+   `(LET ((TAIL ,LIST))
+         #'(LAMBDA (FINISH)
+                  (PROG1 (IF (ENDP TAIL)
+                             (FUNCALL FINISH)
+                             TAIL)
+                      (SETQ TAIL (FUNCALL ,BY TAIL))))))
+
+(DEFMACRO ELEMENTS (SEQUENCE)
+   "Generates successive elements of SEQUENCE, with second value being the index.  Use (ELEMENTS (THE type arg)) if you care about the type."
+   (LET* ((TYPE (AND (CONSP SEQUENCE)
+                     (EQ (FIRST SEQUENCE)
+                         'THE)
+                     (SECOND SEQUENCE)))
+          (ACCESSOR (IF TYPE
+                        (SEQUENCE-ACCESSOR TYPE)
+                        'ELT))
+          (LISTP (EQ TYPE 'LIST)))
+
+         (IL:* IL:|;;| "If type is given via THE, we may be able to generate a good accessor here for the benefit of implementations that aren't smart about (ELT (THE STRING FOO)).  I'm not bothering to keep the THE inside the body, however, since I assume any compiler that would understand (AREF (THE SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I bound S to (THE SIMPLE-ARRAY foo) and never modified it. If sequence is declared to be a list, it's better to cdr down it, so we have some extra cases here.  Normally folks would write LIST-ELEMENTS, but maybe they wanted to get the index for free... ")
+
+         `(LET* ((INDEX 0)
+                 (S ,SEQUENCE)
+                 ,@(AND (NOT LISTP)
+                        '((SIZE (LENGTH S)))))
+                #'(LAMBDA (FINISH)
+                         (VALUES (COND
+                                    ,(IF LISTP
+                                         '((NOT (ENDP S))
+                                           (POP S))
+                                         `((< INDEX SIZE)
+                                           (,ACCESSOR S INDEX)))
+                                    (T (FUNCALL FINISH)))
+                                (PROG1 INDEX
+                                    (SETQ INDEX (1+ INDEX))))))))
+
+(DEFMACRO PLIST-ELEMENTS (PLIST)
+   "Generates each time 2 items, the indicator and the value."
+   `(LET ((TAIL ,PLIST))
+         #'(LAMBDA (FINISH)
+                  (VALUES (IF (ENDP TAIL)
+                              (FUNCALL FINISH)
+                              (FIRST TAIL))
+                         (PROG1 (IF (ENDP (SETQ TAIL (CDR TAIL)))
+                                    (FUNCALL FINISH)
+                                    (FIRST TAIL))
+                             (SETQ TAIL (CDR TAIL)))))))
+
+(DEFUN SEQUENCE-ACCESSOR (TYPE)
+
+   (IL:* IL:|;;| 
+ "returns the function with which most efficiently to make accesses to a sequence of type TYPE. ")
+
+   (CASE (IF (CONSP TYPE)                                    (IL:* IL:\; "e.g., (VECTOR FLOAT *)")
+             (CAR TYPE)
+             TYPE)
+       ((ARRAY SIMPLE-ARRAY VECTOR) 'AREF)
+       (SIMPLE-VECTOR 'SVREF)
+       (STRING 'CHAR)
+       (SIMPLE-STRING 'SCHAR)
+       (BIT-VECTOR 'BIT)
+       (SIMPLE-BIT-VECTOR 'SBIT)
+       (T 'ELT)))
+
+
+
+(IL:* IL:|;;| "These \"iterators\" may be withdrawn")
+
+
+(DEFMACRO EACHTIME (EXPR)
+   `#'(LAMBDA (FINISH)
+             (DECLARE (IGNORE FINISH))
+             ,EXPR))
+
+(DEFMACRO WHILE (EXPR)
+   `#'(LAMBDA (FINISH)
+             (UNLESS ,EXPR (FUNCALL FINISH))))
+
+(DEFMACRO UNTIL (EXPR)
+   `#'(LAMBDA (FINISH)
+             (WHEN ,EXPR (FUNCALL FINISH))))
+
+
+
+(IL:* IL:\; "GATHERING macro")
+
+
+(DEFMACRO GATHERING (CLAUSES &BODY BODY &ENVIRONMENT ENV)
+   (OR (OPTIMIZE-GATHERING-FORM CLAUSES BODY ENV)
+       (SIMPLE-EXPAND-GATHERING-FORM CLAUSES BODY ENV)))
+
+(DEFMACRO WITH-GATHERING (CLAUSES GATHER-BODY &BODY USE-BODY)
+   "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour."
+
+   (IL:* IL:|;;| "We may optimize this a little better later for those compilers that don't do a good job on (m-v-bind vars (... (values ...)) ...). ")
+
+   `(MULTIPLE-VALUE-BIND ,(MAPCAR #'CAR CLAUSES)
+        (GATHERING ,CLAUSES ,GATHER-BODY)
+      ,@USE-BODY))
+
+(DEFUN SIMPLE-EXPAND-GATHERING-FORM (CLAUSES BODY ENV)
+   (DECLARE (IGNORE ENV))
+
+   (IL:* IL:|;;| 
+ "The \"formal semantics\" of GATHERING.  We use this only in cases that can't be optimized. ")
+
+   (LET
+    ((ACC-NAMES (MAPCAR #'FIRST (IF (SYMBOLP CLAUSES)        (IL:* IL:\; 
+                                                        "Shorthand using anonymous gathering site ")
+                                    (SETQ CLAUSES `((*ANONYMOUS-GATHERING-SITE* (,CLAUSES))))
+                                    CLAUSES)))
+     (REALIZER-NAMES (MAPCAR #'(LAMBDA (BINDING)
+                                      (DECLARE (IGNORE BINDING))
+                                      (GENSYM))
+                            CLAUSES)))
+    `(MULTIPLE-VALUE-CALL
+      #'(LAMBDA ,(MAPCAN #'LIST ACC-NAMES REALIZER-NAMES)
+               (FLET ((GATHER (VALUE &OPTIONAL (ACCUMULATOR *ANONYMOUS-GATHERING-SITE*))
+                             (FUNCALL ACCUMULATOR VALUE)))
+                     ,@BODY
+                     (VALUES ,@(MAPCAR #'(LAMBDA (RNAME)
+                                                `(FUNCALL ,RNAME))
+                                      REALIZER-NAMES))))
+      ,@(MAPCAR #'SECOND CLAUSES))))
+
+(DEFVAR *ACTIVE-GATHERERS* NIL
+   "List of GATHERING bindings currently active during macro expansion)")
+
+(DEFVAR *ANONYMOUS-GATHERING-SITE* NIL
+   "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site)."
+)
+
+(DEFUN OPTIMIZE-GATHERING-FORM (CLAUSES BODY GATHERING-ENV)
+   (LET*
+    (ACC-INFO LEFTOVER-BODY TOP-BINDINGS FINISH-FORMS TOP-DECLS)
+    (DOLIST (CLAUSE (IF (SYMBOLP CLAUSES)                    (IL:* IL:\; "A shorthand")
+                        `((*ANONYMOUS-GATHERING-SITE* (,CLAUSES)))
+                        CLAUSES))
+        (MULTIPLE-VALUE-BIND (LET-BODY BINDING-TYPE LET-BINDINGS LOCALDECLS OTHERDECLS EXTRA-BODY)
+            (EXPAND-INTO-LET (SECOND CLAUSE)
+                   'GATHERING GATHERING-ENV)
+          (PROG* ((ACC-VAR (FIRST CLAUSE))
+                  RENAMED-VARS ACCUMULATOR REALIZER)
+                 (WHEN (AND (CONSP LET-BODY)
+                            (EQ (CAR LET-BODY)
+                                'VALUES)
+                            (CONSP (SETQ LET-BODY (CDR LET-BODY)))
+                            (SETQ ACCUMULATOR (FUNCTION-LAMBDA-P (CAR LET-BODY)))
+                            (CONSP (SETQ LET-BODY (CDR LET-BODY)))
+                            (SETQ REALIZER (FUNCTION-LAMBDA-P (CAR LET-BODY)
+                                                  0))
+                            (NULL (CDR LET-BODY)))
+
+                     (IL:* IL:|;;| "Macro returned something of the form (VALUES #'(lambda (value)")
+
+                     (IL:* IL:|;;| 
+   "..) #'(lambda () ...)), a function to accumulate values and a function to realize the result. ")
+
+                     (WHEN BINDING-TYPE
+
+                         (IL:* IL:|;;| "Gatherer expanded into a LET")
+
+                         (COND
+                            (OTHERDECLS (MAYBE-WARN :DEFINITION "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S"
+                                               (SECOND CLAUSE)
+                                               `(DECLARE ,@OTHERDECLS))
+                                   (GO PUNT)))
+                         (WHEN LET-BINDINGS
+
+                             (IL:* IL:|;;| "The first transformation we want to perform is a variant of \"LET-eversion\": turn (mv-bind (acc real) (let (..bindings..) (values #'(lambda ...) #'(lambda ")
+
+                             (IL:* IL:|;;| "..))) ..body..) into (let* (..bindings.. (acc #'(lambda ...)) (real #'(lambda ...))) ..body..).  This transformation is valid if nothing in body refers to any of the bindings, something we can assure by alpha-converting the inner let (substituting new names for each var).  Of course, none of those vars can be special, but we already checked for that above. ")
+
+                             (MULTIPLE-VALUE-SETQ (LET-BINDINGS RENAMED-VARS)
+                                    (RENAME-LET-BINDINGS LET-BINDINGS BINDING-TYPE GATHERING-ENV
+                                           LEFTOVER-BODY))
+                             (SETQ TOP-BINDINGS (NCONC TOP-BINDINGS LET-BINDINGS))
+                             (SETQ LEFTOVER-BODY NIL)        (IL:* IL:\; 
+                                     "If there was any leftover from previous, it is now consumed ")
+                             ))
+                     (SETQ LEFTOVER-BODY (NCONC LEFTOVER-BODY EXTRA-BODY))
+                                                             (IL:* IL:\; 
+                                                          "Computation to do after these bindings ")
+                     (PUSH (CONS ACC-VAR (RENAME-AND-CAPTURE-VARIABLES ACCUMULATOR RENAMED-VARS 
+                                                GATHERING-ENV))
+                           ACC-INFO)
+                     (SETQ REALIZER (RENAME-VARIABLES REALIZER RENAMED-VARS GATHERING-ENV))
+                     (PUSH (COND
+                              ((NULL (CDDDR REALIZER))       (IL:* IL:\; 
+                                                           "Simple (LAMBDA () expr) => expr ")
+                               (THIRD REALIZER))
+                              (T                             (IL:* IL:\; 
+                                     "There could be declarations or something, so leave as a LET ")
+                                 (CONS 'LET (CDR REALIZER))))
+                           FINISH-FORMS)
+                     (UNLESS (NULL LOCALDECLS)               (IL:* IL:\; 
+                                   "Declarations about the LET variables also has to percolate up ")
+                         (SETQ TOP-DECLS (NCONC TOP-DECLS (SUBLIS RENAMED-VARS LOCALDECLS))))
+                     (RETURN))
+                 (MAYBE-WARN :DEFINITION "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))"
+                        (SECOND CLAUSE))
+             PUNT
+                 (LET ((GS (GENSYM))
+                       (EXPANSION `(MULTIPLE-VALUE-LIST ,(SECOND CLAUSE))))
+                                                             (IL:* IL:\; 
+                "Slow way--bind gensym to the macro expansion, and we will funcall it in the body ")
+                      (PUSH (LIST ACC-VAR GS)
+                            ACC-INFO)
+                      (PUSH `(FUNCALL (CADR ,GS))
+                            FINISH-FORMS)
+                      (SETQ TOP-BINDINGS
+                            (NCONC TOP-BINDINGS
+                                   (LIST (LIST GS
+                                               (COND
+                                                  (LEFTOVER-BODY
+                                                   `(PROGN ,@(PROG1 LEFTOVER-BODY (SETQ LEFTOVER-BODY
+                                                                                        NIL))
+                                                           ,EXPANSION))
+                                                  (T EXPANSION))))))))))
+    (SETQ BODY (WALK-GATHERING-BODY BODY GATHERING-ENV ACC-INFO))
+    (COND
+       ((EQ BODY :ABORT)                                     (IL:* IL:\; 
+                                                           "Couldn't finish expansion")
+        NIL)
+       (T `(LET* ,TOP-BINDINGS ,@(AND TOP-DECLS `((DECLARE ,@TOP-DECLS)))
+                 ,BODY
+                 ,(COND
+                     ((NULL (CDR FINISH-FORMS))              (IL:* IL:\; "just a single value")
+                      (CAR FINISH-FORMS))
+                     (T `(VALUES ,@(REVERSE FINISH-FORMS)))))))))
+
+(DEFUN RENAME-AND-CAPTURE-VARIABLES (FORM ALIST ENV)
+
+   (IL:* IL:|;;| "Walks FORM, renaming occurrences of the key variables in ALIST with their corresponding values, and capturing any other free variables. Returns a list of the new form and the list of other closed-over vars.  ENV is FORM's environment, so we can make sure we are talking about the same variables. ")
+
+   (LET (CLOSED)
+        (LIST (WALK-FORM FORM ENV #'(LAMBDA (FORM CONTEXT SUBENV)
+                                           (DECLARE (IGNORE CONTEXT))
+                                           (LET (PAIR)
+                                                (COND
+                                                   ((OR (NOT (SYMBOLP FORM))
+                                                        (NOT (VARIABLE-SAME-P FORM SUBENV ENV)))
+                                                             (IL:* IL:\; 
+                                                       "non-variable or one that has been rebound ")
+                                                    FORM)
+                                                   ((SETQ PAIR (ASSOC FORM ALIST))
+                                                             (IL:* IL:\; "One to rename")
+                                                    (CDR PAIR))
+                                                   (T        (IL:* IL:\; "var is free")
+                                                      (PUSHNEW FORM CLOSED)
+                                                      FORM)))))
+              CLOSED)))
+
+(DEFUN WALK-GATHERING-BODY (BODY GATHERING-ENV ACC-INFO)
+
+   (IL:* IL:|;;| "Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV. ACC-INFO is a list of information about each of the gathering \"bindings\" in the form, in the form (var gatheringfn freevars env) ")
+
+   (LET ((*ACTIVE-GATHERERS* (NCONC (MAPCAR #'CAR ACC-INFO)
+                                    *ACTIVE-GATHERERS*)))
+
+        (IL:* IL:|;;| "*ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER targets.  This is so that when we encounter a GATHER not belonging to us we can know whether to warn about it. ")
+
+        (WALK-FORM
+         (CONS 'PROGN BODY)
+         GATHERING-ENV
+         #'(LAMBDA (FORM CONTEXT ENV)
+                  (DECLARE (IGNORE CONTEXT))
+                  (LET (INFO SITE)
+                       (COND
+                          ((CONSP FORM)
+                           (COND
+                              ((NOT (EQ (CAR FORM)
+                                        'GATHER))            (IL:* IL:\; 
+                                                           "We only care about GATHER")
+                               (WHEN (AND (EQ (CAR FORM)
+                                              'FUNCTION)
+                                          (EQ (CADR FORM)
+                                              'GATHER))      (IL:* IL:\; 
+                                                         "Passed as functional--can't macroexpand ")
+                                   (MAYBE-WARN :USER 
+                                         "Can't optimize GATHERING because of reference to #'GATHER."
+                                          )
+                                   (RETURN-FROM WALK-GATHERING-BODY :ABORT))
+                               FORM)
+                              ((SETQ INFO (ASSOC (SETQ SITE (IF (NULL (CDDR FORM))
+                                                                '*ANONYMOUS-GATHERING-SITE*
+                                                                (THIRD FORM)))
+                                                 ACC-INFO))  (IL:* IL:\; 
+                  "One of ours--expand (GATHER value var).  INFO = (var gatheringfn freevars env) ")
+                               (UNLESS (NULL (CDDDR FORM))
+                                      (WARN "Extra arguments (> 2) in ~S discarded." FORM))
+                               (LET ((FN (SECOND INFO)))
+                                    (COND
+                                       ((SYMBOLP FN)         (IL:* IL:\; "Unoptimized case--just call the gatherer.  FN is the gensym that we bound to the list of two values returned from the gatherer. ")
+                                        `(FUNCALL (CAR ,FN)
+                                                ,(SECOND FORM)))
+                                       (T                    (IL:* IL:\; 
+                                                           "FN = (lambda (value) ...)")
+                                          (DOLIST (S (THIRD INFO))
+                                              (UNLESS (OR (VARIABLE-SAME-P S ENV GATHERING-ENV)
+                                                          (AND (VARIABLE-SPECIAL-P S ENV)
+                                                               (VARIABLE-SPECIAL-P S GATHERING-ENV)))
+
+                                 (IL:* IL:|;;| "Some var used free in the LAMBDA form has been rebound between here and the parent GATHERING form, so can't substitute the lambda.  Ok if it's a special reference both here and in the LAMBDA, because then it's not closed over. ")
+
+                                                  (MAYBE-WARN :USER "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it."
+                                                         S)
+                                                  (RETURN-FROM WALK-GATHERING-BODY :ABORT)))
+
+                                 (IL:* IL:|;;| "Return ((lambda (value) ...) actual-value).  In many cases we could simplify this further by substitution, but we'd have to be careful (for example, we would need to alpha-convert any LET we found inside).  Any decent compiler will do it for us. ")
+
+                                          (LIST FN (SECOND FORM))))))
+                              ((AND (SETQ INFO (MEMBER SITE *ACTIVE-GATHERERS*))
+                                    (OR (EQ SITE '*ANONYMOUS-GATHERING-SITE*)
+                                        (VARIABLE-SAME-P SITE ENV (FOURTH INFO))))
+                                                             (IL:* IL:\; "Some other GATHERING will take care of this form, so pass it up for now. Environment check is to make sure nobody shadowed it between here and there ")
+                               FORM)
+                              (T                             (IL:* IL:\; 
+                                                           "Nobody's going to handle it")
+                                 (IF (EQ SITE '*ANONYMOUS-GATHERING-SITE*)
+                                                             (IL:* IL:\; 
+    "More likely that she forgot to mention the site than forget to write an anonymous gathering. ")
+                                     (WARN "There is no gathering site specified in ~S." FORM)
+                                     (WARN 
+                                   "The site ~S in ~S is not defined in an enclosing GATHERING form."
+                                           SITE FORM))       (IL:* IL:\; 
+                           "Turn it into something else so we don't warn twice in the nested case ")
+                                 `(%ORPHANED-GATHER ,@(CDR FORM)))))
+                          ((AND (SYMBOLP FORM)
+                                (SETQ INFO (ASSOC FORM ACC-INFO))
+                                (VARIABLE-SAME-P FORM ENV GATHERING-ENV))
+                                                             (IL:* IL:\; 
+                                   "A variable reference to a gather binding from environment TEM ")
+                           (MAYBE-WARN :USER 
+                "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form."
+                                  FORM)
+                           (RETURN-FROM WALK-GATHERING-BODY :ABORT))
+                          (T FORM)))))))
+
+
+
+(IL:* IL:|;;| "Sample gatherers")
+
+
+(DEFMACRO COLLECTING (&KEY INITIAL-VALUE)
+   `(LET* ((HEAD ,INITIAL-VALUE)
+           (TAIL ,(AND INITIAL-VALUE `(LAST HEAD))))
+          (VALUES #'(LAMBDA (VALUE)
+                           (IF (NULL HEAD)
+                               (SETQ HEAD (SETQ TAIL (LIST VALUE)))
+                               (SETQ TAIL (CDR (RPLACD TAIL (LIST VALUE))))))
+                 #'(LAMBDA NIL HEAD))))
+
+(DEFMACRO JOINING (&KEY INITIAL-VALUE)
+   `(LET ((RESULT ,INITIAL-VALUE))
+         (VALUES #'(LAMBDA (VALUE)
+                          (SETQ RESULT (NCONC RESULT VALUE)))
+                #'(LAMBDA NIL RESULT))))
+
+(DEFMACRO MAXIMIZING (&KEY INITIAL-VALUE)
+   `(LET ((RESULT ,INITIAL-VALUE))
+         (VALUES #'(LAMBDA (VALUE)
+                          (WHEN ,(COND
+                                    ((AND (CONSTANTP INITIAL-VALUE)
+                                          (NOT (NULL (EVAL INITIAL-VALUE))))
+                                                             (IL:* IL:\; 
+                    "Initial value is given and we know it's not NIL, so leave out the null check ")
+                                     '(> VALUE RESULT))
+                                    (T '(OR (NULL RESULT)
+                                            (> VALUE RESULT))))
+                                (SETQ RESULT VALUE)))
+                #'(LAMBDA NIL RESULT))))
+
+(DEFMACRO MINIMIZING (&KEY INITIAL-VALUE)
+   `(LET ((RESULT ,INITIAL-VALUE))
+         (VALUES #'(LAMBDA (VALUE)
+                          (WHEN ,(COND
+                                    ((AND (CONSTANTP INITIAL-VALUE)
+                                          (NOT (NULL (EVAL INITIAL-VALUE))))
+                                                             (IL:* IL:\; 
+                    "Initial value is given and we know it's not NIL, so leave out the null check ")
+                                     '(< VALUE RESULT))
+                                    (T '(OR (NULL RESULT)
+                                            (< VALUE RESULT))))
+                                (SETQ RESULT VALUE)))
+                #'(LAMBDA NIL RESULT))))
+
+(DEFMACRO SUMMING (&KEY (INITIAL-VALUE 0))
+   `(LET ((SUM ,INITIAL-VALUE))
+         (VALUES #'(LAMBDA (VALUE)
+                          (SETQ SUM (+ SUM VALUE)))
+                #'(LAMBDA NIL SUM))))
+
+
+
+(IL:* IL:\; "Easier to read expanded code if PROG1 gets left alone ")
+
+
+(XCL:DEFINE-FILE-ENVIRONMENT "ITERATE" :PACKAGE (IN-PACKAGE :ITERATE :USE '(:LISP :WALKER))
+   :READTABLE "XCL"
+   :BASE 10
+   :COMPILER :COMPILE-FILE)
+(IL:PUTPROPS IL:ITERATE IL:COPYRIGHT ("Venue" 1991))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/clos/2.0/lap.lisp b/clos/2.0/lap.lisp
new file mode 100644
index 00000000..4dceda84
--- /dev/null
+++ b/clos/2.0/lap.lisp
@@ -0,0 +1,364 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+;;; This file defines CLOS's interface to the LAP mechanism. The file is divided into two parts.  The
+;;; first part defines the interface used by CLOS to create abstract LAP code vectors.  CLOS never
+;;; creates lists that represent LAP code directly, it always calls this mechanism to do so. This
+;;; provides a layer of error checking on the LAP code before it gets to the implementation-specific
+;;; assembler.  Note that this error checking is syntactic only, but even so is useful to have. 
+;;; Because of it, no specific LAP assembler should worry itself with checking the syntax of the LAP
+;;; code. The second part of the file defines the LAP assemblers for each CLOS port. These are
+;;; included together in the same file to make it easier to change them all should some random
+;;; change be made in the LAP mechanism. 
+
+
+(defvar *make-lap-closure-generator*)
+
+(defvar *precompile-lap-closure-generator*)
+
+(defvar *lap-in-lisp*)
+
+(defun make-lap-closure-generator (closure-variables arguments iregs vregs tregs lap-code)
+       (funcall *make-lap-closure-generator* closure-variables arguments iregs vregs tregs lap-code))
+
+(defmacro precompile-lap-closure-generator (cvars args i-regs v-regs t-regs lap)
+       (funcall *precompile-lap-closure-generator* cvars args i-regs v-regs t-regs lap))
+
+(defmacro lap-in-lisp (cvars args iregs vregs tregs lap)
+       (declare (ignore cvars args))
+       `(locally (declare (optimize (safety 0)
+                                 (speed 3)))
+               ,(make-lap-prog iregs vregs tregs (flatten-lap lap (opcode :label 'exit-lap-in-lisp)))
+               ))
+
+
+;;; The following functions and macros are used by CLOS when generating LAP code: GENERATING-LAP
+;;; WITH-LAP-REGISTERS ALLOCATE-REGISTER DEALLOCATE-REGISTER LAP-FLATTEN OPCODE OPERAND 
+
+
+(proclaim '(special *generating-lap*))
+
+                                                             ; CAR   - alist of free registers CADR 
+                                                             ; - alist of allocated registers CADDR
+                                                             ; - max reg number allocated in each
+                                                             ; alist, the entries have the form: 
+                                                             ; (type . (:REG <n>)) 
+
+
+
+;;; This goes around the generation of any lap code.  <body> should return a lap code sequence, this
+;;; macro will take care of converting that to a lap closure generator. 
+
+
+(defmacro generating-lap (closure-variables arguments &body body)
+       `(let* ((*generating-lap* (list nil nil -1)))
+              (finalize-lap-generation nil ,closure-variables ,arguments (progn ,@body))))
+
+(defmacro generating-lap-in-lisp (closure-variables arguments &body body)
+       `(let* ((*generating-lap* (list nil nil -1)))
+              (finalize-lap-generation t ,closure-variables ,arguments (progn ,@body))))
+
+
+;;; Each register specification looks like: (<var> <type> &key :reuse <other-reg>) 
+
+
+(defmacro with-lap-registers (register-specifications &body body)
+       
+       ;; Given that, for now, there is only one keyword argument and that, for now, we do no error
+       ;; checking, we can be pretty sleazy about how this works. 
+       (flet ((make-allocations
+               nil
+               (gathering1 (collecting)
+                      (dolist (spec register-specifications)
+                          (gather1 `(,(car spec)
+                                     (or ,(cadddr spec)
+                                         (allocate-register ',(cadr spec))))))))
+              (make-deallocations nil (gathering1
+                                       (collecting)
+                                       (dolist (spec register-specifications)
+                                           (gather1 `(unless ,(cadddr spec)
+                                                         (deallocate-register ,(car spec))))))))
+             `(let ,(make-allocations)
+                   (multiple-value-prog1 (progn ,@body)
+                          ,@(make-deallocations)))))
+
+(defun allocate-register (type)
+       (destructuring-bind (free allocated)
+              *generating-lap*
+              (let ((entry (assoc type free)))
+                   (cond (entry (setf (car *generating-lap*)
+                                      (delete entry free)
+                                      (cadr *generating-lap*)
+                                      (cons entry allocated))
+                                (cdr entry))
+                         (t (let ((new `(,type :reg ,(incf (caddr *generating-lap*)))))
+                                 (setf (cadr *generating-lap*)
+                                       (cons new allocated))
+                                 (cdr new)))))))
+
+(defun deallocate-register (reg)
+       (let ((entry (rassoc reg (cadr *generating-lap*))))
+            (unless entry (error "Attempt to free an unallocated register."))
+            (push entry (car *generating-lap*))
+            (setf (cadr *generating-lap*)
+                  (delete entry (cadr *generating-lap*)))))
+
+(defvar *precompiling-lap* nil)
+
+(defun finalize-lap-generation (in-lisp-p closure-variables arguments lap-code)
+       (when (cadr *generating-lap*)
+             (error "Registers still allocated when lap being finalized."))
+       (let ((iregs nil)
+             (vregs nil)
+             (tregs nil))
+            (dolist (entry (car *generating-lap*))
+                (ecase (car entry)
+                    (index (push (caddr entry)
+                                 iregs))
+                    (vector (push (caddr entry)
+                                  vregs))
+                    ((t) (push (caddr entry)
+                               tregs))))
+            (cond (in-lisp-p (macroexpand `(lap-in-lisp ,closure-variables ,arguments ,iregs
+                                                  ,vregs
+                                                  ,tregs
+                                                  ,lap-code)))
+                  (*precompiling-lap* (values closure-variables arguments iregs vregs tregs lap-code)
+                         )
+                  (t (make-lap-closure-generator closure-variables arguments iregs vregs tregs 
+                            lap-code)))))
+
+(defun flatten-lap (&rest opcodes-or-sequences)
+       (let ((result nil))
+            (dolist (opcode-or-sequence opcodes-or-sequences result)
+                (cond ((null opcode-or-sequence))
+                      ((not (consp (car opcode-or-sequence)))
+                                                             ; its an opcode
+                       (setf result (append result (list opcode-or-sequence))))
+                      (t (setf result (append result opcode-or-sequence)))))))
+
+(defmacro flattening-lap nil '(let ((result nil))
+                                   (values #'(lambda (value)
+                                                    (push value result))
+                                          #'(lambda nil (apply #'flatten-lap (reverse result))))))
+
+
+;;; This code deals with the syntax of the individual opcodes and operands. The first two of these
+;;; variables are documented to all ports.  They are lists of the symbols which name the lap opcodes
+;;; and operands.  They can be useful to determine whether a port has implemented all the required
+;;; opcodes and operands. The third of these variables is for use of the emitter only. 
+
+
+(defvar *lap-operands* nil)
+
+(defvar *lap-opcodes* nil)
+
+(defvar *lap-emitters* (make-hash-table :test #'eq :size 30))
+
+(defun opcode (name &rest args)
+       (let ((emitter (gethash name *lap-emitters*)))
+            (if emitter
+                (apply emitter args)
+                (error "No opcode named ~S." name))))
+
+(defun operand (name &rest args)
+       (let ((emitter (gethash name *lap-emitters*)))
+            (if emitter
+                (apply emitter args)
+                (error "No operand named ~S." name))))
+
+(defmacro defopcode (name types)
+       (let ((fn-name (symbol-append "LAP Opcode " name *the-clos-package*))
+             (lambda-list (mapcar #'(lambda (x)
+                                           (declare (ignore x))
+                                           (gensym))
+                                 types)))
+            `(progn (eval-when (load eval)
+                           (load-defopcode ',name ',fn-name))
+                    (defun ,fn-name ,lambda-list (defopcode-1 ',name ',types ,@lambda-list)))))
+
+(defmacro defoperand (name types)
+       (let ((fn-name (symbol-append "LAP Operand " name *the-clos-package*))
+             (lambda-list (mapcar #'(lambda (x)
+                                           (declare (ignore x))
+                                           (gensym))
+                                 types)))
+            `(progn (eval-when (load eval)
+                           (load-defoperand ',name ',fn-name))
+                    (defun ,fn-name ,lambda-list (defoperand-1 ',name ',types ,@lambda-list)))))
+
+(defun load-defopcode (name fn-name)
+       (if* (memq name *lap-operands*)
+            (error "LAP opcodes and operands must have disjoint names.")
+            (setf (gethash name *lap-emitters*)
+                  fn-name)
+            (pushnew name *lap-opcodes*)))
+
+(defun load-defoperand (name fn-name)
+       (if* (memq name *lap-opcodes*)
+            (error "LAP opcodes and operands must have disjoint names.")
+            (setf (gethash name *lap-emitters*)
+                  fn-name)
+            (pushnew name *lap-operands*)))
+
+(defun defopcode-1 (name operand-types &rest args)
+       (iterate ((arg (list-elements args))
+                 (type (list-elements operand-types)))
+              (check-opcode-arg name arg type))
+       (cons name (copy-list args)))
+
+(defun defoperand-1 (name operand-types &rest args)
+       (iterate ((arg (list-elements args))
+                 (type (list-elements operand-types)))
+              (check-operand-arg name arg type))
+       (cons name (copy-list args)))
+
+(defun check-opcode-arg (name arg type)
+       (labels ((usual (x)
+                       (and (consp arg)
+                            (eq (car arg)
+                                x)))
+                (check (x)
+                       (ecase x
+                           ((:reg :cdr :constant :iref :cvar :arg :lisp :lisp-variable) (usual x))
+                           (:label (symbolp arg))
+                           (:operand (and (consp arg)
+                                          (memq (car arg)
+                                                *lap-operands*))))))
+              (unless (if (consp type)
+                          (if (eq (car type)
+                                  'or)
+                              (some #'check (cdr type))
+                              (error "What type is this?"))
+                          (check type))
+                     (error "The argument ~S to the opcode ~A is not of type ~S." arg name type))))
+
+(defun check-operand-arg (name arg type)
+       (flet ((check (x)
+                     (ecase x
+                         (:symbol (symbolp arg))
+                         (:register-number (and (integerp arg)
+                                                (>= x 0)))
+                         (:t t)
+                         (:reg (and (consp arg)
+                                    (eq (car arg)
+                                        :reg)))
+                         (:fixnum (typep arg 'fixnum)))))
+             (unless (if (consp type)
+                         (if (eq (car type)
+                                 'or)
+                             (some #'check (cdr type))
+                             (error "What type is this?"))
+                         (check type))
+                    (error "The argument ~S to the operand ~A is not of type ~S." arg name type))))
+
+
+;;; The actual opcodes. 
+
+
+(defopcode :break nil)
+
+                                                             ; For debugging only.  Not
+
+
+(defopcode :beep nil)
+
+                                                             ; all ports are required to
+
+
+(defopcode :print (:reg))
+
+                                                             ; implement this.
+
+
+(defopcode :move (:operand (or :reg :iref :cdr :lisp-variable)))
+
+(defopcode :eq ((or :reg :constant)
+                (or :reg :constant)
+                :label))
+
+(defopcode :neq ((or :reg :constant)
+                 (or :reg :constant)
+                 :label))
+
+(defopcode :fix= ((or :reg :constant)
+                  (or :reg :constant)
+                  :label))
+
+(defopcode :izerop (:reg :label))
+
+(defopcode :std-instance-p (:reg :label))
+
+(defopcode :fsc-instance-p (:reg :label))
+
+(defopcode :built-in-instance-p (:reg :label))
+
+(defopcode :structure-instance-p (:reg :label))
+
+(defopcode :jmp ((or :reg :constant)))
+
+(defopcode :label (:label))
+
+(defopcode :go (:label))
+
+(defopcode :return ((or :reg :constant)))
+
+(defopcode :exit-lap-in-lisp nil)
+
+
+;;; The actual operands. 
+
+
+(defoperand :reg (:register-number))
+
+(defoperand :cvar (:symbol))
+
+(defoperand :arg (:symbol))
+
+(defoperand :cdr (:reg))
+
+(defoperand :constant (:t))
+
+(defoperand :std-wrapper (:reg))
+
+(defoperand :fsc-wrapper (:reg))
+
+(defoperand :built-in-wrapper (:reg))
+
+(defoperand :structure-wrapper (:reg))
+
+(defoperand :other-wrapper (:reg))
+
+(defoperand :std-slots (:reg))
+
+(defoperand :fsc-slots (:reg))
+
+(defoperand :cref (:reg :fixnum))
+
+(defoperand :iref (:reg :reg))
+
+(defoperand :iset (:reg :reg :reg))
+
+(defoperand :i1+ (:reg))
+
+(defoperand :i+ (:reg :reg))
+
+(defoperand :i- (:reg :reg))
+
+(defoperand :ilogand (:reg :reg))
+
+(defoperand :ilogxor (:reg :reg))
+
+(defoperand :ishift (:reg :fixnum))
+
+(defoperand :lisp (:t))
+
+(defoperand :lisp-variable (:symbol))
+
+
+;;; LAP tests (there need to be a lot more of these) 
+
diff --git a/clos/2.0/load-clos.lisp b/clos/2.0/load-clos.lisp
new file mode 100644
index 00000000..8ba7e9a2
--- /dev/null
+++ b/clos/2.0/load-clos.lisp
@@ -0,0 +1,42 @@
+;;; -*- Mode: Lisp; Package: xcl-User ; Base: 10.; Syntax: Common-Lisp -*-
+;;;
+
+(in-package "CLOS" :use (list (or (find-package :walker)
+				    (make-package :walker :use '(:lisp)))
+				(or (find-package :iterate)
+				    (make-package :iterate
+						  :use '(:lisp :walker)))
+				(find-package :lisp)))
+(export (intern (symbol-name :iterate)		;Have to do this here,
+		(find-package :iterate))	;because in the defsystem
+	(find-package :iterate))		;(later in this file)
+						;we use the symbol iterate
+						;to name the file
+
+(defun load-truename (&optional (errorp nil))
+  (flet ((bad-time ()
+	   (when errorp
+	     (error "LOAD-TRUENAME called but a file isn't being loaded."))))
+    (let ((filename (pathname (il:fullname *standard-input*))))
+      (if filename
+	  (make-pathname :host (pathname-host filename) :device
+			 (pathname-device filename) :directory
+			 (pathname-directory filename) :name "") 
+	  (bad-time)))))
+
+(defvar *clos-directory* (load-truename))
+
+(defun load-clos (&optional pathname)
+  (defvar *clos-system-date* "7/14/91 Medley 2.0 (interim)")
+  (defvar *the-clos-package* (find-package :clos))
+  (dolist (filename '(patch pkg walk iterate macros low low2 fin
+		    defclass defs fngen lap plap cache dlap boot
+		    vector slots init std-class cpl braid fsc methods
+		    combin dfun precom1 precom2 precom4 fixup
+		    defcombin ctypes construct env))
+
+    (load (merge-pathnames 
+			 (make-pathname  :name (string-downcase filename) :type
+					 "dfasl") (or pathname *clos-directory*))))
+  (pushnew :clos cl:*features*))
+
diff --git a/clos/2.0/low.lisp b/clos/2.0/low.lisp
new file mode 100644
index 00000000..dcd28cef
--- /dev/null
+++ b/clos/2.0/low.lisp
@@ -0,0 +1,194 @@
+
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 26-Mar-91 10:29:45 from source low
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>low.;4 created 27-Feb-91 17:16:47
+
+;;;. Copyright (c) 1991 by Venue
+
+
+
+(in-package "CLOS")
+
+;;; Shadow, Export, Require, Use-package, and Import forms should follow here
+
+
+
+;;;
+;;;*************************************************************************
+;;;Copyright (c) 1991 Venue
+;;; This file contains portable versions of low-level functions and macros which are ripe for
+;;; implementation specific customization.  None of the code in this file *has* to be customized for
+;;; a particular Common Lisp implementation. Moreover, in some implementations it may not make any
+;;; sense to customize some of this code. ks. 
+
+
+(defmacro %svref (vector index)
+       `(locally (declare (optimize (speed 3)
+                                 (safety 0))
+                        (inline svref))
+               (svref (the simple-vector ,vector)
+                      (the fixnum ,index))))
+
+(defsetf %svref (vector index)
+       (new-value)
+       `(locally (declare (optimize (speed 3)
+                                 (safety 0))
+                        (inline svref))
+               (setf (svref (the simple-vector ,vector)
+                            (the fixnum ,index))
+                     ,new-value)))
+
+
+;;; without-interrupts OK, Common Lisp doesn't have this and for good reason.  But For all of the
+;;; Common Lisp's that CLOS runs on today, there is a meaningful way to implement this.  WHAT I MEAN
+;;; IS: I want the body to be evaluated in such a way that no other code that is running CLOS can be
+;;; run during that evaluation.  I agree that the body won't take *long* to evaluate.  That is to
+;;; say that I will only use without interrupts around relatively small computations. INTERRUPTS-ON
+;;; should turn interrupts back on if they were on. INTERRUPTS-OFF should turn interrupts back off.
+;;; These are only valid inside the body of WITHOUT-INTERRUPTS. OK? 
+
+
+
+;;; AKW: IT'S CALLED, BUT NEVER REALLY USED, SO I'VE REPLACED IT WITH THE PROGN. IF WE REALLY NEED
+;;; IT, CAN BE TRIVIALLY DONE WITH IL:MONITORS
+
+
+(defmacro without-interrupts (&body body)
+       `(progn ,.body))
+
+
+;;; Very Low-Level representation of instances with meta-class standard-class. 
+
+
+(defmacro std-instance-wrapper (x)
+       `(%std-instance-wrapper ,x))
+
+(defmacro std-instance-slots (x)
+       `(%std-instance-slots ,x))
+
+(defun print-std-instance (instance stream depth)
+                                                             ; A temporary definition used
+       (declare (ignore depth))
+                                                             ; for debugging the bootstrap
+       (printing-random-thing (instance stream)
+                                                             ; code of CLOS (See high.lisp).
+              (format stream "#<std-instance>")))
+
+(defmacro %allocate-instance--class (no-of-slots)
+       `(let ((instance (%%allocate-instance--class)))
+             (%allocate-instance--class-1 ,no-of-slots instance)
+             instance))
+
+(defmacro %allocate-instance--class-1 (no-of-slots instance)
+       (once-only (instance)
+              `(progn (setf (std-instance-slots ,instance)
+                            (%allocate-static-slot-storage--class ,no-of-slots)))))
+
+
+;;; This is the value that we stick into a slot to tell us that it is unbound. It may seem gross,
+;;; but for performance reasons, we make this an interned symbol.  That means that the fast check to
+;;; see if a slot is unbound is to say (EQ <val> '..SLOT-UNBOUND..).  That is considerably faster
+;;; than looking at the value of a special variable.  Be careful, there are places in the code which
+;;; actually use ..slot-unbound.. rather than this variable.  So much for modularity 
+
+
+(defvar *slot-unbound* '..slot-unbound..)
+
+(defmacro %allocate-static-slot-storage--class (no-of-slots)
+       `(make-array ,no-of-slots :initial-element *slot-unbound*))
+
+(defmacro std-instance-class (instance)
+       `(wrapper-class (std-instance-wrapper ,instance)))
+
+
+;; 
+
+
+
+;;; FUNCTION-ARGLIST
+
+
+
+;; 
+
+
+
+;;; [COMMENTED OUT AKW. NEVER CALLED] Given something which is functionp, function-arglist should
+;;; return the argument list for it.  CLOS does not count on having this available, but
+;;; MAKE-SPECIALIZABLE works much better if it is available.  Versions of function-arglist for each
+;;; specific port of clos should be put in the appropriate xxx-low file. This is what it should look
+;;; like: 
+
+
+                                                             ; (defun function-arglist (function)
+                                                             ; (<system-dependent-arglist-function>
+                                                             ; function)) 
+
+
+
+;; (FUNCTIONS CLOS::FUNCTION-PRETTY-ARGLIST) (SETFS CLOS::FUNCTION-PRETTY-ARGLIST) (FUNCTIONS
+;; CLOS::SET-FUNCTION-PRETTY-ARGLIST)
+
+
+
+;;; set-function-name When given a function should give this function the name <new-name>. Note that
+;;; <new-name> is sometimes a list.  Some lisps get the upset in the tummy when they start thinking
+;;; about functions which have lists as names.  To deal with that there is set-function-name-intern
+;;; which takes a list spec for a function name and turns it into a symbol if need be. When given a
+;;; funcallable instance, set-function-name MUST side-effect that FIN to give it the name.  When
+;;; given any other kind of function set-function-name is allowed to return new function which is
+;;; the 'same' except that it has the name. In all cases, set-function-name must return the new (or
+;;; same) function. 
+
+
+(defun set-function-name #'new-name (declare (notinline set-function-name-1 intern-function-name))
+       (set-function-name-1 function (intern-function-name new-name)
+              new-name))
+
+(defun set-function-name-1 (fn new-name uninterned-name)
+       (cond ((typep fn 'il:compiled-closure)
+              (il:\\rplptr (compiled-closure-fnheader fn)
+                     4 new-name)
+              (when (and (consp uninterned-name)
+                         (eq (car uninterned-name)
+                             'method))
+                  (let ((debug (si::compiled-function-debugging-info fn)))
+                       (when debug
+                           (setf (cdr debug)
+                                 uninterned-name)))))
+             (t nil))
+       fn)
+
+(defun intern-function-name (name)
+       (cond ((symbolp name)
+              name)
+             ((listp name)
+              (intern (let ((*package* *the-clos-package*)
+                            (*print-case* :upcase)
+                            (*print-gensym* 't))
+                           (format nil "~S" name))
+                     *the-clos-package*))))
+
+
+;;; COMPILE-LAMBDA This is like the Common Lisp function COMPILE.  In fact, that is what it ends up
+;;; calling.   
+
+
+(defun compile-lambda (lambda &rest desirability)
+       (declare (ignore desirability))
+       (compile nil lambda))
+
+(defmacro precompile-random-code-segments (&optional system)
+  `(progn
+     (precompile-function-generators ,system)
+     (precompile-dfun-constructors ,system)))
+
+
+
+(defun record-definition (type spec &rest args)
+  (declare (ignore type spec args))
+  ())
+
+(defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun)
\ No newline at end of file
diff --git a/clos/2.0/low2.lisp b/clos/2.0/low2.lisp
new file mode 100644
index 00000000..0c648b9b
--- /dev/null
+++ b/clos/2.0/low2.lisp
@@ -0,0 +1,144 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 26-Mar-91 10:30:44 from source xerox-low
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>xerox-low.;3 created 27-Feb-91 16:37:43
+
+;;;. Copyright (c) 1991 by Venue
+
+
+
+(in-package "CLOS")
+
+;;; Shadow, Export, Require, Use-package, and Import forms should follow here
+
+
+
+;;; ************************************************************************* This is the 1100
+;;; (Xerox version) of the file portable-low. 
+
+
+(defmacro load-time-eval (form)
+       `(il:loadtimeconstant ,form))
+
+
+;;; make the pointer from an instance to its class wrapper be an xpointer. this prevents instance
+;;; creation from spending a lot of time incrementing the large refcount of the class-wrapper.  This
+;;; is safe because there will always be some other pointer to the wrapper to keep it around. 
+
+
+(defstruct (std-instance (:predicate std-instance-p)
+                  (:conc-name %std-instance-)
+                  (:constructor %%allocate-instance--class nil)
+                  (:fast-accessors t)
+                  (:print-function %print-std-instance))
+       (wrapper nil :type il:fullxpointer)
+       (slots nil))
+
+(defun %print-std-instance (instance &optional stream depth)
+       
+       ;; See the IRM, section 25.3.3.  Unfortunatly, that documentation is not correct.  In
+       ;; particular, it makes no mention of the third argument. 
+       (cond ((streamp stream)
+              
+              ;; Use the standard CLOS printing method, then return T to tell the printer that we
+              ;; have done the printing ourselves. 
+              (print-std-instance instance stream depth)
+              t)
+             (t 
+                ;; Internal printing (again, see the IRM section 25.3.3). Return a list containing
+                ;; the string of characters that would be printed, if the object were being printed
+                ;; for real. 
+                (list (with-output-to-string (stream)
+                             (print-std-instance instance stream depth))))))
+
+
+;; 
+
+
+
+;;; FUNCTION-ARGLIST
+
+
+
+;; 
+
+
+(defun function-arglist (x)
+       
+       ;; Xerox lisp has the bad habit of returning a symbol to mean &rest, and strings instead of
+       ;; symbols.  How silly. 
+       (let ((arglist (il:arglist x)))
+            (when (symbolp arglist)
+                
+                ;; This could be due to trying to extract the arglist of an interpreted function
+                ;; (though why that should be hard is beyond me).  On the other hand, if the
+                ;; function is compiled, it helps to ask for the "smart" arglist. 
+                (setq arglist (if (consp (symbol-function x))
+                                  (second (symbol-function x))
+                                  (il:arglist x t))))
+            (if (symbolp arglist)
+                
+                ;; Probably never get here, but just in case
+                (list '&rest 'rest)
+                
+                ;; Make sure there are no strings where there should be symbols
+                (if (some #'stringp arglist)
+                    (mapcar #'(lambda (a)
+                                     (if (symbolp a)
+                                         a
+                                         (intern a)))
+                           arglist)
+                    arglist))))
+
+(defun printing-random-thing-internal (thing stream)
+       (let ((*print-base* 8))
+            (princ (il:\\hiloc thing)
+                   stream)
+            (princ "," stream)
+            (princ (il:\\loloc thing)
+                   stream)))
+
+(defun record-definition (name type &optional parent-name parent-type)
+       (declare (ignore type parent-name))
+       nil)
+
+
+;;; FIN uses this too! 
+
+
+(eval-when (compile load eval)
+       (il:datatype il:compiled-closure (il:fnheader il:environment))
+       (il:blockrecord closure-overlay ((funcallable-instance-p il:flag))))
+
+(defun compiled-closure-fnheader (compiled-closure)
+       (il:fetch (il:compiled-closure il:fnheader)
+              il:of compiled-closure))
+
+(defun set-compiled-closure-fnheader (compiled-closure nv)
+       (il:replace (il:compiled-closure il:fnheader)
+              il:of compiled-closure nv))
+
+(defsetf compiled-closure-fnheader set-compiled-closure-fnheader)
+
+
+;;; In Lyric, and until the format of FNHEADER changes, getting the name from a compiled closure
+;;; looks like this: (fetchfield '(nil 4 pointer) (fetch (compiled-closure fnheader) closure)) Of
+;;; course this is completely non-robust, but it will work for now.  This is not the place to go
+;;; into a long tyrade about what is wrong with having record package definitions go away when you
+;;; ship the sysout; there isn't enough diskspace. 
+
+
+(defun set-function-name-1 (fn new-name uninterned-name)
+       (cond ((typep fn 'il:compiled-closure)
+              (il:\\rplptr (compiled-closure-fnheader fn)
+                     4 new-name)
+              (when (and (consp uninterned-name)
+                         (eq (car uninterned-name)
+                             'method))
+                  (let ((debug (si::compiled-function-debugging-info fn)))
+                       (when debug
+                           (setf (cdr debug)
+                                 uninterned-name)))))
+             (t nil))
+       fn)
diff --git a/clos/2.0/macros.lisp b/clos/2.0/macros.lisp
new file mode 100644
index 00000000..4f6a294d
--- /dev/null
+++ b/clos/2.0/macros.lisp
@@ -0,0 +1,355 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 26-Mar-91 10:27:21 from source macros
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>macros.;3 created 19-Feb-91 13:51:21
+
+;;;. Copyright (c) 1991 Venue
+
+
+
+(in-package "CLOS")
+
+
+;;;Macros global variable
+;;; definitions, and other random support stuff used by the rest of the system. For simplicity (not
+;;; having to use eval-when a lot), this file must be loaded before it can be compiled. 
+
+
+(in-package 'clos)
+
+(proclaim '(declaration values arglist indentation class variable-rebinding clos-fast-call))
+
+
+;;; Age old functions which CommonLisp cleaned-up away.  They probably exist in other packages in
+;;; all CommonLisp implementations, but I will leave it to the compiler to optimize into calls to
+;;; them. Common Lisp BUG: Some Common Lisps define these in the Lisp package which causes all sorts
+;;; of lossage.  Common Lisp should explictly specify which symbols appear in the Lisp package. 
+
+
+(eval-when (compile load eval)
+       (defmacro memq (item list)
+              `(member ,item ,list :test #'eq))
+       (defmacro assq (item list)
+              `(assoc ,item ,list :test #'eq))
+       (defmacro rassq (item list)
+              `(rassoc ,item ,list :test #'eq))
+       (defmacro delq (item list)
+              `(delete ,item ,list :test #'eq))
+       (defmacro posq (item list)
+              `(position ,item ,list :test #'eq))
+       (defmacro neq (x y)
+              `(not (eq ,x ,y)))
+       (defun make-caxr (n form)
+              (if (< n 4)
+                  `(,(nth n '(car cadr caddr cadddr))
+                    ,form)
+                  (make-caxr (- n 4)
+                         `(cddddr ,form))))
+       (defun make-cdxr (n form)
+              (cond ((zerop n)
+                     form)
+                    ((< n 5)
+                     `(,(nth n '(identity cdr cddr cdddr cddddr))
+                       ,form))
+                    (t (make-cdxr (- n 4)
+                              `(cddddr ,form))))))
+
+(defun zero (&rest ignore)
+       (declare (ignore ignore))
+       0)
+
+(defun make-plist (keys vals)
+       (if (null vals)
+           nil
+           (list* (car keys)
+                  (car vals)
+                  (make-plist (cdr keys)
+                         (cdr vals)))))
+
+(defun remtail (list tail)
+       (if (eq list tail)
+           nil
+           (cons (car list)
+                 (remtail (cdr list)
+                        tail))))
+
+
+;;; ONCE-ONLY does the same thing as it does in zetalisp.  I should have just lifted it from there
+;;; but I am honest.  Not only that but this one is written in Common Lisp.  I feel a lot like
+;;; bootstrapping, or maybe more like rebuilding Rome. 
+
+
+(defmacro once-only (vars &body body)
+       (let ((gensym-var (gensym))
+             (run-time-vars (gensym))
+             (run-time-vals (gensym))
+             (expand-time-val-forms nil))
+            (dolist (var vars)
+                (push `(if (or (symbolp ,var)
+                               (numberp ,var)
+                               (and (listp ,var)
+                                    (member (car ,var)
+                                           ''function)))
+                           ,var
+                           (let ((,gensym-var (gensym)))
+                                (push ,gensym-var ,run-time-vars)
+                                (push ,var ,run-time-vals)
+                                ,gensym-var))
+                      expand-time-val-forms))
+            `(let* (,run-time-vars ,run-time-vals (wrapped-body (let ,(mapcar #'list vars
+                                                                             (reverse 
+                                                                                expand-time-val-forms
+                                                                                    ))
+                                                                     ,@body)))
+                   `(let ,(mapcar #'list (reverse ,run-time-vars)
+                                 (reverse ,run-time-vals))
+                         ,wrapped-body))))
+
+(eval-when
+ (compile load eval)
+ (defun extract-declarations (body &optional environment)
+        (declare (values documentation declarations body))
+        (let (documentation declarations form)
+             (when (and (stringp (car body))
+                        (cdr body))
+                 (setq documentation (pop body)))
+             (block outer
+                 (loop (when (null body)
+                             (return-from outer nil))
+                       (setq form (car body))
+                       (when (block inner
+                                 (loop (cond ((not (listp form))
+                                              (return-from outer nil))
+                                             ((eq (car form)
+                                                  'declare)
+                                              (return-from inner 't))
+                                             (t (multiple-value-bind
+                                                 (newform macrop)
+                                                 (macroexpand-1 form environment)
+                                                 (if (or (not (eq newform form))
+                                                         macrop)
+                                                     (setq form newform)
+                                                     (return-from outer nil)))))))
+                           (pop body)
+                           (dolist (declaration (cdr form))
+                               (push declaration declarations)))))
+             (values documentation (and declarations `((declare ,.(nreverse declarations))))
+                    body))))
+
+(defvar *keyword-package* (find-package 'keyword))
+
+(defun make-keyword (symbol)
+       (intern (symbol-name symbol)
+              *keyword-package*))
+
+(eval-when (compile load eval)
+       (defun string-append (&rest strings)
+              (setq strings (copy-list strings))
+                                                             ; The explorer can't even rplaca an
+                                                             ; &rest arg? 
+              (do ((string-loc strings (cdr string-loc)))
+                  ((null string-loc)
+                   (apply #'concatenate 'string strings))
+                (rplaca string-loc (string (car string-loc))))))
+
+(defun symbol-append (sym1 sym2 &optional (package *package*))
+       (intern (string-append sym1 sym2)
+              package))
+
+(defmacro check-member (place list &key (test #'eql)
+                              (pretty-name place))
+       (once-only (place list)
+              `(or (member ,place ,list :test ,test)
+                   (error "The value of ~A, ~S is not one of ~S." ',pretty-name ,place ,list))))
+
+(defmacro alist-entry (alist key make-entry-fn)
+       (once-only (alist key)
+              `(or (assq ,key ,alist)
+                   (progn (setf ,alist (cons (,make-entry-fn ,key)
+                                             ,alist))
+                          (car ,alist)))))
+
+(defmacro collecting-once (&key initial-value)
+       `(let* ((head ,initial-value)
+               (tail ,(and initial-value `(last head))))
+              (values #'(lambda (value)
+                               (if (null head)
+                                   (setq head (setq tail (list value)))
+                                   (unless (memq value head)
+                                       (setq tail (cdr (rplacd tail (list value)))))))
+                     #'(lambda nil head))))
+
+(defmacro doplist ((key val)
+                   plist &body body &environment env)
+       (multiple-value-bind (doc decls bod)
+              (extract-declarations body env)
+              (declare (ignore doc))
+              `(let ((.plist-tail. ,plist)
+                     ,key
+                     ,val)
+                    ,@decls
+                    (loop (when (null .plist-tail.)
+                                (return nil))
+                          (setq ,key (pop .plist-tail.))
+                          (when (null .plist-tail.)
+                                (error "Malformed plist in doplist, odd number of elements."))
+                          (setq ,val (pop .plist-tail.))
+                          (progn ,@bod)))))
+
+(defmacro if* (condition true &rest false)
+       `(if ,condition
+            ,true
+            (progn ,@false)))
+
+
+;; 
+
+
+
+;;; printing-random-thing
+
+
+
+;; 
+
+
+
+;;; Similar to printing-random-object in the lisp machine but much simpler and machine independent. 
+
+
+(defmacro printing-random-thing ((thing stream)
+                                 &body body)
+       (once-only (stream)
+              `(progn (format ,stream "#<")
+                      ,@body
+                      (format ,stream " ")
+                      (printing-random-thing-internal ,thing ,stream)
+                      (format ,stream ">"))))
+
+(defun printing-random-thing-internal (thing stream)
+       (let ((*print-base* 8))
+            (princ (il:\\hiloc thing)
+                   stream)
+            (princ "," stream)
+            (princ (il:\\loloc thing)
+                   stream)))
+
+
+;; 
+
+
+
+;;; 
+
+
+
+;; 
+
+
+(defun capitalize-words (string &optional (dashes-p t))
+       (let ((string (copy-seq (string string))))
+            (declare (string string))
+            (do* ((flag t flag)
+                  (length (length string)
+                         length)
+                  (char nil char)
+                  (i 0 (+ i 1)))
+                 ((= i length)
+                  string)
+               (setq char (elt string i))
+               (cond ((both-case-p char)
+                      (if flag
+                          (and (setq flag (lower-case-p char))
+                               (setf (elt string i)
+                                     (char-upcase char)))
+                          (and (not flag)
+                               (setf (elt string i)
+                                     (char-downcase char))))
+                      (setq flag nil))
+                     ((char-equal char #\-)
+                      (setq flag t)
+                      (unless dashes-p
+                          (setf (elt string i)
+                                #\Space)))
+                     (t (setq flag nil))))))
+
+
+;;; FIND-CLASS This is documented in the CLOS specification. 
+
+
+(defvar *find-class* (make-hash-table :test #'eq))
+
+(defun legal-class-name-p (x)
+       (and (symbolp x)
+            (not (keywordp x))))
+
+(defun find-class (symbol &optional (errorp t)
+                         environment)
+       (declare (ignore environment))
+       (or (gethash symbol *find-class*)
+           (cond ((null errorp)
+                  nil)
+                 ((legal-class-name-p symbol)
+                  (error "No class named: ~S." symbol))
+                 (t (error "~S is not a legal class name." symbol)))))
+
+(defsetf find-class (symbol &optional (errorp t)
+                           environment)
+       (new-value)
+       (declare (ignore errorp environment))
+       `(|SETF CLOS FIND-CLASS| ,new-value ,symbol))
+
+(defun |SETF CLOS FIND-CLASS| (new-value symbol)
+       (if (legal-class-name-p symbol)
+           (setf (gethash symbol *find-class*)
+                 new-value)
+           (error "~S is not a legal class name." symbol)))
+
+(defun find-wrapper (symbol)
+       (class-wrapper (find-class symbol)))
+
+(defmacro gathering1 (gatherer &body body)
+  `(gathering ((.gathering1. ,gatherer))
+               (macrolet ((gather1 (x)
+                                 `(gather ,x .gathering1.)))
+                      ,@body)))
+
+
+;;; 
+
+
+(defmacro vectorizing (&key (size 0))
+       `(let* ((limit ,size)
+               (result (make-array limit))
+               (index 0))
+              (values #'(lambda (value)
+                               (if (= index limit)
+                                   (error "vectorizing more elements than promised.")
+                                   (progn (setf (svref result index)
+                                                value)
+                                          (incf index)
+                                          value)))
+                     #'(lambda nil result))))
+
+
+;;; These are augmented definitions of list-elements and list-tails from iterate.lisp.  These
+;;; versions provide the extra :by keyword which can be used to specify the step function through
+;;; the list. 
+
+
+(defmacro *list-elements (list &key (by #'cdr))
+       `(let ((tail ,list))
+             #'(lambda (finish)
+                      (if (endp tail)
+                          (funcall finish)
+                          (prog1 (car tail)
+                              (setq tail (funcall ,by tail)))))))
+
+(defmacro *list-tails (list &key (by #'cdr))
+       `(let ((tail ,list))
+             #'(lambda (finish)
+                      (prog1 (if (endp tail)
+                                 (funcall finish)
+                                 tail)
+                          (setq tail (funcall ,by tail))))))
diff --git a/clos/2.0/methods.lisp b/clos/2.0/methods.lisp
new file mode 100644
index 00000000..fa52befe
--- /dev/null
+++ b/clos/2.0/methods.lisp
@@ -0,0 +1,1304 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+
+
+;;; METHODS Methods themselves are simple inanimate objects.  Most properties of methods are
+;;; immutable, methods cannot be reinitialized.  The following properties of methods can be changed:
+;;; METHOD-GENERIC-FUNCTION METHOD-FUNCTION            ?? 
+
+(defclass method (metaobject) ())
+
+(defclass standard-method (definition-source-mixin documentation-mixin method)
+     ((generic-function
+	:initform nil	
+	:accessor method-generic-function)
+;     (qualifiers
+;	:initform ()
+;	:initarg  :qualifiers
+;	:reader method-qualifiers)
+      (specializers
+	:initform ()
+	:initarg  :specializers
+	:reader method-specializers)
+      (lambda-list
+	:initform ()
+	:initarg  :lambda-list
+	:reader method-lambda-list)
+      (function
+	:initform nil
+	:initarg :function
+	:reader method-function)		;writer defined by hand
+;     (documentation
+;	:initform ""
+;	:initarg  :documentation)
+      ))
+
+(defclass standard-accessor-method (standard-method)
+     ((slot-name :initform nil
+		 :initarg :slot-name)))
+
+
+;;; This method has to be defined by hand!  Don't try to define it using :accessor or :reader.  It
+;;; can't be an automatically generated reader method because that would break the way the special
+;;; discriminator code which uses this feature works.  -- Probably false now 8/21 
+
+
+(defmethod accessor-method-slot-name ((m standard-accessor-method))
+       (slot-value m 'slot-name))
+
+(defclass standard-reader-method (standard-accessor-method) ())
+(defclass standard-writer-method (standard-accessor-method) ())
+
+(defmethod print-object ((method standard-method)
+                         stream)
+       (printing-random-thing (method stream)
+              (let ((generic-function (method-generic-function method))
+                    (class-name (capitalize-words (class-name (class-of method)))))
+                   (format stream "~A ~S ~{~S ~}~:S" class-name (and generic-function (
+                                                                                generic-function-name
+                                                                                       
+                                                                                     generic-function
+                                                                                       ))
+                          (method-qualifiers method)
+                          (unparse-specializers method)))))
+
+(defmethod print-object ((method standard-accessor-method)
+                         stream)
+       (printing-random-thing (method stream)
+              (let ((generic-function (method-generic-function method))
+                    (class-name (capitalize-words (class-name (class-of method)))))
+                   (format stream "~A ~S, slot:~S, ~:S" class-name (and generic-function (
+                                                                                generic-function-name
+                                                                                          
+                                                                                     generic-function
+                                                                                          ))
+                          (accessor-method-slot-name method)
+                          (unparse-specializers method)))))
+
+
+;;; INITIALIZATION Error checking is done in before methods.  Because of the simplicity of standard
+;;; method objects the standard primary method can fill the slots. Methods are not reinitializable. 
+
+
+(defmethod reinitialize-instance ((method standard-method)
+                                  &rest initargs)
+       (declare (ignore initargs))
+       (error 
+        "Attempt to reinitialize the method ~S.~%~
+          Method objects cannot be reinitialized." method))
+
+(defmethod shared-initialize :before ((method standard-method)
+                                      slot-names &key qualifiers lambda-list specializers function 
+                                      documentation)
+       (declare (ignore slot-names))
+       (flet ((lose (initarg value string)
+                    (error "When initializing the method ~S:~%~
+                   The ~S initialization argument was: ~S.~%~
+                   which ~A." method initarg value string)))
+             (let ((check-qualifiers (legal-std-qualifiers-p qualifiers))
+                   (check-lambda-list (legal-std-lambda-list-p lambda-list))
+                   (check-specializers (legal-std-specializers-p specializers))
+                   (check-function (legal-std-method-function-p function))
+                   (check-documentation (legal-std-documentation-p documentation)))
+                  (unless (eq check-qualifiers t)
+                         (lose :qualifiers qualifiers check-qualifiers))
+                  (unless (eq check-lambda-list t)
+                         (lose :lambda-list lambda-list check-lambda-list))
+                  (unless (eq check-specializers t)
+                         (lose :specializers specializers check-specializers))
+                  (unless (eq check-function t)
+                         (lose :function function check-function))
+                  (unless (eq check-documentation t)
+                         (lose :documentation documentation check-documentation)))))
+
+(defmethod shared-initialize :before ((method standard-accessor-method)
+                                      slot-names &key slot-name)
+       (declare (ignore slot-names))
+       (let ((legalp (legal-std-slot-name-p slot-name)))
+            (unless (eq legalp t)
+                   (error "The value of the :SLOT-NAME initarg ~A." legalp))))
+
+(defmethod shared-initialize :after ((method standard-method)
+                                     slot-names &key qualifiers)
+       (setf (plist-value method 'qualifiers)
+             qualifiers))
+
+(defmethod method-qualifiers ((method standard-method))
+       (plist-value method 'qualifiers))
+
+(defclass generic-function (dependent-update-mixin
+			    definition-source-mixin
+			    metaobject)
+     ()
+  (:metaclass funcallable-standard-class))
+    
+(defclass standard-generic-function (generic-function)
+     ((name
+	:initform nil
+	:initarg :name
+	:accessor generic-function-name)
+      (methods
+	:initform ()
+	:accessor generic-function-methods)
+      (method-class
+	:initarg :method-class
+	:accessor generic-function-method-class)
+      (method-combination
+	:initarg :method-combination
+	:accessor generic-function-method-combination)
+
+;     (permutation
+;	:accessor gf-permutation)
+      (arg-info
+	:initform ()
+	:accessor gf-arg-info)
+      (dfun-state
+	:initform ()
+	:accessor gf-dfun-state)
+      (effective-method-functions		;((methods . fn) ..)
+	:initform ()
+	:accessor gf-effective-method-functions)
+      (valid-p
+	:initform nil
+	:accessor gf-valid-p)
+      (pretty-arglist
+	:initform ()
+	:accessor gf-pretty-arglist)
+      )
+  (:metaclass funcallable-standard-class)
+  (:default-initargs :method-class *the-class-standard-method*
+		     :method-combination *standard-method-combination*))
+
+
+(define-gf-predicate generic-function-p generic-function)
+
+(define-gf-predicate method-p method)
+
+(define-gf-predicate standard-accessor-method-p standard-accessor-method)
+
+(define-gf-predicate standard-reader-method-p standard-reader-method)
+
+(define-gf-predicate standard-writer-method-p standard-writer-method)
+
+(defvar *the-class-method* (find-class 'method))
+
+(defvar *the-class-standard-method* (find-class 'standard-method))
+
+(defvar *the-class-generic-function* (find-class 'generic-function))
+
+(defvar *the-class-standard-generic-function* (find-class 'standard-generic-function))
+
+(defmethod print-object ((generic-function generic-function)
+                         stream)
+       (named-object-print-function generic-function stream (list (length (generic-function-methods
+                                                                           generic-function)))))
+
+(defmethod shared-initialize :before ((generic-function standard-generic-function)
+                                      slot-names &key (name nil namep)
+                                      (lambda-list nil lambda-list-p)
+                                      argument-precedence-order declarations documentation
+                                      (method-class nil method-class-supplied-p)
+                                      (method-combination nil method-combination-supplied-p))
+       (declare (ignore slot-names declarations argument-precedence-order lambda-list lambda-list-p 
+                       name))
+       (when namep (set-function-name generic-function name))
+       (flet ((initarg-error (initarg value string)
+                     (error "When initializing the generic-function ~S:~%~
+                   The ~S initialization argument was: ~A.~%~
+                   It must be ~A." generic-function initarg value string)))
+             (cond (method-class-supplied-p (when (symbolp method-class)
+                                                (setq method-class (find-class method-class)))
+                          (unless (and (classp method-class)
+                                       (*subtypep method-class *the-class-method*))
+                                 (initarg-error :method-class method-class 
+                                        "a subclass of the class METHOD"))
+                          (setf (slot-value generic-function 'method-class)
+                                method-class))
+                   ((slot-boundp generic-function 'method-class))
+                   (t (initarg-error :method-class "not supplied" "a subclass of the class METHOD")))
+             (cond (method-combination-supplied-p (unless (method-combination-p method-combination)
+                                                         (initarg-error :method-combination 
+                                                                method-combination 
+                                                                "a method combination object")))
+                   ((slot-boundp generic-function 'method-combination))
+                   (t (initarg-error :method-combination "not supplied" "a method combination object"
+                             )))))
+
+(defmethod initialize-instance :after ((gf standard-generic-function)
+                                       &key lambda-list argument-precedence-order)
+       (declare (ignore slot-names))
+       (when lambda-list
+           (setf (gf-arg-info gf)
+                 (new-arg-info-from-generic-function lambda-list argument-precedence-order))))
+
+(defmethod reinitialize-instance ((generic-function standard-generic-function)
+                                  &rest initargs &key name lambda-list argument-precedence-order 
+                                  declarations documentation method-class method-combination)
+       (declare (ignore documentation declarations argument-precedence-order lambda-list name 
+                       method-class method-combination))
+       (macrolet ((add-initarg (check name slot-name)
+                         `(unless ,check
+                              (push (slot-value generic-function ,slot-name)
+                                    initargs)
+                              (push ,name initargs))))
+                                                             ; (add-initarg name :name 'name)
+                                                             ; (add-initarg lambda-list :lambda-list
+                                                             ; 'lambda-list) (add-initarg
+                                                             ; argument-precedence-order
+                                                             ; :argument-precedence-order
+                                                             ; 'argument-precedence-order)
+                                                             ; (add-initarg declarations
+                                                             ; :declarations 'declarations)
+                                                             ; (add-initarg documentation
+                                                             ; :documentation 'documentation)
+                                                             ; (add-initarg method-class
+                                                             ; :method-class 'method-class)
+                                                             ; (add-initarg method-combination
+                                                             ; :method-combination
+                                                             ; 'method-combination) 
+              (apply #'call-next-method generic-function initargs)))
+
+
+;;; These three are scheduled for demolition. 
+
+
+(defmethod remove-named-method (generic-function-name argument-specifiers &optional extra)
+       (let ((generic-function nil)
+             (method nil))
+            (cond ((or (null (fboundp generic-function-name))
+                       (not (generic-function-p (setq generic-function (symbol-function 
+                                                                              generic-function-name))
+                                   )))
+                   (error "~S does not name a generic-function." generic-function-name))
+                  ((null (setq method (get-method generic-function extra (parse-specializers 
+                                                                                argument-specifiers)
+                                             nil)))
+                   (error "There is no method for the generic-function ~S~%~
+                   which matches the argument-specifiers ~S." generic-function argument-specifiers))
+                  (t (remove-method generic-function method)))))
+
+(defun real-add-named-method (generic-function-name qualifiers specializers lambda-list function 
+                                    &rest other-initargs)
+       
+       ;; What about changing the class of the generic-function if there is one.  Whose job is that
+       ;; anyways.  Do we need something kind of like class-for-redefinition? 
+       (let* ((generic-function (ensure-generic-function generic-function-name :lambda-list
+                                       (method-ll->generic-function-ll lambda-list)))
+              (specs (parse-specializers specializers))
+                                                             ; (existing (get-method
+                                                             ; generic-function qualifiers specs
+                                                             ; nil))
+              (proto (method-prototype-for-gf generic-function-name))
+              (new (apply #'make-instance (class-of proto)
+                          :qualifiers qualifiers :specializers specs :lambda-list lambda-list 
+                          :function function other-initargs)))
+                                                             ; (when existing (remove-method
+                                                             ; generic-function existing))
+             (add-method generic-function new)))
+
+(defun make-specializable (function-name &key (arglist nil arglistp))
+       (cond ((not (null arglistp)))
+             ((not (fboundp function-name)))
+             ((fboundp 'function-arglist)
+              
+              ;; function-arglist exists, get the arglist from it.
+              (setq arglist (function-arglist function-name)))
+             (t (error "The :arglist argument to make-specializable was not supplied~%~
+            and there is no version of FUNCTION-ARGLIST defined for this~%~
+            port of Portable CommonLoops.~%~
+            You must either define a version of FUNCTION-ARGLIST (which~%~
+            should be easy), and send it off to the Portable CommonLoops~%~
+            people or you should call make-specializable again with the~%~
+            :arglist keyword to specify the arglist.")))
+       (let ((original (and (fboundp function-name)
+                            (symbol-function function-name)))
+             (generic-function (make-instance 'standard-generic-function :name function-name))
+             (nrequireds 0))
+            (if (generic-function-p original)
+                original
+                (progn (dolist (arg arglist)
+                           (if (memq arg lambda-list-keywords)
+                               (return)
+                               (incf nrequireds)))
+                       (setf (symbol-function function-name)
+                             generic-function)
+                       (set-function-name generic-function function-name)
+                       (when arglistp
+                           (setf (gf-pretty-arglist generic-function)
+                                 arglist))
+                       (when original
+                           (add-named-method function-name nil (make-list nrequireds :initial-element
+                                                                      't)
+                                  arglist original))
+                       generic-function))))
+
+(defun real-get-method (generic-function qualifiers specializers &optional (errorp t))
+       (let ((hit (dolist (method (generic-function-methods generic-function))
+                      (when (and (equal qualifiers (method-qualifiers method))
+                                 (every #'same-specializer-p specializers (method-specializers method
+                                                                                 )))
+                            (return method)))))
+            (cond (hit hit)
+                  ((null errorp)
+                   nil)
+                  (t (error "No method on ~S with qualifiers ~:S and specializers ~:S." 
+                            generic-function qualifiers specializers)))))
+
+
+;;; Compute various information about a generic-function's arglist by looking at the argument lists
+;;; of the methods.  The hair for trying not to use &rest arguments lives here. The values returned
+;;; are: number-of-required-arguments the number of required arguments to this generic-function's
+;;; discriminating function &rest-argument-p whether or not this generic-function's discriminating
+;;; function takes an &rest argument. specialized-argument-positions a list of the positions of the
+;;; arguments this generic-function specializes (e.g. for a classical generic-function this is the
+;;; list: (1)). 
+
+
+(defmethod compute-discriminating-function-arglist-info ((generic-function standard-generic-function)
+                                                         )
+       (declare (values number-of-required-arguments &rest-argument-p specialized-argument-postions))
+       (let ((number-required nil)
+             (restp nil)
+             (specialized-positions nil)
+             (methods (generic-function-methods generic-function)))
+            (dolist (method methods)
+                (multiple-value-setq (number-required restp specialized-positions)
+                       (compute-discriminating-function-arglist-info-internal generic-function method
+                              number-required restp specialized-positions)))
+            (values number-required restp (sort specialized-positions #'<))))
+
+(defun compute-discriminating-function-arglist-info-internal (generic-function method 
+                                                                    number-of-requireds restp 
+                                                                    specialized-argument-positions)
+       (declare (ignore generic-function))
+       (let ((requireds 0))
+            
+            ;; Go through this methods arguments seeing how many are required, and whether there is
+            ;; an &rest argument. 
+            (dolist (arg (method-lambda-list method))
+                (cond ((eq arg '&aux)
+                       (return))
+                      ((memq arg '(&optional &rest &key))
+                       (return (setq restp t)))
+                      ((memq arg lambda-list-keywords))
+                      (t (incf requireds))))
+            
+            ;; Now go through this method's type specifiers to see which argument positions are type
+            ;; specified.  Treat T specially in the usual sort of way.  For efficiency don't bother
+            ;; to keep specialized-argument-positions sorted, rather depend on our caller to do
+            ;; that. 
+            (iterate ((type-spec (list-elements (method-specializers method)))
+                      (pos (interval :from 0)))
+                   (unless (eq type-spec *the-class-t*)
+                          (pushnew pos specialized-argument-positions)))
+            
+            ;; Finally merge the values for this method into the values for the exisiting methods
+            ;; and return them.  Note that if num-of-requireds is NIL it means this is the first
+            ;; method and we depend on that. 
+            (values (min (or number-of-requireds requireds)
+                         requireds)
+                   (or restp (and number-of-requireds (/= number-of-requireds requireds)))
+                   specialized-argument-positions)))
+
+(defun make-discriminating-function-arglist (number-required-arguments restp)
+       (nconc (gathering ((args (collecting)))
+                     (iterate ((i (interval :from 0 :below number-required-arguments)))
+                            (gather (intern (format nil "Discriminating Function Arg ~D" i))
+                                   args)))
+              (when restp
+                  `(&rest ,(intern "Discriminating Function &rest Arg")))))
+
+
+;;; 
+
+
+(defun make-arg-info (precedence metatypes number-optional key/rest-p keywords)
+       (let ((new (make-array 6 :adjustable nil)))
+            (setf (svref new 0)
+                  'arg-info
+                  (svref new 1)
+                  precedence
+                  (svref new 2)
+                  metatypes
+                  (svref new 3)
+                  number-optional
+                  (svref new 4)
+                  key/rest-p
+                  (svref new 5)
+                  keywords)
+                                                             ; nil         no keyword or rest
+                                                             ; allowed (k1 k2 ..)  each method must
+                                                             ; accept these keyword arguments T     
+                                                             ; must have &key or &rest 
+            new))
+
+(defun check-arg-info (x)
+       (or (and (simple-vector-p x)
+                (= (array-dimension x 0)
+                   6)
+                (eq (svref x 0)
+                    'arg-info))
+           (error "~S is not an ARG-INFO." x)))
+
+(defun arg-info-precedence (arg-info)
+       (check-arg-info arg-info)
+       (svref arg-info 1))
+
+(defun arg-info-metatypes (arg-info)
+       (check-arg-info arg-info)
+       (svref arg-info 2))
+
+(defun arg-info-number-optional (arg-info)
+       (check-arg-info arg-info)
+       (svref arg-info 3))
+
+(defun arg-info-key/rest-p (arg-info)
+       (check-arg-info arg-info)
+       (svref arg-info 4))
+
+(defun arg-info-keywords (arg-info)
+       (check-arg-info arg-info)
+       (svref arg-info 5))
+
+(defun arg-info-applyp (arg-info)
+       (check-arg-info arg-info)
+       (or (plusp (arg-info-number-optional arg-info))
+           (arg-info-key/rest-p arg-info)))
+
+(defun arg-info-number-required (arg-info)
+       (check-arg-info arg-info)
+       (length (arg-info-metatypes arg-info)))
+
+(defun arg-info-nkeys (arg-info)
+       (count-if #'(lambda (x)
+                          (neq x 't))
+              (arg-info-metatypes arg-info)))
+
+(defun new-arg-info-from-generic-function (lambda-list argument-precedence-order)
+       (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
+           (analyze-lambda-list lambda-list)
+         (declare (ignore allow-other-keys-p))
+         (let ((metatypes (make-list nreq))
+               (precedence (compute-precedence lambda-list nreq argument-precedence-order)))
+              (make-arg-info precedence metatypes nopt (or keysp restp)
+                     keywords))))
+
+(defun new-arg-info-from-method (method)
+       (multiple-value-bind (nreq nopt keysp restp)
+           (analyze-lambda-list (method-lambda-list method))
+         (make-arg-info (compute-precedence (method-lambda-list method)
+                               nreq nil)
+                (mapcar #'raise-metatype (make-list nreq)
+                       (method-specializers method))
+                nopt
+                (or keysp restp)
+                nil)))
+
+(defun add-arg-info (generic-function method arg-info)
+       (flet ((lose (string &rest args)
+                    (error 
+              "Attempt to add the method ~S to the generic function ~S.~%~
+                   But ~A" method generic-function (apply #'format nil string args)))
+              (compare (x y)
+                     (if (> x y)
+                         "more"
+                         "fewer")))
+             (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
+                 (analyze-lambda-list (method-lambda-list method))
+               (let ((gf-nreq (arg-info-number-required arg-info))
+                     (gf-nopt (arg-info-number-optional arg-info))
+                     (gf-key/rest-p (arg-info-key/rest-p arg-info))
+                     (gf-keywords (arg-info-keywords arg-info)))
+                    (unless (= nreq gf-nreq)
+                        (lose "the method has ~A required arguments than the generic function."
+                              (compare nreq gf-nreq)))
+                    (unless (= nopt gf-nopt)
+                        (lose "the method has ~S optional arguments than the generic function."
+                              (compare nopt gf-nopt)))
+                    (unless (eq (or keysp restp)
+                                gf-key/rest-p)
+                           (error "the method and generic function differ in whether they accept~%~
+                  rest or keyword arguments."))
+                    (when gf-keywords
+                        (unless (or (and restp (not keysp))
+                                    allow-other-keys-p
+                                    (every #'(lambda (k)
+                                                    (memq k keywords))
+                                           gf-keywords))
+                               (error "the generic function requires each method to accept the keyword arguments~%~
+               ~S.  The method does not all of accept these." gf-keywords)))
+                    (make-arg-info (arg-info-precedence arg-info)
+                           (mapcar #'raise-metatype (arg-info-metatypes arg-info)
+                                  (method-specializers method))
+                           gf-nopt gf-key/rest-p gf-keywords)))))
+
+(defun remove-arg-info (generic-function method arg-info)
+       (declare (ignore generic-function method))
+       arg-info)
+
+
+;;; 
+
+
+(defun compute-precedence (lambda-list nreq argument-precedence-order)
+       (let ((nreq (analyze-lambda-list lambda-list)))
+            (if (null argument-precedence-order)
+                (let ((c -1))
+                     (gathering1 (collecting)
+                            (dotimes (i nreq)
+                                (gather1 (incf c)))))
+                (mapcar #'(lambda (x)
+                                 (position x lambda-list))
+                       argument-precedence-order))))
+
+(defmethod no-applicable-method (generic-function &rest args)
+       (cerror "Retry call to ~S" 
+         "No matching method for the generic-function ~S,~@
+          when called with arguments ~S." generic-function args)
+       (let ((*invalid-dfuns-on-stack* (remove generic-function *invalid-dfuns-on-stack*)))
+            (invalidate-discriminating-function generic-function)
+            (apply generic-function args)))
+
+(defun real-add-method (generic-function method)
+       (if (method-generic-function method)
+           (error "The method ~S is already part of the generic~@
+              function ~S.  It can't be added to another generic~@
+              function until it is removed from the first one." method (method-generic-function
+                                                                        method))
+           (let* ((qualifiers (method-qualifiers method))
+                  (lambda-list (method-lambda-list method))
+                  (specializers (method-specializers method))
+                  (existing (get-method generic-function qualifiers specializers nil)))
+                 
+                 ;; If there is already a method like this one then we must get rid of it before
+                 ;; proceeding.  Note that we call the generic function remove-method to remove it
+                 ;; rather than doing it in some internal way. 
+                 (when existing (remove-method generic-function existing))
+                 
+                 ;; 
+                 (let ((arg-info (gf-arg-info generic-function)))
+                      (setf (gf-arg-info generic-function)
+                            (if (null arg-info)
+                                (new-arg-info-from-method method)
+                                (add-arg-info generic-function method arg-info)))
+                      (setf (method-generic-function method)
+                            generic-function)
+                      (pushnew method (generic-function-methods generic-function))
+                      (dolist (specializer specializers)
+                          (add-method-on-specializer method specializer))
+                      (invalidate-discriminating-function generic-function)
+                      (maybe-update-constructors generic-function method)
+                      method))))
+
+(defun real-remove-method (generic-function method)
+       (if (neq generic-function (method-generic-function method))
+           (error "The method ~S is attached to the generic function~@
+               ~S.  It can't be removed from the generic function~@
+               to which it is not attached." method (method-generic-function method))
+           (let* ((methods (generic-function-methods generic-function))
+                  (new-methods (remove method methods))
+                  (new-arg-info (remove-arg-info generic-function method (gf-arg-info 
+                                                                                generic-function))))
+                 (setf (method-generic-function method)
+                       nil)
+                 (setf (generic-function-methods generic-function)
+                       new-methods)
+                 (dolist (specializer (method-specializers method))
+                     (remove-method-on-specializer method specializer))
+                 (setf (gf-arg-info generic-function)
+                       new-arg-info)
+                 (invalidate-discriminating-function generic-function)
+                 (maybe-update-constructors generic-function method)
+                 generic-function)))
+
+
+;;; This is it.  You have reached the special place where everything comes together.  This is where
+;;; we ensure that the metacircularity will bottom out properly. Remember once again that the source
+;;; of the problem is that the specified behavior clearly calls for the process of method lookup to
+;;; itself call generic functions.  This implies that for a given generic function in the method
+;;; lookup protocol (compute-applicable-methods for example), we can end up in the unfortunate
+;;; situation of having to call that generic function in order to call it! So, we must arrange to
+;;; snap this infinite regress. The strategy taken here is to identify a particular subset of calls
+;;; to method lookup protocol generic functions and snap the recursion there. This subset of generic
+;;; function calls has the following properties: - Any generic function call in the world will,
+;;; eventually reach one of these generic function calls.  That is we are sure that if we can
+;;; arrange for these calls not to recurse we know we are all set. - These calls themselves don't
+;;; recurse.  We arrange, by magic, for the method lookup and application involved in these calls
+;;; not to call any other generic functions. 
+
+
+(defvar *magic-generic-functions* '((compute-discriminating-function ((standard-generic-function)
+                                                                      (standard-generic-function)))
+                                    (compute-applicable-methods ((standard-generic-function t)
+                                                                 (generic-function t)))
+                                    (compute-applicable-methods-using-classes ((
+                                                                            standard-generic-function
+                                                                                t)
+                                                                               (generic-function
+                                                                                t)))
+                                                             ; (same-specializer-p      
+                                                             ; ((standard-class standard-class) (t
+                                                             ; t))) (specializer-applicable-p
+                                                             ; ((standard-class t) (class t))) 
+                                    (specializer-applicable-using-class-p ((standard-class t)
+                                                                           (class t))
+                                           ((built-in-class t)
+                                            (class t)))
+                                    (order-specializers-using-class ((standard-class standard-class t
+                                                                            )
+                                                                     (class class t)))
+                                    (compute-effective-method ((standard-generic-function
+                                                                (eql *standard-method-combination*)
+                                                                t)
+                                                               (generic-function 
+                                                                      standard-method-combination t))
+                                           )
+                                    (method-p ((standard-method)
+                                               (method))
+                                           ((standard-reader-method)
+                                            (method))
+                                           ((standard-writer-method)
+                                            (method)))
+                                    (standard-accessor-method-p ((standard-method)
+                                                                 (t))
+                                           ((standard-reader-method)
+                                            (standard-accessor-method))
+                                           ((standard-writer-method)
+                                            (standard-accessor-method)))
+                                    (standard-reader-method-p ((standard-method)
+                                                               (t))
+                                           ((standard-reader-method)
+                                            (standard-reader-method))
+                                           ((standard-writer-method)
+                                            (t)))
+                                    (standard-writer-method-p ((standard-method)
+                                                               (t))
+                                           ((standard-reader-method)
+                                            (t))
+                                           ((standard-writer-method)
+                                            (standard-writer-method)))
+                                    (method-qualifiers ((standard-method)
+                                                        (standard-method))
+                                           ((standard-reader-method)
+                                            (standard-method)))
+                                    (method-specializers ((standard-method)
+                                                          (standard-method))
+                                           ((standard-reader-method)
+                                            (standard-method)))
+                                    (method-lambda-list ((standard-method)
+                                                         (standard-method))
+                                           ((standard-reader-method)
+                                            (standard-method)))
+                                    (method-function ((standard-method)
+                                                      (standard-method))
+                                           ((standard-reader-method)
+                                            (standard-method)))
+                                    (accessor-method-slot-name ((standard-reader-method)
+                                                                (standard-accessor-method))
+                                           ((standard-writer-method)
+                                            (standard-accessor-method)))
+                                    (classp ((standard-class)
+                                             (class))
+                                           ((built-in-class)
+                                            (class)))
+                                    (class-precedence-list ((standard-class)
+                                                            (clos-class)))
+                                    (class-finalized-p ((standard-class)
+                                                        (clos-class)))
+                                    (generic-function-methods ((standard-generic-function)
+                                                               (standard-generic-function)))
+                                    (generic-function-method-combination ((standard-generic-function)
+                                                                          (standard-generic-function)
+                                                                          ))
+                                    (gf-arg-info ((standard-generic-function)
+                                                  (standard-generic-function)))
+                                    (gf-dfun-state ((standard-generic-function)
+                                                    (standard-generic-function)))
+                                    (gf-effective-method-functions ((standard-generic-function)
+                                                                    (standard-generic-function)))
+                                    ((setf gf-effective-method-functions)
+                                     ((t standard-generic-function)
+                                      (t standard-generic-function)))
+                                                             ; (gf-permutation                      
+                                                             ; ((standard-generic-function)
+                                                             ; (standard-generic-function))) 
+                                    (slot-value-using-class ((standard-class t 
+                                                                   standard-effective-slot-definition
+                                                                    )
+                                                             ; the first t is a bug
+                                                             (std-class standard-object 
+                                                                   standard-effective-slot-definition
+                                                                    ))
+                                           ((funcallable-standard-class t 
+                                                   standard-effective-slot-definition)
+                                            (std-class standard-object 
+                                                   standard-effective-slot-definition)))
+                                    ((setf slot-value-using-class)
+                                     ((t standard-class t standard-effective-slot-definition)
+                                      (t std-class standard-object standard-effective-slot-definition
+                                         ))
+                                     ((t funcallable-standard-class t 
+                                         standard-effective-slot-definition)
+                                      (t std-class standard-object standard-effective-slot-definition
+                                         )))))
+
+(defvar *magic-generic-functions-1* nil)
+
+(defun
+ fixup-magic-generic-function
+ (gfspec early-methods gf methods)
+ (flet
+  ((get-specls (names convert-t-p)
+          (mapcar #'(lambda (s)
+                           (cond ((consp s)
+                                  `(eql ,(eval (cadr s))))
+                                 ((eq s t)
+                                  (if convert-t-p
+                                      (find-class t)
+                                      t))
+                                 (t (find-class s))))
+                 names)))
+  (let
+   ((e (assoc gfspec *magic-generic-functions* :test #'equal)))
+   (when e
+       (push (list* gf (make-arg-info
+                        nil
+                        (apply #'mapcar #'(lambda (&rest args)
+                                                 (if (every #'(lambda (arg)
+                                                                     (eq arg 't))
+                                                            args)
+                                                     't
+                                                     'standard-instance))
+                               (mapcar #'second (cdr e)))
+                        nil nil nil)
+                    (gathering1 (collecting)
+                           (dolist (pair (cdr e))
+                               (iterate ((em (list-elements early-methods))
+                                         (m (list-elements methods)))
+                                      (when (equal (early-method-specializers em t)
+                                                   (get-specls (cadr pair)
+                                                          t))
+                                          (gather1 (list (get-specls (car pair)
+                                                                nil)
+                                                         (list m)
+                                                         (early-method-function em)))
+                                          (return t))))))
+             *magic-generic-functions-1*)))))
+
+(defun get-secondary-dispatch-function (generic-function args)
+       (declare (values compiled-secondary-dispatch-function methods arg-info))
+       (multiple-value-bind (fn methods arg-info)
+           (get-magic-secondary-dispatch-function generic-function args)
+         (if fn
+             (values fn methods arg-info)
+             (get-normal-secondary-dispatch-function generic-function args))))
+
+(defun get-magic-secondary-dispatch-function (generic-function args)
+       (let ((e (assq generic-function *magic-generic-functions-1*)))
+            (when e
+                (dolist (entry (cddr e))
+                    (destructuring-bind (specls appl function)
+                           entry
+                           (unless (iterate ((arg (list-elements args))
+                                             (specl (list-elements specls)))
+                                          (let ((class (class-of arg)))
+                                               (unless (if (consp specl)
+                                                           (eql (cadr specl)
+                                                                arg)
+                                                           (or (eq specl t)
+                                                               (eq specl class)))
+                                                      (return t))))
+                               (return (values function appl (cadr e)))))))))
+
+(defmacro protect-cache-miss-code (gf args &body body)
+       (let ((wrappers (gensym))
+             (invalidp (gensym))
+             #'(gensym)
+             (appl (gensym)))
+            (once-only (gf args)
+                   `(if (memq ,gf *invalid-dfuns-on-stack*)
+                        (multiple-value-bind (,wrappers ,invalidp ,function ,appl)
+                            (cache-miss-values ,gf ,args)
+                          (declare (ignore ,wrappers ,invalidp))
+                          (if (null ,appl)
+                              (apply #'no-applicable-method ,gf ,args)
+                              (apply ,function ,args)))
+                        (let ((*invalid-dfuns-on-stack* (cons ,gf *invalid-dfuns-on-stack*)))
+                             ,@body)))))
+
+(defmethod same-specializer-p (specl1 specl2)
+       (eq specl1 specl2))
+
+(defmethod specializer-applicable-p ((specializer class)
+                                     object)
+       (memq specializer (class-precedence-list (class-of object))))
+
+(defmethod specializer-applicable-using-class-p ((specializer class)
+                                                 class)
+       (*subtypep class specializer))
+
+(defmethod order-specializers-using-class ((specl1 class)
+                                           (specl2 class)
+                                           class)
+       (cond ((eq specl1 specl2)
+              nil)
+             ((memq specl2 (memq specl1 (class-precedence-list class)))
+              specl1)
+             (t specl2)))
+
+(defmethod compute-applicable-methods ((generic-function generic-function)
+                                       arguments)
+       (labels ((filter (method)
+                       (let ((arguments-tail arguments))
+                            (dolist (m-spec (method-specializers method)
+                                           t)
+                                (unless arguments-tail
+                                    (error "The function ~S requires at least ~D arguments"
+                                           (generic-function-name generic-function)
+                                           (arg-info-number-required (gf-arg-info generic-function))))
+                                (unless (specializer-applicable-p m-spec (pop arguments-tail))
+                                       (return nil)))))
+                (sorter (method-1 method-2)
+                       (dolist (index (arg-info-precedence (gf-arg-info generic-function)))
+                           (let* ((specl1 (nth index (method-specializers method-1)))
+                                  (specl2 (nth index (method-specializers method-2)))
+                                  (class (class-of (nth index arguments)))
+                                  (order (order-specializers-using-class specl1 specl2 class)))
+                                 (when order
+                                     (return-from sorter (eq order specl1)))))))
+              (let ((methods (generic-function-methods generic-function)))
+                   (stable-sort (copy-list (remove-if-not #'filter methods))
+                          #'sorter))))
+
+(defmethod compute-applicable-methods-using-classes ((generic-function generic-function)
+                                                     classes)
+       (labels ((filter (method)
+                       (let ((classes-tail classes))
+                            (dolist (m-spec (method-specializers method)
+                                           t)
+                                (unless classes-tail
+                                    (error "The function ~S requires at least ~D arguments"
+                                           (generic-function-name generic-function)
+                                           (arg-info-number-required (gf-arg-info generic-function))))
+                                (unless (specializer-applicable-using-class-p m-spec (pop 
+                                                                                         classes-tail
+                                                                                          ))
+                                       (return nil)))))
+                (sorter (method-1 method-2)
+                       (dolist (index (arg-info-precedence (gf-arg-info generic-function)))
+                           (let* ((specl1 (nth index (method-specializers method-1)))
+                                  (specl2 (nth index (method-specializers method-2)))
+                                  (class (nth index classes))
+                                  (order (order-specializers-using-class specl1 specl2 class)))
+                                 (when order
+                                     (return-from sorter (eq order specl1)))))))
+              (let ((methods (generic-function-methods generic-function)))
+                   (stable-sort (copy-list (remove-if-not #'filter methods))
+                          #'sorter))))
+
+(defun get-normal-secondary-dispatch-function (generic-function args)
+       (let* ((classes (mapcar #'(lambda (arg mt)
+                                        (declare (ignore mt))
+                                        (class-of arg))
+                              args
+                              (arg-info-metatypes (gf-arg-info generic-function))))
+              (methods (compute-applicable-methods-using-classes generic-function classes))
+              (net (generate-discrimination-net generic-function methods))
+              (arg-info (gf-arg-info generic-function))
+              (metatypes (arg-info-metatypes arg-info))
+              (applyp (arg-info-applyp arg-info)))
+             (flet ((net-test-converter (form)
+                           (if (and (consp form)
+                                    (eq (car form)
+                                        'methods))
+                               '.methods.
+                               (default-test-converter form)))
+                    (net-code-converter (form)
+                           (if (and (consp form)
+                                    (eq (car form)
+                                        'methods))
+                               (let ((gensym (gensym)))
+                                    (values (make-dfun-call metatypes applyp gensym)
+                                           (list gensym)))
+                               (default-code-converter form)))
+                    (net-constant-converter (form)
+                           (if (and (consp form)
+                                    (eq (car form)
+                                        'methods))
+                               (list (get-effective-method-function generic-function (cdr form)))
+                               (default-constant-converter form))))
+                   (if (eq (car net)
+                           'methods)
+                       (and (cdr net)
+                            (values (get-effective-method-function generic-function (cdr net))
+                                   methods))
+                       (values (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp)
+                                                     ,net)
+                                      #'net-test-converter
+                                      #'net-code-converter
+                                      #'net-constant-converter)
+                              methods)))))
+
+(defun get-effective-method-function (generic-function methods)
+       (let ((combin (generic-function-method-combination generic-function))
+             (precomputed (gf-effective-method-functions generic-function)))
+            
+            ;; NOTE: We are assuming a restriction on user code that the method combination must not
+            ;; change once it is connected to the generic function. This has to be legal, because
+            ;; otherwise any kind of method lookup caching couldn't work.  See this by saying that
+            ;; this cache, is just a backing cache for the fast cache.  If that cache is legal, this
+            ;; one must be too. Should altering the set of methods flush this cache? 
+            (let ((entry (assoc methods precomputed :test #'equal)))
+                 (if entry
+                     (values (cdr entry)
+                            (car entry))
+                     (let* ((effective (compute-effective-method generic-function combin methods))
+                            (fn (make-effective-method-function generic-function effective)))
+                           (setf (gf-effective-method-functions generic-function)
+                                 (cons (cons methods fn)
+                                       precomputed))
+                           (values fn methods))))))
+
+(defun
+ generate-discrimination-net
+ (generic-function methods)
+ (let* ((arg-info (gf-arg-info generic-function))
+        (nreq (arg-info-number-required arg-info))
+        (metatypes (arg-info-metatypes arg-info)))
+       (labels ((do-column (position contenders)
+                       (if (< position nreq)
+                           (if (eq (nth position metatypes)
+                                   't)
+                               (do-column (1+ position)
+                                      contenders)
+                               (do-methods position contenders nil nil))
+                           `(methods ,@contenders)))
+                (do-methods
+                 (position contenders known-outcomes winners)
+                 
+                 ;; <contenders> is a (sorted) list of methods that must be discriminated
+                 ;; <known-outcomes> is a list of outcomes from tests already made on this argument
+                 ;; each outcome looks like (<specializer> [t | nil]) <winners> is a (sorted) list
+                 ;; of methods that are potentially applicable after the discrimination has been
+                 ;; made. 
+                 (if (null contenders)
+                     (do-column (1+ position)
+                            winners)
+                     (let* ((method (car contenders))
+                            (specl (nth position (method-specializers method))))
+                           (flet ((determined-to-be (truth-value)
+                                         (if (classp specl)
+                                             truth-value
+                                             (some #'(lambda (outcome)
+                                                            (outcome-implies-p generic-function
+                                                                   (car outcome)
+                                                                   (cadr outcome)
+                                                                   specl truth-value))
+                                                   known-outcomes)))
+                                  (if-true nil (do-methods position (cdr contenders)
+                                                      (if (not (classp specl))
+                                                          (cons `(,specl t)
+                                                                known-outcomes)
+                                                          known-outcomes)
+                                                      (append winners `(,method))))
+                                  (if-false nil (do-methods position (cdr contenders)
+                                                       (if (not (classp specl))
+                                                           (cons `(,specl nil)
+                                                                 known-outcomes)
+                                                           known-outcomes)
+                                                       winners)))
+                                 (cond ((determined-to-be nil)
+                                        (if-false))
+                                       ((determined-to-be t)
+                                        (if-true))
+                                       (t `(if ,(compute-argument-test-form generic-function
+                                                       (dfun-arg-symbol position)
+                                                       specl)
+                                               ,(if-true)
+                                               ,(if-false)))))))))
+              (do-column 0 methods))))
+
+(define-gf-predicate eql-specializer-p eql-specializer)
+
+(defmethod same-specializer-p ((specl1 eql-specializer)
+                               (specl2 eql-specializer))
+       (eql (eql-specializer-object specl1)
+            (eql-specializer-object specl2)))
+
+(defmethod specializer-applicable-p ((specializer eql-specializer)
+                                     object)
+       (eql (eql-specializer-object specializer)
+            object))
+
+(defmethod specializer-applicable-using-class-p ((specializer eql-specializer)
+                                                 class)
+       (eq class (class-of (eql-specializer-object specializer))))
+
+                                                             ; It would be most egregious to use
+                                                             ; *subtypep here. 
+
+
+(defmethod order-specializers-using-class ((specl1 eql-specializer)
+                                           (specl2 eql-specializer)
+                                           argument-class)
+       (declare (ignore argument-class))
+       nil)
+
+(defmethod order-specializers-using-class ((specl1 class)
+                                           (specl2 eql-specializer)
+                                           argument-class)
+       (declare (ignore argument-class))
+       specl2)
+
+(defmethod order-specializers-using-class ((specl1 eql-specializer)
+                                           (specl2 class)
+                                           argument-class)
+       (declare (ignore argument-class))
+       specl1)
+
+
+;;; Does a given pair of values for {<specializer1> <truth1>} imply a given pair of values for
+;;; {<specializer2> <truth2>}. 
+
+
+(defmethod outcome-implies-p ((generic-function generic-function)
+                              (specl1 eql-specializer)
+                              value1
+                              (specl2 eql-specializer)
+                              value2)
+       (flet ((same-truth-value (x y)
+                     (or (and x y)
+                         (and (not x)
+                              (not y)))))
+             (let ((obj1 (eql-specializer-object specl1))
+                   (obj2 (eql-specializer-object specl2)))
+                  (or (and (eql obj1 obj2)
+                           (same-truth-value value1 value2))
+                      (and (not (eql obj1 obj2))
+                           value1
+                           (not value2))))))
+
+
+;;; Return a form which tests a given argument against a given specializer. 
+
+
+(defmethod compute-argument-test-form ((generic-function generic-function)
+                                       argument-form
+                                       (specializer eql-specializer))
+       `(eql ,argument-form ',(eql-specializer-object specializer)))
+
+
+;;; The value returned by compute-discriminating-function is a function object.  It is called a
+;;; discriminating function because it is called when the generic function is called and its role is
+;;; to discriminate on the arguments to the generic function and then call appropriate method
+;;; functions. A discriminating function can only be called when it is installed as the funcallable
+;;; instance function of the generic function for which it was computed. More precisely, if
+;;; compute-discriminating-function is called with an argument <gf1>, and returns a result <df1>,
+;;; that result must not be passed to apply or funcall directly.  Rather, <df1> must be stored as
+;;; the funcallable instance function of the same generic function <gf1> (using
+;;; set-funcallable-instance-function).  Then the generic function can be passed to funcall or
+;;; apply. An important exception is that methods on this generic function are permitted to return a
+;;; function which itself ends up calling the value returned by a more specific method.  This kind
+;;; of `encapsulation' of discriminating function is critical to many uses of the MOP. As an
+;;; example, the following canonical case is legal: (defmethod compute-discriminating-function ((gf
+;;; my-generic-function)) (let ((std (call-next-method))) #'(lambda (arg) (print (list 'call-to-gf
+;;; gf arg)) (funcall std arg)))) Because many discriminating functions would like to use a dynamic
+;;; strategy in which the precise discriminating function changes with time it is important to
+;;; specify how a discriminating function is permitted itself to change the funcallable instance
+;;; function of the generic function. Discriminating functions are may set the funcallable instance
+;;; function of the generic function, but the new value must be generated by making a call to
+;;; COMPUTE-DISCRIMINATING-FUNCTION.  This is to ensure that any more specific methods which may
+;;; have encapsulated the discriminating function will get a chance to encapsulate the new, inner
+;;; discriminating function. This implies that if a discriminating function wants to modify itself
+;;; it should first store some information in the generic function proper, and then call
+;;; compute-discriminating-function.  The appropriate method on compute-discriminating-function will
+;;; see the information stored in the generic function and generate a discriminating function
+;;; accordingly. The following is an example of a discriminating function which modifies itself in
+;;; accordance with this protocol: (defmethod compute-discriminating-function ((gf
+;;; my-generic-function)) #'(lambda (arg) (cond (<some condition> <store some info in the generic
+;;; function> (set-funcallable-instance-function gf (compute-discriminating-function gf)) (funcall
+;;; gf arg)) (t <call-a-method-of-gf>)))) Whereas this code would not be legal: (defmethod
+;;; compute-discriminating-function ((gf my-generic-function)) #'(lambda (arg) (cond (<some
+;;; condition> (set-funcallable-instance-function gf #'(lambda (a) ..)) (funcall gf arg)) (t
+;;; <call-a-method-of-gf>)))) NOTE:  All the examples above assume that all instances of the class
+;;; my generic function accept only one argument. 
+
+
+(defmethod compute-discriminating-function ((gf standard-generic-function))
+       (let* ((state (gf-dfun-state gf))
+              (dfun (typecase state
+                        (null (make-initial-dfun gf))
+                        (function state)
+                        (cons (car state)))))
+             (doctor-dfun-for-the-debugger gf dfun)))
+
+(defun update-dfun (generic-function dfun &optional cache)
+       (let ((ostate (gf-dfun-state generic-function)))
+            (unless (typep ostate '(or null function))
+                (free-cache (cdr ostate)))
+            (setf (gf-dfun-state generic-function)
+                  (if cache
+                      (cons dfun cache)
+                      dfun))
+            (invalidate-dfun-internal generic-function)))
+
+(defvar *generate-random-code-segments* nil)
+
+(defun invalidate-discriminating-function (generic-function)
+       (let ((ostate (gf-dfun-state generic-function)))
+            (unless (typep ostate '(or null function))
+                (free-cache (cdr ostate)))
+            (setf (gf-dfun-state generic-function)
+                  nil)
+            (setf (gf-effective-method-functions generic-function)
+                  nil)
+            (invalidate-dfun-internal generic-function)
+            (when *generate-random-code-segments*
+                (let ((*generate-random-code-segments* nil))
+                     (generate-random-code-segments generic-function)))))
+
+(defun invalidate-dfun-internal (generic-function)
+       
+       ;; Set the funcallable instance function to something that just calls invalid-dfun, that is,
+       ;; arrange to use lazy evaluation to update the dfun later. 
+       (set-funcallable-instance-function generic-function #'(lambda (&rest args)
+                                                                    (invalid-dfun generic-function 
+                                                                           args)))
+       
+       ;; Except that during bootstrapping, we would like to update the dfun right away, and this
+       ;; arranges for that. 
+       (when *invalidate-discriminating-function-force-p*
+           (let ((*invalid-dfuns-on-stack* (cons generic-function *invalid-dfuns-on-stack*)))
+                (set-funcallable-instance-function generic-function (compute-discriminating-function
+                                                                     generic-function)))))
+
+(defun invalid-dfun (gf args)
+       (protect-cache-miss-code gf args (let ((new-dfun (compute-discriminating-function gf)))
+                                             (set-funcallable-instance-function gf new-dfun)
+                                             (apply gf args))))
+
+
+;;; 
+
+
+(defmethod function-keywords ((method standard-method))
+       (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
+           (analyze-lambda-list (method-lambda-list method))
+         (declare (ignore nreq nopt keysp restp))
+         (values keywords allow-other-keys-p)))
+
+(defun analyze-lambda-list (lambda-list)
+       (declare (values nrequired noptional keysp restp allow-other-keys-p keywords 
+                       keyword-parameters))
+       (flet ((parse-keyword-argument (arg)
+                     (if (listp arg)
+                         (if (listp (car arg))
+                             (cadar arg)
+                             (make-keyword (car arg)))
+                         (make-keyword arg))))
+             (let ((nrequired 0)
+                   (noptional 0)
+                   (keysp nil)
+                   (restp nil)
+                   (allow-other-keys-p nil)
+                   (keywords nil)
+                   (keyword-parameters nil)
+                   (state 'required))
+                  (dolist (x lambda-list)
+                      (if (memq x lambda-list-keywords)
+                          (case x
+                              (&optional (setq state 'optional))
+                              (&key (setq keysp 't state 'key))
+                              (&allow-other-keys (setq allow-other-keys-p 't))
+                              (&rest (setq restp 't state 'rest))
+                              (&aux (return t))
+                              (otherwise (error 
+                                               "Encountered the non-standard lambda list keyword ~S."
+                                                x)))
+                          (ecase state
+                              (required (incf nrequired))
+                              (optional (incf noptional))
+                              (key 
+                                 (push (parse-keyword-argument x)
+                                       keywords)
+                                 (push x keyword-parameters))
+                              (rest nil))))
+                  (values nrequired noptional keysp restp allow-other-keys-p (reverse keywords)
+                         (reverse keyword-parameters)))))
+
+(defun method-ll->generic-function-ll (ll)
+       (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters)
+           (analyze-lambda-list ll)
+         (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords))
+         (remove-if #'(lambda (s)
+                             (or (memq s keyword-parameters)
+                                 (eq s '&allow-other-keys)))
+                ll)))
+
+
+;;; This is based on the rules of method lambda list congruency defined in the spec.  The lambda
+;;; list it constructs is the pretty union of the lambda lists of all the methods.  It doesn't take
+;;; method applicability into account at all yet. 
+
+
+(defmethod generic-function-pretty-arglist ((generic-function standard-generic-function))
+       (let ((methods (generic-function-methods generic-function))
+             (arglist nil))
+            (when methods
+                (multiple-value-bind (required optional rest key allow-other-keys)
+                    (method-pretty-arglist (car methods))
+                  (dolist (m (cdr methods))
+                      (multiple-value-bind (method-key-keywords method-allow-other-keys method-key)
+                          (function-keywords m)
+                        
+                        ;; we've modified function-keywords to return what we want as the third
+                        ;; value, no other change here. 
+                        (declare (ignore method-key-keywords))
+                        (setq key (union key method-key))
+                        (setq allow-other-keys (or allow-other-keys method-allow-other-keys))))
+                  (when allow-other-keys
+                      (setq arglist '(&allow-other-keys)))
+                  (when key
+                      (setq arglist (nconc (list '&key)
+                                           key arglist)))
+                  (when rest
+                      (setq arglist (nconc (list '&rest rest)
+                                           arglist)))
+                  (when optional
+                      (setq arglist (nconc (list '&optional)
+                                           optional arglist)))
+                  (nconc required arglist)))))
+
+(defmethod method-pretty-arglist ((method standard-method))
+       (let ((required nil)
+             (optional nil)
+             (rest nil)
+             (key nil)
+             (allow-other-keys nil)
+             (state 'required)
+             (arglist (method-lambda-list method)))
+            (dolist (arg arglist)
+                (cond ((eq arg '&optional)
+                       (setq state 'optional))
+                      ((eq arg '&rest)
+                       (setq state 'rest))
+                      ((eq arg '&key)
+                       (setq state 'key))
+                      ((eq arg '&allow-other-keys)
+                       (setq allow-other-keys 't))
+                      ((memq arg lambda-list-keywords))
+                      (t (ecase state
+                             (required (push arg required))
+                             (optional (push arg optional))
+                             (key (push arg key))
+                             (rest (setq rest arg))))))
+            (values (nreverse required)
+                   (nreverse optional)
+                   rest
+                   (nreverse key)
+                   allow-other-keys)))
diff --git a/clos/2.0/patch.lisp b/clos/2.0/patch.lisp
new file mode 100644
index 00000000..eab79094
--- /dev/null
+++ b/clos/2.0/patch.lisp
@@ -0,0 +1,143 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (CLIN-PACKAGE "XCL-USER") BASE 10)
+(IL:FILECREATED "19-Feb-91 14:09:19" 
+IL:|{DSK}<usr>local>users>welch>lisp>clos>rev4>il-format>XEROX-PATCHES.;2| 9876   
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:XEROX-PATCHESCOMS)
+
+      IL:|previous| IL:|date:| " 6-Feb-91 10:55:16" 
+IL:|{DSK}<usr>local>users>welch>lisp>clos>rev4>il-format>XEROX-PATCHES.;1|)
+
+
+; Copyright (c) 1991 by Venue.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:XEROX-PATCHESCOMS)
+
+(IL:RPAQQ IL:XEROX-PATCHESCOMS (
+
+
+                                    (IL:FUNCTIONS OPTIMIZE-LOGICAL-OP-1-ARG)
+                                    (OPTIMIZERS (LOGIOR :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)
+                                           (LOGXOR :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)
+                                           (LOGAND :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)
+                                           (LOGEQV :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG))
+                                    
+                                    (IL:* IL:|;;| "A bug compiling LABELS")
+
+                                    (IL:FUNCTIONS COMPILER::META-CALL-LABELS)
+                                    (FILE-ENVIRONMENTS "XEROX-PATCHES")))
+
+
+
+
+
+
+(IL:* IL:|;;;| 
+"Declare side-effects (actually, lack of side-effects) info for some internal arithmetic functions.  These are needed because the compiler runs the optimizers before checking the side-effects, so side-effect declarations on the \"real\" functions are oft times ignored. Fix a nit in the compiler While no person would generate code like (logor x), macro can (and do). "
+)
+
+
+(DEFUN OPTIMIZE-LOGICAL-OP-1-ARG (FORM ENV CTXT)
+   (DECLARE (IGNORE ENV CTXT))
+   (IF (= 2 (LENGTH FORM))
+       (SECOND FORM)
+       'COMPILER:PASS))
+
+(DEFOPTIMIZER LOGIOR OPTIMIZE-LOGICAL-OP-1-ARG)
+
+(DEFOPTIMIZER LOGXOR OPTIMIZE-LOGICAL-OP-1-ARG)
+
+(DEFOPTIMIZER LOGAND OPTIMIZE-LOGICAL-OP-1-ARG)
+
+(DEFOPTIMIZER LOGEQV OPTIMIZE-LOGICAL-OP-1-ARG)
+
+
+
+(IL:* IL:|;;| "A bug compiling LABELS")
+
+
+(DEFUN COMPILER::META-CALL-LABELS (COMPILER::NODE COMPILER:CONTEXT)
+
+   (IL:* IL:|;;| "This is similar to META-CALL-LAMBDA, but we have some extra information. There are only required arguments, and we have the correct number of them. ")
+
+   (LET ((COMPILER::*MADE-CHANGES* NIL))
+
+        (IL:* IL:|;;| "First, substitute the functions wherever possible.")
+
+        (DOLIST (COMPILER::FN-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE)
+                       (WHEN (NULL (COMPILER::NODE-META-P (COMPILER::LABELS-BODY COMPILER::NODE)))
+                           (SETF (COMPILER::NODE-META-P COMPILER::NODE)
+                                 NIL)
+                           (SETQ COMPILER::*MADE-CHANGES* T)))
+            (WHEN (COMPILER::SUBSTITUTABLE-P (CDR COMPILER::FN-PAIR)
+                         (CAR COMPILER::FN-PAIR))
+                (LET ((COMPILER::*SUBST-OCCURRED* NIL))
+
+                     (IL:* IL:|;;| "First try substituting into the body.")
+
+                     (SETF (COMPILER::LABELS-BODY COMPILER::NODE)
+                           (COMPILER::META-SUBSTITUTE (CDR COMPILER::FN-PAIR)
+                                  (CAR COMPILER::FN-PAIR)
+                                  (COMPILER::LABELS-BODY COMPILER::NODE)))
+                     (WHEN (NOT COMPILER::*SUBST-OCCURRED*)
+
+                         (IL:* IL:|;;| "Wasn't in the body - try the other functions.")
+
+                         (DOLIST (COMPILER::TARGET-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE))
+                             (UNLESS (EQ COMPILER::TARGET-PAIR COMPILER::FN-PAIR)
+                                 (SETF (CDR COMPILER::TARGET-PAIR)
+                                       (COMPILER::META-SUBSTITUTE (CDR COMPILER::FN-PAIR)
+                                              (CAR COMPILER::FN-PAIR)
+                                              (CDR COMPILER::TARGET-PAIR)))
+                                 (WHEN COMPILER::*SUBST-OCCURRED*
+                                                             (IL:* IL:\; 
+                                                           "Found it, we can stop now.")
+                                     (SETF (COMPILER::NODE-META-P COMPILER::NODE)
+                                           NIL)
+                                     (SETQ COMPILER::*MADE-CHANGES* T)
+                                     (RETURN)))))
+
+                     (IL:* IL:|;;| "May need to reanalyze the node, since things might have changed. Note that reanalyzing the parts of the node this way means the the state in the enclosing loop is not lost. ")
+
+                     (DOLIST (COMPILER::FNS (COMPILER::LABELS-FUNS COMPILER::NODE))
+                         (COMPILER::MEVAL (CDR COMPILER::FNS)
+                                :ARGUMENT))
+                     (COMPILER::MEVAL (COMPILER::LABELS-BODY COMPILER::NODE)
+                            :RETURN))))
+
+        (IL:* IL:|;;| "Now remove any functions that aren't referenced.")
+
+        (DOLIST (COMPILER::FN-PAIR (PROG1 (COMPILER::LABELS-FUNS COMPILER::NODE)
+                                       (SETF (COMPILER::LABELS-FUNS COMPILER::NODE)
+                                             NIL)))
+            (COND
+               ((NULL (COMPILER::VARIABLE-READ-REFS (CAR COMPILER::FN-PAIR)))
+                (COMPILER::RELEASE-TREE (CDR COMPILER::FN-PAIR))
+                (SETQ COMPILER::*MADE-CHANGES* T))
+               (T (PUSH COMPILER::FN-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE)))))
+
+        (IL:* IL:|;;| "If there aren't any functions left, replace the node with its body.")
+
+        (WHEN (NULL (COMPILER::LABELS-FUNS COMPILER::NODE))
+            (LET ((COMPILER::BODY (COMPILER::LABELS-BODY COMPILER::NODE)))
+                 (SETF (COMPILER::LABELS-BODY COMPILER::NODE)
+                       NIL)
+                 (COMPILER::RELEASE-TREE COMPILER::NODE)
+                 (SETQ COMPILER::NODE COMPILER::BODY COMPILER::*MADE-CHANGES* T)))
+
+        (IL:* IL:|;;| "Finally, set the meta-p flag if everythings OK.")
+
+        (IF (NULL COMPILER::*MADE-CHANGES*)
+            (SETF (COMPILER::NODE-META-P COMPILER::NODE)
+                  COMPILER:CONTEXT)
+            (SETF (COMPILER::NODE-META-P COMPILER::NODE)
+                  NIL)))
+   COMPILER::NODE)
+
+(DEFINE-FILE-ENVIRONMENT "XEROX-PATCHES" :PACKAGE (IN-PACKAGE "XCL-USER")
+   :READTABLE "XCL"
+   :BASE 10
+   :COMPILER :COMPILE-FILE)
+(IL:PUTPROPS IL:XEROX-PATCHES IL:COPYRIGHT ("Venue" 1991))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/clos/2.0/pkg.lisp b/clos/2.0/pkg.lisp
new file mode 100644
index 00000000..7491df0d
--- /dev/null
+++ b/clos/2.0/pkg.lisp
@@ -0,0 +1,81 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 26-Mar-91 10:23:29 from source pkg
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>pkg.;4 created  1-Mar-91 10:10:26
+
+;;;. Copyright (c) 1991 by Venue
+
+
+(in-package "CLOS")
+
+
+
+;;; Some CommonLisps have more symbols in the Lisp package than the ones that are explicitly
+;;; specified in CLtL.  This causes trouble. Any Lisp that has extra symbols in the Lisp package
+;;; should shadow those symbols in the CLOS package. 
+
+
+(shadow 'cl:documentation)
+
+
+;;; These come from the index pages of 88-002R. 
+
+(eval-when (compile load eval)
+(defvar *exports*
+       '(add-method built-in-class call-method call-next-method change-class class-name class-of 
+               compute-applicable-methods defclass defgeneric define-method-combination defmethod 
+               ensure-generic-function find-class find-method function-keywords generic-flet 
+               generic-labels initialize-instance invalid-method-error make-instance 
+               make-instances-obsolete method-combination-error method-qualifiers next-method-p 
+               no-applicable-method no-next-method print-object reinitialize-instance remove-method 
+               shared-initialize slot-boundp slot-exists-p slot-makunbound slot-missing slot-unbound
+               slot-value standard standard-class standard-generic-function standard-method 
+               standard-object structure-class symbol-macrolet update-instance-for-different-class 
+               update-instance-for-redefined-class with-accessors with-added-methods with-slots))
+
+(import '(xcl:false xcl:destructuring-bind xcl:true) *the-clos-package*)
+
+(export *exports* *the-clos-package*)
+
+(import *exports* (find-package :lisp))
+
+(export *exports* (find-package :lisp)))
+
+                                                             ; (defvar *chapter-3-exports* '(
+                                                             ; get-setf-function
+                                                             ; get-setf-function-name
+                                                             ; class-prototype class object 
+
+
+
+;; essential-class
+
+
+                                                             ; class-name class-precedence-list
+                                                             ; class-local-supers class-local-slots
+                                                             ; class-direct-subclasses
+                                                             ; class-direct-methods class-slots
+                                                             ; method-arglist
+                                                             ; method-argument-specifiers
+                                                             ; method-function method-equal
+                                                             ; slotd-name slot-missing 
+
+
+
+;; define-meta-class %allocate-instance %instance-ref %instancep %instance-meta-class 
+
+
+                                                             ; allocate-instance optimize-slot-value
+                                                             ; optimize-setf-of-slot-value
+                                                             ; add-named-class
+                                                             ; class-for-redefinition add-class
+                                                             ; supers-changed slots-changed
+                                                             ; check-super-metaclass-compatibility
+                                                             ; make-slotd
+                                                             ; compute-class-precedence-list
+                                                             ; walk-method-body
+                                                             ; walk-method-body-form
+                                                             ; add-named-method remove-named-method
+                                                             ; )) 
+
diff --git a/clos/2.0/plap.lisp b/clos/2.0/plap.lisp
new file mode 100644
index 00000000..49d8b833
--- /dev/null
+++ b/clos/2.0/plap.lisp
@@ -0,0 +1,309 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+
+;;; The portable implementation of the LAP assembler. The portable implementation of the LAP
+;;; assembler works by translating LAP code back into Lisp code and then compiling that Lisp code. 
+;;; Note that this implementation is actually going to get a lot of use.  Some implementations (KCL)
+;;; won't implement a native LAP assembler at all. Other implementations may not implement native
+;;; LAP assemblers for all of their ports.  All of this implies that this portable LAP assembler
+;;; needs to generate the best code it possibly can. 
+
+
+(defmacro
+ lap-case
+ (operand &body cases)
+ (once-only
+  (operand)
+  `(ecase (car ,operand)
+       ,@(mapcar #'(lambda (case)
+                          `(,(car case)
+                            (apply #'(lambda ,(cadr case)
+                                            ,@(cddr case))
+                                   (cdr ,operand))))
+                cases))))
+
+(defvar *lap-args*)
+
+(defvar *lap-rest-p*)
+
+(defvar *lap-i-regs*)
+
+(defvar *lap-v-regs*)
+
+(defvar *lap-t-regs*)
+
+(defvar *lap-optimize-declaration* '((speed 3)
+                                     (safety 0)
+                                     (compilation-speed 0)))
+
+(eval-when (load eval)
+       (setq *make-lap-closure-generator* #'(lambda (closure-var-names arg-names index-regs 
+                                                           vector-regs t-regs lap-code)
+                                                   (compile-lambda (make-lap-closure-generator-lambda
+                                                                    closure-var-names arg-names 
+                                                                    index-regs vector-regs t-regs 
+                                                                    lap-code)))
+             *precompile-lap-closure-generator*
+             #'(lambda (cvars args i-regs v-regs t-regs lap)
+                      `#',(make-lap-closure-generator-lambda cvars args i-regs v-regs t-regs lap))
+             *lap-in-lisp*
+             #'(lambda (cvars args iregs vregs tregs lap)
+                      (declare (ignore cvars args))
+                      (make-lap-prog iregs vregs tregs (flatten-lap lap 
+                                                             ; (opcode :label 'exit-lap-in-lisp)
+                                                              )))))
+
+(defun make-lap-closure-generator-lambda (cvars args i-regs v-regs t-regs lap)
+       (let* ((rest (memq '&rest args))
+              (ldiff (and rest (ldiff args rest))))
+             (when rest
+                 (setq args (append ldiff '(&rest .lap-rest-arg.))))
+             (let* ((*lap-args* (if rest
+                                    ldiff
+                                    args))
+                    (*lap-rest-p* (not (null rest))))
+                   `(lambda ,cvars #'(lambda ,args (declare (optimize . ,*lap-optimize-declaration*))
+                                            ,(make-lap-prog-internal i-regs v-regs t-regs lap))))))
+
+(defun make-lap-prog (i-regs v-regs t-regs lap)
+       (let* ((*lap-args* 'lap-in-lisp)
+              (*lap-rest-p* 'lap-in-lisp))
+             (make-lap-prog-internal i-regs v-regs t-regs lap)))
+
+(defun make-lap-prog-internal (i-regs v-regs t-regs lap)
+       (let* ((*lap-i-regs* i-regs)
+              (*lap-v-regs* v-regs)
+              (*lap-t-regs* t-regs)
+              (code (mapcar #'lap-opcode lap)))
+             `(prog ,(mapcar #'(lambda (reg)
+                                      `(,(lap-reg reg)
+                                        ,(lap-reg-initial-value-form reg)))
+                            (append i-regs v-regs t-regs))
+                    (declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*))
+                           (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*))
+                           (optimize . ,*lap-optimize-declaration*))
+                    ,.code)))
+
+(defconstant *empty-vector* '#())
+
+(defun lap-reg-initial-value-form (reg)
+       (cond ((member reg *lap-i-regs*)
+              0)
+             ((member reg *lap-v-regs*)
+              '*empty-vector*)
+             ((member reg *lap-t-regs*)
+              nil)
+             (t (error "What kind of register is ~S?" reg))))
+
+(defun lap-opcode (opcode)
+       (lap-case opcode (:move (from to)
+                               `(setf ,(lap-operand to)
+                                      ,(lap-operand from)))
+              ((:eq :neq :fix=)
+               (arg1 arg2 label)
+               `(when ,(lap-operands (ecase (car opcode)
+                                         (:eq 'eq)
+                                         (:neq 'neq)
+                                         (:fix= 'runtime\ fix=))
+                              arg1 arg2)
+                    (go ,label)))
+              ((:izerop)
+               (arg label)
+               `(when ,(lap-operands 'runtime\ izerop arg)
+                    (go ,label)))
+              (:std-instance-p (from label)
+                     `(when ,(lap-operands 'runtime\ std-instance-p from)
+                          (go ,label)))
+              (:fsc-instance-p (from label)
+                     `(when ,(lap-operands 'runtime\ fsc-instance-p from)
+                          (go ,label)))
+              (:built-in-instance-p (from label)
+                     (declare (ignore from))
+                     `(when ,t
+                          (go ,label)))
+                                                             ; ***
+              (:structure-instance-p (from label)
+                     `(when ,(lap-operands 'runtime\ ??? from)
+                          (go ,label)))
+                                                             ; ***
+              (:jmp (fn)
+                    (if (eq *lap-args* 'lap-in-lisp)
+                        (error "Can't do a :JMP in LAP-IN-LISP.")
+                        `(return ,(if *lap-rest-p*
+                                      `(runtime\ apply ,(lap-operand fn)
+                                              ,@*lap-args* .lap-rest-arg.)
+                                      `(runtime\ funcall ,(lap-operand fn)
+                                              ,@*lap-args*)))))
+              (:return (value)
+                     `(return ,(lap-operand value)))
+              (:label (label)
+                     label)
+              (:go (label)
+                   `(go ,label))
+              (:exit-lap-in-lisp nil `(go exit-lap-in-lisp))
+              (:break nil `(break))
+              (:beep nil)
+              (:print (val)
+                     (lap-operands 'print val))))
+
+(defun lap-operand (operand)
+       (lap-case operand (:reg (n)
+                               (lap-reg n))
+              (:cdr (reg)
+                    (lap-operands 'cdr reg))
+              ((:cvar :arg)
+               (name)
+               name)
+              (:constant (c)
+                     `',c)
+              ((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper :std-slots :fsc-slots)
+               (x)
+               (lap-operands (ecase (car operand)
+                                 (:std-wrapper 'runtime\ std-wrapper)
+                                 (:fsc-wrapper 'runtime\ fsc-wrapper)
+                                 (:built-in-wrapper 'runtime\ built-in-wrapper)
+                                 (:structure-wrapper 'runtime\ structure-wrapper)
+                                 (:std-slots 'runtime\ std-slots)
+                                 (:fsc-slots 'runtime\ fsc-slots))
+                      x))
+              (:i1+ (index)
+                    (lap-operands 'runtime\ i1+ index))
+              (:i+ (index1 index2)
+                   (lap-operands 'runtime\ i+ index1 index2))
+              (:i- (index1 index2)
+                   (lap-operands 'runtime\ i- index1 index2))
+              (:ilogand (index1 index2)
+                     (lap-operands 'runtime\ ilogand index1 index2))
+              (:ilogxor (index1 index2)
+                     (lap-operands 'runtime\ ilogxor index1 index2))
+              (:iref (vector index)
+                     (lap-operands 'runtime\ iref vector index))
+              (:iset (vector index value)
+                     (lap-operands 'runtime\ iset vector index value))
+              (:cref (vector i)
+                     `(runtime\ svref ,(lap-operand vector)
+                             ,i))
+              (:lisp-variable (symbol)
+                     symbol)
+              (:lisp (form)
+                     form)))
+
+(defun lap-operands (fn &rest regs)
+       (cons fn (mapcar #'lap-operand regs)))
+
+(defun lap-reg (n)
+       (intern (format nil "REG~D" n)
+              *the-clos-package*))
+
+
+;;; Runtime Implementations of the operands and opcodes. In those ports of CLOS which choose not to
+;;; completely re-implement the LAP code generator, it may still be provident to consider
+;;; reimplementing one or more of these to get the compiler to produce better code.  That is why
+;;; they are split out. 
+
+
+(proclaim '(declaration clos-fast-call))
+
+(defmacro runtime\ funcall (fn &rest args)
+       `(funcall ,fn ,.args))
+
+(defmacro runtime\ apply (fn &rest args)
+       `(apply ,fn ,.args))
+
+(defmacro runtime\ std-wrapper (x)
+       `(std-instance-wrapper ,x))
+
+(defmacro runtime\ fsc-wrapper (x)
+       `(fsc-instance-wrapper ,x))
+
+(defmacro runtime\ built-in-wrapper (x)
+       `(built-in-wrapper-of ,x))
+
+(defmacro runtime\ structure-wrapper (x)
+       `(??? ,x))
+
+(defmacro runtime\ std-slots (x)
+       `(std-instance-slots (the std-instance ,x)))
+
+(defmacro runtime\ fsc-slots (x)
+       `(fsc-instance-slots ,x))
+
+(defmacro runtime\ std-instance-p (x)
+       `(std-instance-p ,x))
+
+(defmacro runtime\ fsc-instance-p (x)
+       `(fsc-instance-p ,x))
+
+(defmacro runtime\ izerop (x)
+       `(zerop (the fixnum ,x)))
+
+(defmacro runtime\ fix= (x y)
+       `(= (the fixnum ,x)
+           (the fixnum ,y)))
+
+
+;;; These are the implementations of the index operands.  The portable assembler generates Lisp code
+;;; that uses these macros.  Even though the variables holding the arguments and results have type
+;;; declarations on them, we put type declarations in here. Some compilers are so stupid... 
+
+
+(defmacro runtime\ iref (vector index)
+       `(svref (the simple-vector ,vector)
+               (the fixnum ,index)))
+
+(defmacro runtime\ iset (vector index value)
+       `(setf (svref (the simple-vector ,vector)
+                     (the fixnum ,index))
+              ,value))
+
+(defmacro runtime\ svref (vector fixnum)
+       `(svref (the simple-vector ,vector)
+               (the fixnum ,fixnum)))
+
+(defmacro runtime\ i+ (index1 index2)
+       `(the fixnum (+ (the fixnum ,index1)
+                       (the fixnum ,index2))))
+
+(defmacro runtime\ i- (index1 index2)
+       `(the fixnum (- (the fixnum ,index1)
+                       (the fixnum ,index2))))
+
+(defmacro runtime\ i1+ (index)
+       `(the fixnum (1+ (the fixnum ,index))))
+
+(defmacro runtime\ ilogand (index1 index2)
+       `(the fixnum (logand (the fixnum ,index1)
+                           (the fixnum ,index2))))
+
+(defmacro runtime\ ilogxor (index1 index2)
+       `(the fixnum (logxor (the fixnum ,index1)
+                           (the fixnum ,index2))))
+
+
+;;; In the portable implementation, indexes are just fixnums. 
+
+
+(defconstant index-value-limit most-positive-fixnum)
+
+(defun index-value->index (index-value)
+       index-value)
+
+(defun index->index-value (index)
+       index)
+
+(defun make-index-mask (cache-size line-size)
+       (let ((cache-size-in-bits (floor (log cache-size 2)))
+             (line-size-in-bits (floor (log line-size 2)))
+             (mask 0))
+            (dotimes (i cache-size-in-bits)
+                (setq mask (dpb 1 (byte 1 i)
+                                mask)))
+            (dotimes (i line-size-in-bits)
+                (setq mask (dpb 0 (byte 1 i)
+                                mask)))
+            mask))
diff --git a/clos/2.0/precom-browser.cl b/clos/2.0/precom-browser.cl
new file mode 100644
index 00000000..cb7bad35
--- /dev/null
+++ b/clos/2.0/precom-browser.cl
@@ -0,0 +1,3 @@
+;;
+
+(CLOS::PRECOMPILE-RANDOM-CODE-SEGMENTS BROWSER)
diff --git a/clos/2.0/precom1.lisp b/clos/2.0/precom1.lisp
new file mode 100644
index 00000000..76d6e88b
--- /dev/null
+++ b/clos/2.0/precom1.lisp
@@ -0,0 +1,31 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+;;;
+;;; pre-allocate generic function caches.  The hope is that this will put
+;;; them nicely together in memory, and that that may be a win.  Of course
+;;; the first gc copy will probably blow that out, this really wants to be
+;;; wrapped in something that declares the area static.
+;;;
+;;; This preallocation only creates about 25% more caches than CLOS itself
+;;; uses need.  Some ports may want to preallocate some more of these.
+;;; 
+(eval-when (load)
+  (flet ((allocate (n size)
+	   (mapcar #'free-cache
+		   (mapcar #'get-cache
+			   (make-list n :initial-element size)))))
+    (allocate 128 4)
+    (allocate 64 8)
+    (allocate 64 9)
+    (allocate 32 16)
+    (allocate 16 17)
+    (allocate 16 32)
+    (allocate 1  64)))
\ No newline at end of file
diff --git a/clos/2.0/precom2.lisp b/clos/2.0/precom2.lisp
new file mode 100644
index 00000000..0c763a45
--- /dev/null
+++ b/clos/2.0/precom2.lisp
@@ -0,0 +1,12 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+(precompile-dfun-constructors clos)		;this is half of a call to
+						;precompile-random-code-segments
diff --git a/clos/2.0/precom4.lisp b/clos/2.0/precom4.lisp
new file mode 100644
index 00000000..06a17cf5
--- /dev/null
+++ b/clos/2.0/precom4.lisp
@@ -0,0 +1,12 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+(precompile-function-generators clos)		;this is half of a call to
+						;precompile-random-code-segments
diff --git a/clos/2.0/slots.lisp b/clos/2.0/slots.lisp
new file mode 100644
index 00000000..c21c00d6
--- /dev/null
+++ b/clos/2.0/slots.lisp
@@ -0,0 +1,261 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+;;; These four functions work on std-instances and fsc-instances.  These are instances for which it
+;;; is possible to change the wrapper and the slots. For these kinds of instances, most specified
+;;; methods from the instance structure protocol are promoted to the implementation-specific class
+;;; std-class.  Many of these methods call these four functions. 
+
+
+(defun get-wrapper (inst)
+       (cond ((std-instance-p inst)
+              (std-instance-wrapper inst))
+             ((fsc-instance-p inst)
+              (fsc-instance-wrapper inst))
+             (t (error "What kind of instance is this?"))))
+
+(defun get-slots (inst)
+       (cond ((std-instance-p inst)
+              (std-instance-slots inst))
+             ((fsc-instance-p inst)
+              (fsc-instance-slots inst))
+             (t (error "What kind of instance is this?"))))
+
+(defun set-wrapper (inst new)
+       (cond ((std-instance-p inst)
+              (setf (std-instance-wrapper inst)
+                    new))
+             ((fsc-instance-p inst)
+              (setf (fsc-instance-wrapper inst)
+                    new))
+             (t (error "What kind of instance is this?"))))
+
+(defun set-slots (inst new)
+       (cond ((std-instance-p inst)
+              (setf (std-instance-slots inst)
+                    new))
+             ((fsc-instance-p inst)
+              (setf (fsc-instance-slots inst)
+                    new))
+             (t (error "What kind of instance is this?"))))
+
+(defmacro get-slot-value-2 (instance wrapper slot-name slots index)
+       `(let ((val (%svref ,slots ,index)))
+             (if (eq val ',*slot-unbound*)
+                 (slot-unbound (wrapper-class ,wrapper)
+                        ,instance
+                        ,slot-name)
+                 val)))
+
+(defmacro set-slot-value-2 (nv instance wrapper slot-name slots index)
+       (declare (ignore instance wrapper slot-name))
+       `(setf (%svref ,slots ,index)
+              ,nv))
+
+(defun get-class-slot-value-1 (object wrapper slot-name)
+       (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
+            (if (null entry)
+                (slot-missing (wrapper-class wrapper)
+                       object slot-name 'slot-value)
+                (if (eq (cdr entry)
+                        *slot-unbound*)
+                    (slot-unbound (wrapper-class wrapper)
+                           object slot-name)
+                    (cdr entry)))))
+
+(defun set-class-slot-value-1 (new-value object wrapper slot-name)
+       (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
+            (if (null entry)
+                (slot-missing (wrapper-class wrapper)
+                       object slot-name 'setf new-value)
+                (setf (cdr entry)
+                      new-value))))
+
+(defmethod class-slot-value ((class std-class)
+                             slot-name)
+       (let ((wrapper (class-wrapper class))
+             (prototype (class-prototype class)))
+            (get-class-slot-value-1 prototype wrapper slot-name)))
+
+(defmethod (setf class-slot-value)
+       (nv (class std-class)
+           slot-name)
+       (let ((wrapper (class-wrapper class))
+             (prototype (class-prototype class)))
+            (set-class-slot-value-1 nv prototype wrapper slot-name)))
+
+(defmethod find-slot-definition ((class std-class)
+                                 slot-name)
+       (if (and (eq class *the-class-standard-class*)
+                (eq slot-name 'slots))
+           *the-eslotd-standard-class-slots*
+           (progn (unless (class-finalized-p class)
+                         (finalize-inheritance class))
+                  (dolist (eslotd (class-slots class))
+                      (when (eq (slotd-name eslotd)
+                                slot-name)
+                            (return eslotd))))))
+
+(defun slot-value (object slot-name)
+       (let ((class (class-of object)))
+            (if (eq class *the-class-standard-effective-slot-definition*)
+                (let* ((wrapper (check-wrapper-validity object))
+                       (slots (get-slots object))
+                       (index (instance-slot-index wrapper slot-name)))
+                      (if index
+                          (get-slot-value-2 object wrapper slot-name slots index)
+                          (get-class-slot-value-1 object wrapper slot-name)))
+                (let ((slot-definition (find-slot-definition class slot-name)))
+                     (if (null slot-definition)
+                         (slot-missing class object slot-name 'slot-value)
+                         (slot-value-using-class class object slot-definition))))))
+
+(defun set-slot-value (object slot-name new-value)
+       (let ((class (class-of object)))
+            (if (eq class *the-class-standard-effective-slot-definition*)
+                (let* ((wrapper (check-wrapper-validity object))
+                       (slots (get-slots object))
+                       (index (instance-slot-index wrapper slot-name)))
+                      (if index
+                          (set-slot-value-2 new-value object wrapper slot-name slots index)
+                          (set-class-slot-value-1 new-value object wrapper slot-name)))
+                (let ((slot-definition (find-slot-definition class slot-name)))
+                     (if (null slot-definition)
+                         (slot-missing class object slot-name 'setf)
+                         (setf (slot-value-using-class class object slot-definition)
+                               new-value))))))
+
+(defun slot-boundp (object slot-name)
+       (let* ((class (class-of object))
+              (slot-definition (find-slot-definition class slot-name)))
+             (if (null slot-definition)
+                 (slot-missing class object slot-name 'slot-boundp)
+                 (slot-boundp-using-class class object slot-definition))))
+
+(defun slot-makunbound (object slot-name)
+       (let* ((class (class-of object))
+              (slot-definition (find-slot-definition class slot-name)))
+             (if (null slot-definition)
+                 (slot-missing class object slot-name 'slot-makunbound)
+                 (slot-makunbound-using-class class object slot-definition))))
+
+(defun slot-exists-p (object slot-name)
+       (let* ((class (class-of object))
+              (slot-definition (find-slot-definition class slot-name)))
+             (and slot-definition (slot-exists-p-using-class class object slot-definition))))
+
+
+;;; This isn't documented, but is used within CLOS in a number of print object methods (see
+;;; named-object-print-function). 
+
+
+(defun slot-value-or-default (object slot-name &optional (default "unbound"))
+       (if (slot-boundp object slot-name)
+           (slot-value object slot-name)
+           default))
+
+
+;;; 
+
+
+(defmethod slot-value-using-class ((class std-class)
+                                   (object standard-object)
+                                   (slotd standard-effective-slot-definition))
+       (let* ((wrapper (check-wrapper-validity object))
+                                                             ; trap if need be
+              (slots (get-slots object))
+              (slot-name (slotd-name slotd))
+              (index (or (slotd-instance-index slotd)
+                         (setf (slotd-instance-index slotd)
+                               (instance-slot-index wrapper slot-name)))))
+             (if index
+                 (get-slot-value-2 object wrapper slot-name slots index)
+                 (get-class-slot-value-1 object wrapper slot-name))))
+
+(defmethod (setf slot-value-using-class)
+       (new-value (class std-class)
+              (object standard-object)
+              (slotd standard-effective-slot-definition))
+       (let* ((wrapper (check-wrapper-validity object))
+                                                             ; trap if need be
+              (slots (get-slots object))
+              (slot-name (slotd-name slotd))
+              (index (or (slotd-instance-index slotd)
+                         (setf (slotd-instance-index slotd)
+                               (instance-slot-index wrapper slot-name)))))
+             (if index
+                 (set-slot-value-2 new-value object wrapper slot-name slots index)
+                 (set-class-slot-value-1 new-value object wrapper slot-name))))
+
+(defmethod slot-boundp-using-class ((class std-class)
+                                    (object standard-object)
+                                    (slotd standard-effective-slot-definition))
+       (let* ((wrapper (check-wrapper-validity object))
+                                                             ; trap if need be
+              (slots (get-slots object))
+              (slot-name (slotd-name slotd))
+              (index (or (slotd-instance-index slotd)
+                         (setf (slotd-instance-index slotd)
+                               (instance-slot-index wrapper slot-name)))))
+             (if index
+                 (neq (svref slots index)
+                      *slot-unbound*)
+                 (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
+                      (if (null entry)
+                          (slot-missing class object slot-name 'slot-boundp)
+                          (neq (cdr entry)
+                               *slot-unbound*))))))
+
+(defmethod slot-makunbound-using-class ((class std-class)
+                                        (object standard-object)
+                                        (slotd standard-effective-slot-definition))
+       (let* ((wrapper (check-wrapper-validity object))
+                                                             ; trap if need be
+              (slots (get-slots object))
+              (slot-name (slotd-name slotd))
+              (index (or (slotd-instance-index slotd)
+                         (setf (slotd-instance-index slotd)
+                               (instance-slot-index wrapper slot-name)))))
+             (cond (index (setf (%svref slots index)
+                                *slot-unbound*)
+                          object)
+                   (t (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
+                           (if* (null entry)
+                                (slot-missing class object slot-name 'slot-makunbound)
+                                (setf (cdr entry)
+                                      *slot-unbound*)
+                                object))))))
+
+(defmethod slot-exists-p-using-class ((class std-class)
+                                      (object standard-object)
+                                      (slotd standard-effective-slot-definition))
+       t)
+
+(defmethod slot-missing ((class t)
+                         instance slot-name operation &optional new-value)
+       (error "When attempting to ~A,~%the slot ~S is missing from the object ~S."
+              (ecase operation
+                  (slot-value "read the slot's value (slot-value)")
+                  (setf (format nil "set the slot's value to ~S (setf of slot-value)" new-value))
+                  (slot-boundp "test to see if slot is bound (slot-boundp)")
+                  (slot-makunbound "make the slot unbound (slot-makunbound)"))
+              slot-name instance))
+
+(defmethod slot-unbound ((class t)
+                         instance slot-name)
+       (error "The slot ~S is unbound in the object ~S." slot-name instance))
+
+(defmethod allocate-instance ((class standard-class)
+                              &rest initargs)
+       (declare (ignore initargs))
+       (unless (class-finalized-p class)
+              (finalize-inheritance class))
+       (let* ((class-wrapper (class-wrapper class))
+              (instance (%allocate-instance--class (class-no-of-instance-slots class))))
+             (setf (std-instance-wrapper instance)
+                   class-wrapper)
+             instance))
diff --git a/clos/2.0/std-class.lisp b/clos/2.0/std-class.lisp
new file mode 100644
index 00000000..a07b366c
--- /dev/null
+++ b/clos/2.0/std-class.lisp
@@ -0,0 +1,997 @@
+
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 10-Apr-91 22:24:19 from source std-class
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>std-class.;4 created 20-Feb-91 13:07:14
+
+;;;. Copyright (c) 1991 by Venue
+
+
+(in-package "CLOS")
+
+
+
+(define-gf-predicate classp class)
+
+(define-gf-predicate standard-class-p standard-class)
+
+(define-gf-predicate forward-referenced-class-p forward-referenced-class)
+
+(defmethod shared-initialize :after ((object documentation-mixin)
+                                     slot-names &key documentation)
+       (declare (ignore slot-names))
+       (setf (plist-value object 'documentation)
+             documentation))
+
+(defmethod documentation (object &optional doc-type)
+       (cl:documentation object doc-type))
+
+(defmethod (setf documentation)
+       (new-value object &optional doc-type)
+       (declare (ignore new-value doc-type))
+       (error "Can't change the documentation of ~S." object))
+
+(defmethod documentation ((object documentation-mixin)
+                          &optional doc-type)
+  (declare (ignore doc-type))
+  (car (plist-value object 'documentation)))
+
+(defmethod (setf documentation)
+       (new-value (object documentation-mixin)
+              &optional doc-type)
+       (declare (ignore doc-type))
+       (setf (plist-value object 'documentation)
+             new-value))
+
+(defmethod documentation ((slotd standard-slot-definition)
+                          &optional doc-type)
+       (declare (ignore doc-type))
+       (slot-value slotd 'documentation))
+
+(defmethod (setf documentation)
+       (new-value (slotd standard-slot-definition)
+              &optional doc-type)
+       (declare (ignore doc-type))
+       (setf (slot-value slotd 'documentation)
+             new-value))
+
+(defmethod documentation ((method standard-method) &optional doc-type)
+  (declare (ignore doc-type))
+  (plist-value method 'documentation))
+
+(defmethod (setf documentation)
+	   (new-value (method standard-method)
+		      &optional doc-type)
+  (declare (ignore doc-type))
+  (setf (plist-value method 'documentation) new-value))
+
+;;; Various class accessors that are a little more complicated than can be done with automatically
+;;; generated reader methods. 
+
+
+(defmethod class-wrapper ((class clos-class))
+       (with-slots (wrapper)
+           class
+         (let ((w? wrapper))
+              (if (consp w?)
+                  (let ((new (make-wrapper class)))
+                       (setf (wrapper-instance-slots-layout new)
+                             (car w?)
+                             (wrapper-class-slots new)
+                             (cdr w?))
+                       (setq wrapper new))
+                  w?))))
+
+(defmethod class-precedence-list ((class clos-class))
+       (unless (class-finalized-p class)
+              (finalize-inheritance class))
+       (with-slots (class-precedence-list)
+           class
+         class-precedence-list))
+
+(defmethod class-finalized-p ((class clos-class))
+       (with-slots (wrapper)
+           class
+         (not (null wrapper))))
+
+(defmethod class-prototype ((class std-class))
+       (with-slots (prototype)
+           class
+         (or prototype (setq prototype (allocate-instance class)))))
+
+(defmethod class-direct-default-initargs ((class std-class))
+       (plist-value class 'direct-default-initargs))
+
+(defmethod class-default-initargs ((class std-class))
+       (plist-value class 'default-initargs))
+
+(defmethod class-constructors ((class std-class))
+       (plist-value class 'constructors))
+
+(defmethod class-slot-cells ((class std-class))
+       (plist-value class 'class-slot-cells))
+
+
+;;; Class accessors that are even a little bit more complicated than those above.  These have a
+;;; protocol for updating them, we must implement that protocol. Maintaining the direct subclasses
+;;; backpointers.  The update methods are here, the values are read by an automatically generated
+;;; reader method. 
+
+
+(defmethod add-direct-subclass ((class class)
+                                (subclass class))
+       (with-slots (direct-subclasses)
+           class
+         (pushnew subclass direct-subclasses)
+         subclass))
+
+(defmethod remove-direct-subclass ((class class)
+                                   (subclass class))
+       (with-slots (direct-subclasses)
+           class
+         (setq direct-subclasses (remove subclass direct-subclasses))
+         subclass))
+
+
+;;; Maintaining the direct-methods and direct-generic-functions backpointers. There are four generic
+;;; functions involved, each has one method for the class case and another method for the damned EQL
+;;; specializers. All of these are specified methods and appear in their specified place in the
+;;; class graph. ADD-METHOD-ON-SPECIALIZER REMOVE-METHOD-ON-SPECIALIZER SPECIALIZER-METHODS
+;;; SPECIALIZER-GENERIC-FUNCTIONS In each case, we maintain one value which is a cons.  The car is
+;;; the list methods.  The cdr is a list of the generic functions.  The cdr is always computed
+;;; lazily. 
+
+
+(defmethod add-method-on-specializer ((method method)
+                                      (specializer class))
+       (with-slots (direct-methods)
+           specializer
+         (setf (car direct-methods)
+               (adjoin method (car direct-methods))
+               (cdr direct-methods)
+               nil))
+       method)
+
+(defmethod remove-method-on-specializer ((method method)
+                                         (specializer class))
+       (with-slots (direct-methods)
+           specializer
+         (setf (car direct-methods)
+               (remove method (car direct-methods))
+               (cdr direct-methods)
+               nil))
+       method)
+
+(defmethod specializer-methods ((specializer class))
+       (with-slots (direct-methods)
+           specializer
+         (car direct-methods)))
+
+(defmethod specializer-generic-functions ((specializer class))
+       (with-slots (direct-methods)
+           specializer
+         (or (cdr direct-methods)
+             (setf (cdr direct-methods)
+                   (gathering1 (collecting-once)
+                          (dolist (m (car direct-methods))
+                              (gather1 (method-generic-function m))))))))
+
+
+;;; This hash table is used to store the direct methods and direct generic functions of EQL
+;;; specializers.  Each value in the table is the cons. 
+
+
+(defvar *eql-specializer-methods* (make-hash-table :test #'eql))
+
+(defmethod add-method-on-specializer ((method method)
+                                      (specializer eql-specializer))
+       (let* ((object (eql-specializer-object specializer))
+              (entry (gethash object *eql-specializer-methods*)))
+             (unless entry
+                 (setq entry (setf (gethash object *eql-specializer-methods*)
+                                   (cons nil nil))))
+             (setf (car entry)
+                   (adjoin method (car entry))
+                   (cdr entry)
+                   nil)
+             method))
+
+(defmethod remove-method-on-specializer ((method method)
+                                         (specializer eql-specializer))
+       (let* ((object (eql-specializer-object specializer))
+              (entry (gethash object *eql-specializer-methods*)))
+             (when entry
+                 (setf (car entry)
+                       (remove method (car entry))
+                       (cdr entry)
+                       nil))
+             method))
+
+(defmethod specializer-methods ((specializer eql-specializer))
+       (car (gethash (eql-specializer-object specializer)
+                   *eql-specializer-methods*)))
+
+(defmethod specializer-generic-functions ((specializer eql-specializer))
+       (let* ((object (eql-specializer-object specializer))
+              (entry (gethash object *eql-specializer-methods*)))
+             (when entry
+                 (or (cdr entry)
+                     (setf (cdr entry)
+                           (gathering1 (collecting-once)
+                                  (dolist (m (car entry))
+                                      (gather1 (method-generic-function m)))))))))
+
+(defun real-load-defclass (name metaclass-name supers slots other accessors)
+       (do-standard-defsetfs-for-defclass accessors)
+                                                             ; ***
+       (apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots
+              slots :definition-source `((defclass ,name ()
+                                             ())
+                                         ,(load-truename))
+              other))
+
+(defun ensure-class (name &rest all)
+       (apply #'ensure-class-using-class name (find-class name nil)
+              all))
+
+(defmethod ensure-class-using-class (name (class null)
+                                          &rest args &key)
+       (multiple-value-bind (meta initargs)
+           (ensure-class-values class args)
+         (setf class (apply #'make-instance meta :name name initargs)
+               (find-class name)
+               class)
+	 (inform-type-system-about-class class name)
+                                                             ; ***
+         class))
+
+(defmethod ensure-class-using-class (name (class clos-class)
+                                          &rest args &key)
+       (multiple-value-bind (meta initargs)
+           (ensure-class-values class args)
+         (unless (eq (class-of class)
+                     meta)
+                (change-class class meta))
+         (apply #'reinitialize-instance class initargs)
+         (inform-type-system-about-class class name)
+                                                             ; ***
+         class))
+
+(defun ensure-class-values (class args)
+       (let* ((initargs (copy-list args))
+              (unsupplied (list 1))
+              (supplied-meta (getf initargs :metaclass unsupplied))
+              (supplied-supers (getf initargs :direct-superclasses unsupplied))
+              (supplied-slots (getf initargs :direct-slots unsupplied))
+              (meta (cond ((neq supplied-meta unsupplied)
+                           (find-class supplied-meta))
+                          ((or (null class)
+                               (forward-referenced-class-p class))
+                           *the-class-standard-class*)
+                          (t (class-of class))))
+              (proto (class-prototype meta)))
+             (flet ((fix-super (s)
+                           (cond ((classp s)
+                                  s)
+                                 ((not (legal-class-name-p s))
+                                  (error "~S is not a class or a legal class name." s))
+                                 (t (or (find-class s nil)
+                                        (setf (find-class s)
+                                              (make-instance 'forward-referenced-class :name s)))))))
+                   (loop (unless (remf initargs :metaclass)
+                                (return)))
+                   (loop (unless (remf initargs :direct-superclasses)
+                                (return)))
+                   (loop (unless (remf initargs :direct-slots)
+                                (return)))
+                   (values meta (list* :direct-superclasses (and (neq supplied-supers unsupplied)
+                                                                 (mapcar #'fix-super supplied-supers)
+                                                                 )
+                                       :direct-slots
+                                       (and (neq supplied-slots unsupplied)
+                                            supplied-slots)
+                                       initargs)))))
+
+
+;;; 
+
+
+(defmethod shared-initialize :before ((class std-class)
+                                      slot-names &key direct-superclasses)
+       (declare (ignore slot-names))
+       
+       ;; *** error checking
+       )
+
+(defmethod shared-initialize :after ((class std-class)
+                                     slot-names 
+				     &key (direct-superclasses 
+					   nil direct-superclasses-p)
+                                     (direct-slots nil direct-slots-p)
+                                     (direct-default-initargs 
+				      nil direct-default-initargs-p))
+  (declare (ignore slot-names))
+  (setq direct-superclasses (if direct-superclasses-p
+				(setf (slot-value class 'direct-superclasses)
+				      (or direct-superclasses 
+					  (list *the-class-standard-object*)
+					  ))
+				(slot-value class 'direct-superclasses)))
+  (setq direct-slots (if direct-slots-p
+			 (setf (slot-value class 'direct-slots)
+			       (mapcar #'(lambda (pl)
+					   (make-direct-slotd class pl))
+				       direct-slots))
+			 (slot-value class 'direct-slots)))
+  (if direct-default-initargs-p
+      (setf (plist-value class 'direct-default-initargs)
+	    direct-default-initargs)
+      (setq direct-default-initargs
+	    (plist-value class 'direct-default-initargs)))
+  (setf (plist-value class 'class-slot-cells)
+	(gathering1 (collecting)
+                    (dolist (dslotd direct-slots)
+		      (when (eq (slotd-allocation dslotd)
+				class)
+			(let ((initfunction (slotd-initfunction dslotd)))
+			  (gather1 (cons (slotd-name dslotd)
+					 (if initfunction
+					     (funcall initfunction)
+					     *slot-unbound*))))))))
+  (add-direct-subclasses class direct-superclasses)
+  (add-slot-accessors class direct-slots))
+
+(defmethod reinitialize-instance :before ((class std-class)
+                                          &key direct-superclasses direct-slots 
+                                          direct-default-initargs)
+       (declare (ignore direct-default-initargs))
+       (remove-direct-subclasses class (class-direct-superclasses class))
+       (remove-slot-accessors class (class-direct-slots class)))
+
+(defmethod reinitialize-instance :after ((class std-class)
+                                         &rest initargs &key)
+       (update-class class nil)
+       (map-dependents class #'(lambda (dependent)
+                                      (apply #'update-dependent class dependent initargs))))
+
+(defun add-slot-accessors (class dslotds)
+       (fix-slot-accessors class dslotds 'add))
+
+(defun remove-slot-accessors (class dslotds)
+       (fix-slot-accessors class dslotds 'remove))
+
+(defun fix-slot-accessors (class dslotds add/remove)
+       (flet ((fix (gfspec name r/w)
+                   (let ((gf (ensure-generic-function gfspec)))
+                        (case r/w
+                            (r (if (eq add/remove 'add)
+                                   (add-reader-method class gf name)
+                                   (remove-reader-method class gf)))
+                            (w (if (eq add/remove 'add)
+                                   (add-writer-method class gf name)
+                                   (remove-writer-method class gf)))))))
+             (dolist (dslotd dslotds)
+                 (let ((slot-name (slotd-name dslotd)))
+                      (dolist (r (slotd-readers dslotd))
+                          (fix r slot-name 'r))
+                      (dolist (w (slotd-writers dslotd))
+                          (fix w slot-name 'w))))))
+
+(defun add-direct-subclasses (class new)
+       (dolist (n new)
+           (unless (memq class (class-direct-subclasses class))
+                  (add-direct-subclass n class))))
+
+(defun remove-direct-subclasses (class new)
+       (let ((old (class-direct-superclasses class)))
+            (dolist (o (set-difference old new))
+                (remove-direct-subclass o class))))
+
+
+;;; 
+
+
+(defmethod finalize-inheritance ((class std-class))
+       (update-class class t))
+
+
+;;; Called by :after reinitialize instance whenever a class is reinitialized. The class may or may
+;;; not be finalized. 
+
+
+(defun update-class (class finalizep)
+       (when (or finalizep (class-finalized-p class))
+           (let* ((dsupers (class-direct-superclasses class))
+                  (dslotds (class-direct-slots class))
+                  (dinits (class-direct-default-initargs class))
+                  (cpl (compute-class-precedence-list class dsupers))
+                  (eslotds (compute-slots class cpl dslotds))
+                  (inits (compute-default-initargs class cpl dinits)))
+                 (update-cpl class cpl)
+                 (update-slots class cpl eslotds)
+		 (update-dinits class dinits)
+                 (update-inits class inits)
+                 (update-constructors class)))
+       (unless finalizep
+           (dolist (sub (class-direct-subclasses class))
+               (update-class sub nil))))
+
+(defun update-cpl (class cpl)
+       (when (class-finalized-p class)
+           (unless (equal (class-precedence-list class)
+                          cpl)
+                  (force-cache-flushes class)))
+       (setf (slot-value class 'class-precedence-list)
+             cpl))
+
+(defun update-slots (class cpl eslotds)
+       (multiple-value-bind (nlayout nwrapper-class-slots)
+           (compute-storage-info cpl eslotds)
+         
+         ;; If there is a change in the shape of the instances then the old class is now obsolete. 
+         (let* ((owrapper (class-wrapper class))
+                (olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
+                (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
+                (nwrapper (cond ((null owrapper)
+                                 (make-wrapper class))
+                                ((and (equal nlayout olayout)
+                                      (not (iterate ((o (list-elements owrapper-class-slots))
+                                                     (n (list-elements nwrapper-class-slots)))
+                                                  (unless (eq (car o)
+                                                              (car n))
+                                                         (return t)))))
+                                 owrapper)
+                                (t 
+
+                                 ;; This will initialize the new wrapper to have the same state as
+                                 ;; the old wrapper.  We will then have to change that.  This may
+                                 ;; seem like wasted work (it is), but the spec requires that we
+                                 ;; call make-instances-obsolete. 
+                                   (make-instances-obsolete class)
+                                   (class-wrapper class)))))
+               (with-slots (wrapper no-of-instance-slots slots)
+                   class
+                 (setf no-of-instance-slots (length nlayout)
+                       slots eslotds (wrapper-instance-slots-layout nwrapper)
+                       nlayout
+                       (wrapper-class-slots nwrapper)
+                       nwrapper-class-slots wrapper nwrapper))
+               (dolist (eslotd eslotds)
+                   (setf (slotd-class eslotd)
+                         class)
+                   (setf (slotd-instance-index eslotd)
+                         (instance-slot-index nwrapper (slotd-name eslotd)))))))
+
+(defun compute-storage-info (cpl eslotds)
+       (let ((instance nil)
+             (class nil))
+            (dolist (eslotd eslotds)
+                (let ((alloc (slotd-allocation eslotd)))
+                     (cond ((eq alloc :instance)
+                            (push eslotd instance))
+                           ((classp alloc)
+                            (push eslotd class)))))
+            (values (compute-layout cpl instance)
+                   (compute-class-slots class))))
+
+(defun compute-layout (cpl instance-eslotds)
+       (let* ((names (gathering1 (collecting)
+                            (dolist (eslotd instance-eslotds)
+                                (when (eq (slotd-allocation eslotd)
+                                          :instance)
+                                    (gather1 (slotd-name eslotd))))))
+              (order nil))
+             (labels ((rwalk (tail)
+                             (when tail
+                                 (rwalk (cdr tail))
+                                 (dolist (ss (class-slots (car tail)))
+                                     (let ((n (slotd-name ss)))
+                                          (when (memq n names)
+                                              (setq order (cons n order)
+                                                    names
+                                                    (remove n names))))))))
+                    (rwalk cpl)
+                    (reverse (append names order)))))
+
+(defun compute-class-slots (eslotds)
+       (gathering1 (collecting)
+              (dolist (eslotd eslotds)
+                  (gather1 (assoc (slotd-name eslotd)
+                                  (class-slot-cells (slotd-allocation eslotd)))))))
+(defun update-dinits (class dinits)
+  (setf (plist-value class 'direct-default-initargs) 
+	(remove-invalid dinits (class-slots class))))
+
+(defun update-inits (class inits)
+       (setf (plist-value class 'default-initargs) 
+	     (remove-invalid inits (class-slots class))))
+
+;; bug: :default-initargs aren't updated with slots are removed, so
+;; update-inits removes initargs that don't have corresponding slots.
+
+(defun remove-invalid (inits slotds &aux (return nil))
+  (dolist (element inits)
+    (dolist (slotd slotds)
+      (if (member (car element) (slot-value slotd 'initargs))
+	  (pushnew element return))))
+  return)
+
+
+
+(defmethod compute-default-initargs ((class std-class)
+                                     cpl direct)
+       (labels ((walk (tail)
+                      (if (null tail)
+                          nil
+                          (let ((c (pop tail)))
+                               (append (if (eq c class)
+                                           direct
+                                           (class-direct-default-initargs c))
+                                      (walk tail))))))
+              (let ((initargs (walk cpl)))
+		(delete-duplicates initargs 
+				   :test #'eq :key #'car :from-end t))))
+
+
+;;; Protocols for constructing direct and effective slot definitions. 
+
+
+(defmethod direct-slot-definition-class ((class std-class)
+                                         initargs)
+       (declare (ignore initargs))
+       (find-class 'standard-direct-slot-definition))
+
+(defun make-direct-slotd (class initargs)
+       (let ((initargs (list* :class class initargs)))
+            (apply #'make-instance (direct-slot-definition-class class initargs)
+                   initargs)))
+
+
+;;; 
+
+
+(defmethod compute-slots ((class std-class)
+                          cpl class-direct-slots)
+       
+       ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once for each different slot
+       ;; name we find in our superclasses.  Each call receives the class and a list of the dslotds
+       ;; with that name. The list is in most-specific-first order. 
+       (let ((name-dslotds-alist nil))
+            (labels ((collect-one-class (dslotds)
+                            (dolist (d dslotds)
+                                (let* ((name (slotd-name d))
+                                       (entry (assq name name-dslotds-alist)))
+                                      (if entry
+                                          (push d (cdr entry))
+                                          (push (list name d)
+                                                name-dslotds-alist))))))
+                   (collect-one-class class-direct-slots)
+                   (dolist (c (cdr cpl))
+                       (collect-one-class (class-direct-slots c)))
+                   (mapcar #'(lambda (direct)
+                                    (compute-effective-slot-definition class (nreverse (cdr direct)))
+                                    )
+                          name-dslotds-alist))))
+
+(defmethod compute-effective-slot-definition ((class std-class)
+                                              dslotds)
+       (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
+              (class (effective-slot-definition-class class initargs)))
+             (apply #'make-instance class initargs)))
+
+(defmethod effective-slot-definition-class ((class std-class)
+                                            initargs)
+       (declare (ignore initargs))
+       (find-class 'standard-effective-slot-definition))
+
+(defmethod compute-effective-slot-definition-initargs ((class std-class)
+                                                       direct-slotds)
+       (let* ((name nil)
+              (initfunction nil)
+              (initform nil)
+              (initargs nil)
+              (allocation nil)
+              (type t)
+              (namep nil)
+              (initp nil)
+              (allocp nil))
+             (dolist (slotd direct-slotds)
+                 (when slotd
+                     (unless namep
+                         (setq name (slotd-name slotd)
+                               namep t))
+                     (unless initp
+                         (when (slotd-initfunction slotd)
+                             (setq initform (slotd-initform slotd)
+                                   initfunction
+                                   (slotd-initfunction slotd)
+                                   initp t)))
+                     (unless allocp
+                         (setq allocation (slotd-allocation slotd)
+                               allocp t))
+                     (setq initargs (append (slotd-initargs slotd)
+                                           initargs))
+                     (let ((slotd-type (slotd-type slotd)))
+                          (setq type (cond ((null type)
+                                            slotd-type)
+                                           ((subtypep type slotd-type)
+                                            type)
+                                           (t `(and ,type ,slotd-type)))))))
+             (list :name name :initform initform :initfunction initfunction :initargs initargs 
+                   :allocation allocation :type type)))
+
+
+;;; NOTE: For bootstrapping considerations, these can't use make-instance to make the method object.
+;;; They have to use make-a-method which is a specially bootstrapped mechanism for making standard
+;;; methods. 
+
+
+(defmethod add-reader-method ((class std-class)
+                              generic-function slot-name)
+       (let* ((name (class-name class))
+              (method (make-a-method 'standard-reader-method nil (list (or name 'standard-object))
+                             (list class)
+                             (make-reader-method-function class slot-name)
+                             "automatically generated reader method" slot-name)))
+             (add-method generic-function method)))
+
+(defmethod add-writer-method ((class std-class)
+                              generic-function slot-name)
+       (let* ((name (class-name class))
+              (method (make-a-method 'standard-writer-method nil (list 'new-value (or name
+                                                                                      
+                                                                                      '
+                                                                                      standard-object
+                                                                                      ))
+                             (list *the-class-t* class)
+                             (make-writer-method-function class slot-name)
+                             "automatically generated writer method" slot-name)))
+             (add-method generic-function method)))
+
+(defmethod remove-reader-method ((class std-class)
+                                 generic-function)
+       (let ((method (get-method generic-function nil (list class)
+                            nil)))
+            (when method (remove-method generic-function method))))
+
+(defmethod remove-writer-method ((class std-class)
+                                 generic-function)
+       (let ((method (get-method generic-function nil (list *the-class-t* class)
+                            nil)))
+            (when method (remove-method generic-function method))))
+
+
+;;; make-reader-method-function and make-write-method function are NOT part of the standard
+;;; protocol.  They are however useful, CLOS makes uses makes use of them internally and documents
+;;; them for CLOS users. *** This needs work to make type testing by the writer functions which ***
+;;; do type testing faster.  The idea would be to have one constructor *** for each possible type
+;;; test.  In order to do this it would be nice *** to have help from inform-type-system-about-class
+;;; and friends. *** There is a subtle bug here which is going to have to be fixed. *** Namely, the
+;;; simplistic use of the template has to be fixed.  We *** have to give the optimize-slot-value
+;;; method the user might have *** defined for this metclass a chance to run. 
+
+
+(defmethod make-reader-method-function ((class standard-class)
+                                        slot-name)
+       (make-std-reader-method-function slot-name))
+
+(defmethod make-writer-method-function ((class standard-class)
+                                        slot-name)
+       (make-std-writer-method-function slot-name))
+
+(defun make-std-reader-method-function (slot-name)
+       #'(lambda (instance)
+                (slot-value instance slot-name)))
+
+(defun make-std-writer-method-function (slot-name)
+       #'(lambda (nv instance)
+                (setf (slot-value instance slot-name)
+                      nv)))
+
+                                                             ; inform-type-system-about-class
+                                                             ; make-type-predicate 
+
+
+
+;;; These are NOT part of the standard protocol.  They are internal mechanism which CLOS uses to
+;;; *try* and tell the type system about class definitions. In a more fully integrated
+;;; implementation of CLOS, the type system would know about class objects and class names in a more
+;;; fundamental way and the mechanism used to inform the type system about new classes would be
+;;; different. 
+
+
+(defmethod inform-type-system-about-class ((class std-class)
+                                           name)
+       (let ((predicate-name (make-type-predicate-name name)))
+            (setf (symbol-function predicate-name)
+                  (make-type-predicate name))
+            (do-satisfies-deftype name predicate-name)
+	    (setf (gethash name lisp::*typep-hash-table*)
+		  predicate-name))) ;makes typep significantly faster...
+
+(defun make-type-predicate (name)
+       #'(lambda (x)
+                (not (null (memq (find-class name)
+                                 (cond ((std-instance-p x)
+                                        (class-precedence-list (std-instance-class x)))
+                                       ((fsc-instance-p x)
+                                        (class-precedence-list (fsc-instance-class x)))))))))
+
+
+;;; These 4 definitions appear here for bootstrapping reasons.  Logically, they should be in the
+;;; construct file.  For documentation purposes, a copy of these definitions appears in the
+;;; construct file.  If you change one of the definitions here, be sure to change the copy there. 
+
+
+(defvar *initialization-generic-functions* (list #'make-instance #'default-initargs 
+                                                 #'allocate-instance #'initialize-instance
+                                                 #'shared-initialize))
+
+(defmethod maybe-update-constructors ((generic-function generic-function)
+                                      (method method))
+       (when (memq generic-function *initialization-generic-functions*)
+           (labels ((recurse (class)
+                           (update-constructors class)
+                           (dolist (subclass (class-direct-subclasses class))
+                               (recurse subclass))))
+                  (when (classp (car (method-specializers method)))
+                      (recurse (car (method-specializers method)))))))
+
+(defmethod update-constructors ((class std-class))
+       (dolist (cons (class-constructors class))
+           (install-lazy-constructor-installer cons)))
+
+(defmethod update-constructors ((class class))
+       nil)
+
+(defmethod compatible-meta-class-change-p (class proto-new-class)
+       (eq (class-of class)
+           (class-of proto-new-class)))
+
+(defmethod check-super-metaclass-compatibility ((class t)
+                                                (new-super t))
+       (unless (eq (class-of class)
+                   (class-of new-super))
+           (error "The class ~S was specified as a~%super-class of the class ~S;~%~
+            but the meta-classes ~S and~%~S are incompatible." new-super class (class-of new-super)
+                  (class-of class))))
+
+
+;;; 
+
+
+(defun force-cache-flushes (class)
+       (let* ((owrapper (class-wrapper class))
+              (state (wrapper-state owrapper)))
+             
+             ;; We only need to do something if the state is still T.  If the state isn't T, it will
+             ;; be FLUSH or OBSOLETE, and both of those will already be doing what we want.  In
+             ;; particular, we must be sure we never change an OBSOLETE into a FLUSH since OBSOLETE
+             ;; means do what FLUSH does and then some. 
+             (when (eq state 't)
+                 (let ((nwrapper (make-wrapper class)))
+                      (setf (wrapper-instance-slots-layout nwrapper)
+                            (wrapper-instance-slots-layout owrapper))
+                      (setf (wrapper-class-slots nwrapper)
+                            (wrapper-class-slots owrapper))
+                      (without-interrupts (setf (slot-value class 'wrapper)
+                                                nwrapper)
+                             (invalidate-wrapper owrapper 'flush nwrapper))
+                      (update-constructors class)))))
+
+                                                             ; ??? ***
+
+
+(defun flush-cache-trap (owrapper nwrapper instance)
+       (declare (ignore owrapper))
+       (set-wrapper instance nwrapper))
+
+
+;;; make-instances-obsolete can be called by user code.  It will cause the next access to the
+;;; instance (as defined in 88-002R) to trap through the update-instance-for-redefined-class
+;;; mechanism. 
+
+
+(defmethod make-instances-obsolete ((class std-class))
+       (let ((owrapper (class-wrapper class))
+             (nwrapper (make-wrapper class)))
+            (setf (wrapper-instance-slots-layout nwrapper)
+                  (wrapper-instance-slots-layout owrapper))
+            (setf (wrapper-class-slots nwrapper)
+                  (wrapper-class-slots owrapper))
+            (without-interrupts (setf (slot-value class 'wrapper)
+                                      nwrapper)
+                   (invalidate-wrapper owrapper 'obsolete nwrapper)
+                   class)))
+
+(defmethod make-instances-obsolete ((class symbol))
+       (make-instances-obsolete (find-class class)))
+
+
+;;; obsolete-instance-trap is the internal trap that is called when we see an obsolete instance. 
+;;; The times when it is called are: - when the instance is involved in method lookup - when
+;;; attempting to access a slot of an instance It is not called by class-of, wrapper-of, or any of
+;;; the low-level instance access macros. Of course these times when it is called are an internal
+;;; implementation detail of CLOS and are not part of the documented description of when the obsolete
+;;; instance update happens.  The documented description is as it appears in 88-002R. This has to
+;;; return the new wrapper, so it counts on all the methods on obsolete-instance-trap-internal to
+;;; return the new wrapper.  It also does a little internal error checking to make sure that the
+;;; traps are only happening when they should, and that the trap methods are computing apropriate
+;;; new wrappers. 
+
+
+(defun obsolete-instance-trap (owrapper nwrapper instance)
+       
+       ;; local  --> local        transfer local  --> shared       discard local  -->  --         
+       ;; discard shared --> local        transfer shared --> shared       discard shared -->  --   
+       ;; discard --    --> local        add --    --> shared        -- 
+       (let* ((class (wrapper-class nwrapper))
+              (guts (allocate-instance class))
+                                                             ; ??? allocate-instance ???
+              (olayout (wrapper-instance-slots-layout owrapper))
+              (nlayout (wrapper-instance-slots-layout nwrapper))
+              (oslots (get-slots instance))
+              (nslots (get-slots guts))
+              (oclass-slots (wrapper-class-slots owrapper))
+              (added nil)
+              (discarded nil)
+              (plist nil))
+             
+             ;; Go through all the old local slots. 
+             (iterate ((name (list-elements olayout))
+                       (opos (interval :from 0)))
+                    (let ((npos (posq name nlayout)))
+                         (if npos
+                             (setf (svref nslots npos)
+                                   (svref oslots opos))
+                             (progn (push name discarded)
+                                    (unless (eq (svref oslots opos)
+                                                *slot-unbound*)
+                                        (setf (getf plist name)
+                                              (svref oslots opos)))))))
+             
+             ;; Go through all the old shared slots. 
+             (iterate ((oclass-slot-and-val (list-elements oclass-slots)))
+                    (let ((name (car oclass-slot-and-val))
+                          (val (cdr oclass-slot-and-val)))
+                         (let ((npos (posq name nlayout)))
+                              (if npos
+                                  (setf (svref nslots npos)
+                                        (cdr oclass-slot-and-val))
+                                  (progn (push name discarded)
+                                         (unless (eq val *slot-unbound*)
+                                             (setf (getf plist name)
+                                                   val)))))))
+             
+             ;; Go through all the new local slots to compute the added slots. 
+             (dolist (nlocal nlayout)
+                 (unless (or (memq nlocal olayout)
+                             (assq nlocal oclass-slots))
+                        (push nlocal added)))
+             (without-interrupts (set-wrapper instance nwrapper)
+                    (set-slots instance nslots))
+             (update-instance-for-redefined-class instance added discarded plist)
+             nwrapper))
+
+
+;;; 
+
+
+(defmacro change-class-internal (wrapper-fetcher slots-fetcher alloc)
+       `(let* ((old-class (class-of instance))
+               (copy (,alloc old-class))
+               (guts (,alloc new-class))
+               (new-wrapper (,wrapper-fetcher guts))
+               (old-wrapper (class-wrapper old-class))
+               (old-layout (wrapper-instance-slots-layout old-wrapper))
+               (new-layout (wrapper-instance-slots-layout new-wrapper))
+               (old-slots (,slots-fetcher instance))
+               (new-slots (,slots-fetcher guts))
+               (old-class-slots (wrapper-class-slots old-wrapper)))
+              
+              ;; "The values of local slots specified by both the class Cto and Cfrom are retained. 
+              ;; If such a local slot was unbound, it remains unbound." 
+              (iterate ((new-slot (list-elements new-layout))
+                        (new-position (interval :from 0)))
+                     (let ((old-position (position new-slot old-layout :test #'eq)))
+                          (when old-position
+                              (setf (svref new-slots new-position)
+                                    (svref old-slots old-position)))))
+              
+              ;; "The values of slots specified as shared in the class Cfrom and as local in the
+              ;; class Cto are retained." 
+              (iterate ((slot-and-val (list-elements old-class-slots)))
+                     (let ((position (position (car slot-and-val)
+                                            new-layout :test #'eq)))
+                          (when position
+                              (setf (svref new-slots position)
+                                    (cdr slot-and-val)))))
+              
+              ;; Make the copy point to the old instance's storage, and make the old instance point
+              ;; to the new storage. 
+              (without-interrupts (setf (,slots-fetcher copy)
+                                        old-slots)
+                     (setf (,wrapper-fetcher instance)
+                           new-wrapper)
+                     (setf (,slots-fetcher instance)
+                           new-slots))
+              (update-instance-for-different-class copy instance)
+              instance))
+
+(defmethod change-class ((instance standard-object)
+                         (new-class standard-class))
+       (unless (std-instance-p instance)
+           (error "Can't change the class of ~S to ~S~@
+            because it isn't already an instance with metaclass~%~S." instance new-class 
+                  'standard-class))
+       (change-class-internal std-instance-wrapper std-instance-slots allocate-instance))
+
+(defmethod change-class ((instance standard-object)
+                         (new-class funcallable-standard-class))
+       (unless (fsc-instance-p instance)
+           (error "Can't change the class of ~S to ~S~@
+            because it isn't already an instance with metaclass~%~S." instance new-class 
+                  'funcallable-standard-class))
+       (change-class-internal fsc-instance-wrapper fsc-instance-slots allocate-instance))
+
+(defmethod change-class ((instance t)
+                         (new-class-name symbol))
+       (change-class instance (find-class new-class-name)))
+
+
+;;; The metaclass BUILT-IN-CLASS This metaclass is something of a weird creature.  By this point,
+;;; all instances of it which will exist have been created, and no instance is ever created by
+;;; calling MAKE-INSTANCE. But, there are other parts of the protcol we must follow and those
+;;; definitions appear here. 
+
+
+(defmethod shared-initialize :before ((class built-in-class)
+                                      slot-names &rest initargs)
+       (declare (ignore slot-names))
+       (error "Attempt to initialize or reinitialize a built in class."))
+
+(defmethod class-direct-slots ((class built-in-class))
+       nil)
+
+(defmethod class-slots ((class built-in-class))
+       nil)
+
+(defmethod class-direct-default-initargs ((class built-in-class))
+       nil)
+
+(defmethod class-default-initargs ((class built-in-class))
+       nil)
+
+(defmethod check-super-metaclass-compatibility ((c class)
+                                                (s built-in-class))
+       (or (eq s *the-class-t*)
+           (error "~S cannot have ~S as a super.~%~
+              The class ~S is the only built in class that can be a~%~
+              superclass of a standard class." c s *the-class-t*)))
+
+
+;;; 
+
+
+(defmethod check-super-metaclass-compatibility ((c std-class)
+                                                (f forward-referenced-class))
+       't)
+
+
+;;; 
+
+
+(defmethod add-dependent ((metaobject dependent-update-mixin)
+                          dependent)
+       (pushnew dependent (plist-value metaobject 'dependents)))
+
+(defmethod remove-dependent ((metaobject dependent-update-mixin)
+                             dependent)
+       (setf (plist-value metaobject 'dependents)
+             (delete dependent (plist-value metaobject 'dependents))))
+
+(defmethod map-dependents ((metaobject dependent-update-mixin)
+                           function)
+       (dolist (dependent (plist-value metaobject 'dependents))
+           (funcall function dependent)))
diff --git a/clos/2.0/test.lisp b/clos/2.0/test.lisp
new file mode 100644
index 00000000..74c921f2
--- /dev/null
+++ b/clos/2.0/test.lisp
@@ -0,0 +1,2880 @@
+;;;-*- Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;; 
+;;; Testing code.
+;;;
+
+(in-package :clos)
+
+;;; Because CommonLoops runs in itself so much, the notion of a test file for
+;;; it is kind of weird.
+;;;
+;;; If all of CLOS loads then many of the tests in this file (particularly
+;;; those at the beginning) are sure to work.  Those tests exists primarily
+;;; to help debug things when low-level changes are made to CLOS, or when a
+;;; particular port customizes low-level code.
+;;;
+;;; Some of the other tests are "real" in the sense that they test things
+;;; that CLOS itself does not use, so might be broken.
+;;; 
+;;; NOTE:
+;;;   The tests in this file do not appear in random order!  They
+;;;   depend on state  which has already been set up in order to run.
+;;;
+
+(defmacro do-test (name cleanups &body body)
+  `(let ((do-test-failed nil))
+     (catch 'do-test
+       (format t "~&Testing ~A..." ,name)
+;       (cleanup-do-test ',cleanups)
+       (block do-test ,@body)
+       (if do-test-failed
+           (format t "~&FAILED!")
+           (format t "OK")))))
+  
+(defmacro do-test-error (fatal string &rest args)
+  `(progn (terpri)
+          (setq do-test-failed t)
+          (format t ,string ,@args)
+          (when ,fatal (return-from do-test nil))))
+
+(defun cleanup-do-test (cleanups)
+  (dolist (cleanup cleanups)
+    (ecase (car cleanup)
+      (:classes
+        (dolist (c (cdr cleanup))
+          (let ((class (find-class c 'nil)))
+            (when class
+              (dolist (super (slot-value class 'direct-superclasses))
+                (setf (slot-value class 'direct-subclasses)
+                      (remove class (slot-value class 'direct-subclasses))))
+              (setf (find-class c) nil)))))
+      (:functions
+        (dolist (f (cdr cleanup))
+          (fmakunbound f)))
+      (:setf-generic-functions
+        (dolist (f (cdr cleanup))
+          (fmakunbound (get-setf-function-name f))))
+      (:variables
+        (dolist (v (cdr cleanup))
+          (makunbound v))))))
+
+#-(or KCL IBCL :Coral GCLisp)
+(eval-when (eval)
+  (compile 'do-test)
+  (compile 'do-test-error)
+  (compile 'cleanup-do-test))
+
+  ;;   
+;;;;;; 
+  ;;   
+
+(do-test "types for early classes"
+         ()
+  (dolist (x '(standard-object standard-class standard-slot-definition))
+    (or (typep (make-instance x) x)
+        (do-test-error () "instance of ~S not of type ~S??" x x))))
+
+
+(do-test "types for late classes"
+         ()
+  (dolist (x '(standard-method standard-generic-function))
+    (or (typep (make-instance x) x)
+        (do-test-error () "~&instance of ~S not of type ~S??" x x))))
+
+(defvar *built-in-class-tests*
+        '((ARRAY (MAKE-ARRAY '(10 10)))
+          (BIT-VECTOR (MAKE-ARRAY 10 :ELEMENT-TYPE 'BIT))
+          (CHARACTER #\a)
+          (COMPLEX #C(1 2))
+          (CONS (LIST 1 2 3))
+          (FLOAT 1.3)
+          (INTEGER 1)
+         ;LIST                   abstract super of cons, null
+          (NULL NIL)
+         ;NUMBER                 abstract super of complex, float, rational
+          (RATIO 1/2)
+         ;RATIONAL               abstract super of ratio, integer
+         ;SEQUENCE               abstract super of list, vector
+          (STRING "foo")
+          (SYMBOL 'FOO)
+          (VECTOR (VECTOR 1 2 3))))
+
+(do-test "built-in-class-of"
+         ()
+  (let ((lostp nil))
+    (dolist (tst *built-in-class-tests*)
+      (unless (eq (find-class (car tst) 't)
+                  (class-of (eval (cadr tst))))
+        (do-test-error ()
+                       "~&class-of ~S was ~A not ~A~%"
+                       (cadr tst)
+                       (class-name (class-of (eval (cadr tst))))
+                       (car tst))
+        (setq lostp t)))
+    (not lostp)))
+
+(do-test "existence of generic-functions for accessors of early classes"
+         ()
+  ;; Because accessors are done with add-method, and this has to be done
+  ;; specially for early classes it is worth testing to make sure that
+  ;; the generic-functions got created for the accessor of early classes.
+  ;;
+  ;; Of course CLOS wouldn't have loaded if most of these didn't exist,
+  ;; but what the hell.
+  (dolist (class '(standard-class
+                   standard-slot-definition
+                   standard-generic-function
+                   standard-method))
+    (dolist (slotd (class-slots (find-class class)))
+      (dolist (rea (slotd-readers slotd))
+        (unless (and (gboundp rea)
+                     (generic-function-p (gdefinition rea)))
+          (do-test-error () "~S isn't a generic function" rea)))
+      (dolist (wri (slotd-writers slotd))
+        (unless (and (gboundp wri)
+                     (generic-function-p (gdefinition wri)))
+          (do-test-error () "~S isn't a generic function" wri))))))
+
+(do-test "early reader/writer methods are appropriate class"
+         ()
+  ;; Because accessors are done with add-method, and this has to be done
+  ;; specially for early classes it is worth testing to make sure that
+  ;; the generic-functions got created for the accessor of early classes.
+  ;;
+  ;; Of course CLOS wouldn't have loaded if most of these didn't exist,
+  ;; but what the hell.
+  (dolist (class '(standard-class
+                   standard-slot-definition
+                   standard-generic-function
+                   standard-method))
+    (let ((class (find-class 'standard-class)))
+      (flet ((check-reader (gf)
+               (let ((reader (get-method (gdefinition gf)
+                                         ()
+                                         (list class))))
+                 (unless (typep reader 'standard-reader-method)
+                   (do-test-error () "~S isn't a READER method" reader))))
+             (check-writer (gf)
+               (let ((writer (get-method (gdefinition gf)
+                                         ()
+                                         (list (find-class 't) class))))
+                 (unless (typep writer 'standard-writer-method)
+                   (do-test-error () "~S isn't a WRITER method" writer)))))
+        (dolist (slotd (class-direct-slots class))
+          (dolist (rea (slotd-readers slotd))
+            (check-reader rea))   
+          (dolist (wri (slotd-writers slotd))
+            (check-writer wri)))))))
+
+(do-test "typep works for standard-classes"
+         ((:classes foo1 foo2 bar))
+
+  (defclass foo1 () ())
+  (defclass foo2 (foo1) ())
+  (defclass bar () ())
+
+  (let ((f1 (make-instance 'foo1))
+        (f2 (make-instance 'foo2)))
+    (or (typep f1 'foo1)
+        (do-test-error
+          () "an instance of foo1 isn't subtypep of foo1"))
+    (or (not (typep f1 'foo2))
+        (do-test-error
+          () "an instance of foo1 is suptypep of a subclass of foo1"))
+    (or (not (typep f1 'bar))
+        (do-test-error
+          () "an instance of foo1 is subtypep of an unrelated class"))
+    (or (typep f2 'foo1)
+        (do-test-error
+          () "an instance of foo2 is not subtypep of a super-class of foo2"))
+    ))
+
+(do-test "accessors and readers should NOT be inherited"
+         ((:classes foo bar)
+          (:functions foo-x foo-y))
+
+  (defclass foo ()
+       ((x :accessor foo-x)
+        (y :reader foo-y)))
+
+  (fmakunbound 'foo-x)
+  (fmakunbound 'foo-y)
+
+  (defclass bar (foo)
+       (x y))
+
+  (and (fboundp 'foo-x) (do-test-error () "foo-x got inherited?"))
+  (and (fboundp 'foo-y) (do-test-error () "foo-x got inherited?")))
+
+(do-test ":accessor and :reader methods go away"
+         ((:classes foo)
+          (:functions foo-x foo-y)
+          (:setf-generic-functions foo-x foo-y))  
+
+  (defclass foo () ((x :accessor foo-x) (y :reader foo-y)))
+
+  (unless (and (fboundp 'foo-x)
+               (fboundp 'foo-y))
+    (do-test-error t "accessors didn't even get generated?"))
+
+  (defclass foo () (x y))
+
+  (flet ((methods (x)
+           (generic-function-methods (symbol-function 'foo-y))))
+    
+    (and (methods 'foo-x)
+         (do-test-error () "~&reader method for foo-x not removed"))
+    (and (methods 'foo-y)
+         (do-test-error () "~&reader method for foo-y not removed"))
+    (and (methods (get-setf-function-name 'foo-y))
+         (do-test-error () "~&writer method for foo-y not removed"))
+    t))
+
+
+(defclass test-class-1 ()
+     ((x :initform nil :accessor test-class-1-x :initarg :x)
+      (y :initform nil :accessor test-class-1-y :initarg :y)))
+
+(do-test "Simple with-accessors test -- does not really exercise the walker."
+         ((:functions foo bar))
+
+  (defmethod foo ((obj test-class-1))
+    (with-accessors ((x test-class-1-x)
+                     (y test-class-1-y))
+                    obj
+      (list x y)))
+
+  (defmethod bar ((obj test-class-1))
+    (with-accessors ((x test-class-1-x)
+                     (y test-class-1-y))
+                obj
+      (setq x 1
+            y 2)))
+
+  (or (and (equal '(nil nil) (foo (make-instance 'test-class-1)))
+           (equal '(1 2) (foo (make-instance 'test-class-1 :x 1 :y 2))))
+      (do-test-error () "FOO (the one that reads) failed"))
+
+  (or (let ((foo (make-instance 'test-class-1)))
+        (bar foo)
+        (or (and (equal (slot-value foo 'x) 1)
+                 (equal (slot-value foo 'y) 2))
+            (do-test-error () "BAR (the one that writes) failed")))))
+
+(do-test "Simple with-slots test -- does not really exercise the walker."
+         ((:functions foo bar))
+  
+  (defmethod foo ((obj test-class-1))
+    (with-slots (x y)
+                obj
+      (list x y)))
+
+  (defmethod bar ((obj test-class-1))
+    (with-slots ((obj-x x)
+                 (obj-y y))
+                obj
+      (setq obj-x 1
+            obj-y 2)))
+
+  (or (and (equal '(nil nil) (foo (make-instance 'test-class-1)))
+           (equal '(1 2) (foo (make-instance 'test-class-1 :x 1 :y 2))))
+      (do-test-error () "FOO (the one that reads) failed"))
+
+  (or (let ((foo (make-instance 'test-class-1)))
+        (bar foo)
+        (or (and (equal (slot-value foo 'x) 1)
+                 (equal (slot-value foo 'y) 2))
+            (do-test-error () "BAR (the one that writes) failed")))))
+
+  ;;   
+;;;;;; things that bug fixes prompted.
+  ;;   
+
+
+(do-test "with-slots inside of lexical closures"
+         ((:functions frog barg))
+  ;; 6/20/86
+  ;; The walker was confused about what (FUNCTION (LAMBDA ..)) meant.  It
+  ;; didn't walk inside there.  Its sort of surprising this didn't get
+  ;; caught sooner.
+
+  (defun frog (fn foos)
+    (and foos (cons (funcall fn (car foos)) (frog fn (cdr foos)))))
+
+  (defun barg ()
+    (let ((the-test-class (make-instance 'test-class-1 :x 0 :y 3)))
+      (with-slots (x y)
+                  the-test-class
+        (frog #'(lambda (foo) (incf x) (decf y))
+             (make-list 3)))))
+
+  (or (equal (barg) '(2 1 0))
+      (do-test-error t "lost")))
+
+(do-test "redefinition of default method has proper effect"
+         ((:functions foo))
+  ;; 5/26/86
+  ;; This was caused because the hair for trying to avoid making a
+  ;; new discriminating function didn't know that changing the default
+  ;; method was a reason to make a new discriminating function.  Fixed
+  ;; by always making a new discriminating function when a method is
+  ;; added or removed.  The template stuff should keep this from being
+  ;; expensive.
+
+  (defmethod foo ((x standard-class)) 'standard-class)
+  (defmethod foo (x) 'default)
+  (defmethod foo (x) 'new-default)
+
+  (or (eq (foo nil) 'new-default)
+      (do-test-error t "lost")))
+
+
+
+(defvar *call-next-method-test-object* (make-instance 'standard-object))
+
+(do-test "call-next-method passes original arguments"
+         ((:functions foo))
+  ;; 2/4/88
+  ;; The spec says that call-next-method must pass the original arguments
+  ;; to call-next-method when none are supplied.  This tests that.
+
+  (defmethod foo ((x t))
+    (unless (eq x *call-next-method-test-object*)
+      (do-test-error t "got wrong value")))
+
+  (defmethod foo ((x standard-object))
+    (setq x nil)
+    (call-next-method))
+
+  (foo *call-next-method-test-object*)
+
+  )
+
+(do-test "call-next-method closures pass original arguments - 1"
+         ((:functions foo))
+  ;; 2/4/88
+  ;; call-next-method must pass the original arguments even when it is
+  ;; returned as a lexical closure with indefinite extent
+
+  (defmethod foo ((x t))
+    (unless (eq x *call-next-method-test-object*)
+      (do-test-error t "got wrong value")))
+
+  (defmethod foo ((x standard-object))
+    (setq x nil)
+    #'call-next-method)
+
+  (funcall (foo *call-next-method-test-object*))
+
+  )
+
+(do-test "call-next-method closures pass original arguments - 2"
+         ((:functions foo))
+  ;; 2/4/88
+  ;; call-next-method must pass the original arguments even when it is
+  ;; returned as a lexical closure with indefinite extent
+
+  (defmethod foo ((x t))
+    (unless (eq x *call-next-method-test-object*)
+      (do-test-error t "got wrong value")))
+
+  (defmethod foo ((x standard-object))
+    #'(lambda ()
+        (setq x nil)
+        (call-next-method)))
+
+  (funcall (foo *call-next-method-test-object*))
+
+  )
+
+(do-test "call-next-method passes supplied arguments"
+         ((:functions foo))
+  ;; 2/4/88
+  ;; The spec says that call-next-method must pass the original arguments
+  ;; to call-next-method when none are supplied.  This tests that.
+
+  (defmethod foo ((x t))
+    (unless (eq x *call-next-method-test-object*)
+      (do-test-error t "got wrong value")))
+
+  (defmethod foo ((x standard-object))
+    (call-next-method *call-next-method-test-object*))
+
+  (foo (make-instance 'standard-object))
+
+  )
+
+(do-test "call-next-method closures pass supplied arguments - 1"
+         ((:functions foo))
+  ;; 2/4/88
+  ;; call-next-method must pass the original arguments even when it is
+  ;; returned as a lexical closure with indefinite extent
+
+  (defmethod foo ((x t))
+    (unless (eq x *call-next-method-test-object*)
+      (do-test-error t "got wrong value")))
+
+  (defmethod foo ((x standard-object))
+    #'call-next-method)
+
+  (funcall (foo (make-instance 'standard-object)) *call-next-method-test-object*)
+
+  )
+
+(do-test "call-next-method closures pass supplied arguments - 2"
+         ((:functions foo))
+  ;; 2/4/88
+  ;; call-next-method must pass the original arguments even when it is
+  ;; returned as a lexical closure with indefinite extent
+
+  (defmethod foo ((x t))
+    (unless (eq x *call-next-method-test-object*)
+      (do-test-error t "got wrong value")))
+
+  (defmethod foo ((x standard-object))
+    #'(lambda (x)
+        (call-next-method x)))
+
+  (funcall (foo (make-instance 'standard-object)) 
+	   *call-next-method-test-object*))
+
+
+(do-test "call-next-method inside of default value form of &optional"
+         ((:functions foo))
+  ;; 5/3/88
+  ;; call-next-method must work inside the default value forms of the
+  ;; method's &mumble arguments.
+
+  (defmethod foo1 ((x t) &optional y)
+    (declare (ignore y))
+    *call-next-method-test-object*)
+
+  (defmethod foo1 ((x standard-object) &optional (y (call-next-method)))
+    (list x y))
+
+  (let ((object (make-instance 'standard-object)))
+    (unless (equal (foo1 object) (list object *call-next-method-test-object*))
+      (do-test-error t "Got wrong value"))))
+
+(do-test "specifying :type when superclass doesn't"
+         ((:classes foo bar))
+  ;; 3/23/88
+  ;; if a suclass specifies the :type slot option for a slot for which no
+  ;; superclass specifies a type then the inheritance rule is just to take
+  ;; the type specified by the subclass
+  
+  (defclass foo ()
+       ((x)))
+
+  (defclass bar (foo)
+       ((x :type number))))
+
+
+(do-test "Leaky next methods"
+         ((:functions foo bar))
+  ;; 6/23/88
+  ;; Since I use special variables to communicate the next methods info,
+  ;; there can be bugs which cause them to leak to the wrong method.
+
+  (defmethod foo ((x standard-class))
+    (bar x))
+
+  (defmethod foo ((x class))
+    (call-next-method))
+
+  (defmethod foo ((x t))
+    t)
+
+  (defmethod bar ((x standard-class))
+    (next-method-p))
+
+  (unless (foo (find-class 't))
+    (do-test-error nil "Method leaked.")))
+
+
+;;;
+;;; some simple tests for initialization protocols
+;;; 8/5/88
+;;; 
+(proclaim '(special x-initform-fired y-initform-fired z-initform-fired))
+
+(defclass initialization-test-1 ()
+     ((x :initform (setq x-initform-fired 'x-initform))
+      (y :initform (setq y-initform-fired 'y-initform))
+      (z :initform (setq z-initform-fired 'z-initform))))
+
+(defclass initialization-test-2 ()
+     ((x :initform (setq x-initform-fired 'x-initform) :initarg :x)
+      (y :initform (setq y-initform-fired 'y-initform) :initarg :y)
+      (z :initform (setq z-initform-fired 'z-initform) :initarg :z)))
+
+(defclass initialization-test-3 ()
+     ((x :initform (setq x-initform-fired 'x-initform) :initarg :x)
+      (y :initform (setq y-initform-fired 'y-initform) :initarg :y)
+      (z :initform (setq z-initform-fired 'z-initform) :initarg :z))
+  (:default-initargs :x 'x-default))
+
+(defclass initalization-test-4 (initialization-test-3)
+     ()
+  (:default-initargs :z 'z-default))
+
+(defclass initialization-test-5 (initialization-test-4)
+     ()
+  (:default-initargs :x 'x-default-from-5))
+      
+(do-test "shared-initialize with T argument and no initargs"
+         ()
+
+  (let (x-initform-fired y-initform-fired z-initform-fired)
+    (let* ((class (find-class 'initialization-test-1))
+           (instance (allocate-instance class)))
+
+      (shared-initialize instance 't)
+
+      (unless x-initform-fired (do-test-error nil "x initform not evaluated"))
+      (unless y-initform-fired (do-test-error nil "y initform not evaluated"))
+      (unless z-initform-fired (do-test-error nil "z initform not evaluated"))
+      
+      (unless (eq (slot-value instance 'x) 'x-initform)
+        (do-test-error nil "Value of X doesn't match initform"))
+      (unless (eq (slot-value instance 'y) 'y-initform)
+        (do-test-error nil "Value of X doesn't match initform"))
+      (unless (eq (slot-value instance 'z) 'z-initform)
+        (do-test-error nil "Value of X doesn't match initform"))
+
+      )))
+
+(do-test "shared-initialize with T argument and initargs"
+         ()
+
+  (let (x-initform-fired y-initform-fired z-initform-fired)
+    (let* ((class (find-class 'initialization-test-2))
+           (instance (allocate-instance class)))
+
+      (shared-initialize instance 't :y 'y-initarg)
+
+      (unless x-initform-fired
+        (do-test-error nil "x initform not evaluated"))
+      (unless (not y-initform-fired)
+        (do-test-error nil "y initform was evaluated"))
+      (unless z-initform-fired
+        (do-test-error nil "z initform not evaluated"))
+      
+      (unless (eq (slot-value instance 'x) 'x-initform)
+        (do-test-error nil "Value of X doesn't match initform"))
+      (unless (eq (slot-value instance 'y) 'y-initarg)
+        (do-test-error nil "Value of X doesn't match initform"))
+      (unless (eq (slot-value instance 'z) 'z-initform)
+        (do-test-error nil "Value of X doesn't match initform"))
+
+      )))
+
+(do-test "initialization arguments rules test"
+         ((:classes foo bar))
+
+  (defclass foo ()
+       ((x :initarg a)))
+
+  (defclass bar (foo)
+       ((x :initarg b))
+    (:default-initargs a 1 b 2))
+
+  (unless (and (equal (default-initargs (find-class 'bar) '())
+                      '(b 2 a 1))
+               (equal (default-initargs (find-class 'bar) '(a 3))
+                      '(a 3 b 2))
+               (equal (default-initargs (find-class 'bar) '(b 4))
+                      '(b 4 a 1))
+               (equal (default-initargs (find-class 'bar) '(a 1 a 2))
+                      '(a 1 a 2 b 2)))
+    (do-test-error nil "default-initargs got wrong value"))
+
+  (unless (and (eq (slot-value (make-instance 'bar) 'x) 1)
+               (eq (slot-value (make-instance 'bar 'a 3) 'x) 3)
+               (eq (slot-value (make-instance 'bar 'b 4) 'x) 4)
+               (eq (slot-value (make-instance 'bar 'a 1 'a 2) 'x) 1))
+    (do-test-error nil "initialization in make-instance failed"))
+
+  )
+
+
+#| testing a pair of lists for equality bogus, '(a b c) <> '(b c a)
+
+(do-test "more tests for initialization arguments rules"
+         ((:classes foo fie bar baz))
+
+  (defclass foo ()
+       ((a :initform 'initform-foo-a)
+        (b :initarg :foo-b)
+        (c :initform 'initform-foo-c)
+        (d :initarg :foo-d))
+    (:default-initargs :foo-b 'initarg-foo-b
+                       :foo-d 'initarg-foo-d))
+  (defclass fie (foo)
+       ((a :initform 'initform-fie-a)
+        (b :initarg :fie-b)
+        (c :initform 'initform-fie-c :allocation :class)
+        (d :initarg :fie-d :allocation :class))
+    (:default-initargs :fie-b 'initarg-fie-b
+                       :fie-d 'initarg-fie-d))
+  (defclass bar (foo)
+       ((a :initform 'initform-bar-a)
+        (b :initarg :bar-b)
+        (c :initform 'initform-bar-c)
+        (d :initarg :bar-d))
+    (:default-initargs :bar-b 'initarg-bar-b
+                       :bar-d 'initarg-bar-d))
+  (defclass baz (fie bar)
+       ((a :initform 'initform-baz-a)
+        (b :initarg :baz-b)
+        (c :initform 'initform-baz-c)
+        (d :initarg :baz-d))
+    (:default-initargs :baz-b 'initarg-baz-b
+                       :baz-d 'initarg-baz-d))
+
+  (unless (and (equal (default-initargs (find-class 'foo) ())
+                      '(:foo-d initarg-foo-d 
+			:foo-b initarg-foo-b))
+               (equal (default-initargs (find-class 'fie) ())
+                      '(:fie-b initarg-fie-b
+                        :fie-d initarg-fie-d
+                        :foo-b initarg-foo-b
+                        :foo-d initarg-foo-d))
+               (equal (default-initargs (find-class 'bar) ())
+                      '(:bar-b initarg-bar-b
+                        :bar-d initarg-bar-d
+                        :foo-b initarg-foo-b
+                        :foo-d initarg-foo-d))
+               (equal (default-initargs (find-class 'baz) ())
+                      '(:baz-b initarg-baz-b
+                        :baz-d initarg-baz-d
+                        :fie-b initarg-fie-b
+                        :fie-d initarg-fie-d
+                        :bar-b initarg-bar-b
+                        :bar-d initarg-bar-d
+                        :foo-b initarg-foo-b
+                        :foo-d initarg-foo-d)))
+    (do-test-error nil "default-initargs got wrong value"))
+  )
+|#
+(do-test "initialization protocols"
+         ((:classes foo))
+
+  (let ((initform-for-x 'initform-x)
+        (initform-for-y 'initform-y)
+        (initform-for-z 'initform-z)
+        (default-initarg-for-x 'default-initarg-x)
+        (initarg-supplied-for-z 'initarg-z)
+        instance-of-foo)
+    
+    (defclass foo ()
+         ((x :initform initform-for-x :initarg :x)
+          (y :initform initform-for-y :initarg :y)
+          (z :initform initform-for-z :initarg :z))
+      (:default-initargs :x default-initarg-for-x))
+
+    (setq instance-of-foo (make-instance 'foo :z initarg-supplied-for-z))
+
+    (unless (and (eq (slot-value instance-of-foo 'x)
+                     default-initarg-for-x)
+                 (eq (slot-value instance-of-foo 'y)
+                     initform-for-y)
+                 (eq (slot-value instance-of-foo 'z)
+                     initarg-supplied-for-z))
+      (do-test-error nil "initialization failed"))
+
+    (setq instance-of-foo
+          (reinitialize-instance (allocate-instance (find-class 'foo))
+                                 :z initarg-supplied-for-z))
+
+    (unless (and (not (slot-boundp instance-of-foo 'x))
+                 (not (slot-boundp instance-of-foo 'y))
+                 (eq (slot-value instance-of-foo 'z)
+                     initarg-supplied-for-z))
+      (do-test-error nil "initialization failed")))
+
+  )
+
+(do-test "update-instance-for-different-class"
+         ((:classes foo bar))
+
+  (let ((initform-for-x 'initform-x)
+        (initform-for-y 'initform-y)
+        (default-initarg-for-x 'default-initarg-x)
+        (initform-for-z 'initform-z)
+        (initform-for-u 'initform-u)
+        (initform-for-v 'initform-v)
+        (default-initarg-for-z 'default-intiarg-z)
+        (initarg-supplied-for-v 'initarg-v)
+        instance-of-foo
+        instance-of-bar)
+
+    (defclass foo ()
+         ((x :initform initform-for-x :initarg :x)
+          (y :initform initform-for-y :initarg :y))
+      (:default-initargs :x default-initarg-for-x))
+
+    (defclass bar ()
+         ((x :initform initform-for-x :initarg :x)
+          (y :initform initform-for-y :initarg :y)
+          (z :initform initform-for-z :initarg :z)
+          (u :initform initform-for-u :initarg :u)
+          (v :initform initform-for-v :initarg :v))
+      (:default-initargs :z default-initarg-for-z))
+
+    (setq instance-of-foo (make-instance 'foo))
+    (setq instance-of-bar (allocate-instance (find-class 'bar)))
+    (update-instance-for-different-class instance-of-foo instance-of-bar
+                                         :v initarg-supplied-for-v)
+    (unless (and (not (slot-boundp instance-of-bar 'x))
+                 (not (slot-boundp instance-of-bar 'y))
+                 (eq (slot-value instance-of-bar 'z) initform-for-z)
+                 (eq (slot-value instance-of-bar 'u) initform-for-u)
+                 (eq (slot-value instance-of-bar 'v) initarg-supplied-for-v))
+      (do-test-error nil "initialization failed"))))
+
+(do-test "only needed forms should be evaluated in initializing instances"
+         ((:classes foo))
+
+  (defclass foo ()
+    ((x :initform (do-test-error nil "x initform was evaluated")
+        :initarg :x)
+     (y :initform (do-test-error nil "y initform was evaluated")
+        :initarg :y)
+     (z :initform (do-test-error nil "z initform was evaluated")
+        :initarg :z))
+    (:default-initargs :y 1
+                       :z (do-test-error nil "z default initarg was evaluated")))
+
+  (make-instance 'foo :x 1 :z 1))
+
+
+;;;
+;;; We need to put these class defenitions in top level.
+;;;
+
+(defclass class-for-testing-change-class-1 ()
+  ((x :initform 'x :accessor class-1-x)
+   (y :initform 'y :accessor class-1-y)))
+
+(defclass class-for-testing-change-class-2 ()
+  ((a :initform 'a :accessor class-2-a)
+   (b :initform 'b :accessor class-2-b)))
+
+(do-test "update-instance-for-different-class/change-class"
+         ()
+
+  (defmethod update-instance-for-different-class
+             ((previous class-for-testing-change-class-1)
+              (current class-for-testing-change-class-2)
+              &rest initargs)
+    (declare (ignore initargs))
+    (setf (class-2-a current) (class-1-x previous))
+    (setf (class-2-b current) (class-1-y previous)))
+
+  (let ((f1 (make-instance 'class-for-testing-change-class-1))
+        (f2 (make-instance 'class-for-testing-change-class-1)))
+    (change-class f1 (find-class 'class-for-testing-change-class-2))
+    (unless (and (eq (class-2-a f1) (class-1-x f2))
+                 (eq (class-2-b f1) (class-1-y f2)))
+      (do-test-error nil "change class failed")))
+  )
+
+(cleanup-do-test '((:classes class-for-testing-redefined-class)
+                   (:functions test-x test-y test-a)
+                   (:setf-generic-functions class-x class-y)))
+                    
+(let (foo)
+  (defclass class-for-testing-redefined-class ()
+    ((x :initform 'x :accessor test-x)
+     (y :initform 'y :accessor test-y)))
+
+  (setq foo (make-instance 'class-for-testing-redefined-class))
+
+  (defclass class-for-testing-redefined-class ()
+    ((a :initform 0 :accessor test-a)
+     (y :initform 1 :accessor test-y)))
+
+  (do-test "update-instance-for-redefined-class/make-instances-obsolete(1)"
+        ()
+    (unless (and (eq (test-a foo) 0)
+                 (eq (test-y foo) 'y))
+      (do-test-error nil "default behavior failed"))))
+
+(cleanup-do-test '((:classes x-y-pos)
+                   (:functions pos-x pos-y pos-rho pos-theta)
+                   (:setf-generic-functions pos-x pos-y pos-rho pos-theta)))
+
+(let (old-pos new-pos)
+
+  (defclass x-y-pos ()
+    ((x :initform 3 :accessor pos-x)
+     (y :initform 4 :accessor pos-y)))
+  
+  (setq old-pos (make-instance 'x-y-pos))
+  
+  (defclass x-y-pos ()
+    ((rho :initform 0 :accessor pos-rho)
+     (theta :initform 0 :accessor pos-theta)))
+  
+  (do-test "update-instance-for-redefined-class/make-instances-obsolete(2)"
+        ()
+
+    (defmethod update-instance-for-redefined-class :before
+               ((pos x-y-pos) added deleted plist &key)
+      ;; Transform the x-y coordinates to polar coordinates
+      ;; and store into the new slots
+      (let ((x (getf plist 'x))
+            (y (getf plist 'y)))
+        (setf (pos-rho pos) (sqrt (+ (* x x) (* y y)))
+              (pos-theta pos) (atan y x))))
+
+    (defmethod pos-x ((pos x-y-pos))
+      (with-slots (rho theta) pos (* rho (cos theta))))
+
+    (defmethod (setf pos-x) (new-x (pos x-y-pos))
+      (with-slots (rho theta) pos
+        (let ((y (pos-y pos)))
+          (setq rho (sqrt (+ (* new-x new-x) (* y y)))
+                theta (atan y new-x))
+          new-x)))
+    
+    (defmethod pos-y ((pos x-y-pos))
+      (with-slots (rho theta) pos (* rho (sin theta))))
+  
+    (defmethod (setf pos-y) (new-y (pos x-y-pos))
+      (with-slots (rho theta)
+        (let ((x (pos-x pos)))
+          (setq rho (sqrt (+ (* x x) (* new-y new-y)))
+                theta (atan new-y x))
+          new-y)))
+
+    (unless (and (equalp 5 (pos-rho old-pos))
+                 (equalp (* 5 (cos (atan 4 3))) (pos-x old-pos))
+                 (equalp (* 5 (sin (atan 4 3))) (pos-y old-pos)))
+      (do-test-error nil "specialized behaivior failed"))
+    ))
+
+(cleanup-do-test '((:classes class-for-testing-redefined-class
+                             test-obsolete-class)
+                   (:functions test-x test-y test-a)
+                   (:setf-generic-functions class-x class-y)))
+
+(defclass test-obsolete-class (standard-class) ())
+
+(defmethod check-super-metaclass-compatibility ((x test-obsolete-class)
+                                                (y standard-class))
+  't)
+                    
+(let ((foo 'nil)
+      bar)
+  (defmethod make-instances-obsolete ((x test-obsolete-class))
+    (setq foo 'called)
+    (call-next-method))
+
+  (defclass class-for-testing-redefined-class ()
+    ((x :initform 'x :accessor test-x)
+     (y :initform 'y :accessor test-y))
+    (:metaclass test-obsolete-class))
+
+  (setq bar (make-instance 'class-for-testing-redefined-class))
+
+  (defclass class-for-testing-redefined-class ()
+    ((a :initform 0 :accessor test-a)
+     (y :initform 1 :accessor test-y)))
+
+  (do-test "update-instance-for-redefined-class/make-instances-obsolete(3)"
+        ()
+    (unless (and (eq (test-a bar) 0)
+                 (eq (test-y bar) '1)
+                 (eq foo 'called))
+      (do-test-error nil "imcompatible class change failed"))))
+
+(cleanup-do-test '((:classes class-for-testing-redefined-class)
+                   (:functions test-x test-y test-a)
+                   (:setf-generic-functions class-x class-y)))
+                    
+(let (foo)
+  (defclass class-for-testing-redefined-class ()
+    ((x :initform 'x :accessor test-x)
+     (y :initform 'y :accessor test-y)))
+
+  (setq foo (make-instance 'class-for-testing-redefined-class))
+
+  (make-instances-obsolete 'class-for-testing-redefined-class)
+  
+  (do-test "update-instance-for-redefined-class/make-instances-obsolete(4)"
+        ()
+    (unless (and (eq (test-x foo) 'x)
+                 (eq (test-y foo) 'y))
+      (do-test-error nil "call make-instances-obsolete by hand failed"))))
+
+(do-test "slot-mumble functions"
+         ((:variables foo1 bar1)
+          (:classes foo bar))
+
+  (defclass foo-sm ()
+    ((x :initform 'x :allocation :class)
+     (y :initform 'y)
+     (z :allocation :class)
+     (u)))
+
+  (defclass bar-sm ()
+    ((x :initform 'x :allocation :class)
+     (y :initform 'y)
+     (z :allocation :class)
+     (u))
+    (:metaclass funcallable-standard-class))
+
+  (defmethod slot-missing ((class standard-class)
+                           (instance foo-sm)
+                           slot-name operation &optional new-value)
+    (list* class instance slot-name operation new-value))
+  
+  (defmethod slot-missing ((class standard-class)
+                           (instance bar-sm)
+                           slot-name operation &optional new-value)
+    (list* class instance slot-name operation new-value))
+
+  (defmethod slot-unbound ((class standard-class)
+                           (instance foo-sm)
+                           slot-name)
+    (list class instance slot-name))
+  
+  (defmethod slot-unbound ((class funcallable-standard-class)
+                           (instance bar-sm)
+                           slot-name)
+    (list class instance slot-name))
+  
+  (setq foo1 (make-instance 'foo-sm))
+  (setq bar1 (make-instance 'bar-sm))
+
+  (flet ((test1 (instance)
+           (and (eq (slot-value instance 'x) 'x)
+                (eq (slot-value instance 'y) 'y)
+                (equal (slot-value instance 'z)
+                       (list (class-of instance) instance 'z))
+                (equal (slot-value instance 'u)
+                       (list (class-of instance) instance 'u))
+                (slot-boundp instance 'x)
+                (slot-boundp instance 'y)
+                (not (slot-boundp instance 'z))
+                (not (slot-boundp instance 'u))))
+         (test2 (instance)
+           (and (not (slot-boundp instance 'x))
+                (not (slot-boundp instance 'y))
+                (slot-boundp instance 'z)
+                (slot-boundp instance 'u)
+                (equal (slot-value instance 'x)
+                       (list (class-of instance) instance 'x))
+                (equal (slot-value instance 'y)
+                       (list (class-of instance) instance 'y))
+                (eq (slot-value instance 'z) 'z)
+                (eq (slot-value instance 'u) 'u)))
+         (test3 (instance)
+           (and (slot-exists-p instance 'x)
+                (slot-exists-p instance 'y)))
+         (test4 (instance)
+           (and (equal (slot-value instance 'a)
+                       (list (class-of instance)
+                             instance
+                             'a
+                             'slot-value))
+                (equal (setf (slot-value instance 'a) 'b)
+                       (list* (class-of instance)
+                              instance
+                              'a
+                              'setf
+                              'b))
+                (equal (slot-boundp instance 'a)
+                       (list (class-of instance)
+                             instance
+                             'a
+                             'slot-boundp))
+
+                (equal (slot-makunbound instance 'a)
+                       (list (class-of instance)
+                             instance
+                             'a
+                             'slot-makunbound)))))
+
+        (unless (and (test1 foo1)
+                     (test1 bar1))
+          (do-test-error nil "slot functions test1 failed"))
+
+        (slot-makunbound foo1 'x)
+        (slot-makunbound foo1 'y)
+        (setf (slot-value foo1 'z) 'z)
+        (setf (slot-value foo1 'u) 'u)
+        (slot-makunbound bar1 'x)
+        (slot-makunbound bar1 'y)
+        (setf (slot-value bar1 'z) 'z)
+        (setf (slot-value bar1 'u) 'u)
+
+        (unless (and (test2 foo1)
+                     (test2 bar1))
+          (do-test-error nil "slot functions test2 failed"))
+
+        (unless (and (test3 foo1)
+                     (test3 bar1))
+          (do-test-error nil "slot functions test3 failed"))
+        
+        (unless (and (test4 foo1)
+                     (test4 bar1))
+          (do-test-error nil "slot function test4 failed"))
+        ))
+
+
+(cleanup-do-test '((:classes foo-sm bar-sm)
+                   (:functions foo-x foo-y bar-x bar-y)))
+
+(defclass foo ()
+  ((x :initform 'x :allocation :class :reader foo-x)
+   (y :initform 'y :reader foo-y)))
+
+(defclass bar ()
+  ((x :allocation :class :reader bar-x)
+   (y :reader bar-y)))
+
+(do-test "slot-value/slot-unbound for pv optimization case and :reader method"
+         ((:functions get-foo-x get-foo-y get-x-1 get-y-1
+                      get-bar-x get-bar-y get-x-2 get-y-2)
+          (:variables foo1 bar1))
+
+  (defmethod get-foo-x ((foo1 foo))
+    (slot-value foo1 'x))
+  (defmethod get-foo-y ((foo1 foo))
+    (slot-value foo1 'y))
+
+  (defun get-x-1 (foo1)
+    (slot-value foo1 'x))
+  (defun get-y-1 (foo1)
+    (slot-value foo1 'y))
+
+  (defmethod slot-unbound ((class standard-class) (instance foo) slot-name)
+    (list class instance slot-name))
+  
+  (setq foo1 (make-instance 'foo))
+  
+  (unless (and (eq (get-foo-x foo1) 'x)
+               (eq (get-foo-y foo1) 'y)
+               (eq (get-x-1 foo1) 'x)
+               (eq (get-y-1 foo1) 'y)
+               (eq (foo-x foo1) 'x)
+               (eq (foo-y foo1) 'y))
+    (do-test-error nil "slot-value failed"))
+
+  (unless (and (eq (slot-makunbound foo1 'x) foo1)
+               (eq (slot-makunbound foo1 'y) foo1))
+    (do-test-error nil "slot-makunbound returns wrong value"))
+
+  (unless (and (equal (get-foo-x foo1)
+                      (list (find-class 'foo) foo1 'x))
+               (equal (get-foo-y foo1)
+                      (list (find-class 'foo) foo1 'y))
+               (equal (get-x-1 foo1)
+                      (list (find-class 'foo) foo1 'x))
+               (equal (get-y-1 foo1)
+                      (list (find-class 'foo) foo1 'y))
+               (equal (foo-x foo1)
+                      (list (find-class 'foo) foo1 'x))
+               (equal (foo-y foo1)
+                      (list (find-class 'foo) foo1 'y)))
+    (do-test-error nil "slot-value/slot-unbound failed"))
+
+  (defmethod get-bar-x ((bar1 bar))
+    (slot-value bar1 'x))
+  (defmethod get-bar-y ((bar1 bar))
+    (slot-value bar1 'y))
+
+  (defun get-x-2 (bar1)
+    (slot-value bar1 'x))
+  (defun get-y-2 (bar1)
+    (slot-value bar1 'y))
+
+  (defmethod slot-unbound ((class standard-class) (instance bar) slot-name)
+    (list class instance slot-name))
+
+  (setq bar1 (make-instance 'bar))
+
+  (unless (and (equal (get-bar-x bar1)
+                      (list (find-class 'bar) bar1 'x))
+               (equal (get-bar-y bar1)
+                      (list (find-class 'bar) bar1 'y))
+               (equal (get-x-2 bar1)
+                      (list (find-class 'bar) bar1 'x))
+               (equal (get-y-2 bar1)
+                      (list (find-class 'bar) bar1 'y))
+               (equal (bar-x bar1)
+                      (list (find-class 'bar) bar1 'x))
+               (equal (bar-y bar1)
+                      (list (find-class 'bar) bar1 'y)))
+    (do-test-error nil "slot-value/slot-unbound failed")))
+
+  
+(do-test "defmethod/call-next-method/&aux variable"
+         ((:variables foo1 bar1)
+          (:classes foo bar)
+          (:functions test1 test2 test3))
+
+  (defclass foo ()
+    ((x :initform 0)
+     (y :initform 1)))
+
+  (defclass bar (foo) ())
+
+  (defmethod test1 ((foo1 foo) &aux aux-arg)
+    (setq aux-arg (list foo1)))
+
+  (defmethod test1 ((bar1 bar) &aux aux-arg)
+    (setq aux-arg (list (list bar1)))
+    (call-next-method)
+    aux-arg)
+
+  (setq foo1 (make-instance 'foo))
+  (setq bar1 (make-instance 'bar))
+  (unless (and (equal (test1 foo1) (list foo1))
+               (equal (test1 bar1) (list (list bar1))))
+    (do-test-error nil "defmethod with call-next-method and &aux failed")))
+
+;;;
+;;; defconstructor tests
+;;;
+(format t
+        "~%Testing defconstructor [methods, default/initform, slot-filling]")
+
+(defun check-slots (object &rest names-and-values)
+  (doplist (name value) names-and-values
+    (unless (if (eq value :unbound)
+                (not (slot-boundp object name))
+                (and (slot-boundp object name)
+                     (eq (slot-value object name) value)))
+      (return-from check-slots nil)))
+  't)
+
+;;;
+;;; [methods, default/initform, slot-filling]
+;;; methods:           [nil, :after, t]
+;;; default/initform:  [nil, :constant, t]
+;;; slot-filling:      [:instance, :class]
+;;;
+;;; supplied:          [nil, :constant, t]
+
+
+(cleanup-do-test '((:classes foo1 foo2 foo3 foo4
+                             foo5 foo6 foo7 foo8
+                             foo9 foo10 foo11 foo12)
+                   (:variables *a-initform* *b-initform* *c-initform*
+                               *a-default* *b-default* *c-default*
+                               *a-supplied* *b-supplied* *c-supplied*)
+                   (:functions foo1-test1 foo1-test2 foo1-test3
+                               foo2-test1 foo2-test2 foo2-test3
+                               foo3-test1 foo3-test2 foo3-test3
+                               foo4-test1 foo4-test2 foo4-test3
+                               foo5-test1 foo5-test2 foo5-test3
+                               foo6-test1 foo6-test2 foo6-test3
+                               foo7-test1 foo7-test2 foo7-test3
+                               foo8-test1 foo8-test2 foo8-test3
+                               foo9-test1 foo9-test2 foo9-test3
+                               foo10-test1 foo10-test2 foo10-test3
+                               foo11-test1 foo11-test2 foo11-test3
+                               foo12-test1 foo12-test2 foo12-test3)))
+
+(defvar *a-initform* 'a-initform)
+(defvar *b-initform* 'b-initform)
+(defvar *c-initform* 'c-initform)
+(defvar *a-default* 'a-default)
+(defvar *b-default* 'b-default)
+(defvar *c-default* 'c-default)
+(defvar *a-supplied* 'a-supplied)
+(defvar *b-supplied* 'b-supplied)
+(defvar *c-supplied* 'c-supplied)
+
+;;;
+;;; foo1
+;;; [methods, default/initform, slot-filing]
+;;; (t,       t,                :class)
+
+(defclass foo1 ()
+    ((a :initarg :a :initform *a-initform*)
+     (b :initarg :b :initform *b-initform*)
+     (c :initarg :c :allocation :class :initform *c-initform*))
+  (:default-initargs :b *b-default* :c *c-default*))
+
+(defmethod *initialize-instance :before ((instance foo1) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (t,       t,                :class) (1)"
+         ((:functions foo1-test1 foo1-test2 foo1-test3))
+
+  (defconstructor foo1-test1 foo1 ())
+  (defconstructor foo1-test2 foo1 () :a 1 :b 2 :c 3)
+  (defconstructor foo1-test3 foo1 (a b c) :a a :b b :c c)
+
+  (dotimes (i 2)                                ;Do it twice to be sure that
+                                                ;the constructor works more
+                                                ;than just the first time.
+    (unless (check-slots (foo1-test1)
+                         'a *a-initform*
+                         'b *b-default*
+                         'c *c-default*)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo1-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo1-test3 *a-supplied* *b-supplied* *c-supplied*)
+                         'a *a-supplied*
+                         'b *b-supplied*
+                         'c *c-supplied*)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+;;;
+;;; foo2
+;;; [methods, default/initform, slot-filling]
+;;; (t,       t,                :class)
+
+(defclass foo2 ()
+    ((a :initform *a-initform* :initarg :a)
+     (b :initform *b-initform* :initarg :b)
+     (c :allocation :class :initform *c-initform* :initarg :c))
+  (:default-initargs :b *b-default*))
+
+(defmethod *initialize-instance :before ((instance foo2) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (t,       t,                :class) (2)"
+         ((:functions foo2-test1 foo2-test2 foo2-test3))
+
+  (defconstructor foo2-test1 foo2 ())
+  (defconstructor foo2-test2 foo2 () :a 1 :b 2 :c 3)
+  (defconstructor foo2-test3 foo2 (a b c) :a a
+                                          :b b
+                                          :c c)
+  
+  (dotimes (i 2)
+    (unless (check-slots (foo2-test1) 'a *a-initform*
+                                      'b *b-default*
+                                      'c *c-initform*)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo2-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo2-test3 *a-supplied* *b-supplied* *c-supplied*)
+                         'a *a-supplied*
+                         'b *b-supplied*
+                         'c *c-supplied*)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; foo3
+;;; [methods, default/initform, slot-filling]
+;;; (t,       t,                :instance)
+
+(defclass foo3 ()
+    ((a :initform *a-initform* :initarg :a)
+     (b :initform *b-initform* :initarg :b)
+     (c :allocation :class :initform *c-initform*))
+  (:default-initargs :b *b-default*))
+
+(defmethod *initialize-instance :before ((instance foo3) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (t,       t,                :instance) (1)"
+         ((:functions foo3-test1 foo3-test2 foo3-test3))
+
+  (defconstructor foo3-test1 foo3 ())
+  (defconstructor foo3-test2 foo3 () :a 1 :b 2)
+  (defconstructor foo3-test3 foo3 (a b) :a a :b b)
+  
+  
+  (dotimes (i 2)
+    (unless (check-slots (foo3-test1) 'a *a-initform*
+                                      'b *b-default*
+                                      'c *c-initform*)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo3-test2) 'a '1 'b '2 'c *c-initform*)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo3-test3 *a-supplied* *b-supplied*)
+                         'a *a-supplied*
+                         'b *b-supplied*
+                         'c *c-initform*)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; foo4
+;;; [methods, default/initform, slot-filling]
+;;; (t,       t,                :instance)
+
+(defclass foo4 ()
+    ((a :initform *a-initform* :initarg :a)
+     (b :initform *b-initform* :initarg :b)
+     (c :allocation :class))
+  (:default-initargs :b *b-default*))
+
+(defmethod *initialize-instance :before ((instance foo4) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (t,       t,                :instance) (2)"
+         ((:functions foo4-test1 foo4-test2 foo4-test3))
+
+  (defconstructor foo4-test1 foo4 ())
+  (defconstructor foo4-test2 foo4 () :a 1 :b 2)
+  (defconstructor foo4-test3 foo4 (a b) :a a :b b)
+
+  (dotimes (i 2)
+    (unless (check-slots (foo4-test1) 'a *a-initform*
+                                      'b *b-default*
+                                      'c :unbound)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo4-test2) 'a '1 'b '2 'c :unbound)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo4-test3 *a-supplied* *b-supplied*)
+                         'a *a-supplied*
+                         'b *b-supplied*
+                         'c :unbound)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; foo5
+;;; [methods, default/initform, slot-filling]
+;;; (:after,  t,                :class)
+
+(defclass foo5 ()
+    ((a :initarg :a :initform *a-initform*)
+     (b :initarg :b :initform *b-initform*)
+     (c :initarg :c :allocation :class :initform *c-initform*))
+  (:default-initargs :b *b-default* :c *c-default*))
+
+(defmethod *initialize-instance :after ((instance foo5) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (:after,  t,                :class) (1)"
+         ((:functions foo5-test1 foo5-test2 foo5-test3))
+
+  (defconstructor foo5-test1 foo5 ())
+  (defconstructor foo5-test2 foo5 () :a 1 :b 2 :c 3)
+  (defconstructor foo5-test3 foo5 (a b c) :a a
+                                          :b b
+                                          :c c)
+
+  (dotimes (i 2)
+    (unless (check-slots (foo5-test1) 'a *a-initform*
+                                      'b *b-default*
+                                      'c *c-default*)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo5-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo5-test3 *a-supplied* *b-supplied* *c-supplied*)
+                         'a *a-supplied*
+                         'b *b-supplied*
+                         'c *c-supplied*)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; foo6
+;;; [methods, default/initform, slot-filling]
+;;; (:after,  t,                :class)
+
+(defclass foo6 ()
+    ((a :initform *a-initform* :initarg :a)
+     (b :initform *b-initform* :initarg :b)
+     (c :allocation :class :initform *c-initform* :initarg :c))
+  (:default-initargs :b *b-default*))
+
+(defmethod *initialize-instance :after ((instance foo6) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (:after,  t,                :class) (2)"
+         ((:functions foo6-test1 foo6-test2 foo6-test3))
+
+  (defconstructor foo6-test1 foo6 ())
+  (defconstructor foo6-test2 foo6 () :a 1 :b 2 :c 3)
+  (defconstructor foo6-test3 foo6 (a b c) :a a
+                                          :b b
+                                          :c c)
+  
+  (dotimes (i 2)
+    (unless (check-slots (foo6-test1) 'a *a-initform*
+                                      'b *b-default*
+                                      'c *c-initform*)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo6-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo6-test3 *a-supplied* *b-supplied* *c-supplied*)
+                         'a *a-supplied*
+                         'b *b-supplied*
+                         'c *c-supplied*)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; foo7
+;;; [methods, default/initform, slot-filling]
+;;; (:after,  t,                :instance)
+
+(defclass foo7 ()
+    ((a :initform *a-initform* :initarg :a)
+     (b :initform *b-initform* :initarg :b)
+     (c :allocation :class :initform *c-initform*))
+  (:default-initargs :b *b-default*))
+
+(defmethod *initialize-instance :after ((instance foo7) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (:after,  t,                :instance) (1)"
+         ((:functions foo7-test1 foo7-test2 foo7-test3))
+
+  (defconstructor foo7-test1 foo7 ())
+  (defconstructor foo7-test2 foo7 () :a 1 :b 2)
+  (defconstructor foo7-test3 foo7 (a b) :a a :b b)
+  
+  (dotimes (i 2)
+    (unless (check-slots (foo7-test1) 'a *a-initform*
+                                      'b *b-default*
+                                      'c *c-initform*)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo7-test2) 'a '1 'b '2 'c *c-initform*)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo7-test3 *a-supplied* *b-supplied*)
+                         'a *a-supplied*
+                         'b *b-supplied*
+                         'c *c-initform*)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; foo8
+;;; [methods, default/initform, slot-filling]
+;;; (:after,  t,                :instance)
+
+(defclass foo8 ()
+    ((a :initform *a-initform* :initarg :a)
+     (b :initform *b-initform* :initarg :b)
+     (c :allocation :class))
+  (:default-initargs :b *b-default*))
+
+(defmethod *initialize-instance :after ((instance foo8) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (:after,  t,                :instance) (2)"
+         ((:functions foo8-test1 foo8-test2 foo8-test3))
+
+  (defconstructor foo8-test1 foo8 ())
+  (defconstructor foo8-test2 foo8 () :a 1 :b 2)
+  (defconstructor foo8-test3 foo8 (a b) :a a :b b)
+
+  (dotimes (i 2)
+    (unless (check-slots (foo8-test1) 'a *a-initform*
+                                      'b *b-default*
+                                      'c :unbound)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo8-test2) 'a '1 'b '2 'c :unbound)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo8-test3 *a-supplied* *b-supplied*)
+                         'a *a-supplied*
+                         'b *b-supplied*
+                         'c :unbound)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; foo9
+;;; [methods, default/initform, slot-filling]
+;;; (nil,     t,                :class)
+
+(defclass foo9 ()
+    ((a :initarg :a :initform *a-initform*)
+     (b :initarg :b :initform *b-initform*)
+     (c :initarg :c :allocation :class :initform *c-initform*))
+  (:default-initargs :b *b-default* :c *c-default*))
+
+(do-test "defconstructor (nil,     t,                :class) (1)"
+         ((:functions foo9-test1 foo9-test2 foo9-test3))
+
+  (defconstructor foo9-test1 foo9 ())
+  (defconstructor foo9-test2 foo9 () :a 1 :b 2 :c 3)
+  (defconstructor foo9-test3 foo9 (a b c) :a a
+                                          :b b
+                                          :c c)
+  
+  (dotimes (i 2)
+    (unless (check-slots (foo9-test1) 'a *a-initform*
+                                      'b *b-default*
+                                      'c *c-default*)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo9-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo9-test3 *a-supplied* *b-supplied* *c-supplied*)
+                         'a *a-supplied*
+                         'b *b-supplied*
+                         'c *c-supplied*)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+    
+;;;
+;;; foo10
+;;; [methods, default/initform, slot-filling]
+;;; (nil,     t,                :class)
+
+(defclass foo10 ()
+    ((a :initform *a-initform* :initarg :a)
+     (b :initform *b-initform* :initarg :b)
+     (c :allocation :class :initform *c-initform* :initarg :c))
+  (:default-initargs :b *b-default*))
+
+(do-test "defconstructor (nil,     t,                :class) (2)"
+         ((:functions foo10-test1 foo10-test2 foo10-test3))
+
+  (defconstructor foo10-test1 foo10 ())
+  (defconstructor foo10-test2 foo10 () :a 1 :b 2 :c 3)
+  (defconstructor foo10-test3 foo10 (a b c) :a a
+                                            :b b
+                                            :c c)
+  (dotimes (i 2)
+    (unless (check-slots (foo10-test1) 'a *a-initform*
+                                       'b *b-default*
+                                       'c *c-initform*)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo10-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo10-test3 *a-supplied* *b-supplied* *c-supplied*)
+                         'a *a-supplied*
+                         'b *b-supplied*
+                         'c *c-supplied*)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; foo11
+;;; [methods, default/initform, slot-filling]
+;;; (nil,     t,                :instance)
+
+(defclass foo11 ()
+    ((a :initform *a-initform* :initarg :a)
+     (b :initform *b-initform* :initarg :b)
+     (c :allocation :class :initform *c-initform*))
+  (:default-initargs :b *b-default*))
+
+(do-test "defconstructor (nil,     t,                :instance) (1)"
+         ((:functions foo11-test1 foo11-test2 foo11-test3))
+
+  (defconstructor foo11-test1 foo11 ())
+  (defconstructor foo11-test2 foo11 () :a 1 :b 2)
+  (defconstructor foo11-test3 foo11 (a b) :a a :b b)
+  
+  (dotimes (i 2)
+    (unless (check-slots (foo11-test1) 'a *a-initform*
+                                       'b *b-default*
+                                       'c *c-initform*)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo11-test2) 'a '1 'b '2 'c *c-initform*)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo11-test3 *a-supplied* *b-supplied*)
+                         'a *a-supplied*
+                         'b *b-supplied*
+                         'c *c-initform*)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; foo12
+;;; [methods, default/initform, slot-filling]
+;;; (nil,     t,                :instance)
+
+(defclass foo12 ()
+    ((a :initform *a-initform* :initarg :a)
+     (b :initform *b-initform* :initarg :b)
+     (c :allocation :class))
+  (:default-initargs :b *b-default*))
+
+(defmethod *initialize-instance :after ((instance foo12) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (nil,     t,                :instance) (2)"
+         ((:functions foo12-test1 foo12-test2 foo12-test3))
+
+  (defconstructor foo12-test1 foo12 ())
+  (defconstructor foo12-test2 foo12 () :a 1 :b 2)
+  (defconstructor foo12-test3 foo12 (a b) :a a :b b)
+
+  (dotimes (i 2)
+    (unless (check-slots (foo12-test1) 'a *a-initform*
+                                       'b *b-default*
+                                       'c :unbound)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo12-test2) 'a '1 'b '2 'c :unbound)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (foo12-test3 *a-supplied* *b-supplied*)
+                         'a *a-supplied*
+                         'b *b-supplied*
+                         'c :unbound)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+
+(cleanup-do-test '((:classes bar1 bar2 bar3 bar4
+                             bar5 bar6 bar7 bar8
+                             bar9 bar10 bar11 bar12)
+                   (:functions bar1-test1 bar1-test2 bar1-test3
+                               bar2-test1 bar2-test2 bar2-test3
+                               bar3-test1 bar3-test2 bar3-test3
+                               bar4-test1 bar4-test2 bar4-test3
+                               bar5-test1 bar5-test2 bar5-test3
+                               bar6-test1 bar6-test2 bar6-test3
+                               bar7-test1 bar7-test2 bar7-test3
+                               bar8-test1 bar8-test2 bar8-test3
+                               bar9-test1 bar9-test2 bar9-test3
+                               bar10-test1 bar10-test2 bar10-test3
+                               bar11-test1 bar11-test2 bar11-test3
+                               bar12-test1 bar12-test2 bar12-test3)))
+
+;;;
+;;; bar1
+;;; [methods, default/initform, slot-filling]
+;;; (t,       :constant,        :class)
+
+(defclass bar1 ()
+    ((a :initarg :a :initform 1)
+     (b :initarg :b :initform 2)
+     (c :initarg :c :allocation :class :initform 3))
+  (:default-initargs :b 5 :c 6))
+
+(defmethod *initialize-instance :before ((instance bar1) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (t,       :constant,        :class) (1)"
+         ((:functions bar1-test1 bar1-test2 bar1-test3))
+
+  (defconstructor bar1-test1 bar1 ())
+  (defconstructor bar1-test2 bar1 () :a 1 :b 2 :c 3)
+  (defconstructor bar1-test3 bar1 (a b c) :a a
+                                          :b b
+                                          :c c)
+  
+  (dotimes (i 2)
+    (unless (check-slots (bar1-test1) 'a '1 'b '5 'c '6)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar1-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar1-test3 7 8 9) 'a '7 'b '8 'c '9)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; bar2
+;;; [methods, default/initform, slot-filling]
+;;; (t,       :constant,        :class)
+
+(defclass bar2 ()
+    ((a :initform 1 :initarg :a)
+     (b :initform 2 :initarg :b)
+     (c :allocation :class :initform 3 :initarg :c))
+  (:default-initargs :b 5))
+
+(defmethod *initialize-instance :before ((instance bar2) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (t,       :constant,        :class) (2)"
+         ((:functions bar2-test1 bar2-test2 bar2-test3))
+
+  (defconstructor bar2-test1 bar2 ())
+  (defconstructor bar2-test2 bar2 () :a 1 :b 2 :c 3)
+  (defconstructor bar2-test3 bar2 (a b c) :a a
+                                          :b b
+                                          :c c)
+  
+  (dotimes (i 2)
+    (unless (check-slots (bar2-test1) 'a '1 'b '5 'c '3)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar2-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar2-test3 7 8 9) 'a '7 'b '8 'c '9)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; bar3
+;;; [methods, default/initform, slot-filling]
+;;; (t,       :constant,        :instance)
+
+(defclass bar3 ()
+    ((a :initform 1 :initarg :a)
+     (b :initform 2 :initarg :b)
+     (c :allocation :class :initform 3))
+  (:default-initargs :b 5))
+
+(defmethod *initialize-instance :before ((instance bar3) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (t,       :constant,        :instance) (1)"
+         ((:functions bar3-test1 bar3-test2 bar3-test3))
+
+  (defconstructor bar3-test1 bar3 ())
+  (defconstructor bar3-test2 bar3 () :a 1 :b 2)
+  (defconstructor bar3-test3 bar3 (a b) :a a :b b)
+  
+  (dotimes (i 2)
+    (unless (check-slots (bar3-test1) 'a '1 'b '5 'c '3)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar3-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar3-test3 7 8) 'a '7 'b '8 'c '3)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; bar4
+;;; [methods, default/initform, slot-filling]
+;;; (t,       :constant,        :instance)
+
+(defclass bar4 ()
+    ((a :initform 1 :initarg :a)
+     (b :initform 2 :initarg :b)
+     (c :allocation :class))
+  (:default-initargs :b 5))
+
+(defmethod *initialize-instance :before ((instance bar4) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (t,       :constant,        :instance) (2)"
+         ((:functions bar4-test1 bar4-test2 bar4-test3))
+
+  (defconstructor bar4-test1 bar4 ())
+  (defconstructor bar4-test2 bar4 () :a 1 :b 2)
+  (defconstructor bar4-test3 bar4 (a b) :a a :b b)
+
+  (dotimes (i 2)
+    (unless (check-slots (bar4-test1) 'a '1 'b '5 'c :unbound)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar4-test2) 'a '1 'b '2 'c :unbound)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar4-test3 7 8) 'a '7 'b '8 'c :unbound)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; bar5
+;;; [methods, default/initform, slot-filling]
+;;; (:after,  :constant,        :class)
+
+(defclass bar5 ()
+    ((a :initarg :a :initform 1)
+     (b :initarg :b :initform 2)
+     (c :initarg :c :allocation :class :initform 3))
+  (:default-initargs :b 5 :c 6))
+
+(defmethod *initialize-instance :after ((instance bar5) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (:after,  :constant,        :class) (1)"
+         ((:functions bar5-test1 bar5-test2 bar5-test3))
+
+  (defconstructor bar5-test1 bar5 ())
+  (defconstructor bar5-test2 bar5 () :a 1 :b 2 :c 3)
+  (defconstructor bar5-test3 bar5 (a b c) :a a
+                                          :b b
+                                          :c c)
+  
+  (dotimes (i 2)
+    (unless (check-slots (bar5-test1) 'a '1 'b '5 'c '6)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar5-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar5-test3 7 8 9) 'a '7 'b '8 'c '9)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; bar6
+;;; [methods, default/initform, slot-filling]
+;;; (:after,  :constant,        :class)
+
+(defclass bar6 ()
+    ((a :initform 1 :initarg :a)
+     (b :initform 2 :initarg :b)
+     (c :allocation :class :initform 3 :initarg :c))
+  (:default-initargs :b 5))
+
+(defmethod *initialize-instance :after ((instance bar6) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (:after,  :constant,        :class) (2)"
+         ((:functions bar6-test1 bar6-test2 bar6-test3))
+
+  (defconstructor bar6-test1 bar6 ())
+  (defconstructor bar6-test2 bar6 () :a 1 :b 2 :c 3)
+  (defconstructor bar6-test3 bar6 (a b c) :a a
+                                          :b b
+                                          :c c)
+  
+  (dotimes (i 2)
+    (unless (check-slots (bar6-test1) 'a '1 'b '5 'c '3)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar6-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar6-test3 7 8 9) 'a '7 'b '8 'c '9)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; bar7
+;;; [methods, default/initform, slot-filling]
+;;; (:after,  :constant,        :instance)
+
+(defclass bar7 ()
+    ((a :initform 1 :initarg :a)
+     (b :initform 2 :initarg :b)
+     (c :allocation :class :initform 3))
+  (:default-initargs :b 5))
+
+(defmethod *initialize-instance :after ((instance bar7) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (:after,  :constant,        :instance) (1)"
+         ((:functions bar7-test1 bar7-test2 bar7-test3))
+
+  (defconstructor bar7-test1 bar7 ())
+  (defconstructor bar7-test2 bar7 () :a 1 :b 2)
+  (defconstructor bar7-test3 bar7 (a b) :a a :b b)
+  
+  (dotimes (i 2)
+    (unless (check-slots (bar7-test1) 'a '1 'b '5 'c '3)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar7-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar7-test3 7 8) 'a '7 'b '8 'c '3)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; bar8
+;;; [methods, default/initform, slot-filling]
+;;; (:after,  :constant,        :instance)
+
+(defclass bar8 ()
+    ((a :initform 1 :initarg :a)
+     (b :initform 2 :initarg :b)
+     (c :allocation :class))
+  (:default-initargs :b 5))
+
+(defmethod *initialize-instance :after ((instance bar8) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (:after,  :constant,        :instance) (2)"
+         ((:functions bar8-test1 bar8-test2 bar8-test3))
+
+  (defconstructor bar8-test1 bar8 ())
+  (defconstructor bar8-test2 bar8 () :a 1 :b 2)
+  (defconstructor bar8-test3 bar8 (a b) :a a :b b)
+
+  (dotimes (i 2)
+    (unless (check-slots (bar8-test1) 'a '1 'b '5 'c :unbound)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar8-test2) 'a '1 'b '2 'c :unbound)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar8-test3 7 8) 'a '7 'b '8 'c :unbound)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; bar9
+;;; [methods, default/initform, slot-filling]
+;;; (nil,     :constant,        :class)
+
+(defclass bar9 ()
+    ((a :initarg :a :initform 1)
+     (b :initarg :b :initform 2)
+     (c :initarg :c :allocation :class :initform 3))
+  (:default-initargs :b 5 :c 6))
+
+(do-test "defconstructor (nil,     :constant,        :class) (1)"
+         ((:functions bar9-test1 bar9-test2 bar9-test3))
+
+  (defconstructor bar9-test1 bar9 ())
+  (defconstructor bar9-test2 bar9 () :a 1 :b 2 :c 3)
+  (defconstructor bar9-test3 bar9 (a b c) :a a
+                                          :b b
+                                          :c c)
+  
+  (dotimes (i 2)
+    (unless (check-slots (bar9-test1) 'a '1 'b '5 'c '6)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar9-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar9-test3 7 8 9) 'a '7 'b '8 'c '9)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; bar10
+;;; [methods, default/initform, slot-filling]
+;;; (nil,     :constant,        :class)
+
+(defclass bar10 ()
+    ((a :initform 1 :initarg :a)
+     (b :initform 2 :initarg :b)
+     (c :allocation :class :initform 3 :initarg :c))
+  (:default-initargs :b 5))
+
+(do-test "defconstructor (nil,     :constant,        :class) (2)"
+         ((:functions bar10-test1 bar10-test2 bar10-test3))
+
+  (defconstructor bar10-test1 bar10 ())
+  (defconstructor bar10-test2 bar10 () :a 1 :b 2 :c 3)
+  (defconstructor bar10-test3 bar10 (a b c) :a a
+                                          :b b
+                                          :c c)
+  
+  (dotimes (i 2)
+    (unless (check-slots (bar10-test1) 'a '1 'b '5 'c '3)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar10-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar10-test3 7 8 9) 'a '7 'b '8 'c '9)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; bar11
+;;; [methods, default/initform, slot-filling]
+;;; (nil,     :constant,        :instance)
+
+(defclass bar11 ()
+    ((a :initform 1 :initarg :a)
+     (b :initform 2 :initarg :b)
+     (c :allocation :class :initform 3))
+  (:default-initargs :b 5))
+
+(do-test "defconstructor (nil,     :constant,        :instance) (1)"
+         ((:functions bar11-test1 bar11-test2 bar11-test3))
+
+  (defconstructor bar11-test1 bar11 ())
+  (defconstructor bar11-test2 bar11 () :a 1 :b 2)
+  (defconstructor bar11-test3 bar11 (a b) :a a :b b)
+  
+  (dotimes (i 2)
+    (unless (check-slots (bar11-test1) 'a '1 'b '5 'c '3)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar11-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar11-test3 7 8) 'a '7 'b '8 'c '3)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; bar12
+;;; [methods, default/initform, slot-filling]
+;;; (nil,     :constant,        :instance)
+
+(defclass bar12 ()
+    ((a :initform 1 :initarg :a)
+     (b :initform 2 :initarg :b)
+     (c :allocation :class))
+  (:default-initargs :b 5))
+
+(defmethod *initialize-instance :after ((instance bar12) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (nil,     :constant,        :instance) (2)"
+         ((:functions bar12-test1 bar12-test2 bar12-test3))
+
+  (defconstructor bar12-test1 bar12 ())
+  (defconstructor bar12-test2 bar12 () :a 1 :b 2)
+  (defconstructor bar12-test3 bar12 (a b) :a a :b b)
+
+  (dotimes (i 2)
+    (unless (check-slots (bar12-test1) 'a '1 'b '5 'c :unbound)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar12-test2) 'a '1 'b '2 'c :unbound)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (bar12-test3 7 8) 'a '7 'b '8 'c :unbound)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+
+(cleanup-do-test '((:classes baz1 baz2 baz3)
+                   (:functions baz1-test1 baz1-test2 baz1-test3
+                               baz2-test1 baz2-test2 baz2-test3
+                               baz3-test1 baz3-test2 baz3-test3)))
+
+;;;
+;;; baz1
+;;; [methods, default/initform, slot-filling]
+;;; (t,       nil,              :class)
+
+(defclass baz1 ()
+    ((a :initarg :a)
+     (b :initarg :b)
+     (c :initarg :c :allocation :class)))
+
+(defmethod *initialize-instance :before ((instance baz1) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (t,       nil,              :class) (1)"
+         ((:functions baz1-test1 baz1-test2 baz1-test3))
+
+  (defconstructor baz1-test1 baz1 ())
+  (defconstructor baz1-test2 baz1 () :a 1 :b 2 :c 3)
+  (defconstructor baz1-test3 baz1 (a b c) :a a
+                                          :b b
+                                          :c c)
+  
+  (dotimes (i 2)
+    (unless (check-slots (baz1-test1) 'a :unbound 'b :unbound 'c :unbound)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (baz1-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (baz1-test3 7 8 9) 'a '7 'b '8 'c '9)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; baz2
+;;; [methods, default/initform, slot-filling]
+;;; (:after,  nil,              :class)
+
+(defclass baz2 ()
+    ((a :initarg :a)
+     (b :initarg :b)
+     (c :initarg :c :allocation :class)))
+
+(defmethod *initialize-instance :after ((instance baz2) &rest ignore)
+  (declare (ignore ignore))
+  ())
+
+(do-test "defconstructor (:after,  nil,              :class) (1)"
+         ((:functions baz2-test1 baz2-test2 baz2-test3))
+
+  (defconstructor baz2-test1 baz2 ())
+  (defconstructor baz2-test2 baz2 () :a 1 :b 2 :c 3)
+  (defconstructor baz2-test3 baz2 (a b c) :a a
+                                          :b b
+                                          :c c)
+  
+  (dotimes (i 2)
+    (unless (check-slots (baz2-test1) 'a :unbound 'b :unbound 'c :unbound)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (baz2-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (baz2-test3 7 8 9) 'a '7 'b '8 'c '9)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+;;;
+;;; baz3
+;;; [methods, default/initform, slot-filling]
+;;; (nil,     nil,              :class)
+
+(defclass baz3 ()
+    ((a :initarg :a)
+     (b :initarg :b)
+     (c :initarg :c :allocation :class)))
+
+(do-test "defconstructor (nil,     nil,              :class) (1)"
+         ((:functions baz3-test1 baz3-test2 baz3-test3))
+
+  (defconstructor baz3-test1 baz3 ())
+  (defconstructor baz3-test2 baz3 () :a 1 :b 2 :c 3)
+  (defconstructor baz3-test3 baz3 (a b c) :a a
+                                          :b b
+                                          :c c)
+  
+  (dotimes (i 2)
+    (unless (check-slots (baz3-test1) 'a :unbound 'b :unbound 'c :unbound)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (baz3-test2) 'a '1 'b '2 'c '3)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (baz3-test3 7 8 9) 'a '7 'b '8 'c '9)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+
+(cleanup-do-test '((:classes foo bar)
+                   (:functions make-bar-1 make-bar-2 make-bar-3)))
+
+(setq *foo-a* 'foo-a
+      *foo-b* 'foo-b
+      *foo-c* 'foo-c
+      *bar-a* 'bar-a
+      *bar-b* 'bar-b
+      *bar-c* 'bar-c
+      *supplied-a* 'a
+      *supplied-b* 'b
+      *supplied-c* 'c)
+
+(defclass foo ()
+    ((a :initarg :a)
+     (b :initarg :b)
+     (c :initarg :c))
+  (:default-initargs :a *foo-a* :b *foo-b* :c *foo-c*))
+
+(defclass bar (foo)
+    ((c :initarg :a))
+  (:default-initargs :a *bar-a* :c *bar-c*))
+
+(defconstructor make-bar-1 bar ())
+(defconstructor make-bar-2 bar () :a 1 :b 2 :c 3)
+(defconstructor make-bar-3 bar (a b c) :a a :b b :c c)
+
+(do-test "defconstructor/shadowing"
+         ()
+
+  (dotimes (i 2)
+    (unless (check-slots (make-bar-1) 'a *bar-a* 'b *foo-b* 'c *bar-a*)
+      (do-test-error nil "no initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (make-bar-2) 'a '1 'b '2 'c '1)
+      (do-test-error nil "constant initargs failed (~D time)" i)))
+
+  (dotimes (i 2)
+    (unless (check-slots (make-bar-3 *supplied-a* *supplied-b* *supplied-c*)
+                         'a  *supplied-a* 'b *supplied-b* 'c *supplied-a*)
+      (do-test-error nil "non constant initargs failed (~D time)" i))))
+
+
+(do-test "defconstructor/only needed forms should be evaluated"
+         ((:classes foo)
+          (:functions make-foo-1 make-foo-2))
+
+  (defclass foo ()
+      ((x :initform (do-test-error nil "foo x initform was evaluated")
+          :initarg :x)
+       (y :initform (do-test-error nil "foo y initform was evaluated")
+          :initarg :y)
+       (z :initform (do-test-error nil "foo z initform was evaluated")
+          :initarg :z))
+    (:default-initargs :y 2
+                       :z (do-test-error
+                            nil
+                            "z default was evaluated")))
+
+  (defconstructor make-foo-1 foo () :x 1 :z 3)
+  (defconstructor make-foo-2 foo (x z) :x x :z z)
+
+  (make-foo-1)
+  (make-foo-1)
+  (make-foo-2 'x 'z)
+  (make-foo-2 'x 'z))
+
+(do-test "defconstructor/shadowing/only needed forms should be evaluated"
+         ((:classes foo bar)
+          (:functions make-bar-4 make-bar-5))
+
+  (defclass foo ()
+      ((x :initform (do-test-error nil "foo x initform was evaluated")
+          :initarg :x)
+       (y :initform (do-test-error nil "foo y initform was evaluated")
+          :initarg :y)
+       (z :initform (do-test-error nil "foo z initform was evaluated")
+          :initarg :z))
+    (:default-initargs :x (do-test-error
+                            nil
+                            "foo z default was evaluated")
+                       :y (do-test-error
+                            nil
+                            "foo y default was evaluated")
+                       :z (do-test-error
+                            nil
+                            "foo z default was evaluated")))
+  (defclass bar (foo)
+      ((x :initform (do-test-error nil "bar x initform was evaluated"))
+       (y :initform (do-test-error nil "bar y initform was evaluated"))
+       (z :initform (do-test-error nil "bar z initform was evaluated")))
+    (:default-initargs :y 2
+                       :z (do-test-error
+                            nil
+                            "bar z default was evaluated")))
+
+  (defconstructor make-bar-4 bar () :x 1 :z 3)
+  (defconstructor make-bar-5 bar (x z) :x x :z z)
+
+  (make-bar-4)
+  (make-bar-4)
+  (make-bar-5 'x 'z)
+  (make-bar-5 'x 'z))
+
+;;;
+;;; 11/1 test to make sure reader/writer call slot-value-using-class
+;;;
+;;; **********************************************************************
+;;; This test codes will have to change in each of the next releases
+;;; **********************************************************************
+;;;
+(cleanup-do-test '((:classes test-deoptimized-slot-access-class
+                             test-deoptimized-slot-access)
+                   (:functions test-a test-b test-c)
+                   (:setf-generic-functions test-a test-b)))
+
+(defclass test-deoptimized-slot-access-class (standard-class) ())
+
+(defmethod check-super-metaclass-compatibility
+    ((x test-deoptimized-slot-access-class) (y standard-class))
+  't)
+
+(defmethod all-std-class-reader-miss-1
+    ((class test-deoptimized-slot-access-class) wrapper slot-name)
+  (declare (ignore wrapper slot-name))
+  ())
+
+(defmethod lookup-pv-miss-1
+    ((class test-deoptimized-slot-access-class) slots pv)
+  (let ((pv (call-next-method)))
+    (make-list (length pv) :initial-element nil)))
+
+
+(defclass test-deoptimized-slot-access ()
+    ((a :initform 'a :accessor test-a)
+     (b :initform 'b :accessor test-b))
+  (:metaclass test-deoptimized-slot-access-class))
+
+(defmethod test-c ((o test-deoptimized-slot-access))
+  (list (slot-value o 'a) (slot-value o 'b)))
+
+(let ((called-p 'nil)
+      instance)
+  (defmethod slot-value-using-class ((class test-deoptimized-slot-access-class)
+                                     object
+                                     slot-name)
+    (setq called-p 'read)
+    (call-next-method))
+
+  (defmethod (setf slot-value-using-class)
+      (nv (class test-deoptimized-slot-access-class) object slot-name)
+    (setq called-p 'written)
+    (call-next-method))
+
+  (setq instance (make-instance 'test-deoptimized-slot-access))
+  
+  (do-test "deoptimized slot access should call slot-value-using-class"
+        ()
+    (unless (and (eq (test-a instance) 'a)
+                 (eq called-p 'read))
+      (do-test-error nil "reader doesn't call slot-value-using-class"))
+
+    (setq called-p 'nil)
+    (setf (test-b instance) 'c)
+    (unless (eq called-p 'written)
+      (do-test-error nil "writer doesn't call slot-value-using-class"))
+
+    (setq called-p 'nil)
+    (unless (and (equal (test-c instance) '(a c))
+                 (eq called-p 'read))
+      (do-test-error nil "slot-value doesn't call slot-value-using-class"))))
+
+;;;
+;;; 5/3/89 eql specializers tests
+;;; 
+
+(cleanup-do-test '((:classes foo bar)))
+(defclass foo () ())
+(defclass bar (foo) ())
+
+(do-test "eql specializers(eql and other methods/symbol only)"
+         ((:functions test)
+          (:variables i))
+
+  (defmethod test ((self foo) x) 'foo)
+  (defmethod test ((self bar) (x (eql 'a))) 'a)
+  (defmethod test ((self bar) (x (eql 'b))) 'b)
+  (setq i (make-instance 'bar))
+
+  (unless (eq (test i 'a) 'a)
+    (do-test-error () "for (bar (eql a)) wrong method was called"))
+  (unless (eq (test i 'b) 'b)
+    (do-test-error () "for (bar (eql b)) wrong method was called"))
+  (unless (eq (test i 'c) 'foo)
+    (do-test-error () "for (bar (eql c)) wrong method was called"))
+  )
+
+(do-test "eql specializers(only eql methods/symbol only)"
+         ((:functions test2)
+          (:variables i))
+
+  (defmethod test2 ((self bar) (x (eql 'a))) 'a)
+  (defmethod test2 ((self bar) (x (eql 'b))) 'b)
+  (setq i (make-instance 'bar))
+
+  (unless (eq (test2 i 'a) 'a)
+    (do-test-error () "for (bar (eql a)) wrong method was called"))
+  (unless (eq (test2 i 'b) 'b)
+    (do-test-error () "for (bar (eql b)) wrong method was called"))
+  )
+
+(do-test "eql specializers(only eql methods/symbol and integer)"
+         ((:functions test3))
+
+  (defmethod test3 ((x (eql 'a)) (y (eql '1))) 'a-1)
+  (defmethod test3 ((x (eql 'b)) (y (eql '1))) 'b-1)
+  (defmethod test3 ((x (eql 'c)) (y (eql '1))) 'c-1)
+  (defmethod test3 ((x (eql 'a)) (y (eql '2))) 'a-2)
+  (defmethod test3 ((x (eql 'b)) (y (eql '2))) 'b-2)
+  (defmethod test3 ((x (eql 'c)) (y (eql '2))) 'c-2)
+  (defmethod test3 ((x (eql 'a)) (y (eql '3))) 'a-3)
+  (defmethod test3 ((x (eql 'b)) (y (eql '3))) 'b-3)
+  (defmethod test3 ((x (eql 'c)) (y (eql '3))) 'c-3)
+  
+  (unless (eq (test3 'a '1) 'a-1)
+    (do-test-error () "for (a 1) wrong method was called"))
+  (unless (eq (test3 'a '2) 'a-2)
+    (do-test-error () "for (a 2) wrong method was called"))
+  (unless (eq (test3 'a '3) 'a-3)
+    (do-test-error () "for (a 3) wrong method was called"))
+  (unless (eq (test3 'b '1) 'b-1)
+    (do-test-error () "for (b 1) wrong method was called"))
+  (unless (eq (test3 'b '2) 'b-2)
+    (do-test-error () "for (b 2) wrong method was called"))
+  (unless (eq (test3 'b '3) 'b-3)
+    (do-test-error () "for (b 3) wrong method was called"))
+  (unless (eq (test3 'c '1) 'c-1)
+    (do-test-error () "for (c 1) wrong method was called"))
+  (unless (eq (test3 'c '2) 'c-2)
+    (do-test-error () "for (c 2) wrong method was called"))
+  (unless (eq (test3 'c '3) 'c-3)
+    (do-test-error () "for (c 3) wrong method was called"))
+
+  )
+
+(do-test "eql specializers(eql and other methods/symbol and integer)"
+         ((:functions test4))
+
+  (defmethod test4 ((x (eql 'a)) (y (eql '1))) 'a-1)
+  (defmethod test4 ((x (eql 'b)) (y (eql '1))) 'b-1)
+  (defmethod test4 ((x (eql 'c)) (y (eql '2))) 'c-2)
+  (defmethod test4 ((x (eql 'b)) (y (eql '3))) 'b-3)
+  (defmethod test4 (x y) 'other)
+  
+  (unless (eq (test4 'a '1) 'a-1)
+    (do-test-error () "for (a 1) wrong method was called"))
+  (unless (eq (test4 'a '2) 'other)
+    (do-test-error () "for (a 2) wrong method was called"))
+  (unless (eq (test4 'a '3) 'other)
+    (do-test-error () "for (a 3) wrong method was called"))
+  (unless (eq (test4 'b '1) 'b-1)
+    (do-test-error () "for (b 1) wrong method was called"))
+  (unless (eq (test4 'b '2) 'other)
+    (do-test-error () "for (b 2) wrong method was called"))
+  (unless (eq (test4 'b '3) 'b-3)
+    (do-test-error () "for (b 3) wrong method was called"))
+  (unless (eq (test4 'c '1) 'other)
+    (do-test-error () "for (c 1) wrong method was called"))
+  (unless (eq (test4 'c '2) 'c-2)
+    (do-test-error () "for (c 2) wrong method was called"))
+  (unless (eq (test4 'c '3) 'other)
+    (do-test-error () "for (c 3) wrong method was called"))
+
+  )
+
+(do-test "eql specializers(call-next-method)"
+         ((:functions test5))
+
+  (defmethod test5 (x) ())
+  (defmethod test5 ((x (eql 'a))) (cons 'a (call-next-method)))
+  (defmethod test5 ((x (eql 'b))) (cons 'b (call-next-method)))
+
+  (unless (equal (test5 'a) '(a))
+    (do-test-error () "for (a) wrong method was called"))
+  (unless (equal (test5 'b) '(b))
+    (do-test-error () "for (b) wrong method was called"))
+  (unless (eq (test5 'c) '())
+    (do-test-error () "for (c) wrong method was called"))
+  )
+
+(do-test "eql specializers(for random types)"
+         ((:functions test6))
+
+  (defmethod test6 (x) ())
+  (defmethod test6 ((x symbol))  (cons 'the-class-symbol  (call-next-method)))
+  (defmethod test6 ((x null))    (cons 'the-class-null    (call-next-method)))
+  (defmethod test6 ((x number))  (cons 'the-class-number  (call-next-method)))
+  (defmethod test6 ((x integer)) (cons 'the-class-integer (call-next-method)))
+  (defmethod test6 ((x (eql 'foo))) (cons 'foo (call-next-method)))
+  (defmethod test6 ((x (eql 'bar))) (cons 'bar (call-next-method)))
+  (defmethod test6 ((x (eql 'nil))) (cons 'nil (call-next-method)))
+  (defmethod test6 ((x (eql '1.7))) (cons '1.7 (call-next-method)))
+  (defmethod test6 ((x (eql '321))) (cons '321 (call-next-method)))
+
+  (unless (eq (test6 '(other)) ())
+    (do-test-error () "for ((other)) wrong method was called"))
+  (unless (equal (test6 'symbol) '(the-class-symbol))
+    (do-test-error () "for (symbol) wrong method was called"))
+  (unless (equal (test6 '5.5) '(the-class-number))
+    (do-test-error () "for (number) wrong method was called"))
+  (unless (equal (test6 '123) '(the-class-integer the-class-number))
+    (do-test-error () "for (integer) wrong method was called"))
+  (unless (equal (test6 'foo) '(foo the-class-symbol))
+    (do-test-error () "for ((eql foo)) wrong method was called"))
+  (unless (equal (test6 'bar) '(bar the-class-symbol))
+    (do-test-error () "for ((eql bar)) wrong method was called"))
+  (unless (equal (test6 'nil) '(nil the-class-null the-class-symbol))
+    (do-test-error () "for ((eql nil)) wrong method was called"))
+  (unless (equal (test6 '1.7) '(1.7 the-class-number))
+    (do-test-error () "for ((eql 1.7)) wrong method was called"))
+  (unless (equal (test6 '321) '(321 the-class-integer the-class-number))
+    (do-test-error () "for ((eql 321)) wrong method was called"))
+  )
+
+;;;
+;;; (5/3/89)Testing :allocation :class for funcallable-instance
+;;;
+
+(format t "~%Testing :allocation :class test(for standard-instance)~%")
+         
+(cleanup-do-test '((:classes foo bar)
+                   (:variables foo1 bar1)))
+
+(defclass foo ()
+    ((a :initform (list 'foo-a) :allocation :class)
+     (b :initform (list 'foo-b) :allocation :class)
+     (c :initform (list 'foo-c) :allocation :class)
+     (d :allocation :class)
+     (e :allocation :class)
+     (f :allocation :class)))
+
+(defclass bar (foo)
+    ((b :initform (list 'bar-b) :allocation :class)
+     (c :allocation :class)
+     (e :initform (list 'bar-e) :allocation :class)
+     (f :allocation :class)))
+
+(defmethod slot-missing ((class standard-class)
+                         (instance foo)
+                         slot-name operation &optional new-value)
+  (list* class instance slot-name operation new-value))
+
+(defmethod slot-missing ((class standard-class)
+                         (instance bar)
+                         slot-name operation &optional new-value)
+  (list* class instance slot-name operation new-value))
+
+(defmethod slot-unbound ((class standard-class)
+                         (instance foo)
+                         slot-name)
+  (list class instance slot-name))
+
+(defmethod slot-unbound ((class standard-class)
+                         (instance bar)
+                         slot-name)
+  (list class instance slot-name))
+
+(setq foo1 (make-instance 'foo)
+      bar1 (make-instance 'bar))
+
+(do-test ":allocation :class(:initform/slot-value)"
+  ()
+  (unless (and (equal (slot-value foo1 'a) '(foo-a))
+               (equal (slot-value foo1 'b) '(foo-b))
+               (equal (slot-value foo1 'c) '(foo-c))
+               (equal (slot-value bar1 'a) '(foo-a))
+               (equal (slot-value bar1 'b) '(bar-b))
+               (equal (slot-value bar1 'c) '(foo-c))
+               (equal (slot-value bar1 'e) '(bar-e)))
+    (do-test-error () ":initform/slot-value failed")))
+
+(do-test ":allocation :class(shared by instances of super and sub case)"
+  ()
+  (unless (eq (slot-value foo1 'a)
+              (slot-value bar1 'a))
+    (do-test-error () ":class slot should be shared by instances")))
+
+(do-test ":allocation :class(not shared by instances of super and sub case)"
+  ()
+  (unless (not (eq (slot-value foo1 'c)
+                   (slot-value bar1 'c)))
+    (do-test-error () ":class slot should not be shared by instances")))
+
+(do-test ":allocation :class(slot-boundp)"
+  ()
+  (unless (and (slot-boundp foo1 'a)
+               (slot-boundp foo1 'b)
+               (slot-boundp foo1 'c)
+               (not (slot-boundp foo1 'd))
+               (not (slot-boundp foo1 'e))
+               (not (slot-boundp foo1 'f))
+               (slot-boundp bar1 'a)
+               (slot-boundp bar1 'b)
+               (slot-boundp bar1 'c)
+               (not (slot-boundp bar1 'd))
+               (slot-boundp bar1 'e)
+               (not (slot-boundp bar1 'f)))
+    (do-test-error () "slot-boundp failed")))
+
+(slot-makunbound foo1 'a)
+(slot-makunbound foo1 'b)
+
+(do-test ":allocation :class(slot-makunbound)"
+  ()
+  (unless (and (not (slot-boundp foo1 'a))
+               (not (slot-boundp foo1 'b))
+               (not (slot-boundp bar1 'a))
+               (slot-boundp bar1 'b))
+    (do-test-error () "slot-makunbound failed")))
+
+(setf (slot-value foo1 'a) '(new-foo-a)
+      (slot-value foo1 'b) '(new-foo-b)
+      (slot-value foo1 'c) '(new-foo-c)
+      (slot-value bar1 'b) '(new-bar-b)
+      (slot-value bar1 'e) '(new-bar-e))
+
+(do-test ":allocation :class(slot-value/(setf slot-value))"
+  ()
+  (unless (and (equal (slot-value foo1 'a) '(new-foo-a))
+               (equal (slot-value foo1 'b) '(new-foo-b))
+               (equal (slot-value foo1 'c) '(new-foo-c))
+               (equal (slot-value bar1 'a) '(new-foo-a))
+               (equal (slot-value bar1 'b) '(new-bar-b))
+               (equal (slot-value bar1 'e) '(new-bar-e)))
+    (do-test-error () "slot-value/(setf slot-value failed")))
+
+(do-test ":allocation :class(slot-exists-p)"
+  ()
+  (unless (and (slot-exists-p foo1 'a)
+               (slot-exists-p foo1 'b)
+               (slot-exists-p foo1 'c)
+               (slot-exists-p foo1 'd)
+               (slot-exists-p foo1 'e)
+               (slot-exists-p foo1 'f)
+               (slot-exists-p bar1 'a)
+               (slot-exists-p bar1 'b)
+               (slot-exists-p bar1 'c)
+               (slot-exists-p bar1 'd)
+               (slot-exists-p bar1 'e)
+               (slot-exists-p bar1 'f))
+    (do-test-error () "slot-exist-p failed")))
+
+(do-test ":allocation :class(slot-missing)"
+  ()
+  (unless (and (equal (slot-value foo1 'x)
+                      (list (class-of foo1)
+                            foo1
+                            'x
+                            'slot-value))
+               (equal (setf (slot-value foo1 'x) 'dummy)
+                      (list* (class-of foo1)
+                             foo1
+                             'x
+                             'setf
+                             'dummy))
+               (equal (slot-boundp foo1 'x)
+                      (list (class-of foo1)
+                            foo1
+                            'x
+                            'slot-boundp))
+               
+               (equal (slot-makunbound foo1 'x)
+                      (list (class-of foo1)
+                            foo1
+                            'x
+                            'slot-makunbound))
+               (equal (slot-value bar1 'x)
+                      (list (class-of bar1)
+                            bar1
+                            'x
+                            'slot-value))
+               (equal (setf (slot-value bar1 'x) 'dummy)
+                      (list* (class-of bar1)
+                             bar1
+                             'x
+                             'setf
+                             'dummy))
+               (equal (slot-boundp bar1 'x)
+                      (list (class-of bar1)
+                            bar1
+                            'x
+                            'slot-boundp))
+               
+               (equal (slot-makunbound bar1 'x)
+                      (list (class-of bar1)
+                            bar1
+                            'x
+                            'slot-makunbound)))
+    (do-test-error () "slot-missing failed")))
+
+;;;
+;;; (5/4/89)Testing :allocation :class for funcallable-instance
+;;;
+
+(format t "~%Testing :allocation :class test~
+           (for funcallable-standard-instance)~%")
+         
+(cleanup-do-test '((:classes foo bar)
+                   (:variables foo2 bar2)))
+
+(defclass foo ()
+    ((a :initform (list 'foo-a) :allocation :class)
+     (b :initform (list 'foo-b) :allocation :class)
+     (c :initform (list 'foo-c) :allocation :class)
+     (d :allocation :class)
+     (e :allocation :class)
+     (f :allocation :class))
+  (:metaclass funcallable-standard-class))
+
+(defclass bar (foo)
+    ((b :initform (list 'bar-b) :allocation :class)
+     (c :allocation :class)
+     (e :initform (list 'bar-e) :allocation :class)
+     (f :allocation :class))
+  (:metaclass funcallable-standard-class))
+
+(defmethod slot-missing ((class standard-class)
+                         (instance foo)
+                         slot-name operation &optional new-value)
+  (list* class instance slot-name operation new-value))
+
+(defmethod slot-missing ((class standard-class)
+                         (instance bar)
+                         slot-name operation &optional new-value)
+  (list* class instance slot-name operation new-value))
+
+(defmethod slot-unbound ((class standard-class)
+                         (instance foo)
+                         slot-name)
+  (list class instance slot-name))
+
+(defmethod slot-unbound ((class standard-class)
+                         (instance bar)
+                         slot-name)
+  (list class instance slot-name))
+
+(setq foo2 (make-instance 'foo)
+      bar2 (make-instance 'bar))
+
+(do-test ":allocation :class(:initform/slot-value)"
+  ()
+  (unless (and (equal (slot-value foo2 'a) '(foo-a))
+               (equal (slot-value foo2 'b) '(foo-b))
+               (equal (slot-value foo2 'c) '(foo-c))
+               (equal (slot-value bar2 'a) '(foo-a))
+               (equal (slot-value bar2 'b) '(bar-b))
+               (equal (slot-value bar2 'c) '(foo-c))
+               (equal (slot-value bar2 'e) '(bar-e)))
+    (do-test-error () ":initform/slot-value failed")))
+
+(do-test ":allocation :class(shared by instances of super and sub case)"
+  ()
+  (unless (eq (slot-value foo2 'a)
+              (slot-value bar2 'a))
+    (do-test-error () ":class slot should be shared by instances")))
+
+(do-test ":allocation :class(not shared by instances of super and sub case)"
+  ()
+  (unless (not (eq (slot-value foo2 'c)
+                   (slot-value bar2 'c)))
+    (do-test-error () ":class slot should not be shared by instances")))
+
+(do-test ":allocation :class(slot-boundp)"
+  ()
+  (unless (and (slot-boundp foo2 'a)
+               (slot-boundp foo2 'b)
+               (slot-boundp foo2 'c)
+               (not (slot-boundp foo2 'd))
+               (not (slot-boundp foo2 'e))
+               (not (slot-boundp foo2 'f))
+               (slot-boundp bar2 'a)
+               (slot-boundp bar2 'b)
+               (slot-boundp bar2 'c)
+               (not (slot-boundp bar2 'd))
+               (slot-boundp bar2 'e)
+               (not (slot-boundp bar2 'f)))
+    (do-test-error () "slot-boundp failed")))
+
+(slot-makunbound foo2 'a)
+(slot-makunbound foo2 'b)
+
+(do-test ":allocation :class(slot-makunbound)"
+  ()
+  (unless (and (not (slot-boundp foo2 'a))
+               (not (slot-boundp foo2 'b))
+               (not (slot-boundp bar2 'a))
+               (slot-boundp bar2 'b))
+    (do-test-error () "slot-makunbound failed")))
+
+(setf (slot-value foo2 'a) '(new-foo-a)
+      (slot-value foo2 'b) '(new-foo-b)
+      (slot-value foo2 'c) '(new-foo-c)
+      (slot-value bar2 'b) '(new-bar-b)
+      (slot-value bar2 'e) '(new-bar-e))
+
+(do-test ":allocation :class(slot-value/(setf slot-value))"
+  ()
+  (unless (and (equal (slot-value foo2 'a) '(new-foo-a))
+               (equal (slot-value foo2 'b) '(new-foo-b))
+               (equal (slot-value foo2 'c) '(new-foo-c))
+               (equal (slot-value bar2 'a) '(new-foo-a))
+               (equal (slot-value bar2 'b) '(new-bar-b))
+               (equal (slot-value bar2 'e) '(new-bar-e)))
+    (do-test-error () "slot-value/(setf slot-value failed")))
+
+(do-test ":allocation :class(slot-exists-p)"
+  ()
+  (unless (and (slot-exists-p foo2 'a)
+               (slot-exists-p foo2 'b)
+               (slot-exists-p foo2 'c)
+               (slot-exists-p foo2 'd)
+               (slot-exists-p foo2 'e)
+               (slot-exists-p foo2 'f)
+               (slot-exists-p bar2 'a)
+               (slot-exists-p bar2 'b)
+               (slot-exists-p bar2 'c)
+               (slot-exists-p bar2 'd)
+               (slot-exists-p bar2 'e)
+               (slot-exists-p bar2 'f))
+    (do-test-error () "slot-exist-p failed")))
+
+;(do-test ":allocation :class(slot-missing)"
+;  ()
+;  (unless (and (equal (slot-value foo2 'x)
+;                      (list (class-of foo2)
+;                            foo2
+;                              'x
+;                            'slot-value))
+;               (equal (setf (slot-value foo2 'x) 'dummy)
+;                      (list* (class-of foo2)
+;                             foo2
+;                             'x
+ ;                            'setf
+;                             'dummy))
+;               (equal (slot-boundp foo2 'x)
+;                      (list (class-of foo2)
+;                            foo2
+;                            'x
+;                            'slot-boundp))
+;               
+;               (equal (slot-makunbound foo2 'x)
+;                      (list (class-of foo2)
+;                            foo2
+;                            'x
+;                            'slot-makunbound))
+;               (equal (slot-value bar2 'x)
+;                      (list (class-of bar2)
+;                            bar2
+;                            'x
+;                            'slot-value))
+;               (equal (setf (slot-value bar2 'x) 'dummy)
+;                      (list* (class-of bar2)
+;                             bar2
+;                             'x
+;                             'setf
+;                             'dummy))
+;               (equal (slot-boundp bar2 'x)
+;                      (list (class-of bar2)
+;                            bar2
+;                            'x
+;                            'slot-boundp))
+;               
+;               (equal (slot-makunbound bar2 'x)
+;                      (list (class-of bar2)
+;                            bar2
+;                            'x
+;                            'slot-makunbound)))
+;    (do-test-error () "slot-missing failed")))
+
+
+
diff --git a/clos/2.0/unchaged.lisp b/clos/2.0/unchaged.lisp
new file mode 100644
index 00000000..4116cfd3
--- /dev/null
+++ b/clos/2.0/unchaged.lisp
@@ -0,0 +1,22 @@
+boot
+braid
+cache
+combin
+compat
+construct
+cpl
+defcombin
+defs
+dlap
+env
+fixup
+fngen
+fsc
+lap
+methods
+plap
+precom2
+precom4
+test
+vector
+walk
\ No newline at end of file
diff --git a/clos/2.0/vector.lisp b/clos/2.0/vector.lisp
new file mode 100644
index 00000000..5f613f84
--- /dev/null
+++ b/clos/2.0/vector.lisp
@@ -0,0 +1,368 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;; Permutation vectors.
+;;;
+
+(in-package 'clos)
+
+(defmacro instance-slot-index (wrapper slot-name)
+  `(let ((pos 0))
+     (block loop
+       (dolist (sn (wrapper-instance-slots-layout ,wrapper))
+	 (when (eq ,slot-name sn) (return-from loop pos))
+	 (incf pos)))))
+
+
+;;;
+;;;
+;;;
+(defmacro %isl-cache           (isl) `(%svref ,isl 1))
+(defmacro %isl-field           (isl) `(%svref ,isl 2))
+(defmacro %isl-mask            (isl) `(%svref ,isl 3))
+(defmacro %isl-size            (isl) `(%svref ,isl 4))
+(defmacro %isl-slot-name-lists (isl) `(%svref ,isl 5))
+
+(defun make-isl (slot-name-lists)
+  (multiple-value-bind (mask size)
+      (compute-primary-pv-cache-size slot-name-lists)
+    (make-isl-internal (wrapper-field 'number)
+		       (get-cache size)
+		       mask
+		       size
+		       slot-name-lists)))
+
+(defun make-isl-internal (field cache mask size slot-name-lists)  
+  (let ((isl (make-array 6)))
+    (setf (svref isl 0)               'isl
+	  (%isl-cache isl)            cache
+	  (%isl-field isl)            field
+	  (%isl-mask  isl)            mask
+	  (%isl-size  isl)            size
+	  (%isl-slot-name-lists isl)  slot-name-lists)
+    isl))
+
+(defun make-isl-type-declaration (var)
+  `(type simple-vector ,var))
+
+(defun islp (x)
+  (and (simple-vector-p x)
+       (= (array-dimension x 0) 5)
+       (eq (svref x 0) 'isl)))
+
+(defvar *slot-name-lists-inner* (make-hash-table :test #'equal))
+(defvar *slot-name-lists-outer* (make-hash-table :test #'equal))
+
+(defun intern-slot-name-lists (slot-name-lists)
+  (flet ((inner (x) 
+	   (or (gethash x *slot-name-lists-inner*)
+	       (setf (gethash x *slot-name-lists-inner*) (copy-list x))))
+	 (outer (x) 
+	   (or (gethash x *slot-name-lists-outer*)
+	       (setf (gethash x *slot-name-lists-outer*) (make-isl (copy-list x))))))
+    (outer (mapcar #'inner slot-name-lists))))
+
+
+
+(defvar *pvs* (make-hash-table :test #'equal))
+
+(defvar default-svuc-method nil)
+(defvar default-setf-svuc-method nil)
+
+(defun optimize-slot-value-by-class-p (class slot-name setf-p)
+  (or (not (eq *boot-state* 'complete))
+      (let* ((slot-definition (find-slot-definition class slot-name))
+	     (gfun-name (if setf-p
+			    '(setf slot-value-using-class) 'slot-value-using-class))
+	     (gfun (gdefinition gfun-name))
+	     (csym (if setf-p 'default-setf-svuc-method 'default-svuc-method))
+	     (app-methods nil))
+	(dolist (method (generic-function-methods gfun))
+	  (let* ((mspecs (method-specializers method))
+		 (specs (if setf-p (cdr mspecs) mspecs)))
+	    (when (and (specializer-applicable-p (first specs) class)
+		       (specializer-applicable-using-class-p (second specs) class)
+		       (specializer-applicable-p (third specs) slot-definition))
+	      (push method app-methods))))
+	(and app-methods (null (cdr app-methods))
+	     (eq (car app-methods)
+		 (or (symbol-value csym)
+		     (let* ((specs (if setf-p
+				       '(t
+					 std-class 
+					 standard-object
+					 standard-effective-slot-definition)
+				       '(std-class 
+					 standard-object
+					 standard-effective-slot-definition)))
+			    (slist (mapcar #'find-class specs)))
+		       (set csym (get-method gfun nil slist)))))))))
+
+(defun lookup-pv (isl args)
+  (let* ((class-slot-p nil)
+	 (elements
+	  (gathering1 (collecting)
+	    (iterate ((slot-names (list-elements (%isl-slot-name-lists isl)))
+		      (arg (list-elements args)))
+	      (when slot-names
+		(let* ((wrapper     (check-wrapper-validity arg))
+		       (class       (wrapper-class wrapper))
+		       (class-slots (wrapper-class-slots wrapper)))
+		  (dolist (slot-name slot-names)
+		    (if (and (optimize-slot-value-by-class-p
+			      class slot-name nil)
+			     (optimize-slot-value-by-class-p
+			      class slot-name t))
+			(let ((index (instance-slot-index wrapper slot-name)))
+			  (if index
+			      (gather1 index)
+			      (let ((cell (assq slot-name class-slots)))
+				(if cell
+				    (progn (setq class-slot-p t) (gather1 cell))
+				    (gather1 nil)))))
+			(gather1 nil)))))))))
+    (if class-slot-p				;Sure is a shame Common Lisp doesn't
+	(make-permutation-vector elements)	;give me the right kind of hash table.
+	(or (gethash elements *pvs*)
+	    (setf (gethash elements *pvs*) (make-permutation-vector elements))))))
+
+(defun make-permutation-vector (indexes)
+  (make-array (length indexes) :initial-contents indexes))
+
+(defun make-pv-type-declaration (var)
+  `(type simple-vector ,var))
+
+(defmacro pvref (pv index)
+  `(svref ,pv ,index))
+
+
+
+(defun can-optimize-access (var required-parameters env)
+  (let ((rebound? (caddr (variable-declaration 'variable-rebinding var env))))
+    (if rebound?
+	(car (memq rebound? required-parameters))
+	(car (memq var required-parameters)))))
+
+(defun optimize-slot-value (slots parameter form)
+  (destructuring-bind (ignore ignore slot-name)
+		      form
+    (optimize-instance-access slots :read parameter (eval slot-name) nil)))
+
+(defun optimize-set-slot-value (slots parameter form)
+  (destructuring-bind (ignore ignore slot-name new-value)
+		      form
+    (optimize-instance-access slots :write parameter (eval slot-name) new-value)))
+
+;;;
+;;; The <slots> argument is an alist, the CAR of each entry is the name of
+;;; a required parameter to the function.  The alist is in order, so the
+;;; position of an entry in the alist corresponds to the argument's position
+;;; in the lambda list.
+;;; 
+(defun optimize-instance-access (slots read/write parameter slot-name new-value)
+  (let* ((parameter-entry (assq parameter slots))
+	 (slot-entry      (assq slot-name (cdr parameter-entry)))
+	 (position (position parameter-entry slots)))
+    (unless parameter-entry
+      (error "Internal error in slot optimization."))
+    (unless slot-entry
+      (setq slot-entry (list slot-name))
+      (push slot-entry (cdr parameter-entry)))
+    (ecase read/write
+      (:read
+	(let ((form (list 'instance-read ''.PV-OFFSET. parameter position 
+			  `',slot-name)))
+	  (push form (cdr slot-entry))
+	  form))
+      (:write
+	(let ((form (list 'instance-write ''.PV-OFFSET. parameter position 
+			  `',slot-name '.new-value.)))
+	  (push form (cdr slot-entry))
+	  `(let ((.new-value. ,new-value)) ,form))))))
+
+(define-walker-template instance-read)
+(define-walker-template instance-write)
+
+
+(defmacro instance-read (pv-offset parameter position slot-name)
+  `(locally
+     (declare (optimize (speed 3) (safety 0) (compilation-speed 0)))
+     (let ((.INDEX. (pvref .PV. ,pv-offset)))
+       (if (and (typep .INDEX. 'fixnum)
+		(neq (setq .INDEX. (%svref ,(slot-vector-symbol position) .INDEX.))
+		     ',*slot-unbound*))
+	   .INDEX.
+	   (pv-access-trap ,parameter .PV. ,pv-offset ,slot-name)))))
+
+(defmacro instance-write (pv-offset parameter position slot-name new-value)
+  `(locally
+     (declare (optimize (speed 3) (safety 0) (compilation-speed 0)))
+     (let ((.INDEX. (pvref .PV. ,pv-offset)))
+       (if (typep .INDEX. 'fixnum)
+	   (setf (%svref ,(slot-vector-symbol position) .INDEX.) ,new-value)
+	   (pv-access-trap ,parameter .PV. ,pv-offset ,slot-name ,new-value)))))
+
+(defun pv-access-trap (instance pv offset slot-name &optional (new-value nil nvp))
+  ;;
+  ;; First thing we do is a quick check to see if this is a class variable.
+  ;; This could be done inline by moving it to INSTANCE-READ/WRITE.  I did
+  ;; not do that because I don't know whether its worth it.
+  ;;
+  (let ((cell (pvref pv offset)))
+    (if (consp cell)
+	(if nvp (setf (cdr cell) new-value) (cdr cell))
+	;;
+	;; Well, now do a slow trap.
+	;; 
+	(if nvp
+	    (setf (slot-value instance slot-name) new-value)
+	    (slot-value instance slot-name)))))
+
+;;;
+;;; This magic function has quite a job to do indeed.
+;;;
+;;; The careful reader will recall that <slots> contains all of the optimized
+;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS.  Each of these is
+;;; a call to either INSTANCE-READ or INSTANCE-WRITE.
+;;;
+;;; At the time these calls were produced, the first argument was specified as
+;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset
+;;; arguments into the actual number that is the correct offset into the pv.
+;;;
+;;; But first, oh but first, we sort <slots> a bit so that for each argument
+;;; we have the slots in alphabetical order.  This canonicalizes the ISL's a
+;;; bit and will hopefully lead to having fewer PV's floating around.  Even
+;;; if the gain is only modest, it costs nothing.
+;;;  
+(defun slot-name-lists-from-slots (slots)
+  (mapcar #'(lambda (parameter-entry) (mapcar #'car (cdr parameter-entry)))
+	  (mutate-slots slots)))
+
+(defun mutate-slots (slots)
+  (let ((sorted (sort-slots slots))
+	(pv-offset -1))
+    (dolist (parameter-entry sorted)
+      (dolist (slot-entry (cdr parameter-entry))
+	(incf pv-offset)	
+	(dolist (form (cdr slot-entry))
+	  (setf (cadr form) pv-offset))))
+    sorted))
+
+(defun sort-slots (slots)
+  (mapcar #'(lambda (parameter-entry)
+	      (cons (car parameter-entry)
+		    (sort (cdr parameter-entry)	;slot entries
+			  #'(lambda (a b)
+			      (string-lessp (symbol-name (car a))
+					    (symbol-name (car b)))))))
+	  slots))
+
+
+;;;
+;;; This needs to work in terms of metatypes and also needs to work for
+;;; automatically generated reader and writer functions.
+;;;   
+(defun add-pv-binding (method-body plist required-parameters)
+  (let* ((isl (getf plist :isl))
+	 (isl-cache-symbol (make-symbol "isl-cache")))
+    (nconc plist (list :isl-cache-symbol isl-cache-symbol))
+    (with-gathering ((slot-variables (collecting))
+		     (metatypes (collecting)))
+	  (iterate ((slots (list-elements isl))
+		    (i (interval :from 0)))
+	    (cond (slots
+		   (gather (slot-vector-symbol i) slot-variables)
+		   (gather 'standard-instance     metatypes))
+		  (t
+		   (gather nil slot-variables)
+		   (gather t   metatypes))))
+      `((let ((.ISL. (locally (declare (special ,isl-cache-symbol)) ,isl-cache-symbol))
+	      (.PV. *empty-vector*)
+	      ,@(remove nil slot-variables))
+	  (declare ,(make-isl-type-declaration '.ISL.)
+		   ,(make-pv-type-declaration '.PV.))
+	
+	  (let* ((cache (%isl-cache .ISL.))
+		 (size  (%isl-size  .ISL.))
+		 (mask  (%isl-mask  .ISL.))
+		 (field (%isl-field .ISL.)))
+	    ,(generating-lap-in-lisp '(cache size mask field)
+				     required-parameters
+	       (flatten-lap
+		 (emit-pv-dlap required-parameters metatypes slot-variables))))
+
+	  ,@method-body)))))
+
+(defun emit-pv-dlap (required-parameters metatypes slot-variables)
+  (let* ((slot-regs (mapcar #'(lambda (sv) (and sv (operand :lisp-variable sv)))
+			    slot-variables))
+	 (wrappers (dlap-wrappers metatypes))
+	 (nwrappers (remove nil wrappers)))
+    (flet ((wrapper-moves (miss-label)
+	     (dlap-wrapper-moves wrappers required-parameters metatypes miss-label slot-regs)))
+      (prog1 (emit-dlap-internal
+	       nwrappers                   ;wrapper-regs
+	       (wrapper-moves 'pv-miss)    ;wrapper-moves
+	       (opcode :exit-lap-in-lisp)  ;hit
+	       (flatten-lap		   ;miss
+		 (opcode :label 'pv-miss)
+		 (opcode :move
+			 (operand :lisp `(primary-pv-cache-miss
+					  .ISL. ,@required-parameters))
+			 (operand :lisp-variable '.PV.))
+		 (apply #'flatten-lap (wrapper-moves 'pv-wrapper-miss)) ; -- Maybe the wrappers have changed.
+		 (opcode :label 'pv-wrapper-miss)
+		 (opcode :exit-lap-in-lisp))                               
+	       'pv-miss			    ;miss-label
+	       (operand :lisp-variable '.PV.)) ;value-reg
+	   (mapc #'deallocate-register nwrappers)))))
+
+(defun compute-primary-pv-cache-size (slot-name-lists)
+  (compute-cache-parameters (- (length slot-name-lists) (count nil slot-name-lists))
+			    t
+			    2))
+
+(defun pv-cache-limit-fn (nlines)
+  (default-limit-fn nlines))
+
+(defun primary-pv-cache-miss (isl &rest args)
+  (let* ((wrappers
+	   (gathering1 (collecting) 
+	     (iterate ((slot-names (list-elements (%isl-slot-name-lists isl)))
+		       (arg        (list-elements args)))
+	       (when slot-names (gather1 (check-wrapper-validity arg))))))
+	 (pv (lookup-pv isl args))
+	 (field (%isl-field isl))
+	 (cache (%isl-cache isl))
+	 (nkeys (length wrappers)))
+    (multiple-value-bind (new-field new-cache new-mask new-size)
+	(fill-cache field cache nkeys t #'pv-cache-limit-fn
+		    (if (= nkeys 1) (car wrappers) wrappers)
+		    pv)
+      (when (or (not (= new-field field))
+		(not (eq new-cache cache)))
+	(without-interrupts			;NOTE:
+	  (setf (%isl-field isl) new-field	; There is no mechanism to
+		(%isl-cache isl) new-cache	; synchronize the reading of
+		(%isl-size  isl) new-size	; these values.  But, this is
+		(%isl-mask  isl) new-mask))	; a safe order to write them
+						; in.  Stricly speaking, the
+						; use of without-interrupts
+						; is superfluous.
+	(when (neq new-cache cache) (free-cache cache))))
+    pv))
+
+
+
+(defmethod wrapper-fetcher ((class standard-class))
+  'std-instance-wrapper)
+
+(defmethod slots-fetcher ((class standard-class))
+  'std-instance-slots)
+
+(defmethod raw-instance-allocator ((class standard-class))
+  '%%allocate-instance--class)
diff --git a/clos/2.0/walk.lisp b/clos/2.0/walk.lisp
new file mode 100644
index 00000000..2172c050
--- /dev/null
+++ b/clos/2.0/walk.lisp
@@ -0,0 +1,2005 @@
+;;;-*- Mode:LISP; Package:(WALKER LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;; 
+;;; A simple code walker, based IN PART on: (roll the credits)
+;;;   Larry Masinter's Masterscope
+;;;   Moon's Common Lisp code walker
+;;;   Gary Drescher's code walker
+;;;   Larry Masinter's simple code walker
+;;;   .
+;;;   .
+;;;   boy, thats fair (I hope).
+;;;
+;;; For now at least, this code walker really only does what CLOS needs it to
+;;; do.  Maybe it will grow up someday.
+;;;
+
+;;;
+;;; This code walker used to be completely portable.  Now it is just "Real
+;;; easy to port".  This change had to happen because the hack that made it
+;;; completely portable kept breaking in different releases of different
+;;; Common Lisps, and in addition it never worked entirely anyways.  So,
+;;; its now easy to port.  To port this walker, all you have to write is one
+;;; simple macro and two simple functions.  These macros and functions are
+;;; used by the walker to manipluate the macroexpansion environments of
+;;; the Common Lisp it is running in.
+;;;
+;;; The code which implements the macroexpansion environment manipulation
+;;; mechanisms is in the first part of the file, the real walker follows it.
+;;; 
+
+(in-package 'walker)
+
+;;;
+;;; The user entry points are walk-form and nested-walked-form.  In addition,
+;;; it is legal for user code to call the variable information functions:
+;;; variable-lexical-p, variable-special-p and variable-class.  Some users
+;;; will need to call define-walker-template, they will have to figure that
+;;; out for themselves.
+;;; 
+(export '(define-walker-template
+	  walk-form
+	  nested-walk-form
+	  variable-lexical-p
+	  variable-special-p
+	  variable-globally-special-p
+	  *variable-declarations*
+	  variable-declaration
+	  ))
+
+
+
+;;;
+;;; On the following pages are implementations of the implementation specific
+;;; environment hacking functions for each of the implementations this walker
+;;; has been ported to.  If you add a new one, so this walker can run in a new
+;;; implementation of Common Lisp, please send the changes back to us so that
+;;; others can also use this walker in that implementation of Common Lisp.
+;;;
+;;; This code just hacks 'macroexpansion environments'.  That is, it is only
+;;; concerned with the function binding of symbols in the environment.  The
+;;; walker needs to be able to tell if the symbol names a lexical macro or
+;;; function, and it needs to be able to build environments which contain
+;;; lexical macro or function bindings.  It must be able, when walking a
+;;; macrolet, flet or labels form to construct an environment which reflects
+;;; the bindings created by that form.  Note that the environment created
+;;; does NOT have to be sufficient to evaluate the body, merely to walk its
+;;; body.  This means that definitions do not have to be supplied for lexical
+;;; functions, only the fact that that function is bound is important.  For
+;;; macros, the macroexpansion function must be supplied.
+;;;
+;;; This code is organized in a way that lets it work in implementations that
+;;; stack cons their environments.  That is reflected in the fact that the
+;;; only operation that lets a user build a new environment is a with-body
+;;; macro which executes its body with the specified symbol bound to the new
+;;; environment.  No code in this walker or in CLOS will hold a pointer to
+;;; these environments after the body returns.  Other user code is free to do
+;;; so in implementations where it works, but that code is not considered
+;;; portable.
+;;;
+;;; There are 3 environment hacking tools.  One macro which is used for
+;;; creating new environments, and two functions which are used to access the
+;;; bindings of existing environments.
+;;;
+;;; WITH-AUGMENTED-ENVIRONMENT
+;;;
+;;; ENVIRONMENT-FUNCTION
+;;;
+;;; ENVIRONMENT-MACRO
+;;; 
+
+(defun unbound-lexical-function (&rest args)
+  (declare (ignore args))
+  (error "The evaluator was called to evaluate a form in a macroexpansion~%~
+          environment constructed by the CLOS portable code walker.  These~%~
+          environments are only useful for macroexpansion, they cannot be~%~
+          used for evaluation.~%~
+          This error should never occur when using CLOS.~%~
+          This most likely source of this error is a program which tries to~%~
+          to use the CLOS portable code walker to build its own evaluator."))
+
+
+;;;
+;;; In Coral Common Lisp, the macroexpansion environment is just a list
+;;; of environment entries.  The cadr of each element specifies the type
+;;; of the element.  The only types that interest us are CCL::MACRO and
+;;; FUNCTION.  In these cases the element is interpreted as follows.
+;;;
+;;;   (<function-name> CCL::MACRO . macroexpansion-function)
+;;;   
+;;;   (<function-name> FUNCTION . <fn>)
+;;;   
+;;;   When in the compiler, <fn> is a gensym which will be
+;;;   a variable which bound at run-time to the function.
+;;;   When in the interpreter, <fn> is the actual function.
+;;;   
+;;;
+#+:Coral
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env
+							,functions
+							,macros)))
+     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  (dolist (f functions)
+    (push (list* f 'function (gensym)) env))
+  (dolist (m macros)
+    (push (list* (car m) 'ccl::macro (cadr m)) env))
+  env)
+
+(defun environment-function (env fn)
+  (let ((entry (assoc fn env :test #'equal)))
+    (and entry
+	 (eq (cadr entry) 'function)
+	 (cddr entry))))
+
+(defun environment-macro (env macro)
+  (let ((entry (assoc macro env :test #'equal)))
+    (and entry
+	 (eq (cadr entry) 'ccl::macro)
+	 (cddr entry))))
+
+);#+:Coral
+
+
+;;;
+;;; Franz Common Lisp is a lot like Coral Lisp.  The macroexpansion
+;;; environment is just a list of entries.  The cadr of each element
+;;; specifies the type of the element.  The types that interest us
+;;; are FUNCTION, EXCL::MACRO, and COMPILER::FUNCTION-VALUE.  These
+;;; are interpreted as follows:
+;;;
+;;;   (<function-name> FUNCTION . <a lexical closure>)
+;;;
+;;;      This happens in the interpreter with lexically
+;;;      bound functions.
+;;;
+;;;   (<function-name> COMPILER::FUNCTION-VALUE . <gensym>)
+;;;
+;;;      This happens in the compiler.  The gensym represents
+;;;      a variable which will be bound at run time to the
+;;;      function object.
+;;;
+;;;   (<function-name> EXCL::MACRO . <a lambda>)
+;;;
+;;;      In both interpreter and compiler, this is the
+;;;      representation used for macro definitions.
+;;;   
+;;;
+#+:ExCL
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env
+							,functions
+							,macros)))
+     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  (dolist (f functions)
+    (push (list* f 'function #'unbound-lexical-function) env))
+  (dolist (m macros)
+    (push (list* (car m) 'excl::macro (cadr m)) env))
+  env)
+
+(defun environment-function (env fn)
+  (let ((entry (assoc fn env :test #'equal)))
+    (and entry
+	 (or (eq (cadr entry) 'function)
+	     (eq (cadr entry) 'compiler::function-value))
+	 (cddr entry))))
+
+(defun environment-macro (env macro)
+  (let ((entry (assoc macro env :test #'equal)))
+    (and entry
+	 (eq (cadr entry) 'excl::macro)
+	 (cddr entry))))
+
+);#+:ExCL
+
+
+#+Lucid
+(progn
+  
+(proclaim '(inline
+	    %alphalex-p
+	    add-contour-to-env-shape
+	    make-function-variable
+	    make-sfc-contour
+	    sfc-contour-type
+	    sfc-contour-elements
+	    add-sfc-contour
+	    add-function-contour
+	    add-macrolet-contour
+	    find-variable-in-contour
+	    find-alist-element-in-contour
+	    find-macrolet-in-contour))
+
+(defun %alphalex-p (object)
+  #-Prime
+  (eq (cadddr (cddddr object)) 'lucid::%alphalex)
+  #+Prime
+  (eq (caddr (cddddr object)) 'lucid::%alphalex))
+
+#+Prime 
+(defun lucid::augment-lexenv-fvars-dummy (lexical vars)
+  (lucid::augment-lexenv-fvars-aux lexical vars '() '() 'flet '()))
+
+(defconstant function-contour 1)
+(defconstant macrolet-contour 5)
+
+(defstruct lucid::contour
+  type
+  elements)
+
+(defun add-contour-to-env-shape (contour-type elements env-shape)
+  (cons (make-contour :type contour-type
+		      :elements elements)
+	env-shape))
+
+(defstruct (variable (:constructor make-variable (name source-type)))
+  name
+  (identifier nil)
+  source-type)
+
+(defconstant function-sfc-contour 1)
+(defconstant macrolet-sfc-contour 8)
+(defconstant function-variable-type 1)
+
+(defun make-function-variable (name)
+  (make-variable name function-variable-type))
+
+(defun make-sfc-contour (type elements)
+  (cons type elements))
+
+(defun sfc-contour-type (sfc-contour)
+  (car sfc-contour))
+
+(defun sfc-contour-elements (sfc-contour)
+  (cdr sfc-contour))
+
+(defun add-sfc-contour (element-list environment type)
+  (cons (make-sfc-contour type element-list) environment))
+
+(defun add-function-contour (variable-list environment)
+  (add-sfc-contour variable-list environment function-sfc-contour))
+
+(defun add-macrolet-contour (alist environment)
+  (add-sfc-contour alist environment macrolet-sfc-contour))
+
+(defun find-variable-in-contour (name contour)
+  (dolist (element (sfc-contour-elements contour) nil)
+    (when (eq (variable-name element) name)
+      (return element))))
+
+(defun find-alist-element-in-contour (name contour)
+  (cdr (assoc name (sfc-contour-elements contour))))
+
+(defun find-macrolet-in-contour (name contour)
+  (find-alist-element-in-contour name contour))
+
+(defmacro do-sfc-contours ((contour-var environment &optional result)
+			   &body body)
+  `(dolist (,contour-var ,environment ,result) ,@body))
+
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)     
+  `(let* ((,new-env (with-augmented-environment-internal ,old-env
+							 ,functions
+							 ,macros)))
+     ,@body))
+
+;;;
+;;; with-augmented-environment-internal is where the real work of augmenting
+;;; the environment happens.
+;;; 
+(defun with-augmented-environment-internal (env functions macros)
+  (let ((function-names (mapcar #'first functions))
+	(macro-names (mapcar #'first macros))
+	(macro-functions (mapcar #'second macros)))
+    (cond ((or (null env)
+	       (contour-p (first env)))
+	   (when function-names
+	     (setq env (add-contour-to-env-shape function-contour
+						 function-names
+						 env)))
+	   (when macro-names
+	     (setq env (add-contour-to-env-shape macrolet-contour
+						 (pairlis macro-names
+							  macro-functions)
+						 env))))
+	  ((%alphalex-p env)
+	   (when function-names
+	     (setq env (lucid::augment-lexenv-fvars-dummy env function-names)))
+	   (when macro-names
+	     (setq env (lucid::augment-lexenv-mvars env
+						    macro-names
+						    macro-functions))))
+	  (t
+	   (when function-names
+	     (setq env (add-function-contour
+			 (mapcar #'make-function-variable function-names)
+			 env)))
+	   (when macro-names
+	     (setq env (add-macrolet-contour
+			 (pairlis macro-names macro-functions)
+			 env)))))
+    env))
+	 
+
+(defun environment-function (env fn)
+  (cond ((null env) nil)
+	((contour-p (first env))
+	 (if (lucid::find-lexical-function fn env)
+	     t
+	     nil))
+	((%alphalex-p env)
+	 (if (lucid::lexenv-fvar fn env)
+	     t
+	     nil))
+	(t (do-sfc-contours (contour env nil)
+	     (let ((type (sfc-contour-type contour)))
+	       (cond ((eql type function-sfc-contour)
+		      (when (find-variable-in-contour fn contour)
+			(return t)))
+		     ((eql type macrolet-sfc-contour)
+		      (when (find-macrolet-in-contour fn contour)
+			(return nil)))))))))
+		      
+(defun environment-macro (env macro)
+  (cond ((null env) nil)
+	((contour-p (first env))
+	 (lucid::find-lexical-macro macro env))
+	((%alphalex-p env)
+	 (lucid::lexenv-mvar macro env))
+	(t (do-sfc-contours (contour env nil)
+	     (let ((type (sfc-contour-type contour)))
+	       (cond ((eql type function-sfc-contour)
+		      (when (find-variable-in-contour macro contour)
+			(return nil)))
+		     ((eql type macrolet-sfc-contour)
+		      (let ((fn (find-macrolet-in-contour macro contour)))
+			(when fn
+			  (return fn))))))))))
+  
+
+);#+Lucid
+
+
+
+;;;
+;;; On the 3600, the documentation for how the environments are represented
+;;; is in sys:sys;eval.lisp.  That total information is not repeated here.
+;;; The important points are that:
+;;;    si:env-variables returns a list of which each element is:
+;;;
+;;;		(symbol value)
+;;;	     or (symbol . locative)
+;;;
+;;;	The first form is for lexical variables, the second for
+;;;	special and instance variables.  In either case CADR of
+;;;	the entry is the value and SETF of CADR is used to change
+;;;	the value.  Variables are looked up with ASSQ.
+;;;
+;;;    si:env-functions returns a list of which each element is:
+;;;     
+;;;		(symbol definition)
+;;;
+;;;	where definition is anything that could go in a function cell.
+;;;	This is used for both local functions and local macros.
+;;;
+;;; The 3600 stack conses its environments (at least in the interpreter).
+;;; This means that code written using this walker and running on the 3600
+;;; must not hold on to the environment after the walk-function returns.
+;;; No code in this walker or in CLOS does that.
+;;;
+#+Genera
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  (let ((funs (make-symbol "FNS"))
+	(macs (make-symbol "MACROS"))
+	(new  (make-symbol "NEW")))
+    `(let ((,funs ,functions)
+	   (,macs ,macros)
+	   (,new ()))
+       (dolist (f ,funs)
+	 (push `(,(car f) ,#'unbound-lexical-function) ,new))
+       (dolist (m ,macs)
+	 (push `(,(car m) (special ,(cadr m))) ,new))
+       (let* ((.old-env. ,old-env)
+	      (.old-vars. (pop .old-env.))
+	      (.old-funs. (pop .old-env.))
+	      (.old-blks. (pop .old-env.))
+	      (.old-tags. (pop .old-env.))
+	      (.old-dcls. (pop .old-env.)))
+	 (si:with-interpreter-environment (,new-env
+					   .old-env.
+					   .old-vars.
+					   (append ,new .old-funs.)
+					   .old-blks.
+					   .old-tags.
+					   .old-dcls.)
+	   ,@body)))))
+  
+
+(defun environment-function (env fn)
+  (if (null env)
+      (values nil nil)
+      (let ((entry (assoc fn (si:env-functions env) :test #'equal)))
+	(if (and entry
+		 (or (not (listp (cadr entry)))
+		     (not (eq (caadr entry) 'special))))
+	    (values (cadr entry) t)
+	    (environment-function (si:env-parent env) fn)))))
+
+(defun environment-macro (env macro)
+  (if (null env)
+      (values nil nil)
+      (let ((entry (assoc macro (si:env-functions env) :test #'equal)))
+	(if (and entry
+		 (listp (cadr entry))
+		 (eq (caadr entry) 'special))
+	    (values (cadadr entry) t)
+	    (environment-macro (si:env-parent env) macro)))))
+
+);#+Genera
+
+#+Cloe-Runtime
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros)))
+     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  functions
+  (dolist (m macros)
+    (setf env `(,(first m) (compiler::macro . ,(second m)) ,@env)))
+  env)
+
+(defun environment-function (env fn)
+  nil)
+
+(defun environment-macro (env macro)
+  (let ((entry (getf env macro)))
+    (if (and (consp entry)
+	     (eq (car entry) 'compiler::macro))
+	(values (cdr entry) t)
+	(values nil nil))))
+
+);#+Cloe-Runtime
+
+
+;;;
+;;; In Xerox Lisp, the compiler and interpreter use different structures for
+;;; the environment.  This doesn't cause a serious problem, the parts of the
+;;; environments we are concerned with are fairly similar.
+;;; 
+#+:Xerox
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)     
+  `(let* ((,new-env (with-augmented-environment-internal ,old-env
+							 ,functions
+							 ,macros)))
+     ,@body))
+
+;;;
+;;; with-augmented-environment-internal is where the real work of augmenting
+;;; the environment happens.  Before it gets there, env had better not be NIL
+;;; anymore because we have to know what kind of environment we are supposed
+;;; to be building up.  This is probably never a real concern in practice.
+;;; It better not be because we don't do anything about it.
+;;; 
+(defun with-augmented-environment-internal (env functions macros)
+  (cond
+     ((compiler::env-p env)
+	(dolist (f functions)
+	   (setq env (compiler::copy-env-with-function
+		       env f :function)))
+	(dolist (m macros)
+	   (setq env (compiler::copy-env-with-function
+	 	  env (car m) :macro (cadr m)))))
+     (t (setq env (if (il:environment-p env)
+		    (il:\\copy-environment env)
+		    (il:\\make-environment)))
+	;; The functions field of the environment is a plist of function names
+	;; and conses like (:function . fn) or (:macro . expansion-fn).
+	;; Note that we can't smash existing entries in this plist since these
+	;; are likely shared with older environments.
+	(dolist (f functions)
+	  (setf (il:environment-functions env)
+		(list* f (cons :function #'unbound-lexical-function)
+		       (il:environment-functions env))))
+	(dolist (m macros)
+	  (setf (il:environment-functions env)
+		(list* (car m) (cons :macro (cadr m))
+		       (il:environment-functions env))))))
+  env)
+
+(defun environment-function (env fn)
+  (cond ((compiler::env-p env) (eq (compiler:env-fboundp env fn) :function))
+	((il:environment-p env) (eq (getf (il:environment-functions env) fn)
+				    :function))
+	(t nil)))
+
+(defun environment-macro (env macro) 
+  (cond ((compiler::env-p env)
+	 (multiple-value-bind (type def)
+	     (compiler:env-fboundp env macro)
+	   (when (eq type :macro) def)))
+	((il:environment-p env)
+	 (xcl:destructuring-bind (type . def)
+	     (getf (il:environment-functions env) macro)
+	   (when (eq type :macro) def)))
+	(t nil)))
+
+);#+:Xerox
+
+
+;;;
+;;; In IBUKI Common Lisp, the macroexpansion environment is a three element
+;;; list.  The second element describes lexical functions and macros.  The 
+;;; function entries in this list have the form 
+;;;     (<name> . (FUNCTION . (<function-value> . nil))
+;;; The macro entries have the form 
+;;;     (<name> . (MACRO . (<macro-value> . nil)).
+;;;
+;;;
+#+(or KCL IBCL)
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+	  `(let ((,new-env (with-augmented-environment-internal ,old-env
+								,functions
+								,macros)))
+	     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  (let ((first (first env))
+	(lexicals (second env))
+	(third (third env)))
+    (dolist (f functions)
+      (push `(,(car f) .  (function  . (,#'unbound-lexical-function . nil)))
+	    lexicals))
+    (dolist (m macros)
+      (push `(,(car m)  .  (macro . ( ,(cadr m) . nil))) 
+	    lexicals))
+    (list first lexicals third)))
+
+(defun environment-function (env fn)
+  (when env
+	(let ((entry (assoc fn (second env))))
+	  (and entry
+	       (eq (cadr entry) 'function)
+	       (caddr entry)))))
+
+(defun environment-macro (env macro)
+  (when env
+	(let ((entry (assoc macro (second env))))
+	  (and entry
+	       (eq (cadr entry) 'macro)
+	       (caddr entry)))))
+);#+(or KCL IBCL)
+
+
+;;;   --- TI Explorer --
+
+;;; An environment is a two element list, whose car we can ignore and
+;;; whose cadr is list of the local-definitions-frames. Each
+;;; local-definitions-frame holds either macros or functions, but not
+;;; both.  Each frame is a plist of <name> <def> <name> <def> ...  where
+;;; <name> is a locative to the function cell of the symbol that names
+;;; the function or macro, and <def> is the new def or NIL if this is function
+;;; redefinition or (cons 'ticl:macro <macro-expansion-function>) if this is a macro
+;;; redefinition.
+;;;
+;;; Here's an example.  For the form:
+;;; (defun foo ()
+;;;   (macrolet ((bar (a b) (list a b))
+;;;	         (bar2 (a b) (list a b)))
+;;;     (flet ((some-local-fn (c d) (print (list c d)))
+;;;	       (another (c d) (print (list c d))))
+;;;       (bar (some-local-fn 1 2) 3))))
+
+;;; the environment arg to macroexpand-1 when called on
+;;; (bar (some-local-fn 1 2) 3)
+;;;is 
+;;;(NIL ((#<DTP-LOCATIVE 4710602> NIL
+;;;       #<DTP-LOCATIVE 4710671> NIL)
+;;;      (#<DTP-LOCATIVE 7346562>
+;;;       (TICL:MACRO TICL:NAMED-LAMBDA (BAR (:DESCRIPTIVE-ARGLIST (A B)))
+;;;		   (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*)
+;;;		   (BLOCK BAR ....))
+;;;       #<DTP-LOCATIVE 4710664>
+;;;       (TICL:MACRO TICL:NAMED-LAMBDA (BAR2 (:DESCRIPTIVE-ARGLIST (A B)))
+;;;		   (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*)
+;;;		   (BLOCK BAR2 ....))))
+#+TI
+(progn 
+
+;;; from sys:site;macros.lisp
+(eval-when (compile load eval)
+  
+(DEFMACRO MACRO-DEF? (thing)
+  `(AND (CONSP ,thing) (EQ (CAR ,thing) 'TICL::MACRO)))
+
+;; the following macro generates code to check the 'local' environment
+;; for a macro definition for THE SYMBOL <name>. Such a definition would
+;; be set up only by a MACROLET. If a macro definition for <name> is
+;; found, its expander function is returned.
+
+(DEFMACRO FIND-LOCAL-DEFINITION (name local-function-environment)
+  `(IF ,local-function-environment
+       (LET ((vcell (ticl::LOCF (SYMBOL-FUNCTION ,name))))
+	 (DOLIST (frame  ,local-function-environment)
+	   ;; <value> is nil or a locative
+	   (LET ((value (sys::GET-LOCATION-OR-NIL (ticl::LOCF frame)
+						  vcell))) 
+	     (When value (RETURN (CAR value))))))
+       nil)))
+
+ 
+;;;Edited by Reed Hastings         13 Jan 88  16:29
+(defun environment-macro (env macro)
+  "returns what macro-function would, ie. the expansion function"
+  ;;some code picked off macroexpand-1
+  (let* ((local-definitions (cadr env))
+	 (local-def (find-local-definition macro local-definitions)))
+    (if (macro-def? local-def)
+	(cdr local-def))))
+
+;;;Edited by Reed Hastings         13 Jan 88  16:29
+;;;Edited by Reed Hastings         7 Mar 88  19:07
+(defun environment-function (env fn)
+  (let* ((local-definitions (cadr env)))
+    (dolist (frame local-definitions)
+      (let ((val (getf frame
+		       (ticl::locf (symbol-function fn))
+		       :not-found-marker)))
+	(cond ((eq val :not-found-marker))
+	      ((functionp val) (return t))
+	      ((and (listp val)
+		    (eq (car val) 'ticl::macro))
+	       (return nil))
+	      (t
+	       (error "we are confused")))))))
+	     
+
+;;;Edited by Reed Hastings         13 Jan 88  16:29
+;;;Edited by Reed Hastings         7 Mar 88  19:07
+(defun with-augmented-environment-internal (env functions macros)
+  (let ((local-definitions (cadr env))
+	(new-local-fns-frame
+	  (mapcan #'(lambda (fn)
+		      (list (ticl:locf (symbol-function (car fn)))
+			    #'unbound-lexical-function))
+		  functions))
+	 (new-local-macros-frame
+	   (mapcan #'(lambda (m)
+		       (list (ticl:locf (symbol-function (car m))) (cons 'ticl::macro (cadr m))))
+		   macros)))
+    (when new-local-fns-frame 
+      (push new-local-fns-frame local-definitions))
+    (when new-local-macros-frame
+      (push new-local-macros-frame local-definitions))   
+    `(,(car env) ,local-definitions)))
+
+
+;;;Edited by Reed Hastings         7 Mar 88  19:07
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env
+							,functions
+							,macros)))
+     ,@body))
+
+);#+TI
+
+
+#+(and dec vax common)
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env
+							,functions
+							,macros)))
+     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  #'(lambda (op &optional (arg nil arg-p))
+      (cond ((eq op :macro-function) 
+	     (unless arg-p (error "Invalid environment use."))
+	     (lookup-macro-function arg env functions macros))
+            (arg-p
+	     (error "Invalid environment operation: ~S ~S" op arg))
+            (t
+	     (lookup-macro-function op env functions macros)))))
+
+(defun lookup-macro-function (name env fns macros)
+  (let ((m (assoc name macros)))
+    (cond (m                (cadr m))
+          ((assoc name fns) :function)
+          (env              (funcall env name))
+          (t                nil))))
+
+(defun environment-macro (env macro)
+  (let ((m (and env (funcall env macro))))
+    (and (not (eq m :function)) 
+         m)))
+
+;;; Nobody calls environment-function.  What would it return, anyway?
+);#+(and dec vax common)
+
+
+;;;
+;;; In Golden Common Lisp, the macroexpansion environment is just a list
+;;; of environment entries.  Unless the car of the list is :compiler-menv 
+;;; it is an interpreted environment.  The cadr of each element specifies 
+;;; the type of the element.  The only types that interest us are GCL:MACRO
+;;; and FUNCTION.  In these cases the element is interpreted as follows.
+;;;
+;;; Compiled:
+;;;   (<function-name> <gensym> macroexpansion-function)
+;;;   (<function-name> <fn>)
+;;;   
+;;; Interpreted:
+;;;   (<function-name> GCL:MACRO macroexpansion-function)
+;;;   (<function-name> <fn>)
+;;;   
+;;;   When in the compiler, <fn> is a gensym which will be
+;;;   a variable which bound at run-time to the function.
+;;;   When in the interpreter, <fn> is the actual function.
+;;;   
+;;;
+#+gclisp
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env
+							,functions
+							,macros)))
+     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  (let ((new-entries nil))
+    (dolist (f functions)
+      (push (cons (car f) nil) new-entries))
+    (dolist (m macros)
+      (push (cons (car m)
+		  (if (eq :compiler-menv (car env))
+		      (if (eq (caadr m) 'lisp::lambda)
+			  `(,(gensym) ,(cadr m))
+			`(,(gensym) ,@(cadr m)))
+		    `(gclisp:MACRO ,@(cadr m))))
+	      new-entries))
+    (if (eq :compiler-menv (car env))
+	`(:compiler-menv ,@new-entries ,@(cdr env))
+      (append new-entries env))))
+
+(defun environment-function (env fn)
+  (let ((entry (lisp::lexical-function fn env)))
+    (and entry 
+	 (eq entry 'lisp::lexical-function)
+	 fn)))
+
+(defun environment-macro (env macro)
+  (let ((entry (assoc macro (if (eq :compiler-menv (first env))
+				 (rest env)
+			       env))))
+    (and entry
+	 (consp entry)
+	 (symbolp (car entry))			;name
+	 (symbolp (cadr entry))			;gcl:macro or gensym
+	 (nthcdr 2 entry))))
+
+);#+gclisp
+
+
+
+(defmacro with-new-definition-in-environment
+	  ((new-env old-env macrolet/flet/labels-form) &body body)
+  (let ((functions (make-symbol "Functions"))
+	(macros (make-symbol "Macros")))
+    `(let ((,functions ())
+	   (,macros ()))
+       (ecase (car ,macrolet/flet/labels-form)
+	 ((flet labels)
+	  (dolist (fn (cadr ,macrolet/flet/labels-form))
+	    (push fn ,functions)))
+	 ((macrolet)
+	  (dolist (mac (cadr ,macrolet/flet/labels-form))
+	    (push (list (car mac)
+			(convert-macro-to-lambda (cadr mac)
+						 (cddr mac)
+						 (string (car mac))))
+		  ,macros))))
+       (with-augmented-environment
+	      (,new-env ,old-env :functions ,functions :macros ,macros)
+	 ,@body))))
+
+#-Genera
+(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro"))
+  (let ((gensym (make-symbol name)))
+    (eval `(defmacro ,gensym ,llist ,@body))
+    (macro-function gensym)))
+
+#+Genera
+(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro"))
+  (si:defmacro-1
+    'sys:named-lambda 'sys:special (make-symbol name) llist body))
+
+
+
+
+
+;;;
+;;; Now comes the real walker.
+;;;
+;;; As the walker walks over the code, it communicates information to itself
+;;; about the walk.  This information includes the walk function, variable
+;;; bindings, declarations in effect etc.  This information is inherently
+;;; lexical, so the walker passes it around in the actual environment the
+;;; walker passes to macroexpansion functions.  This is what makes the
+;;; nested-walk-form facility work properly.
+;;;
+(defmacro walker-environment-bind ((var env &rest key-args)
+				      &body body)
+  `(with-augmented-environment
+     (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args))
+     .,body))
+
+(defvar *key-to-walker-environment* (gensym))
+
+(defun env-lock (env)
+  (environment-macro env *key-to-walker-environment*))
+
+(defun walker-environment-bind-1 (env &key (walk-function nil wfnp)
+					   (walk-form nil wfop)
+					   (declarations nil decp)
+					   (lexical-variables nil lexp))
+  (let ((lock (environment-macro env *key-to-walker-environment*)))
+    (list
+      (list *key-to-walker-environment*
+	    (list (if wfnp walk-function     (car lock))
+		  (if wfop walk-form         (cadr lock))
+		  (if decp declarations      (caddr lock))
+		  (if lexp lexical-variables (cadddr lock)))))))
+		  
+(defun env-walk-function (env)
+  (car (env-lock env)))
+
+(defun env-walk-form (env)
+  (cadr (env-lock env)))
+
+(defun env-declarations (env)
+  (caddr (env-lock env)))
+
+(defun env-lexical-variables (env)
+  (cadddr (env-lock env)))
+
+
+(defun note-declaration (declaration env)
+  (let ((lock (env-lock env)))
+    (setf (caddr lock)
+	  (cons declaration (caddr lock)))))
+
+(defun note-lexical-binding (thing env)
+  (let ((lock (env-lock env)))
+    (setf (cadddr lock)
+	  (cons thing (cadddr lock)))))
+
+
+(defun VARIABLE-LEXICAL-P (var env)
+  (member var (env-lexical-variables env)))
+
+(defvar *VARIABLE-DECLARATIONS* '(special))
+
+(defun VARIABLE-DECLARATION (declaration var env)
+  (if (not (member declaration *variable-declarations*))
+      (error "~S is not a reckognized variable declaration." declaration)
+      (let ((id (or (member var (env-lexical-variables env)) var)))
+	(dolist (decl (env-declarations env))
+	  (when (and (eq (car decl) declaration)
+		     (eq (cadr decl) id))
+	    (return decl))))))
+
+(defun VARIABLE-SPECIAL-P (var env)
+  (or (not (null (variable-declaration 'special var env)))
+      (variable-globally-special-p var)))
+
+;;;
+;;; VARIABLE-GLOBALLY-SPECIAL-P is used to ask if a variable has been
+;;; declared globally special.  Any particular CommonLisp implementation
+;;; should customize this function accordingly and send their customization
+;;; back.
+;;;
+;;; The default version of variable-globally-special-p is probably pretty
+;;; slow, so it uses *globally-special-variables* as a cache to remember
+;;; variables that it has already figured out are globally special.
+;;;
+;;; This would need to be reworked if an unspecial declaration got added to
+;;; Common Lisp.
+;;;
+;;; Common Lisp nit:
+;;;   variable-globally-special-p should be defined in Common Lisp.
+;;;
+#-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs
+      GCLisp TI pyramid)
+(defvar *globally-special-variables* ())
+
+(defun variable-globally-special-p (symbol)
+  #+Genera                      (si:special-variable-p symbol)
+  #+Cloe-Runtime		(compiler::specialp symbol)
+  #+Lucid                       (lucid::proclaimed-special-p symbol)
+  #+TI                          (get symbol 'special)
+  #+Xerox                       (il:variable-globally-special-p symbol)
+  #+(and dec vax common)        (get symbol 'system::globally-special)
+  #+(or KCL IBCL)               (si:specialp symbol)
+  #+excl                        (get symbol 'excl::.globally-special.)
+  #+:CMU			(or (get symbol 'lisp::globally-special)
+				    (get symbol
+					 'clc::globally-special-in-compiler))
+  #+HP-HPLabs                   (member (get symbol 'impl:vartype)
+					'(impl:fluid impl:global)
+					:test #'eq)
+  #+:GCLISP                     (gclisp::special-p symbol)
+  #+pyramid			(or (get symbol 'lisp::globally-special)
+				    (get symbol
+					 'clc::globally-special-in-compiler))
+  #+:CORAL                      (ccl::proclaimed-special-p symbol)
+  #-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs
+	GCLisp TI pyramid :CORAL)
+  (or (not (null (member symbol *globally-special-variables* :test #'eq)))
+      (when (eval `(flet ((ref () ,symbol))
+		     (let ((,symbol '#,(list nil)))
+		       (and (boundp ',symbol) (eq ,symbol (ref))))))
+	(push symbol *globally-special-variables*)
+	t)))
+
+
+  ;;   
+;;;;;; Handling of special forms (the infamous 24).
+  ;;
+;;;
+;;; and I quote...
+;;; 
+;;;     The set of special forms is purposely kept very small because
+;;;     any program analyzing program (read code walker) must have
+;;;     special knowledge about every type of special form. Such a
+;;;     program needs no special knowledge about macros...
+;;;
+;;; So all we have to do here is a define a way to store and retrieve
+;;; templates which describe how to walk the 24 special forms and we are all
+;;; set...
+;;;
+;;; Well, its a nice concept, and I have to admit to being naive enough that
+;;; I believed it for a while, but not everyone takes having only 24 special
+;;; forms as seriously as might be nice.  There are (at least) 3 ways to
+;;; lose:
+;;
+;;;   1 - Implementation x implements a Common Lisp special form as a macro
+;;;       which expands into a special form which:
+;;;         - Is a common lisp special form (not likely)
+;;;         - Is not a common lisp special form (on the 3600 IF --> COND).
+;;;
+;;;     * We can safe ourselves from this case (second subcase really) by
+;;;       checking to see if there is a template defined for something
+;;;       before we check to see if we we can macroexpand it.
+;;;
+;;;   2 - Implementation x implements a Common Lisp macro as a special form.
+;;;
+;;;     * This is a screw, but not so bad, we save ourselves from it by
+;;;       defining extra templates for the macros which are *likely* to
+;;;       be implemented as special forms.  (DO, DO* ...)
+;;;
+;;;   3 - Implementation x has a special form which is not on the list of
+;;;       Common Lisp special forms.
+;;;
+;;;     * This is a bad sort of a screw and happens more than I would like
+;;;       to think, especially in the implementations which provide more
+;;;       than just Common Lisp (3600, Xerox etc.).
+;;;       The fix is not terribly staisfactory, but will have to do for
+;;;       now.  There is a hook in get walker-template which can get a
+;;;       template from the implementation's own walker.  That template
+;;;       has to be converted, and so it may be that the right way to do
+;;;       this would actually be for that implementation to provide an
+;;;       interface to its walker which looks like the interface to this
+;;;       walker.
+;;;
+
+(eval-when (compile load eval)
+
+(defmacro get-walker-template-internal (x) ;Has to be inside eval-when because
+  `(get ,x 'walker-template))		   ;Golden Common Lisp doesn't hack
+					   ;compile time definition of macros
+					   ;right for setf.
+
+(defmacro define-walker-template
+	  (name &optional (template '(nil repeat (eval))))
+  `(eval-when (load eval)
+     (setf (get-walker-template-internal ',name) ',template)))
+)
+
+(defun get-walker-template (x)
+  (cond ((symbolp x)
+	 (or (get-walker-template-internal x)
+	     (get-implementation-dependent-walker-template x)))
+	((and (listp x) (eq (car x) 'lambda))
+	 '(lambda repeat (eval)))
+	(t
+	 (error "Can't get template for ~S" x))))
+
+(defun get-implementation-dependent-walker-template (x)
+  (declare (ignore x))
+  ())
+
+
+  ;;   
+;;;;;; The actual templates
+  ;;   
+
+(define-walker-template BLOCK                (NIL NIL REPEAT (EVAL)))
+(define-walker-template CATCH                (NIL EVAL REPEAT (EVAL)))
+(define-walker-template COMPILER-LET         walk-compiler-let)
+(define-walker-template DECLARE              walk-unexpected-declare)
+(define-walker-template EVAL-WHEN            (NIL QUOTE REPEAT (EVAL)))
+(define-walker-template FLET                 walk-flet)
+(define-walker-template FUNCTION             (NIL CALL))
+(define-walker-template GO                   (NIL QUOTE))
+(define-walker-template IF                   walk-if)
+(define-walker-template LABELS               walk-labels)
+(define-walker-template LAMBDA               walk-lambda)
+(define-walker-template LET                  walk-let)
+(define-walker-template LET*                 walk-let*)
+(define-walker-template MACROLET             walk-macrolet)
+(define-walker-template MULTIPLE-VALUE-CALL  (NIL EVAL REPEAT (EVAL)))
+(define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL)))
+(define-walker-template MULTIPLE-VALUE-SETQ  (NIL (REPEAT (SET)) EVAL))
+(define-walker-template MULTIPLE-VALUE-BIND  walk-multiple-value-bind)
+(define-walker-template PROGN                (NIL REPEAT (EVAL)))
+(define-walker-template PROGV                (NIL EVAL EVAL REPEAT (EVAL)))
+(define-walker-template QUOTE                (NIL QUOTE))
+(define-walker-template RETURN-FROM          (NIL QUOTE REPEAT (RETURN)))
+(define-walker-template SETQ                 (NIL REPEAT (SET EVAL)))
+(define-walker-template TAGBODY              walk-tagbody)
+(define-walker-template THE                  (NIL QUOTE EVAL))
+(define-walker-template THROW                (NIL EVAL EVAL))
+(define-walker-template UNWIND-PROTECT       (NIL RETURN REPEAT (EVAL)))
+
+;;; The new special form.
+;(define-walker-template clos::LOAD-TIME-EVAL       (NIL EVAL))
+
+;;;
+;;; And the extra templates...
+;;;
+(define-walker-template DO      walk-do)
+(define-walker-template DO*     walk-do*)
+(define-walker-template PROG    walk-prog)
+(define-walker-template PROG*   walk-prog*)
+(define-walker-template COND    (NIL REPEAT ((TEST REPEAT (EVAL)))))
+
+#+Genera
+(progn
+  (define-walker-template zl::named-lambda walk-named-lambda)
+  (define-walker-template SCL:LETF walk-let)
+  (define-walker-template SCL:LETF* walk-let*)
+  )
+
+#+Lucid
+(progn
+  (define-walker-template #+LCL3.0 lucid-common-lisp:named-lambda
+			  #-LCL3.0 sys:named-lambda walk-named-lambda)
+  )
+
+#+(or KCL IBCL)
+(progn
+  (define-walker-template lambda-block walk-named-lambda);Not really right,
+							 ;we don't hack block
+						         ;names anyways.
+  )
+
+#+TI
+(progn
+  (define-walker-template TICL::LET-IF walk-let-if)
+  )
+
+#+:Coral
+(progn
+  (define-walker-template ccl:%stack-block walk-let)
+  )
+
+
+
+(defun WALK-FORM (form
+		  &optional environment
+			    (walk-function
+			      #'(lambda (subform context env)
+				  (declare (ignore context env))
+				  subform)))
+  (walker-environment-bind (new-env environment :walk-function walk-function)
+    (walk-form-internal form :eval new-env)))
+
+;;;
+;;; nested-walk-form provides an interface that allows nested macros, each
+;;; of which must walk their body to just do one walk of the body of the
+;;; inner macro.  That inner walk is done with a walk function which is the
+;;; composition of the two walk functions.
+;;;
+;;; This facility works by having the walker annotate the environment that
+;;; it passes to macroexpand-1 to know which form is being macroexpanded.
+;;; If then the &whole argument to the macroexpansion function is eq to
+;;; the env-walk-form of the environment, nested-walk-form can be certain
+;;; that there are no intervening layers and that a nested walk is alright.
+;;;
+;;; There are some semantic problems with this facility.  In particular, if
+;;; the outer walk function returns T as its walk-no-more-p value, this will
+;;; prevent the inner walk function from getting a chance to walk the subforms
+;;; of the form.  This is almost never what you want, since it destroys the
+;;; equivalence between this nested-walk-form function and two seperate
+;;; walk-forms.
+;;;
+(defun NESTED-WALK-FORM (whole
+			 form
+			 &optional environment
+				   (walk-function
+				     #'(lambda (subform context env)
+					 (declare (ignore context env))
+					 subform)))
+  (if (eq whole (env-walk-form environment))
+      (let ((outer-walk-function (env-walk-function environment)))
+	(throw whole
+	  (walk-form
+	    form
+	    environment
+	    #'(lambda (f c e)
+		;; First loop to make sure the inner walk function
+		;; has done all it wants to do with this form.
+		;; Basically, what we are doing here is providing
+		;; the same contract walk-form-internal normally
+		;; provides to the inner walk function.
+		(let ((inner-result nil)
+		      (inner-no-more-p nil)
+		      (outer-result nil)
+		      (outer-no-more-p nil))
+		  (loop
+		    (multiple-value-setq (inner-result inner-no-more-p)
+					 (funcall walk-function f c e))
+		    (cond (inner-no-more-p (return))
+			  ((not (eq inner-result f)))
+			  ((not (consp inner-result)) (return))
+			  ((get-walker-template (car inner-result)) (return))
+			  (t
+			   (multiple-value-bind (expansion macrop)
+			       (walker-environment-bind
+				     (new-env e :walk-form inner-result)
+				 (macroexpand-1 inner-result new-env))
+			     (if macrop
+				 (setq inner-result expansion)
+				 (return)))))
+		    (setq f inner-result))
+		  (multiple-value-setq (outer-result outer-no-more-p)
+				       (funcall outer-walk-function
+						inner-result
+						c
+						e))
+		  (values outer-result
+			  (and inner-no-more-p outer-no-more-p)))))))
+      (walk-form form environment walk-function)))
+
+;;;
+;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It
+;;; takes a form and the current context and walks the form calling itself or
+;;; the appropriate template recursively.
+;;;
+;;;   "It is recommended that a program-analyzing-program process a form
+;;;    that is a list whose car is a symbol as follows:
+;;;
+;;;     1. If the program has particular knowledge about the symbol,
+;;;        process the form using special-purpose code.  All of the
+;;;        standard special forms should fall into this category.
+;;;     2. Otherwise, if macro-function is true of the symbol apply
+;;;        either macroexpand or macroexpand-1 and start over.
+;;;     3. Otherwise, assume it is a function call. "
+;;;     
+
+(defun walk-form-internal (form context env
+			   &aux newform newnewform
+				walk-no-more-p macrop
+				fn template)
+  ;; First apply the walk-function to perform whatever translation
+  ;; the user wants to this form.  If the second value returned
+  ;; by walk-function is T then we don't recurse...
+  (catch form
+    (multiple-value-setq (newform walk-no-more-p)
+      (funcall (env-walk-function env) form context env))
+    (catch newform
+      (cond (walk-no-more-p newform)
+	    ((not (eq form newform))
+	     (walk-form-internal newform context env))
+	    ((not (consp newform)) newform)
+	    ((setq template (get-walker-template (setq fn (car newform))))
+	     (if (symbolp template)
+		 (funcall template newform context env)
+		 (walk-template newform template context env)))
+	    (t
+	     (multiple-value-setq (newnewform macrop)
+	       (walker-environment-bind (new-env env :walk-form newform)
+		 (macroexpand-1 newform new-env)))
+	     (cond (macrop (walk-form-internal newnewform context env))
+		   ((and (symbolp fn)
+			 (not (fboundp fn))
+			 (special-form-p fn))
+		    (error
+		      "~S is a special form, not defined in the CommonLisp.~%~
+                       manual This code walker doesn't know how to walk it.~%~
+                       Define a template for this special form and try again."
+		      fn))
+		   (t
+		    ;; Otherwise, walk the form as if its just a standard 
+		    ;; functioncall using a template for standard function
+		    ;; call.
+		    (walk-template
+		      newnewform '(call repeat (eval)) context env))))))))
+
+(defun walk-template (form template context env)
+  (if (atom template)
+      (ecase template
+        ((EVAL FUNCTION TEST EFFECT RETURN)
+         (walk-form-internal form :EVAL env))
+        ((QUOTE NIL) form)
+        (SET
+          (walk-form-internal form :SET env))
+        ((LAMBDA CALL)
+	 (cond ((symbolp form) form)
+	       #+Lispm
+	       ((sys:validate-function-spec form) form)
+	       (t (walk-form-internal form context env)))))
+      (case (car template)
+        (REPEAT
+          (walk-template-handle-repeat form
+                                       (cdr template)
+				       ;; For the case where nothing happens
+				       ;; after the repeat optimize out the
+				       ;; call to length.
+				       (if (null (cddr template))
+					   ()
+					   (nthcdr (- (length form)
+						      (length
+							(cddr template)))
+						   form))
+                                       context
+				       env))
+        (IF
+	  (walk-template form
+			 (if (if (listp (cadr template))
+				 (eval (cadr template))
+				 (funcall (cadr template) form))
+			     (caddr template)
+			     (cadddr template))
+			 context
+			 env))
+        (REMOTE
+          (walk-template form (cadr template) context env))
+        (otherwise
+          (cond ((atom form) form)
+                (t (recons form
+                           (walk-template
+			     (car form) (car template) context env)
+                           (walk-template
+			     (cdr form) (cdr template) context env))))))))
+
+(defun walk-template-handle-repeat (form template stop-form context env)
+  (if (eq form stop-form)
+      (walk-template form (cdr template) context env)
+      (walk-template-handle-repeat-1 form
+				     template
+				     (car template)
+				     stop-form
+				     context
+				     env)))
+
+(defun walk-template-handle-repeat-1 (form template repeat-template
+					   stop-form context env)
+  (cond ((null form) ())
+        ((eq form stop-form)
+         (if (null repeat-template)
+             (walk-template stop-form (cdr template) context env)       
+             (error "While handling repeat:
+                     ~%~Ran into stop while still in repeat template.")))
+        ((null repeat-template)
+         (walk-template-handle-repeat-1
+	   form template (car template) stop-form context env))
+        (t
+         (recons form
+                 (walk-template (car form) (car repeat-template) context env)
+                 (walk-template-handle-repeat-1 (cdr form)
+						template
+						(cdr repeat-template)
+						stop-form
+						context
+						env)))))
+
+(defun walk-repeat-eval (form env)
+  (and form
+       (recons form
+	       (walk-form-internal (car form) :eval env)
+	       (walk-repeat-eval (cdr form) env))))
+
+(defun recons (x car cdr)
+  (if (or (not (eq (car x) car))
+          (not (eq (cdr x) cdr)))
+      (cons car cdr)
+      x))
+
+(defun relist (x &rest args)
+  (relist-internal x args nil))
+
+(defun relist* (x &rest args)
+  (relist-internal x args 't))
+
+(defun relist-internal (x args *p)
+  (if (null (cdr args))
+      (if *p (car args) (list (car args)))
+      (recons x
+	      (car args)
+	      (relist-internal (cdr x) (cdr args) *p))))
+
+
+  ;;   
+;;;;;; Special walkers
+  ;;
+
+(defun walk-declarations (body fn env
+			       &optional doc-string-p declarations old-body
+			       &aux (form (car body)) macrop new-form)
+  (cond ((and (stringp form)			;might be a doc string
+              (cdr body)			;isn't the returned value
+              (null doc-string-p)		;no doc string yet
+              (null declarations))		;no declarations yet
+         (recons body
+                 form
+                 (walk-declarations (cdr body) fn env t)))
+        ((and (listp form) (eq (car form) 'declare))
+         ;; Got ourselves a real live declaration.  Record it, look for more.
+         (dolist (declaration (cdr form))
+	   (let ((type (car declaration))
+		 (name (cadr declaration))
+		 (args (cddr declaration)))
+	     (if (member type *variable-declarations*)
+		 (note-declaration `(,type
+				     ,(or (variable-lexical-p name env) name)
+				     ,.args)
+				   env)
+		 (note-declaration declaration env))
+	     (push declaration declarations)))
+         (recons body
+                 form
+                 (walk-declarations
+		   (cdr body) fn env doc-string-p declarations)))
+        ((and form
+	      (listp form)
+	      (null (get-walker-template (car form)))
+	      (progn
+		(multiple-value-setq (new-form macrop)
+				     (macroexpand-1 form env))
+		macrop))
+	 ;; This form was a call to a macro.  Maybe it expanded
+	 ;; into a declare?  Recurse to find out.
+	 (walk-declarations (recons body new-form (cdr body))
+			    fn env doc-string-p declarations
+			    (or old-body body)))
+	(t
+	 ;; Now that we have walked and recorded the declarations,
+	 ;; call the function our caller provided to expand the body.
+	 ;; We call that function rather than passing the real-body
+	 ;; back, because we are RECONSING up the new body.
+	 (funcall fn (or old-body body) env))))
+
+
+(defun walk-unexpected-declare (form context env)
+  (declare (ignore context env))
+  (warn "Encountered declare ~S in a place where a declare was not expected."
+	form)
+  form)
+
+(defun walk-arglist (arglist context env &optional (destructuringp nil)
+					 &aux arg)
+  (cond ((null arglist) ())
+        ((symbolp (setq arg (car arglist)))
+         (or (member arg lambda-list-keywords)
+             (note-lexical-binding arg env))
+         (recons arglist
+                 arg
+                 (walk-arglist (cdr arglist)
+                               context
+			       env
+                               (and destructuringp
+				    (not (member arg
+						 lambda-list-keywords))))))
+        ((consp arg)
+         (prog1 (if destructuringp
+                    (walk-arglist arg context env destructuringp)
+                    (recons arglist
+                            (relist* arg
+                                     (car arg)
+                                     (walk-form-internal (cadr arg) :eval env)
+                                     (cddr arg))
+                            (walk-arglist (cdr arglist) context env nil)))
+                (if (symbolp (car arg))
+                    (note-lexical-binding (car arg) env)
+                    (note-lexical-binding (cadar arg) env))
+                (or (null (cddr arg))
+                    (not (symbolp (caddr arg)))
+                    (note-lexical-binding (caddr arg) env))))
+          (t
+	   (error "Can't understand something in the arglist ~S" arglist))))
+
+(defun walk-let (form context env)
+  (walk-let/let* form context env nil))
+
+(defun walk-let* (form context env)
+  (walk-let/let* form context env t))
+
+(defun walk-prog (form context env)
+  (walk-prog/prog* form context env nil))
+
+(defun walk-prog* (form context env)
+  (walk-prog/prog* form context env t))
+
+(defun walk-do (form context env)
+  (walk-do/do* form context env nil))
+
+(defun walk-do* (form context env)
+  (walk-do/do* form context env t))
+
+(defun walk-let/let* (form context old-env sequentialp)
+  (walker-environment-bind (new-env old-env)
+    (let* ((let/let* (car form))
+	   (bindings (cadr form))
+	   (body (cddr form))
+	   (walked-bindings 
+	     (walk-bindings-1 bindings
+			      old-env
+			      new-env
+			      context
+			      sequentialp))
+	   (walked-body
+	     (walk-declarations body #'walk-repeat-eval new-env)))
+      (relist*
+	form let/let* walked-bindings walked-body))))
+
+(defun walk-prog/prog* (form context old-env sequentialp)
+  (walker-environment-bind (new-env old-env)
+    (let* ((possible-block-name (second form))
+	   (blocked-prog (and (symbolp possible-block-name)
+			      (not (eq possible-block-name 'nil)))))
+      (multiple-value-bind (let/let* block-name bindings body)
+	  (if blocked-prog
+	      (values (car form) (cadr form) (caddr form) (cdddr form))
+	      (values (car form) nil	     (cadr  form) (cddr  form)))
+	(let* ((walked-bindings 
+		 (walk-bindings-1 bindings
+				  old-env
+				  new-env
+				  context
+				  sequentialp))
+	       (walked-body
+		 (walk-declarations 
+		   body
+		   #'(lambda (real-body real-env)
+		       (walk-tagbody-1 real-body context real-env))
+		   new-env)))
+	  (if block-name
+	      (relist*
+		form let/let* block-name walked-bindings walked-body)
+	      (relist*
+		form let/let* walked-bindings walked-body)))))))
+
+(defun walk-do/do* (form context old-env sequentialp)
+  (walker-environment-bind (new-env old-env)
+    (let* ((do/do* (car form))
+	   (bindings (cadr form))
+	   (end-test (caddr form))
+	   (body (cdddr form))
+	   (walked-bindings (walk-bindings-1 bindings
+					     old-env
+					     new-env
+					     context
+					     sequentialp))
+	   (walked-body
+	     (walk-declarations body #'walk-repeat-eval new-env)))
+      (relist* form
+	       do/do*
+	       (walk-bindings-2 bindings walked-bindings context new-env)
+	       (walk-template end-test '(test repeat (eval)) context new-env)
+	       walked-body))))
+
+(defun walk-let-if (form context env)
+  (let ((test (cadr form))
+	(bindings (caddr form))
+	(body (cdddr form)))
+    (walk-form-internal
+      `(let ()
+	 (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x))
+				     bindings)))
+	 (flet ((.let-if-dummy. () ,@body))
+	   (if ,test
+	       (let ,bindings (.let-if-dummy.))
+	       (.let-if-dummy.))))
+      context
+      env)))
+
+(defun walk-multiple-value-bind (form context old-env)
+  (walker-environment-bind (new-env old-env)
+    (let* ((mvb (car form))
+	   (bindings (cadr form))
+	   (mv-form (walk-template (caddr form) 'eval context old-env))
+	   (body (cdddr form))
+	   walked-bindings
+	   (walked-body
+	     (walk-declarations 
+	       body
+	       #'(lambda (real-body real-env)
+		   (setq walked-bindings
+			 (walk-bindings-1 bindings
+					  old-env
+					  new-env
+					  context
+					  nil))
+		   (walk-repeat-eval real-body real-env))
+	       new-env)))
+      (relist* form mvb walked-bindings mv-form walked-body))))
+
+(defun walk-bindings-1 (bindings old-env new-env context sequentialp)
+  (and bindings
+       (let ((binding (car bindings)))
+         (recons bindings
+                 (if (symbolp binding)
+                     (prog1 binding
+                            (note-lexical-binding binding new-env))
+                     (prog1 (relist* binding
+				     (car binding)
+				     (walk-form-internal (cadr binding)
+							 context
+							 (if sequentialp
+							     new-env
+							     old-env))
+				     (cddr binding))	;save cddr for DO/DO*
+						        ;it is the next value
+						        ;form. Don't walk it
+						        ;now though.
+                            (note-lexical-binding (car binding) new-env)))
+                 (walk-bindings-1 (cdr bindings)
+				  old-env
+				  new-env
+				  context
+				  sequentialp)))))
+
+(defun walk-bindings-2 (bindings walked-bindings context env)
+  (and bindings
+       (let ((binding (car bindings))
+             (walked-binding (car walked-bindings)))
+         (recons bindings
+		 (if (symbolp binding)
+		     binding
+		     (relist* binding
+			      (car walked-binding)
+			      (cadr walked-binding)
+			      (walk-template (cddr binding)
+					     '(eval)
+					     context
+					     env)))		 
+                 (walk-bindings-2 (cdr bindings)
+				  (cdr walked-bindings)
+				  context
+				  env)))))
+
+(defun walk-lambda (form context old-env)
+  (walker-environment-bind (new-env old-env)
+    (let* ((arglist (cadr form))
+           (body (cddr form))
+           (walked-arglist (walk-arglist arglist context new-env))
+           (walked-body
+             (walk-declarations body #'walk-repeat-eval new-env)))
+      (relist* form
+               (car form)
+	       walked-arglist
+               walked-body))))
+
+(defun walk-named-lambda (form context old-env)
+  (walker-environment-bind (new-env old-env)
+    (let* ((name (cadr form))
+	   (arglist (caddr form))
+           (body (cdddr form))
+           (walked-arglist (walk-arglist arglist context new-env))
+           (walked-body
+             (walk-declarations body #'walk-repeat-eval new-env)))
+      (relist* form
+               (car form)
+	       name
+	       walked-arglist
+               walked-body))))  
+
+(defun walk-tagbody (form context env)
+  (recons form (car form) (walk-tagbody-1 (cdr form) context env)))
+
+(defun walk-tagbody-1 (form context env)
+  (and form
+       (recons form
+               (walk-form-internal (car form)
+				   (if (symbolp (car form)) 'quote context)
+				   env)
+               (walk-tagbody-1 (cdr form) context env))))
+
+(defun walk-compiler-let (form context old-env)
+  (declare (ignore context))
+  (let ((vars ())
+	(vals ()))
+    (dolist (binding (cadr form))
+      (cond ((symbolp binding) (push binding vars) (push nil vals))
+	    (t
+	     (push (car binding) vars)
+	     (push (eval (cadr binding)) vals))))
+    (relist* form
+	     (car form)
+	     (cadr form)
+	     (progv vars vals (walk-repeat-eval (cddr form) old-env)))))
+
+(defun walk-macrolet (form context old-env)
+  (walker-environment-bind (macro-env
+			    nil
+			    :walk-function (env-walk-function old-env))
+    (labels ((walk-definitions (definitions)
+	       (and definitions
+		    (let ((definition (car definitions)))
+		      (recons definitions
+                              (relist* definition
+                                       (car definition)
+                                       (walk-arglist (cadr definition)
+						     context
+						     macro-env
+						     t)
+                                       (walk-declarations (cddr definition)
+							  #'walk-repeat-eval
+							  macro-env))
+			      (walk-definitions (cdr definitions)))))))
+      (with-new-definition-in-environment (new-env old-env form)
+	(relist* form
+		 (car form)
+		 (walk-definitions (cadr form))
+		 (walk-declarations (cddr form)
+				    #'walk-repeat-eval
+				    new-env))))))
+
+(defun walk-flet (form context old-env)
+  (labels ((walk-definitions (definitions)
+	     (if (null definitions)
+		 ()
+		 (recons definitions
+			 (walk-lambda (car definitions) context old-env)
+			 (walk-definitions (cdr definitions))))))
+    (recons form
+	    (car form)
+	    (recons (cdr form)
+		    (walk-definitions (cadr form))
+		    (with-new-definition-in-environment (new-env old-env form)
+		      (walk-declarations (cddr form)
+					 #'walk-repeat-eval
+					 new-env))))))
+
+(defun walk-labels (form context old-env)
+  (with-new-definition-in-environment (new-env old-env form)
+    (labels ((walk-definitions (definitions)
+	       (if (null definitions)
+		   ()
+		   (recons definitions
+			   (walk-lambda (car definitions) context new-env)
+			   (walk-definitions (cdr definitions))))))
+      (recons form
+	      (car form)
+	      (recons (cdr form)
+		      (walk-definitions (cadr form))
+		      (walk-declarations (cddr form)
+					 #'walk-repeat-eval
+					 new-env))))))
+
+(defun walk-if (form context env)
+  (let ((predicate (cadr form))
+	(arm1 (caddr form))
+	(arm2 
+	  (if (cddddr form)
+	      (progn
+		(warn "In the form:~%~S~%~
+                       IF only accepts three arguments, you are using ~D.~%~
+                       It is true that some Common Lisps support this, but ~
+                       it is not~%~
+                       truly legal Common Lisp.  For now, this code ~
+                       walker is interpreting ~%~
+                       the extra arguments as extra else clauses. ~
+                       Even if this is what~%~
+                       you intended, you should fix your source code."
+		      form
+		      (length (cdr form)))
+		(cons 'progn (cdddr form)))
+	      (cadddr form))))
+    (relist form
+	    'if
+	    (walk-form-internal predicate context env)
+	    (walk-form-internal arm1 context env)
+	    (walk-form-internal arm2 context env))))
+
+
+;;;
+;;; Tests tests tests
+;;;
+
+#|
+;;; 
+;;; Here are some examples of the kinds of things you should be able to do
+;;; with your implementation of the macroexpansion environment hacking
+;;; mechanism.
+;;; 
+;;; with-lexical-macros is kind of like macrolet, but it only takes names
+;;; of the macros and actual macroexpansion functions to use to macroexpand
+;;; them.  The win about that is that for macros which want to wrap several
+;;; macrolets around their body, they can do this but have the macroexpansion
+;;; functions be compiled.  See the WITH-RPUSH example.
+;;;
+;;; If the implementation had a special way of communicating the augmented
+;;; environment back to the evaluator that would be totally great.  It would
+;;; mean that we could just augment the environment then pass control back
+;;; to the implementations own compiler or interpreter.  We wouldn't have
+;;; to call the actual walker.  That would make this much faster.  Since the
+;;; principal client of this is defmethod it would make compiling defmethods
+;;; faster and that would certainly be a win.
+;;;
+(defmacro with-lexical-macros (macros &body body &environment old-env)
+  (with-augmented-environment (new-env old-env :macros macros)
+    (walk-form (cons 'progn body) :environment new-env)))
+
+(defun expand-rpush (form env)
+  `(push ,(caddr form) ,(cadr form)))
+
+(defmacro with-rpush (&body body)
+  `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body))
+
+
+;;;
+;;; Unfortunately, I don't have an automatic tester for the walker.  
+;;; Instead there is this set of test cases with a description of
+;;; how each one should go.
+;;; 
+(defmacro take-it-out-for-a-test-walk (form)
+  `(take-it-out-for-a-test-walk-1 ',form))
+
+(defun take-it-out-for-a-test-walk-1 (form)
+  (terpri)
+  (terpri)
+  (let ((copy-of-form (copy-tree form))
+	(result (walk-form form nil
+		  #'(lambda (x y env)
+		      (format t "~&Form: ~S ~3T Context: ~A" x y)
+		      (when (symbolp x)
+			(let ((lexical (variable-lexical-p x env))
+			      (special (variable-special-p x env)))
+			  (when lexical
+			    (format t ";~3T")
+			    (format t "lexically bound"))
+			  (when special
+			    (format t ";~3T")
+			    (format t "declared special"))
+			  (when (boundp x)
+			    (format t ";~3T")
+			    (format t "bound: ~S " (eval x)))))
+		      x))))
+    (cond ((not (equal result copy-of-form))
+	   (format t "~%Warning: Result not EQUAL to copy of start."))
+	  ((not (eq result form))
+	   (format t "~%Warning: Result not EQ to copy of start.")))
+    (pprint result)
+    result))
+
+(defmacro foo (&rest ignore) ''global-foo)
+
+(defmacro bar (&rest ignore) ''global-bar)
+
+(take-it-out-for-a-test-walk (list arg1 arg2 arg3))
+(take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5)))
+
+(take-it-out-for-a-test-walk (progn (foo) (bar 1)))
+
+(take-it-out-for-a-test-walk (block block-name a b c))
+(take-it-out-for-a-test-walk (block block-name (list a) b c))
+
+(take-it-out-for-a-test-walk (catch catch-tag (list a) b c))
+;;;
+;;; This is a fairly simple macrolet case.  While walking the body of the
+;;; macro, x should be lexically bound. In the body of the macrolet form
+;;; itself, x should not be bound.
+;;; 
+(take-it-out-for-a-test-walk
+  (macrolet ((foo (x) (list x) ''inner))
+    x
+    (foo 1)))
+
+;;;
+;;; A slightly more complex macrolet case.  In the body of the macro x
+;;; should not be lexically bound.  In the body of the macrolet form itself
+;;; x should be bound.  Note that THIS CASE WILL CAUSE AN ERROR when it
+;;; tries to macroexpand the call to foo.
+;;; 
+(take-it-out-for-a-test-walk
+     (let ((x 1))
+       (macrolet ((foo () (list x) ''inner))
+	 x
+	 (foo))))
+
+;;;
+;;; A truly hairy use of compiler-let and macrolet.  In the body of the
+;;; macro x should not be lexically bound.  In the body of the macrolet
+;;; itself x should not be lexically bound.  But the macro should expand
+;;; into 1.
+;;; 
+(take-it-out-for-a-test-walk
+  (compiler-let ((x 1))
+    (let ((x 2))
+      (macrolet ((foo () x))
+	x
+	(foo)))))
+
+
+(take-it-out-for-a-test-walk
+  (flet ((foo (x) (list x y))
+	 (bar (x) (list x y)))
+    (foo 1)))
+
+(take-it-out-for-a-test-walk
+  (let ((y 2))
+    (flet ((foo (x) (list x y))
+	   (bar (x) (list x y)))
+      (foo 1))))
+
+(take-it-out-for-a-test-walk
+  (labels ((foo (x) (bar x))
+	   (bar (x) (foo x)))
+    (foo 1)))
+
+(take-it-out-for-a-test-walk
+  (flet ((foo (x) (foo x)))
+    (foo 1)))
+
+(take-it-out-for-a-test-walk
+  (flet ((foo (x) (foo x)))
+    (flet ((bar (x) (foo x)))
+      (bar 1))))
+
+(take-it-out-for-a-test-walk (compiler-let ((a 1) (b 2)) (foo a) b))
+(take-it-out-for-a-test-walk (prog () (declare (special a b))))
+(take-it-out-for-a-test-walk (let (a b c)
+                               (declare (special a b))
+                               (foo a) b c))
+(take-it-out-for-a-test-walk (let (a b c)
+                               (declare (special a) (special b))
+                               (foo a) b c))
+(take-it-out-for-a-test-walk (let (a b c)
+                               (declare (special a))
+                               (declare (special b))
+                               (foo a) b c))
+(take-it-out-for-a-test-walk (let (a b c)
+                               (declare (special a))
+                               (declare (special b))
+                               (let ((a 1))
+                                 (foo a) b c)))
+(take-it-out-for-a-test-walk (eval-when ()
+                               a
+                               (foo a)))
+(take-it-out-for-a-test-walk (eval-when (eval when load)
+                               a
+                               (foo a)))
+
+(take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b)))
+(take-it-out-for-a-test-walk (multiple-value-bind (a b)
+				 (foo a b)
+			       (declare (special a))
+			       (list a b)))
+(take-it-out-for-a-test-walk (progn (function foo)))
+(take-it-out-for-a-test-walk (progn a b (go a)))
+(take-it-out-for-a-test-walk (if a b c))
+(take-it-out-for-a-test-walk (if a b))
+(take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2))
+(take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b))
+			      1 2))
+(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c)))
+(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c)))
+(take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
+                               (declare (special a b))
+                               (list a b c)))
+(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
+                               (declare (special a b))
+                               (list a b c)))
+(take-it-out-for-a-test-walk (let ((a 1) (b 2))
+                               (foo bar)
+                               (declare (special a))
+                               (foo a b)))
+(take-it-out-for-a-test-walk (multiple-value-call #'foo a b c))
+(take-it-out-for-a-test-walk (multiple-value-prog1 a b c))
+(take-it-out-for-a-test-walk (progn a b c))
+(take-it-out-for-a-test-walk (progv vars vals a b c))
+(take-it-out-for-a-test-walk (quote a))
+(take-it-out-for-a-test-walk (return-from block-name a b c))
+(take-it-out-for-a-test-walk (setq a 1))
+(take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3))
+(take-it-out-for-a-test-walk (tagbody a b c (go a)))
+(take-it-out-for-a-test-walk (the foo (foo-form a b c)))
+(take-it-out-for-a-test-walk (throw tag-form a))
+(take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f))
+
+(defmacro flet-1 (a b) ''outer)
+(defmacro labels-1 (a b) ''outer)
+
+(take-it-out-for-a-test-walk
+  (flet ((flet-1 (a b) () (flet-1 a b) (list a b)))
+    (flet-1 1 2)
+    (foo 1 2)))
+(take-it-out-for-a-test-walk
+  (labels ((label-1 (a b) () (label-1 a b)(list a b)))
+    (label-1 1 2)
+    (foo 1 2)))
+(take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
+                               (macrolet-1 a b)
+                               (foo 1 2)))
+
+(take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
+                               (foo 1)))
+
+(take-it-out-for-a-test-walk (progn (bar 1)
+                                    (macrolet ((bar (a)
+						 `(inner-bar-expanded ,a)))
+                                      (bar 2))))
+
+(take-it-out-for-a-test-walk (progn (bar 1)
+                                    (macrolet ((bar (s)
+						 (bar s)
+						 `(inner-bar-expanded ,s)))
+                                      (bar 2))))
+
+(take-it-out-for-a-test-walk (cond (a b)
+                                   ((foo bar) a (foo a))))
+
+
+(let ((the-lexical-variables ()))
+  (walk-form '(let ((a 1) (b 2))
+		#'(lambda (x) (list a b x y)))
+	     ()
+	     #'(lambda (form context env)
+		 (when (and (symbolp form)
+			    (variable-lexical-p form env))
+		   (push form the-lexical-variables))
+		 form))
+  (or (and (= (length the-lexical-variables) 3)
+	   (member 'a the-lexical-variables)
+	   (member 'b the-lexical-variables)
+	   (member 'x the-lexical-variables))
+      (error "Walker didn't do lexical variables of a closure properly.")))
+    
+|#
+
+()
diff --git a/clos/2.01big/CLOS-BROWSER.TEDIT b/clos/2.01big/CLOS-BROWSER.TEDIT
new file mode 100644
index 00000000..21d02b63
Binary files /dev/null and b/clos/2.01big/CLOS-BROWSER.TEDIT differ
diff --git a/clos/2.01big/NEW-CLOS-BROWSER.DFASL b/clos/2.01big/NEW-CLOS-BROWSER.DFASL
new file mode 100644
index 00000000..1add0989
Binary files /dev/null and b/clos/2.01big/NEW-CLOS-BROWSER.DFASL differ
diff --git a/clos/2.01big/WEB-EDITOR.DFASL b/clos/2.01big/WEB-EDITOR.DFASL
new file mode 100644
index 00000000..677def40
Binary files /dev/null and b/clos/2.01big/WEB-EDITOR.DFASL differ
diff --git a/clos/2.01big/boot.dfasl b/clos/2.01big/boot.dfasl
new file mode 100644
index 00000000..06971f5f
Binary files /dev/null and b/clos/2.01big/boot.dfasl differ
diff --git a/clos/2.01big/braid.dfasl b/clos/2.01big/braid.dfasl
new file mode 100644
index 00000000..6d0d54fa
Binary files /dev/null and b/clos/2.01big/braid.dfasl differ
diff --git a/clos/2.01big/cache.dfasl b/clos/2.01big/cache.dfasl
new file mode 100644
index 00000000..2371e8e0
Binary files /dev/null and b/clos/2.01big/cache.dfasl differ
diff --git a/clos/2.01big/clos-env-internal.DFASL b/clos/2.01big/clos-env-internal.DFASL
new file mode 100644
index 00000000..3f4811d6
Binary files /dev/null and b/clos/2.01big/clos-env-internal.DFASL differ
diff --git a/clos/2.01big/clos-env.DFASL b/clos/2.01big/clos-env.DFASL
new file mode 100644
index 00000000..34289504
Binary files /dev/null and b/clos/2.01big/clos-env.DFASL differ
diff --git a/clos/2.01big/combin.dfasl b/clos/2.01big/combin.dfasl
new file mode 100644
index 00000000..d5810482
Binary files /dev/null and b/clos/2.01big/combin.dfasl differ
diff --git a/clos/2.01big/compat.dfasl b/clos/2.01big/compat.dfasl
new file mode 100644
index 00000000..f0bae057
Binary files /dev/null and b/clos/2.01big/compat.dfasl differ
diff --git a/clos/2.01big/construct.dfasl b/clos/2.01big/construct.dfasl
new file mode 100644
index 00000000..fd30ec49
Binary files /dev/null and b/clos/2.01big/construct.dfasl differ
diff --git a/clos/2.01big/cpl.dfasl b/clos/2.01big/cpl.dfasl
new file mode 100644
index 00000000..e4334140
Binary files /dev/null and b/clos/2.01big/cpl.dfasl differ
diff --git a/clos/2.01big/ctypes.dfasl b/clos/2.01big/ctypes.dfasl
new file mode 100644
index 00000000..aea567f5
Binary files /dev/null and b/clos/2.01big/ctypes.dfasl differ
diff --git a/clos/2.01big/defclass.dfasl b/clos/2.01big/defclass.dfasl
new file mode 100644
index 00000000..7a37b676
Binary files /dev/null and b/clos/2.01big/defclass.dfasl differ
diff --git a/clos/2.01big/defcombin.dfasl b/clos/2.01big/defcombin.dfasl
new file mode 100644
index 00000000..3dd0d755
Binary files /dev/null and b/clos/2.01big/defcombin.dfasl differ
diff --git a/clos/2.01big/defs.dfasl b/clos/2.01big/defs.dfasl
new file mode 100644
index 00000000..1684e017
Binary files /dev/null and b/clos/2.01big/defs.dfasl differ
diff --git a/clos/2.01big/defsys.DFASL b/clos/2.01big/defsys.DFASL
new file mode 100644
index 00000000..748c1593
Binary files /dev/null and b/clos/2.01big/defsys.DFASL differ
diff --git a/clos/2.01big/dfun.dfasl b/clos/2.01big/dfun.dfasl
new file mode 100644
index 00000000..035d479a
Binary files /dev/null and b/clos/2.01big/dfun.dfasl differ
diff --git a/clos/2.01big/dlap.dfasl b/clos/2.01big/dlap.dfasl
new file mode 100644
index 00000000..cf52e2b1
Binary files /dev/null and b/clos/2.01big/dlap.dfasl differ
diff --git a/clos/2.01big/env.dfasl b/clos/2.01big/env.dfasl
new file mode 100644
index 00000000..decb1a80
Binary files /dev/null and b/clos/2.01big/env.dfasl differ
diff --git a/clos/2.01big/fin.dfasl b/clos/2.01big/fin.dfasl
new file mode 100644
index 00000000..715e2d29
Binary files /dev/null and b/clos/2.01big/fin.dfasl differ
diff --git a/clos/2.01big/fixup.dfasl b/clos/2.01big/fixup.dfasl
new file mode 100644
index 00000000..2f111caf
Binary files /dev/null and b/clos/2.01big/fixup.dfasl differ
diff --git a/clos/2.01big/fngen.dfasl b/clos/2.01big/fngen.dfasl
new file mode 100644
index 00000000..81212cd5
Binary files /dev/null and b/clos/2.01big/fngen.dfasl differ
diff --git a/clos/2.01big/fsc.dfasl b/clos/2.01big/fsc.dfasl
new file mode 100644
index 00000000..fff65ea9
Binary files /dev/null and b/clos/2.01big/fsc.dfasl differ
diff --git a/clos/2.01big/init.dfasl b/clos/2.01big/init.dfasl
new file mode 100644
index 00000000..ae72d647
Binary files /dev/null and b/clos/2.01big/init.dfasl differ
diff --git a/clos/2.01big/iterate.dfasl b/clos/2.01big/iterate.dfasl
new file mode 100644
index 00000000..ed34b9aa
Binary files /dev/null and b/clos/2.01big/iterate.dfasl differ
diff --git a/clos/2.01big/lap.dfasl b/clos/2.01big/lap.dfasl
new file mode 100644
index 00000000..f587ef04
Binary files /dev/null and b/clos/2.01big/lap.dfasl differ
diff --git a/clos/2.01big/load-clos.lisp b/clos/2.01big/load-clos.lisp
new file mode 100644
index 00000000..8ba7e9a2
--- /dev/null
+++ b/clos/2.01big/load-clos.lisp
@@ -0,0 +1,42 @@
+;;; -*- Mode: Lisp; Package: xcl-User ; Base: 10.; Syntax: Common-Lisp -*-
+;;;
+
+(in-package "CLOS" :use (list (or (find-package :walker)
+				    (make-package :walker :use '(:lisp)))
+				(or (find-package :iterate)
+				    (make-package :iterate
+						  :use '(:lisp :walker)))
+				(find-package :lisp)))
+(export (intern (symbol-name :iterate)		;Have to do this here,
+		(find-package :iterate))	;because in the defsystem
+	(find-package :iterate))		;(later in this file)
+						;we use the symbol iterate
+						;to name the file
+
+(defun load-truename (&optional (errorp nil))
+  (flet ((bad-time ()
+	   (when errorp
+	     (error "LOAD-TRUENAME called but a file isn't being loaded."))))
+    (let ((filename (pathname (il:fullname *standard-input*))))
+      (if filename
+	  (make-pathname :host (pathname-host filename) :device
+			 (pathname-device filename) :directory
+			 (pathname-directory filename) :name "") 
+	  (bad-time)))))
+
+(defvar *clos-directory* (load-truename))
+
+(defun load-clos (&optional pathname)
+  (defvar *clos-system-date* "7/14/91 Medley 2.0 (interim)")
+  (defvar *the-clos-package* (find-package :clos))
+  (dolist (filename '(patch pkg walk iterate macros low low2 fin
+		    defclass defs fngen lap plap cache dlap boot
+		    vector slots init std-class cpl braid fsc methods
+		    combin dfun precom1 precom2 precom4 fixup
+		    defcombin ctypes construct env))
+
+    (load (merge-pathnames 
+			 (make-pathname  :name (string-downcase filename) :type
+					 "dfasl") (or pathname *clos-directory*))))
+  (pushnew :clos cl:*features*))
+
diff --git a/clos/2.01big/low.dfasl b/clos/2.01big/low.dfasl
new file mode 100644
index 00000000..7ba900eb
Binary files /dev/null and b/clos/2.01big/low.dfasl differ
diff --git a/clos/2.01big/low2.dfasl b/clos/2.01big/low2.dfasl
new file mode 100644
index 00000000..f0e021c7
Binary files /dev/null and b/clos/2.01big/low2.dfasl differ
diff --git a/clos/2.01big/macros.dfasl b/clos/2.01big/macros.dfasl
new file mode 100644
index 00000000..c5900f91
Binary files /dev/null and b/clos/2.01big/macros.dfasl differ
diff --git a/clos/2.01big/methods.dfasl b/clos/2.01big/methods.dfasl
new file mode 100644
index 00000000..0d99a4ea
Binary files /dev/null and b/clos/2.01big/methods.dfasl differ
diff --git a/clos/2.01big/patch.dfasl b/clos/2.01big/patch.dfasl
new file mode 100644
index 00000000..23d002f8
Binary files /dev/null and b/clos/2.01big/patch.dfasl differ
diff --git a/clos/2.01big/pkg.dfasl b/clos/2.01big/pkg.dfasl
new file mode 100644
index 00000000..01eb5465
Binary files /dev/null and b/clos/2.01big/pkg.dfasl differ
diff --git a/clos/2.01big/plap.dfasl b/clos/2.01big/plap.dfasl
new file mode 100644
index 00000000..a0e96c70
Binary files /dev/null and b/clos/2.01big/plap.dfasl differ
diff --git a/clos/2.01big/precom1.dfasl b/clos/2.01big/precom1.dfasl
new file mode 100644
index 00000000..13c3abd2
Binary files /dev/null and b/clos/2.01big/precom1.dfasl differ
diff --git a/clos/2.01big/precom2.dfasl b/clos/2.01big/precom2.dfasl
new file mode 100644
index 00000000..633f8e42
Binary files /dev/null and b/clos/2.01big/precom2.dfasl differ
diff --git a/clos/2.01big/precom4.dfasl b/clos/2.01big/precom4.dfasl
new file mode 100644
index 00000000..f547707d
Binary files /dev/null and b/clos/2.01big/precom4.dfasl differ
diff --git a/clos/2.01big/slots.dfasl b/clos/2.01big/slots.dfasl
new file mode 100644
index 00000000..ef784156
Binary files /dev/null and b/clos/2.01big/slots.dfasl differ
diff --git a/clos/2.01big/std-class.dfasl b/clos/2.01big/std-class.dfasl
new file mode 100644
index 00000000..818e18c8
Binary files /dev/null and b/clos/2.01big/std-class.dfasl differ
diff --git a/clos/2.01big/vector.dfasl b/clos/2.01big/vector.dfasl
new file mode 100644
index 00000000..71697f84
Binary files /dev/null and b/clos/2.01big/vector.dfasl differ
diff --git a/clos/2.01big/walk.dfasl b/clos/2.01big/walk.dfasl
new file mode 100644
index 00000000..93c99e8f
Binary files /dev/null and b/clos/2.01big/walk.dfasl differ
diff --git a/fonts/altofonts/original/helvetica10.strike b/fonts/altofonts/original/helvetica10.strike
new file mode 100644
index 00000000..36809695
Binary files /dev/null and b/fonts/altofonts/original/helvetica10.strike differ
diff --git a/fonts/altofonts/original/helvetica12.strike b/fonts/altofonts/original/helvetica12.strike
new file mode 100644
index 00000000..198378ba
Binary files /dev/null and b/fonts/altofonts/original/helvetica12.strike differ
diff --git a/fonts/altofonts/original/helvetica14.strike b/fonts/altofonts/original/helvetica14.strike
new file mode 100644
index 00000000..3de64cfd
Binary files /dev/null and b/fonts/altofonts/original/helvetica14.strike differ
diff --git a/fonts/altofonts/original/helvetica18.strike b/fonts/altofonts/original/helvetica18.strike
new file mode 100644
index 00000000..95b07031
Binary files /dev/null and b/fonts/altofonts/original/helvetica18.strike differ
diff --git a/fonts/altofonts/original/helvetica7.strike b/fonts/altofonts/original/helvetica7.strike
new file mode 100644
index 00000000..c300b15c
Binary files /dev/null and b/fonts/altofonts/original/helvetica7.strike differ
diff --git a/fonts/altofonts/original/helvetica8.strike b/fonts/altofonts/original/helvetica8.strike
new file mode 100644
index 00000000..a09e008a
Binary files /dev/null and b/fonts/altofonts/original/helvetica8.strike differ
diff --git a/fonts/altofonts/original/hippo12.strike b/fonts/altofonts/original/hippo12.strike
new file mode 100644
index 00000000..741eac01
Binary files /dev/null and b/fonts/altofonts/original/hippo12.strike differ
diff --git a/fonts/altofonts/original/logo24.strike b/fonts/altofonts/original/logo24.strike
new file mode 100644
index 00000000..623dd3e3
Binary files /dev/null and b/fonts/altofonts/original/logo24.strike differ
diff --git a/fonts/altofonts/original/math10.strike b/fonts/altofonts/original/math10.strike
new file mode 100644
index 00000000..f2fb2fe7
Binary files /dev/null and b/fonts/altofonts/original/math10.strike differ
diff --git a/fonts/altofonts/original/timesroman10.strike b/fonts/altofonts/original/timesroman10.strike
new file mode 100644
index 00000000..6ad608ff
Binary files /dev/null and b/fonts/altofonts/original/timesroman10.strike differ
diff --git a/fonts/altofonts/original/timesroman12.strike b/fonts/altofonts/original/timesroman12.strike
new file mode 100644
index 00000000..39a4c1cf
Binary files /dev/null and b/fonts/altofonts/original/timesroman12.strike differ
diff --git a/fonts/altofonts/original/timesroman14.strike b/fonts/altofonts/original/timesroman14.strike
new file mode 100644
index 00000000..8d440ac9
Binary files /dev/null and b/fonts/altofonts/original/timesroman14.strike differ
diff --git a/fonts/altofonts/original/timesroman18.strike b/fonts/altofonts/original/timesroman18.strike
new file mode 100644
index 00000000..6add13d5
Binary files /dev/null and b/fonts/altofonts/original/timesroman18.strike differ
diff --git a/fonts/altofonts/original/timesroman8.strike b/fonts/altofonts/original/timesroman8.strike
new file mode 100644
index 00000000..0a70b5a4
Binary files /dev/null and b/fonts/altofonts/original/timesroman8.strike differ
diff --git a/fonts/altofonts/roundedwidths/helvetica10.strike b/fonts/altofonts/roundedwidths/helvetica10.strike
new file mode 100644
index 00000000..1b2b063f
Binary files /dev/null and b/fonts/altofonts/roundedwidths/helvetica10.strike differ
diff --git a/fonts/altofonts/roundedwidths/helvetica11.strike b/fonts/altofonts/roundedwidths/helvetica11.strike
new file mode 100644
index 00000000..a8efc26e
Binary files /dev/null and b/fonts/altofonts/roundedwidths/helvetica11.strike differ
diff --git a/fonts/altofonts/roundedwidths/helvetica12.strike b/fonts/altofonts/roundedwidths/helvetica12.strike
new file mode 100644
index 00000000..aaa5b0df
Binary files /dev/null and b/fonts/altofonts/roundedwidths/helvetica12.strike differ
diff --git a/fonts/altofonts/roundedwidths/helvetica14.strike b/fonts/altofonts/roundedwidths/helvetica14.strike
new file mode 100644
index 00000000..b7be1cfa
Binary files /dev/null and b/fonts/altofonts/roundedwidths/helvetica14.strike differ
diff --git a/fonts/altofonts/roundedwidths/helvetica18.strike b/fonts/altofonts/roundedwidths/helvetica18.strike
new file mode 100644
index 00000000..248d8084
Binary files /dev/null and b/fonts/altofonts/roundedwidths/helvetica18.strike differ
diff --git a/fonts/altofonts/roundedwidths/helvetica8.strike b/fonts/altofonts/roundedwidths/helvetica8.strike
new file mode 100644
index 00000000..88489112
Binary files /dev/null and b/fonts/altofonts/roundedwidths/helvetica8.strike differ
diff --git a/fonts/altofonts/roundedwidths/helvetica9.strike b/fonts/altofonts/roundedwidths/helvetica9.strike
new file mode 100644
index 00000000..6c0f77f7
Binary files /dev/null and b/fonts/altofonts/roundedwidths/helvetica9.strike differ
diff --git a/fonts/altofonts/roundedwidths/hippo10.strike b/fonts/altofonts/roundedwidths/hippo10.strike
new file mode 100644
index 00000000..58ab9552
Binary files /dev/null and b/fonts/altofonts/roundedwidths/hippo10.strike differ
diff --git a/fonts/altofonts/roundedwidths/hippo8.strike b/fonts/altofonts/roundedwidths/hippo8.strike
new file mode 100644
index 00000000..0b5af26d
Binary files /dev/null and b/fonts/altofonts/roundedwidths/hippo8.strike differ
diff --git a/fonts/altofonts/roundedwidths/logo24.strike b/fonts/altofonts/roundedwidths/logo24.strike
new file mode 100644
index 00000000..ce0cc359
Binary files /dev/null and b/fonts/altofonts/roundedwidths/logo24.strike differ
diff --git a/fonts/altofonts/roundedwidths/timesroman10.strike b/fonts/altofonts/roundedwidths/timesroman10.strike
new file mode 100644
index 00000000..86287b88
Binary files /dev/null and b/fonts/altofonts/roundedwidths/timesroman10.strike differ
diff --git a/fonts/altofonts/roundedwidths/timesroman11.strike b/fonts/altofonts/roundedwidths/timesroman11.strike
new file mode 100644
index 00000000..7061c4e2
Binary files /dev/null and b/fonts/altofonts/roundedwidths/timesroman11.strike differ
diff --git a/fonts/altofonts/roundedwidths/timesroman12.strike b/fonts/altofonts/roundedwidths/timesroman12.strike
new file mode 100644
index 00000000..1c63c8af
Binary files /dev/null and b/fonts/altofonts/roundedwidths/timesroman12.strike differ
diff --git a/fonts/altofonts/roundedwidths/timesroman14.strike b/fonts/altofonts/roundedwidths/timesroman14.strike
new file mode 100644
index 00000000..a7c8d1d3
Binary files /dev/null and b/fonts/altofonts/roundedwidths/timesroman14.strike differ
diff --git a/fonts/altofonts/roundedwidths/timesroman18.strike b/fonts/altofonts/roundedwidths/timesroman18.strike
new file mode 100644
index 00000000..b13455ce
Binary files /dev/null and b/fonts/altofonts/roundedwidths/timesroman18.strike differ
diff --git a/fonts/altofonts/roundedwidths/timesroman8.strike b/fonts/altofonts/roundedwidths/timesroman8.strike
new file mode 100644
index 00000000..82efcc39
Binary files /dev/null and b/fonts/altofonts/roundedwidths/timesroman8.strike differ
diff --git a/fonts/altofonts/roundedwidths/timesroman9.strike b/fonts/altofonts/roundedwidths/timesroman9.strike
new file mode 100644
index 00000000..9e277649
Binary files /dev/null and b/fonts/altofonts/roundedwidths/timesroman9.strike differ
diff --git a/fonts/altofonts/roundedwidths/timesromand24.strike b/fonts/altofonts/roundedwidths/timesromand24.strike
new file mode 100644
index 00000000..fd294b99
Binary files /dev/null and b/fonts/altofonts/roundedwidths/timesromand24.strike differ
diff --git a/fonts/altofonts/roundedwidths/timesromand30.strike b/fonts/altofonts/roundedwidths/timesromand30.strike
new file mode 100644
index 00000000..614d0c3b
Binary files /dev/null and b/fonts/altofonts/roundedwidths/timesromand30.strike differ
diff --git a/fonts/altofonts/roundedwidths/timesromand36.strike b/fonts/altofonts/roundedwidths/timesromand36.strike
new file mode 100644
index 00000000..0daa9c0e
Binary files /dev/null and b/fonts/altofonts/roundedwidths/timesromand36.strike differ
diff --git a/fontsold/displayfonts/JIS1/CLASSIC18-MRR-C67.DISPLAYFONT b/fontsold/displayfonts/JIS1/CLASSIC18-MRR-C67.DISPLAYFONT
new file mode 100644
index 00000000..9e755608
Binary files /dev/null and b/fontsold/displayfonts/JIS1/CLASSIC18-MRR-C67.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/chinese/CLASSIC24-MRR-C243.DISPLAYFONT b/fontsold/displayfonts/chinese/CLASSIC24-MRR-C243.DISPLAYFONT
new file mode 100644
index 00000000..f856f917
Binary files /dev/null and b/fontsold/displayfonts/chinese/CLASSIC24-MRR-C243.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/chinese/MODERN12-MRR-C261.DISPLAYFONT b/fontsold/displayfonts/chinese/MODERN12-MRR-C261.DISPLAYFONT
new file mode 100644
index 00000000..5eca935f
Binary files /dev/null and b/fontsold/displayfonts/chinese/MODERN12-MRR-C261.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/presentation/GACHA08-MRR-C0.DISPLAYFONT b/fontsold/displayfonts/presentation/GACHA08-MRR-C0.DISPLAYFONT
new file mode 100644
index 00000000..acecd86f
Binary files /dev/null and b/fontsold/displayfonts/presentation/GACHA08-MRR-C0.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/presentation/GACHA08-MRR-C0.DISPLAYFONT.~1~ b/fontsold/displayfonts/presentation/GACHA08-MRR-C0.DISPLAYFONT.~1~
new file mode 100644
index 00000000..5e194ea0
Binary files /dev/null and b/fontsold/displayfonts/presentation/GACHA08-MRR-C0.DISPLAYFONT.~1~ differ
diff --git a/fontsold/displayfonts/presentation/GACHA10-MRR-C0.DISPLAYFONT b/fontsold/displayfonts/presentation/GACHA10-MRR-C0.DISPLAYFONT
new file mode 100644
index 00000000..fa862224
Binary files /dev/null and b/fontsold/displayfonts/presentation/GACHA10-MRR-C0.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/presentation/GACHA10-MRR-C0.DISPLAYFONT.~1~ b/fontsold/displayfonts/presentation/GACHA10-MRR-C0.DISPLAYFONT.~1~
new file mode 100644
index 00000000..cdea2d85
Binary files /dev/null and b/fontsold/displayfonts/presentation/GACHA10-MRR-C0.DISPLAYFONT.~1~ differ
diff --git a/fontsold/displayfonts/presentation/TIMESROMAN07-BRR-C0.DISPLAYFONT b/fontsold/displayfonts/presentation/TIMESROMAN07-BRR-C0.DISPLAYFONT
new file mode 100644
index 00000000..b1478f48
Binary files /dev/null and b/fontsold/displayfonts/presentation/TIMESROMAN07-BRR-C0.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/presentation/TIMESROMAN07-MRR-C0.DISPLAYFONT b/fontsold/displayfonts/presentation/TIMESROMAN07-MRR-C0.DISPLAYFONT
new file mode 100644
index 00000000..3517802e
Binary files /dev/null and b/fontsold/displayfonts/presentation/TIMESROMAN07-MRR-C0.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-BIR-C0.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-BIR-C0.DISPLAYFONT
new file mode 100644
index 00000000..5515351c
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-BIR-C0.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-BIR-C356.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-BIR-C356.DISPLAYFONT
new file mode 100644
index 00000000..41e8161b
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-BIR-C356.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-BIR-C357.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-BIR-C357.DISPLAYFONT
new file mode 100644
index 00000000..137b8c82
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-BIR-C357.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-BIR-C361.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-BIR-C361.DISPLAYFONT
new file mode 100644
index 00000000..90b23135
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-BIR-C361.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-BIR-C41.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-BIR-C41.DISPLAYFONT
new file mode 100644
index 00000000..307c206f
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-BIR-C41.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-BRR-C0.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-BRR-C0.DISPLAYFONT
new file mode 100644
index 00000000..7a5e65b1
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-BRR-C0.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-BRR-C357.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-BRR-C357.DISPLAYFONT
new file mode 100644
index 00000000..ed354396
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-BRR-C357.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-BRR-C361.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-BRR-C361.DISPLAYFONT
new file mode 100644
index 00000000..5adeae02
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-BRR-C361.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-BRR-C41.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-BRR-C41.DISPLAYFONT
new file mode 100644
index 00000000..03c516b3
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-BRR-C41.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-MIR-C0.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-MIR-C0.DISPLAYFONT
new file mode 100644
index 00000000..14ecda66
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-MIR-C0.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-MIR-C356.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-MIR-C356.DISPLAYFONT
new file mode 100644
index 00000000..bdf8a990
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-MIR-C356.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-MIR-C357.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-MIR-C357.DISPLAYFONT
new file mode 100644
index 00000000..15033ed3
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-MIR-C357.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-MIR-C361.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-MIR-C361.DISPLAYFONT
new file mode 100644
index 00000000..5e9552c1
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-MIR-C361.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-MIR-C41.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-MIR-C41.DISPLAYFONT
new file mode 100644
index 00000000..622011e1
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-MIR-C41.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-MRR-C0.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-MRR-C0.DISPLAYFONT
new file mode 100644
index 00000000..32909c50
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-MRR-C0.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-MRR-C357.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-MRR-C357.DISPLAYFONT
new file mode 100644
index 00000000..2b766154
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-MRR-C357.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-MRR-C361.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-MRR-C361.DISPLAYFONT
new file mode 100644
index 00000000..f29aca30
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-MRR-C361.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN06-MRR-C41.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN06-MRR-C41.DISPLAYFONT
new file mode 100644
index 00000000..5376e147
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN06-MRR-C41.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-BIR-C0.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-BIR-C0.DISPLAYFONT
new file mode 100644
index 00000000..5515351c
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-BIR-C0.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-BIR-C356.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-BIR-C356.DISPLAYFONT
new file mode 100644
index 00000000..41e8161b
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-BIR-C356.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-BIR-C357.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-BIR-C357.DISPLAYFONT
new file mode 100644
index 00000000..137b8c82
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-BIR-C357.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-BIR-C361.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-BIR-C361.DISPLAYFONT
new file mode 100644
index 00000000..90b23135
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-BIR-C361.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-BIR-C41.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-BIR-C41.DISPLAYFONT
new file mode 100644
index 00000000..307c206f
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-BIR-C41.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-BRR-C0.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-BRR-C0.DISPLAYFONT
new file mode 100644
index 00000000..7a5e65b1
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-BRR-C0.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-BRR-C357.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-BRR-C357.DISPLAYFONT
new file mode 100644
index 00000000..ed354396
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-BRR-C357.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-BRR-C361.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-BRR-C361.DISPLAYFONT
new file mode 100644
index 00000000..5adeae02
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-BRR-C361.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-BRR-C41.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-BRR-C41.DISPLAYFONT
new file mode 100644
index 00000000..03c516b3
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-BRR-C41.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-MIR-C0.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-MIR-C0.DISPLAYFONT
new file mode 100644
index 00000000..14ecda66
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-MIR-C0.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-MIR-C356.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-MIR-C356.DISPLAYFONT
new file mode 100644
index 00000000..bdf8a990
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-MIR-C356.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-MIR-C357.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-MIR-C357.DISPLAYFONT
new file mode 100644
index 00000000..15033ed3
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-MIR-C357.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-MIR-C361.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-MIR-C361.DISPLAYFONT
new file mode 100644
index 00000000..5e9552c1
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-MIR-C361.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-MIR-C41.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-MIR-C41.DISPLAYFONT
new file mode 100644
index 00000000..622011e1
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-MIR-C41.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-MRR-C0.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-MRR-C0.DISPLAYFONT
new file mode 100644
index 00000000..32909c50
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-MRR-C0.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-MRR-C357.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-MRR-C357.DISPLAYFONT
new file mode 100644
index 00000000..2b766154
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-MRR-C357.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-MRR-C361.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-MRR-C361.DISPLAYFONT
new file mode 100644
index 00000000..f29aca30
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-MRR-C361.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN09-MRR-C41.DISPLAYFONT b/fontsold/displayfonts/printwheel/TITAN09-MRR-C41.DISPLAYFONT
new file mode 100644
index 00000000..5376e147
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN09-MRR-C41.DISPLAYFONT differ
diff --git a/fontsold/displayfonts/printwheel/TITAN10-MRR-C0.DISPLAYFONT.~2~ b/fontsold/displayfonts/printwheel/TITAN10-MRR-C0.DISPLAYFONT.~2~
new file mode 100644
index 00000000..32909c50
Binary files /dev/null and b/fontsold/displayfonts/printwheel/TITAN10-MRR-C0.DISPLAYFONT.~2~ differ
diff --git a/fontsold/displayfonts/publishing/MODERN30-MIR-C0.DISPLAYFONT b/fontsold/displayfonts/publishing/MODERN30-MIR-C0.DISPLAYFONT
new file mode 100644
index 00000000..0b29ad9b
Binary files /dev/null and b/fontsold/displayfonts/publishing/MODERN30-MIR-C0.DISPLAYFONT differ
diff --git a/fontsold/ipfonts/JIS1/CLASSIC10-MRR-C71.WD b/fontsold/ipfonts/JIS1/CLASSIC10-MRR-C71.WD
new file mode 100644
index 00000000..4ecb5406
Binary files /dev/null and b/fontsold/ipfonts/JIS1/CLASSIC10-MRR-C71.WD differ
diff --git a/fontsold/ipfonts/JIS2/CLASSIC14-MRR-C146.WD b/fontsold/ipfonts/JIS2/CLASSIC14-MRR-C146.WD
new file mode 100644
index 00000000..f0a259c9
Binary files /dev/null and b/fontsold/ipfonts/JIS2/CLASSIC14-MRR-C146.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-BIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA06-BIR-C0.WD
new file mode 100644
index 00000000..a8cb4bf0
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-BIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-BIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA06-BIR-C356.WD
new file mode 100644
index 00000000..65f560bc
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-BIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-BIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA06-BIR-C357.WD
new file mode 100644
index 00000000..ffa8d8e3
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-BIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-BIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA06-BIR-C360.WD
new file mode 100644
index 00000000..2218eea4
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-BIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-BIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA06-BIR-C361.WD
new file mode 100644
index 00000000..c3ba0ec6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-BIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-BIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA06-BIR-C41.WD
new file mode 100644
index 00000000..4cb4129d
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-BIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-BIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA06-BIR-C42.WD
new file mode 100644
index 00000000..ffa9554e
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-BIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-BIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA06-BIR-C43.WD
new file mode 100644
index 00000000..2681100c
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-BIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-BRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA06-BRR-C0.WD
new file mode 100644
index 00000000..265a947d
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-BRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-BRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA06-BRR-C356.WD
new file mode 100644
index 00000000..34b94ecc
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-BRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-BRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA06-BRR-C357.WD
new file mode 100644
index 00000000..c5537795
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-BRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-BRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA06-BRR-C360.WD
new file mode 100644
index 00000000..0c3eee59
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-BRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-BRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA06-BRR-C361.WD
new file mode 100644
index 00000000..447a5704
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-BRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-BRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA06-BRR-C41.WD
new file mode 100644
index 00000000..20a6f6c5
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-BRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-BRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA06-BRR-C42.WD
new file mode 100644
index 00000000..e7bda0d3
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-BRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-BRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA06-BRR-C43.WD
new file mode 100644
index 00000000..5ef66ab6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-BRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-MIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA06-MIR-C0.WD
new file mode 100644
index 00000000..3388573e
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-MIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-MIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA06-MIR-C356.WD
new file mode 100644
index 00000000..aa8109d6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-MIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-MIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA06-MIR-C357.WD
new file mode 100644
index 00000000..47190ac7
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-MIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-MIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA06-MIR-C360.WD
new file mode 100644
index 00000000..2d1f988f
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-MIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-MIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA06-MIR-C361.WD
new file mode 100644
index 00000000..420069e2
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-MIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-MIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA06-MIR-C41.WD
new file mode 100644
index 00000000..c801e5ca
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-MIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-MIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA06-MIR-C42.WD
new file mode 100644
index 00000000..340aeb7d
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-MIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-MIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA06-MIR-C43.WD
new file mode 100644
index 00000000..8854b13d
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-MIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-MRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA06-MRR-C0.WD
new file mode 100644
index 00000000..b8f64afa
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-MRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-MRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA06-MRR-C356.WD
new file mode 100644
index 00000000..d58483b5
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-MRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-MRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA06-MRR-C357.WD
new file mode 100644
index 00000000..d9e0a271
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-MRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-MRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA06-MRR-C360.WD
new file mode 100644
index 00000000..7bea3b1d
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-MRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-MRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA06-MRR-C361.WD
new file mode 100644
index 00000000..df16ddcf
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-MRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-MRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA06-MRR-C41.WD
new file mode 100644
index 00000000..75c3dc83
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-MRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-MRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA06-MRR-C42.WD
new file mode 100644
index 00000000..3052f345
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-MRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA06-MRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA06-MRR-C43.WD
new file mode 100644
index 00000000..a1e894a2
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA06-MRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-BIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA07-BIR-C0.WD
new file mode 100644
index 00000000..a55ae131
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-BIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-BIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA07-BIR-C356.WD
new file mode 100644
index 00000000..71e3cba1
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-BIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-BIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA07-BIR-C357.WD
new file mode 100644
index 00000000..3f1a53a3
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-BIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-BIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA07-BIR-C360.WD
new file mode 100644
index 00000000..2d0d5406
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-BIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-BIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA07-BIR-C361.WD
new file mode 100644
index 00000000..590b3de6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-BIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-BIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA07-BIR-C41.WD
new file mode 100644
index 00000000..51bc4d6b
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-BIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-BIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA07-BIR-C42.WD
new file mode 100644
index 00000000..22442fd8
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-BIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-BIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA07-BIR-C43.WD
new file mode 100644
index 00000000..31f176f3
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-BIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-BRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA07-BRR-C0.WD
new file mode 100644
index 00000000..fc75e736
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-BRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-BRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA07-BRR-C356.WD
new file mode 100644
index 00000000..fef4324c
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-BRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-BRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA07-BRR-C357.WD
new file mode 100644
index 00000000..702048e9
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-BRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-BRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA07-BRR-C360.WD
new file mode 100644
index 00000000..233683d6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-BRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-BRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA07-BRR-C361.WD
new file mode 100644
index 00000000..89c845b9
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-BRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-BRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA07-BRR-C41.WD
new file mode 100644
index 00000000..99e96c6e
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-BRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-BRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA07-BRR-C42.WD
new file mode 100644
index 00000000..cd378e4c
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-BRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-BRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA07-BRR-C43.WD
new file mode 100644
index 00000000..547e7709
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-BRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-MIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA07-MIR-C0.WD
new file mode 100644
index 00000000..823b58d4
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-MIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-MIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA07-MIR-C356.WD
new file mode 100644
index 00000000..501350b6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-MIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-MIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA07-MIR-C357.WD
new file mode 100644
index 00000000..672d8d41
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-MIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-MIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA07-MIR-C360.WD
new file mode 100644
index 00000000..34bee25d
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-MIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-MIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA07-MIR-C361.WD
new file mode 100644
index 00000000..5608484f
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-MIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-MIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA07-MIR-C41.WD
new file mode 100644
index 00000000..e97d672d
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-MIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-MIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA07-MIR-C42.WD
new file mode 100644
index 00000000..36305d35
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-MIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-MIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA07-MIR-C43.WD
new file mode 100644
index 00000000..e2b56c73
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-MIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-MRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA07-MRR-C0.WD
new file mode 100644
index 00000000..5dd6522c
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-MRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-MRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA07-MRR-C356.WD
new file mode 100644
index 00000000..bd74a7d4
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-MRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-MRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA07-MRR-C357.WD
new file mode 100644
index 00000000..c108aa55
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-MRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-MRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA07-MRR-C360.WD
new file mode 100644
index 00000000..91ca0484
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-MRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-MRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA07-MRR-C361.WD
new file mode 100644
index 00000000..ec2144f6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-MRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-MRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA07-MRR-C41.WD
new file mode 100644
index 00000000..a9f941bf
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-MRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-MRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA07-MRR-C42.WD
new file mode 100644
index 00000000..9362396f
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-MRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA07-MRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA07-MRR-C43.WD
new file mode 100644
index 00000000..1296e55b
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA07-MRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-BIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA08-BIR-C0.WD
new file mode 100644
index 00000000..41cceccd
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-BIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-BIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA08-BIR-C356.WD
new file mode 100644
index 00000000..3704c475
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-BIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-BIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA08-BIR-C357.WD
new file mode 100644
index 00000000..80a264c3
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-BIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-BIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA08-BIR-C360.WD
new file mode 100644
index 00000000..ad9f64a2
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-BIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-BIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA08-BIR-C361.WD
new file mode 100644
index 00000000..564e55a9
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-BIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-BIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA08-BIR-C41.WD
new file mode 100644
index 00000000..5e8d7f20
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-BIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-BIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA08-BIR-C42.WD
new file mode 100644
index 00000000..6c7e8541
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-BIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-BIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA08-BIR-C43.WD
new file mode 100644
index 00000000..c1cf2c3e
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-BIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-BRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA08-BRR-C0.WD
new file mode 100644
index 00000000..d7a2fa5e
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-BRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-BRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA08-BRR-C356.WD
new file mode 100644
index 00000000..6898fbb4
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-BRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-BRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA08-BRR-C357.WD
new file mode 100644
index 00000000..00f741ef
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-BRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-BRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA08-BRR-C360.WD
new file mode 100644
index 00000000..b8b223f8
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-BRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-BRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA08-BRR-C361.WD
new file mode 100644
index 00000000..ed4ba9e5
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-BRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-BRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA08-BRR-C41.WD
new file mode 100644
index 00000000..21687e46
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-BRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-BRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA08-BRR-C42.WD
new file mode 100644
index 00000000..be98b044
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-BRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-BRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA08-BRR-C43.WD
new file mode 100644
index 00000000..1b2134e1
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-BRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-MIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA08-MIR-C0.WD
new file mode 100644
index 00000000..4ceea2ae
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-MIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-MIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA08-MIR-C356.WD
new file mode 100644
index 00000000..c84a29fe
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-MIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-MIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA08-MIR-C357.WD
new file mode 100644
index 00000000..67c1e332
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-MIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-MIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA08-MIR-C360.WD
new file mode 100644
index 00000000..8f060fb5
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-MIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-MIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA08-MIR-C361.WD
new file mode 100644
index 00000000..ae03c655
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-MIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-MIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA08-MIR-C41.WD
new file mode 100644
index 00000000..97ca4e40
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-MIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-MIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA08-MIR-C42.WD
new file mode 100644
index 00000000..4b2066d0
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-MIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-MIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA08-MIR-C43.WD
new file mode 100644
index 00000000..7f275f86
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-MIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-MRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA08-MRR-C0.WD
new file mode 100644
index 00000000..51f81db7
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-MRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-MRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA08-MRR-C356.WD
new file mode 100644
index 00000000..4b0ef3d1
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-MRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-MRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA08-MRR-C357.WD
new file mode 100644
index 00000000..fc4f5bc7
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-MRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-MRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA08-MRR-C360.WD
new file mode 100644
index 00000000..c4e669e2
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-MRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-MRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA08-MRR-C361.WD
new file mode 100644
index 00000000..146111c1
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-MRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-MRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA08-MRR-C41.WD
new file mode 100644
index 00000000..1e9a1923
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-MRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-MRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA08-MRR-C42.WD
new file mode 100644
index 00000000..0c1b7a72
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-MRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA08-MRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA08-MRR-C43.WD
new file mode 100644
index 00000000..f4efb5d3
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA08-MRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-BIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA09-BIR-C0.WD
new file mode 100644
index 00000000..d42433f1
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-BIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-BIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA09-BIR-C356.WD
new file mode 100644
index 00000000..5a5aa6c8
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-BIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-BIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA09-BIR-C357.WD
new file mode 100644
index 00000000..24d12c72
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-BIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-BIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA09-BIR-C360.WD
new file mode 100644
index 00000000..cce77664
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-BIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-BIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA09-BIR-C361.WD
new file mode 100644
index 00000000..95908ca0
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-BIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-BIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA09-BIR-C41.WD
new file mode 100644
index 00000000..59282e55
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-BIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-BIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA09-BIR-C42.WD
new file mode 100644
index 00000000..36f9cd9b
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-BIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-BIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA09-BIR-C43.WD
new file mode 100644
index 00000000..8f92f169
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-BIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-BRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA09-BRR-C0.WD
new file mode 100644
index 00000000..b84175e0
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-BRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-BRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA09-BRR-C356.WD
new file mode 100644
index 00000000..19321a87
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-BRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-BRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA09-BRR-C357.WD
new file mode 100644
index 00000000..2b7a6693
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-BRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-BRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA09-BRR-C360.WD
new file mode 100644
index 00000000..cb447171
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-BRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-BRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA09-BRR-C361.WD
new file mode 100644
index 00000000..0f634d09
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-BRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-BRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA09-BRR-C41.WD
new file mode 100644
index 00000000..93e1e5b4
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-BRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-BRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA09-BRR-C42.WD
new file mode 100644
index 00000000..fe56dd27
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-BRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-BRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA09-BRR-C43.WD
new file mode 100644
index 00000000..ec3ed880
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-BRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-MIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA09-MIR-C0.WD
new file mode 100644
index 00000000..ec9929f3
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-MIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-MIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA09-MIR-C356.WD
new file mode 100644
index 00000000..e22523a0
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-MIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-MIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA09-MIR-C357.WD
new file mode 100644
index 00000000..0ce9bfac
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-MIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-MIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA09-MIR-C360.WD
new file mode 100644
index 00000000..096fa508
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-MIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-MIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA09-MIR-C361.WD
new file mode 100644
index 00000000..26b36cb4
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-MIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-MIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA09-MIR-C41.WD
new file mode 100644
index 00000000..67fa4d57
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-MIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-MIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA09-MIR-C42.WD
new file mode 100644
index 00000000..41080caf
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-MIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-MIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA09-MIR-C43.WD
new file mode 100644
index 00000000..91ea6c55
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-MIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-MRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA09-MRR-C0.WD
new file mode 100644
index 00000000..bb216269
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-MRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-MRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA09-MRR-C356.WD
new file mode 100644
index 00000000..a19d3890
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-MRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-MRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA09-MRR-C357.WD
new file mode 100644
index 00000000..d3f6c8e8
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-MRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-MRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA09-MRR-C360.WD
new file mode 100644
index 00000000..cc9e3302
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-MRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-MRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA09-MRR-C361.WD
new file mode 100644
index 00000000..bde5ed41
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-MRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-MRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA09-MRR-C41.WD
new file mode 100644
index 00000000..ddb3d98d
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-MRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-MRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA09-MRR-C42.WD
new file mode 100644
index 00000000..3b7dd0ec
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-MRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA09-MRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA09-MRR-C43.WD
new file mode 100644
index 00000000..fd281ad5
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA09-MRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-BIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA10-BIR-C0.WD
new file mode 100644
index 00000000..e99266f3
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-BIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-BIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA10-BIR-C356.WD
new file mode 100644
index 00000000..62317bfd
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-BIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-BIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA10-BIR-C357.WD
new file mode 100644
index 00000000..1d5c4f62
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-BIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-BIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA10-BIR-C360.WD
new file mode 100644
index 00000000..f73eed88
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-BIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-BIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA10-BIR-C361.WD
new file mode 100644
index 00000000..050174a3
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-BIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-BIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA10-BIR-C41.WD
new file mode 100644
index 00000000..98989cd6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-BIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-BIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA10-BIR-C42.WD
new file mode 100644
index 00000000..5b3118c6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-BIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-BIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA10-BIR-C43.WD
new file mode 100644
index 00000000..486340a2
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-BIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-BRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA10-BRR-C0.WD
new file mode 100644
index 00000000..e17c8b7d
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-BRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-BRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA10-BRR-C356.WD
new file mode 100644
index 00000000..5180c3c6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-BRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-BRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA10-BRR-C357.WD
new file mode 100644
index 00000000..b2d04201
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-BRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-BRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA10-BRR-C360.WD
new file mode 100644
index 00000000..8de50bf5
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-BRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-BRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA10-BRR-C361.WD
new file mode 100644
index 00000000..eafdb1da
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-BRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-BRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA10-BRR-C41.WD
new file mode 100644
index 00000000..78bc4f48
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-BRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-BRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA10-BRR-C42.WD
new file mode 100644
index 00000000..aa332992
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-BRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-BRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA10-BRR-C43.WD
new file mode 100644
index 00000000..a976cb5f
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-BRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-MIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA10-MIR-C0.WD
new file mode 100644
index 00000000..6f5df222
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-MIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-MIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA10-MIR-C356.WD
new file mode 100644
index 00000000..ce71e7d6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-MIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-MIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA10-MIR-C357.WD
new file mode 100644
index 00000000..d1d6dbd3
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-MIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-MIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA10-MIR-C360.WD
new file mode 100644
index 00000000..1423e320
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-MIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-MIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA10-MIR-C361.WD
new file mode 100644
index 00000000..48214dc6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-MIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-MIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA10-MIR-C41.WD
new file mode 100644
index 00000000..f190ce93
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-MIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-MIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA10-MIR-C42.WD
new file mode 100644
index 00000000..bb0ae6c8
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-MIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-MIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA10-MIR-C43.WD
new file mode 100644
index 00000000..f7dc07a5
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-MIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-MRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA10-MRR-C0.WD
new file mode 100644
index 00000000..eb9bdbda
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-MRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-MRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA10-MRR-C356.WD
new file mode 100644
index 00000000..ccefa232
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-MRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-MRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA10-MRR-C357.WD
new file mode 100644
index 00000000..3a6ec9af
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-MRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-MRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA10-MRR-C360.WD
new file mode 100644
index 00000000..eb0f3d2b
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-MRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-MRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA10-MRR-C361.WD
new file mode 100644
index 00000000..42c35a07
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-MRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-MRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA10-MRR-C41.WD
new file mode 100644
index 00000000..5a8d648a
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-MRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-MRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA10-MRR-C42.WD
new file mode 100644
index 00000000..0998de48
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-MRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA10-MRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA10-MRR-C43.WD
new file mode 100644
index 00000000..b83aaeca
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA10-MRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-BIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA11-BIR-C0.WD
new file mode 100644
index 00000000..d1f5bdd2
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-BIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-BIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA11-BIR-C356.WD
new file mode 100644
index 00000000..e6a027c1
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-BIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-BIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA11-BIR-C357.WD
new file mode 100644
index 00000000..72f19f4c
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-BIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-BIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA11-BIR-C360.WD
new file mode 100644
index 00000000..8713b793
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-BIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-BIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA11-BIR-C361.WD
new file mode 100644
index 00000000..1916cd1e
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-BIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-BIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA11-BIR-C41.WD
new file mode 100644
index 00000000..9d1ef857
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-BIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-BIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA11-BIR-C42.WD
new file mode 100644
index 00000000..d2673bea
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-BIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-BIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA11-BIR-C43.WD
new file mode 100644
index 00000000..52daec0a
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-BIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-BRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA11-BRR-C0.WD
new file mode 100644
index 00000000..ccea7cc1
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-BRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-BRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA11-BRR-C356.WD
new file mode 100644
index 00000000..ca82a5a9
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-BRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-BRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA11-BRR-C357.WD
new file mode 100644
index 00000000..4180b52b
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-BRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-BRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA11-BRR-C360.WD
new file mode 100644
index 00000000..b03511ec
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-BRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-BRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA11-BRR-C361.WD
new file mode 100644
index 00000000..95f2b59a
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-BRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-BRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA11-BRR-C41.WD
new file mode 100644
index 00000000..289a231e
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-BRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-BRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA11-BRR-C42.WD
new file mode 100644
index 00000000..29547ad2
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-BRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-BRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA11-BRR-C43.WD
new file mode 100644
index 00000000..86555a46
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-BRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-MIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA11-MIR-C0.WD
new file mode 100644
index 00000000..9eff1aa5
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-MIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-MIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA11-MIR-C356.WD
new file mode 100644
index 00000000..e8484388
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-MIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-MIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA11-MIR-C357.WD
new file mode 100644
index 00000000..28b94560
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-MIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-MIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA11-MIR-C360.WD
new file mode 100644
index 00000000..6e97eafc
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-MIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-MIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA11-MIR-C361.WD
new file mode 100644
index 00000000..27c1f006
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-MIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-MIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA11-MIR-C41.WD
new file mode 100644
index 00000000..10017e81
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-MIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-MIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA11-MIR-C42.WD
new file mode 100644
index 00000000..bebe7d5c
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-MIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-MIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA11-MIR-C43.WD
new file mode 100644
index 00000000..12a97bf6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-MIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-MRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA11-MRR-C0.WD
new file mode 100644
index 00000000..b606afee
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-MRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-MRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA11-MRR-C356.WD
new file mode 100644
index 00000000..7aefb479
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-MRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-MRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA11-MRR-C357.WD
new file mode 100644
index 00000000..8a891438
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-MRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-MRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA11-MRR-C360.WD
new file mode 100644
index 00000000..9429b755
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-MRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-MRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA11-MRR-C361.WD
new file mode 100644
index 00000000..a11390a7
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-MRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-MRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA11-MRR-C41.WD
new file mode 100644
index 00000000..e5dec744
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-MRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-MRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA11-MRR-C42.WD
new file mode 100644
index 00000000..3d5d00d2
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-MRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA11-MRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA11-MRR-C43.WD
new file mode 100644
index 00000000..35be5390
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA11-MRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-BIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA12-BIR-C0.WD
new file mode 100644
index 00000000..82ed2015
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-BIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-BIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA12-BIR-C356.WD
new file mode 100644
index 00000000..acd16d38
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-BIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-BIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA12-BIR-C357.WD
new file mode 100644
index 00000000..c5b969ed
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-BIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-BIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA12-BIR-C360.WD
new file mode 100644
index 00000000..950f4b8b
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-BIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-BIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA12-BIR-C361.WD
new file mode 100644
index 00000000..5e598a84
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-BIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-BIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA12-BIR-C41.WD
new file mode 100644
index 00000000..aafb55a7
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-BIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-BIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA12-BIR-C42.WD
new file mode 100644
index 00000000..97bf8fa8
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-BIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-BIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA12-BIR-C43.WD
new file mode 100644
index 00000000..295cfc6a
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-BIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-BRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA12-BRR-C0.WD
new file mode 100644
index 00000000..8654688e
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-BRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-BRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA12-BRR-C356.WD
new file mode 100644
index 00000000..dfabf0be
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-BRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-BRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA12-BRR-C357.WD
new file mode 100644
index 00000000..2da42e2e
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-BRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-BRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA12-BRR-C360.WD
new file mode 100644
index 00000000..91d3d4f3
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-BRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-BRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA12-BRR-C361.WD
new file mode 100644
index 00000000..5e4cfbc5
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-BRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-BRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA12-BRR-C41.WD
new file mode 100644
index 00000000..5cad80c6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-BRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-BRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA12-BRR-C42.WD
new file mode 100644
index 00000000..914ae5cb
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-BRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-BRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA12-BRR-C43.WD
new file mode 100644
index 00000000..71c77182
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-BRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-MIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA12-MIR-C0.WD
new file mode 100644
index 00000000..154d089e
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-MIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-MIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA12-MIR-C356.WD
new file mode 100644
index 00000000..fd77ae04
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-MIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-MIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA12-MIR-C357.WD
new file mode 100644
index 00000000..9911ccb9
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-MIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-MIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA12-MIR-C360.WD
new file mode 100644
index 00000000..8ce3754e
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-MIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-MIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA12-MIR-C361.WD
new file mode 100644
index 00000000..fcdbf03d
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-MIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-MIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA12-MIR-C41.WD
new file mode 100644
index 00000000..a27e5bd3
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-MIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-MIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA12-MIR-C42.WD
new file mode 100644
index 00000000..fa5686c5
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-MIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-MIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA12-MIR-C43.WD
new file mode 100644
index 00000000..e0a0c406
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-MIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-MRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA12-MRR-C0.WD
new file mode 100644
index 00000000..93b388ff
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-MRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-MRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA12-MRR-C356.WD
new file mode 100644
index 00000000..df983302
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-MRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-MRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA12-MRR-C357.WD
new file mode 100644
index 00000000..1e107cbd
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-MRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-MRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA12-MRR-C360.WD
new file mode 100644
index 00000000..160538e8
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-MRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-MRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA12-MRR-C361.WD
new file mode 100644
index 00000000..d42823ee
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-MRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-MRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA12-MRR-C41.WD
new file mode 100644
index 00000000..cd030ec3
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-MRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-MRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA12-MRR-C42.WD
new file mode 100644
index 00000000..0e45395f
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-MRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA12-MRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA12-MRR-C43.WD
new file mode 100644
index 00000000..209a0ded
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA12-MRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-BIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA14-BIR-C0.WD
new file mode 100644
index 00000000..70c2bef5
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-BIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-BIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA14-BIR-C356.WD
new file mode 100644
index 00000000..e48f2add
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-BIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-BIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA14-BIR-C357.WD
new file mode 100644
index 00000000..3dfcf69f
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-BIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-BIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA14-BIR-C360.WD
new file mode 100644
index 00000000..7cdf099a
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-BIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-BIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA14-BIR-C361.WD
new file mode 100644
index 00000000..f848d196
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-BIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-BIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA14-BIR-C41.WD
new file mode 100644
index 00000000..ddc9ea20
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-BIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-BIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA14-BIR-C42.WD
new file mode 100644
index 00000000..d5b49eb1
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-BIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-BIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA14-BIR-C43.WD
new file mode 100644
index 00000000..efaeb077
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-BIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-BRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA14-BRR-C0.WD
new file mode 100644
index 00000000..fc66ef65
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-BRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-BRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA14-BRR-C356.WD
new file mode 100644
index 00000000..6e15d8cd
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-BRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-BRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA14-BRR-C357.WD
new file mode 100644
index 00000000..2f48990e
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-BRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-BRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA14-BRR-C360.WD
new file mode 100644
index 00000000..5bb06208
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-BRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-BRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA14-BRR-C361.WD
new file mode 100644
index 00000000..c4df2346
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-BRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-BRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA14-BRR-C41.WD
new file mode 100644
index 00000000..aaadb32d
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-BRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-BRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA14-BRR-C42.WD
new file mode 100644
index 00000000..db170438
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-BRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-BRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA14-BRR-C43.WD
new file mode 100644
index 00000000..0a3c08b6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-BRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-MIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA14-MIR-C0.WD
new file mode 100644
index 00000000..701c2223
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-MIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-MIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA14-MIR-C356.WD
new file mode 100644
index 00000000..6c116d0a
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-MIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-MIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA14-MIR-C357.WD
new file mode 100644
index 00000000..8f329939
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-MIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-MIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA14-MIR-C360.WD
new file mode 100644
index 00000000..48e235ff
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-MIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-MIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA14-MIR-C361.WD
new file mode 100644
index 00000000..f16632a4
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-MIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-MIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA14-MIR-C41.WD
new file mode 100644
index 00000000..ec70a5c6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-MIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-MIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA14-MIR-C42.WD
new file mode 100644
index 00000000..55f838c7
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-MIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-MIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA14-MIR-C43.WD
new file mode 100644
index 00000000..40e207b6
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-MIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-MRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA14-MRR-C0.WD
new file mode 100644
index 00000000..7f8d9eb1
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-MRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-MRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA14-MRR-C356.WD
new file mode 100644
index 00000000..a6ed113e
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-MRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-MRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA14-MRR-C357.WD
new file mode 100644
index 00000000..25efb1d4
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-MRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-MRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA14-MRR-C360.WD
new file mode 100644
index 00000000..f284e7e1
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-MRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-MRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA14-MRR-C361.WD
new file mode 100644
index 00000000..8e6eb446
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-MRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-MRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA14-MRR-C41.WD
new file mode 100644
index 00000000..057abce3
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-MRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-MRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA14-MRR-C42.WD
new file mode 100644
index 00000000..f5059548
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-MRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA14-MRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA14-MRR-C43.WD
new file mode 100644
index 00000000..b96f9f61
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA14-MRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-BIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA18-BIR-C0.WD
new file mode 100644
index 00000000..41559f56
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-BIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-BIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA18-BIR-C356.WD
new file mode 100644
index 00000000..d2a9932d
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-BIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-BIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA18-BIR-C357.WD
new file mode 100644
index 00000000..0e5db817
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-BIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-BIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA18-BIR-C360.WD
new file mode 100644
index 00000000..e5eec77a
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-BIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-BIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA18-BIR-C361.WD
new file mode 100644
index 00000000..36398bea
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-BIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-BIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA18-BIR-C41.WD
new file mode 100644
index 00000000..39da82a0
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-BIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-BIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA18-BIR-C42.WD
new file mode 100644
index 00000000..6c1d5641
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-BIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-BIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA18-BIR-C43.WD
new file mode 100644
index 00000000..6b9b1198
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-BIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-BRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA18-BRR-C0.WD
new file mode 100644
index 00000000..510e972e
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-BRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-BRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA18-BRR-C356.WD
new file mode 100644
index 00000000..0a78b9fa
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-BRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-BRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA18-BRR-C357.WD
new file mode 100644
index 00000000..0c8b7559
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-BRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-BRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA18-BRR-C360.WD
new file mode 100644
index 00000000..1f366cd2
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-BRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-BRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA18-BRR-C361.WD
new file mode 100644
index 00000000..5ec0ff0f
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-BRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-BRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA18-BRR-C41.WD
new file mode 100644
index 00000000..40b5d198
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-BRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-BRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA18-BRR-C42.WD
new file mode 100644
index 00000000..ab32aac4
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-BRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-BRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA18-BRR-C43.WD
new file mode 100644
index 00000000..0f03a515
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-BRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-MIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA18-MIR-C0.WD
new file mode 100644
index 00000000..49cbc1ee
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-MIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-MIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA18-MIR-C356.WD
new file mode 100644
index 00000000..b75fdf50
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-MIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-MIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA18-MIR-C357.WD
new file mode 100644
index 00000000..bfaa8fe4
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-MIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-MIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA18-MIR-C360.WD
new file mode 100644
index 00000000..5f7bbc4c
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-MIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-MIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA18-MIR-C361.WD
new file mode 100644
index 00000000..f7a886fb
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-MIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-MIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA18-MIR-C41.WD
new file mode 100644
index 00000000..62311e60
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-MIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-MIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA18-MIR-C42.WD
new file mode 100644
index 00000000..2af7cd22
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-MIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-MIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA18-MIR-C43.WD
new file mode 100644
index 00000000..c658fe31
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-MIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-MRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA18-MRR-C0.WD
new file mode 100644
index 00000000..98a026be
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-MRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-MRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA18-MRR-C356.WD
new file mode 100644
index 00000000..edab6dcd
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-MRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-MRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA18-MRR-C357.WD
new file mode 100644
index 00000000..afbe154a
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-MRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-MRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA18-MRR-C360.WD
new file mode 100644
index 00000000..b792cf63
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-MRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-MRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA18-MRR-C361.WD
new file mode 100644
index 00000000..ed95a16e
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-MRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-MRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA18-MRR-C41.WD
new file mode 100644
index 00000000..d1ff88b9
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-MRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-MRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA18-MRR-C42.WD
new file mode 100644
index 00000000..f4c760cd
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-MRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA18-MRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA18-MRR-C43.WD
new file mode 100644
index 00000000..867b234c
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA18-MRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-BIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA24-BIR-C0.WD
new file mode 100644
index 00000000..6ef0e07a
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-BIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-BIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA24-BIR-C356.WD
new file mode 100644
index 00000000..6c227894
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-BIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-BIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA24-BIR-C357.WD
new file mode 100644
index 00000000..9525c5de
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-BIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-BIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA24-BIR-C360.WD
new file mode 100644
index 00000000..f509fcbf
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-BIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-BIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA24-BIR-C361.WD
new file mode 100644
index 00000000..afe3726a
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-BIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-BIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA24-BIR-C41.WD
new file mode 100644
index 00000000..3610b767
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-BIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-BIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA24-BIR-C42.WD
new file mode 100644
index 00000000..a9ca0bd1
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-BIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-BIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA24-BIR-C43.WD
new file mode 100644
index 00000000..412cbd22
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-BIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-BRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA24-BRR-C0.WD
new file mode 100644
index 00000000..e58498fc
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-BRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-BRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA24-BRR-C356.WD
new file mode 100644
index 00000000..8be8f6cf
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-BRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-BRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA24-BRR-C357.WD
new file mode 100644
index 00000000..8558086b
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-BRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-BRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA24-BRR-C360.WD
new file mode 100644
index 00000000..d90f197f
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-BRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-BRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA24-BRR-C361.WD
new file mode 100644
index 00000000..ceb5400a
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-BRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-BRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA24-BRR-C41.WD
new file mode 100644
index 00000000..e8f4dfb7
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-BRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-BRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA24-BRR-C42.WD
new file mode 100644
index 00000000..04c006fa
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-BRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-BRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA24-BRR-C43.WD
new file mode 100644
index 00000000..bd97707a
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-BRR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-MIR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA24-MIR-C0.WD
new file mode 100644
index 00000000..b0f6ae7c
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-MIR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-MIR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA24-MIR-C356.WD
new file mode 100644
index 00000000..b3f3a4c7
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-MIR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-MIR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA24-MIR-C357.WD
new file mode 100644
index 00000000..3c255f96
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-MIR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-MIR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA24-MIR-C360.WD
new file mode 100644
index 00000000..fd02f828
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-MIR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-MIR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA24-MIR-C361.WD
new file mode 100644
index 00000000..4cb1a167
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-MIR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-MIR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA24-MIR-C41.WD
new file mode 100644
index 00000000..8e02a618
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-MIR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-MIR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA24-MIR-C42.WD
new file mode 100644
index 00000000..a0aa8718
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-MIR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-MIR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA24-MIR-C43.WD
new file mode 100644
index 00000000..70afff8b
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-MIR-C43.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-MRR-C0.WD b/fontsold/ipfonts/presentation/HELVETICA24-MRR-C0.WD
new file mode 100644
index 00000000..9438c391
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-MRR-C0.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-MRR-C356.WD b/fontsold/ipfonts/presentation/HELVETICA24-MRR-C356.WD
new file mode 100644
index 00000000..edc01c97
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-MRR-C356.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-MRR-C357.WD b/fontsold/ipfonts/presentation/HELVETICA24-MRR-C357.WD
new file mode 100644
index 00000000..d47c4a06
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-MRR-C357.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-MRR-C360.WD b/fontsold/ipfonts/presentation/HELVETICA24-MRR-C360.WD
new file mode 100644
index 00000000..c227510a
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-MRR-C360.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-MRR-C361.WD b/fontsold/ipfonts/presentation/HELVETICA24-MRR-C361.WD
new file mode 100644
index 00000000..a3ecf3bf
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-MRR-C361.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-MRR-C41.WD b/fontsold/ipfonts/presentation/HELVETICA24-MRR-C41.WD
new file mode 100644
index 00000000..0fc5ef4f
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-MRR-C41.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-MRR-C42.WD b/fontsold/ipfonts/presentation/HELVETICA24-MRR-C42.WD
new file mode 100644
index 00000000..b821f2a5
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-MRR-C42.WD differ
diff --git a/fontsold/ipfonts/presentation/HELVETICA24-MRR-C43.WD b/fontsold/ipfonts/presentation/HELVETICA24-MRR-C43.WD
new file mode 100644
index 00000000..ea5a6e58
Binary files /dev/null and b/fontsold/ipfonts/presentation/HELVETICA24-MRR-C43.WD differ
diff --git a/fontsold/ipfonts/publishing/MODERN18-MRR-C356.WD b/fontsold/ipfonts/publishing/MODERN18-MRR-C356.WD
new file mode 100644
index 00000000..9be95c0b
Binary files /dev/null and b/fontsold/ipfonts/publishing/MODERN18-MRR-C356.WD differ
diff --git a/fontsold/postscriptfonts/AvantGarde01-BIR-C0.PSCFONT b/fontsold/postscriptfonts/AvantGarde01-BIR-C0.PSCFONT
new file mode 100644
index 00000000..ab008dba
Binary files /dev/null and b/fontsold/postscriptfonts/AvantGarde01-BIR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/AvantGarde01-BRR-C0.PSCFONT b/fontsold/postscriptfonts/AvantGarde01-BRR-C0.PSCFONT
new file mode 100644
index 00000000..adcc35d8
Binary files /dev/null and b/fontsold/postscriptfonts/AvantGarde01-BRR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/AvantGarde01-MIR-C0.PSCFONT b/fontsold/postscriptfonts/AvantGarde01-MIR-C0.PSCFONT
new file mode 100644
index 00000000..a29ef301
Binary files /dev/null and b/fontsold/postscriptfonts/AvantGarde01-MIR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/AvantGarde01-MRR-C0.PSCFONT b/fontsold/postscriptfonts/AvantGarde01-MRR-C0.PSCFONT
new file mode 100644
index 00000000..33f3ab32
Binary files /dev/null and b/fontsold/postscriptfonts/AvantGarde01-MRR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/COURIER01-BIR-C0.PSCFONT b/fontsold/postscriptfonts/COURIER01-BIR-C0.PSCFONT
new file mode 100644
index 00000000..f32c6005
Binary files /dev/null and b/fontsold/postscriptfonts/COURIER01-BIR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/COURIER01-BRR-C0.PSCFONT b/fontsold/postscriptfonts/COURIER01-BRR-C0.PSCFONT
new file mode 100644
index 00000000..da834ab3
Binary files /dev/null and b/fontsold/postscriptfonts/COURIER01-BRR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/COURIER01-MIR-C0.PSCFONT b/fontsold/postscriptfonts/COURIER01-MIR-C0.PSCFONT
new file mode 100644
index 00000000..88672cec
Binary files /dev/null and b/fontsold/postscriptfonts/COURIER01-MIR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/COURIER01-MRR-C0.PSCFONT b/fontsold/postscriptfonts/COURIER01-MRR-C0.PSCFONT
new file mode 100644
index 00000000..2d9e8578
Binary files /dev/null and b/fontsold/postscriptfonts/COURIER01-MRR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/Garamond01-BIR-C0.PSCFONT b/fontsold/postscriptfonts/Garamond01-BIR-C0.PSCFONT
new file mode 100644
index 00000000..c312aa24
Binary files /dev/null and b/fontsold/postscriptfonts/Garamond01-BIR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/Garamond01-BRR-C0.PSCFONT b/fontsold/postscriptfonts/Garamond01-BRR-C0.PSCFONT
new file mode 100644
index 00000000..527cc099
Binary files /dev/null and b/fontsold/postscriptfonts/Garamond01-BRR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/Garamond01-MIR-C0.PSCFONT b/fontsold/postscriptfonts/Garamond01-MIR-C0.PSCFONT
new file mode 100644
index 00000000..694a3174
Binary files /dev/null and b/fontsold/postscriptfonts/Garamond01-MIR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/Garamond01-MRR-C0.PSCFONT b/fontsold/postscriptfonts/Garamond01-MRR-C0.PSCFONT
new file mode 100644
index 00000000..e68c91ae
Binary files /dev/null and b/fontsold/postscriptfonts/Garamond01-MRR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/HELVETICA-NARROW01-BIR-C0.PSCFONT b/fontsold/postscriptfonts/HELVETICA-NARROW01-BIR-C0.PSCFONT
new file mode 100644
index 00000000..8a7692ac
Binary files /dev/null and b/fontsold/postscriptfonts/HELVETICA-NARROW01-BIR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/HELVETICA-NARROW01-BRR-C0.PSCFONT b/fontsold/postscriptfonts/HELVETICA-NARROW01-BRR-C0.PSCFONT
new file mode 100644
index 00000000..78f064d7
Binary files /dev/null and b/fontsold/postscriptfonts/HELVETICA-NARROW01-BRR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/HELVETICA-NARROW01-MIR-C0.PSCFONT b/fontsold/postscriptfonts/HELVETICA-NARROW01-MIR-C0.PSCFONT
new file mode 100644
index 00000000..e25fb0b6
Binary files /dev/null and b/fontsold/postscriptfonts/HELVETICA-NARROW01-MIR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/HELVETICA-NARROW01-MRR-C0.PSCFONT b/fontsold/postscriptfonts/HELVETICA-NARROW01-MRR-C0.PSCFONT
new file mode 100644
index 00000000..ac049851
Binary files /dev/null and b/fontsold/postscriptfonts/HELVETICA-NARROW01-MRR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/HELVETICA01-BIR-C0.PSCFONT b/fontsold/postscriptfonts/HELVETICA01-BIR-C0.PSCFONT
new file mode 100644
index 00000000..e92bd72a
Binary files /dev/null and b/fontsold/postscriptfonts/HELVETICA01-BIR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/HELVETICA01-BRR-C0.PSCFONT b/fontsold/postscriptfonts/HELVETICA01-BRR-C0.PSCFONT
new file mode 100644
index 00000000..42eabf49
Binary files /dev/null and b/fontsold/postscriptfonts/HELVETICA01-BRR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/HELVETICA01-MIR-C0.PSCFONT b/fontsold/postscriptfonts/HELVETICA01-MIR-C0.PSCFONT
new file mode 100644
index 00000000..8915b1b7
Binary files /dev/null and b/fontsold/postscriptfonts/HELVETICA01-MIR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/HELVETICA01-MRR-C0.PSCFONT b/fontsold/postscriptfonts/HELVETICA01-MRR-C0.PSCFONT
new file mode 100644
index 00000000..28ac1576
Binary files /dev/null and b/fontsold/postscriptfonts/HELVETICA01-MRR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/NEWCENTURYSCHLBK01-BIR-C0.PSCFONT b/fontsold/postscriptfonts/NEWCENTURYSCHLBK01-BIR-C0.PSCFONT
new file mode 100644
index 00000000..350b7f49
Binary files /dev/null and b/fontsold/postscriptfonts/NEWCENTURYSCHLBK01-BIR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/NEWCENTURYSCHLBK01-BRR-C0.PSCFONT b/fontsold/postscriptfonts/NEWCENTURYSCHLBK01-BRR-C0.PSCFONT
new file mode 100644
index 00000000..b5365cfa
Binary files /dev/null and b/fontsold/postscriptfonts/NEWCENTURYSCHLBK01-BRR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/NEWCENTURYSCHLBK01-MIR-C0.PSCFONT b/fontsold/postscriptfonts/NEWCENTURYSCHLBK01-MIR-C0.PSCFONT
new file mode 100644
index 00000000..4989dfec
Binary files /dev/null and b/fontsold/postscriptfonts/NEWCENTURYSCHLBK01-MIR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/NEWCENTURYSCHLBK01-MRR-C0.PSCFONT b/fontsold/postscriptfonts/NEWCENTURYSCHLBK01-MRR-C0.PSCFONT
new file mode 100644
index 00000000..c9f5b24c
Binary files /dev/null and b/fontsold/postscriptfonts/NEWCENTURYSCHLBK01-MRR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/PALATINO01-BIR-C0.PSCFONT b/fontsold/postscriptfonts/PALATINO01-BIR-C0.PSCFONT
new file mode 100644
index 00000000..84518d5c
Binary files /dev/null and b/fontsold/postscriptfonts/PALATINO01-BIR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/PALATINO01-BRR-C0.PSCFONT b/fontsold/postscriptfonts/PALATINO01-BRR-C0.PSCFONT
new file mode 100644
index 00000000..36fc6f31
Binary files /dev/null and b/fontsold/postscriptfonts/PALATINO01-BRR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/PALATINO01-MIR-C0.PSCFONT b/fontsold/postscriptfonts/PALATINO01-MIR-C0.PSCFONT
new file mode 100644
index 00000000..6c2edc49
Binary files /dev/null and b/fontsold/postscriptfonts/PALATINO01-MIR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/PALATINO01-MRR-C0.PSCFONT b/fontsold/postscriptfonts/PALATINO01-MRR-C0.PSCFONT
new file mode 100644
index 00000000..e9594c3a
Binary files /dev/null and b/fontsold/postscriptfonts/PALATINO01-MRR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/TIMES01-BIR-C0.PSCFONT b/fontsold/postscriptfonts/TIMES01-BIR-C0.PSCFONT
new file mode 100644
index 00000000..e6284982
Binary files /dev/null and b/fontsold/postscriptfonts/TIMES01-BIR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/TIMES01-BRR-C0.PSCFONT b/fontsold/postscriptfonts/TIMES01-BRR-C0.PSCFONT
new file mode 100644
index 00000000..5a1687d5
Binary files /dev/null and b/fontsold/postscriptfonts/TIMES01-BRR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/TIMES01-MIR-C0.PSCFONT b/fontsold/postscriptfonts/TIMES01-MIR-C0.PSCFONT
new file mode 100644
index 00000000..0455ab96
Binary files /dev/null and b/fontsold/postscriptfonts/TIMES01-MIR-C0.PSCFONT differ
diff --git a/fontsold/postscriptfonts/TIMES01-MRR-C0.PSCFONT b/fontsold/postscriptfonts/TIMES01-MRR-C0.PSCFONT
new file mode 100644
index 00000000..8246ebf4
Binary files /dev/null and b/fontsold/postscriptfonts/TIMES01-MRR-C0.PSCFONT differ
diff --git a/lispusers/COMPAREDIRECTORIES.LCOM.~274~ b/lispusers/COMPAREDIRECTORIES.LCOM.~274~
new file mode 100644
index 00000000..5cc3ff18
Binary files /dev/null and b/lispusers/COMPAREDIRECTORIES.LCOM.~274~ differ
diff --git a/lispusers/COMPAREDIRECTORIES.~274~ b/lispusers/COMPAREDIRECTORIES.~274~
new file mode 100644
index 00000000..32658929
--- /dev/null
+++ b/lispusers/COMPAREDIRECTORIES.~274~
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "31-Oct-2020 09:13:05" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;274 62687  

      changes to%:  (FNS SOURCE-FOR-COMPILED-P FIX-DIRECTORY-DATES)

      previous date%: "23-Oct-2020 12:29:12" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;271)


(* ; "
Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994, 1998, 2018, 2020 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT COMPAREDIRECTORIESCOMS)

(RPAQQ COMPAREDIRECTORIESCOMS
       (
        (* ;; "Compare the contents of two directories.")

        (FNS COMPAREDIRECTORIES CDFILES COMPAREDIRECTORIES.INFOS MATCHNAME)
        (FNS CDPRINT CDPRINT.LINE)
        (FNS CDMAP CDENTRY CDSUBSET)
        (FNS BINCOMP EOLTYPE)
        (RECORDS CDENTRY CDINFO)
        
        (* ;; "look for compiled files older than the sources")

        (FNS FIND-UNCOMPILED-FILES FIND-UNSOURCED-FILES FIND-SOURCE-FILES FIND-COMPILED-FILES 
             FIND-UNLOADED-FILES FIND-LOADED-FILES FIND-MULTICOMPILED-FILES)
        (FNS CREATED-AS SOURCE-FOR-COMPILED-P COMPILE-SOURCE-DATE-DIFF)
        (FNS FIX-DIRECTORY-DATES FIX-EQUIV-DATES COPY-COMPARED-FILES COPY-MISSING-FILES 
             COMPILED-ON-SAME-SOURCE)
        [VARS (ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01")
                                (IDATE "1-Jan-2020 12:00:00"]
        (INITVARS (LASTCDENTRIES NIL))
        (COMS (FNS COMPARE-ENTRY-SOURCE-FILES)
              (FILES COMPARESOURCES))))



(* ;; "Compare the contents of two directories.")

(DEFINEQ

(COMPAREDIRECTORIES
  [LAMBDA (DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS)
                                                            (* ; "Edited 14-Oct-2020 21:15 by rmk:")

    (* ;; "Compare the contents of two directories, e.g., for change-control purposes.  Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other.  If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (<  >), T is the same as (< > =).  Also allows selection based on file-length criteria.")

    (* ;; "")

    (* ;; "Unless USEDIRECTORYDATE, comparison is with respect to the the LISP filecreated dates if evailable.")

    (* ;; "")

    (* ;; "If OUTPUTFILE is NIL, the list of compared entries is returned.  Otherwise the selected entries are printed on OUTPUTFILE (T for the display).")

    [SETQ SELECT (SELECTQ SELECT
                     (NIL '(< > -* *-))
                     (T '(< > -* *- =))
                     (FOR S IN (MKLIST SELECT) COLLECT (SELECTQ S
                                                                       ((AFTER >) 
                                                                            '>)
                                                                       ((BEFORE <) 
                                                                            '<)
                                                                       ((SAME SAMEDATE =) 
                                                                            '=)
                                                                       (AUTHOR 'AUTHOR)
                                                                       (-* '-*)
                                                                       (*- '*-)
                                                                       (ERROR 
                                                                      "UNRECOGNIZED SELECT PARAMETER"
                                                                              S]
    (PROG (INFOS1 INFOS2 CANDIDATES SELECTED COMPAREDATE DEPTH1 DEPTH2)
          [SETQ COMPAREDATE (INTERSECTION SELECT '(< > =]

     (* ;; "DIRECTORYNAME here to get unrelativized specifications for header.")

     (* ;; "Allow all subdirectories if a directory ends in *, but peel it off for the resolution")

          (CL:WHEN (EQ '* (NTHCHAR DIR1 -1))
              (SETQ DEPTH1 T)
              (SETQ DIR1 (SUBSTRING DIR1 1 -2)))
          (CL:WHEN (EQ '* (NTHCHAR DIR2 -1))
              (SETQ DEPTH2 T)
              (SETQ DIR2 (SUBSTRING DIR2 1 -2)))
          (SETQ DIR1 (OR (DIRECTORYNAME (OR DIR1 T))
                         (ERROR "DIRECTORY DOES NOT EXIST" DIR1)))
          (SETQ DIR2 (OR (DIRECTORYNAME (OR DIR2 T))
                         (ERROR "DIRECTORY DOES NOT EXIST" DIR2)))
          (PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE)
                 " selecting " SELECT " ... ")
          (SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 FILEPATTERNS EXTENSIONSTOAVOID
                                                            ALLVERSIONS DEPTH1)
                              USEDIRECTORYDATE))
          (SETQ INFOS2 (COMPAREDIRECTORIES.INFOS (CDFILES DIR2 FILEPATTERNS EXTENSIONSTOAVOID
                                                            ALLVERSIONS DEPTH2)
                              USEDIRECTORYDATE))
          (CL:UNLESS (AND INFOS2 INFOS1)
                 (RETURN))

     (* ;; "At this point the CAR of each info is the atomic match-name. Peel it off to produce candidate entries.")

     (* ;; 
   "Look through all of the I2's because multiple versions (if VERSIONS) have the same matchname")

          [SETQ CANDIDATES (FOR I1 IN INFOS1
                              JOIN (IF ALLVERSIONS
                                           THEN (OR (FOR I2 IN INFOS2
                                                           WHEN (EQ (CAR I2)
                                                                        (CAR I1))
                                                           COLLECT (LIST (CAR I1)
                                                                             (CDR I1)
                                                                             (CDR I2)))
                                                        (CONS (LIST (CAR I1)
                                                                    (CDR I1)
                                                                    NIL)))
                                         ELSE (CONS (LIST (CAR I1)
                                                              (CDR I1)
                                                              (CDR (ASSOC (CAR I1)
                                                                          INFOS2]

     (* ;; "Could be some 2's without 1's")

          (SORT [NCONC CANDIDATES (FOR I2 IN INFOS2 UNLESS (ASSOC (CAR I2)
                                                                              CANDIDATES)
                                     COLLECT (LIST (CAR I2)
                                                       NIL
                                                       (CDR I2]
                T)

     (* ;; "CANDIDATES is now a sorted list of the form (matchname entry1 entry2) where an entry consists of (fullname date length author)")

     (* ;; "Do the SELECT filtering and insert the date relation.")

          [SETQ SELECTED
           (FOR C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP IN CANDIDATES
              EACHTIME (SETQ MATCHNAME (POP C))
                    (SETQ INFO1 (POP C))
                    (SETQ INFO2 (POP C))
                    (IF (AND INFO1 INFO2)
                        THEN (SETQ IDATE1 (IDATE (FETCH DATE OF INFO1)))
                              (SETQ IDATE2 (IDATE (FETCH DATE OF INFO2)))
                              (SETQ DATEREL (IF (IGREATERP IDATE1 IDATE2)
                                                THEN '>
                                              ELSEIF (ILESSP IDATE1 IDATE2)
                                                THEN '<
                                              ELSE '=))
                      ELSE 

                            (* ;; "Just for printing--no comparison")

                            (SETQ DATEREL '*))
              WHEN (IF (AND INFO1 INFO2)
                           THEN (OR (NULL COMPAREDATE)
                                        (SELECTQ DATEREL
                                            (> (MEMB '> SELECT))
                                            (< (MEMB '< SELECT))
                                            (= (MEMB '= SELECT))
                                            (SHOULDNT)))
                         ELSEIF INFO1
                           THEN 

                                 (* ;; "OK if INFO2 is missing?")

                                 (MEMB '*- SELECT)
                         ELSE 

                               (* ;; "OK if INFO1 is missing?")

                               (MEMB '-* SELECT))
              COLLECT (CREATE CDENTRY
                                 MATCHNAME _ MATCHNAME
                                 INFO1 _ INFO1
                                 DATEREL _ DATEREL
                                 INFO2 _ INFO2
                                 EQUIV _ (CL:UNLESS (EQ DATEREL '*)
                                             (BINCOMP (FETCH FULLNAME OF INFO1)
                                                    (FETCH FULLNAME OF INFO2)
                                                    T
                                                    (FETCH EOL OF INFO1)
                                                    (FETCH EOL OF INFO2)))]
          (PRINTOUT T (LENGTH SELECTED)
                 " entries" T)
          (PUSH SELECTED (LIST DIR1 DIR2 SELECT (DATE)))
          (SETQ LASTCDENTRIES SELECTED)
          (CL:UNLESS OUTPUTFILE (RETURN SELECTED))
          (RETURN (CDPRINT SELECTED OUTPUTFILE (MEMB 'AUTHOR SELECT SELECT])

(CDFILES
  [LAMBDA (DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH)
                                                            (* ; "Edited 16-Oct-2020 13:42 by rmk:")

    (* ;; "Returns a list of fullnames for files that satisfy the criteria")

    (* ;; "For each name returned by (DIRECTORY DIR), assumes that FILEPATTERNS applies to the suffix after the directory (i.e. after NAMEPOS).  That includes possibly subdirectories, dotted files in ultimate file names, and versions.")

    (* ;; "     Exclude subdirectories unless FILEPATTERNS includes *>*")

    (* ;; "     Exclude dotted files (.xxx) unless FILEPATTERNS includes .*")

    (* ;; "     Exclude files with extensions in EXTENSIONSTOAVOID (*=NIL does no filtering)")

    (* ;; "     Exclude older versions unless ALLVERSIONS=T")

    (* ;; "  DEPTH is the number of subdirectories below the ones specified in DIR (NIL top-level of DIR only, T = any depth)")

    (* ;; "Resolve relative directories, so we can suppress subdirectory matches.   ")

    (SETQ EXTENSIONSTOAVOID (MKLIST (U-CASE EXTENSIONSTOAVOID)))
    [SETQ FILEPATTERNS (MKLIST (OR FILEPATTERNS '*]
    (FOR FP FN FPNAME FPEXT EXCLUDEDOTTED (TOPDIR _ (DIRECTORYNAME (OR DIR T))) IN 
                                                                                         FILEPATTERNS
       JOIN [SETQ FPNAME (U-CASE (FILENAMEFIELD FP 'NAME]
             [SETQ FPEXT (U-CASE (FILENAMEFIELD FP 'EXTENSION]
             (CL:UNLESS FPNAME
                 (IF FPEXT
                     THEN 

                           (* ;; ".XY")

                           (SETQ FPNAME (PACK* "." FPEXT))
                   ELSE (SETQ FPNAME '*)))
             (CL:UNLESS FPEXT
                 (SETQ FPEXT '*))
             (SETQ EXCLUDEDOTTED (NEQ (CHARCODE %.)
                                      (CHCON1 FPNAME)))
             (SETQ FN (PACKFILENAME.STRING 'VERSION (CL:IF ALLVERSIONS
                                                        '*
                                                        "")
                             'DIRECTORY TOPDIR 'NAME '* 'EXTENSION '*)) 

             (* ;; "DEPTH is the number of internal %">%"")

             [IF (EQ DEPTH T)
                 THEN (SETQ DEPTH MAX.SMALLP)
               ELSEIF DEPTH
               ELSE (SETQ DEPTH (BIND (CNT _ 0)
                                           (POS _ 0)
                                           (FNDIR _ (FILENAMEFIELD FN 'DIRECTORY))
                                       WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS)))
                                       DO (ADD CNT 1) FINALLY (RETURN CNT]
             (FOR FULLNAME NAME EXT THISDEPTH IN (DIRECTORY FN)
                EACHTIME [SETQ NAME (U-CASE (FILENAMEFIELD FULLNAME 'NAME]
                      [SETQ EXT (U-CASE (FILENAMEFIELD FULLNAME 'EXTENSION]
                      (CL:UNLESS NAME
                          (IF EXT
                              THEN 

                                    (* ;; ".XY")

                                    (SETQ NAME (PACK* "." EXT))
                                    (SETQ EXT NIL)))
                      (CL:WHEN (AND EXCLUDEDOTTED (EQ (CHARCODE %.)
                                                      (CHCON1 NAME)))
                             (GO $$ITERATE))
                      (SETQ THISDEPTH (BIND (CNT _ 0)
                                             (POS _ 0)
                                             (FNDIR _ (FILENAMEFIELD FULLNAME 'DIRECTORY))
                                         WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS)))
                                         DO (ADD CNT 1) FINALLY (RETURN CNT))) 

                      (* ;; "An empty subdirectory may appear without name or extensions")
 WHEN (AND (OR NAME EXT)
               (OR (EQ FPNAME '*)
                   (EQ FPNAME NAME))
               (OR (EQ FPEXT '*)
                   (EQ FPEXT EXT))) UNLESS [OR (IGREATERP THISDEPTH DEPTH)
                                                   (AND EXT (OR (MEMB '* EXTENSIONSTOAVOID)
                                                                (MEMB EXT EXTENSIONSTOAVOID]
                COLLECT FULLNAME) FINALLY (CL:UNLESS $$VAL (PRINTOUT T 
                                                                          "No relevant files in " 
                                                                          TOPDIR T])

(COMPAREDIRECTORIES.INFOS
  [LAMBDA (FILES USEDIRECTORYDATE)                      (* ; "Edited 13-Oct-2020 08:42 by rmk:")

    (* ;; "Value is a list of CDINFOS with the match-name consed on to the front")

    (FOR FULLNAME TYPE LDATE IN FILES
       COLLECT 

             (* ;; "GDATE/IDATE in case Y2K")

             (SETQ LDATE (FILEDATE FULLNAME))                (* ; "Is it a Lisp file?")
             (CONS (MATCHNAME FULLNAME)
                   (CREATE CDINFO
                          FULLNAME _ FULLNAME
                          DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE
                                                   THEN (GETFILEINFO FULLNAME 'CREATIONDATE)
                                                 ELSEIF (OR LDATE (GETFILEINFO FULLNAME
                                                                             'CREATIONDATE]
                          LENGTH _ (GETFILEINFO FULLNAME 'LENGTH)
                          AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR)
                          TYPE _ (IF LDATE
                                     THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION)
                                                           *COMPILED-EXTENSIONS*)
                                                  'COMPILED
                                                  'SOURCE)
                                   ELSE (PRINTFILETYPE FULLNAME))
                          EOL _ (EOLTYPE FULLNAME])

(MATCHNAME
  [LAMBDA (NAME)                                        (* ; "Edited  5-Sep-2020 13:41 by rmk:")

    (* ;; "The NAME.DIR for matching related files")

    (LET ((M (PACKFILENAME 'HOST NIL 'VERSION NIL 'DIRECTORY NIL 'BODY NAME)))

         (* ;; "Strip off the nuisance period")

         (CL:IF (EQ (CHARCODE %.)
                    (NTHCHARCODE M -1))
             (SUBATOM M 1 -2)
             M)])
)
(DEFINEQ

(CDPRINT
  [LAMBDA (CDENTRIES FILE PRINTAUTHOR)                  (* ; "Edited 13-Oct-2020 08:38 by rmk:")

    (* ;; "Typically CDENTRIES will have a header.  If not, we fake one up, at least for the directories and today's date.")

    (CL:UNLESS CDENTRIES
        (PRINTOUT T T "Note:  Using LASTCDENTRIES" T T)
        (SETQ CDENTRIES LASTCDENTRIES))
    (RESETLST
        (LET (INFO1 TEXT STREAM DATE1POS ENDDATE1 DIR1 DIR2 (HEADER (CAR CDENTRIES))
                    NCHARSDIR1)
             (CL:UNLESS (STRINGP (CADR HEADER))
                 (SETQ HEADER (LIST [FOR E IN CDENTRIES WHEN (FETCH INFO1
                                                                            OF E)
                                       DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL
                                                             'VERSION NIL 'BODY
                                                             (FETCH FULLNAME
                                                                OF (FETCH INFO1 OF E]
                                    [FOR E IN CDENTRIES WHEN (FETCH INFO2
                                                                            OF E)
                                       DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL
                                                             'VERSION NIL 'BODY
                                                             (FETCH FULLNAME
                                                                OF (FETCH INFO2 OF E]
                                    NIL
                                    (DATE)))
                 (PUSH CDENTRIES HEADER))
             (SETQ DIR1 (CAR HEADER))
             (SETQ NCHARSDIR1 (NCHARS DIR1))
             (SETQ DIR2 (CADR HEADER))
             (CL:UNLESS (SETQ STREAM (GETSTREAM FILE 'OUTPUT T))
                 [RESETSAVE (SETQ STREAM (OPENSTREAM (PACKFILENAME 'EXTENSION 'TXT 'BODY FILE)
                                                'OUTPUT
                                                'NEW))
                        '(PROGN (CLOSEF? OLDVALUE])
             (CL:WHEN DIR1
                 (PRINTOUT STREAM "Comparing " DIR1 6 "vs. " DIR2 T "as of " (CADDDR HEADER))
                 (CL:WHEN (CADDR HEADER)
                     (PRINTOUT STREAM " selecting " (CADDR HEADER)))
                 (PRINTOUT STREAM -2 (LENGTH (CDR CDENTRIES))
                        " entries" T T))
             (LINELENGTH 1000 STREAM)                        (* ; "Don't wrap")

             (* ;; "DATE1POS is the position of the first character of INFO1's date, used for tabbing.  We have to measure the filename, date, size, and author if desired")

             (IF (CDR CDENTRIES)
                 THEN (FOR E INFO1 (MAXDATE1WIDTH _ 0)
                                 (SPACEWIDTH _ 1)
                                 (PARENWIDTH _ 2) IN (CDR CDENTRIES)
                             WHEN (SETQ INFO1 (FETCH INFO1 OF E))
                             LARGEST [SETQ MAXDATE1WIDTH (IMAX MAXDATE1WIDTH
                                                                   (NCHARS (FETCH DATE
                                                                              OF INFO1]
                                   (IPLUS (- (NCHARS (FETCH FULLNAME OF INFO1))
                                             NCHARSDIR1)
                                          (NCHARS (FETCH LENGTH OF INFO1))
                                          (CL:IF PRINTAUTHOR
                                              (IPLUS SPACEWIDTH PARENWIDTH
                                                     (NCHARS (FETCH AUTHOR OF INFO1)))
                                              0)) FINALLY 

                                                        (* ;; 
                            "First 4 for width of equiv.  $$EXTREME is NIL if there are no INFO1's")

                                                        (SETQ DATE1POS (IPLUS (OR $$EXTREME 10)
                                                                              4
                                                                              (ITIMES 3 SPACEWIDTH)))
                                                        (SETQ ENDDATE1 (IPLUS DATE1POS MAXDATE1WIDTH)
                                                         ))
                       (FOR E IN (CDR CDENTRIES)
                          DO (CDPRINT.LINE STREAM E PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1
                                        (NCHARS DIR2)))
               ELSE (PRINTOUT T "CDENTRIES is empty" T))
             (AND STREAM (CLOSEF? STREAM))))])

(CDPRINT.LINE
  [LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 NCHARSDIR2)
                                                            (* ; "Edited 13-Oct-2020 08:51 by rmk:")

    (* ;; "Format one line of the directory comparison listing.  If PRINTAUTHOR and AUTHOR1 or AUTHOR2 are non-NIL, list the author in parens; otherwise omit it.")

    (LET ((INFO1 (FETCH INFO1 OF ENTRY))
          (INFO2 (FETCH INFO2 OF ENTRY)))
         (PRINTOUT STREAM (SELECTQ (FETCH EQUIV OF ENTRY)
                              (T "==")
                              (NIL "  ")
                              (PROGN (SELECTQ (FETCH EOL OF INFO1)
                                         (CR 'C)
                                         (LF 'L)
                                         (CRLF 2)
                                         " ")
                                     (SELECTQ (FETCH EOL OF INFO2)
                                         (CR 'C)
                                         (LF 'L)
                                         (CRLF 2)
                                         " ")))
                " ")
         (CL:WHEN INFO1
             (PRINTOUT STREAM (SUBSTRING (FETCH FULLNAME OF INFO1)
                                     (ADD1 NCHARSDIR1)
                                     NIL
                                     (CONSTANT (CONCAT)))
                    " ")
             (CL:WHEN PRINTAUTHOR
                 (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO1)
                        ") "))
             (PRINTOUT STREAM (FETCH LENGTH OF INFO1)
                    .TAB0 DATE1POS (FETCH DATE OF INFO1)))
         (PRINTOUT STREAM .TAB0 ENDDATE1 "  " (FETCH DATEREL OF ENTRY)
                "  ")
         (CL:WHEN INFO2
             (PRINTOUT STREAM (FETCH DATE OF INFO2)
                    "   "
                    (SUBSTRING (FETCH FULLNAME OF INFO2)
                           (ADD1 NCHARSDIR2)
                           NIL
                           (CONSTANT (CONCAT)))
                    " ")
             (CL:WHEN PRINTAUTHOR
                 (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO2)
                        ") "))
             (PRINTOUT STREAM (FETCH LENGTH OF INFO2)))
         (TERPRI STREAM])
)
(DEFINEQ

(CDMAP
  [LAMBDA (CDENTRIES FN)                                (* ; "Edited  6-Sep-2020 15:58 by rmk:")
    (CL:UNLESS CDENTRIES
        (PRINTOUT T T "Note:  Using LASTCDENTRIES" T T)
        (SETQ CDENTRIES LASTCDENTRIES))
    (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES)
       DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV)
       EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE))
             (SETQ INFO1 (FETCH INFO1 OF CDE))
             (SETQ DATEREL (FETCH DATEREL OF CDE))
             (SETQ INFO2 (FETCH INFO2 OF CDE))
             (SETQ EQUIV (FETCH EQUIV OF CDE)) DO (APPLY* FN CDE])

(CDENTRY
  [LAMBDA (MATCHNAME CDENTRIES)                     (* ; "Edited  5-Sep-2020 21:09 by rmk:")
    (ASSOC MATCHNAME (OR CDENTRIES LASTCDENTRIES])

(CDSUBSET
  [LAMBDA (CDENTRIES FN)                                (* ; "Edited 15-Sep-2020 13:49 by rmk:")
    (CL:UNLESS CDENTRIES
        (PRINTOUT T T "Note:  Using LASTCDENTRIES" T T)
        (SETQ CDENTRIES LASTCDENTRIES))
    (CONS (CAR CDENTRIES)
          (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES)
             DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV)
             EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE))
                   (SETQ INFO1 (FETCH INFO1 OF CDE))
                   (SETQ DATEREL (FETCH DATEREL OF CDE))
                   (SETQ INFO2 (FETCH INFO2 OF CDE))
                   (SETQ EQUIV (FETCH EQUIV OF CDE)) WHEN (APPLY* FN CDE) COLLECT
                                                                                      CDE])
)
(DEFINEQ

(BINCOMP
  [LAMBDA (FILE1 FILE2 EOLDIFFOK EOL1 EOL2)             (* ; "Edited 13-Oct-2020 08:53 by rmk:")

    (* ;; "Returns T if FILE1 and FILE2 are byte-equivalent.  Returns EOLDIFF if they are byte equivalent except for CR/LF/CRLF exchanges.  ")

    (* ;; "If EOLDIFFOK, return indicates that the files are the same except for EOL mappings.  If EOL1 and EOL2 are not provided, they are computed here.")

    (IF (IEQP (GETFILEINFO FILE1 'LENGTH)
                  (GETFILEINFO FILE2 'LENGTH))
        THEN [CL:WITH-OPEN-FILE
                  (STREAM1 FILE1 :DIRECTION :INPUT)
                  (CL:WITH-OPEN-FILE
                   (STREAM2 FILE2 :DIRECTION :INPUT)
                   (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL))

                   (* ;; "Simpler code to recompute eol's even if provided")

                   (BIND B1 B2 EOL1 EOL2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1))
                      UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2)))
                      DO (CL:UNLESS (AND EOLDIFFOK (SELCHARQ B1
                                                            (CR (CL:WHEN (EQ EOL1 'LF)
                                                                       (RETURN NIL))
                                                                (SETQ EOL1 'CR)
                                                                (SETQ EOL2 'LF)
                                                                (EQ B2 (CHARCODE LF)))
                                                            (LF (CL:WHEN (EQ EOL1 'CR)
                                                                       (RETURN NIL))
                                                                (SETQ EOL1 'LF)
                                                                (SETQ EOL2 'CR)
                                                                (EQ B2 (CHARCODE CR)))
                                                            NIL))
                                    (RETURN NIL))
                            (CL:UNLESS EOLDIFF
                                (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T]
      ELSEIF EOLDIFFOK
        THEN 

              (* ;; "Lengths are different possibly because of CRLF to CR/LF substitutions.")

              (* ;; 
        "More complex code could detect the EOLTYPE incrementally without separate passes, but ...")

              (CL:UNLESS EOL1
                  (SETQ EOL1 (EOLTYPE FILE1)))
              (CL:UNLESS EOL2
                  (SETQ EOL2 (EOLTYPE FILE2)))
              (CL:WHEN (IF [AND (EQ EOL1 'CRLF)
                                    (MEMB EOL2 '(LF CR]
                         ELSEIF [AND (EQ EOL2 'CRLF)
                                         (MEMB EOL1 '(LF CR]
                           THEN (SWAP FILE1 FILE2))

                  (* ;; "FILE1 is now CRLF, FILE2 is not.  If FILE1 isn't longer, it can't have a CRLF that corresponds to a CR or LF.")

                  (CL:WHEN (IGREATERP (GETFILEINFO FILE1 'LENGTH)
                                  (GETFILEINFO FILE2 'LENGTH))
                      [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT)
                             (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT)
                                    (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL))
                                    (BIND B1 B2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1))
                                       UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2)))
                                       DO (CL:UNLESS [AND (EQ (CHARCODE CR)
                                                                  B1)
                                                              (EQ (CHARCODE LF)
                                                                  (\BIN STREAM1))
                                                              (MEMB B2 (CHARCODE (CR LF]
                                                     (RETURN NIL))
                                             (CL:UNLESS EOLDIFF
                                                 (SETQ EOLDIFF (LIST EOL1 EOL2)))
                                       FINALLY (RETURN (OR EOLDIFF T]))])

(EOLTYPE
  [LAMBDA (FILE)                                        (* ; "Edited  3-Sep-2020 17:05 by rmk:")

    (* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.")

    (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
           (SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL))
           (BIND EOLTYPE
              DO (SELCHARQ (OR (\BIN STREAM)
                                   (RETURN EOLTYPE))
                          (CR (IF (EQ (CHARCODE LF)
                                          (\PEEKBIN STREAM T))
                                  THEN (CL:WHEN (MEMB EOLTYPE '(LF CR))
                                                  (RETURN NIL))
                                        (\BIN STREAM)
                                        (SETQ EOLTYPE 'CRLF)
                                ELSEIF (MEMB EOLTYPE '(LF CRLF))
                                  THEN (RETURN NIL)
                                ELSE (SETQ EOLTYPE 'CR)))
                          (LF (CL:WHEN (MEMB EOLTYPE '(CR CRLF))
                                     (RETURN NIL))
                              (SETQ EOLTYPE 'LF))
                          NIL])
)
(DECLARE%: EVAL@COMPILE

(RECORD CDENTRY (MATCHNAME INFO1 DATEREL INFO2 . EQUIV))

(RECORD CDINFO (FULLNAME DATE LENGTH AUTHOR TYPE EOL))
)



(* ;; "look for compiled files older than the sources")

(DEFINEQ

(FIND-UNCOMPILED-FILES
  [LAMBDA (FILES DFASLMARGIN COMPILEEXTS)               (* ; "Edited 20-Sep-2020 23:04 by rmk:")
                                                             (* ; "Edited  3-Nov-94 15:17 by jds")

    (* ;; "Produces a list of the source files in FILES that have no corresponding compiled file")

    (* ;; "This determines whether there is at least one compiled file.  If there are two or more, that's a problem")

    (* ;; "We want the most recent version only")

    (* ;; "Source files have a 2-element created-as with a non-NIL date")

    (SETQ FILES (FOR F IN (OR (LISTP FILES)
                                      (FILDIR FILES)) UNLESS (MEMB (SETQ F (PACKFILENAME
                                                                                'VERSION NIL
                                                                                'BODY F))
                                                                       $$VAL) COLLECT F))
    (FOR F SCREATION FILES IN FILES WHEN (AND (CADR (SETQ SCREATION (CREATED-AS
                                                                                 F)))
                                                          (NOT (CDDR SCREATION)))
       WHEN [SETQ FILES
                 (FOR CEXT CF IN (OR COMPILEEXTS *COMPILED-EXTENSIONS*)
                    WHEN (SETQ CF (INFILEP (PACKFILENAME 'EXTENSION CEXT 'VERSION NIL
                                                      'BODY F)))
                    COLLECT (CL:WHEN (SOURCE-FOR-COMPILED-P SCREATION CF DFASLMARGIN)
                                       (RETURN NIL))
                          CF
                    FINALLY 

                          (* ;; "If we found some compiled files, they weren't on this source.  If there weren't any compiled files to check, maybe there weren't any functions.")

                          (* ;; 
      "NLSETQ because we don't want to stop if there is an error, typically from a package problem")

                          (RETURN (OR $$VAL (LET [(FCOMS (CAR (NLSETQ (GETDEF (FILECOMS F)
                                                                             'VARS F]
                                                 (IF (NULL FCOMS)
                                                     THEN 

                                                           (* ;; 
                                               "GETDEF caused an error.  Maybe a package problem. ")

                                                           (AND NIL 'NOCOMMANDS)
                                                   ELSEIF (INFILECOMS? NIL '(FUNCTIONS FNS)
                                                                     FCOMS)
                                                     THEN T]
       COLLECT (CONS F (SELECTQ FILES
                               (T NIL)
                               (NOCOMMANDS (CONS "No commands"))
                               (FOR CF IN FILES COLLECT 

                                                        (* ;; 
           "Positive means that compiled is later than source, normal order but maybe by too much.")

                                                              (* ;; 
                                            "Negative means that compiled came before source.  Odd")

                                                              (LIST CF (COMPILE-SOURCE-DATE-DIFF
                                                                        CF SCREATION])

(FIND-UNSOURCED-FILES
  [LAMBDA (FILES DFASLMARGIN COMPILEEXTS)               (* ; "Edited 15-Sep-2020 15:32 by rmk:")
                                                             (* ; "Edited  3-Nov-94 15:17 by jds")

    (* ;; 
  "Produces a list of compiled FILES for which no source file can be found in the same directory.")

    (* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding?  So, give a margin.")

    (* ;; 
"We want the most recent version only.  Check CREATED-AS to make sure it really is a compiled file.")

    (* ;; "Sort to get lcoms and dfasls next to each other.")

    (LET (CCREATEDS)
         (SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS 
                                                                     *COMPILED-EXTENSIONS*)
                            JOIN (FOR CF IN [OR (LISTP FILES)
                                                            (FILDIR (PACKFILENAME 'EXTENSION CEXT
                                                                           'VERSION "" 'BODY
                                                                           '*]
                                        WHEN (CDDR (SETQ CCREATED (CREATED-AS CF)))
                                        UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED)))

         (* ;; "CCREATEDS is now a list of CREATED-AS items")

         (FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME 'EXTENSION 
                                                                                  NIL 'VERSION NIL
                                                                                  'BODY
                                                                                  (CAR CC]
                                                         (SOURCE-FOR-COMPILED-P (SETQ SF
                                                                                     (CREATED-AS
                                                                                      SF))
                                                                CC DFASLMARGIN))
            COLLECT [LIST (CAR CC)
                              (AND SF (LIST (CAR SF)
                                            (ROUND (COMPILE-SOURCE-DATE-DIFF CC SF]
            FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (CF1 CF2)
                                                        (ALPHORDER (FILENAMEFIELD (CAR CF1)
                                                                          'NAME)
                                                               (FILENAMEFIELD (CAR CF2)
                                                                      'NAME])

(FIND-SOURCE-FILES
  [LAMBDA (CFILES SDIRS DFASLMARGIN)                    (* ; "Edited  9-Sep-2020 12:26 by rmk:")

    (* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.")

    (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.")

    (SETQ SDIRS (FOR SD INSIDE (OR SDIRS T) COLLECT (DIRECTORYNAME SD)))
    (SORT (FOR CF SFILES CNAME CCREATED IN (OR (LISTP CFILES)
                                                       (FILDIR CFILES))
             WHEN (AND (SETQ CNAME (INFILEP CF))
                           (CDDR (SETQ CCREATED (CREATED-AS CF)))
                           (SETQ SFILES (FOR SD SF IN SDIRS
                                           WHEN (AND (SETQ SF (INFILEP (PACKFILENAME
                                                                            'NAME
                                                                            (FILENAMEFIELD
                                                                             CF
                                                                             'NAME)
                                                                            'BODY SD)))
                                                         (SOURCE-FOR-COMPILED-P SF CCREATED 
                                                                DFASLMARGIN)) COLLECT SF)))
             COLLECT (CONS CNAME SFILES))
          (FUNCTION (LAMBDA (P1 P2)
                      (ALPHORDER (FILENAMEFIELD (CAR P1))
                             (FILENAMEFIELD (CAR P2])

(FIND-COMPILED-FILES
  [LAMBDA (SFILES CDIRS DFASLMARGIN)                    (* ; "Edited  9-Sep-2020 12:26 by rmk:")

    (* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.")

    (* ;; "FILEDATE is true for source files and compiled files")

    (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.")

    (SETQ CDIRS (FOR CD INSIDE (OR CDIRS T) COLLECT (DIRECTORYNAME CD)))
    (SORT (FOR SF CFILES SNAME SCREATED IN (OR (LISTP SFILES)
                                                       (FILDIR SFILES))
             WHEN [AND (SETQ SNAME (INFILEP SF))
                           (SETQ SCREATED (CREATED-AS SF))
                           (NOT (CDDR SCREATED))
                           (SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD SNAME 'NAME))
                                           IN *COMPILED-EXTENSIONS*
                                           JOIN (FOR CD CF IN CDIRS
                                                       WHEN (AND (SETQ CF
                                                                      (INFILEP (PACKFILENAME
                                                                                'NAME ROOT
                                                                                'EXTENSION CEXT
                                                                                'BODY CD)))
                                                                     (SOURCE-FOR-COMPILED-P
                                                                      SCREATED CF DFASLMARGIN))
                                                       COLLECT CF] COLLECT (CONS SNAME CFILES
                                                                                         ))
          (FUNCTION (LAMBDA (P1 P2)
                      (ALPHORDER (FILENAMEFIELD (CAR P1))
                             (FILENAMEFIELD (CAR P2])

(FIND-UNLOADED-FILES
  [LAMBDA (FILES)                                       (* ; "Edited  9-Sep-2020 19:35 by rmk:")

    (* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.")

    (FOR F IN (OR (LISTP FILES)
                          (FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F)
                                                                             (CAR F)
                                                                             F)))
                                                        (FILEDATE F))
       UNLESS (GETP (FILENAMEFIELD F 'NAME)
                        'FILEDATES) COLLECT F])

(FIND-LOADED-FILES
  [LAMBDA (ROOTFILENAMES)                               (* ; "Edited 19-Sep-2020 07:20 by rmk:")
    (FOR RN INSIDE ROOTFILENAMES WHEN (GETP RN 'FILEDATES)
       COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD
                                                                             F
                                                                             'NAME)) COLLECT
                                                                                     F])

(FIND-MULTICOMPILED-FILES
  [LAMBDA (FILES SHOWINFO)                              (* ; "Edited 20-Sep-2020 20:57 by rmk:")

    (* ;; "Returns a list of names for files in FILES that have multiple compilations")

    (LET (SFILES)
         (FOR F EXT NAME IN (OR (LISTP FILES)
                                        (FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD
                                                                                  F
                                                                                  'EXTENSION))
                                                                       *COMPILED-EXTENSIONS*)
            DO (SETQ NAME (FILENAMEFIELD F 'NAME)) 

                  (* ;; "PUSHNEW because we haven't filtered out versions")

                  (PUSHNEW [CDR (OR (ASSOC NAME SFILES)
                                        (CAR (PUSH SFILES (CONS NAME]
                         EXT))
         (FOR S IN SFILES WHEN (CDDR S)
            COLLECT (IF SHOWINFO
                            THEN `[,(CAR S)
                                       ,(CADAR (FIND-LOADED-FILES (CAR S)))
                                       ,(CREATED-AS (CAR S))
                                       ,@(FOR EXT IN (SORT (CDR S))
                                            COLLECT (CREATED-AS (PACKFILENAME 'EXTENSION EXT
                                                                               'BODY
                                                                               (CAR S]
                          ELSE (CAR S])
)
(DEFINEQ

(CREATED-AS
  [LAMBDA (FILE)                                        (* ; "Edited 20-Sep-2020 23:06 by rmk:")

    (* ;; "For lisp source files, returns (filecreatename filecreateddate)")

    (* ;; "For lisp compiled files, returns (cfilename cfiledate sfilecreatename sfilecreateddate)")

    (* ;; "For other files, (fullfilename NIL)")

    (* ;; "The cfilename is just the current directory name for DFASLs.")

    (* ;; "So:  (CADR value) is non-NIL for Lisp files.  Of those, (CDDR value) is non-NIL for compiled files.")

    (* ;; "We disable the package delimiter because the atoms in changes may have a packages that we don't know.")

    (CL:WITH-OPEN-FILE
     (STREAM FILE :DIRECTION :INPUT)
     (LET
      (FILEDATE FILENAME SOURCEDATE SOURCENAME LINE POS)
      [IF (EQ (CHARCODE %()
                  (SKIPSEPRCODES STREAM))
          THEN                                           (* ; "Managed source or LCOM")
          (RESETLST
              [LET (FORM SFORM (RDTBL (FIND-READTABLE "OLD-INTERLISP-FILE")))
                   (SETQ POS (GETFILEPTR STREAM))
                   (READCCODE STREAM)
                   (IF (EQ 'DEFINE-FILE-INFO (RATOM STREAM RDTBL))
                       THEN 

                             (* ;; "Reading is package-safe")

                             (SETFILEPTR STREAM POS)
                             (SETQ FORM (READ STREAM RDTBL))
                             (SETQ RDTBL (FIND-READTABLE (LISTGET (CDR FORM)
                                                                :READTABLE)))
                     ELSE (SETFILEPTR STREAM POS))
                   (CL:WHEN (EQ 'PACKAGEDELIM (GETSYNTAX '%: RDTBL))
                       [RESETSAVE (SETSYNTAX '%: 'OTHER RDTBL)
                              `(SETSYNTAX %: PACKAGEDELIM ,RDTBL])

                   (* ;; "One way or the other, we're ready for the filecreated")

                   (CL:WHEN (EQ (CHARCODE %()
                                (SKIPSEPRCODES STREAM))
                       (SETQ FORM (READ STREAM RDTBL))
                       (CL:WHEN (MEMB (U-CASE (CAR FORM))
                                      '(FILECREATED IL%:FILECREATED))

                           (* ;; "IL%%:FILECREATED because we screwed the readtable.")

                           (IF [STREQUAL "compiled on " (CAR (LISTP (CADDR FORM]
                               THEN                      (* ; "LCOM, get source info")
                                     (IF [AND (EQ (CHARCODE %()
                                                      (SKIPSEPRCODES STREAM))
                                                  (MEMB [U-CASE (CAR (SETQ SFORM (READ STREAM RDTBL]
                                                        '(FILECREATED IL%:FILECREATED]
                                         THEN (SETQ FILENAME (FULLNAME STREAM))
                                               (SETQ FILEDATE (CADR FORM))
                                               (SETQ SOURCENAME (CADDR SFORM))
                                               (SETQ SOURCEDATE (CADR SFORM))
                                       ELSE (SETQ FILENAME (FULLNAME STREAM))
                                             (SETQ FILEDATE (CADR FORM)))
                             ELSE (SETQ FILENAME (CADDR FORM))
                                   (SETQ FILEDATE (CADR FORM)))))])
        ELSEIF (SETQ POS (STRPOS "XCL Compiler output for source file " (SETQ LINE (CL:READ-LINE
                                                                                        STREAM))
                                    1 NIL NIL T))
          THEN                                           (* ; "DFASL compiled?")
                (SETQ SOURCENAME (SUBATOM LINE POS))
                (CL:WHEN (SETQ POS (STRPOS "Source file created " (SETQ LINE (CL:READ-LINE STREAM))
                                          1 NIL NIL T))
                    [SETQ SOURCEDATE (GDATE (IDATE (SUBSTRING LINE POS]
                    (CL:WHEN (SETQ POS (STRPOS "FASL file created " (SETQ LINE (CL:READ-LINE STREAM))
                                              1 NIL NIL T))
                        [SETQ FILEDATE (GDATE (IDATE (SUBSTRING LINE POS]))]

      (* ;; "Revert filenames to Interlisp package if needed:")

      (CL:WHEN (STRPOS "IL:" FILENAME)
          (SETQ FILENAME (SUBATOM FILENAME 4)))
      (CL:WHEN (STRPOS "IL:" SOURCENAME)
          (SETQ SOURCENAME (MKATOM SOURCENAME 4)))

      (* ;; "Return DATE NIL if file is not a Lisp file")

      `(,(OR FILENAME (FULLNAME STREAM))
        ,(AND FILEDATE (GDATE (IDATE FILEDATE)))
        ,@(CL:WHEN SOURCENAME
              (LIST SOURCENAME (GDATE (IDATE SOURCEDATE))))])

(SOURCE-FOR-COMPILED-P
  [LAMBDA (SOURCE COMPILED DFASLMARGIN)                 (* ; "Edited 31-Oct-2020 09:12 by rmk:")

    (* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly.  But if they are within DFASLMARGIN, we assume a match.  We require exact date match for LCOMS")

    (* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.")

    (* ;; "")

    (* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).")

    (* ;; "A single positive integer x is interpreted as (x 0).  A single negative integer x is interpreted as (-x x) (before or after x).")

    (* ;; "Default is (20 0).")

    (* ;; "T is positive or negative infinity")

    (CL:UNLESS (LISTP SOURCE)
        (SETQ SOURCE (CREATED-AS SOURCE)))
    (CL:UNLESS (LISTP COMPILED)
        (SETQ COMPILED (CREATED-AS COMPILED)))
    (SETQ DFASLMARGIN (IF (NULL DFASLMARGIN)
                          THEN 

                                (* ;; 
                       "If compiled is later than source by less than 20 minutes, it's probably OK")

                                '(20 0)
                        ELSEIF (EQ T DFASLMARGIN)
                          THEN '(T 0)
                        ELSEIF (LISTP DFASLMARGIN)
                        ELSEIF (NOT (FIXP DFASLMARGIN))
                          THEN (ERROR "ILLEGAL DFASLMARGIN" DFASLMARGIN)
                        ELSEIF (MINUSP DFASLMARGIN)
                          THEN (LIST (MINUS DFASLMARGIN)
                                         DFASLMARGIN)
                        ELSE (LIST DFASLMARGIN 0)))
    (OR (EQUAL (CAR SOURCE)
               (CADDR COMPILED))
        (EQUAL (CADR SOURCE)
               (CADDDR COMPILED))
        (AND [EQ 'DFASL (U-CASE (FILENAMEFIELD (CAR COMPILED)
                                       'EXTENSION]
             (LET ((TIMEDIFF (COMPILE-SOURCE-DATE-DIFF COMPILED SOURCE)))

                  (* ;; "If compiled was no more than 20 minutes later, it's probably OK.  Of no more than DFASLMARGIN earlier, if it is negative.")

                  (AND (OR (EQ T (CAR DFASLMARGIN))
                           (LEQ TIMEDIFF (CAR DFASLMARGIN)))
                       (OR (EQ T (CADR DFASLMARGIN))
                           (GEQ TIMEDIFF (CADR DFASLMARGIN])

(COMPILE-SOURCE-DATE-DIFF
  [LAMBDA (CFILE SFILE)                                 (* ; "Edited 20-Sep-2020 22:59 by rmk:")

    (* ;; "Positive means that compiled is later than source, normal order but maybe by too much. Negative means that compiled came before source, i.e., compiled on a source that didn't yet exist.")

    (* ;; "Value is in minutes")

    (ROUND (FQUOTIENT [IDIFFERENCE [IDATE (CADDDR (OR (LISTP CFILE)
                                                      (CREATED-AS CFILE]
                             (IDATE (CADR (OR (LISTP SFILE)
                                              (CREATED-AS SFILE]
                  (TIMES 60 ONESECOND])
)
(DEFINEQ

(FIX-DIRECTORY-DATES
  [LAMBDA (FILES MARGIN)                                (* ; "Edited 30-Oct-2020 22:01 by rmk:")

    (* ;; "For Lisp source and compiled files, ensures that the directory file date corresponds to the  filecreated date. Returns the list of files whose dates were changed.")

    (* ;; "This allows for the fact that directory dates that  are no later than, say, 30 seconds of the filecreated date are probably OK--the directory date may be set when the file is closed.")

    (* ;; "Use IDATEs in case FDCDATE is not Y2K.")

    (* ;; "Stop if directory date is more than 2 minutes earlier than the filecreated date.  Earlier could be because the dates are asserted at different points in the filing process.  But 2 minutes is worth thinking about.  Returning from HELP will get them aligned.")

    (SETQ MARGIN (ITIMES (OR MARGIN 2)
                        60 ONESECOND))
    (FOR F DIDATE FCDATE IN (OR (LISTP FILES)
                                        (FILDIR FILES)) WHEN (SETQ FCDATE (FILEDATE F))
       UNLESS (IEQP (SETQ DIDATE (GETFILEINFO F 'ICREATIONDATE))
                        (SETQ FCDATE (IDATE FCDATE))) COLLECT (CL:WHEN (IGREATERP (IDIFFERENCE
                                                                                       FCDATE DIDATE)
                                                                                  MARGIN)
                                                                      (HELP 
                                                       "DIRECTORY DATE EARLIER THAN FILECREATED DATE"
                                                                            (LIST F (GDATE DIDATE)
                                                                                  (GDATE FCDATE))))
                                                            (SETFILEINFO F 'ICREATIONDATE FCDATE)
                                                            F])

(FIX-EQUIV-DATES
  [LAMBDA (CDENTRIES)                                   (* ; "Edited  1-Sep-2020 16:21 by rmk:")

    (* ;; "For every entry whose files are EQUIVALENT and whose filedates are different, sets the directory of the file with the later date to be the date of the one with the earlier date.  This preumes that the later one must have been a copy. ")

    (CL:UNLESS CDENTRIES
        (PRINTOUT T "Note:  Using LASTCDENTRIES" T)
        (SETQ CDENTRIES LASTCDENTRIES))
    (FOR CDE EARLY LATE IN (CDR CDENTRIES) WHEN (FETCH EQUIV OF CDE)
       UNLESS (EQ '= (FETCH DATEREL OF CDE))
       COLLECT (SELECTQ (FETCH DATEREL OF CDE)
                       (> (SETQ EARLY (FETCH INFO2 OF CDE))
                          (SETQ LATE (FETCH INFO1 OF CDE)))
                       (< (SETQ EARLY (FETCH INFO1 OF CDE))
                          (SETQ LATE (FETCH INFO2 OF CDE)))
                       (SHOULDNT))
             (SETFILEINFO (FETCH FULLNAME OF LATE)
                    'ICREATIONDATE
                    (GETFILEINFO (FETCH FULLNAME OF EARLY)
                           'ICREATIONDATE))
             (FETCH FULLNAME OF LATE])

(COPY-COMPARED-FILES
  [LAMBDA (CDENTRIES TARGET MATCHNAMES)                 (* ; "Edited  1-Sep-2020 16:20 by rmk:")

    (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.")

    (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target.  Value is the list of matchnames whose files have been copied.")

    (* ;; "Directory filedates and other properties are preserved.")

    (CL:UNLESS (MEMB TARGET '(1 2))
           (ERROR "INVALID TARGET" TARGET))
    (CL:UNLESS CDENTRIES
        (PRINTOUT T "Note:  Using LASTCDENTRIES" T)
        (SETQ CDENTRIES LASTCDENTRIES))
    (SETQ MATCHNAMES (MKLIST MATCHNAMES))
    (FOR CDE SINFO TINFO MATCHNAME IN (CDR CDENTRIES) EACHTIME (SETQ SINFO
                                                                            (FETCH INFO1
                                                                               OF CDE))
                                                                    (SETQ TINFO (FETCH INFO2
                                                                                   OF CDE))
                                                                    (CL:WHEN (EQ TARGET 1)
                                                                           (SWAP SINFO TINFO))
                                                                    (SETQ MATCHNAME
                                                                     (FETCH MATCHNAME
                                                                        OF CDE))
       WHEN (AND (FETCH FULLNAME OF SINFO)
                     (FETCH FULLNAME OF TINFO)) UNLESS (AND MATCHNAMES
                                                                        (NOT (MEMB MATCHNAME 
                                                                                   MATCHNAMES)))
       COLLECT (COPYFILE (FETCH FULLNAME OF SINFO)
                          (PACKFILENAME 'VERSION NIL 'BODY (FETCH FULLNAME OF TINFO)))
             MATCHNAME])

(COPY-MISSING-FILES
  [LAMBDA (CDENTRIES TARGET MATCHNAMES)                 (* ; "Edited  1-Sep-2020 16:21 by rmk:")

    (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.")

    (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target.  Value is the list of matchnames whose files have been copied.")

    (* ;; "Directory filedates and other properties are preserved.")

    (CL:UNLESS (MEMB TARGET '(1 2))
           (ERROR "INVALID TARGET" TARGET))
    (CL:UNLESS CDENTRIES
        (PRINTOUT T "Note:  Using LASTCDENTRIES" T)
        (SETQ CDENTRIES LASTCDENTRIES))
    (CL:UNLESS (STRINGP (CADR (CAR CDENTRIES)))
        (ERROR "(CAR CDENTRIES) IS NOT A VALID PARAMETER LIST" (CAR CDENTRIES)))
    (SETQ MATCHNAMES (MKLIST MATCHNAMES))
    (FOR CDE SINFO TINFO TDIR MATCHNAME (TDIR _ (CL:IF (EQ TARGET 1)
                                                        (CAAR CDENTRIES)
                                                        (CADAR CDENTRIES))) IN (CDR CDENTRIES)
       EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE))
             (SETQ SINFO (FETCH INFO1 OF CDE))
             (SETQ TINFO (FETCH INFO2 OF CDE))
             (CL:WHEN (EQ TARGET 1)
                    (SWAP SINFO TINFO)) WHEN (AND (FETCH FULLNAME OF SINFO)
                                                          (NOT (FETCH FULLNAME OF TINFO)))
       UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES)))
       COLLECT 

             (* ;; "Using the source fullname in the target should preserve the version number")

             (COPYFILE (FETCH FULLNAME OF SINFO)
                    (PACKFILENAME 'BODY TDIR 'BODY (FETCH FULLNAME OF SINFO)))
             MATCHNAME])

(COMPILED-ON-SAME-SOURCE
  [LAMBDA (CDENTRIES)                                   (* ; "Edited  9-Sep-2020 13:00 by rmk:")

    (* ;; "Returms a subset of CDENTRIES consisting of files that are compiled on the same source (i.e. their source names or dates are the same). Preserves the header.")

    (CDSUBSET CDENTRIES (FUNCTION (LAMBDA (CDE)
                                        (DECLARE (USEDFREE INFO1 INFO2))
                                        (LET (CREATED1 CREATED2)
                                             (CL:WHEN [AND (EQ 'COMPILED (FETCH TYPE OF
                                                                                         INFO1))
                                                           (EQ 'COMPILED (FETCH TYPE OF
                                                                                         INFO2))
                                                           [CDDR (SETQ CREATED1
                                                                  (CREATED-AS (FETCH FULLNAME
                                                                                     OF INFO1]
                                                           (CDDR (SETQ CREATED2
                                                                  (CREATED-AS (FETCH FULLNAME
                                                                                     OF INFO2]
                                                 (OR (EQUAL (CADDR CREATED1)
                                                            (CADDR CREATED2))
                                                     (EQUAL (CADDDR CREATED1)
                                                            (CADDDR CREATED2))))])
)

(RPAQ ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01")
                           (IDATE "1-Jan-2020 12:00:00")))

(RPAQ? LASTCDENTRIES NIL)
(DEFINEQ

(COMPARE-ENTRY-SOURCE-FILES
  [LAMBDA (CDENTRY LISTSTREAM EXAMINE DW?)              (* ; "Edited 30-Aug-2020 12:22 by rmk:")

    (* ;; "Wrapper to call COMPARESOURCES on the Lisp source files of CDENTRY")

    (CL:WHEN [AND (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO1 OF CDENTRY)))
                  (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO2 OF CDENTRY]
        (COMPARESOURCES (FETCH FULLNAME OF (FETCH INFO1 OF CDENTRY))
               (FETCH FULLNAME OF (FETCH INFO2 OF CDENTRY))
               EXAMINE DW? LISTSTREAM))])
)

(FILESLOAD COMPARESOURCES)
(PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998
 2018 2020))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1649 16680 (COMPAREDIRECTORIES 1659 . 10149) (CDFILES 10151 . 14726) (
COMPAREDIRECTORIES.INFOS 14728 . 16243) (MATCHNAME 16245 . 16678)) (16681 23866 (CDPRINT 16691 . 21491
) (CDPRINT.LINE 21493 . 23864)) (23867 25619 (CDMAP 23877 . 24573) (CDENTRY 24575 . 24743) (CDSUBSET 
24745 . 25617)) (25620 31151 (BINCOMP 25630 . 29919) (EOLTYPE 29921 . 31149)) (31364 44571 (
FIND-UNCOMPILED-FILES 31374 . 35017) (FIND-UNSOURCED-FILES 35019 . 37828) (FIND-SOURCE-FILES 37830 . 
39534) (FIND-COMPILED-FILES 39536 . 41614) (FIND-UNLOADED-FILES 41616 . 42360) (FIND-LOADED-FILES 
42362 . 42916) (FIND-MULTICOMPILED-FILES 42918 . 44569)) (44572 52774 (CREATED-AS 44582 . 49379) (
SOURCE-FOR-COMPILED-P 49381 . 52079) (COMPILE-SOURCE-DATE-DIFF 52081 . 52772)) (52775 61754 (
FIX-DIRECTORY-DATES 52785 . 54753) (FIX-EQUIV-DATES 54755 . 56015) (COPY-COMPARED-FILES 56017 . 58141)
 (COPY-MISSING-FILES 58143 . 59982) (COMPILED-ON-SAME-SOURCE 59984 . 61752)) (61909 62520 (
COMPARE-ENTRY-SOURCE-FILES 61919 . 62518)))))
STOP
\ No newline at end of file
diff --git a/lispusers/HISTMENU b/lispusers/HISTMENU
new file mode 100644
index 00000000..7bb53c19
--- /dev/null
+++ b/lispusers/HISTMENU
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "10-Nov-2020 15:57:14" |{DSK}<export>home>denber>lisp>HISTMENU.;40| 28526  

      |changes| |to:|  (FNS |HistoryMenu| |UpdateHistoryWindow| |UpdateWistoryWindow| 
                            |HistRightButtonFn| |HistMenuOp| |HistMenuMiddle| REMOVENTH)
                       (VARS HISTMENUCOMS HISTCOMS)

      |previous| |date:| "20-Oct-2020 12:02:51" |{DSK}<export>home>denber>lisp>HISTMENU.;1|)


(PRETTYCOMPRINT HISTMENUCOMS)

(RPAQQ HISTMENUCOMS ((FNS |HistMenuMiddle| |HistMenuOp| |HistRightButtonFn| |HistoryMenu| 
                              REMOVENTH |UpdateHistoryWindow| |UpdateWistoryWindow|)
                         (VARS HISTCOMS)))
(DEFINEQ

(|HistMenuMiddle|
  (LAMBDA (ITEM MENU KEY)

    (* |;;| "Actions to take when the middle button is pressed on a History Window menu item.")
                                                       (* \; "Edited 30-Oct-2020 14:36 by root")
    (PROG (N)                                                (* PRINT "HistMenuMiddle")
                                                             (* PRINT ITEM)
          (RETURN (CADR ITEM)))))

(|HistMenuOp|
  (LAMBDA (ITEM MENU KEY)                              (* \; "Edited  4-Nov-2020 19:59 by root")

    (* |;;| "Process History Window menu items when the user clicks on one.")

    (PROG (NITEMS)

     (* |;;| "Need to know the number of the item (ie. ITEMNO) the user clicked on in the menu so we can compute the Exec line that corresponds to.")

          (SETQ ITEMNO (|\\ItemNumber| ITEM (|fetch| (MENU ITEMS) |of| MENU)))
                                                             (* PRINT ITEMNO)
                                                             (* SETQ ITEMNO (-
                                                           ITEMNO 2))
          (SETQ ITEMEXEC (- LASTEXEC ITEMNO))

     (* |;;| 
   "This method is needed to stay in sync in case the user deletes an entry form the menu.")

          (SETQ ITEMEXEC (CAADAR (NTH |HistoryString| ITEMNO)))
                                                             (* \; 
                                                           "The exec line of the selected item.")

     (* |;;| " Stuff the appropriate text into the Exec window.  Since it actually goes into the window that has the caret first check to see if the window with focus is an Exec window.  Note the original HISTMENU did not do this.")
                                                             (* PRINT "HistMenuOp KEY=")
                                                             (* PRINT KEY)
          (|if| (NEQ (STRPOS "EXEC" (PROCESSPROP (TTY.PROCESS)
                                               'NAME))
                         NIL)
              |then| (SELECTQ KEY
                             (LEFT (BKSYSBUF (CONCAT "REDO " ITEMEXEC))
                                   (BKSYSCHARCODE (CHARCODE CR)))
                             (MIDDLE (SETQ MRET (MENU MMENU))(* \; 
                                  "Show the middle button menu and return which item was selected.")
                                                             (* PRINT MRET)
                                     (SETQ MRET (CADR MRET))
                                     (SELECTQ MRET
                                         (REDO (BKSYSBUF (CONCAT "REDO " ITEMEXEC))
                                               (BKSYSCHARCODE (CHARCODE CR)))
                                         (FIX (BKSYSBUF (CONCAT "FIX " ITEMEXEC))
                                              (BKSYSCHARCODE (CHARCODE CR)))
                                         (UNDO (BKSYSBUF (CONCAT "UNDO " ITEMEXEC))
                                               (BKSYSCHARCODE (CHARCODE CR)))
                                         (?? (BKSYSBUF (CONCAT "?? " ITEMEXEC))
                                             (BKSYSCHARCODE (CHARCODE CR)))
                                         (|Deleted|          (* PRINT "DELETE")
                                                             (* PRINT ITEMNO)
                                                    (SETQ NITEMS (LENGTH |HistoryString|))

                                                    (* |;;| 
                                                  "Remove the selected item from HistoryString:")

                                                    (SETQ |HistoryString| (REMOVENTH (- ITEMNO 1)
                                                                                 |HistoryString|))

                                                    (* |;;| 
                                  "Remove the selected item from HMITEMS too so they stay in sync.")

                                                    (SETQ HMITEMS (REMOVENTH (- ITEMNO 1)
                                                                         HMITEMS))

                                 (* |;;| "Now add in the earlier Exec item to the end so that both lists remain histMenuLength long.  Ie. if the last item on the last was 734, go find 733 and tack it on the end.")

                                                    (SETQ NBACK (LIST (MINUS (SUB1 NITEMS))))
                                                    (SETQ |HistoryString| (APPEND |HistoryString|
                                                                                 (LISPXFIND
                                                                                  LISPXHISTORY NBACK
                                                                                  'ENTRIES)))
                                                    (SETQ HMITEMS
                                                     (APPEND HMITEMS
                                                            (LIST (LIST (CAAAR (NTH |HistoryString| 
                                                                                    NITEMS))))))

                                                    (* |;;| "And finally update the menu image.")

                                                    (|replace| ITEMS |of| |HistMenu|
                                                       |with| HMITEMS)
                                                    (UPDATE/MENU/IMAGE |HistMenu|)
                                                    (REDISPLAYW |HistWin|))
                                         NIL))
                             (* |;;| "The RIGHTBUTTONFN of the underlying window takes precedence over the WHENSELECTEDFN of the menu filling the window so we do not put a RIGHT button entry here.")
                             (RIGHT (PRINT "HistMenuOp RIGHT")
                                                             (* SETQ MRET (CAR (MENU 
                                                           |HistRightMenu|)))
                                    (SETQ MRET NIL)
                                    (PRINT MRET)
                                    (SELECTQ MRET
                                        (|Bury| (BURYW |HistWin|))
                                        (|Move| (MOVEW |HistWin|))
                                        (|Shrink| (SHRINKW |HistWin|))
                                        (|Update| (|UpdateHistoryWindow|))
                                        NIL))
                             NIL)
            |else| (PROMPTPRINT "Please select the Exec window for this action.")))))

(|HistRightButtonFn|
  (LAMBDA (WIN)                                        (* \; "Edited  8-Nov-2020 17:01 by root")
    (PROG (X)
          (MENU |HistRightMenu|)                             (* SELECTQ MRET (|Bury|
                                                           (BURYW |HistWin|))
                                                           (|Move| (MOVEW |HistWin|))
                                                           (|Shrink| (SHRINKW |HistWin|))
                                                           (|Update| (|UpdateHistoryWindow|)) 
                                                           NIL)
          (RETURN WIN))))

(|HistoryMenu|
  (LAMBDA (|histMenuLength| |histMenuPosition|)        (* \; "Edited 10-Nov-2020 15:56 by root")
    (PROG (NEGLEN)                                           (* PRINT "Start HistoryMenu")
          (OR |histMenuLength| (SETQ |histMenuLength| 30))

     (* |;;| "The MIN here is needed in case the user starts HistoryMenu before the history has grown to the requested size.")

          (SETQ ACTUALNITEMS (MIN (CADR LISPXHISTORY)
                                  |histMenuLength|))
          (SETQ NEGLEN (MINUS (MIN |histMenuLength| ACTUALNITEMS)))
          (SETQ NBACK (LIST -1 `THRU NEGLEN))                (* \; " N.B. backquote!")
                                                             (* OR |histMenuPosition|
                                                           (SETQ |histMenuPosition|
                                                           (QUOTE (LASTMOUSEX LASTMOUSEY 176 
                                                           464))))
          (SETQ |HistEventWidth| (- (OR (CADDR |histMenuPosition|)
                                        178)
                                    4))
          (SETQ |HistoryString| (LISPXFIND LISPXHISTORY NBACK 'ENTRIES))
          (SETQ HMITEMS (LIST (CAAR |HistoryString|)))
          (|for| I |from| 2 |to| (MIN |histMenuLength| ACTUALNITEMS)
             |do|                                        (* PRINT (CAAAR (NTH |HistoryString| 
                                                           I)))
                   (SETQ HMITEMS (APPEND HMITEMS (LIST (LIST (CAAAR (NTH |HistoryString| I)))))))

     (* |;;| "try (CAADAR (NTH HistoryString n)) to get item no.")

          (SETQ MMENU (|create| MENU
                             ITEMS _ '((REDO 'REDO "REDO item selected")
                                       (FIX 'FIX "Edit item selected")
                                       (UNDO 'UNDO "UNDO event selected")
                                       (?? '?? "Show event selected")
                                       (|Delete| '|Deleted| "Delete event from history menu"))
                             WHENSELECTEDFN _ '|HistMenuMiddle|))
          (SETQ |HistRightMenu| (|create| MENU
                                       ITEMS _ '((|Bury| (BURYW |HistWin|)
                                                        "Puts this window on the bottom.")
                                                 (|Move| (MOVEW |HistWin|)
                                                        "Moves window by a corner.")
                                                 (|Shrink| (SHRINKW |HistWin|)
                                                        
                           "Replaces this window with its icon (or title if it doesn't have an icon."
                                                        )
                                                 (|Update| (|UpdateHistoryWindow|)
                                                        
                                                       "Update the window to show all current items."
                                                        )))) (* SETQ |HistWin| (CREATEW
                                                           (QUOTE (50 100 172 382)) 
                                                           "History Window"))
          (SETQ |HistMenu| (|create| MENU
                                  ITEMS _ HMITEMS
                                  MENUROWS _ |histMenuLength|
                                  ITEMWIDTH _ |HistEventWidth|
                                  WHENSELECTEDFN _ '|HistMenuOp|
                                  MENUOUTLINESIZE _ 0))

     (* |;;| " Remember the last Exec line no. so we know which one to FIX, etc.")

          (SETQ LASTEXEC (CAR (HISTORY-NTH LISPXHISTORY 2)))
          (SETQ LASTEXEC (- LASTEXEC 2))                     (* SETQ |HistRightButtonFn| NIL)
          (SETQ |HistWin| (ADDMENU |HistMenu| NIL |histMenuPosition|))
          (OR |histMenuPosition| (MOVEW |HistWin|))
          (WINDOWPROP |HistWin| 'RIGHTBUTTONFN '|HistRightButtonFn|)
          (WINDOWPROP |HistWin| 'TITLE "History Window")
          (WINDOWPROP |HistWin| 'BORDER 4)                   (* CREATEMENUEDWINDOW PUTMENUPROP 
                                                           UPDATE/MENU/IMAG WINDOWPROP HWIN
                                                           (QUOTE RIGHTBUTTONFN) 
                                                           |HistRightButtonFn|)
          (RETURN HWIN))))

(REMOVENTH
  (LAMBDA (N LIST)                                     (* \; "Edited 27-Oct-2020 16:15 by root")

    (* |;;| "Return LIST with the Nth element removed.")

    (|if| (OR (ZEROP N)
                  (NULL LIST))
        |then| (CDR LIST)
      |else| (CONS (CAR LIST)
                       (REMOVENTH (CL:1- N)
                              (CDR LIST))))))

(|UpdateHistoryWindow|
  (LAMBDA (NEGLEN)                                     (* \; "Edited 10-Nov-2020 15:53 by root")
    (PROG (NITEMS)
          (SETQ NITEMS (LENGTH (|fetch| ITEMS |of| |HistMenu|)))

     (* |;;| "Need this in case HistoryMenu was started before the requested size was reached,")

          (SETQ ACTUALNITEMS (ADD1 (MIN (CADR LISPXHISTORY)
                                        NITEMS)))
          (SETQ NEGLEN (MINUS ACTUALNITEMS))
          (SETQ NBACK (LIST -2 `THRU NEGLEN))
          (SETQ |HistoryString| (LISPXFIND LISPXHISTORY NBACK 'ENTRIES))
          (SETQ HMITEMS (LIST (CAAR |HistoryString|)))

     (* |;;| "Make sure LASTEXEC again points to the most recent event since that has now changed.")

          (SETQ LASTEXEC (CAR (HISTORY-NTH LISPXHISTORY 2)))
          (SETQ LASTEXEC (- LASTEXEC 2))
          (|for| I |from| 2 |to| ACTUALNITEMS
             |do| (SETQ HMITEMS (APPEND HMITEMS (LIST (LIST (CAAAR (NTH |HistoryString| I)))))))
          (|replace| ITEMS |of| |HistMenu| |with| HMITEMS)
          (UPDATE/MENU/IMAGE |HistMenu|)
          (WINDOWPROP |HistWin| 'BORDER 4)
          (REDISPLAYW |HistWin|))))

(|UpdateWistoryWindow|
  (LAMBDA NIL
    (PROG (N)
      NIL)))
)

(RPAQQ HISTCOMS
       ((FNS PRINTHISTORY ENTRY# PRINTHISTORY1 PRINTHISTORY2)
        (FNS EVALQT ENTEREVALQT USEREXEC LISPXREAD LISPXREADBUF LISPXREADP LISPXUNREAD LISPX LISPX/ 
             LISPX/1 LISPXEVAL LISPXSTOREVALUE HISTORYSAVE LISPXFIND LISPXGETINPUT REMEMBER 
             GETEXPRESSIONFROMEVENTSPEC LISPXFIND0 LISPXFIND1 HISTORYFIND HISTORYFIND1 HISTORYMATCH 
             VALUEOF VALUOF VALUOF-EVENT LISPXUSE LISPXUSE0 LISPXUSE1 LISPXSUBST LISPXUSEC LISPXFIX 
             CHANGESLICE LISPXSTATE LISPXTYPEAHEAD)
        (ALISTS (SYSTEMINITVARS LISPXHISTORY GREETHIST))
        (DECLARE\: DONTEVAL@LOAD DOCOPY (VARS (\#REDOCNT 3)
                                              (ARCHIVEFLG T)
                                              (ARCHIVEFN)
                                              (ARCHIVELST '(NIL 0 50 100))
                                              (DISPLAYTERMFLG)
                                              (EDITHISTORY '(NIL 0 30 100))
                                              (HERALDSTRING)
                                              (LASTEXEC)
                                              (LASTHISTORY)
                                              (LISPXBUFS)
                                              (LISPXHIST)
                                              (LISPXHISTORY '(NIL 0 30 100))
                                              (LISPXPRINTFLG T)
                                              (LISPXUSERFN)
                                              (MAKESYSDATE)
                                              (PROMPT#FLG T)
                                              (REDOCNT)
                                              (SYSOUT.EXT 'SYSOUT)
                                              (SYSOUTFILE 'WORK)
                                              (SYSOUTGAG)
                                              (TOPLISPXBUFS)))
        (LISPXMACROS SHH RETRIEVE BEFORE AFTER OK REMEMBER\: REMEMBER TYPE-AHEAD ??T)
        (ADDVARS (LISPXFINDSPLST FROM TO THRU SUCHTHAT ALL AND)
               (BEFORESYSOUTFORMS (SETQ SYSOUTDATE (DATE))
                      (PROGN (COND ((NULL FILE)
                                    (SETQ FILE SYSOUTFILE))
                                   (T (SETQ SYSOUTFILE (PACKFILENAME 'VERSION NIL 'BODY FILE))))
                             (COND ((AND (NULL (FILENAMEFIELD FILE 'EXTENSION))
                                         (NULL (FILENAMEFIELD FILE 'VERSION)))
                                    (SETQ FILE (PACKFILENAME 'BODY FILE 'EXTENSION SYSOUT.EXT))))))
               (RESETFORMS (SETQ READBUF NIL)
                      (SETQ READBUFSOURCE NIL)
                      (SETQ TOPLISPXBUFS (OR (CLBUFS T)
                                             TOPLISPXBUFS))
                      (COND ((EQ CLEARSTKLST T)
                             (COND ((EQ NOCLEARSTKLST NIL)
                                    (CLEARSTK))
                                   (T (* |clear| |all| |stack| |pointers| EXCEPT |those| |on| 
                                         NOCLEARSTKLST.)
                                      (MAPC (CLEARSTK T)
                                            (FUNCTION (LAMBDA (X)
                                                             (AND (NOT (FMEMB X NOCLEARSTKLST))
                                                                  (RELSTK X))))))))
                            (T (MAPC CLEARSTKLST (FUNCTION RELSTK))
                               (SETQ CLEARSTKLST NIL))))
               (HISTORYSAVEFORMS)
               (LISPXCOMS  |...| ?? FIX FORGET NAME ORIGINAL REDO REPEAT RETRY UNDO USE |fix| 
                      |forget| |name| |redo| |repeat| |retry| |undo| |use|)
               (SYSTATS (LISPXSTATS LISPX INPUTS)
                      (UNDOSAVES UNDO SAVES)
                      (UNDOSTATS CHANGES UNDONE)
                      NIL
                      (EDITCALLS CALLS TO EDITOR)
                      (EDITSTATS EDIT COMMANDS)
                      (EDITEVALSTATS COMMANDS INVOLVING EVALUATING A LISP EXPRESSION)
                      (EDITESTATS USES OF AN E COMMAND TYPED IN DIRECTLY)
                      (EDITISTATS USES OF AN I COMMAND TYPED IN DIRECTLY)
                      (EDITUNDOSAVES EDIT UNDO SAVES)
                      (EDITUNDOSTATS EDIT CHANGES UNDONE)
                      NIL
                      (P.A.STATS P.A. COMMANDS)
                      NIL
                      (CLISPIFYSTATS CALLS TO CLISPIFY)
                      NIL
                      (FIXCALLS CALLS TO DWIM)
                      (FIXTIME)
                      (ERRORCALLS WERE DUE TO ERRORS)
                      (DWIMIFYFIXES WERE FROM DWIMIFYING)
                      NIL "OF THOSE DUE TO ERRORS:" (TYPEINFIXES WERE DUE TO ERRORS IN TYPE-IN)
                      (PROGFIXES WERE DUE TO ERRORS IN USER PROGRAMS)
                      (SUCCFIXES1 OF THESE CALLS WERE SUCCESSFUL)
                      NIL "OF THE CALLS DUE TO DWIMIFYING:" (SUCCFIXES2 WERE SUCCESSFUL)
                      NIL
                      (SPELLSTATS OF ALL DWIM CORRECTIONS WERE SPELLING CORRECTIONS)
                      (CLISPSTATS WERE CLISP TRANSFORMATIONS)
                      (INFIXSTATS OF THESE WERE INFIX TRANSFORMATIONS)
                      (IFSTATS WERE IF/THEN/ELSE STATEMENTS)
                      (I.S.STATS WERE ITERATIVE STATEMENTS)
                      (MATCHSTATS WERE PATTERN MATCHES)
                      (RECORDSTATS WERE RECORD OPERATIONS)
                      NIL
                      (SPELLSTATS1 OTHER SPELLING CORRECTIONS\, E.G. EDIT COMMANDS)
                      NIL
                      (RUNONSTATS OF ALL SPELLING CORRECTIONS WERE RUN-ON CORRECTIONS)
                      NIL
                      (VETOSTATS CORRECTIONS WERE VETOED)
                      NIL)
               (NOCLEARSTKLST))
        (APPENDVARS (AFTERSYSOUTFORMS (COND ((LISTP SYSOUTGAG)
                                             (EVAL SYSOUTGAG))
                                            (SYSOUTGAG)
                                            ((OR (NULL USERNAME)
                                                 (EQ USERNAME (USERNAME NIL T)))
                                             (TERPRI T)
                                             (PRIN1 HERALDSTRING T)
                                             (TERPRI T)
                                             (TERPRI T)
                                             (GREET0)
                                             (TERPRI T))
                                            (T (LISPXPRIN1 '"****ATTENTION USER " T)
                                               (LISPXPRIN1 (USERNAME)
                                                      T)
                                               (LISPXPRIN1 '":
this sysout is initialized for user " T)
                                               (LISPXPRIN1 USERNAME T)
                                               (LISPXPRIN1 '".
" T)
                                               (LISPXPRIN1 '"To reinitialize, type GREET()
" T)))
                           (SETINITIALS)))
        (P (MAPC SYSTATS (FUNCTION (LAMBDA (X)
                                          (AND (LISTP X)
                                               (EQ (GETTOPVAL (CAR X))
                                                   'NOBIND)
                                               (SETTOPVAL (CAR X)
                                                      NIL)))))
           (PUTD 'E))
        (COMS (FNS GREET GREET0)
              (ADDVARS (PREGREETFORMS (DREMOVE GREETFORM RESETFORMS)
                              (SETQ CONSOLETIME (SETQ CPUTIME (SETQ EDITIME 0)))
                              (SETQ CONSOLETIME0 (CLOCK 0))
                              (SETQ CPUTIME0 (CLOCK 2)))
                     (POSTGREETFORMS (SETINITIALS)
                            (AND EDITCHARACTERS (APPLY 'SETTERMCHARS EDITCHARACTERS))))
              (DECLARE\: DONTEVAL@LOAD DOCOPY (VARS (GREETHIST)
                                                    (SYSTEMTYPE)
                                                    (GREETFORM '(LISPXEVAL '(GREET)
                                                                       '_))
                                                    (CUTEFLG)
                                                    (GREETDATES '((" 1-JAN" . "Happy new year")
                                                                  ("12-FEB"
                                                                        . "Happy Lincoln's birthday")
                                                                  ("14-FEB"
                                                                           . "Happy Valentine's day")
                                                                  ("22-FEB"
                                                                     . "Happy Washington's birthday")
                                                                  ("15-MAR"
                                                                        . "Beware the Ides of March")
                                                                  ("17-MAR"
                                                                         . "Happy St. Patrick's day")
                                                                  ("18-MAY" . "It's Victoria Day")
                                                                  (" 1-JUL" . "It's Canada Day")
                                                                  ("31-OCT" . "Trick or Treat")
                                                                  (" 5-NOV"
                                                                      . "<boom> it's Guy Fawkes day")
                                                                  ("25-DEC" . "Merry Christmas")))
                                                    (USERNAME)
                                                    (HOSTNAME)
                                                    (CONSOLETIME 0)
                                                    (CONSOLETIME0 0)
                                                    (CPUTIME 0)
                                                    (CPUTIME0 0)
                                                    (EDITIME 0)
                                                    (FIRSTNAME))
                     (ADDVARS (BEFOREMAKESYSFORMS (SETQ RESETFORMS (CONS GREETFORM RESETFORMS))
                                     (SETQ MAKESYSDATE (DATE))))
                     (ADDVARS (AFTERMAKESYSFORMS (LISPXEVAL '(GREET)
                                                        '_)))))
        (FNS LISPXPRINT LISPXPRIN1 LISPXPRIN2 LISPXPRINTDEF LISPXPRINTDEF0 LISPXSPACES LISPXTERPRI 
             LISPXTAB USERLISPXPRINT LISPXPUT)
        (GLOBALVARS \#REDOCNT ARCHIVEFLG ARCHIVEFN ARCHIVELST BOUNDPDUMMY BREAKRESETVALSLST 
               CAR/CDRNIL CHCONLST1 CLEARSTKLST CLISPARRAY CLISPCHARS CLISPFLG CLISPTRANFLG 
               CONSOLETIME CONSOLETIME0 CPUTIME CPUTIME0 CTRLUFLG CUTEFLG DISPLAYTERMFLG DWIMFLG 
               EDITHISTORY EDITIME EDITQUIETFLG EDITSTATS EVALQTFORMS FILERDTBL FIRSTNAME GREETDATES
               GREETHIST HISTORYCOMS HISTORYSAVEFN HISTORYSAVEFORMS HISTSTR0 HISTSTR2 HISTSTR3 IT 
               LASTHISTORY LISP-RELEASE-VERSION LISPXBUFS LISPXCOMS LISPXFINDSPLST LISPXFNS 
               LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS LISPXPRINTFLG LISPXREADFN LISPXSTATS 
               LISPXUSERFN MACSCRATCHSTRING NEWUSERFLG P.A.STATS POSTGREETFORMS PREGREETFORMS 
               PRETTYHEADER RANDSTATE READBUFSOURCE REDOCNT REREADFLG RESETFORMS SYSFILES 
               TOPLISPXBUFS USERHANDLE USERNAME)
        (VARS (LISP-RELEASE-VERSION 2.0))
        (BLOCKS (LISPXFINDBLOCK LISPXFIND LISPXFIND0 LISPXFIND1 HISTORYFIND HISTORYFIND1
                       (ENTRIES LISPXFIND HISTORYFIND)
                       (LOCALFREEVARS _FLG L LST Z =FLG HISTORYFLG PREDFLG LINE HISTORY TYPE BACKUP 
                              QUIETFLG)
                       (NOLINKFNS HISTORYMATCH LISPXGETINPUT))
               (NIL ENTRY# EVALQT GETEXPRESSIONFROMEVENTSPEC GREET GREET0 HISTORYMATCH HISTORYSAVE 
                    LISPX LISPX/ LISPX/1 LISPXEVAL LISPXFIND1 LISPXGETINPUT LISPXPRIN1 LISPXPRIN2 
                    LISPXPRINT LISPXPRINTDEF LISPXPRINTDEF0 LISPXPUT LISPXREAD LISPXREADBUF 
                    LISPXREADP LISPXSPACES LISPXSTOREVALUE LISPXSUBST LISPXTAB LISPXTERPRI 
                    LISPXTYPEAHEAD LISPXUNREAD LISPXUSE LISPXUSE0 LISPXUSE1 LISPXUSEC PRINTHISTORY 
                    PRINTHISTORY1 PRINTHISTORY2 USEREXEC USERLISPXPRINT VALUEOF VALUOF (LOCALVARS
                                                                                                 . T)
                    (SPECVARS LISPXLINE LISPXID LISPXVALUE LISPXLISTFLG HISTORY ID EVENT 
                           BREAKRESETVALS VARS GENLST INITLST NAME MESSAGE)
                    (LINKFNS . T)
                    (NOLINKFNS LISPXTYPEAHEAD UNDOLISPX ARCHIVEFN LISPXFIX LISPXUSE LISPXUSE0 
                           LISPXSUBST LISPXFIND HISTORYMATCH PRINTHISTORY DISPLAYTERMP 
                           LISPXSTOREVALUE HISTORYSAVEFN ENTEREVALQT PRINTHISTORY1 PRINTHISTORY2 
                           LISPXFIND HISTORYMATCH LISPXGETINPUT LISPXSUBST ARCHIVEFN LISPXFIX 
                           LISPXUSE LISPXUSE0 LISPXSUBST HISTORYMATCH PRINTHISTORY DISPLAYTERMP 
                           LISPXSTOREVALUE HISTORYSAVEFN ENTEREVALQT LISPXTYEAHEAD UNDOLISPX 
                           GREETFILENAME)))
        (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA VALUEOF)
                                                                             (NLAML)
                                                                             (LAMA)))))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (731 14594 (|HistMenuMiddle| 741 . 1200) (|HistMenuOp| 1202 . 7581) (|HistRightButtonFn|
 7583 . 8274) (|HistoryMenu| 8276 . 12906) (REMOVENTH 12908 . 13307) (|UpdateHistoryWindow| 13309 . 
14523) (|UpdateWistoryWindow| 14525 . 14592)))))
STOP
\ No newline at end of file
diff --git a/lispusers/HISTMENU.LCOM b/lispusers/HISTMENU.LCOM
new file mode 100644
index 00000000..b7c4dd18
Binary files /dev/null and b/lispusers/HISTMENU.LCOM differ
diff --git a/lispusers/HISTMENU.TEDIT b/lispusers/HISTMENU.TEDIT
new file mode 100644
index 00000000..50fbc19f
Binary files /dev/null and b/lispusers/HISTMENU.TEDIT differ
diff --git a/loadups/xfull35.dribble.~74~ b/loadups/xfull35.dribble.~74~
new file mode 100644
index 00000000..e8fc96f2
--- /dev/null
+++ b/loadups/xfull35.dribble.~74~
@@ -0,0 +1 @@
+
Full loadup started at 27-Oct-2020 15:43:11 while connected to 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>POSTSCRIPTSTREAM.LCOM;1
compiled on 14-May-2018 10:53:32
File created 14-May-2018 10:52:48
POSTSCRIPTSTREAMCOMS
Loading FULL fonts...
  Loading CLASSIC 8 10 12 
  Loading MODERN 8 10 12 
  Loading TERMINAL 8 10 12 
  Loading postscript fonts
FULL fonts loaded

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>CHAT.LCOM;1
compiled on 25-Oct-93 12:23:25
File created 20-Jan-93 13:46:52
CHATCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>DMCHAT.LCOM;1
compiled on 25-Feb-93 18:08:53
File created 20-Jan-93 13:49:09
DMCHATCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>CHATTERMINAL.LCOM;1
compiled on 24-Feb-93 19:37:23
File created  4-Jul-90 02:21:01
CHATTERMINALCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>NSCHAT.LCOM;1
compiled on 18-Jul-94 10:13:24
File created 12-Sep-91 18:26:50
NSCHATCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDIT.LCOM;1
compiled on 18-May-2018 09:16:24
File created 19-Apr-2018 12:22:03
TEDITCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITDCL.LCOM;1
compiled on 18-May-2018 09:17:04
File created 25-Aug-94 10:53:00
TEDITDCLCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>PCTREE.LCOM;1
compiled on 18-May-2018 09:19:35
File created 19-Apr-2018 12:19:49
PCTREECOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEXTOFD.LCOM;1
compiled on 11-Feb-2001 12:06:43
File created 11-Feb-2001 12:06:42
TEXTOFDCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITCOMMAND.LCOM;1
compiled on 18-May-2018 09:16:59
File created 20-Apr-2018 08:07:35
TEDITCOMMANDCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITSCREEN.LCOM;1
compiled on 18-May-2018 09:18:38
File created 25-Aug-94 13:26:23
TEDITSCREENCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITABBREV.LCOM;1
compiled on  6-Aug-2020 14:52:14
File created  6-Aug-2020 14:52:14
TEDITABBREVCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITLOOKS.LCOM;1
compiled on 18-May-2018 09:17:44
File created 29-Jan-99 17:33:35
TEDITLOOKSCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITFIND.LCOM;1
compiled on 18-May-2018 09:17:21
File created  6-May-2018 17:34:44
TEDITFINDCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITHISTORY.LCOM;1
compiled on 18-May-2018 09:17:41
File created 29-Jan-99 17:34:39
TEDITHISTORYCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITFILE.LCOM;1
compiled on 18-May-2018 09:17:06
File created 19-May-2001 11:45:53
TEDITFILECOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITWINDOW.LCOM;1
compiled on 18-May-2018 09:18:51
File created 21-Jun-99 20:00:42
TEDITWINDOWCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITSELECTION.LCOM;1
compiled on 18-May-2018 09:18:43
File created 25-Aug-94 10:56:07
TEDITSELECTIONCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>IMAGEOBJ.LCOM;1
compiled on  8-Feb-97 11:26:32
File created  7-Dec-95 13:21:56
IMAGEOBJCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>EDITBITMAP.LCOM;1
compiled on 25-Feb-93 18:10:27
File created 11-Jun-90 15:42:25
EDITBITMAPCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>READNUMBER.LCOM;1
compiled on 16-Aug-95 11:18:52
File created 25-May-93 00:28:30
READNUMBERCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TFBRAVO.LCOM;1
compiled on 19-Apr-2018 12:19:55
File created 19-Apr-2018 12:19:55
TFBRAVOCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITHCPY.LCOM;1
compiled on 18-May-2018 09:17:32
File created 25-Aug-94 10:54:07
TEDITHCPYCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITPAGE.LCOM;1
compiled on 18-May-2018 09:18:32
File created 25-Aug-94 10:55:28
TEDITPAGECOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITMENU.LCOM;1
compiled on 18-May-2018 09:18:07
File created 24-Apr-95 12:05:29
TEDITMENUCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITFNKEYS.LCOM;1
compiled on 18-May-2018 09:17:25
File created  6-May-2018 17:15:13
TEDITFNKEYSCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>HRULE.LCOM;1
compiled on 26-Feb-93 11:26:19
File created  8-Oct-92 16:50:21
HRULECOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITCHAT.LCOM;1
compiled on 18-May-2018 09:16:55
File created 28-Mar-94 16:05:24
IL:TEDITCHATCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>FILEBROWSER.LCOM;1
compiled on 11-Sep-2001 09:26:17
File created 11-Sep-2001 09:26:14

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TABLEBROWSER.LCOM;1
compiled on  1-Dec-2018 17:25:13
File created  1-Dec-2018 17:25:13
TABLEBROWSERCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>THINFILES.LCOM;1
compiled on 26-Jun-99 00:47:00
File created  1-May-92 16:49:39
THINFILESCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>GRAPHER.LCOM;1
compiled on 14-May-2018 10:24:43
File created 14-May-2018 10:24:38
GRAPHERCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>SPY.LCOM;1
compiled on 23-Aug-94 16:33:38
File created 29-Apr-94 14:13:52
SPYCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>WHERE-IS.DFASL;1
XCL Compiler output for source file {DSK}<python>lde>lispcore>library>WHERE-IS.;1
Source file created Wednesday, 13 June 1990, 1:16:15.
FASL file created Thursday, 21 January 1993, 18:52:55.


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>HASH-FILE.dfasl;1
XCL Compiler output for source file {PELE:MV:ENVOS}<LISPCORE>LIBRARY>HASH-FILE.;2
Source file created Monday, 11 June 1990, 16:16:54.
FASL file created Friday, 26 February 1993, 11:23:40.


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>CASH-FILE.DFASL;4
XCL Compiler output for source file {DSK}<usr>local>lde>lispcore>library>CASH-FILE.;2
Source file created 11-Jun-90 14:33:44
FASL file created Saturday, 19 September 2020, 22:04:31


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>COPYFILES.LCOM;1
compiled on  6-Apr-2018 21:14:29
File created  6-Apr-2018 21:14:29
COPYFILESCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>MSANALYZE.DFASL;1
XCL Compiler output for source file {PELE:MV:ENVOS}<LISPCORE>LIBRARY>MSANALYZE.;5
Source file created Wednesday, 15 August 1990, 13:11:23.
FASL file created Sunday, 28 February 1993, 23:16:46.


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>MSPARSE.DFASL;1
XCL Compiler output for source file {PELE:MV:ENVOS}<LISPCORE>LIBRARY>MSPARSE.;5
Source file created Wednesday, 15 August 1990, 13:00:12.
FASL file created Sunday, 28 February 1993, 23:24:50.


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>MASTERSCOPE.DFASL;3
XCL Compiler output for source file {DSK}<Users>kaplan>Local>medley3.5>lispcore>library>MASTERSCOPE.;4
Source file created Saturday, 19 September 2020, 9:54:51.
FASL file created Saturday, 19 September 2020, 9:54:51.


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>MSCOMMON.DFASL;1
XCL Compiler output for source file {PELE:MV:ENVOS}<LISPCORE>LIBRARY>MSCOMMON.;3
Source file created Monday, 4 May 1992, 13:19:40.
FASL file created Sunday, 28 February 1993, 23:23:14.


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>UNIXPRINT.DFASL;1
XCL Compiler output for source file {DSK}<Users>kaplan>Local>medley3.5>lispcore>library>UNIXPRINT.;8
Source file created Friday, 4 May 2018, 17:18:00.
FASL file created Friday, 4 May 2018, 17:18:00.


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>UNIXCOMM.LCOM;1
compiled on 25-Apr-2018 07:31:56
File created 25-Apr-2018 07:31:56
UNIXCOMMCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>UNICODE.LCOM;17
compiled on 17-Aug-2020 08:48:36
File created 17-Aug-2020 08:48:36
UNICODECOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>iso8859io.LCOM;4
compiled on  9-Mar-99 18:20:33
File created  9-Mar-99 18:20:26
ISO8859IOCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.LCOM;1
compiled on  8-Aug-2020 15:48:08
File created  8-Aug-2020 15:48:08
CLIPBOARDCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.LCOM;46
compiled on  8-Aug-2020 15:48:17
File created  8-Aug-2020 15:48:17
MACINTERFACECOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>PRETTYFILEINDEX.LCOM;2
compiled on 28-Jun-99 17:13:58
File created 28-Jun-99 17:13:51
PRETTYFILEINDEXCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>WHO-LINE.LCOM;1
compiled on 19-Feb-2001 11:57:34
File created 19-Feb-2001 11:53:32
WHO-LINECOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>NSCOPYFILE.LCOM;1
compiled on  8-Jun-94 17:54:54
File created 10-Dec-87 11:40:53
NSCOPYFILECOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>UNIXCHAT.LCOM;1
compiled on 21-Jan-93 18:45:15
File created 15-Aug-90 11:05:53
UNIXCHATCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>UNIXTELNET.LCOM;1
compiled on 18-Jul-94 23:29:48
File created 16-Feb-90 17:00:31
UNIXTELNETCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>SETDEFAULTPRINTER.LCOM;2
compiled on 12-Nov-98 17:41:28
File created  7-Jun-93 15:34:58
SETDEFAULTPRINTERCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>DEFAULTSUBITEMFN.LCOM;1
compiled on  8-Sep-94 20:23:23
File created  4-Mar-87 15:59:01
DEFAULTSUBITEMFNCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>LoadPatches.;1
File created 16-Nov-88 14:11:42
LOADPATCHESCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>patches>NOXNSPATCH.LCOM;1
compiled on 31-Mar-99 17:08:42
File created 31-Mar-99 17:08:40
NOXNSPATCHCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>patches>LLREADPATCH.LCOM;5
compiled on  1-Aug-2020 18:52:48
File created  1-Aug-2020 18:52:48
LLREADPATCHCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>patches>MACHINEINDEPENDENTPATCH.LCOM;2
compiled on 19-Sep-2020 21:18:45
File created 19-Sep-2020 20:56:09
MACHINEINDEPENDENTPATCHCOMS
About to end loadup
Creating FULL sysout on 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>/loadups/xfull35.sysout
\ No newline at end of file
diff --git a/loadups/xfull35.sysout.~8~ b/loadups/xfull35.sysout.~8~
new file mode 100644
index 00000000..cba36507
Binary files /dev/null and b/loadups/xfull35.sysout.~8~ differ
diff --git a/loadups/xlisp.dribble.~61~ b/loadups/xlisp.dribble.~61~
new file mode 100644
index 00000000..f6bf7010
--- /dev/null
+++ b/loadups/xlisp.dribble.~61~
@@ -0,0 +1,184 @@
+
+Synchronizing Lisp sysout at 27-Oct-2020 15:42:46 while connected to 
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>
+     {DSK}<Users>kaplan>Local>medley3.5>lispcore>makesysout>SYNCLISPFILES.;48
+     created 23-Oct-2020 23:51:41
+
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FASLOAD.DFASL;1
+XCL Compiler output for source file {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FASLOAD.;2
+Source file created Tuesday, 17 April 2018, 7:55:20.
+FASL file created Tuesday, 17 April 2018, 8:09:14.
+
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FONT.LCOM;6
+compiled on 28-Jun-99 16:29:55
+File created 28-Jun-99 16:29:49
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>UFSCALLC.LCOM;3
+compiled on 18-May-2018 12:53:18
+File created 18-May-2018 12:53:00
+UFSCALLCCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>UFS.LCOM;3
+compiled on 18-May-2018 09:20:25
+File created 31-Dec-2000 12:38:40
+UFSCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>APRINT.LCOM;2
+compiled on 17-Jan-2020 05:51:20
+File created 17-Jan-2020 05:51:20
+APRINTCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>PMAP.LCOM;3
+compiled on 18-May-2018 09:21:40
+File created  3-Feb-2002 14:11:02
+PMAPCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>ADIR.LCOM;7
+compiled on 14-Oct-2020 11:14:41
+File created 14-Oct-2020 11:14:03
+ADIRCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>COREIO.LCOM;2
+compiled on  4-Oct-2018 14:13:06
+File created  4-Oct-2018 14:13:06
+COREIOCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>ACODE.LCOM;6
+compiled on 25-Jun-2017 22:38:30
+File created 25-Jun-2017 22:35:00
+ACODECOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>IOCHAR.LCOM;10
+compiled on 10-Aug-2020 21:44:38
+File created 10-Aug-2020 21:44:38
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>LLDATATYPE.LCOM;1
+compiled on 28-Jun-99 16:57:53
+File created 28-Jun-99 16:57:50
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>LLCHAR.LCOM;2
+compiled on 11-Nov-2018 13:08:05
+File created 11-Nov-2018 13:08:04
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEIO.LCOM;12
+compiled on 13-Aug-2020 11:43:08
+File created 13-Aug-2020 11:43:08
+FILEIOCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>PRETTY.LCOM;6
+compiled on 16-Apr-2018 21:37:10
+File created 16-Apr-2018 21:37:09
+PRETTYCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>NEWPRINTDEF.LCOM;2
+compiled on 31-Dec-2000 11:53:35
+File created 31-Dec-2000 11:53:33
+NEWPRINTDEFCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FONTPROFILE.LCOM;2
+compiled on 14-May-2018 00:04:35
+File created 28-Jun-99 22:10:46
+FONTPROFILECOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>PRINTFN.LCOM;4
+compiled on 16-Apr-2018 21:40:32
+File created 16-Apr-2018 21:40:32
+PRINTFNCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>LOADFNS.LCOM;10
+compiled on 16-Apr-2018 17:38:16
+File created 16-Apr-2018 17:38:16
+LOADFNSCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.LCOM;13
+compiled on 27-Oct-2020 15:40:33
+File created 27-Oct-2020 15:40:32
+FILEPKGCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>ASKUSER.LCOM;5
+compiled on 10-Aug-2020 21:18:50
+File created 10-Aug-2020 21:18:50
+ASKUSERCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>CMLMODULES.DFASL;4
+XCL Compiler output for source file {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>CMLMODULES.;2
+Source file created Monday, 16 April 2018, 22:46:19.
+FASL file created Monday, 16 April 2018, 22:46:19.
+
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>LOGOW.DFASL;1
+XCL Compiler output for source file {DSK}<tilde>sybalsky>lispcore>sources>LOGOW.;2
+Source file created Sunday, 9 April 2000, 18:08:24.
+FASL file created Sunday, 9 April 2000, 18:08:25.
+
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>DEXEC.LCOM;12
+compiled on 13-Aug-2020 12:36:18
+File created 13-Aug-2020 12:36:18
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>INSPECT.LCOM;7
+compiled on 21-Apr-2018 08:08:07
+File created 21-Apr-2018 08:08:07
+INSPECTCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>TWODINSPECTOR.LCOM;2
+compiled on 11-Aug-2020 11:22:31
+File created 11-Aug-2020 11:22:30
+TWODINSPECTORCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.DFASL;9
+XCL Compiler output for source file {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;10
+Source file created 19-Sep-2020 22:02:59
+FASL file created Saturday, 19 September 2020, 22:02:59
+
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>HARDCOPY.LCOM;6
+compiled on 16-Apr-2018 22:15:08
+File created 16-Apr-2018 22:15:08
+HARDCOPYCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>INTERPRESS.LCOM;6
+compiled on 16-Apr-2018 21:56:38
+File created 16-Apr-2018 21:56:38
+INTERPRESSCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>SEDIT-COMMANDS.DFASL;3
+XCL Compiler output for source file {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>SEDIT-COMMANDS.;3
+Source file created Monday, 23 April 2018, 18:12:52.
+FASL file created Monday, 23 April 2018, 18:13:51.
+
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>SEDIT-WINDOW.DFASL;2
+XCL Compiler output for source file {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>SEDIT-WINDOW.;2
+Source file created Monday, 14 May 2018, 14:12:02.
+FASL file created Monday, 14 May 2018, 14:12:02.
+
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>TIME.LCOM;4
+compiled on 16-Apr-2018 23:05:17
+File created 16-Apr-2018 23:05:10
+
+
+30 files loaded
+
+{DSK}<USERS>KAPLAN>LOCAL>MEDLEY3.5>LISPCORE>PATCHES>LLREADPATCH.LCOM;5
+compiled on  1-Aug-2020 18:52:48
+File created  1-Aug-2020 18:52:48
+LLREADPATCHCOMS
+
+{DSK}<USERS>KAPLAN>LOCAL>MEDLEY3.5>LISPCORE>PATCHES>MACHINEINDEPENDENTPATCH.LCOM;2
+compiled on 19-Sep-2020 21:18:45
+File created 19-Sep-2020 20:56:09
+MACHINEINDEPENDENTPATCHCOMS
+
+{DSK}<USERS>KAPLAN>LOCAL>MEDLEY3.5>LISPCORE>PATCHES>NOXNSPATCH.LCOM;1
+compiled on 31-Mar-99 17:08:42
+File created 31-Mar-99 17:08:40
+NOXNSPATCHCOMS
+
+
+3 files loaded
+Creating updated LISP sysout on 
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>loadups>xlisp.sysout;2
diff --git a/loadups/xlisp.dribble.~62~ b/loadups/xlisp.dribble.~62~
new file mode 100644
index 00000000..039c7c5d
--- /dev/null
+++ b/loadups/xlisp.dribble.~62~
@@ -0,0 +1,184 @@
+
+Synchronizing Lisp sysout at 20-Nov-2020 23:12:24 while connected to 
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>
+     {DSK}<Users>kaplan>Local>medley3.5>lispcore>makesysout>SYNCLISPFILES.;48
+     created 23-Oct-2020 23:51:41
+
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FASLOAD.DFASL;1
+XCL Compiler output for source file {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FASLOAD.;2
+Source file created Tuesday, 17 April 2018, 7:55:20.
+FASL file created Tuesday, 17 April 2018, 8:09:14.
+
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FONT.LCOM;6
+compiled on 28-Jun-99 16:29:55
+File created 28-Jun-99 16:29:49
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>UFSCALLC.LCOM;3
+compiled on 18-May-2018 12:53:18
+File created 18-May-2018 12:53:00
+UFSCALLCCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>UFS.LCOM;3
+compiled on 18-May-2018 09:20:25
+File created 31-Dec-2000 12:38:40
+UFSCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>APRINT.LCOM;2
+compiled on 17-Jan-2020 05:51:20
+File created 17-Jan-2020 05:51:20
+APRINTCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>PMAP.LCOM;3
+compiled on 18-May-2018 09:21:40
+File created  3-Feb-2002 14:11:02
+PMAPCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>ADIR.LCOM;7
+compiled on 14-Oct-2020 11:14:41
+File created 14-Oct-2020 11:14:03
+ADIRCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>COREIO.LCOM;2
+compiled on  4-Oct-2018 14:13:06
+File created  4-Oct-2018 14:13:06
+COREIOCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>ACODE.LCOM;6
+compiled on 25-Jun-2017 22:38:30
+File created 25-Jun-2017 22:35:00
+ACODECOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>IOCHAR.LCOM;10
+compiled on 10-Aug-2020 21:44:38
+File created 10-Aug-2020 21:44:38
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>LLDATATYPE.LCOM;1
+compiled on 28-Jun-99 16:57:53
+File created 28-Jun-99 16:57:50
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>LLCHAR.LCOM;2
+compiled on 11-Nov-2018 13:08:05
+File created 11-Nov-2018 13:08:04
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEIO.LCOM;12
+compiled on 13-Aug-2020 11:43:08
+File created 13-Aug-2020 11:43:08
+FILEIOCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>PRETTY.LCOM;6
+compiled on 16-Apr-2018 21:37:10
+File created 16-Apr-2018 21:37:09
+PRETTYCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>NEWPRINTDEF.LCOM;2
+compiled on 31-Dec-2000 11:53:35
+File created 31-Dec-2000 11:53:33
+NEWPRINTDEFCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FONTPROFILE.LCOM;2
+compiled on 14-May-2018 00:04:35
+File created 28-Jun-99 22:10:46
+FONTPROFILECOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>PRINTFN.LCOM;4
+compiled on 16-Apr-2018 21:40:32
+File created 16-Apr-2018 21:40:32
+PRINTFNCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>LOADFNS.LCOM;10
+compiled on 16-Apr-2018 17:38:16
+File created 16-Apr-2018 17:38:16
+LOADFNSCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.LCOM;13
+compiled on 27-Oct-2020 15:40:33
+File created 27-Oct-2020 15:40:32
+FILEPKGCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>ASKUSER.LCOM;5
+compiled on 10-Aug-2020 21:18:50
+File created 10-Aug-2020 21:18:50
+ASKUSERCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>CMLMODULES.DFASL;4
+XCL Compiler output for source file {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>CMLMODULES.;2
+Source file created Monday, 16 April 2018, 22:46:19.
+FASL file created Monday, 16 April 2018, 22:46:19.
+
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>LOGOW.DFASL;1
+XCL Compiler output for source file {DSK}<tilde>sybalsky>lispcore>sources>LOGOW.;2
+Source file created Sunday, 9 April 2000, 18:08:24.
+FASL file created Sunday, 9 April 2000, 18:08:25.
+
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>DEXEC.LCOM;12
+compiled on 13-Aug-2020 12:36:18
+File created 13-Aug-2020 12:36:18
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>INSPECT.LCOM;7
+compiled on 21-Apr-2018 08:08:07
+File created 21-Apr-2018 08:08:07
+INSPECTCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>TWODINSPECTOR.LCOM;2
+compiled on 11-Aug-2020 11:22:31
+File created 11-Aug-2020 11:22:30
+TWODINSPECTORCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.DFASL;9
+XCL Compiler output for source file {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;10
+Source file created 19-Sep-2020 22:02:59
+FASL file created Saturday, 19 September 2020, 22:02:59
+
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>HARDCOPY.LCOM;6
+compiled on 16-Apr-2018 22:15:08
+File created 16-Apr-2018 22:15:08
+HARDCOPYCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>INTERPRESS.LCOM;6
+compiled on 16-Apr-2018 21:56:38
+File created 16-Apr-2018 21:56:38
+INTERPRESSCOMS
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>SEDIT-COMMANDS.DFASL;3
+XCL Compiler output for source file {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>SEDIT-COMMANDS.;3
+Source file created Monday, 23 April 2018, 18:12:52.
+FASL file created Monday, 23 April 2018, 18:13:51.
+
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>SEDIT-WINDOW.DFASL;2
+XCL Compiler output for source file {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>SEDIT-WINDOW.;2
+Source file created Monday, 14 May 2018, 14:12:02.
+FASL file created Monday, 14 May 2018, 14:12:02.
+
+
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>TIME.LCOM;4
+compiled on 16-Apr-2018 23:05:17
+File created 16-Apr-2018 23:05:10
+
+
+30 files loaded
+
+{DSK}<USERS>KAPLAN>LOCAL>MEDLEY3.5>LISPCORE>PATCHES>LLREADPATCH.LCOM;5
+compiled on  1-Aug-2020 18:52:48
+File created  1-Aug-2020 18:52:48
+LLREADPATCHCOMS
+
+{DSK}<USERS>KAPLAN>LOCAL>MEDLEY3.5>LISPCORE>PATCHES>MACHINEINDEPENDENTPATCH.LCOM;2
+compiled on 19-Sep-2020 21:18:45
+File created 19-Sep-2020 20:56:09
+MACHINEINDEPENDENTPATCHCOMS
+
+{DSK}<USERS>KAPLAN>LOCAL>MEDLEY3.5>LISPCORE>PATCHES>NOXNSPATCH.LCOM;1
+compiled on 31-Mar-99 17:08:42
+File created 31-Mar-99 17:08:40
+NOXNSPATCHCOMS
+
+
+3 files loaded
+Creating updated LISP sysout on 
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>loadups>xlisp.sysout;3
diff --git a/loadups/xlisp.sysout.~2~ b/loadups/xlisp.sysout.~2~
new file mode 100644
index 00000000..8247e228
Binary files /dev/null and b/loadups/xlisp.sysout.~2~ differ
diff --git a/loadups/xlisp.sysout.~3~ b/loadups/xlisp.sysout.~3~
new file mode 100644
index 00000000..b432811a
Binary files /dev/null and b/loadups/xlisp.sysout.~3~ differ
diff --git a/sources/CLSMARTEN b/sources/CLSMARTEN
new file mode 100644
index 00000000..e69de29b
diff --git a/sources/FILEPKG.LCOM.~13~ b/sources/FILEPKG.LCOM.~13~
new file mode 100644
index 00000000..c3d5a0d8
Binary files /dev/null and b/sources/FILEPKG.LCOM.~13~ differ
diff --git a/sources/FILEPKG.~12~ b/sources/FILEPKG.~12~
new file mode 100644
index 00000000..cafb9363
--- /dev/null
+++ b/sources/FILEPKG.~12~
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "27-Oct-2020 15:40:32" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;12 285044 

      changes to%:  (FNS MAKEFILE1 COMPILE-FILE?)

      previous date%: "10-Aug-2020 21:24:58" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;11)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1995, 2018, 2020 by Venue & Xerox Corporation.  All rights reserved.
The following program was created in 1982 but has not been published
within the meaning of the copyright law, is furnished under license,
and may not be used, copied and/or disclosed except in accordance
with the terms of said license.
")

(PRETTYCOMPRINT FILEPKGCOMS)

(RPAQQ FILEPKGCOMS
       [(COMS                                                (* ; 
            "standard records for accessing file  package type/command parts.  Exported for PRETTY")
              (VARS FILEPKGTYPEPROPS)
              (EXPORT (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS * FILEPKGRECORDS)))
              (FNS SEARCHPRETTYTYPELST PRETTYDEFMACROS FILEPKGCOMPROPS)
              (INITRECORDS * FILEPKGRECORDS))
        [DECLARE%: EVAL@COMPILE DOCOPY 

               (* ;; "Proclaim SPECIAL those variables that are used freely in a lot of code.")

               (P (CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES 
                                       PRETTYPRINTMACROS *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS
                                       PRETTYFLG))
                  (CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES 
                                       NOTCOMPILEDFILES MAKEFILEFORMS CLEANUPOPTIONS]
        (INITVARS (MSDATABASELST))
        [COMS 
              (* ;; "making, adding, listing, compiling files")

              (FNS CLEANUP COMPILEFILES COMPILEFILES0 CONTINUEDIT MAKEFILE FILECHANGES 
                   FILEPKG.MERGECHANGES FILEPKG.CHANGEDFNS MAKEFILE1 COMPILE-FILE? MAKEFILES ADDFILE
                   ADDFILE0 LISTFILES)
              (INITVARS (*DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)
                     (FILELST)
                     (LOADEDFILELST)
                     (NOTLISTEDFILES)
                     (NOTCOMPILEDFILES)
                     (MAKEFILEFORMS)
                     (NILCOMS))
              (ADDVARS (MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% 
                              F ST STF (REC . RC)
                              (BREC . RC)
                              (TC . C)
                              (BC . C)
                              (TCOMPL . C)
                              (BCOMPL . C)))
              (INITVARS (MAKEFILEREMAKEFLG T)
                     (CLEANUPOPTIONS '(RC]
        (COMS 
              (* ;; "scanning file coms")

              (FNS FILEPKGCHANGES GETFILEPKGTYPE MARKASCHANGED FILECOMS WHEREIS SMASHFILECOMS 
                   FILEFNSLST FILECOMSLST UPDATEFILES INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM
                   INFILECOMSVALS INFILECOMSVAL INFILECOMSPROP IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
                   IFCDECLARE INFILEPAIRS INFILECOMSMACRO))
        (COMS 
              (* ;; "adding to a file")

              (FNS FILES? FILES?1 FILES?PRINTLST ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM 
                   ADDTOCOM1 ADDNEWCOM MAKENEWCOM DEFAULTMAKENEWCOM)
              (INITVARS (DEFAULTCOMHASFILEFLG))
              (ADDVARS (MARKASCHANGEDFNS))
              (FNS MERGEINSERT MERGEINSERT1)
              
              (* ;; "RMK: Changed INITVARS to VARS, so = addition is a synonym for untypable LF, and also suppress appearance of raw CR and LF in the file")

              (VARS [ADDTOFILEKEYLST `(("[" "" EXPLAINSTRING 
                                           "[ -- prettyprint the item to terminal and then ask again"
                                            NOECHOFLG T)
                                       (= "" EXPLAINSTRING "= - same as previous response" NOECHOFLG
                                          T)
                                       (,(CHARACTER (CHARCODE LF))
                                        "" EXPLAINSTRING "{line-feed} - same as previous response" 
                                        NOECHOFLG T)
                                       (" " ,(CONCATCODES (LIST (CHARCODE SPACE)
                                                                (CHARCODE EOL)))
                                            EXPLAINSTRING "{space} - no action" NOECHOFLG T)
                                       ("]" ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL)))
                                            EXPLAINSTRING
                                            ,(CONCAT "] - nowhere, item is marked as a dummy"
                                                    (CHARACTER (CHARCODE EOL)))
                                            NOECHOFLG T)
                                       ["(" "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST
                                            (( "" CONFIRMFG [%) %] ,(CHARACTER (CHARCODE SPACE))
                                                                 ,(CHARACTER (CHARCODE EOL]
                                                RETURN
                                                (CDR ANSWER]
                                       (@ "Near: " EXPLAINSTRING 
                                          "@ other-item   -- put the item near the other item" 
                                          NOECHOFLG T KEYLST (( "" CONFIRMFLG
                                                                 [,(CHARACTER (CHARCODE EOL]
                                                                 RETURN ANSWER)))
                                       [,(CHARACTER (CHARCODE CR))
                                        "" RETURN ,(CHARACTER (CHARCODE SPACE]
                                       ("" "File name: " EXPLAINSTRING "a file name" KEYLST (]
                    (LASTFILE)))
        (COMS 
              (* ;; "deleting an item from a file")

              (FNS DELFROMFILES DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM MOVETOFILE)
              (P (MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)
                 (MOVD? 'MOVETOFILE 'MOVEITEM NIL T))
              (ADDVARS (SYSPROPS PROPTYPE VARTYPE)))
        [COMS                                                (* ; 
                      "functions for doing things and marking them changed and auxiliary functions")
              (FNS SAVEPUT)
              [DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
                                                     (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT]
              (FNS UNMARKASCHANGED PREEDITFN POSTEDITPROPS POSTEDITALISTS)
              (ADDVARS (LISPXFNS (PUT . SAVEPUT)
                              (PUTPROP . SAVEPUT]
        (COMS                                                (* ; 
                                                  "sub-functions for file package commands & types")
              (FNS ALISTS.GETDEF ALISTS.WHENCHANGED CLEARCLISPARRAY EXPRESSIONS.WHENCHANGED 
                   MAKEALISTCOMS MAKEFILESCOMS MAKELISPXMACROSCOMS MAKEPROPSCOMS MAKEUSERMACROSCOMS 
                   PROPS.WHENCHANGED FILEGETDEF.LISPXMACROS FILEGETDEF.ALISTS FILEGETDEF.RECORDS 
                   FILEGETDEF.PROPS FILEGETDEF.MACROS FILEGETDEF.VARS FILEGETDEF.FNS 
                   FILEPKGCOMS.PUTDEF FILES.PUTDEF VARS.PUTDEF FILES.WHENCHANGED)
              (ADDVARS (MACROPROPS MACRO BYTEMACRO DMACRO)
                     (SYSPROPS PROPTYPE))
              (PROP PROPTYPE I.S.OPR SUBR LIST CODE FILEDATES FILE FILEMAP EXPR VALUE COPYRIGHT 
                    FILETYPE)
              (PROP VARTYPE BAKTRACELST BREAKMACROS COMPILETYPELST EDITMACROS ERRORTYPELST FONTDEFS 
                    LISPXHISTORYMACROS LISPXMACROS PRETTYDEFMACROS PRETTYEQUIVLST PRETTYPRINTMACROS 
                    PRETTYPRINTYPEMACROS USERMACROS))
        (COMS                                                (* ; 
                    "Define the commands below AFTER the various properties have been established.")
              (USERMACROS M))
        (COMS                                                (* ; "GETDEF methods")
              (FNS RENAME CHANGECALLERS)
              (FNS SHOWDEF COPYDEF GETDEF GETDEFCOM GETDEFCOM0 GETDEFCURRENT GETDEFERR GETDEFFROMFILE
                   GETDEFSAVED PUTDEF EDITDEF DEFAULT.EDITDEF EDITDEF.FILES LOADDEF DWIMDEF DELDEF 
                   DELFROMLIST HASDEF GETFILEDEF SAVEDEF UNSAVEDEF COMPAREDEFS COMPARE TYPESOF)
              (INITVARS (WHEREIS.HASH)))
                                                             (* ; "Must come after PUTDEF")
        (FNS FIXEDITDATE EDITDATE?)
                                                             (* ; 
                                  "Edit date support for all kinds of definers (from PARC 6/10/92)")
        [VARS (EDITDATE-ARGLIST-DEFINERS '(FUNCTIONS TYPES))
              (EDITDATE-NAME-DEFINERS '(STRUCTURES VARIABLES]
        (GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
        (COMS 
              (* ;; "how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started.")

              (FNS FILEPKGCOM FILEPKGTYPE)
              (PROP ARGNAMES FILEPKGCOM)
              (ADDVARS (FILEPKGCOMSPLST FILEPKGCOMS)
                     (FILEPKGTYPES FILEPKGCOMS))
              (FILEPKGCOMS FILEPKGCOMS)
              (FILEPKGCOMS ALISTS DEFS EDITMACROS EXPRESSIONS FIELDS FILEPKGTYPES FILES FILEVARS FNS
                     INITRECORDS INITVARS LISPXCOMS LISPXMACROS MACROS PRETTYDEFMACROS PROPS RECORDS
                     OLDRECORDS SYSRECORDS USERMACROS VARS * CONSTANTS))
        (ADDVARS (SHADOW-TYPES (FUNCTIONS FNS)
                        (VARIABLES VARS CONSTANTS)))
        (INITVARS (SAVEDDEFS))
        (COMS                                                (* ; "EDITCALLERS")
              (FNS FINDCALLERS EDITCALLERS EDITFROMFILE FINDATS LOOKIN)
              (FNS SEPRCASE)
              [INITVARS (DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL]
              (INITVARS (SEPRCASEARRAYS)
                     (CLISPCASEARRAYS))
              (P (MOVD? 'INFILEP 'FINDFILE)
                                                             (* ; "or else from SPELLFILE"))
              (BLOCKS (EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
                             (NOLINKFNS LOADFROM)))
              (GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS))
        (COMS                                                (* ; "EXPORT")
              (FNS IMPORTFILE IMPORTEVAL IMPORTFILESCAN CHECKIMPORTS GATHEREXPORTS \DUMPEXPORTS)
              (FILEPKGCOMS EXPORT)
              [INITVARS (BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")
                     (ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"]
              (GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM))
        (COMS                                                (* ; "for GAINSPACE")
              (FNS CLEARFILEPKG)
              [ADDVARS (GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
                                              ((Y "es")
                                               (N "o")
                                               (E . "verything")
                                               (F "ilemaps only
"]
              (GLOBALVARS SMASHPROPSLST1))
        (GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT 
               DECLARETAGSLST DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 
               I.S.OPRLST LISPXCOMS LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS 
               MAKEFILEOPTIONS MAKEFILEREMAKEFLG MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS 
               SYSPROPS USERMACROS USERRECLST USERWORDS FILEPKGTYPEPROPS)
        (BLOCKS (DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
                       (SPECVARS COMSNAME))
               (ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
                      (NOLINKFNS . T)
                      (SPECVARS COMSNAME)
                      (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))
               (INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL 
                      INFILECOMSVALS INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
                      IFCDECLARE (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
                      INFILECOMSPROP)
               (NIL MAKEFILE (LOCALVARS . T)
                    (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))
               (ADDFILE ADDFILE ADDFILE0)
               (FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))
               (NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
                    COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES 
                    EDITDEF EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM 
                    FILEPKGCOMPROPS FILEPKGTYPE FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL 
                    LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES MAKEFILESCOMS MAKELISPXMACROSCOMS 
                    MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED MOVETOFILE 
                    POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
                    SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED 
                    UNSAVEDEF UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS 
                                                 COMPILE.EXT EDITMACROS EDITLOADFNSFLG LOADOPTIONS)
                    (LOCALVARS . T))
               (DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))
               (GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
                      GETDEFSAVED (RETFNS GETDEFCOM)
                      (NOLINKFNS . T)
                      (GLOBALVARS NOT-FOUNDTAG)))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS 
                               MAKEFILESCOMS MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP 
                               FILEPKGCOMPROPS PRETTYDEFMACROS)
                      (NLAML)
                      (LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES])



(* ; "standard records for accessing file  package type/command parts.  Exported for PRETTY")


(RPAQQ FILEPKGTYPEPROPS (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
                                   HASDEF EDITDEF CANFILEDEF FILEGETDEF))
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE DONTCOPY 

(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
(DECLARE%: EVAL@COMPILE

(ACCESSFNS FILEPKGCOM [[ADD (GETPROP DATUM 'ADDTOPRETTYCOM)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE))
                                               (T (/REMPROP DATUM 'ADDTOPRETTYCOM]
                           [DELETE (GETPROP DATUM 'DELFROMPRETTYCOM)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE))
                                               (T (/REMPROP DATUM 'DELFROMPRETTYCOM]
                           [PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE))
                                               (T (/REMPROP DATUM 'PRETTYTYPE]
                           [CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE))
                                               (T (/REMPROP DATUM 'FILEPKGCONTENTS]
                           (MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS]
                                  (STANDARD [COND
                                               [NEWVALUE (PUTASSOC DATUM NEWVALUE
                                                                (OR (LISTP (GETTOPVAL 
                                                                                  'PRETTYDEFMACROS))
                                                                    (SETTOPVAL 'PRETTYDEFMACROS
                                                                           (LIST (LIST DATUM]
                                               (T (SETTOPVAL 'PRETTYDEFMACROS
                                                         (REMOVE (FASSOC DATUM (GETTOPVAL
                                                                                'PRETTYDEFMACROS))
                                                                (GETTOPVAL 'PRETTYDEFMACROS]
                                         UNDOABLE
                                         (COND
                                            [NEWVALUE (/PUTASSOC DATUM NEWVALUE
                                                             (OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS))
                                                                 (/SETTOPVAL 'PRETTYDEFMACROS
                                                                        (LIST (LIST DATUM]
                                            (T (/SETTOPVAL 'PRETTYDEFMACROS
                                                      (REMOVE (FASSOC DATUM (GETTOPVAL 
                                                                                   'PRETTYDEFMACROS))
                                                             (GETTOPVAL 'PRETTYDEFMACROS]
                                                             (* Not an atom record cause want 
                                                           REMPROP on NILs.)
                                                             (* NOTE%: PRETTCOM on PRETTY has 
                                                           open-coded access to the MACRO 
                                                           property.)
                          (INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE 
                                       FILEPKGCONTENTS)))

(ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
                                   HASDEF EDITDEF FILEGETDEF CANFILEDEF)
                            (ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM))
                                                           (CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
                                                           )
                                                    (CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST
                                                                              DATUM)))
                                                           (STANDARD (SETTOPVAL (CAR (
                                                                                  SEARCHPRETTYTYPELST
                                                                                      DATUM NEWVALUE)
                                                                                     )
                                                                            NEWVALUE)
                                                                  UNDOABLE
                                                                  (/SETTOPVAL (CAR (
                                                                                  SEARCHPRETTYTYPELST
                                                                                    DATUM NEWVALUE))
                                                                         NEWVALUE)))
                                                    (DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST
                                                                             DATUM)))
                                                           (CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST
                                                                               DATUM NEWVALUE))
                                                                       NEWVALUE)))
                                                    (ALLFIELDS NIL (/SETTOPVAL
                                                                    'PRETTYTYPELST
                                                                    (REMOVE (SEARCHPRETTYTYPELST
                                                                             DATUM)
                                                                           (GETTOPVAL 'PRETTYTYPELST]
                                                             (* NOTE%: PRETTYCOM on PRETTY has 
                                                           open-coded access to GETDEF property)
                                   (INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
                                                (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                                                                   (PUT X
                                                                                        'PROPTYPE
                                                                                        'FILEPKGCOMS]
                                         (ADDTOVAR PRETTYTYPELST ))))

(ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP)
                     [ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE)
                                             (STANDARD (PUTPROP DATUM 'FILE NEWVALUE)
                                                    UNDOABLE
                                                    (/PUTPROP DATUM 'FILE NEWVALUE])

(RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME))

(RECORD FILEPROP ((COMSNAME . LOADTYPE) . TOBEDUMPED))
)

(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)

[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]

(ADDTOVAR PRETTYTYPELST )
)

(* "END EXPORTED DEFINITIONS")

(DEFINEQ

(SEARCHPRETTYTYPELST
  [LAMBDA (TYPE FLG)                                     (* rmk%: " 3-JAN-82 22:55")
                                                             (* ; 
                                                           "access functions used by the records")
    (AND (LITATOM TYPE)
         (OR (find X in PRETTYTYPELST suchthat (EQ (CADR X)
                                                               TYPE))
             (COND
                (FLG [/SETTOPVAL 'PRETTYTYPELST (CONS (SETQ FLG (LIST (PACK* 'CHANGED TYPE
                                                                             'LST)
                                                                      TYPE NIL))
                                                      (GETTOPVAL 'PRETTYTYPELST]
                     (OR (LISTP (GETTOPVAL (CAR FLG)))
                         (/SETTOPVAL (CAR FLG)
                                NIL))
                     FLG])

(PRETTYDEFMACROS
  [NLAMBDA ARGS                                          (* lmm " 5-SEP-78 16:16")
                                                             (* ; 
                                                 "included so that old files will continue to load")
    (for X in ARGS collect (FILEPKGCOM (CAR X)
                                              'MACRO
                                              (CDR X])

(FILEPKGCOMPROPS
  [NLAMBDA PROPS
    (MAPC PROPS (FUNCTION (LAMBDA (Y)
                            (OR (MEMB Y SYSPROPS)
                                (SETQ SYSPROPS (CONS Y SYSPROPS)))
                            (PUT Y 'PROPTYPE 'FILEPKGCOMS])
)

(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))

(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)

[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]

(ADDTOVAR PRETTYTYPELST )
(DECLARE%: EVAL@COMPILE DOCOPY 

(CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES PRETTYPRINTMACROS 
                     *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS PRETTYFLG))

(CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES NOTCOMPILEDFILES MAKEFILEFORMS 
                     CLEANUPOPTIONS))
)

(RPAQ? MSDATABASELST )



(* ;; "making, adding, listing, compiling files")

(DEFINEQ

(CLEANUP
  [NLAMBDA FILES                                         (* lmm "14-Aug-84 19:17")
    (PROG (TEM1 TEM2 OPTIONS)
          (COND
             ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
              (SETQ OPTIONS (CAR FILES))
              (SETQ FILES (CDR FILES)))
             (T (SETQ OPTIONS CLEANUPOPTIONS)))
          (RETURN (APPEND (MAKEFILES OPTIONS FILES)
                         (COND
                            ((NOT (MEMB 'LIST OPTIONS))
                             NIL)
                            ((NULL FILES)
                             (LISTFILES))
                            ((SETQ TEM1 (INTERSECTION FILES NOTLISTEDFILES))
                                                             (* ; 
            "Intersection check because LISTFILES applied to NIL means list all of NOTLISTEDFILES.")
                             (APPLY 'LISTFILES TEM1)))
                         (COND
                            [(NULL (SETQ TEM1 (MEMB 'RC OPTIONS]
                            ((NULL FILES)
                             (COMPILEFILES0 (SETQ TEM2 NOTCOMPILEDFILES)
                                    (CDR TEM1))
                             TEM2)
                            ((SETQ TEM2 (INTERSECTION FILES NOTCOMPILEDFILES))
                             (COMPILEFILES0 TEM2 (CDR TEM1))
                             TEM2])

(COMPILEFILES
  [NLAMBDA FILES                                         (* lmm "14-Aug-84 19:17")
    (COND
       ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
        (COMPILEFILES0 (CDR FILES)
               (CAR FILES)))
       (T (COMPILEFILES0 FILES])

(COMPILEFILES0
  [LAMBDA (FILES OPTIONS)                                (* rmk%: "19-FEB-83 21:59")
    (for X OPTS (RCFLG _ T) on (OR FILES NOTCOMPILEDFILES)
       first (SETQ OPTS (SELECTQ (CAR (LISTP OPTIONS))
                                (C (SETQ RCFLG NIL)
                                   (CDR OPTIONS))
                                (RC (CDR OPTIONS))
                                OPTIONS)) do (MAKEFILE1 (OR (MISSPELLED? (CAR X)
                                                                           70 FILELST NIL X)
                                                                    (CAR X))
                                                        RCFLG OPTS X])

(CONTINUEDIT
  [LAMBDA (FILE)                                         (* bvm%: "30-Aug-86 15:09")
    (PROG (STREAM FL TEM FC ENV)
          (RESETLST
              [RESETSAVE NIL (LIST 'CLOSEF (SETQ STREAM (OPENSTREAM FILE 'INPUT]
              (SETQ FILE (FULLNAME STREAM))
              (SETFILEPTR STREAM 0)
              (CL:MULTIPLE-VALUE-SETQ (ENV FC)
                     (\PARSE-FILE-HEADER STREAM 'RETURN)))
          (COND
             ([NOT (fetch FILEPROP of (SETQ FL (ROOTFILENAME FILE]
              (LOADFROM FILE)                                (* ; 
                                                           "also calls addfile to notice the file.")
              ))
          (/replace FILECHANGES of FL with (FILECHANGES FC))
          [/replace FILEDATES of FL with
                                            (LIST (create FILEDATEPAIR
                                                         FILEDATE _ (CADR FC)
                                                         DATEFILENAME _ FILE)
                                                  (create FILEDATEPAIR
                                                         FILEDATE _
                                                         [CAR (SETQ TEM (CDR (MEMB 'date%: FC]
                                                         DATEFILENAME _ (CADR TEM]
          (RETURN FILE])

(MAKEFILE
  [LAMBDA (FILE OPTIONS REPRINTFNS SOURCEFILE)           (* ; "Edited 29-Aug-89 11:46 by bvm")

    (* ;; "OPTIONS: FAST means dump with PRETTYFLG set to NIL;  LIST means list the FILE;  RC means RECOMPILE, C means COMPILEL;  --- for C AND RC assume ST unless next option is F.")

    (PROG ((PRETTYFLG (AND [NOT (MEMB 'FAST (SETQ OPTIONS (MKLIST OPTIONS]
                           PRETTYFLG))
           (*PRINT-BASE* (if (EQ *PRINT-BASE* 8)
                             then 8
                           else                          (* ; "make sure radix is either 8 or 10, because all others don't read in like they print.  Maybe obsolete now with makefile environments")
                                 10))
           FILETYPE ROOTNAME FILEPROP CHANGES FILEDATES (Z (ADDFILE FILE)))
          (DECLARE (CL:SPECIAL PRETTYFLG))
          (SETQ FILE (CAR Z))                                (* ; 
                                               "Necessary because FILE might have been misspelled.")
          (SETQ ROOTNAME (CADR Z))                           (* ; "result of (ROOTFILENAME FILE), or if FILE is corrected, result of applying ROOTFILENAME to correct value.")
          (SETQ FILEPROP (CDDR Z))
          (UPDATEFILES)                                  (* ; "Want updating done after file is added to filelst, so any functions that are being dumped are marked as having been dumped.")
          (SETQ CHANGES (fetch TOBEDUMPED of FILEPROP))
          (SETQ FILEDATES (LISTP (fetch FILEDATES of ROOTNAME)))
          (SETQ FILETYPE (GETPROP ROOTNAME 'FILETYPE))
      LP0 (if (AND (NULL (fetch LOADTYPE of FILEPROP))
                       (NULL FILEDATES))
              then                                       (* ; 
                   "File has never been loaded and never dumped i.e. user just set up COMS in core")
            elseif [OR (EQMEMB 'NEW OPTIONS)
                           (AND (NULL MAKEFILEREMAKEFLG)
                                (NOT (MEMB 'REMAKE OPTIONS]
              then (COND
                          ((AND (fetch LOADTYPE of FILEPROP)
                                (NEQ T (fetch LOADTYPE of FILEPROP)))
                           (LISPXPRIN2 FILE T T)
                           (LISPXPRIN1 (SELECTQ (fetch LOADTYPE of FILEPROP)
                                           (LOADCOMP 
                                                  "the file was loaded for compilation purposes only")
                                           ((compiled Compiled COMPILED) 
                                                " -- only the compiled file has been loaded
")
                                           ((loadfns LOADFNS) 
                                                " -- only some of its symbolics have been loaded
")
                                           (SHOULDNT))
                                  T)
                           (COND
                              ((NEQ (ASKUSER DWIMWAIT 'Y "Go ahead and MAKEFILE anyway? ")
                                    'Y)                      (* ; 
            "E.g. user loads a .com file and then resets the COMS or defines the functons by hand.")
                               (GO OUT)))
                           (/replace LOADTYPE of FILEPROP with NIL)))
                    (SETQ SOURCEFILE NIL)
                    (SETQ REPRINTFNS NIL)
            elseif SOURCEFILE
              then                                       (* ; "source file given")
            elseif [AND FILEDATES (OR [AND (SETQ SOURCEFILE (FINDFILE ROOTNAME T))
                                               (EQUAL (FILEDATE SOURCEFILE)
                                                      (fetch FILEDATE of (CAR FILEDATES]
                                          (AND [NOT (STRING-EQUAL SOURCEFILE (SETQ SOURCEFILE
                                                                              (fetch DATEFILENAME
                                                                                 of (CAR 
                                                                                            FILEDATES
                                                                                             ]
                                               (INFILEP SOURCEFILE)
                                               (EQUAL (FILEDATE SOURCEFILE)
                                                      (fetch FILEDATE of (CAR FILEDATES]
              then (/replace DATEFILENAME of (CAR FILEDATES) with SOURCEFILE)
                    (OR REPRINTFNS (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES)))
            elseif [AND (CDR FILEDATES)
                            [SETQ SOURCEFILE (INFILEP (fetch DATEFILENAME of (CADR FILEDATES]
                            (EQUAL (FILEDATE SOURCEFILE)
                                   (fetch FILEDATE of (CADR FILEDATES]
              then 

                    (* ;; "prevous version file is gone, drop back to original daddy file and dump everything that has been changed.")

                    (SETQ CHANGES (FILEPKG.MERGECHANGES (fetch TOBEDUMPED of FILEPROP)
                                         (fetch FILECHANGES of ROOTNAME)))
                    (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES))
            else (LISPXPRIN1 
                            '"can't find either the previous version or the original version of 
" T)
                  (LISPXPRIN2 FILE T T)
                  (LISPXPRIN1 '", so it will have to be written anew
" T)
                  (SETQ SOURCEFILE NIL)
                  (SETQ REPRINTFNS NIL)
                  (push OPTIONS 'NEW)
                  (SETQ CHANGES (fetch FILECHANGES of ROOTNAME))
                  (GO LP0))
          (COND
             ((AND SOURCEFILE (SETQ Z (SELECTQ (fetch LOADTYPE of FILEPROP)
                                          (LOADCOMP          (* ; 
                                                   "only loaded via LOADCOMP.  Need to do LOADFROM")
                                                    (LIST 'N SOURCEFILE "was loaded with LOADCOMP"
                                                          '- "LOADFROM it to obtain VARS/COMS"))
                                          (Compiled (AND (INFILECOMS? 'DONTCOPY 'DECLARE%:
                                                                (fetch COMSNAME of FILEPROP))
                                                         (LIST 'Y "only compiled version of" ROOTNAME
                                                               
                                        "was loaded; LOADVARS the (DECLARE .. DONTCOPY ) expressions"
                                                               )))
                                          ((compiled loadfns) 
                                               (LIST 'N "Only some functions from" SOURCEFILE 
                                             "loaded via LOADFNS. Load all other expressions from it"
                                                     ))
                                          NIL)))
              (SELECTQ [ASKUSER DWIMWAIT (CAR Z)
                              (CDR Z)
                              '((Y "es
")
                                (N "o
")
                                (A "bort MAKEFILE
"]
                  (Y (SELECTQ (fetch LOADTYPE of FILEPROP)
                         (LOADCOMP                           (* ; 
                               "file was never actually loaded, just loadcomped.  thus no filecoms")
                                   (LOADFROM SOURCEFILE))
                         (Compiled 

                                 (* ;; "This is going to be a remake.  If it was originally loaded as a compiled file, must first do a LOADFROM in order to get the properties set up by declare: etc.")

                                   (LOADVARS 'DONTCOPY SOURCEFILE)
                                   (/replace LOADTYPE of FILEPROP with 'COMPILED)
                                                             (* ; "So wont have to be done again.")

                                 (* ;; "These are the only DECLARE:'s that are not also on the compiled file.  Note that a DECLARE: DONTEVAL@LOAD will be found and evaluated, but the corresponding expressions won't be evaluated from within the DECLARE:  Not worthwhile to bother setting up a complicated edit pattern to screen these out, especially if you consider expressions like (DECLARE: -- DONTEVAL@LOAD -- DOEVAL@LOAD --)")

                                   )
                         ((loadfns compiled) 

                                 (* ;; "This is going to be a remake, but the original call to LOADFNS didnt specify all the VARS, so some expressions may not have been loaded.")

                              (LOADVARS T SOURCEFILE))
                         NIL))
                  (A (GO OUT))
                  NIL)))
          (RESETLST
              [COND
                 ((MEMB 'NOCLISP OPTIONS)
                  (RESETSAVE PRETTYTRANFLG T))
                 ((MEMB 'CLISP%  OPTIONS)
                  (RESETSAVE PRETTYTRANFLG 'BOTH]
              (RESETSAVE %#UNDOSAVES)
              [COND
                 ((OR (MEMB 'CLISPIFY OPTIONS)
                      (MEMB 'CLISP OPTIONS))
                  (RESETSAVE CLISPIFYPRETTYFLG T))
                 ((OR (EQ FILETYPE 'CLISP)
                      (MEMB 'CLISP (LISTP FILETYPE)))
                  (RESETSAVE CLISPIFYPRETTYFLG 'CHANGES]
              (for X in MAKEFILEFORMS do (ERSETQ (EVAL X)))
              (SETQ FILE (PRETTYDEF NIL FILE (fetch COMSNAME of FILEPROP)
                                REPRINTFNS SOURCEFILE CHANGES)))
          (SETQ LASTFILE ROOTNAME)
          (/replace TOBEDUMPED of FILEPROP with NIL)
          (COND
             ((NOT (EQMEMB 'DON'TLIST FILETYPE))
              (pushnew NOTLISTEDFILES ROOTNAME)))
          (COND
             ((NOT (EQMEMB 'DON'TCOMPILE FILETYPE))
              (pushnew NOTCOMPILEDFILES ROOTNAME)))
          [for TAIL OPT on OPTIONS do (SETQ OPT (CAR TAIL))
                                                 (SELECTQ OPT
                                                     (RC (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
                                                              (MAKEFILE1 FILE T (CDR TAIL))))
                                                     (C (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
                                                             (MAKEFILE1 FILE NIL (CDR TAIL))))
                                                     (LIST (AND (MEMB ROOTNAME NOTLISTEDFILES)
                                                                (APPLY 'LISTFILES (LIST FILE))))
                                                     (COND
                                                        ((MEMB OPT MAKEFILEOPTIONS))
                                                        ((FIXSPELL OPT NIL MAKEFILEOPTIONS NIL 
                                                                OPTIONS)
                                                         (GO $$LP))
                                                        (T (ERROR "Unrecognized MAKEFILE option" OPT]
          (RETURN FILE)
      OUT (RETURN (LIST FILE "-- MAKEFILE not performed."])

(FILECHANGES
  [LAMBDA (FILE TYPE)                                    (* bvm%: "30-Aug-86 15:08")

    (* ;; "If FILE is a list, it is assumed to be a file-created expressions;  otherwise, the filecreated expression is read from FILE.  If TYPE, returns the list of changed items of that type from the changes expression.  If TYPE=NIL, returns the whole list of typed change-lists")

    (PROG ([FCEXPR (OR (LISTP FILE)
                       (AND FILE (RESETLST
                                     (LET (OLDPTR STREAM)
                                          [if (SETQ STREAM (OPENP FILE 'INPUT))
                                              then (SETQ OLDPTR (GETFILEPTR STREAM))
                                                    (SETFILEPTR STREAM 0)
                                            else (RESETSAVE NIL (LIST 'CLOSEF
                                                                          (SETQ STREAM
                                                                           (OPENSTREAM FILE
                                                                                  'INPUT]
                                          (CL:MULTIPLE-VALUE-BIND (ENV FC)
                                                 (\PARSE-FILE-HEADER STREAM 'RETURN)
                                                 (if OLDPTR
                                                     then (SETFILEPTR STREAM OLDPTR))
                                                 FC)))]
           FNS CHANGES)
          (SETQ CHANGES (LDIFF (SETQ CHANGES (CDR (MEMB 'to%: FCEXPR)))
                               (MEMB 'previous CHANGES)))
          [if (AND TYPE (NEQ TYPE 'FNS))
              then (RETURN (CDR (ASSOC TYPE CHANGES]
          (SETQ FNS (SUBSET CHANGES (FUNCTION LITATOM)))     (* ; 
                         "Old style changes expression listed FNS by name and other things by type")
          (RETURN (if TYPE
                      then                               (* ; "TYPE=FNS cause of test above.")
                            (NCONC FNS (CDR (ASSOC 'FNS CHANGES)))
                    elseif FNS
                      then (CONS (CONS 'FNS FNS)
                                     (SUBSET CHANGES (FUNCTION LISTP)))
                    else CHANGES])

(FILEPKG.MERGECHANGES
  [LAMBDA (C1 C2)                                        (* rmk%: "24-MAY-82 23:09")

    (* ;; "Merges 2 changes lists into a single one.  Treat LITATOM's as FNS, to accomodate old-style format on files.")

    (for E2 TEMP (VAL _ (for E1 in C1 when (CDR (LISTP E1)) collect (APPEND
                                                                                         E1)))
       in C2 do [COND
                           ((SETQ TEMP (ASSOC (CAR E2)
                                              VAL))
                            (NCONC TEMP (for X in (CDR E2) unless (MEMBER X (CDR TEMP))
                                           collect X)))
                           (T (SETQ VAL (NCONC1 VAL (APPEND E2] finally (RETURN VAL])

(FILEPKG.CHANGEDFNS
  [LAMBDA (CHANGES)                                      (* rmk%: "20-MAY-82 22:00")

    (* ;; "Returns list of function names from a file-changes list.  Interprets old format (functions are atoms) and new format (with explicit type headers)")

    (CDR (ASSOC 'FNS CHANGES])

(MAKEFILE1
  [LAMBDA (FILE RECOMPFLG OPTIONS OTHERFILES)           (* ; "Edited 27-Oct-2020 15:40 by rmk:")
                                                             (* ; "Edited 29-Aug-89 11:46 by bvm")

    (* ;; "RMK:  Call COMPILE-FILE? with FILE instead of (ROOTFILENAME FILE)")

    (PROG ((ROOTNAME (ROOTFILENAME FILE))
           (COMPILER (COMPILE-FILE? FILE))
           GROUP)
          (COND
             ((AND (OR (EQ COMPILER 'BCOMPL)
                       (EQ COMPILER 'TCOMPL))
                   (NOT (FILEFNSLST ROOTNAME)))          (* ; 
                 "No FNS on this file, and we're told to use Interlisp compiler, so nothing to do.")
              (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE ROOTNAME NOTCOMPILEDFILES))
              (RETURN NIL)))
          (COND
             ([find X in (SETQ GROUP (GETPROP ROOTNAME 'FILEGROUP))
                 suchthat (AND (NEQ X ROOTNAME)
                                   (OR (fetch TOBEDUMPED of (fetch FILEPROP of X))
                                       (MEMB X OTHERFILES]

              (* ;; "The file in question must be recompiled with other files, and one of the remaining files still needs to be dumped, or else one of the other file is further down the list of files being compiled.  Wait.")

              (RETURN)))
          (LISPXPRIN1 '"
compiling " T)
          (LISPXPRINT (OR GROUP FILE)
                 T T)
          (LISPXPRINT (LET [[REDEFINE? (OR (EQ (CAR OPTIONS)
                                               'ST)
                                           (EQ (CAR OPTIONS)
                                               'STF]
                            (FORGET-EXPRS? (EQ (CAR OPTIONS)
                                               'STF]
                           (SELECTQ COMPILER
                               ((FAKE-COMPILE-FILE)          (* ; 
                                               "The old CommonLispy interface to the ByteCompiler.")
                                    (FAKE-COMPILE-FILE FILE :REDEFINE REDEFINE? :SAVE-EXPRS
                                           (AND REDEFINE? (NOT FORGET-EXPRS?))))
                               ((CL:COMPILE-FILE)            (* ; "The new, improved (?) compiler")
                                    (CL:COMPILE-FILE FILE :LOAD (COND
                                                                   ((AND REDEFINE? (NOT FORGET-EXPRS?
                                                                                        ))
                                                                    :SAVE)
                                                                   (REDEFINE? T)
                                                                   (T NIL))))
                               ((TCOMPL BCOMPL)              (* ; "The old ByteCompiler")
                                    [IF (MEMB (CAR OPTIONS)
                                                  '(ST F S STF))
                                        THEN (LISPXUNREAD (LIST (CAR OPTIONS]
                                    [IF GROUP
                                        THEN 

                                              (* ;; 
                                   "File contained in FILEGROUP.  Therefore must be blockcompiled.")

                                              (IF RECOMPFLG
                                                  THEN (BRECOMPILE GROUP)
                                                ELSE (BCOMPL GROUP))
                                      ELSEIF (EQ COMPILER 'TCOMPL)
                                        THEN (IF RECOMPFLG
                                                     THEN (RECOMPILE FILE)
                                                   ELSE (TCOMPL (LIST FILE)))
                                      ELSE (IF RECOMPFLG
                                                   THEN (BRECOMPILE FILE)
                                                 ELSE (BCOMPL (LIST FILE])
                               (SHOULDNT "Non-existent compiler returned from COMPILE-FILE?...")))
                 T T])

(COMPILE-FILE?
  [LAMBDA (FILE)                                        (* ; "Edited 27-Oct-2020 15:39 by rmk:")
                                                             (* ; "Edited 19-Jan-87 21:12 by Pavel")

    (* ;; "RMK: Argument is FILE instead of ROOTFILENAME, maybe more information")

(* ;;; "Which compiler should CLEANUP use?")

    (LET ((TYPE (GET (ROOTFILENAME FILE)
                     'FILETYPE))
          (UNKNOWN NIL))
         (FOR X INSIDE TYPE DO (SELECTQ X
                                               ((TCOMPL :TCOMPL) 
                                                    (RETURN 'TCOMPL))
                                               ((BCOMPL :BCOMPL) 
                                                    (RETURN 'BCOMPL))
                                               ((:FAKE-COMPILE-FILE CL:COMPILE-FILE COMPILE-FILE) 
                                                    (RETURN 'FAKE-COMPILE-FILE))
                                               ((:COMPILE-FILE :XCL-COMPILE-FILE) 
                                                    (RETURN 'CL:COMPILE-FILE))
                                               ((CLISP) 
                                                    NIL)
                                               (SETQ UNKNOWN T))
            FINALLY (IF UNKNOWN
                            THEN (CL:FORMAT T "~2%%**Warning: unknown FILETYPE value ~S~2%%" TYPE
                                            ))
                  (RETURN *DEFAULT-CLEANUP-COMPILER*])

(MAKEFILES
  [LAMBDA (OPTIONS FILES)                                (* rmk%: "23-FEB-83 21:20")
    (RESETVARS (%#UNDOSAVES)                                 (* ; 
                                                   "Willing to save arbitrary amounts of undo info")
               (UPDATEFILES)
               [COND
                  ((NULL FILES)
                   (for TYPE FLG in FILEPKGTYPES when [FILES?1 TYPE
                                                                         (COND
                                                                            ((NULL FLG)
                                                             (* ; "Gets printed the first time")
                                                                             
                                                                             '
                                        "****NOTE: the following are not contained on any file:
    ")
                                                                            (T '"    "]
                      do (SETQ FLG T) finally (AND FLG (ADDTOFILES?]
               (SETQ OPTIONS (MKLIST OPTIONS))
               (RETURN (for FILE inside (OR FILES FILELST)
                          when [fetch TOBEDUMPED of (LISTP (fetch FILEPROP
                                                                          of (ROOTFILENAME FILE]
                          collect (LISPXPRIN2 FILE T T)
                                (LISPXPRIN1 '|...| T)
                                (PROG1 (MAKEFILE FILE OPTIONS)
                                       (LISPXTERPRI T])

(ADDFILE
  [LAMBDA (FILE LOADTYPE PRLST FCLST)                    (* bvm%: "29-Aug-86 12:22")

    (* ;; "PRLST is the FILEPKGCHANGES prior to this file operation, FCLST is a list of file-created arguments, a singleton for a symbolic file, and a list whose car represents the compiled file and whose cdr represent symbolic files compiled into it, for compiled files.")

    (PROG ((ROOTNAME (ROOTFILENAME FILE))
           FLST VAL)
          [COND
             ((NOT FCLST)
              (SETQ VAL (ADDFILE0 ROOTNAME LOADTYPE FILE)))
             [(NULL (CDR FCLST))                             (* ; "A simple symbolic file")
              (SETQ FCLST (CAR FCLST))
              (SETQ VAL (ADDFILE0 (COND
                                         ((LITATOM (CADR FCLST))
                                          (ROOTFILENAME (CADR FCLST)))
                                         (T ROOTNAME))
                               LOADTYPE FILE (CAR FCLST]
             (T 
                (* ;; "A compiled file, skip the first expression representing the compiled file itself, look at the cdr representing the symbolic files.")

                (SELECTQ LOADTYPE
                    ((T LOADFNS) 
                         (SETQ LOADTYPE 'Compiled))
                    (loadfns (SETQ LOADTYPE 'compiled))
                    (LOADCOMP                                (* ; 
                   "loadcomp on compiled file.  Don't notice since we don't know what its state is")
                              NIL)
                    (SHOULDNT))
                (for X in (CDR FCLST) when (LITATOM (CADR X))
                   do (push FLST (CADR X))
                         (OR (EQ LOADTYPE 'LOADCOMP)
                             (ADDFILE0 (ROOTFILENAME (CADR X))
                                    LOADTYPE
                                    (CADR X)
                                    (CAR X]
          (UPDATEFILES PRLST (OR FLST (LIST FILE)))
          [AND LOADTYPE (for TYPE CHANGED in FILEPKGTYPES
                           when (AND (LITATOM TYPE)
                                         (SETQ CHANGED (fetch CHANGED of TYPE)))
                           do (/replace CHANGED of TYPE
                                     with (INTERSECTION (CDR (ASSOC TYPE PRLST))
                                                     CHANGED]
          (AND ADDSPELLFLG (ADDSPELL ROOTNAME USERWORDS))
          (RETURN VAL])

(ADDFILE0
  [LAMBDA (ROOTNAME LOADTYPE FULLNAME DAT)               (* lmm "28-Nov-84 16:47")
    (PROG (COMS X FILEPROP FLG TEM)
      TOP (SETQ COMS (FILECOMS ROOTNAME))
          [COND
             ((SETQ FILEPROP (fetch FILEPROP of ROOTNAME))
              (COND
                 ([AND LOADTYPE (FMEMB LOADTYPE
                                       (CDR (FMEMB (fetch LOADTYPE of FILEPROP)
                                                   '(LOADCOMP loadfns compiled Compiled LOADFNS 
                                                           COMPILED NIL T]
                  (/replace LOADTYPE of FILEPROP with LOADTYPE)

                  (* ;; "This call to ADDFILE reflects a 'higher' degree of loading, so upgrade property.  'loadfns' means just some information from file, if go to do makefile, must do loadfrom, 'compiled' is like 'loadfns' but for compiled files e.g. user does LOADFNS on compiled file.  'Compiled' means all but DECLARE: expressions are in.  e.g. user does LOAD of a compiled file.  COMPILED means everything is in, e.g. user does LOADDFROM a compiled file.  LOADFNS means everything in, e.g. user des LOADFROM symbolic file.  COMPILED and LOADFNS are equivalent in that means dont have to do any more loading when go to do a makefile but makefile NEW isnt permitted.  NIL is a makefile when coms were set up in core.  T is full load of symbolic file.  The check on TYPE=NIL is bcause dont want to upgrade as result of call from makefile, i.e. no new information there.")

                  (* ;; "LOADCOMP means file was loadcomp'ed.  note that the actual structure is a tree, not a list, and the above is only an approximation.  if you do a loadcomp, and then load the compiled file, the state will be left with latter, but then loadcomp? will loadcomp again because compiled files might not contain all the declare: EVAL@COMPILE expressions, e.g. macros, records etc.  however, in most cases, loadcomp is used independently of other loading, e.g. for compilation purposes only, so this will at least permit loadcomp? to work.")

                  (GO OUT))
                 (T (GO OUT1]
          (COND
             [(OR LOADTYPE (LISTP (GETTOPVAL COMS)))
              (SETQ FILEPROP (/replace FILEPROP of ROOTNAME
                                with (create FILEPROP
                                                COMSNAME _ COMS
                                                LOADTYPE _ LOADTYPE]
             (FLG (GO ERROR))
             ((AND DWIMFLG (EQ ROOTNAME FULLNAME)
                   (SETQ ROOTNAME (MISSPELLED? ROOTNAME 70 FILELST T)))

              (* ;; "The EQ check is so as not to try correcting if the user has specified a version number or directory, as it is too messy trying to take them out, and then put them back in on the corrected root name.")

              (SETQ FULLNAME ROOTNAME)
              (SETQ FLG T)                                   (* ; 
                                         "so wont try to spelling correct again if file isnt there")
              (GO TOP))
             (T (GO ERROR)))
      OUT [AND LOADTYPE DAT (/replace FILEDATES of ROOTNAME
                               with (LIST (create FILEDATEPAIR
                                                     FILEDATE _ DAT
                                                     DATEFILENAME _ FULLNAME]
          (AND (EQ LOADTYPE T)
               (/replace TOBEDUMPED of FILEPROP with NIL))
      OUT1
          [COND
             ([AND (LISTP (GETTOPVAL COMS))
                   (NOT (FMEMB ROOTNAME (GETTOPVAL 'FILELST] (* ; 
                                                          "coms wuld not be set up on a loadccomp.")
              (/SETTOPVAL 'FILELST (CONS ROOTNAME (GETTOPVAL 'FILELST]
          (RETURN (COND
                     ((NULL LOADTYPE)                        (* ; "call from makefile.")
                      (CONS FULLNAME (CONS ROOTNAME FILEPROP)))
                     (T FILEPROP)))
      ERROR
          (ERROR FULLNAME "not file name." T])

(LISTFILES
  [NLAMBDA FILES                                         (* rmk%: " 3-Dec-84 08:58")
    (DECLARE (GLOBALVARS NOTLISTEDFILES))                (* ; "LISTFILES1 is machinedependent")
    (for FILE FULLNAME OPTIONS in (COND
                                             (FILES (SETQ FILES (NLAMBDA.ARGS FILES)))
                                             (T NOTLISTEDFILES))
       when (COND
                   ((LISTP FILE)
                    (SETQ OPTIONS (APPEND FILE OPTIONS))
                    NIL)
                   ((SETQ FULLNAME (FINDFILE FILE))
                    FULLNAME)
                   (T (printout T FILE " not found." T)
                      NIL)) collect [COND
                                           ((LISTFILES1 FULLNAME OPTIONS)
                                            (SETQ NOTLISTEDFILES (REMOVE (NAMEFIELD FULLNAME T)
                                                                        NOTLISTEDFILES]
                                  FULLNAME])
)

(RPAQ? *DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)

(RPAQ? FILELST )

(RPAQ? LOADEDFILELST )

(RPAQ? NOTLISTEDFILES )

(RPAQ? NOTCOMPILEDFILES )

(RPAQ? MAKEFILEFORMS )

(RPAQ? NILCOMS )

(ADDTOVAR MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP%  F ST STF
                                 (REC . RC)
                                 (BREC . RC)
                                 (TC . C)
                                 (BC . C)
                                 (TCOMPL . C)
                                 (BCOMPL . C))

(RPAQ? MAKEFILEREMAKEFLG T)

(RPAQ? CLEANUPOPTIONS '(RC))



(* ;; "scanning file coms")

(DEFINEQ

(FILEPKGCHANGES
  [LAMBDA N                                              (* Pavel " 7-Oct-86 19:22")
    (COND
       [(EQ N 0)
        (PROG (TEM)
              (RETURN (for X in FILEPKGTYPES when (AND (LITATOM X)
                                                                   (SETQ TEM (FILEPKGCHANGES
                                                                              X)))
                         collect (CONS X TEM]
       [(EQ (ARG N 1)
            T)
        (for X in FILEPKGTYPES when (LITATOM X) collect (CONS X (FILEPKGCHANGES
                                                                                 X]
       [(EQ N 1)
        (COND
           [(LISTP (ARG N 1))
            (for X in (ARG N 1) when (FMEMB (CAR X)
                                                        FILEPKGTYPES)
               do (/replace CHANGED of (CAR X) with (CDR X]
           (T (for Y on (fetch CHANGED of (ARG N 1))
                 when [AND (CAR Y)
                               (NOT (for Z in (CDR Y) thereis (CL:EQUAL (CAR Y)
                                                                                 Z]
                 collect (CAR Y]
       (T (/replace CHANGED of (ARG N 1) with (ARG N 2])

(GETFILEPKGTYPE
  [LAMBDA (TYPE ONLY NOERROR NAME)                       (* lmm "20-Nov-86 23:10")

    (* ;; "Coerce TYPE to a well defined definition type (FILEPKG type) or a command. ONLY is an indicator of which is acceptable; if NIL, either one is acceptable, if COMS, only commands are acceptable, and if TYPES, only types should be returned. If none is found, will signal an error if NOERROR is NIL, otherwise return NIL. ")

    (COND
       [(LISTP TYPE)

        (* ;; " given a list of types, coerce them all or return NIL")

        (for X in TYPE collect (OR (GETFILEPKGTYPE X ONLY NOERROR NAME)
                                               (RETURN]
       ((EQ TYPE '?)

        (* ;; "odd case, may be obsolete: if given IL:?, return all known types of NAME. Maybe used by EDITDEF(NAME ?)?? ")

        (AND NAME (TYPESOF NAME)))
       [(AND (NEQ ONLY 'COMS)
             (OR (SELECTQ TYPE
                     (NIL 'FNS)
                     (T 'VARS)
                     NIL)
                 (for X in FILEPKGTYPES do (if (EQ TYPE X)
                                                           then 

                                                                 (* ;; "type matched exactly")

                                                                 (RETURN TYPE)
                                                         elseif (AND (LISTP X)
                                                                         (EQ TYPE (CAR X)))
                                                           then (RETURN (CDR X]
       [(AND (NEQ ONLY 'TYPE)
             (LITATOM TYPE)
             (PROG1 (CAR (FMEMB TYPE FILEPKGCOMSPLST))       (* ; "Prefer an exact match quickly")
                    ]
       [(AND (NEQ ONLY 'COMS)
             (LITATOM TYPE)
             (for X in FILEPKGTYPES bind NAME
                do (SETQ NAME (if (NLISTP X)
                                      then X
                                    else (CAR X))) 

                      (* ;; "see if spelled the same or 1 char shorter; assume all FILEPKGTYPE names end with S. This handles package conversions and also pluralization")

                      (AND (<= 0 (- (NCHARS NAME)
                                    (NCHARS TYPE))
                               1)
                           (STRPOS TYPE NAME)
                           (RETURN (if (EQ X NAME)
                                       then X
                                     else (CDR X]
       [(FIXSPELL TYPE NIL (SELECTQ ONLY
                               (TYPE FILEPKGTYPES)
                               (COMS FILEPKGCOMSPLST)
                               (UNION FILEPKGTYPES FILEPKGCOMSPLST]
       ((NOT NOERROR)
        (ERROR (SELECTQ ONLY
                   (TYPE "unrecognized manager definition type")
                   (COMS "unrecognized manager command")
                   "unrecognized manager definition-type/command")
               TYPE])

(MARKASCHANGED
  [LAMBDA (NAME TYPE REASON)                             (* ; "Edited 25-May-88 15:37 by drc:")
    (COND
       (FILEPKGFLG (SETQ REASON (SELECTQ REASON
                                    ((CLISP LOAD CHANGED DEFINED DELETED) 
                                         REASON)
                                    (NIL 'CHANGED)
                                    (T 'DEFINED)
                                    (ERROR "bad REASON in MARKASCHANGED" REASON)))
              (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
              (for FN inside (fetch WHENCHANGED of TYPE)
                 do (APPLY* FN NAME TYPE REASON))
              (for FN in MARKASCHANGEDFNS do (APPLY* FN NAME TYPE REASON))
              [COND
                 ((EQ REASON 'DELETED)
                  (for L on (fetch CHANGED of TYPE) when (EQUAL (CAR L)
                                                                                    NAME)
                     do (/RPLACA L NIL))                 (* ; 
                                                          "unmark as changed and remove from files")
                  (DELFROMFILES NAME TYPE))
                 (T (LET ((LST (push (fetch CHANGED of TYPE)
                                      NAME)))
                         (AND LISPXHIST (UNDOSAVE (LIST '/RPLACA LST)
                                               LISPXHIST))   (* ; 
                             "UNDO by smashing with NIL;  makes calls to MARKASCHANGED independent")
                         ]
              NAME])

(FILECOMS
  [LAMBDA (FILE X)                                       (* rmk%: "19-FEB-83 13:55")
    (COND
       ((AND (NULL FILE)
             (NULL X))
        'NILCOMS)
       [(AND (OR (NULL X)
                 (EQ X 'COMS))
             (fetch COMSNAME of (LISTP (fetch FILEPROP of FILE]
       (T (PACK* (NAMEFIELD FILE)
                 (OR X 'COMS])

(WHEREIS
  [LAMBDA (NAME TYPE FILES FN)                        (* ; "Edited 12-Jul-88 17:14 by MASINTER")

    (* ;; "T as a NAME has a special meaning to INFILECOMS?  so don't pass through.")

    (CL:UNLESS (EQ NAME T)
        (LET [(IN-FILES (UNION [SUBSET (OR (LISTP FILES)
                                           FILELST)
                                      (FUNCTION (LAMBDA (FILE)
                                                  (INFILECOMS? NAME TYPE (FILECOMS FILE]
                               (AND (EQ FILES T)
                                    (CL:FBOUNDP 'XCL::HASH-FILE-WHERE-IS)
                                    (LET ((FILES NIL))
                                         (for TY inside TYPE
                                            do (for FILE-NAME
                                                      in (XCL::HASH-FILE-WHERE-IS NAME
                                                                    (GETFILEPKGTYPE TYPE))
                                                      do (CL:PUSHNEW (MKATOM (U-CASE FILE-NAME))
                                                                    FILES)))
                                         (REVERSE FILES]
             (CL:IF FN
                 [MAPC IN-FILES (FUNCTION (LAMBDA (FILE)
                                            (APPLY* FN NAME FILE]
                 IN-FILES)))])

(SMASHFILECOMS
  [LAMBDA (FILE)                                         (* rmk%: "19-FEB-83 22:15")
    (for X in (FILECOMSLST FILE 'FILEVARS) when (LITATOM X)
       do (SETTOPVAL X 'NOBIND))
    FILE])

(FILEFNSLST
  [LAMBDA (FILE)                                         (* ; "Edited 14-Jun-90 19:30 by jds")
    (FILECOMSLST FILE '(FUNCTIONS FNS])

(FILECOMSLST
  [LAMBDA (FILE TYPE FLG)                                (* JonL "24-Jul-84 19:48")
                                                             (* ; 
                                                    "TYPE is coerced in the innards of INFILECOMS?")
    (COND
       ((EQ FLG 'UPDATE)
        (CDR (INFILECOMS? NIL TYPE (FILECOMS FILE)
                    FLG)))
       (T (INFILECOMS? NIL TYPE (FILECOMS FILE)
                 FLG])

(UPDATEFILES
  [LAMBDA (PRLST FLST)                                   (* rmk%: "19-FEB-83 14:27")

    (* ;; "PRLST may be the value of FILEPKGCHANGES before some operation (e.g.  LOAD, LOADFNS) involving the files in FLST began.")

    (for TYPE CHANGED in FILEPKGTYPES when (SETQ CHANGED (fetch CHANGED of TYPE))
       do (COND
                 ((NULL (SETQ CHANGED (FILEPKGCHANGES TYPE)))
                                                             (* ; 
                                                           "FILEPKGCHANGES eliminates duplicates")
                  (/replace CHANGED of TYPE with NIL))
                 (T (for FILE FOUND FILEPROP COMS LST TYPEDPROP PCHANGES
                           (PREVITEMS _ (CDR (ASSOC TYPE PRLST))) in FILELST
                       first (SETQ LST (INFILECOMS? CHANGED TYPE 'NILCOMS 'UPDATE)) 

                             (* ;; "First check NIL=Nowhere.  LST:1 contains variables whose values are on the file literally.  These are `found' but not marked.  LST::1 contains all other items.")

                             (SETQ FOUND (NCONC (CAR LST)
                                                (CDR LST)
                                                FOUND))
                       do (SETQ PCHANGES (COND
                                                ((FMEMB (fetch DATEFILENAME
                                                           of (CAR (fetch FILEDATES
                                                                          of FILE)))
                                                        FLST)

                                 (* ;; "PREVITEMS are changed items that were previously on the changed list, before PRLST was computed as this LOAD/LOADFNS began.  Thus, by this intersection we only worry about items that were previously changed;  any items that were only changed during this operation are ignored.")

                                                 (INTERSECTION CHANGED PREVITEMS))
                                                (T CHANGED)))
                             [COND
                                ([AND PCHANGES [SETQ COMS (fetch COMSNAME
                                                             of (SETQ FILEPROP
                                                                     (LISTP (fetch FILEPROP
                                                                               of FILE]
                                      (SETQ LST (INFILECOMS? PCHANGES TYPE COMS 'UPDATE]

                                 (* ;; "LST:1 is a list of the times that literally appear on this file, LST::1 is a list of those whose literal values are not in the coms")

                                 [COND
                                    ((CDR LST)               (* ; "CDR items must be distributed")
                                     [COND
                                        ((NULL (fetch TOBEDUMPED of FILEPROP))

                                         (* ;; "Only finagle global lists the first time an item is added to PROP, when PROP::1 goes from NIL to non-NIL")

                                         [/SETTOPVAL 'NOTLISTEDFILES (REMOVE FILE (GETTOPVAL
                                                                                   'NOTLISTEDFILES]
                                         (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE FILE
                                                                              (GETTOPVAL 
                                                                                     '
                                                                                     NOTCOMPILEDFILES
                                                                                     ]
                                                             (* ; 
                                                   "Get the (possibly new) TYPE item list to smash")
                                     [COND
                                        [(SETQ TYPEDPROP (ASSOC TYPE (fetch TOBEDUMPED
                                                                        of FILEPROP]
                                        (T (/NCONC1 FILEPROP (SETQ TYPEDPROP (CONS TYPE]
                                                             (* ; 
                                                        "Now distribute items to the file property")
                                     (for Y in (CDR LST) unless (MEMBER Y (CDR TYPEDPROP)
                                                                                   )
                                        do (/NCONC1 TYPEDPROP Y]
                                 (SETQ FOUND (NCONC (CAR LST)
                                                    (CDR LST)
                                                    FOUND] finally (/replace CHANGED
                                                                          of TYPE
                                                                          with (LDIFFERENCE
                                                                                    CHANGED FOUND])

(INFILECOMS?
  [LAMBDA (NAME TYPE COMS ONFILETYPE)                 (* ; "Edited 12-Jul-88 17:42 by MASINTER")

    (* ;; "Returns T if NAME is 'CONTAINED' in COMS.  If NAME is NIL, then value is a list of all of the functions contained in COMS.  If NAME=T, value is T if there are any elements of type TYPE, otherwise NIL (this feature is used for deciding whether or not (and how) to compile files.)  Called by FILEFNSLST (which is used by BRECOMPILE) and by NEWFILE1.  while elements are the subset of NAME which are on the file in other case")

    (* ;; "if ONFILETYPE is UPDATE, then NAME is a list of elements, and INFILECOMS?  returns the dotted pair of (literals  . elements) where literals are those which are `literally' on the file (e.g.  (VARS (X 3))) --- if ONEFILETYPE is EDIT, then NAME is interpreted as for ONFILETYPE=NIL, but only those elements which are not on the file literally and which are not subparts of other types are returned")

    (* ;; "if ONFILETYPE is TYPESOF, type can be a list of types, and returns a list of types suitable for EDITDEF ")

    (PROG (VAL LITERALS ORIGFLG)
          (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (SELECTQ ONFILETYPE
              (EDIT (SELECTQ TYPE
                        (FILEVARS (RETURN))
                        NIL))
              NIL)
          [COND
             ((LITATOM COMS)
              (SELECTQ TYPE
                  ((VARS FILEVARS)                           (* ; 
                                                           "the COMS of a file are also on it")
                       (INFILECOMSVAL COMS))
                  NIL)
              (SETQ COMS (EVALV COMS]
          (INFILECOMS COMS)
          (SETQ VAL (DREVERSE VAL))
          (RETURN (COND
                     ((EQ ONFILETYPE 'UPDATE)
                      (CONS LITERALS VAL))
                     (T VAL])

(INFILECOMTAIL
  [LAMBDA (COM FLG)                                   (* ; "Edited  2-Aug-88 02:15 by masinter")
    [SETQ COM (COND
                 ((EQ (CADR COM)
                      '*)
                  (COND
                     [(LITATOM (CADDR COM))
                      (LISTP (EVALV (CADDR COM]
                     (T [RESETVARS (DWIMLOADFNSFLG)
                                   (NLSETQ (SETQ COM (EVAL (CADDR COM]
                        COM)))
                 (T (CDR COM]
    (if (NOT FLG)
        then (for X in COM
                    do [if (AND (LISTP X)
                                        (EQ (CAR X)
                                            COMMENTFLG))
                               then (RETURN (SUBSET COM (FUNCTION (LAMBDA (X)
                                                                        (OR (NLISTP X)
                                                                            (NEQ (CAR X)
                                                                                 COMMENTFLG]
                    finally (RETURN COM))
      else COM])

(INFILECOMS
  [LAMBDA (COMS)                                         (* rmk%: "19-FEB-83 22:17")
    (for X in COMS do (INFILECOM X])

(INFILECOM
  [LAMBDA (COM)                                       (* ; "Edited  2-Aug-88 02:27 by masinter")
    (COND
       [(NLISTP COM)
        (COND
           ((EQ TYPE 'VARS)
            (INFILECOMSVAL COM]
       ((EQ (CAR COM)
            COMMENTFLG)

        (* ;; 
"must be special case'd first so that (* * values) doesn't make it look like `values' is a variable")
                                                             (* ; 
  "don't know why I should bother, but someone might want to know all of the comments on a file???")
        (COND
           ((EQ TYPE COMMENTFLG)
            (INFILECOMSVAL COM T)))
        NIL)
       (T
        (PROG ((COMNAME (CAR COM))
               (TAIL (CDR COM))
               CFN TEM)
              (COND
                 [[COND
                     ((SETQ CFN (fetch (FILEPKGCOM CONTENTS) of COMNAME))
                      (SETQ TEM (APPLY* CFN COM (COND
                                                   ((AND (NULL ONFILETYPE)
                                                         (NOT (CL:SYMBOLP NAME)))
                                                             (* ; 
                                                "call from WHEREIS of a name which is not a symbol")
                                                    (LIST NAME))
                                                   (T NAME))
                                       TYPE ONFILETYPE)))
                     ((SETQ CFN (fetch (FILEPKGCOM PRETTYTYPE) of COMNAME))
                                                             (* ; "for compatability")
                      (SETQ TEM (APPLY* CFN COM TYPE NAME]
                  (COND
                     [(NLISTP TEM)
                      (COND
                         ((EQ TEM T)
                          (COND
                             ((OR (EQ NAME T)
                                  (NULL ONFILETYPE))
                              (RETFROM 'INFILECOMS? T]
                     (T (INFILECOMSVALS TEM]
                 ((LISTP TAIL)

                  (* ;; "this SELECTQ handles the `exceptional cases' for the built in types.  There is an explicit RETURN in the SELECTQ clause if the default is handled")

                  (SELECTQ COMNAME
                      ((PROP IFPROP) 
                           (SETQ TAIL (CDR TAIL)))
                      NIL)
                  [COND
                     ((EQ (CAR TAIL)
                          '*)
                      (COND
                         ((LITATOM (CADR TAIL))
                          (SELECTQ TYPE
                              ((VARS FILEVARS) 
                                   (INFILECOMSVAL (CADR TAIL)))
                              NIL))
                         ((AND (LISTP (CADR TAIL))
                               (EQ ONFILETYPE 'UPDATE)
                               (EQ TYPE 'VARS)
                               (EQ (CAADR TAIL)
                                   'PROGN)
                               (FMEMB (CAR (LAST (CADR TAIL)))
                                      NAME))
                          (SETQ VAL (CONS (CADR TAIL)
                                          VAL]
                  (SELECTQ COMNAME
                      ((COMS EXPORT) 
                           (INFILECOMS (INFILECOMTAIL COM T)))
                      (CL:EVAL-WHEN (INFILECOMS (INFILECOMTAIL (CDR COM)
                                                           T)))
                      (DECLARE%:                             (* ; "skip over DECLARE: tags")
                                 [RETURN (AND (NOT (FMEMB 'COMPILERVARS COM))
                                              (IFCDECLARE (INFILECOMTAIL COM)
                                                     (EQ TYPE 'DECLARE%:])
                      (ORIGINAL                              (* ; "dont expand macros")
                                (PROG ((ORIGFLG T))
                                      (INFILECOMS (INFILECOMTAIL COM T))))
                      ((PROP IFPROP)                         (* ; 
                                       "this currently does not handle `pseudo-types' of PROPNAMES")
                           (SELECTQ TYPE
                               (PROPS (IFCPROPSCAN (INFILECOMTAIL (CDR COM)
                                                              T)
                                             (CADR COM)))
                               (MACROS (INFILECOMSMACRO (INFILECOMTAIL (CDR COM))
                                              (CADR COM)))
                               NIL))
                      (PROPS (RETURN (IFCPROPS COM)))
                      (MACROS (RETURN (SELECTQ TYPE
                                          (PROPS (IFCPROPSCAN (INFILECOMTAIL COM T)
                                                        MACROPROPS))
                                          (MACROS (INFILECOMSVALS (INFILECOMTAIL COM T)))
                                          NIL)))
                      (ALISTS                                (* ; 
                      "sigh.  This should probably also `coerce' when asking for LISPXMACROS, etc.")
                              (RETURN (SELECTQ TYPE
                                          (ALISTS (INFILEPAIRS (INFILECOMTAIL COM)))
                                          NIL)))
                      (P [RETURN (SELECTQ TYPE
                                     ((EXPRESSIONS P) 
                                          (INFILECOMSVALS (INFILECOMTAIL COM T)
                                                 T))
                                     (COND
                                        ((NULL ONFILETYPE)   (* ; "for WHEREIS and FILECOMSLST")
                                         (SELECTQ TYPE
                                             (I.S.OPRS (IFCEXPRTYPE COM 'I.S.OPR))
                                             (TEMPLATES (IFCEXPRTYPE COM 'SETTEMPLATE))
                                             NIL])
                      ((ADDVARS APPENDVARS) 
                           (SELECTQ TYPE
                               (VARS [RETURN (AND (NULL ONFILETYPE)
                                                  (for X in (INFILECOMTAIL COM T)
                                                     do (INFILECOMSVAL (CAR X)
                                                                   T])
                               (ALISTS [RETURN (for X in (INFILECOMTAIL COM T)
                                                  when (EQMEMB 'ALIST (GETPROP (CAR X)
                                                                                 'VARTYPE))
                                                  do (for Z in (CDR X)
                                                            do (INFILECOMSVAL
                                                                    (LIST (CAR X)
                                                                          (CAR Z))
                                                                    T])
                               (OR (EQ TYPE COMNAME)
                                   (RETURN))))
                      ((VARS INITVARS FILEVARS UGLYVARS HORRIBLEVARS CONSTANTS ARRAY) 
                           [RETURN (COND
                                      ((EQ TYPE 'EXPRESSIONS)
                                       (for X in (INFILECOMTAIL COM T)
                                          when (AND (LISTP X)
                                                        (NEQ (CAR X)
                                                             COMMENTFLG))
                                          do (INFILECOMSVAL (CONS 'SETQ X)
                                                        T)))
                                      ((OR (EQ TYPE 'VARS)
                                           (EQ TYPE COMNAME))(* ; 
                   "either want all VARS, or else want all FILEVARS and this is a FILEVARS command")
                                       (for X in (INFILECOMTAIL COM T)
                                          do (COND
                                                    ((LISTP X)
                                                     (AND (CAR X)
                                                          (NEQ (CAR X)
                                                               COMMENTFLG)
                                                          (INFILECOMSVAL (CAR X)
                                                                 T)))
                                                    (X (INFILECOMSVAL X (EQ COMNAME 'INITVARS])
                      (DEFS [RETURN (for X in (INFILECOMTAIL COM T)
                                       when (EQ TYPE (CAR X)) do (INFILECOMSVALS
                                                                          (CDR X])
                      (FILES (RETURN))
                      NIL)

                  (* ;; "Exceptional cases now handled.  If TYPE matches (CAR COM) then scan the tail as usual.  Else expand the com's MACRO, if it has one, unless there was a CONTENTS function")

                  (COND
                     ((EQ COMNAME TYPE)
                      (INFILECOMSVALS (INFILECOMTAIL COM T)))
                     [(AND (LISTP TYPE)
                           (FMEMB COMNAME TYPE))
                      (LET ((TYPE COMNAME))
                           (INFILECOMSVALS (INFILECOMTAIL COM T]
                     ((AND (OR (NULL CFN)
                               (AND (EQ CFN T)
                                    (NULL ONFILETYPE)))
                           (NULL ORIGFLG)
                           (SETQ TEM (fetch (FILEPKGCOM MACRO) of COMNAME)))
                      (INFILECOMS (SUBPAIR (CAR TEM)
                                             (INFILECOMTAIL COM T)
                                             (CDR TEM])

(INFILECOMSVALS
  [LAMBDA (X FLG)                                     (* ; "Edited  2-Aug-88 02:21 by masinter")
    (for Y in X when (NOT (AND (LISTP Y)
                                           (EQ (CAR Y)
                                               COMMENTFLG))) do (INFILECOMSVAL Y FLG])

(INFILECOMSVAL
  [LAMBDA (X FLG)                                     (* ; "Edited 12-Jul-88 17:56 by MASINTER")
    (COND
       [(EQ ONFILETYPE 'UPDATE)
        (AND (OR (NULL NAME)
                 (MEMBER X NAME))
             (COND
                (FLG (SETQ LITERALS (CONS X LITERALS)))
                (T (SETQ VAL (CONS X VAL]
       ((AND (EQ ONFILETYPE 'EDIT)
             FLG)                                            (* ; 
                                        "literals should not be edited as they are on the fileCOMS")
        NIL)
       ((EQ ONFILETYPE 'TYPESOF)
        (AND (COND
                ((LITATOM NAME)
                 (EQ NAME X))
                (T (EQUAL NAME X)))
             (CL:PUSHNEW TYPE VAL)))
       ([OR (EQ NAME T)
            (COND
               ((LITATOM NAME)
                (EQ NAME X))
               (T (EQUAL NAME X]
        (RETFROM (FUNCTION INFILECOMS?)
               T))
       ((NULL NAME)
        (SETQ VAL (CONS X VAL])

(INFILECOMSPROP
  [LAMBDA (AT PROP)                                      (* lmm "25-SEP-81 17:15")
    (COND
       [(EQ ONFILETYPE 'UPDATE)
        (AND [OR (NULL NAME)
                 (find X in NAME suchthat (AND (EQ (CAR X)
                                                               AT)
                                                           (EQ (CADR X)
                                                               PROP]
             (SETQ VAL (CONS (LIST AT PROP)
                             VAL]
       ((OR (EQ NAME T)
            (AND (EQ (CAR NAME)
                     AT)
                 (EQ (CADR NAME)
                     PROP)))
        (RETFROM (FUNCTION INFILECOMS?)
               T))
       ((NULL NAME)
        (SETQ VAL (CONS (LIST AT PROP)
                        VAL])

(IFCPROPS
  [LAMBDA (COM)                                          (* bvm%: " 2-Dec-83 14:24")

(* ;;; "Examine a PROPS com for objects of specified TYPE")

    (SELECTQ TYPE
        (PROPS                                               (* ; 
                                       "the PROPS command can actually take (PROPNAME at1 at2 ...)")
               (INFILEPAIRS (INFILECOMTAIL COM)))
        (PROP                                                (* ; 
                                                "return the atoms which have any properties at all")
              (for PAIR in (INFILECOMTAIL COM) do (for ATNAME
                                                                     inside (CAR PAIR)
                                                                     do (INFILECOMSVAL ATNAME
                                                                                   ))))
        (MACROS                                              (* ; "only MACRO properties")
                (for PAIR in (INFILECOMTAIL COM) do (INFILECOMSMACRO (CAR PAIR)
                                                                           (CDR PAIR))))
        NIL])

(IFCEXPRTYPE
  [LAMBDA (COM FN)                                       (* ; "Edited  6-Apr-87 20:20 by Pavel")

(* ;;; "Recognizes expressions in COM (a P com) that are calls to function FN")

    (for SUBCOM in (INFILECOMTAIL COM)
       when (AND (EQ (CAR SUBCOM)
                         FN)
                     (EQ (CAR (LISTP (CADR SUBCOM)))
                         'QUOTE)) do (INFILECOMSVAL (CADR (CADR SUBCOM))
                                                T])

(IFCPROPSCAN
  [LAMBDA (ATOMS PROPNAMES)                           (* ; "Edited  2-Aug-88 02:20 by masinter")

(* ;;; 
"Recognizes members of ATOMS as being names (atom prop) of type PROPS for any prop in PROPNAMES")

    (for AT in ATOMS WHEN (LITATOM AT) unless [COND
                                                                 [(EQ ONFILETYPE 'UPDATE)
                                                                  (COND
                                                                     (NAME (NOT (ASSOC AT NAME]
                                                                 ((LISTP NAME)
                                                                  (NEQ AT (CAR NAME]
       do (COND
                 ((EQ PROPNAMES 'ALL)
                  (for PROP in (GETPROPLIST AT) by (CDDR PROP)
                     when (NOT (FMEMB PROP SYSPROPS)) collect (INFILECOMSPROP AT PROP)))
                 (T (for PROP inside PROPNAMES do (INFILECOMSPROP AT PROP])

(IFCDECLARE
  [LAMBDA (TAIL WANTDECLARE)                          (* ; "Edited  8-Jun-90 18:11 by teruuchi")
    (PROG ((TAIL TAIL))
      LP  (COND
             ((LISTP TAIL)
              [SELECTQ (CAR TAIL)
                  ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                       [AND WANTDECLARE (INFILECOMSVAL (LIST (CAR TAIL)
                                                                 (CADR TAIL]
                       (SETQ TAIL (CDR TAIL)))
                  (DONTEVAL@LOAD [COND
                                    ((OR (\STKSCAN 'DOFILESLOAD)
                                         (\STKSCAN 'LOAD))
                                                  (* ; "Edited by TT (8-June-90 : for AR#9376) In loading, discard the following contents in DECLARE tag %"DONTEVAL@LOAD%"")
                                     (RETURN))
                                    (WANTDECLARE (INFILECOMSVAL (CAR TAIL])
                  (COMPILERVARS (RETURN))
                  (COND
                     [(FMEMB (CAR TAIL)
                             DECLARETAGSLST)
                      (COND
                         (WANTDECLARE (INFILECOMSVAL (CAR TAIL]
                     (T (INFILECOM (CAR TAIL]
              (SETQ TAIL (CDR TAIL))
              (GO LP])

(INFILEPAIRS
  [LAMBDA (LST)                                          (* lmm " 4-DEC-78 09:51")
    (for LL in LST do (for X inside (CAR LL)
                                     do (for Y inside (CDR LL)
                                               do (INFILECOMSVAL (LIST X Y])

(INFILECOMSMACRO
  [LAMBDA (ATS PROPS)                                    (* lmm "28-SEP-78 18:35")

    (* ;; "this function is used, given a PROP or PROPS command, to tell which MACROS are contained in it.  --- Normally (e.g.  for WHEREIS and FILECOMSLST) it wants to return if the command contains any of the MACROPROPS for the given atom.  However, for UPDATE, it only wants a `hit' if the command contains ALL of the macro properties")

    (for AT inside ATS do (AND [OR (NEQ ONFILETYPE 'UPDATE)
                                               (EVERY (PROPNAMES AT)
                                                      (FUNCTION (LAMBDA (X)
                                                                  (OR (NOT (FMEMB X MACROPROPS))
                                                                      (EQMEMB X PROPS]
                                           [SOME MACROPROPS (FUNCTION (LAMBDA (PROP)
                                                                        (EQMEMB PROP PROPS]
                                           (INFILECOMSVAL AT])
)



(* ;; "adding to a file")

(DEFINEQ

(FILES?
  [LAMBDA NIL                                            (* bvm%: "27-Oct-86 18:14")

(* ;;; 
"Display each file needing dumping, etc.  For files needing dumping, display details of why.")

    (UPDATEFILES)
    (LET (FILES CHANGES PRINTED)
         (for FILE in FILELST when [SETQ CHANGES (fetch TOBEDUMPED
                                                                of (LISTP (fetch FILEPROP
                                                                                 of FILE]
            do (if (NOT PRINTED)
                       then (LISPXPRIN1 "To be dumped:
" T)
                             (SETQ PRINTED T))
                  (LISPXPRIN2 FILE T)
                  (LISPXPRIN1 " ...changes to " T)
                  [for CH in CHANGES bind TB
                     do (COND
                               ((LISTP CH)
                                [COND
                                   (TB (LISPXTAB TB NIL T))
                                   (T (SETQ TB (POSITION T]
                                (LISPXPRIN2 (CAR CH)
                                       T)
                                (FILES?PRINTLST (CDR CH)))
                               (T                            (* ; "old style")
                                  (LISPXPRIN2 CH T)
                                  (LISPXSPACES 1 T]
                  (LISPXTERPRI T))
         (for TYPE FLG in FILEPKGTYPES when (FILES?1 TYPE (AND PRINTED "    plus "))
            do (SETQ FLG T) finally (if FLG
                                                then (OR PRINTED (LISPXPRIN1 "...to be dumped.  "
                                                                            T))
                                                      (ADDTOFILES?)))
         (if (SETQ FILES NOTCOMPILEDFILES)
             then (FILES?PRINTLST FILES "To be compiled: ")
                   (LISPXTERPRI T))
         (if (SETQ FILES NOTLISTEDFILES)
             then (FILES?PRINTLST FILES "To be listed: ")
                   (LISPXTERPRI T))
         (CL:VALUES])

(FILES?1
  [LAMBDA (TYPE FIRST)                                   (* bvm%: "27-Oct-86 18:17")

    (* ;; "If there are changed objects of TYPE, then print them out, preceded by FIRST (if given) plus a descriptive string, and return T.")

    (LET (STR LST)
         (COND
            ([AND (LITATOM TYPE)
                  (SETQ STR (fetch DESCRIPTION of TYPE))
                  (LISTP (SETQ LST (fetch CHANGED of TYPE]
             (AND FIRST (LISPXPRIN1 FIRST T))
             (LISPXPRIN1 '"the " T)
             (LISPXPRIN1 STR T)
             (FILES?PRINTLST LST)
             (LISPXTERPRI T)
             T])

(FILES?PRINTLST
  [LAMBDA (LST STR)                                      (* bvm%: "27-Oct-86 18:15")

    (* ;; "Print elements of LST separated by commas and indenting new lines a bunch.  If MAPRINT had a left margin arg, this would be simpler.")

    (MAPRINT LST T (OR STR ": ")
           NIL ", " [FUNCTION (LAMBDA (STR)
                                (COND
                                   ((> (+ (POSITION T)
                                          (NCHARS STR T T)
                                          3)
                                       (LINELENGTH NIL T))
                                    (LISPXTERPRI T)
                                    (LISPXPRIN1 "         " T)))
                                (LISPXPRIN2 STR T T]
           T])

(ADDTOFILES?
  [LAMBDA (NOASKSTR)                                    (* ; "Edited 10-Aug-2020 21:18 by rmk:")
                                                             (* ; "Edited 21-Aug-91 10:13 by jds")

    (* ;; "ask user about all of the things that need to be dumped, and distribute them to the files that he says")

    (* ;; "RMK: Eliminated literal CR's in the key list.")

    (ERSETQ
     (PROG [BUFS (VARSCHANGES (fetch (FILEPKGTYPE CHANGED) of 'VARS]

      (* ;; "Save VARS list at the beginning, so that changes that might occur from adding things to files (e.g.  changing NILCOMS) will not be processed differently depending on the order of elements in FILEPKGTYPES")

           [COND
              (NOASKSTR (PRIN1 NOASKSTR T))
              (T (DOBE)
                 (SETQ BUFS (READP T))
                 (SELECTQ (ASKUSER DWIMWAIT 'N '("want to say where the above go")
                                 `([Y ,(CONCAT "es" (CHARACTER (CHARCODE EOL]
                                   [N ,(CONCAT "o" (CHARACTER (CHARCODE EOL]
                                   (%] ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL)))
                                       EXPLAINSTRING 
                                       "] - nowhere, all items will be marked as dummy
" NOECHOFLG T))
                                 T)
                     (N (RETURN))
                     (%]                                     (* ; "Nowhere")
                         (for TYPE in FILEPKGTYPES
                            do (for NAME in (fetch (FILEPKGTYPE CHANGED)
                                                           of TYPE)
                                      do (ADDTOFILE NAME TYPE NIL)))
                         (RETURN))
                     NIL)                                    (* ; 
                              "if there was type-ahead BEFORE the askuser, then don't allow it now")
                 (COND
                    (BUFS (SETQ BUFS (COND
                                        ((READP T)
                                         (LINBUF)
                                         (SYSBUF)
                                         (SETQ BUFS (CLBUFS NIL T READBUF]
           [for TYPE STR LST in FILEPKGTYPES
              when [AND (SETQ STR (fetch DESCRIPTION of TYPE))
                            (LISTP (SETQ LST (COND
                                                ((EQ TYPE 'VARS)
                                                 VARSCHANGES)
                                                (T (fetch (FILEPKGTYPE CHANGED) of TYPE]
              do
              (printout T "(" STR ")" T)
              (for NAME TEM FILE in LST when NAME
                 do
                 (PROG NIL
                   LP  (PRIN2 NAME T)
                       (SPACES 2 T)

                  (* ;; "if user typed ahead before entering addtofiles??  then dont allow typeahead here, because it will justgobble his earlier typeahead.")

                  (* ;; "SELCHARQ to avoid literal CR")

                       (SELCHARQ (CHCON1 (SETQ TEM (ASKUSER NIL NIL NIL ADDTOFILEKEYLST T)))
                            (%[ (ERSETQ (PROGN (SHOWDEF NAME TYPE T)

                                 (* ;; "the DOBE is so that if the user control-E's after the printout is done but before it appears on the screen that the control-E will merely clear output buffer")

                                               (DOBE)))
                                (GO LP))
                            (%]                              (* ; "Nowhere")
                                (SETQ FILE))
                            (SPACE                           (* ; "No action")
                                   (RETURN))
                            ((LF =) 
                                 (PRINT (OR (SETQ FILE LASTFILE)
                                            'Nowhere)
                                        T))
                            (SETQ FILE TEM))
                       (OR (ERSETQ (PROG (TEM COMSNAME PLACE LISTNAME NEAR)
                                         (SETQ PLACE (WHATIS FILE NIL TYPE))
                                         [COND
                                            ((LITATOM PLACE) (* ; "file name")
                                             (SETQ FILE PLACE)
                                             (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
                                                        NAME TYPE NEAR LISTNAME)
                                                 (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE))

                                          (* ;; "This isn't factored to the end, cause ADDTOLISTNAME might have to deal with a set of old elements on the listname.")

                                             )
                                            ((EQ (CAR PLACE)
                                                 'Near%:)
                                             (SETQ NEAR (CADR PLACE))
                                             (COND
                                                ([SOME FILELST (FUNCTION (LAMBDA (FL)
                                                                           (ADDTOCOMS
                                                                            (FILECOMS (SETQ FILE
                                                                                           FL))
                                                                            NAME TYPE NEAR LISTNAME]
                                                 (PRINT (LIST 'on FILE)
                                                        T T))
                                                (T (PRINT (LIST (CADR PLACE)
                                                                'not
                                                                'found)
                                                          T T)
                                                   (ERROR!)))
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE)))
                                            ([OR [UNDONLSETQ (PROGN (SAVESET
                                                                     (SETQ LISTNAME (CAR PLACE))
                                                                     (MERGEINSERT
                                                                      NAME
                                                                      (LISTP (GETTOPVAL LISTNAME))
                                                                      T)
                                                                     T
                                                                     'NOPRINT)
                                                                    (OR (SETQ FILE
                                                                         (CAR (WHEREIS NAME TYPE
                                                                                     FILELST)))
                                                                        (ERROR!]
                                                 (SOME FILELST (FUNCTION (LAMBDA (X)
                                                                           (ADDTOCOMS
                                                                            (FILECOMS (SETQ FILE
                                                                                           X))
                                                                            NAME TYPE NEAR LISTNAME]
                                             (PRIN1 "  value is filed on " T)
                                             (PRINT FILE T T)
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE))

                                 (* ;; "Only have to notice the single new item here, unlike the case in ADDNEWCOM below, cause other items on the list already belong and were previously noticed")

                                             )
                                            (T (PRIN1 "    put list " T)
                                               (PRIN2 (CAR PLACE)
                                                      T T)
                                               (SETQ FILE
                                                (WHATIS (ASKUSER NIL NIL " on file: "
                                                                   '(("" "" EXPLAINSTRING 
                                                                         "a file name" KEYLST ()))
                                                                   T)
                                                       'FILE))
                                               (SAVESET (CAR PLACE)
                                                      (MERGEINSERT NAME
                                                             (LISTP (GETTOPVAL (CAR PLACE)))
                                                             T)
                                                      T
                                                      'NOPRINT)

                                     (* ;; "Add new item before new command, so that user's new command function can inspect (CAR PLACE) and see all the items involved.")

                                               (ADDNEWCOM (FILECOMS FILE)
                                                      NAME TYPE (CAR PLACE)
                                                      FILE)
                                               (for F in (fetch WHENFILED of TYPE)
                                                  do (for I in (GETTOPVAL (CAR PLACE))
                                                            do (APPLY* F I TYPE FILE]
                                         (AND FILE (ADDFILE FILE))
                                         (SETQ LASTFILE PLACE)))
                           (GO LP]
           (AND BUFS (BKBUFS BUFS))
           (UPDATEFILES])

(ADDTOFILE
  [LAMBDA (NAME TYPE FILE NEAR LISTNAME)                 (* lmm "21-Nov-84 11:43")
                                                             (* ; "adds NAME to the file FILE")
    (PROG (TEM COMSNAME)
          [SETQ TYPE (OR (GETFILEPKGTYPE TYPE NIL T)
                         (COND
                            ((FMEMB TYPE FILELST)
                             (GETFILEPKGTYPE (swap TYPE FILE)))
                            (T (GETFILEPKGTYPE TYPE]
          (SETQ FILE (WHATIS FILE 'FILE))
          (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
                     NAME TYPE NEAR LISTNAME)
              (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
          (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE))
          (AND FILE (NOT (FMEMB FILE FILELST))
               (ADDFILE FILE))
          (RETURN FILE])

(WHATIS
  [LAMBDA (USERINPUT ONLY)                               (* lmm "28-Nov-84 16:49")

    (* ;; "decides whether USERINPUT is a file or a list name --- if ONLY is nil, means either a listname or a filename is accepatble;  if ONLY is LIST then only a listname is acceptable and if ONLY is FILE then only a file name is acceptable")

    (PROG (TEM UCASE)
          (RETURN (COND
                     ((NULL USERINPUT)                       (* ; "nowhere")
                      NIL)
                     [(LISTP USERINPUT)
                      (COND
                         (ONLY (ERROR!))
                         (T (SELECTQ (CAR USERINPUT)
                                ((@ Near%:) 
                                     (CONS 'Near%: (CDR USERINPUT)))
                                (WHATIS (CAR USERINPUT)
                                       'LIST]
                     ([AND (NEQ ONLY 'LIST)
                           (OR (FMEMB (SETQ TEM (SETQ UCASE (U-CASE USERINPUT)))
                                      FILELST)
                               (LISTP (GETTOPVAL (FILECOMS UCASE)))
                               (SETQ TEM (FIXSPELL UCASE NIL FILELST T]
                      TEM)
                     ((AND (NEQ ONLY 'FILE)
                           (LISTP (GETTOPVAL USERINPUT)))
                      (LIST USERINPUT))
                     ((AND (NEQ ONLY 'LIST)
                           (EQ (ASKUSER NIL NIL (LIST "create new file" UCASE)
                                      NIL T)
                               'Y))
                      UCASE)
                     ((AND (NEQ ONLY 'FILE)
                           (EQ (ASKUSER NIL NIL (LIST "create new list" USERINPUT)
                                      NIL T)
                               'Y))
                      (LIST USERINPUT))
                     (T                                      (* ; "none of above")
                        (ERROR!])

(ADDTOCOMS
  [LAMBDA (COMS NAME TYPE NEAR LISTNAME)                 (* rmk%: "10-JUN-82 22:53")

    (* ;; "try to insert NAME of type TYPE command list COMS (either a coms name, or a just a list of coms);  return NIL if unsuccessful.  If LISTNAME is given, then only insert by adding to LISTNAME.  If NEAR is given, only insert near it")

    (COND
       ((NULL COMS)
        NIL)
       [(LITATOM COMS)                                       (* ; 
      "given a name of a command;  rebind COMSNAME to current variable and try to add to its value")
        (OR [PROG ((COMSNAME COMS))
                  (RETURN (ADDTOCOMS (LISTP (GETTOPVAL COMSNAME))
                                 NAME TYPE NEAR (AND (NEQ COMS LISTNAME)
                                                     LISTNAME]
            (AND (EQ COMS LISTNAME)
                 (ADDNEWCOM COMS NAME TYPE]
       (T (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (for TAIL on COMS do (COND
                                              [(LISTP (CAR TAIL))
                                               (COND
                                                  ((ADDTOCOM (CAR TAIL)
                                                          NAME TYPE NEAR LISTNAME)
                                                   (RETURN T]
                                              (T (SELECTQ (CAR TAIL)
                                                     ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                                                          (SETQ TAIL (CDR TAIL)))
                                                     NIL])

(ADDTOCOM
  [LAMBDA (COM NAME TYPE NEAR LISTNAME)                  (* ; "Edited  2-May-87 19:04 by Pavel")
                                                             (* ; 
                        "tries to insert NAME into the prettycom COM;  returns NIL if unsuccessful")
    (PROG (TEM)
          (COND
             ([AND NEAR (NOT (INFILECOMS? NEAR TYPE (LIST COM]
              (RETURN)))
          [COND
             ((SETQ TEM (fetch ADD of (CAR COM)))
              (RETURN (COND
                         ((OR (NULL LISTNAME)
                              (INFILECOMS? LISTNAME 'FILEVARS (LIST COM)))
                          (AND (SETQ TEM (APPLY* TEM COM NAME TYPE NEAR))
                               (MARKASCHANGED COMSNAME 'VARS))
                          TEM]
          (RETURN
           (SELECTQ (CAR COM)
               (FNS (AND (EQ TYPE 'FNS)
                         (ADDTOCOM1 COM NAME NEAR LISTNAME)))
               ((VARS INITVARS) 
                    (COND
                       ((OR (EQ (CAR COM)
                                'VARS)
                            NEAR LISTNAME)                   (* ; 
                                  "Don't stick on INITVARS unless NEAR or LISTNAME says we should.")
                        (SELECTQ TYPE
                            (EXPRESSIONS (COND
                                            ((EQ (CAR NAME)
                                                 'SETQ)
                                             (ADDTOCOM1 COM (CDR NAME)
                                                    NEAR LISTNAME))))
                            (VARS (ADDTOCOM1 COM NAME NEAR LISTNAME))
                            NIL))))
               (COMS (ADDTOCOMS (COND
                                       [(EQ (CADR COM)
                                            '*)
                                        (COND
                                           ((LITATOM (CADDR COM))
                                            (CADDR COM))
                                           (T (RETURN]
                                       (T (CDR COM)))
                            NAME TYPE NEAR LISTNAME))
               (DECLARE%: (AND (OR LISTNAME NEAR)
                               (ADDTOCOMS (COND
                                                 [(EQ (CADR COM)
                                                      '*)
                                                  (COND
                                                     ((LITATOM (CADDR COM))
                                                      (CADDR COM))
                                                     (T (RETURN]
                                                 (T (CDR COM)))
                                      NAME TYPE NEAR LISTNAME)))
               (CL:EVAL-WHEN (AND (OR LISTNAME NEAR)
                                  (ADDTOCOMS (COND
                                                    [(EQ (CL:THIRD COM)
                                                         '*)
                                                     (COND
                                                        ((LITATOM (CL:FOURTH COM))
                                                         (CL:FOURTH COM))
                                                        (T (RETURN]
                                                    (T (CDDR COM)))
                                         NAME TYPE NEAR LISTNAME)))
               ((PROP IFPROP) 
                    (SELECTQ TYPE
                        (PROPS (COND
                                  ((EQ (CADR COM)
                                       (CADR NAME))
                                   (ADDTOCOM1 (CDR COM)
                                          (CAR NAME)
                                          NEAR LISTNAME))
                                  ((AND (EQ (CAR NAME)
                                            (CADDR COM))
                                        (NULL (CDDDR COM)))
                                   [/RPLACA (CDR COM)
                                          (UNION (MKLIST (CDR NAME))
                                                 (MKLIST (CADR COM]
                                   (MARKASCHANGED COMSNAME 'VARS)
                                   T)))
                        (MACROS (COND
                                   ([AND (for PROP inside (CADR COM)
                                            always (EQMEMB PROP MACROPROPS))
                                         (for PROP in MACROPROPS
                                            always (OR (EQMEMB PROP (CADR COM))
                                                           (NOT (GETPROP NAME PROP]

                                    (* ;; "every property in the command is a macro prop and, either this is an IFPROP or else the MACROS are changed")

                                    (ADDTOCOM1 (CDR COM)
                                           NAME NEAR LISTNAME))))
                        NIL))
               ((PROPS ALISTS) 
                    (AND (EQ TYPE (CAR COM))
                         (ADDTOCOM1
                          COM
                          (/NCONC1 (OR [ASSOC (CAR NAME)
                                              (COND
                                                 [(EQ (CADR COM)
                                                      '*)
                                                  (COND
                                                     [(LITATOM (CADDR COM))
                                                      (AND (OR (NULL LISTNAME)
                                                               (EQ (CADDR COM)
                                                                   LISTNAME))
                                                           (GETTOPVAL (CADDR COM]
                                                     (T (RETURN]
                                                 (T (CDR COM]
                                       (LIST (CAR NAME)))
                                 (CADR NAME))
                          NEAR LISTNAME)))
               (P (COND
                     ((AND (EQ TYPE 'EXPRESSIONS)
                           (NEQ (CAR NAME)
                                'SETQ))
                      (ADDTOCOM1 COM NAME NEAR LISTNAME))))
               (AND (EQ (CAR COM)
                        TYPE)
                    (ADDTOCOM1 COM NAME NEAR LISTNAME])

(ADDTOCOM1
  [LAMBDA (COM NAME NEAR LISTNAME)                       (* rmk%: " 3-JAN-82 22:53")
    (COND
       [(EQ (CADR COM)
            '*)                                              (* ; "add to list name")
        (AND [COND
                (LISTNAME (EQ (CADDR COM)
                              LISTNAME))
                (T (LITATOM (CADDR COM]
             (SAVESET (CADDR COM)
                    [PROGN [SETQ COM (LISTP (GETTOPVAL (CADDR COM]
                           (COND
                              ((AND NEAR (SETQ NEAR (MEMBER NEAR COM)))
                               (/RPLACD NEAR (CONS NAME (CDR NEAR)))
                               COM)
                              (T (MERGEINSERT NAME COM T]
                    T
                    'NOPRINT]
       ((NULL LISTNAME)                                      (* ; "add to standard com")
        [AND (NOT (MEMBER NAME (CDR COM)))
             (COND
                [(SETQ NEAR (MEMBER NEAR COM))
                 (/RPLACD NEAR (CONS NAME (CDR NEAR]
                (T (/RPLACD COM (MERGEINSERT NAME (CDR COM]
        (MARKASCHANGED COMSNAME 'VARS)
        T])

(ADDNEWCOM
  [LAMBDA (COMSNAME NAME TYPE LISTNAME FILE)             (* rmk%: " 3-JAN-82 22:53")

    (* ;; "Adds to COMSNAME a new command that will dump NAME as a TYPE on FILE.  --- if LISTNAME is given, then use it as the listname")

    (PROG (NEWCOM OLDCOM TAIL)
          (SETQ NEWCOM (MAKENEWCOM NAME TYPE LISTNAME FILE))
          [COND
             ((NLISTP (SETQ TAIL (GETTOPVAL COMSNAME)))
              (RETURN (SAVESET COMSNAME (LIST NEWCOM)
                             T
                             'NOPRINT]
      LP  [COND
             ((OR (NLISTP (SETQ OLDCOM (CAR TAIL)))
                  (SELECTQ (CAR OLDCOM)
                      ((LOCALVARS SPECVARS BLOCKS) 
                           T)
                      (DECLARE%: (FMEMB 'COMPILERVARS (CDR OLDCOM)))
                      NIL))
              (/ATTACH NEWCOM TAIL))
             ((LISTP (CDR TAIL))
              (SETQ TAIL (CDR TAIL))
              (GO LP))
             (T (/RPLACD TAIL (LIST NEWCOM]
          (MARKASCHANGED COMSNAME 'VARS])

(MAKENEWCOM
  [LAMBDA (NAME TYPE LISTNAME FILE)                      (* ; "Edited  8-Apr-87 14:55 by Pavel")
    (SETQ TYPE (GETFILEPKGTYPE TYPE))
    (PROG (TEM)

     (* ;; "the user function MUST (a) check if FILE = T and not do anything destructive (since this is only for showdef) and (b) if LISTNAME is given, then use it rather than generating a different listname")

          (AND (LISTP NAME)
               (SETQ NAME (COPY NAME)))
          (RETURN (OR (AND (SETQ TEM (fetch NEWCOM of TYPE))
                           (APPLY* TEM NAME TYPE LISTNAME FILE))
                      (SELECTQ TYPE
                          (PROPS [AND (NULL LISTNAME)
                                      (CONS 'PROP (CONS (COND
                                                           ((AND (LISTP (CDR NAME))
                                                                 (NULL (CDDR NAME)))
                                                            (CADR NAME))
                                                           (T (CDR NAME)))
                                                        (OR (LISTP (CAR NAME))
                                                            (LIST (CAR NAME])
                          (EXPRESSIONS [COND
                                          ((EQ (CAR NAME)
                                               'SETQ)
                                           (MAKENEWCOM (CDR NAME)
                                                  'VARS LISTNAME FILE))
                                          (T (CONS 'P (COND
                                                         (LISTNAME (LIST '* LISTNAME))
                                                         (T (LIST NAME])
                          NIL)
                      (DEFAULTMAKENEWCOM NAME TYPE LISTNAME FILE])

(DEFAULTMAKENEWCOM
  [LAMBDA (NAME TYPE LISTNAME FILE)                      (* lmm "20-OCT-82 22:48")
    (COND
       ((NOT (OR (FMEMB TYPE FILEPKGCOMSPLST)
                 (fetch MACRO of TYPE)
                 (fetch GETDEF of TYPE)))
        (ERROR "no defined way to dump or obtain the definition of " (OR (fetch DESCRIPTION
                                                                            of TYPE)
                                                                         TYPE)
               T))
       ((NULL DEFAULTCOMHASFILEFLG)                          (* ; "disable FOOFNS FOOVARS junk")
        (LIST TYPE NAME))
       ((EQ FILE T)                                          (* ; 
                                                           "FILE=T only when called from SHOWDEF")
        (LIST TYPE NAME))
       ([OR LISTNAME (AND FILE (SAVESET (SETQ LISTNAME (FILECOMS FILE TYPE))
                                      (MERGEINSERT NAME (LISTP (GETTOPVAL LISTNAME))
                                             T)
                                      T
                                      'NOPRINT]              (* ; "The check (AND FILE --) is so that it will not bother with making listnames just for deleting items")
        (LIST TYPE '* LISTNAME))
       (T (LIST TYPE NAME])
)

(RPAQ? DEFAULTCOMHASFILEFLG )

(ADDTOVAR MARKASCHANGEDFNS )
(DEFINEQ

(MERGEINSERT
  [LAMBDA (NEW LST ONEFLG)                               (* lmm "30-Jun-86 18:11")

    (* ;; "searches LST to find the most reasonable place to insert NEW.  Does nothing if ONEFLG is T and NEW is already a member of LST")

    (COND
       ((AND ONEFLG (MEMBER NEW LST))
        LST)
       ((LISTP NEW)
        (/NCONC1 LST NEW))
       (T (PROG ((N 0)
                 LST1 PLACE TEM)
                (SETQ LST1 LST)
            LP  

           (* ;; "finds the function with the longest leading common substring.  The idea is that if the list is only paatially sorted, want to insert the new thing in among those function that look like they are related.")

                (COND
                   ((NULL LST1)
                    (GO OUT))
                   ((OR (LISTP (CAR LST1))
                        (SETQ TEM (STRPOS (CAR LST1)
                                         NEW 1 NIL T T)))

                    (* ;; "this takes precedence over even a longer string so that for example in the list (ADDTOFILES? ADDTOFILE), ADDTOFILE1 will be inserted aater ADDTOFILE")

                    (SETQ PLACE LST1)
                    (GO OUT))
                   ((IGREATERP (SETQ TEM (MERGEINSERT1 (CAR LST1)
                                                NEW))
                           N)
                    (SETQ N TEM)
                    (SETQ PLACE LST1)))
                (SETQ LST1 (CDR LST1))
                (GO LP)
            OUT (SETQ TEM (CAR PLACE))
                (OR [SOME (OR PLACE LST)
                          (FUNCTION (LAMBDA (X LST)
                                      (COND
                                         ([OR (ALPHORDER NEW X)
                                              (AND PLACE (NOT (ALPHORDER TEM X]

                                 (* ;; "for example, if the FNS list is something like (...  FOO FOO1 ...) where the ...  may or may not be in order, e.g.  (ZAP FOO FOO1 BLAH), then want to insert FOO2 after FOO1, i.e. before BLAH, even though FOO2 wold not come before BLAH in a sorted list.")

                                          (/ATTACH NEW LST))
                                         (T (SETQ TEM X)
                                            NIL]
                    (SETQ LST (/NCONC1 LST NEW)))
                (RETURN LST])

(MERGEINSERT1
  [LAMBDA (X Y)                                          (* rmk%: "24-MAY-82 00:05")

    (* ;; "value is the number of leading characters of X and Y that agree.")

    (PROG ((N 1)
           C1 C2)
      LP  [COND
             ((OR (NULL (SETQ C1 (NTHCHARCODE X N)))
                  (NULL (SETQ C2 (NTHCHARCODE Y N)))
                  (NEQ C1 C2))
              (RETURN (SUB1 N]
          (SETQ N (ADD1 N))
          (GO LP])
)



(* ;; 
"RMK: Changed INITVARS to VARS, so = addition is a synonym for untypable LF, and also suppress appearance of raw CR and LF in the file"
)


(RPAQ ADDTOFILEKEYLST
      `(("[" "" EXPLAINSTRING "[ -- prettyprint the item to terminal and then ask again" NOECHOFLG T)
        (= "" EXPLAINSTRING "= - same as previous response" NOECHOFLG T)
        (,(CHARACTER (CHARCODE LF))
         "" EXPLAINSTRING "{line-feed} - same as previous response" NOECHOFLG T)
        (" " ,(CONCATCODES (LIST (CHARCODE SPACE)
                                 (CHARCODE EOL)))
             EXPLAINSTRING "{space} - no action" NOECHOFLG T)
        ("]" ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL)))
             EXPLAINSTRING
             ,(CONCAT "] - nowhere, item is marked as a dummy" (CHARACTER (CHARCODE EOL)))
             NOECHOFLG T)
        ["(" "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST
             (( "" CONFIRMFG [%) %] ,(CHARACTER (CHARCODE SPACE))
                                  ,(CHARACTER (CHARCODE EOL]
                 RETURN
                 (CDR ANSWER]
        (@ "Near: " EXPLAINSTRING "@ other-item   -- put the item near the other item" NOECHOFLG T 
           KEYLST (( "" CONFIRMFLG [,(CHARACTER (CHARCODE EOL]
                      RETURN ANSWER)))
        [,(CHARACTER (CHARCODE CR))
         "" RETURN ,(CHARACTER (CHARCODE SPACE]
        ("" "File name: " EXPLAINSTRING "a file name" KEYLST ())))

(RPAQQ LASTFILE NIL)



(* ;; "deleting an item from a file")

(DEFINEQ

(DELFROMFILES
  [LAMBDA (NAME TYPE FILES)                              (* rmk%: " 6-MAR-82 13:16")

    (* ;; "Eliminates NAME as an item of type TYPE in COMS.")

    (PROG (COMS)
          (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (RETURN (for FILE inside (OR FILES FILELST)
                     when (PROG1 (DELFROMCOMS (SETQ COMS (FILECOMS FILE))
                                            NAME TYPE)
                                  (COND
                                     ((INFILECOMS? NAME TYPE COMS)
                                      (printout T "(could not delete " NAME " from " FILE ")" T))))
                     collect (for FN in (fetch WHENUNFILED of TYPE)
                                    do (APPLY* FN NAME TYPE FILE))
                           FILE])

(DELFROMCOMS
  [LAMBDA (COMS NAME TYPE)                               (* bvm%: " 1-Oct-86 22:02")

    (* ;; "delete NAME of type TYPE from the coms COMS (either the name of some coms or a list).  Returns T if it does anything")

    (* ;; "If COMS is not a symbol, caller is required to bind COMSNAME to the symbol whose value we are deleting from, for benefit of marking it changed.")

    (COND
       [(LITATOM COMS)
        (LET ((COMSNAME COMS))
             (DECLARE (SPECVARS COMS))
             (AND (LISTP (SETQ COMS (GETTOPVAL COMSNAME)))
                  (DELFROMCOMS COMS NAME TYPE]
       (T (PROG (DONE)
                (SETQ TYPE (GETFILEPKGTYPE TYPE))
            LP  (COND
                   ((NLISTP COMS)
                    (RETURN DONE)))
                [COND
                   ((LISTP (CAR COMS))
                    (SELECTQ (DELFROMCOM (CAR COMS)
                                    NAME TYPE)
                        (ALL (/RPLNODE2 COMS (CDR COMS))
                             (SETQQ DONE ALL)
                             (GO LP))
                        (NIL)
                        (SETQ DONE T)))
                   (T (SELECTQ (CAR COMS)
                          ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                               (SETQ COMS (CDR COMS)))
                          (COND
                             ((AND (EQ TYPE 'VARS)
                                   (EQ NAME (CAR COMS)))
                              (/RPLNODE2 COMS (CDR COMS))
                              (SETQ DONE T)
                              (GO LP]
                (SETQ COMS (CDR COMS))
                (GO LP])

(DELFROMCOM
  [LAMBDA (COM NAME TYPE)                                (* ; "Edited  2-May-87 19:02 by Pavel")
                                                             (* ; "Tries to delete NAME from COM")
    (PROG (TEM VAR NEW)
          (COND
             ((SETQ TEM (fetch DELETE of (CAR COM)))
              (AND (SETQ TEM (APPLY* TEM COM NAME TYPE))
                   (MARKASCHANGED COMSNAME 'VARS))
              (RETURN TEM)))
          (RETURN (SELECTQ (CAR COM)
                      ((DECLARE%: COMS) 
                           (DELFROMCOMS (COND
                                               [(EQ (CADR COM)
                                                    '*)
                                                (COND
                                                   ((LITATOM (CADDR COM))
                                                    (CADDR COM))
                                                   (T (RETURN]
                                               (T (CDR COM)))
                                  NAME TYPE))
                      ((CL:EVAL-WHEN) 
                           (DELFROMCOMS (COND
                                               [(EQ (CL:THIRD COM)
                                                    '*)
                                                (COND
                                                   ((LITATOM (CL:FOURTH COM))
                                                    (CL:FOURTH COM))
                                                   (T (RETURN]
                                               (T (CDDR COM)))
                                  NAME TYPE))
                      ((ALISTS PROPS) 
                           (AND (EQ TYPE (CAR COM))
                                (COND
                                   ((EQ (CADR COM)
                                        '*)
                                    (COND
                                       ([AND (LITATOM (SETQ VAR (CADDR COM)))
                                             (SETQ TEM (ASSOC (CAR NAME)
                                                              (GETTOPVAL VAR)))
                                             (NEQ (CDR TEM)
                                                  (SETQ TEM (REMOVEITEM (CADR NAME)
                                                                   (CDR TEM]
                                        (SAVESET VAR TEM T 'NOPRINT)
                                        T)))
                                   ([AND [CDR (SETQ TEM (ASSOC (CAR NAME)
                                                               (CDR COM]
                                         (NEQ (CDR TEM)
                                              (SETQ NEW (REMOVEITEM (CADR NAME)
                                                               (CDR TEM]
                                    (/RPLACD TEM NEW)
                                    (MARKASCHANGED COMSNAME 'VARS)
                                    T))))
                      (BLOCKS 
                              (* ;; "Remove function name from blocks declarations.  This isn't entirely correctly, since in removing the name from the block variables, it will hit homonyms in globalvars, specvars, etc.")

                              [AND (EQ TYPE 'FNS)
                                   (for BLOCK in (INFILECOMTAIL COM T)
                                      do (AND (MEMB NAME BLOCK)
                                                  (/DREMOVE NAME BLOCK))
                                            (for X in BLOCK
                                               when (AND (LISTP X)
                                                             (MEMB NAME (CDR X)))
                                               do (/RPLACD X (REMOVE NAME (CDR X])
                      ((PROP IFPROP) 
                           [SELECTQ TYPE
                               (PROPS (RETURN (COND
                                                 ((EQ (CADR COM)
                                                      (CADR NAME))
                                                  (DELFROMCOM1 (CDR COM)
                                                         (CAR NAME)))
                                                 ((AND (EQMEMB (CADR NAME)
                                                              (CADR COM))
                                                       [NULL (CDR (SETQ TEM (PRETTYCOM1 (CDR COM]
                                                       (EQ (CAR TEM)
                                                           (CAR NAME)))
                                                  [/RPLACA (CDR COM)
                                                         (REMOVE (CADR NAME)
                                                                (MKLIST (CADR COM]
                                                  (MARKASCHANGED COMSNAME 'VARS)
                                                  T))))
                               (COND
                                  ([for PROP inside (CADR COM)
                                      always (EQ TYPE (GETPROP PROP 'PROPTYPE]
                                   (DELFROMCOM1 (CDR COM)
                                          NAME])
                      ((RECORDS INITRECORDS SYSRECORDS) 
                           (AND (EQ TYPE 'RECORDS)
                                (DELFROMCOM1 COM NAME)))
                      (P (AND (EQ TYPE 'EXPRESSIONS)
                              (DELFROMCOM1 COM NAME)))
                      ((VARS INITVARS) 
                           (AND (EQ TYPE 'VARS)
                                (DELFROMCOM1 COM NAME T)))
                      (AND (EQ TYPE (CAR COM))
                           (DELFROMCOM1 COM NAME])

(DELFROMCOM1
  [LAMBDA (COM NAME FLG)                                 (* rmk%: "10-JUN-82 22:44")

    (* ;; 
  "FLG is passed on to REMOVEITEM, determines whether lists whose CAR is NAME will be removed")

    (LET (TEM VAL)
         (COND
            ((EQ (CADR COM)
                 '*)
             (COND
                ([AND (LITATOM (SETQ TEM (CADDR COM)))
                      (NEQ (SETQ VAL (GETTOPVAL TEM))
                           (SETQ VAL (REMOVEITEM NAME VAL FLG]
                 (SAVESET TEM VAL T 'NOPRINT)
                 T)))
            ((NEQ (CDR COM)
                  (SETQ TEM (REMOVEITEM NAME (CDR COM)
                                   FLG)))
             (/RPLACD COM TEM)
             (MARKASCHANGED COMSNAME 'VARS)
             T])

(REMOVEITEM
  [LAMBDA (X LST FLG)                                    (* ; "Edited 25-May-88 17:52 by drc:")
                                                             (* lmm "10-FEB-78 17:29")

    (* ;; 
  "returns a subset of LST with X deleted;  if FLG is set, also remove elements whose CAR is X")

    (COND
       [[OR (MEMBER X LST)
            (AND FLG (SOME LST (FUNCTION (LAMBDA (Y)
                                           (EQUAL (CAR (LISTP Y))
                                                  X]
        (SUBSET LST (FUNCTION (LAMBDA (Y)
                                (AND (NOT (EQUAL Y X))
                                     (OR (NOT FLG)
                                         (NLISTP Y)
                                         (NOT (EQUAL (CAR Y)
                                                     X]
       (T LST])

(MOVETOFILE
  [LAMBDA (TOFILE NAME TYPE FROMFILE)                    (* rmk%: "18-OCT-79 19:51")
                                                             (* ; "To move items between files")
    (SETQ TYPE (GETFILEPKGTYPE TYPE))
    [COND
       ((OR (EQ TYPE 'FNS)
            FROMFILE)                                        (* ; 
       "FNS definition can reside on file if LOADFNS was done.  This guarantees that it is loaded.")
        (PUTDEF NAME TYPE (GETDEF NAME TYPE FROMFILE '(NOCOPY NODWIM]
    (AND (EQ TYPE 'FNS)
         (MARKASCHANGED NAME TYPE))                      (* ; 
                                                   "FNS won't get dumped unless they are `changed'")
    (DELFROMFILES NAME TYPE FROMFILE)
    (ADDTOFILE NAME TYPE TOFILE])
)

(MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)

(MOVD? 'MOVETOFILE 'MOVEITEM NIL T)

(ADDTOVAR SYSPROPS PROPTYPE VARTYPE)



(* ; "functions for doing things and marking them changed and auxiliary functions")

(DEFINEQ

(SAVEPUT
  [LAMBDA (ATM PROP VAL)                                 (* lmm " 7-May-84 16:56")

    (* ;; "analogous to SAVESET but also marks changed property lists;  LISPXFNS are marked to change PUT and PUTPROP to SAVEPUT")

    [COND
       ((NOT (LITATOM ATM))
        (ERRORX (LIST 14 ATM]
    (PROG ((X (GETPROPLIST ATM))
           X0 TEM OLDFLG)
      LOOP
          (COND
             ((NLISTP X)
              (COND
                 ((AND (NULL X)
                       X0)                                   (* ; 
                "typical case.  property list ran out on an even parity position.  e.g.  (A B C D)")
                  (SETQ TEM (LIST PROP VAL))
                  (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM)
                                        LISPXHIST))
                  (FRPLACD (CDR X0)
                         TEM)
                  (GO RET)))

              (* ;; "property list was initially NIL or a non-list, or else it ended in a non-list following an even parity position, e.g. (A B . C) fall through and add new property at beginning")

              )
             ((NLISTP (CDR X))

              (* ;; "property list runs out on an odd parity, or ends in an odd list following an odd parity, e.g.  (A B C) or (A B C . D) fall through and add at beginning.")

              )
             [(EQ (CAR X)
                  PROP)
              (SETQ OLDFLG (NEQ (EQUALN (CADR X)
                                       VAL 400)
                                T))                          (* ; "i.e. it probably changed")
              (/RPLACA (CDR X)
                     VAL)
              (COND
                 ((NOT OLDFLG)
                  (GO RET1))
                 (T (OR (EQ DFNFLG T)
                        (LISPXPRINT (LIST 'new PROP 'property 'for ATM)
                               T T))
                    (GO RET]
             (T (SETQ X (CDDR (SETQ X0 X)))
                (GO LOOP)))
          [SETQ TEM (CONS PROP (CONS VAL (GETPROPLIST ATM]
          (SETPROPLIST ATM TEM)
          (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM)
                                LISPXHIST))
      RET (MARKASCHANGED (LIST ATM PROP)
                 'PROPS
                 (NOT OLDFLG))
      RET1
          (AND ADDSPELLFLG (ADDSPELL ATM 0))
          (RETURN VAL])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
    (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT))
)
(DEFINEQ

(UNMARKASCHANGED
  [LAMBDA (NAME TYPE)                                    (* JonL "24-Jul-84 19:59")

    (* ;; "says to remove NAME from TYPE's changedlst, and also to remove it from any FILE properties.  Value is name if anything is done")

    (PROG (ANYFLG)
          (bind TAIL [CHANGED _ (fetch CHANGED of (SETQ TYPE (GETFILEPKGTYPE
                                                                          TYPE
                                                                          'TYPE]
             while (SETQ TAIL (MEMBER NAME CHANGED)) do (/RPLACA TAIL)
                                                               (SETQ ANYFLG T))
          [for F TAIL PROP TYPEDPROP in FILELST
             when [SETQ TAIL (MEMBER NAME (CDR (SETQ TYPEDPROP
                                                    (ASSOC TYPE (fetch TOBEDUMPED
                                                                   of (SETQ PROP
                                                                           (fetch FILEPROP
                                                                              of F]
             do (SETQ ANYFLG T)
                   (COND
                      ((SETQ TAIL (REMOVE (CAR TAIL)
                                         (CDR TYPEDPROP)))
                       (/RPLACD TYPEDPROP TAIL))
                      (T (/replace TOBEDUMPED of PROP with (REMOVE TYPEDPROP
                                                                              (fetch TOBEDUMPED
                                                                                 of PROP]
          (RETURN (AND ANYFLG NAME])

(PREEDITFN
  [LAMBDA (ATM TYPE EDITCHANGES)                         (* rmk%: "18-FEB-82 21:49")
                                                             (* ; 
                                           "EDITL is advised to call this before editing something")
    (AND FILEPKGFLG (SELECTQ TYPE
                        (PROPLST [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
                                                                   (CONS))
                                                            CLISPARRAY))
                                      (for X in (GETPROPLIST ATM)
                                         do (OR (NLISTP X)
                                                    (GETHASH X CLISPARRAY)
                                                    (PUTHASH X (CONS (CAR X)
                                                                     (CDR X))
                                                           CLISPARRAY]

                                 (* ;; "note that if CLISPARRAY is disabled that ALL properties of an edited prop list will get marked as changed if any destructive edit is made")

                                 [RESETSAVE NIL (LIST (FUNCTION POSTEDITPROPS)
                                                      EDITCHANGES
                                                      (APPEND (GETPROPLIST ATM])
                        (VARS [COND
                                 ((EQMEMB 'ALIST (GETPROP ATM 'VARTYPE))
                                  [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
                                                                    (CONS))
                                                             CLISPARRAY))
                                       (for X in (EVALV ATM)
                                          do (OR (NLISTP X)
                                                     (GETHASH X CLISPARRAY)
                                                     (PUTHASH X (CONS (CAR X)
                                                                      (CDR X))
                                                            CLISPARRAY]
                                  (RESETSAVE NIL (LIST (FUNCTION POSTEDITALISTS)
                                                       EDITCHANGES
                                                       (for X in (EVALV ATM)
                                                          collect (CAR X])
                        NIL])

(POSTEDITPROPS
  [LAMBDA (EDITCHANGES OLDPROPS)                         (* rmk%: "18-FEB-82 21:50")
                                                             (* ; "was RESETSAVE'd from PREEDITFN")
    (PROG (OV FOUNDCHANGE)
          (OR FILEPKGFLG (RETURN))
          (COND
             ((CADR EDITCHANGES)
              (for NEWPROP on (GETPROPLIST (CAR EDITCHANGES)) by (CDDR NEWPROP)
                 when (for OLDPROP on OLDPROPS by (CDDR OLDPROP)
                             do (COND
                                       ((EQ (CAR OLDPROP)
                                            (CAR NEWPROP))   (* ; "Found the property")
                                        [AND (EQ (CADR OLDPROP)
                                                 (CADR NEWPROP))
                                             (COND
                                                ((NLISTP (CADR OLDPROP))
                                                             (* ; "value is same")
                                                 (RETURN))
                                                ((AND CLISPARRAY (SETQ OV (GETHASH (CADR NEWPROP)
                                                                                 CLISPARRAY))
                                                      (EQ (CAADR NEWPROP)
                                                          (CAR OV))
                                                      (EQ (CDADR NEWPROP)
                                                          (CDR OV)))
                                                 (PUTHASH (CADR NEWPROP)
                                                        NIL CLISPARRAY)
                                                             (* ; 
                                         "value has been edited (CLISPARRAY translation went away)")
                                                 (RETURN]
                                        (RETURN T))) finally 
                                                             (* ; "didn't find the property")
                                                           (RETURN T))
                 do (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                 (CAR NEWPROP))
                               'PROPS NIL)
                       (SETQ FOUNDCHANGE T))
              (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
                                      NIL])

(POSTEDITALISTS
  [LAMBDA (EDITCHANGES OLDTOKENS)                        (* rmk%: " 4-JAN-82 10:14")
    (PROG [OV FOUNDCHANGE (NEWENTRIES (GETTOPVAL (CAR EDITCHANGES]
                                                             (* ; 
                                                           "called after an ALIST has been edited")
          (OR FILEPKGFLG (RETURN))
          (COND
             ((CADR EDITCHANGES)
              (for X in OLDTOKENS when (NOT (FASSOC X NEWENTRIES))
                 do (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                 X)
                               'ALISTS NIL)
                       (SETQ FOUNDCHANGE T))
              [for NEWENTRY in NEWENTRIES
                 do (COND
                           ([AND (LISTP NEWENTRY)
                                 (NOT (AND CLISPARRAY (SETQ OV (GETHASH NEWENTRY CLISPARRAY))
                                           (EQ (CAR NEWENTRY)
                                               (CAR OV))
                                           (EQ (CDR NEWENTRY)
                                               (CDR OV]
                            (PUTHASH NEWENTRY NIL CLISPARRAY)
                            (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                     (CAR NEWENTRY))
                                   'ALISTS NIL)
                            (SETQ FOUNDCHANGE T]
              (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
                                      NIL])
)

(ADDTOVAR LISPXFNS (PUT . SAVEPUT)
                       (PUTPROP . SAVEPUT))



(* ; "sub-functions for file package commands & types")

(DEFINEQ

(ALISTS.GETDEF
  [LAMBDA (NAME TYPE OPTIONS)                            (* Pavel " 7-Oct-86 17:24")
    (AND (LISTP NAME)
         (CL:SYMBOLP (CAR NAME))
         (LET [(ASSOCIATION (ASSOC (CADR NAME)
                                   (GETTOPVAL (CAR NAME]
              (AND ASSOCIATION (LIST 'ADDTOVAR (CAR NAME)
                                     ASSOCIATION])

(ALISTS.WHENCHANGED
  [LAMBDA (NAME TYPE NEWFLG)                             (* lmm "16-OCT-78 20:02")
                                                             (* ; 
                                          "called by MARKASCHANGED when an ALIST entry has changed")
    (PROG [(VARTYPE (GETPROP (CAR NAME)
                           'VARTYPE]
          (AND (LISTP VARTYPE)
               (EQ (CAR VARTYPE)
                   'ALIST)
               (RETFROM 'MARKASCHANGED (MARKASCHANGED (CADR NAME)
                                              (CADR VARTYPE)
                                              NEWFLG])

(CLEARCLISPARRAY
  [LAMBDA (NAME TYPE REASON)
    (DECLARE (SPECVARS NAME TYPE REASON))            (* lmm "14-Aug-84 15:03")
    (AND CLISPARRAY (MAPHASH CLISPARRAY (COND
                                           [(EQ TYPE 'I.S.OPRS)
                                            (FUNCTION (LAMBDA (TRAN FORM)
                                                        (AND (MEMB NAME FORM)
                                                             (PUTHASH FORM NIL CLISPARRAY]
                                           (T                (* ; "MACRO changed")
                                              (FUNCTION (LAMBDA (TRAN FORM)
                                                          (COND
                                                             ((OR (EQ NAME (CAR FORM))
                                                                  (EQ (CAR (GETPROP (CAR FORM)
                                                                                  'CLISPWORD))
                                                                      'CHANGETRAN))
                                                              (PUTHASH FORM NIL CLISPARRAY])

(EXPRESSIONS.WHENCHANGED
  [LAMBDA (EXPR)                                         (* ; "Edited  6-Apr-87 20:21 by Pavel")
    (SELECTQ (CAR EXPR)
        ((SETQ SETQQ) 
             (UNMARKASCHANGED (CADR EXPR)
                    'VARS))
        ((PROGN PROG) 
             (for X in (CDR EXPR) do (EXPRESSIONS.WHENCHANGED X)))
        NIL])

(MAKEALISTCOMS
  [NLAMBDA X                                             (* rmk%: "14-OCT-83 13:34")

    (* ;; "make command to dump prettydefmacros")

    (LIST
     (CONS 'ADDVARS
           (for PR in X
              join (for ALISTNAME inside (CAR PR)
                          collect (CONS ALISTNAME
                                            (for ATNAME inside (CDR PR) bind ENTRY
                                               when (SETQ ENTRY
                                                         (OR (SASSOC ATNAME (GETTOPVAL ALISTNAME))
                                                             (PROGN (LISPXPRINT (LIST 'no ATNAME
                                                                                      'entry
                                                                                      'on ALISTNAME)
                                                                           T T)
                                                                    NIL))) collect ENTRY])

(MAKEFILESCOMS
  [NLAMBDA FILES                                         (* JonL "12-FEB-83 19:02")

    (* ;; "This scans the command just to warn the user about any errors.  Must match up with the big SELECTQ in FILESLOAD NIL")

    [for FILE in FILES
       do
       (OR
        (LITATOM FILE)
        (while (LISTP FILE)
           do (SELECTQ (CAR (OR (LISTP FILE)
                                    (RETURN)))
                      ((LOADCOMP LOADFROM))
                      (FROM (pop FILE)
                            (if (OR (EQ (CAR FILE)
                                            'VALUEOF)
                                        (if (AND (EQ (CAR FILE)
                                                         'VALUE)
                                                     (EQ (CADR FILE)
                                                         'OF))
                                            then (pop FILE)))
                                then (pop FILE)))
                      ((COMPILED LOAD EXTENSION EXT SOURCE SYMBOLIC IMPORT NOERROR))
                      (OR (FMEMB (CAR FILE)
                                 LOADOPTIONS)
                          (PRINT (CONS (CAR FILE)
                                       '(-- unrecognized FILES option))
                                 T)))
                 (pop FILE]
    (CONS 'FILESLOAD FILES])

(MAKELISPXMACROSCOMS
  [NLAMBDA X                                             (* lmm " 5-SEP-78 23:15")
    (PROG (TEM TEM2)
          (RETURN (CONS [CONS 'ALISTS (SETQ TEM (NCONC (AND [SETQ TEM (SUBSET X
                                                                             (FUNCTION (LAMBDA (Z)
                                                                                         (FASSOC
                                                                                          Z 
                                                                                   LISPXHISTORYMACROS
                                                                                          ]
                                                            (LIST (CONS 'LISPXHISTORYMACROS TEM)))
                                                       (AND [SETQ TEM (SUBSET X
                                                                             (FUNCTION (LAMBDA (Z)
                                                                                         (FASSOC
                                                                                          Z 
                                                                                          LISPXMACROS
                                                                                          ]
                                                            (LIST (CONS 'LISPXMACROS TEM]
                        (SETQ TEM2 (NCONC [AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
                                                                                (FMEMB Z LISPXCOMS]
                                               (LIST (LIST 'ADDVARS (CONS 'LISPXCOMS TEM2]
                                          (AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
                                                                                (FMEMB Z HISTORYCOMS]
                                               (LIST (LIST 'ADDVARS (CONS 'HISTORYCOMS TEM2])

(MAKEPROPSCOMS
  [NLAMBDA X                                             (* lmm "26-FEB-78 17:10")

    (* ;; "make command to dump PROPS")

    (for PAIR in X collect (CONS 'PROP (CONS (COND
                                                            ((AND (LISTP (CDR PAIR))
                                                                  (NULL (CDDR PAIR)))
                                                             (CADR PAIR))
                                                            (T (CDR PAIR)))
                                                         (OR (LISTP (CAR PAIR))
                                                             (LIST (CAR PAIR])

(MAKEUSERMACROSCOMS
  [NLAMBDA X                                             (* rmk%: " 3-JAN-82 23:20")
    (PROG (TEM)
          [COND
             [X (for Y in X
                   do (OR (FASSOC Y USERMACROS)
                              (FASSOC Y EDITMACROS)
                              (LISPXPRINT (CONS Y '(-- no entry on USERMACROS))
                                     T T]
             (T (SETQ X (INTERSECTION (SETQ X (MAPCAR USERMACROS 'CAR))
                               X]
          (RETURN (LIST (CONS 'ADDVARS
                              (NCONC (for VAR in '(USERMACROS EDITMACROS)
                                        when (SETQ TEM (for Y in (GETTOPVAL VAR)
                                                              when (FMEMB (CAR Y)
                                                                              X) collect Y))
                                        collect (CONS VAR TEM))
                                     (for LST in '(EDITCOMSA EDITCOMSL COMPACTHISTORYCOMS 
                                                                 DONTSAVEHISTORYCOMS)
                                        when [SETQ TEM
                                                  (SUBSET (GETTOPVAL LST)
                                                         (FUNCTION (LAMBDA (Y)
                                                                     (OR (FMEMB Y X)
                                                                         (AND (LISTP Y)
                                                                              (FMEMB (CAR Y)
                                                                                     X]
                                        collect (CONS LST TEM])

(PROPS.WHENCHANGED
  [LAMBDA (NAME TYPE NEWFLG)                             (* lmm " 7-SEP-78 22:08")
    (PROG [(PROPTYPE (GETPROP (CADR NAME)
                            'PROPTYPE]
          (COND
             [PROPTYPE (RETFROM 'MARKASCHANGED (COND
                                                  ((NEQ PROPTYPE 'IGNORE)
                                                   (MARKASCHANGED (CAR NAME)
                                                          PROPTYPE NEWFLG]
             (T (SELECTQ (CADR NAME)
                    (CLISPWORD (CLEARCLISPARRAY (CAR NAME)))
                    NIL])

(FILEGETDEF.LISPXMACROS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:12")
    (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                              (AND (EQ FIRST 'ADDTOVAR)
                                                                   (MEMB SECOND '(LISPXMACROS 
                                                                                        LISPXCOMS))
                                                                   T]
                when (SELECTQ (CADR X)
                             (LISPXMACROS                    (* ; 
                      "Rebuild the expressions cause there might be other elements in the ADDTOVAR")
                                          (AND (SETQ X (ASSOC NAME (CDDR X)))
                                               (SETQ X (LIST 'ADDTOVAR 'LISPXMACROS X))))
                             (LISPXCOMS [COND
                                           ((MEMB NAME (CDDR X))
                                            (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS NAME)))
                                           ((SETQ X (ASSOC NAME (CDDR X)))
                                                             (* ; "For synonym pairs")
                                            (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS X])
                             NIL) collect X])

(FILEGETDEF.ALISTS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:13")
    (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                     (AND (EQ FIRST 'ADDTOVAR)
                                                          (EQ SECOND (CAR NAME]
       when (SETQ X (ASSOC (CADR NAME)
                               (CDDR X))) collect X
       finally (RETURN (COND
                              ($$VAL (CONS 'ADDTOVAR (CONS (CAR NAME)
                                                           $$VAL])

(FILEGETDEF.RECORDS
  [LAMBDA (NAME TYPE SOURCE OPTIONS NOTFOUND)            (* lmm "26-Jun-86 15:56")
    (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                              (AND (MEMB FIRST CLISPRECORDTYPES)
                                                   (OR (EQ SECOND NAME)
                                                       (AND (MEMB SECOND '(%( %[))
                                                            (PROGN (RATOM)
                                                                   (RATOM)
                                                                   (RATOM)
                                                                   (EQ NAME (RATOM]
         (if (EQ (CAAR VAL)
                     'NOT-FOUND%:)
             then NOTFOUND
           elseif (CDR VAL)
             then (CONS 'PROGN VAL)
           else (CAR VAL])

(FILEGETDEF.PROPS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:13")
    (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                     (AND (EQ FIRST 'PUTPROPS)
                                                          (EQ SECOND (CAR NAME]
       join (for TAIL on (CDDR X) by (CDDR TAIL) when (EQ (CAR TAIL)
                                                                              (CADR NAME))
                   join (LIST (CAR TAIL)
                                  (CADR TAIL)))
       finally (RETURN (COND
                              ($$VAL (CONS 'PUTPROPS (CONS (CAR NAME)
                                                           $$VAL])

(FILEGETDEF.MACROS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm "28-May-86 09:51")
    (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                              (AND (FMEMB FIRST '(PUTPROPS DEFMACRO))
                                                                   (EQ SECOND NAME]
                join (if (EQ (CAR X)
                                     'DEFMACRO)
                             then (LIST X)
                           else (for TAIL on (CDDR X) by (CDDR TAIL)
                                       when (FMEMB (CAR TAIL)
                                                       MACROPROPS) collect (LIST 'PUTPROPS
                                                                                     (CADR X)
                                                                                     (CAR TAIL)
                                                                                     (CADR TAIL])

(FILEGETDEF.VARS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:14")
    (for X in (LOADFNS NIL SOURCE 'GETDEF NAME)
       do (SELECTQ (CAR X)
                  ((RPAQQ SETQQ) 
                       (RETURN (CADDR X)))
                  ((RPAQ SETQ RPAQ?) 
                       (RETURN (EVAL (CADDR X))))
                  NIL) finally (RETURN 'NOBIND])

(FILEGETDEF.FNS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* bvm%: "29-Aug-86 22:30")
    (LET (MAP ENV)
         (COND
            [(AND (EQMEMB 'FAST OPTIONS)
                  (PROGN (CL:MULTIPLE-VALUE-SETQ (ENV MAP)
                                (GET-ENVIRONMENT-AND-FILEMAP SOURCE))
                         MAP))
             (for PAIR MAPLOC in (CDR MAP) when [SETQ MAPLOC (CADR (ASSOC NAME
                                                                                      (CDDR PAIR]
                do [OR (OPENP SOURCE)
                           (RESETSAVE NIL (LIST 'CLOSEF? (SETQ SOURCE (OPENSTREAM SOURCE 'INPUT
                                                                             'OLD]
                      (SETFILEPTR SOURCE MAPLOC)
                      (RETURN (WITH-READER-ENVIRONMENT ENV
                                  [COND
                                     ((EQMEMB 'ARGLIST OPTIONS)
                                      (RATOM SOURCE)
                                      (READ SOURCE)
                                      (RATOM SOURCE)
                                      (LIST (READ SOURCE)
                                            (READ SOURCE)))
                                     (T (CADR (READ SOURCE])]
            (T (CADR (FASSOC NAME (LOADEFS NAME SOURCE])

(FILEPKGCOMS.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "15-Jul-85 11:29")
    (PROG (COM TYP)
          [SELECTQ (CAR (LISTP DEFINITION))
              (COM (SETQ COM (CDR DEFINITION)))
              (TYPE (SETQ TYP (CDR DEFINITION)))
              (PROGN (SETQ COM (CDR (ASSOC 'COM DEFINITION)))
                     (SETQ TYP (CDR (ASSOC 'TYPE DEFINITION]

     (* ;; "Check properties first, so that we don't smash some and then get an error in a later call to FILEPKGCOM/TYPE")

          (for I in COM by (CDDR I) do (SELECTQ I
                                                           ((ADD DELETE MACRO CONTENTS CONTAIN COM))
                                                           (ERROR I 
                                                                  "not file package command property"
                                                                  )))
                                                             (* ; 
                                                   "COM merely adds to spelling list, for builtins")
          [FILEPKGCOM NAME 'CONTENTS (OR (LISTGET COM 'CONTENTS)
                                             (LISTGET COM 'CONTAIN]
                                                             (* ; "Until CONTAIN is de-documented.")
          (for PROP in '(ADD DELETE MACRO COM) do (FILEPKGCOM NAME PROP
                                                                         (LISTGET COM PROP)))
          [for I in TYP by (CDDR I) do (OR (FMEMB I FILEPKGTYPEPROPS)
                                                           (SELECTQ I
                                                               ((DESCRIPTION TYPE))
                                                               (ERROR I 
                                                             "not file package type/command property"
                                                                      ]
                                                             (* ; 
                                                  "TYPE merely adds to spelling list, for builtins")
          (for PROP in (UNION '(DESCRIPTION TYPE)
                                      FILEPKGTYPEPROPS) do (FILEPKGTYPE NAME PROP
                                                                      (LISTGET TYP PROP])

(FILES.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "15-Jul-85 17:13")
    (PROGN (PUTDEF (FILECOMS NAME)
                  'VARS
                  (CAR DEFINITION)
                  REASON)                                    (* ; "DEFINE THE COMS")
           (ADDFILE NAME)                                (* ; 
                                                           "MAKE SURE IT IS A FILE PACKAGE ENTITY")
           [/replace TOBEDUMPED of (fetch FILEPROP of NAME)
                                          (FILEPKG.MERGECHANGES (CADR DEFINITION)
                                                 (fetch TOBEDUMPED of (fetch FILEPROP
                                                                                 of NAME]
           (OR (fetch FILEDATES of NAME)
               (/replace FILEDATES of NAME with (CADDR DEFINITION])

(VARS.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "29-Jul-85 20:59")
    (/SETTOPVAL NAME DEFINITION T])

(FILES.WHENCHANGED
  [LAMBDA (NAME TYPE REASON)
    (MARKASCHANGED (FILECOMS NAME)
           'VARS REASON])
)

(ADDTOVAR MACROPROPS MACRO BYTEMACRO DMACRO)

(ADDTOVAR SYSPROPS PROPTYPE)

(PUTPROPS I.S.OPR PROPTYPE I.S.OPRS)

(PUTPROPS SUBR PROPTYPE IGNORE)

(PUTPROPS LIST PROPTYPE IGNORE)

(PUTPROPS CODE PROPTYPE IGNORE)

(PUTPROPS FILEDATES PROPTYPE IGNORE)

(PUTPROPS FILE PROPTYPE IGNORE)

(PUTPROPS FILEMAP PROPTYPE IGNORE)

(PUTPROPS EXPR PROPTYPE FNS)

(PUTPROPS VALUE PROPTYPE VARS)

(PUTPROPS COPYRIGHT PROPTYPE FILES)

(PUTPROPS FILETYPE PROPTYPE FILES)

(PUTPROPS BAKTRACELST VARTYPE ALIST)

(PUTPROPS BREAKMACROS VARTYPE ALIST)

(PUTPROPS COMPILETYPELST VARTYPE ALIST)

(PUTPROPS EDITMACROS VARTYPE (ALIST USERMACROS))

(PUTPROPS ERRORTYPELST VARTYPE ALIST)

(PUTPROPS FONTDEFS VARTYPE ALIST)

(PUTPROPS LISPXHISTORYMACROS VARTYPE (ALIST LISPXMACROS))

(PUTPROPS LISPXMACROS VARTYPE (ALIST LISPXMACROS))

(PUTPROPS PRETTYDEFMACROS VARTYPE (ALIST FILEPKGCOMS))

(PUTPROPS PRETTYEQUIVLST VARTYPE ALIST)

(PUTPROPS PRETTYPRINTMACROS VARTYPE ALIST)

(PUTPROPS PRETTYPRINTYPEMACROS VARTYPE ALIST)

(PUTPROPS USERMACROS VARTYPE (ALIST USERMACROS))



(* ; "Define the commands below AFTER the various properties have been established.")


(ADDTOVAR USERMACROS
          (M NIL (MAKE FILE FILE))
          (M (X . Y)
             (E (MARKASCHANGED (COND ((LISTP 'X)
                                      (CAR 'X))
                                     (T 'X))
                       'USERMACROS)
                T)
             (ORIGINAL (M X . Y))))

(ADDTOVAR EDITMACROS
          (M (X . Y)
             (E (MARKASCHANGED (COND ((LISTP 'X)
                                      (CAR 'X))
                                     (T 'X))
                       'USERMACROS)
                T)
             (ORIGINAL (M X . Y))))

(ADDTOVAR EDITCOMSA M)

(ADDTOVAR EDITCOMSL M)



(* ; "GETDEF methods")

(DEFINEQ

(RENAME
  [LAMBDA (OLD NEW TYPES FILES METHOD)               (* JonL "24-Jul-84 20:01")
    (PROG ((TYPES (GETFILEPKGTYPE TYPES 'TYPE NIL OLD)))

     (* ;; "special kludge: change the callers BEFORE if we are changing a field;  this is so the CHANGECALLERS won't get an UNABLE TO DWIMIFY message")

          [for TYPE inside TYPES when (NEQ TYPE 'FIELDS)
             do (COPYDEF OLD NEW TYPE NIL (COND
                                                     ((EQ TYPE 'VARS)
                                                      'NOERROR]
          (CHANGECALLERS OLD NEW TYPES FILES METHOD)
          [for TYPE inside TYPES do (COND
                                                   ((AND (EQ TYPE 'FIELDS)
                                                         (HASDEF OLD 'FIELDS))

                                 (* ;; "The HASDEF test is because the rename might already have been done in EDITFROMFILE in the CHANGECALLERS, if it found a record with the field on a file.  Otherwise, COPYDEF essentially will just do the necessary substitution in the existing record declarations, given that definitions for FIELDS are mutually exclusive.")

                                                    (COPYDEF OLD NEW 'FIELDS))
                                                   (T (DELDEF OLD TYPE]
          (RETURN NEW])

(CHANGECALLERS
  [LAMBDA (OLD NEW AS-TYPES FILES METHOD)            (* ; "Edited  6-Dec-86 01:25 by lmm")
    (PROG ((AS-TYPES (GETFILEPKGTYPE AS-TYPES))
           REL TEM EDITCOMS FNS)
          (OR METHOD (SETQ METHOD DEFAULTRENAMEMETHOD))
          [SETQ EDITCOMS
           (LIST (COND
                    [(OR (EQMEMB 'CAREFUL METHOD)
                         (PROGN (SETQ TEM (TYPESOF OLD NIL AS-TYPES))
                                (printout T "Warning --" OLD " is also defined as " TEM T)))

                     (* ;; "This creates a `command' that searches like EXAM, but interrogates the user about whether to do the Rename.  Y means do it, No means skip, anything else goes into TTY.")

                     (SUBPAIR '(OLD NEW)
                            (LIST OLD NEW)
                            '(BIND (LPQ (F OLD N)
                                            (MARK %#1)
                                            (ORR (1 !0 P)
                                                 NIL)
                                            (MARK %#2)
                                            (COMS (SELECTQ (ASKUSER NIL NIL "   Replace ? "
                                                                  '((Y "Yes
")
                                                                    (N "No
")
                                                                    (%
 "")
                                                                    (%  "")
                                                                    (%
 "")
                                                                    (& ""))
                                                                  NIL NIL '(NOECHOFLG T))
                                                      (Y '(R1 OLD NEW))
                                                      (N NIL)
                                                      'TTY%:))
                                            (MARK %#3)
                                            (IF (EQ (%## (\ %#3))
                                                        (%## (\ %#2)))
                                                   ((\ %#1))
                                                   NIL]
                    (T (LIST 'R OLD NEW]
          (SELECTQ (COND
                      ((AND (EQMEMB 'MASTERSCOPE METHOD)
                            MSDATABASELST
                            (for TYPE inside AS-TYPES
                               do [COND
                                         ((SETQ TEM (SELECTQ TYPE
                                                        ((FNS FUNCTIONS SPECIAL-FORMS OPTIMIZERS) 
                                                             'CALL)
                                                        (MACROS '(CALL DIRECTLY))
                                                        ((VARS VARIABLES) 
                                                             '(USE OR BIND))
                                                        ((RECORDS FIELDS I.S.OPRS) 
                                                             (LIST 'USE 'AS TYPE))
                                                        (RETURN NIL)))
                                          (COND
                                             (REL (SETQ REL (LIST TEM 'OR REL)))
                                             (T (SETQ REL TEM] FINALLY (RETURN REL)))

                       (* ;; "can only use masterscope if (a) we say to, (b) something's been analyzed, and (c) the types the function is are known")

                       'MASTERSCOPE)
                      ((EQMEMB 'EDITCALLERS METHOD)
                       'EDITCALLERS)
                      (T 'SEARCH))
              (MASTERSCOPE (MAPC [SETQ FNS (NCONC [COND
                                                     ((NULL FILES)
                                                      (UPDATEFILES)
                                                      (FILEPKGCHANGES 'FNS]
                                                  (for FILE inside (OR FILES FILELST)
                                                     join (FILEFNSLST FILE]
                                 (FUNCTION UPDATEFN))
                           (SETQ FNS (INTERSECTION (GETRELATION OLD (SETQ REL (PARSERELATION REL))
                                                          T)
                                            FNS)))
              (EDITCALLERS (SETQ FILES (for X inside (OR FILES FILELST)
                                          when (SETQ TEM (EDITCALLERS OLD X T))
                                          collect (PROGN (SETQ FNS (NCONC FNS (CDR TEM)))
                                                             X))))
              (SEARCH (SETQ FNS (for X inside (OR FILES FILELST) join (FILEFNSLST
                                                                                   X))))
              (ERROR "UNRECOGNIZED RENAME METHOD" METHOD))
          (AND (EQMEMB 'FNS AS-TYPES)
               (FMEMB OLD FNS)
               (SETQ FNS (REMOVE OLD FNS)))
          (EDITFROMFILE FNS FILES OLD EDITCOMS)
          [for TYPE inside AS-TYPES
             do (for FILE in (WHEREIS OLD TYPE FILES)
                       do (AND (ADDTOFILE NEW TYPE FILE)
                                   (DELFROMFILES OLD TYPE FILE)
                                   (printout T OLD " changed to " NEW " on " FILE)))
                   (COND
                      ((SETQ TEM (WHEREIS OLD TYPE FILES))
                       (printout T "Couldn't change " OLD " to " NEW " as " TYPE " on " TEM]
          (COND
             (REL (UPDATECHANGED)
                  (COND
                     ((AND (SETQ TEM (GETRELATION OLD REL T))
                           (WHEREIS TEM 'FNS FILES))
                      (printout T "Couldn't find where " OLD " is referenced in " TEM T])
)
(DEFINEQ

(SHOWDEF
  [LAMBDA (NAME TYPE FILE)                              (* ; "Edited 16-Apr-2018 21:35 by rmk:")
                                                             (* ; 
                                                 "prettyprint NAME as it would be dumped as a TYPE")
    (RESETLST
        (PROG (ORIGFLG FNSLST FL PRETTYCOMSLST NEWFILEMAP)
              (DECLARE (SPECVARS . T))
              [AND FILE (NEQ FILE (OUTPUT))
                   (if (SETQ FL (OPENP FILE 'OUTPUT))
                       then (RESETSAVE (OUTPUT FL))
                     else (OUTFILE FILE)
                           (RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                                (OUTPUT]
              (PRETTYCOM (MAKENEWCOM NAME TYPE))))])

(COPYDEF
  [LAMBDA (OLD NEW TYPE SOURCE OPTIONS)              (* lmm "14-Aug-84 18:38")
                                                             (* ; "like MOVD, but takes a type.")
    (PROG (TEM DEF)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
          [SETQ DEF (GETDEF OLD TYPE SOURCE (COND
                                                   ((EQ OPTIONS 'NOCOPY)
                                                    NIL)
                                                   (T (REMOVE 'NOCOPY (MKLIST OPTIONS]
                                                             (* ; 
      "The default is for GETDEF to return a COPY.  Make sure that NOCOPY isn't in options though.")
          (SELECTQ TYPE
              (VARS)
              (FILES [for X in (CAR DEF)
                        do                               (* ; 
                                          "change all the listnames which are of form filenameTYPE")
                              (SELECTQ (CAR X)
                                  ((PROP IFPROP) 
                                       (SETQ X (CDR X)))
                                  NIL)
                              (COND
                                 ((EQ (CADR X)
                                      '*)
                                  (SETQ X (CDDR X))
                                  (COND
                                     ((AND (LITATOM (CAR X))
                                           (SETQ TEM (STRPOS OLD (CAR X)
                                                            1 NIL T T)))
                                      (SAVESET (SETQ TEM (PACK* NEW (SUBATOM (CAR X)
                                                                           TEM -1)))
                                             (COPY (GETTOPVAL (CAR X)))
                                             T)
                                      (FRPLACA X TEM])
              ((PROPS ALISTS) 
                   (OR (EQ (CAR NEW)
                           (CAR OLD))
                       (DSUBST (CAR NEW)
                              (CAR OLD)
                              DEF))
                   (OR (EQ (CADR NEW)
                           (CADR OLD))
                       (DSUBST (CADR NEW)
                              (CADR OLD)
                              DEF)))
              (DSUBST NEW OLD DEF))
          (PUTDEF NEW TYPE DEF)
          (RETURN NEW])

(GETDEF
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm "13-Jul-85 04:10")

    (* ;; "returns the definition of NAME as a TYPE from SOURCE;  cause ERROR if not found unless OPTIONS is NOERROR --- usually returns a copy unless OPTIONS is NOCOPY in which case it tries not to return a copy --- FLG=NOCOPY is currently only used from SAVEDEF where SOURCE is always 0 --- If options is or contains a string, returns that string instead of causing error if no def found.  The caller can figure out what happened, even for types for which NIL/NOBIND might have defs.")

    (PROG (DEF TEM (NOCOPY (EQMEMB 'NOCOPY OPTIONS)))
          (DECLARE (SPECVARS NOCOPY))
          (SELECTQ OPTIONS
              (0 (SETQQ OPTIONS (NOERROR NODWIM))
                 (SETQ NOCOPY T))
              (1 (SETQQ OPTIONS (NOERROR NODWIM FAST ARGLIST))
                 (SETQ NOCOPY T))
              (T (SETQQ OPTIONS SPELL))
              NIL)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
          (SELECTQ SOURCE
              (0 (SETQQ SOURCE CURRENT))
              (T (SETQQ SOURCE SAVED))
              (NIL (SETQQ SOURCE ?))
              NIL)
          [SELECTQ SOURCE
              (CURRENT (SETQ DEF (GETDEFCURRENT NAME TYPE OPTIONS)))
              (? [LET [(NOERROR (CONS 'NOERROR (MKLIST OPTIONS]
                      (OR (NEQ (SETQ DEF (GETDEFCURRENT NAME TYPE NOERROR))
                               (fetch NULLDEF of TYPE))
                          (NEQ (SETQ DEF (GETDEFSAVED NAME TYPE NOERROR))
                               (fetch NULLDEF of TYPE))
                          (SETQ DEF (GETDEFFROMFILE NAME TYPE 'FILE OPTIONS])
              (SAVED (SETQ DEF (GETDEFSAVED NAME TYPE OPTIONS)))
              (COND
                 ((AND (LISTP SOURCE)
                       (EQ (CAR SOURCE)
                           '=))
                  (SETQ DEF (CDR SOURCE)))
                 (T (SETQ DEF (GETDEFFROMFILE NAME TYPE SOURCE OPTIONS))
                    (SETQ NOCOPY T]
          (OR NOCOPY (SETQ DEF (COPY DEF)))
          (COND
             ((AND (EQ TYPE 'FNS)
                   (NOT (EQMEMB 'NODWIM OPTIONS)))
              (DWIMDEF DEF NAME SOURCE)))
          (RETURN DEF])

(GETDEFCOM
  [LAMBDA (X)                                            (* lmm " 4-Jul-85 13:31")

    (* ;; "In the case where GETDEF doesn't know how to get the definition of something, it resorts to asking the file package to print it out to a file and then reading the file back in.  Actually, though, that is a two stage process where the `command' to print out the datum is first macro expanded and then executed.  --- In some cases, you can tell what would be printed without printing it by looking at the prettydef-macro expansion.  That is what GETDEFCOM does: it takes a list of prettydef commands and returns what Would be printed by those commands (or NIL if it is `too hard' to figure out.) --- A few of the commands are special-cased inside GETDEFCOM0 because they occur frequently or are simple.")
                                                             (* ; "a RETFROM point")
    (for Y in X join (GETDEFCOM0 Y])

(GETDEFCOM0
  [LAMBDA (COM)                                          (* wt%: " 7-FEB-79 23:28")
    (PROG (TEM)
          (RETURN (COND
                     ((SETQ TEM (fetch MACRO of (CAR COM)))
                                                             (* COND ((fetch CONTENTS of
                                                           (CAR COM)) (* ; 
                        "if it has a CONTENTS function, generally means it is not safe to evaluate")
                                                           (RETFROM (QUOTE GETDEFCOM))))
                      (for Y in (SUBPAIR (CAR TEM)
                                               (PRETTYCOM1 COM)
                                               (CDR TEM)) join (GETDEFCOM0 Y)))
                     (T (SELECTQ (CAR COM)
                            (COMS (for X in (PRETTYCOM1 COM) join (GETDEFCOM0 X)))
                            (ADDVARS (for Y in (PRETTYCOM1 COM)
                                        collect (CONS 'ADDTOVAR Y)))
                            (APPENDVARS (for Y in (PRETTYCOM1 COM)
                                           collect (CONS 'APPENDTOVAR Y)))
                            (P (APPEND (PRETTYCOM1 COM)))
                            (RETFROM 'GETDEFCOM])

(GETDEFCURRENT
  [LAMBDA (NAME TYPE OPTIONS)                            (* ; "Edited  2-May-87 19:00 by Pavel")
                                                             (* ; 
                                                           "Gets the current definition--source=0")
    (LET
     (DEF)
     (COND
        ((AND (SETQ DEF (fetch GETDEF of TYPE))
              (NEQ DEF T))

         (* ;; "We assign T to types whose GETDEF is normally handled in the SELECTQ below but whose MACRO is to be defaulted to the PUTDEF/GETDEF in PRETTYCOM.")

         (OR (NEQ (SETQ DEF (APPLY* DEF NAME TYPE OPTIONS))
                  (fetch NULLDEF of TYPE))
             (GETDEFERR NAME TYPE OPTIONS))
         DEF)
        (T
         (OR
          (NEQ
           [SETQ DEF
            (SELECTQ TYPE
                (FNS (AND (LITATOM NAME)
                          (EXPRP (SETQ DEF (VIRGINFN NAME)))
                          DEF))
                (VARS (if (LITATOM NAME)
                          then (GETTOPVAL NAME)
                        else 'NOBIND))
                ((FIELDS RECORDS) 
                     (if (LITATOM NAME)
                         then [SETQ DEF (SELECTQ TYPE
                                                (RECORDS (RECLOOK NAME))
                                                (MKPROGN (FIELDLOOK NAME]
                               (if (EQMEMB 'EDIT OPTIONS)
                                   then (COPY DEF)
                                 else DEF)))
                (FILES                                       (* ; 
              "what is the `definition' of a file?  -- I guess the COMS which say what it contains")
                       [if (LITATOM NAME)
                           then (if (SETQ DEF (GETFILEDEF NAME))
                                        then (UPDATEFILES)
                                              (LIST (LISTP (GETTOPVAL (FILECOMS DEF)))
                                                    (fetch TOBEDUMPED
                                                       of (fetch FILEPROP of DEF))
                                                    (LISTP (fetch FILEDATES of DEF])
                (TEMPLATES (if (AND (LITATOM NAME)
                                        (SETQ DEF (GETTEMPLATE NAME)))
                               then (LIST 'SETTEMPLATE (KWOTE NAME)
                                              (KWOTE DEF))))
                (MACROS [if [AND (LITATOM NAME)
                                     (SETQ DEF (for X on (GETPROPLIST NAME)
                                                  by (CDDR X) when (FMEMB (CAR X)
                                                                                  MACROPROPS)
                                                  join (LIST (CAR X)
                                                                 (CADR X]
                            then `(PUTPROPS ,NAME ,@DEF])
                (EXPRESSIONS (LISTP NAME))
                (PROPS [AND (LISTP NAME)
                            (AND (SETQ DEF (SOME (GETPROPLIST (CAR NAME))
                                                 [FUNCTION (LAMBDA (X)
                                                             (EQ X (CADR NAME]
                                                 (FUNCTION CDDR)))
                                 (LIST 'PUTPROPS (CAR NAME)
                                       (CADR NAME)
                                       (CADR DEF])
                (FILEPKGCOMS [AND (LITATOM NAME)
                                  (PROG ((COM (FILEPKGCOM NAME))
                                         (TYP (FILEPKGTYPE NAME)))
                                        (RETURN (COND
                                                   ((AND COM TYP)
                                                    (LIST (CONS 'COM COM)
                                                          (CONS 'TYPE TYP)))
                                                   (COM (LIST (CONS 'COM COM)))
                                                   (TYP (LIST (CONS 'TYPE TYP])
                (FILEVARS (COND
                             ((AND (LITATOM NAME)
                                   (LISTP (SETQ DEF (GETTOPVAL NAME)))
                                   (WHEREIS NAME 'FILEVARS))
                              DEF)
                             (T 'NOBIND)))
                (LET
                 ((COMS (LIST (MAKENEWCOM NAME TYPE)))
                  FILE)
                 [COND
                    ((NOT (SETQ DEF (GETDEFCOM COMS)))
                     (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT*
                         (RESETLST
                             (RESETSAVE PRETTYFLG)
                             (RESETSAVE FONTCHANGEFLG)
                             [RESETSAVE (OUTPUT (SETQ FILE (OPENSTREAM '{NODIRCORE} 'BOTH]
                             (PRETTYDEFCOMS COMS)
                             (SETFILEPTR FILE 0)
                             [SETQ DEF
                              (for X in (READFILE FILE)
                                 join
                                 (SELECTQ (CAR X)
                                     ((*) 
                                          NIL)
                                     (DECLARE%: (for Y on (CDR X)
                                                   unless (SELECTQ (CAR Y)
                                                                  ((COPYWHEN EVAL@LOADWHEN 
                                                                          EVAL@COMPILEWHEN) 
                                                                       (RETURN (LIST Y)))
                                                                  (FMEMB (CAR Y)
                                                                         DECLARETAGSLST))
                                                   collect (CAR Y)))
                                     (CL:EVAL-WHEN (CDDR X))
                                     (PROGN (CDR X))
                                     (LIST X]
                             (SETQ NOCOPY T)))]
                 (MKPROGN DEF]
           (fetch NULLDEF of TYPE))
          (GETDEFERR NAME TYPE OPTIONS))
         DEF])

(GETDEFERR
  [LAMBDA (NAME TYPE OPTIONS MSG)                        (* lmm "13-Jul-85 04:11")
    (DECLARE (USEDFREE NODEF))                           (* ; 
                                       "Message non-null if looking for saved or filed definition.")
    (PROG (TEM)
          (RETURN (COND
                     ((EQMEMB 'NOERROR OPTIONS)              (* ; 
                                               "We want to do the string search in the HASDEF case")
                      (RETURN (fetch NULLDEF of TYPE)))
                     [(AND (NULL MSG)
                           (EQMEMB 'SPELL OPTIONS)
                           (SETQ TEM (HASDEF NAME TYPE NIL (OR (LISTGET1 (LISTP OPTIONS)
                                                                          'SPELL)
                                                                   T)))
                           (NEQ TEM NAME))
                      (RETFROM 'GETDEF (GETDEF TEM TYPE '? (CONS 'NOERROR (MKLIST OPTIONS]
                     (T (for O inside OPTIONS when (STRINGP O)
                           do (RETFROM 'GETDEF O)
                           finally (ERROR NAME (CONS TYPE '(definition not found))
                                              T])

(GETDEFFROMFILE
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* bvm%: " 1-Oct-86 22:10")

    (* ;; "Tries to get definition from source file.  If successful, returns the definition.  Otherwise returns the NULLDEF of the type if OPTIONS contains NOERROR.")

    (DECLARE (SPECVARS NAME))
    (bind (NOTFOUND _ "not found")
           DEF SOURCE TEM2 for FILE inside (COND
                                                      ((EQ SOURCE 'FILE)
                                                       (WHEREIS NAME TYPE T))
                                                      (T SOURCE))
       when
       (AND
        (SETQ SOURCE (FINDFILE FILE T))
        (NEQ
         [SETQ DEF
          (COND
             ((SETQ TEM2 (fetch FILEGETDEF of TYPE))
              (APPLY* TEM2 NAME TYPE SOURCE OPTIONS NOTFOUND))
             (T
              (SELECTQ TYPE
                  (FNS (FILEGETDEF.FNS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  ((VARS FILEVARS) 
                       (FILEGETDEF.VARS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (MACROS (FILEGETDEF.MACROS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (PROPS (FILEGETDEF.PROPS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (RECORDS (FILEGETDEF.RECORDS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (ALISTS (FILEGETDEF.ALISTS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (LISPXMACROS (FILEGETDEF.LISPXMACROS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (COND
                     [(SETQ DEF (GET TYPE 'DEFINERS))
                      (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF
                                        `(LAMBDA (FIRST SECOND)
                                           (AND (MEMB FIRST ',DEF)
                                                (OR (EQ SECOND NAME)
                                                    (AND (MEMB SECOND '(%( %[))
                                                         (PROGN (RATOM)
                                                                (RATOM)
                                                                (RATOM)
                                                                (EQ NAME (RATOM]
                                                             (* ; "ick!  Should use real closure")
                           (if (EQ (CAAR VAL)
                                       'NOT-FOUND)
                               then NOTFOUND
                             elseif (CDR VAL)
                               then (CONS 'PROGN VAL)
                             else (CAR VAL]
                     (T (RESETLST
                            (RESETSAVE (RESETUNDO))
                            [LET (LOAD-VERBOSE-STREAM)
                                 (DECLARE (SPECVARS LOAD-VERBOSE-STREAM))
                                                             (* ; 
                                                     "just in case we get a PRETTYCOMPRINT in here")
                                 (LOADFNS NIL SOURCE 'PROP (COND
                                                              ((LITATOM NAME)
                                                             (* ; 
                                         "If an atom, only bother with expressions that contain it")
                                                               (CONS (LIST '& '|..| NAME)))
                                                              (T T]
                            (GETDEFCURRENT NAME TYPE (CONS 'NOERROR (MKLIST OPTIONS))))]
         NOTFOUND)) do (AND (EQ SOURCE 'FILE)
                                (OR (FMEMB FILE FILELST)
                                    (CL:FORMAT T "(from ~A)~%%" SOURCE))) 
                                                             (* ; 
                                                        "Copying and dwimifying are done in GETDEF")
                          (RETURN DEF) finally (RETURN (GETDEFERR NAME TYPE OPTIONS
                                                                  (APPEND '(no definition on)
                                                                         (MKLIST SOURCE])

(GETDEFSAVED
  [LAMBDA (NAME TYPE OPTIONS)                          (* ; "Edited 11-Aug-87 18:14 by cutting")
                                                             (* ; 
                                                           "Gets the `saved' definition--source=T")
    (SELECTQ TYPE
        (FNS (OR (GETPROP NAME 'EXPR)
                 (GETDEFERR NAME TYPE OPTIONS "no saved definition for")))
        (VARS                                                (* ; 
                               "The value of a variable is never substituted into and never COPIED")
              (for X on (GETPROPLIST NAME) by (CDDR X) when (EQ (CAR X)
                                                                                'VALUE)
                 do (RETURN (CADR X)) finally (RETURN (GETDEFERR NAME TYPE OPTIONS 
                                                                     "no saved value for "))))
        (OR (CDR (SASSOC NAME (FASSOC TYPE SAVEDDEFS)))
            (GETDEFERR NAME TYPE OPTIONS "no saved definition for "])

(PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* ; "Edited  8-Apr-87 12:52 by Pavel")
    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (LET ((PUTDEF.METHOD (fetch PUTDEF of TYPE)))
         (COND
            (PUTDEF.METHOD (APPLY* PUTDEF.METHOD NAME TYPE DEFINITION REASON))
            (T (SELECTQ TYPE
                   (FNS (FNS.PUTDEF NAME TYPE DEFINITION REASON))
                   (VARS (VARS.PUTDEF NAME TYPE DEFINITION REASON))
                   (FILES (FILES.PUTDEF NAME TYPE DEFINITION REASON))
                   (FILEPKGCOMS (FILEPKGCOMS.PUTDEF NAME TYPE DEFINITION REASON))
                   (EVAL DEFINITION))
               NAME])

(EDITDEF
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)
    (DECLARE (LOCALVARS . T)
           (SPECVARS SOURCE))                          (* ; "Edited 27-Jul-87 11:04 by cutting")

    (* ;; "lets you edit anything.  Given name and type, call editor on the definition (loading it in from SOURCE if necessary).  If you change it, then the definition gets unsaved.  OPTIONS is passed through from ED to the editor.")

    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (COND
       ((AND (fetch EDITDEF of TYPE)
             (APPLY* (fetch EDITDEF of TYPE)
                    NAME TYPE SOURCE EDITCOMS OPTIONS)))
       ((AND (EQ TYPE 'FNS)
             (NULL SOURCE))                                  (* ; 
                                "special hack for EDITDEF of FNS because of ability to EDITLOADFNS")
        (EDITDEF.FNS NAME EDITCOMS OPTIONS))
       (T (DEFAULT.EDITDEF NAME TYPE SOURCE EDITCOMS OPTIONS)))
    NAME])

(DEFAULT.EDITDEF
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)            (* ; "Edited 11-Jun-92 16:26 by cat")
    (PROG [(DEF (COND
                   [SOURCE (GETDEF NAME TYPE SOURCE '(EDIT NOCOPY]
                   [(GETDEF NAME TYPE 'CURRENT '(EDIT NOCOPY NOERROR]
                   [(GETDEF NAME TYPE 'SAVED '(EDIT NOCOPY NOERROR]
                   (T (LET ((FILES (WHEREIS NAME TYPE T)))
                           (CL:IF (NULL FILES)
                               (CL:FORMAT T "~S has no ~A definition.~%%" NAME TYPE)
                               [LET [(FILE (PROGN (CL:FORMAT T "~S is contained on~{ ~S~}.~%%" NAME 
                                                         FILES)
                                                  (CL:IF (CL:ENDP (CDR FILES))
                                                      (CL:IF (CL:Y-OR-N-P 
                                                                    "Shall I load this file PROP? ")
                                                             (CAR FILES))
                                                      (ASKUSER NIL NIL 
                                                             "indicate which file to load PROP: "
                                                             (MAKEKEYLST FILES)
                                                             T))]
                                    (CL:WHEN FILE
                                        (LOAD FILE 'PROP)
                                        (GETDEF NAME TYPE '? '(EDIT NOCOPY)))])]

     (* ;; "the EDIT option says to return a COPY if editing this structure isn't enough, and some installation is necessary.")

          (DECLARE (SPECVARS RETRY))

     (* ;; "what is RETRY ???")

          (SETQ RETRY)
          (CL:WHEN DEF
              (EDITE DEF EDITCOMS NAME TYPE [FUNCTION (LAMBDA (NAME DEF TYPE EXITFLG)
                                                             (* ; 
                                             "this function is called when there were changes made")
                                                        (FIXEDITDATE DEF)
                                                             (* ; "fix the edit date first - jtm")
                                                        (PUTDEF NAME TYPE DEF)
                                                        (MARKASCHANGED NAME TYPE 'CHANGED)

                                 (* ;; "woz 1/25/91 MARKASCHANGED must be called after PUTDEF, so sedit's markaschangedfn will see the new definition.  doc for PUTDEF says it calls MARKASCHANGED, but it doesn't always, so do it here.  this sometimes results in MARKASCHANGED getting called twice.")

                                                        ]
                     OPTIONS))])

(EDITDEF.FILES
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)            (* ; "Edited 18-Mar-87 16:07 by woz")
    (EDITDEF (FILECOMS NAME)
           'VARS SOURCE EDITCOMS OPTIONS])

(LOADDEF
  [LAMBDA (NAME TYPE SOURCE)                             (* lmm "13-SEP-78 01:34")
    (PUTDEF NAME TYPE (GETDEF NAME TYPE SOURCE '(NODWIM NOCOPY])

(DWIMDEF
  [LAMBDA (DEF FN SOURCE)                                (* lmm " 6-Jun-86 17:23")
    (AND [OR (EQ DWIMIFYCOMPFLG T)
             (EQ CLISPIFYPRETTYFLG T)
             (EQ (CAR (CADDR DEF))
                 'CLISP%:)
             (SELECTQ SOURCE
                 ((CURRENT SAVED FILE ?) 
                      NIL)
                 (AND (LITATOM SOURCE)
                      (EQMEMB 'CLISP (GETPROP SOURCE 'FILETYPE]
         (LET ((NOSPELLFLG T)
               (DWIMESSGAG T)
               FILEPKGFLG LISPXHIST)
              (DECLARE (CL:SPECIAL NOSPELLFLG DWIMESSGAG FILEPKGFLG LISPXHIST))
              (DWIMIFY0 DEF (COND
                               ((OR (LISTP FN)
                                    (NULL FN))
                                '?)
                               (T FN))
                     NIL DEF])

(DELDEF
  [LAMBDA (NAME TYPE)                                    (* ; "Edited  5-Dec-86 06:20 by lmm")
    (PROG (TEM)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
      LP  [COND
             ((SETQ TEM (fetch DELDEF of TYPE))
              (APPLY* TEM NAME TYPE))
             (T (SELECTQ TYPE
                    (FNS                                     (* ; 
  "special because GETDEF of a FNS is only its EXPR definition, and DELDEF should only remove such")
                         (AND (EXPRP NAME)
                              (/PUTD NAME))
                         (REMPROP NAME 'EXPR)
                         [AND MSDATABASELST (MASTERSCOPE (LIST 'ERASE (KWOTE NAME])
                    (VARS (/SETTOPVAL NAME 'NOBIND))
                    (FILES [for LST in '(FILELST NOTCOMPILEDFILES NOTLISTEDFILES)
                              do (/SETTOPVAL LST (REMOVE NAME (GETTOPVAL LST]
                           (/replace FILEPROP of NAME with NIL)
                           (/replace FILECHANGES of NAME with NIL)
                           (/replace FILEDATES of NAME with NIL)
                           (FLUSHFILEMAPS NAME))
                    (FILEPKGCOMS (DELFROMLIST 'FILEPKGCOMSPLST NAME)
                                 (DELFROMLIST 'FILEPKGTYPES NAME)
                                 (for FIELD on (FILEPKGCOM NAME)
                                    by (CDDR FIELD) do (FILEPKGCOM NAME (CAR FIELD)
                                                                      NIL))
                                 (for FIELD on (FILEPKGTYPE NAME)
                                    by (CDDR FIELD) do (FILEPKGTYPE NAME (CAR FIELD)
                                                                      NIL))
                                 (/replace ALLFIELDS of NAME with NIL))
                    (ALISTS [AND (LISTP NAME)
                                 (DELFROMLIST (CAR NAME)
                                        (FASSOC (CADR NAME)
                                               (GETTOPVAL (CAR NAME])
                    (MACROS (for P in MACROPROPS do (/REMPROP NAME P)))
                    (PROPS (AND (LISTP NAME)
                                (/REMPROP (CAR NAME)
                                       (CADR NAME))))
                    (LISPXMACROS (DELFROMLIST 'LISPXMACROS (FASSOC NAME LISPXMACROS))
                                 (DELFROMLIST 'LISPXHISTORYMACROS (FASSOC NAME LISPXHISTORYMACROS
                                                                             ))
                                 (DELFROMLIST 'LISPXCOMS NAME)
                                 (DELFROMLIST 'HISTORYCOMS NAME))
                    (PRIN1 (LIST "Note: deleting" TYPE "not implemented yet")
                           T]
          (MARKASCHANGED NAME TYPE 'DELETED)
          (RETURN NAME])

(DELFROMLIST
  [LAMBDA (VAR VAL)                                      (* rmk%: " 3-JAN-82 23:22")
    (AND (FMEMB VAL (GETTOPVAL VAR))
         (/SETTOPVAL VAR (SUBSET (GETTOPVAL VAR)
                                (FUNCTION (LAMBDA (X)
                                            (AND (NEQ X VAL)
                                                 (OR (NLISTP X)
                                                     (NEQ (CDR X)
                                                          VAL])

(HASDEF
  [LAMBDA (NAME TYPE SOURCE SPELLFLG)                    (* ; "Edited 31-Aug-87 18:02 by drc:")

    (* ;; "is NAME the name of something of type TYPE?  NIL SOURCE means 0, not ?")

    (DECLARE (SPECVARS TYPE))
    (COND
       [[OR (LISTP TYPE)
            (LISTP (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE](* ; "ignore SPELLFLG")
        (for TY in TYPE do (AND (SETQ $$VAL (HASDEF NAME TY SOURCE))
                                            (RETURN $$VAL]
       (T
        (PROG [(NODEF (fetch NULLDEF of TYPE))
               (OPTS '(NODWIM NOCOPY NOERROR HASDEF]
              (COND
                 ((NULL SOURCE)
                  (SETQQ SOURCE CURRENT)))
              (RETURN
               (SELECTQ SOURCE
                   ((CURRENT 0) 
                        [COND
                           ([OR
                             (MEMBER NAME (fetch CHANGED of TYPE))
                             (LET ((TM (fetch HASDEF of TYPE)))
                                  (COND
                                     (TM (APPLY* TM NAME TYPE SOURCE))
                                     [(NOT (LITATOM NAME))
                                      (SELECTQ TYPE
                                          (PROPS (AND (LISTP NAME)
                                                      (GETPROP (CAR NAME)
                                                             (CADR NAME))))
                                          ((FILES TEMPLATES MACROS LISPXMACROS VARS I.S.OPRS FNS 
                                                  FIELDS USERMACROS FILEVARS FILEPKGCOMS) 
                                               NIL)
                                          (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
                                     (T 
                                        (* ;; "symbol definitions")

                                        (SELECTQ TYPE
                                            (FILES (LET ((SYMBOL (CL:FIND-SYMBOL (CONCAT NAME "COMS")
                                                                        "INTERLISP")))
                                                        (AND SYMBOL (BOUNDP SYMBOL))))
                                            (TEMPLATES (GETTEMPLATE NAME))
                                            (MACROS (GETLIS NAME MACROPROPS))
                                            (LISPXMACROS (OR (FASSOC NAME LISPXMACROS)
                                                             (FASSOC NAME LISPXHISTORYMACROS)))
                                            (VARS (AND (NOT (CL:KEYWORDP NAME))
                                                       (NEQ (GETTOPVAL NAME)
                                                            'NOBIND)))
                                            (RECORDS (RECLOOK NAME))
                                            (I.S.OPRS [PROG [(TEM (GETPROP NAME 'CLISPWORD]
                                                            (RETURN (AND TEM (EQ (CAR TEM)
                                                                                 'FORWORD)
                                                                         (GETPROP (CDR TEM)
                                                                                'I.S.OPR])
                                            (FNS (AND (OR (AND (GETD NAME)
                                                               (EXPRP (GETD NAME)))
                                                          (GET NAME 'EXPR))
                                                      (NOT (HASDEF NAME 'FUNCTIONS SOURCE))))
                                            (FIELDS (RECORDFIELD? NAME))
                                            (USERMACROS (FASSOC NAME USERMACROS))
                                            (FILEVARS)
                                            ((PROPS ALISTS DEFS EXPRESSIONS) 
                                                 NIL)
                                            (FILEPKGCOMS (OR (FMEMB NAME FILEPKGCOMSPLST)
                                                             (FMEMB NAME FILEPKGTYPES)))
                                            (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
                            (OR NAME T))
                           (SPELLFLG (CL:WHEN (CL:SYMBOLP NAME)
                                         (FIXSPELL NAME NIL
                                                (SELECTQ TYPE
                                                    (FILES FILELST)
                                                    (FILEPKGCOMS (UNION FILEPKGCOMSPLST FILEPKGTYPES))
                                                    (FIELDS (for X in USERRECLST
                                                               join (APPEND (RECORDFIELDNAMES
                                                                                 X))))
                                                    (RECORDS (for X in USERRECLST
                                                                when (LITATOM (CADR X))
                                                                collect (CADR X)))
                                                    (LISPXMACROS LISPXCOMS)
                                                    (I.S.OPRS I.S.OPRLST)
                                                    (USERMACROS (MAPCAR USERMACROS
                                                                       (FUNCTION CAR)))
                                                    USERWORDS)
                                                NIL
                                                (LISTP SPELLFLG)
                                                [FUNCTION (LAMBDA (X)
                                                            (HASDEF X TYPE 'CURRENT]
                                                NIL T))])
                   (? (OR (HASDEF NAME TYPE 'CURRENT)
                          (AND (LITATOM NAME)
                               (HASDEF NAME TYPE 'SAVED SPELLFLG))
                          (WHEREIS NAME TYPE T)))
                   ((SAVED T) 
                        (NEQ NODEF (GETDEF NAME TYPE 'SAVED OPTS)))
                   (NEQ NODEF (GETDEF NAME TYPE SOURCE OPTS])

(GETFILEDEF
  [LAMBDA (FILENAME)                                     (* lmm " 4-Jul-85 13:25")

    (* ;; 
  "returns the official file name from a file name if NAME is FOO, look for FOO.LSP on FILELST")

    (COND
       ((FMEMB FILENAME FILELST)
        FILENAME)
       (T (for FILE in FILELST when (STRPOS FILENAME FILE 1 NIL T)
             do (COND
                       ((EQ (FILENAMEFIELD FILE 'NAME)
                            FILENAME)
                        (RETURN FILE])

(SAVEDEF
  [LAMBDA (NAME TYPE DEFINITION)                         (* JonL "24-Jul-84 20:11")
    (COND
       [(AND (LISTP NAME)
             (NULL TYPE))
        (MAPCAR NAME (FUNCTION (LAMBDA (I)
                                 (SAVEDEF I 'FNS]
       (T [SELECTQ (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
              (FNS (AND (OR DEFINITION (SETQ DEFINITION (GETD NAME)))
                        (/PUT NAME [SETQ TYPE (COND
                                                 ((SUBRP DEFINITION)
                                                  'SUBR)
                                                 ((EXPRP DEFINITION)
                                                  'EXPR)
                                                 ((CCODEP DEFINITION)
                                                  'CODE)
                                                 (T 'LIST]
                              DEFINITION)))
              (VARS (AND (NEQ (OR DEFINITION (SETQ DEFINITION (GETTOPVAL NAME)))
                              'NOBIND)
                         (EQ DEFINITION (GETTOPVAL NAME))
                         (/PUT NAME (SETQ TYPE 'VALUE)
                               DEFINITION)))
              (AND [OR DEFINITION (SETQ DEFINITION (GETDEF NAME TYPE 'CURRENT
                                                          '(NOCOPY NOERROR NODWIM]
                   (/PUTASSOC NAME DEFINITION (OR (CDR (FASSOC TYPE SAVEDDEFS))
                                                  (CAR (SETQ SAVEDDEFS (CONS (LIST TYPE (CONS NAME))
                                                                             SAVEDDEFS]
          TYPE])

(UNSAVEDEF
  [LAMBDA (NAME TYPE DEF)                                (* lmm " 6-Jun-86 17:24")
    (SELECTQ TYPE
        ((NIL EXPR CODE SUBR LIST) 
             (COND
                [(LISTP NAME)                                (* ; "for compatibility")
                 (MAPCAR NAME (FUNCTION (LAMBDA (X)
                                          (UNSAVED1 X TYPE]
                (T (UNSAVED1 NAME TYPE))))
        (PROG NIL
              [OR DEF (SETQ DEF (GETDEF NAME (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
                                       'SAVED 0))
                  (RETURN (CONS TYPE '(not found]
              (COND
                 ((NEQ DFNFLG T)
                  (SAVEDEF NAME TYPE)
                  (LET ((DFNFLG T))
                       (PUTDEF NAME TYPE DEF)))
                 (T (PUTDEF NAME TYPE DEF)))
              (RETURN TYPE])

(COMPAREDEFS
  [LAMBDA (NAME TYPE SOURCES)                            (* lmm " 4-Jul-85 14:37")
    (COND
       ((AND (LISTP TYPE)
             (GETFILEPKGTYPE SOURCES NIL T))
        (swap TYPE SOURCES)))
    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (PROG [DEF DEFS (SRCS (OR SOURCES (WHEREIS NAME TYPE T]
          [COND
             ((NULL SOURCES)
              (AND [OR (MEMBER NAME (FILEPKGCHANGES TYPE))
                       (SOME SRCS (FUNCTION (LAMBDA (FILE)
                                              (MEMBER NAME (CDR (ASSOC TYPE
                                                                       (fetch TOBEDUMPED
                                                                          of (fetch FILEPROP
                                                                                    of FILE]
                   (push SRCS 'CURRENT]
          (SETQ SRCS (for SRC in SRCS
                        when (COND
                                    ((NEQ [SETQ DEF (GETDEF NAME TYPE SRC '(NOERROR NOCOPY]
                                          (fetch NULLDEF of TYPE))
                                     (OR [SOME DEFS (FUNCTION (LAMBDA (DP)
                                                                (COMPARELST DEF (CDR DP]
                                         (push DEFS (CONS SRC DEF)))
                                     T)
                                    (T (PRINTOUT T "No " SRC " definition found for " NAME T)
                                       NIL)) collect SRC))
          (RETURN (COND
                     ((NULL SRCS)
                      '(no definitions found))
                     ((NULL (CDR SRCS))
                      '(only one definition found))
                     ((CDR DEFS)
                      [for S1 on (DREVERSE DEFS)
                         do (for S2 on (CDR S1) do (PRIN2 NAME T T)
                                                                  (AND (CAAR S1)
                                                                       (PRIN1 " from " T)
                                                                       (PRIN2 (CAAR S1)
                                                                              T T))
                                                                  (PRIN1 " and " T)
                                                                  (PRIN2 NAME T T)
                                                                  (COND
                                                                     ((CAAR S2)
                                                                      (PRIN1 " from " T)
                                                                      (PRIN2 (CAAR S2)
                                                                             T T)))
                                                                  (PRIN1 " differ:" T)
                                                                  (TERPRI T)
                                                                  (COMPARELISTS (CDAR S1)
                                                                         (CDAR S2]
                      'DIFFERENT)
                     (T 'SAME])

(COMPARE
  [LAMBDA (NAME1 NAME2 TYPE SOURCE1 SOURCE2)             (* lmm " 5-SEP-78 13:37")
    (PROG [[DEF1 (GETDEF NAME1 TYPE SOURCE1 '(NOERROR NOCOPY]
           (DEF2 (GETDEF NAME2 TYPE SOURCE2 '(NOERROR NOCOPY]
          (COND
             ((COMPARELST DEF1 DEF2)
              (RETURN)))
          (PRIN2 NAME1 T T)
          (COND
             (SOURCE1 (PRIN1 " from " T)
                    (PRIN2 SOURCE1 T T)))
          (PRIN1 " and " T)
          (PRIN2 NAME2 T T)
          (COND
             (SOURCE2 (PRIN1 " from " T)
                    (PRIN2 SOURCE2 T T)))
          (PRIN1 " differ:" T)
          (TERPRI T)
          (COMPARELISTS DEF1 DEF2)
          (RETURN T])

(TYPESOF
  [LAMBDA (NAME POSSIBLETYPES IMPOSSIBLETYPES SOURCE FILTER)
                                                          (* ; "Edited  2-Aug-88 02:08 by masinter")

    (* ;; "return list of all known types which NAME names")

    (LET
     (FOUND SHADOWED)
     (if (FMEMB SOURCE '(? NIL))
         then (CL:FLET [(RSHADOW NIL (for X in FOUND
                                            do (for Y in (CDR (FASSOC X SHADOW-TYPES))
                                                      do (if (FMEMB Y FOUND)
                                                                 then 
                                                             (* ; "shadower found before shadowed")
                                                                       (SETQ FOUND (REMOVE Y FOUND]
                         (LET (NOTFOUND NEWTYPES)
                              (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
                                 when [AND (LITATOM TYPE)
                                               (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
                                               (OR (NULL FILTER)
                                                   (CL:FUNCALL FILTER TYPE))
                                               (NOT (find X in FOUND
                                                       suchthat (FMEMB TYPE
                                                                           (CDR (FASSOC X 
                                                                                       SHADOW-TYPES]
                                 do (if [OR (HASDEF NAME TYPE 'CURRENT)
                                                    (AND (LITATOM NAME)
                                                         (HASDEF NAME TYPE 'SAVED]
                                            then (push FOUND TYPE)
                                          else (push NOTFOUND TYPE)))
                              (RSHADOW)
                              [for FILE in FILELST while NOTFOUND
                                 when [NEQ T (fetch LOADTYPE of (GETPROP FILE
                                                                                   'FILE]
                                 do (if (SETQ NEWTYPES (INFILECOMS? NAME NOTFOUND
                                                                      (FILECOMS FILE)
                                                                      'TYPESOF))
                                            then [bind X for TYPE in NEWTYPES
                                                        when (FMEMB TYPE NOTFOUND)
                                                        do (push FOUND TYPE)
                                                              (if (SETQ X (FASSOC TYPE 
                                                                                     SHADOW-TYPES))
                                                                  then (SETQ NOTFOUND
                                                                            (LDIFFERENCE NOTFOUND X))
                                                                else (SETQ NOTFOUND
                                                                          (REMOVE TYPE NOTFOUND]
                                                  (SETQ NOTFOUND (LDIFFERENCE NOTFOUND NEWTYPES]
                              (if (AND NOTFOUND (GETD 'XCL::HASH-FILE-TYPES-OF))
                                  then (SETQ NEWTYPES (XCL::HASH-FILE-TYPES-OF NAME NOTFOUND))
                                        (SETQ FOUND (UNION NEWTYPES FOUND)))
                              (RSHADOW)
                              FOUND))
       else (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
                   when (AND (LITATOM TYPE)
                                 (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
                                 (OR (NULL FILTER)
                                     (CL:FUNCALL FILTER TYPE))
                                 (HASDEF NAME TYPE SOURCE)) do (push FOUND TYPE)))
     FOUND])
)

(RPAQ? WHEREIS.HASH )



(* ; "Must come after PUTDEF")

(DEFINEQ

(FIXEDITDATE
  [LAMBDA (EXPR)                                         (* ; "Edited 17-Jul-89 11:13 by jtm:")
                                                             (* NOBIND "18-JUL-78 21:11")
                                                             (* Inserts or replaces previous edit 
                                                           date)
    (AND INITIALS (LISTP EXPR)
         (LISTP (CDR EXPR))
         (PROG (E)
               (COND
                  ((FMEMB (CAR EXPR)
                          LAMBDASPLST)

                   (* ;; "insert the edit date after the argument list")

                   (SETQ E (CDDR EXPR)))
                  [(FMEMB (GETPROP (CAR EXPR)
                                 ':DEFINER-FOR)
                          EDITDATE-ARGLIST-DEFINERS)

                   (* ;; "insert the edit date after the argument list")

                   (SETQ E (CDDR EXPR))
                   (while (NOT (CL:LISTP (CAR E))) do (SETQ E (CDR E))
                      finally (SETQ E (CDR E]
                  ((FMEMB (GETPROP (CAR EXPR)
                                 ':DEFINER-FOR)
                          EDITDATE-NAME-DEFINERS)

                   (* ;; "insert the edit date after the name")

                   (SETQ E (CDDR EXPR)))
                  (T (RETURN)))
           RETRY
               [COND
                  ((NLISTP E)
                   (RETURN))
                  ((LISTP (CAR E))
                   (SELECTQ (CAAR E)
                       ((CLISP%: DECLARE) 
                            (SETQ E (CDR E))
                            (GO RETRY))
                       (BREAK1 (COND
                                  ((EQ (CAR (CADAR E))
                                       'PROGN)
                                   (SETQ E (CDR (CADAR E)))
                                   (GO RETRY))))
                       (ADV-PROG                             (* No easy way to mark cleanly the 
                                                           date of an advised function)
                                 (RETURN))
                       (COND
                          ((AND (EQ (CAAR E)
                                    COMMENTFLG)
                                (EQ (CADAR E)
                                    'DECLARATIONS%:))
                           (SETQ E (CDR E))
                           (GO RETRY]
               (COND
                  ([for TAIL on E while (AND (LISTP (CAR TAIL))
                                                         (EQ (CAAR TAIL)
                                                             COMMENTFLG))
                      do (COND
                                ((AND (LISTP (CDR TAIL))
                                      (EDITDATE? (CAR TAIL)))
                                 (/RPLACA TAIL (EDITDATE (CAR TAIL)
                                                      INITIALS))
                                 (RETURN T]                  (* scans the comments for a 
                                                           timestamp for this user.)
                   NIL)
                  (T                                         (* attach the new timestamp at the 
                                                           beginning of the comments.)
                     (/ATTACH (EDITDATE NIL INITIALS)
                            E)))
               (RETURN EXPR])

(EDITDATE?
  [LAMBDA (COMMENT)                                      (* ; "Edited 11-Jun-92 16:44 by cat")
                                                             (* ; "Edited 13-Jul-89 09:30 by jtm:")
                                                             (* lmm "21-Mar-85 08:45")

         (* Tests to see if a given common is in fact an edit date --
       this has to be general enough to recognize the most comment comment forms while 
       specific enough to not recognize things that are not edit dates)

    (DECLARE (LOCALVARS . T))                            (* jtm%: changed test so that it 
                                                           creates one timestamp per user.)
    (COND
       [(LISTP COMMENT)
        (COND
           ((EQ (CAR COMMENT)
                COMMENTFLG)
            [COND
               (NIL (NULL NORMALCOMMENTSFLG)
                    (SETQ COMMENT (GETCOMMENT COMMENT]
            (COND
               ([OR (NOT (LISTP (CDR COMMENT)))
                    (NOT (LISTP (CDDR COMMENT]
                NIL)
               [(EQ (CADR COMMENT)
                    ';)                                      (* ; "CL style comment")
                (STRPOS INITIALS (CADDR COMMENT)
                       (IMINUS (NCHARS INITIALS]
               (T                                            (* ; "IL style comment")
                  (EQ (CADR COMMENT)
                      INITIALS]
       ((STRINGP COMMENT])
)



(* ; "Edit date support for all kinds of definers (from PARC 6/10/92)")


(RPAQQ EDITDATE-ARGLIST-DEFINERS (FUNCTIONS TYPES))

(RPAQQ EDITDATE-NAME-DEFINERS (STRUCTURES VARIABLES))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
)



(* ;; 
"how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started."
)

(DEFINEQ

(FILEPKGCOM
  [LAMBDA N                                              (* JonL "10-Jul-84 19:38")
    (PROG (TEM (COM (ARG N 1)))
          (RETURN (COND
                     [(EQ N 1)
                      (OR (for FIELD in '(MACRO CONTENTS DELETE ADD)
                             when (SETQ TEM (FILEPKGCOM COM FIELD))
                             join (LIST FIELD TEM))
                          (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                               (LIST 'COM T))
                          (AND [SETQ TEM (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]
                               (LIST 'COM TEM]
                     ((EQ N 2)
                      (SELECTQ (ARG N 2)
                          (ADD (fetch ADD of COM))
                          (DELETE (fetch DELETE of COM))
                          (MACRO (fetch MACRO of COM))
                          ((CONTENTS CONTAIN) 
                               [OR (fetch (FILEPKGCOM CONTENTS) of COM)
                                   (COND
                                      ((SETQ COM (fetch (FILEPKGCOM PRETTYTYPE) of COM))
                                       (COND
                                          ((EQ COM 'NILL)
                                           COM)
                                          [(EQ (CAR COM)
                                               'LAMBDA)
                                           (CONS (CAR COM)
                                                 (CONS [CONS (CAADR COM)
                                                             (CONS (OR (CADDR (CADR COM))
                                                                       'NAME)
                                                                   (CONS (CADR (CADR COM))
                                                                         (CDDDR (CADR COM]
                                                       (SUBST 'INFILECOMTAIL 'PRETTYCOM1 (CDDR COM]
                                          (T (LIST 'LAMBDA '(COM TYPE NAME)
                                                   (CONS COM '(COM TYPE NAME])
                          (COM [OR (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                        T)
                                   (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST])
                          (ERROR (ARG N 2)
                                 "not file package command property")))
                     (T [for I TEM2 from 2 to N by 2
                           do (SETQ TEM (ARG N (ADD1 I)))
                                 (COND
                                    [(EQ (ARG N I)
                                         'COM)
                                     (SELECTQ TEM
                                         (NIL)
                                         (T [OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                                (/SETTOPVAL 'FILEPKGCOMSPLST
                                                       (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST])
                                         (COND
                                            ([SETQ TEM2 (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]
                                             (/RPLACD TEM2 TEM))
                                            (T (/SETTOPVAL 'FILEPKGCOMSPLST
                                                      (CONS (CONS COM TEM)
                                                            (GETTOPVAL 'FILEPKGCOMSPLST]
                                    (T [AND TEM (OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                                    (/SETTOPVAL 'FILEPKGCOMSPLST
                                                           (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST]
                                       (SELECTQ (ARG N I)
                                           (ADD (/replace (FILEPKGCOM ADD) of COM
                                                   with TEM))
                                           (DELETE (/replace (FILEPKGCOM DELETE) of
                                                                                         COM
                                                      with TEM))
                                           (MACRO (/replace (FILEPKGCOM MACRO) of COM
                                                     with TEM))
                                           ((CONTENTS CONTAIN) 
                                                (/replace (FILEPKGCOM CONTENTS) of COM
                                                   with TEM))
                                           (ERROR (ARG N I)
                                                  "not file package command property"]
                        (MARKASCHANGED COM 'FILEPKGCOMS])

(FILEPKGTYPE
  [LAMBDA N                                              (* lmm " 5-Jul-85 09:07")
    (PROG ((TYPE (ARG N 1))
           TEM)
          (RETURN (COND
                     [(EQ N 1)
                      (OR (for FIELD in (UNION '(DESCRIPTION)
                                                       FILEPKGTYPEPROPS)
                             when (SETQ TEM (FILEPKGTYPE TYPE FIELD))
                             join (LIST FIELD TEM))
                          (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES))
                               (LIST 'TYPE T))
                          (AND [SETQ TEM (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES]
                               (LIST 'TYPE TEM]
                     [(EQ N 2)
                      (if (FMEMB (ARG N 2)
                                     FILEPKGTYPEPROPS)
                          then (GETPROP TYPE (ARG N 2))
                        else (SELECTQ (ARG N 2)
                                     (DESCRIPTION (fetch DESCRIPTION of TYPE))
                                     (TYPE [OR (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES))
                                                    T)
                                               (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES])
                                     (ERROR (ARG N 2)
                                            "not file package type property"]
                     (T [for I TEM2 from 2 to N by 2
                           do (SETQ TEM (ARG N (ADD1 I)))
                                 (COND
                                    [(EQ (ARG N I)
                                         'TYPE)
                                     (SELECTQ TEM
                                         (NIL)
                                         (T (OR (FMEMB TYPE FILEPKGTYPES)
                                                (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES))))
                                         (COND
                                            ((SETQ TEM2 (ASSOC TYPE FILEPKGTYPES))
                                             (/RPLACD TEM2 TEM))
                                            (T (/SETTOPVAL 'FILEPKGTYPES (CONS (CONS TYPE TEM)
                                                                               FILEPKGTYPES]
                                    (T [AND TEM (OR (FMEMB TYPE FILEPKGTYPES)
                                                    (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES
                                                                                    ]
                                       (if (FMEMB (ARG N I)
                                                      FILEPKGTYPEPROPS)
                                           then (if TEM
                                                        then (/PUTPROP TYPE (ARG N I)
                                                                        TEM)
                                                      else (/REMPROP TYPE (ARG N I)))
                                         else (SELECTQ (ARG N I)
                                                      (DESCRIPTION (/replace DESCRIPTION
                                                                      of TYPE with TEM))
                                                      (ERROR (ARG N I)
                                                             "not file package command/type property"
                                                             ]
                        (MARKASCHANGED TYPE 'FILEPKGCOMS])
)

(PUTPROPS FILEPKGCOM ARGNAMES (COMMANDNAME (KEYWORDS%: MACRO ADD DELETE CONTENTS)))

(ADDTOVAR FILEPKGCOMSPLST FILEPKGCOMS)

(ADDTOVAR FILEPKGTYPES FILEPKGCOMS)
(PUTDEF (QUOTE FILEPKGCOMS) (QUOTE FILEPKGCOMS) '([COM CONTENTS (LAMBDA (COM NAME TYPE)
                                                                       (* Revert to NILL when no 
                                                                          longer coercing 
                                                                          PRETTYDEFMACROS to 
                                                                          FILEPKGCOMS)
                                                                       (AND (EQ TYPE 'FILEPKGCOMS)
                                                                            (INFILECOMTAIL COM]
                                                  (TYPE DESCRIPTION "file package commands/types" 
                                                        GETDEF T PUTDEF FILEPKGCOMS.PUTDEF)))
(PUTDEF (QUOTE ALISTS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEALISTCOMS . X]
                                             (TYPE DESCRIPTION "alist entries" GETDEF ALISTS.GETDEF 
                                                   WHENCHANGED (ALISTS.WHENCHANGED))))
(PUTDEF (QUOTE DEFS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (COMS . X])
(PUTDEF (QUOTE EDITMACROS) (QUOTE FILEPKGCOMS) '((TYPE TYPE USERMACROS)))
(PUTDEF (QUOTE EXPRESSIONS) (QUOTE FILEPKGCOMS) '((TYPE DESCRIPTION "expressions" WHENCHANGED (
                                                                              EXPRESSIONS.WHENCHANGED
                                                                                               )
                                                        EDITDEF NILL)))
(PUTDEF (QUOTE FIELDS) (QUOTE FILEPKGCOMS) '((TYPE EDITDEF NILL)))
(PUTDEF (QUOTE FILEPKGTYPES) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)
                                                   (TYPE TYPE FILEPKGCOMS)))
(PUTDEF (QUOTE FILES) (QUOTE FILEPKGCOMS) '([COM MACRO [X (P * (CONS (MAKEFILESCOMS . X]
                                                 CONTENTS
                                                 (LAMBDA (COM NAME TYPE)
                                                        (AND (EQ TYPE 'FILES)
                                                             (SUBSET (INFILECOMTAIL COM)
                                                                    (FUNCTION LITATOM]
                                            (TYPE PUTDEF FILES.PUTDEF WHENCHANGED (FILES.WHENCHANGED)
                                                  EDITDEF EDITDEF.FILES)))
(PUTDEF (QUOTE FILEVARS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (VARS . X)))
                                               (TYPE NULLDEF NOBIND EDITDEF NILL)))
(PUTDEF (QUOTE FNS) (QUOTE FILEPKGCOMS) '((COM MACRO
                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                         (FN)
                                                                         (AND (GETPROP FN
                                                                                     'FUNCTIONS)
                                                                              (CL:WARN 
                                                                      "~A has a FUNCTIONS definition"
                                                                                     FN]
                                                  (ORIGINAL (FNS . X)))
                                               CONTENTS NILL)
                                          (TYPE DESCRIPTION "functions" PUTDEF FNS.PUTDEF CANFILEDEF
                                                T)))
(PUTDEF (QUOTE INITRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (P * (RECORDALLOCATIONS . X)))
                                                       CONTENTS
                                                       (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                              (AND (NULL ONFILETYPE)
                                                                   (EQ TYPE 'RECORDS)
                                                                   (INFILECOMTAIL COM])
(PUTDEF (QUOTE INITVARS) (QUOTE FILEPKGCOMS) '((COM COM T)))
(PUTDEF (QUOTE LISPXCOMS) (QUOTE FILEPKGCOMS) '((TYPE TYPE LISPXMACROS)))
(PUTDEF (QUOTE LISPXMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKELISPXMACROSCOMS . X)))
                                                       CONTENTS NILL)
                                                  (TYPE DESCRIPTION "LISPX commands")))
(PUTDEF (QUOTE MACROS) (QUOTE FILEPKGCOMS) '((COM
                                              MACRO
                                              [X
                                               (DECLARE%:
                                                EVAL@COMPILE
                                                (P
                                                 *
                                                 (MAPCAR
                                                  'X
                                                  (FUNCTION
                                                   (LAMBDA (Y)
                                                          (LET [[FNDEF (GETDEF Y 'FUNCTIONS
                                                                              'CURRENT
                                                                              '(NOCOPY NOERROR]
                                                                (MACDEF (GETDEF Y 'MACROS
                                                                               'CURRENT
                                                                               '(NOCOPY NOERROR]
                                                               (COND
                                                                ((AND FNDEF (EQ (CAR FNDEF)
                                                                                'DEFMACRO))
                                                                 (CL:WARN 
                           "Need to change MACROS to FUNCTIONS for writing out Common Lisp macro ~S."
                                                                        FNDEF)
                                                                 (LIST 'PROGN FNDEF MACDEF))
                                                                (T (OR MACDEF (CL:CERROR 
                                                          "Go ahead and finish writing out the file."
                                                                                     
                                                                       "No MACROS definition for ~A."
                                                                                     Y)
                                                                       (GETDEF Y 'MACROS 'CURRENT]
                                              CONTENTS NILL)
                                             (TYPE DESCRIPTION "Interlisp macros" GETDEF 
                                                   MACROS.GETDEF WHENCHANGED (CLEARCLISPARRAY))))
(PUTDEF (QUOTE PRETTYDEFMACROS) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)))
(PUTDEF (QUOTE PROPS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEPROPSCOMS . X]
                                            (TYPE DESCRIPTION "property lists" WHENCHANGED (
                                                                                    PROPS.WHENCHANGED
                                                                                            ))))
(PUTDEF (QUOTE RECORDS) (QUOTE FILEPKGCOMS) '[[COM
                                               MACRO
                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                         (RECORD)
                                                                         (AND (GETPROP RECORD
                                                                                     'STRUCTURES)
                                                                              (CL:WARN 
                                                                     "~A has a STRUCTURES definition"
                                                                                     RECORD]
                                                  (E (RECORDECLARATIONS . X))
                                                  (INITRECORDS . X))
                                               CONTENTS
                                               (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                      (AND (EQ TYPE 'FIELDS)
                                                           (NULL ONFILETYPE)
                                                           (MAPCONC (INFILECOMTAIL COM)
                                                                  (FUNCTION (LAMBDA
                                                                             (X)
                                                                             (APPEND (
                                                                                     RECORDFIELDNAMES
                                                                                      X]
                                              (TYPE DESCRIPTION "records" DELDEF
                                                    (LAMBDA (X)
                                                           (/SETTOPVAL 'USERRECLST
                                                                  (REMOVE (RECLOOK X)
                                                                         USERRECLST])
(PUTDEF (QUOTE OLDRECORDS) (QUOTE FILEPKGCOMS) '((COM COM T)))
(PUTDEF (QUOTE SYSRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (SAVEONSYSRECLST . X)))
                                                      CONTENTS
                                                      (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                             (AND (NULL ONFILETYPE)
                                                                  (EQ TYPE 'RECORDS)
                                                                  (INFILECOMTAIL COM])
(PUTDEF (QUOTE USERMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKEUSERMACROSCOMS . X)))
                                                      CONTENTS NILL)
                                                 (TYPE DESCRIPTION "edit macros")))
(PUTDEF (QUOTE VARS) (QUOTE FILEPKGCOMS) '((COM MACRO
                                                (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                          (VAR)
                                                                          (AND (GETPROP VAR
                                                                                      'VARIABLES)
                                                                               (CL:WARN 
                                                                 "~A also has a VARIABLES definition"
                                                                                      VAR]
                                                   (ORIGINAL (VARS . X)))
                                                CONTENTS NILL)
                                           (TYPE DESCRIPTION "variables" NULLDEF NOBIND PUTDEF 
                                                 VARS.PUTDEF)))
(PUTDEF (QUOTE *) (QUOTE FILEPKGCOMS) '((COM CONTENTS NILL)))
(PUTDEF (QUOTE CONSTANTS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (DECLARE%: EVAL@COMPILE (VARS . X)
                                                                     (P (CONSTANTS . X])

(ADDTOVAR SHADOW-TYPES (FUNCTIONS FNS)
                           (VARIABLES VARS CONSTANTS))

(RPAQ? SAVEDDEFS )



(* ; "EDITCALLERS")

(DEFINEQ

(FINDCALLERS
  [LAMBDA (ATOMS FILES)                                  (* lmm "30-SEP-78 01:36")
    (PROG ((X (EDITCALLERS ATOMS FILES T)))
          (RETURN (NCONC (DREVERSE (CDR X))
                         (AND (CAR X)
                              (LIST (CONS (COND
                                             ((CDR X)
                                              '"plus other places on")
                                             (T 'on))
                                          (CAR X])

(EDITCALLERS
  [LAMBDA (ATOMS FILES COMS)                            (* ; "Edited  8-Aug-2020 17:32 by rmk:")
                                                             (* bvm%: " 3-Nov-86 17:30")
    (LET
     (FFILEPOSPATTERNS FNS OTHERSFILES EDITPATTERN)
     [SETQ EDITPATTERN (EDITFPAT (CONS '*ANY* (SETQ ATOMS (MKLIST ATOMS]
     [for FILE in (COND
                             ((NULL FILES)
                              FILELST)
                             ((EQ FILES T)
                              (UNION SYSFILES FILELST))
                             ((LISTP FILES)
                              FILES)
                             (T (LIST FILES)))
        do
        (RESETLST
            [PROG (PATTERNS CA RDTBL MAP NOMAPFLG FULL FILESTREAM PRINTFLG ENV DUMMY TOP I)
                  (OR (SETQ FULL (FINDFILE FILE))
                      (RETURN (LISPXPRINT (CONS FILE '(not found))
                                     T T)))
                  [RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                       (SETQ FILESTREAM (OPENSTREAM FULL 'INPUT]
                  (CL:FORMAT T "~A: " (SETQ FULL (FULLNAME FILESTREAM)))
                  (CL:MULTIPLE-VALUE-SETQ (ENV MAP TOP)
                         (OR (GET-ENVIRONMENT-AND-FILEMAP FULL)
                             (\PARSE-FILE-HEADER FILESTREAM)))

             (* ;; "Get reader environment of file.  The call to GET-ENVIRONMENT-AND-FILEMAP with the filename will get cached info if it exists.  Otherwise, read the top of the file")

                  (SETQ RDTBL (AND ENV (fetch (READER-ENVIRONMENT REREADTABLE) of ENV)))
                  (SETQ CA (SEPRCASE DWIMIFYCOMPFLG RDTBL))
                  [OR (SETQ PATTERNS (CDR (ASSOC RDTBL FFILEPOSPATTERNS)))
                      (push FFILEPOSPATTERNS
                             (CONS RDTBL (SETQ PATTERNS
                                          (for ATOM in ATOMS
                                             collect (CONCAT
                                                          (COND
                                                             ((EQ (CHCON1 ATOM)
                                                                  (CHARCODE ESCAPE))
                                                              (SETQ ATOM (SUBSTRING ATOM 2 -1))
                                                              "")
                                                             (T " "))
                                                          [COND
                                                             ((SETQ I (STRPOS ' ATOM))
                                                              (SUBSTRING ATOM 1 (SUB1 I)))
                                                             ((STRINGP ATOM))
                                                             (T (LET ((*PACKAGE* (CL:SYMBOL-PACKAGE
                                                                                  ATOM)))
                                                             (* ; 
                                                           "Keep MKSTRING from putting a prefix on")
                                                                     (MKSTRING ATOM T RDTBL]
                                                          (COND
                                                             (I "")
                                                             (T " "]
                  (for PATTERN in PATTERNS
                     do
                     (SETFILEPTR FILESTREAM (SETQ I (OR TOP 0)))
                     (while (SETQ I (FFILEPOS PATTERN FILESTREAM I NIL NIL T CA))
                        do
                        (COND
                           ((NULL PRINTFLG)                  (* ; 
                                   "cause the printing of the filename to be saved on history list")
                            (SETQ PRINTFLG T)
                            (LISPXPRIN2 FULL T T T)

                            (* ;; "print with NODOFLG=T means just to record the printing;  the idea is that only those files in which something is found will be remembered on the history list")

                            (LISPXPRIN1 ": " T NIL T)))
                        [OR
                         [AND (NEQ MAP T)
                              (for X in (CDR (OR MAP [PROGN (SETFILEPTR FILESTREAM 0)
                                                                    (SETQ MAP (OR (GETFILEMAP 
                                                                                         FILESTREAM)
                                                                                  (LOADFILEMAP 
                                                                                         FILESTREAM]
                                                         (PROGN 
                                                             (* ; "file has no filemap")
                                                                (SETQ MAP (SETQ NOMAPFLG T))
                                                                (LISPXPRIN1 " no filemap!" T)
                                                                NIL)))
                                 thereis (AND (ILESSP (CAR X)
                                                         I)
                                                  (IGREATERP (CADR X)
                                                         I)
                                                  (for Z in (CDDR X)
                                                     thereis (COND
                                                                    ((AND (ILESSP (CADR Z)
                                                                                 I)
                                                                          (IGREATERP (CDDR Z)
                                                                                 I))
                                                                     [COND
                                                                        ((NOT (FMEMB (CAR Z)
                                                                                     FNS))
                                                                         (SETQ FNS
                                                                          (CONS (LISPXPRIN2
                                                                                 (CAR Z)
                                                                                 T T)
                                                                                FNS]
                                                                     (SETQ I (CDDR Z))
                                                                     T]
                         (PROGN (LISPXPRIN2 I T T)
                                (OR (FMEMB FILE OTHERSFILES)
                                    (SETQ OTHERSFILES (CONS FILE OTHERSFILES]
                        (LISPXSPACES 1 T)))
                  (COND
                     (PRINTFLG (LISPXTERPRI T))
                     (T (TERPRI T)))
                  (COND
                     ((NEQ COMS T)
                      (COND
                         ((OR FNS OTHERSFILES)
                          (EDITFROMFILE (OR NOMAPFLG (DREVERSE FNS))
                                 FULL EDITPATTERN COMS (NULL OTHERSFILES))
                          (SETQ OTHERSFILES)
                          (SETQ FNS])]
     (COND
        ((EQ COMS T)
         (CONS OTHERSFILES FNS])

(EDITFROMFILE
  [LAMBDA (FNS FILES EDITPATTERN EDITCOMS ONLYTYPES)     (* rmk%: "14-Mar-85 21:51")
    (RESETVARS [(EDITLOADFNSFLG (COND
                                   ((EQ EDITLOADFNSFLG T)
                                    '(T . NO))
                                   (T EDITLOADFNSFLG]
               (PROG NIL
                     [OR EDITCOMS (SETQ EDITCOMS (LIST (LIST 'EXAM EDITPATTERN]
                     (AND
                      (SETQ FILES (for FILE inside (OR FILES FILELST)
                                     when (OR (AND EDITLOADFNSFLG (FMEMB (ROOTFILENAME FILE)
                                                                             FILELST))
                                                  (COND
                                                     ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "load from" 
                                                                                        FILE)
                                                                    NIL T))
                                                      (LOADFROM FILE FNS 'ALLPROP)
                                                      T))) collect FILE))
                      (for TYPE in [COND
                                              ((LISTP ONLYTYPES))
                                              (ONLYTYPES '(FNS))
                                              (T 

                                 (* ;; "Move FNS to the front.  This means that all the fns will be dwimified and edited before anything else (like a rename of fields) is done.")

                                                 (CONS 'FNS (REMOVE 'FNS FILEPKGTYPES]
                         when (AND (LITATOM TYPE)
                                       (NEQ (fetch EDITDEF of TYPE)
                                            'NILL))
                         do
                         (PROG (SEEN)
                               (for FILE inside FILES
                                  do
                                  (for NAME in [COND
                                                          ((AND (EQ TYPE 'FNS)
                                                                (NEQ FNS T))
                                                             (* ; 
                                                    "for this type, we are given the list of items")
                                                           (PROG1 FNS (SETQ FNS NIL)))
                                                          (T (* ; 
                             "only want the values of `TYPE' which are not part of some other type")
                                                             (FILECOMSLST FILE TYPE 'EDIT]
                                     unless (MEMBER NAME SEEN)
                                     do
                                     (ERSETQ
                                      (PROG [(DEF (OR (GETDEF NAME TYPE 'CURRENT
                                                             '(NOCOPY NOERROR))
                                                      (GETDEF NAME TYPE 'SAVED
                                                             '(NOCOPY NOERROR]

                                 (* ;; "If definition has been loaded, it may have been editted.  Work on that explicitly instead of bringing in a file definition to smash the users previous changes.  Perhaps we should query the user about this, but until the interaction is worked out, it is better to avoid trashing his in core edits, given that he can always get the file definition from permanent storage with LOADFNS.  --- We might also be more discriminating about this: if the user specified a root file name, then he means the definition from the definition group, not the physical file.  But ...  rmk")

                                            (COND
                                               ((OR (AND (EQ TYPE 'FNS)
                                                         (NEQ FNS T))
                                                    (AND (LISTP DEF)
                                                         (LOOKIN DEF EDITPATTERN)))
                                                (COND
                                                   ((NULL SEEN)
                                                    (LISPXPRIN1 "editing the " T)
                                                    (LISPXPRIN1 (OR (fetch DESCRIPTION
                                                                       of TYPE)
                                                                    TYPE)
                                                           T)
                                                    (LISPXSPACES 1 T)))
                                                (SETQ SEEN (CONS NAME SEEN))
                                                (LISPXPRIN2 NAME T T)
                                                (LISPXPRIN1 ":
" T)
                                                (COND
                                                   ((NOT
                                                     (ERSETQ (EDITDEF
                                                              NAME TYPE
                                                              (OR (AND DEF (CONS '= DEF))
                                                                  FILE)
                                                              EDITCOMS)))
                                                    (LISPXPRIN1 "failed" T)))
                                                (LISPXTERPRI T])

(FINDATS
  [LAMBDA (X L)                                          (* lmm "11-FEB-78 16:03")
    (COND
       ((NLISTP X)
        (FMEMB X L))
       (T (OR (FINDATS (CAR X)
                     L)
              (FINDATS (CDR X)
                     L])

(LOOKIN
  [LAMBDA (X PAT)                                        (* lmm "11-MAR-78 14:20")
    (COND
       ([AND (EQ (CAR PAT)
                 '*ANY*)
             (EVERY (CDR PAT)
                    (FUNCTION (LAMBDA (X)
                                (AND (LITATOM X)
                                     (NOT (STRPOS ' X]
        (FINDATS X (CDR PAT)))
       (T (EDITFINDP X PAT T])
)
(DEFINEQ

(SEPRCASE
  [LAMBDA (CLFLG RDTBL)                                  (* bvm%: "24-Oct-86 18:16")

    (* ;; "make a case array for FFILEPOS in which all of the seprs, breaks, and (possibly) clisp chars are all equivalent.  Based on FILERDTBL, but others are close with respect to breaks and seprs")

    (OR RDTBL (SETQ RDTBL FILERDTBL))
    (OR [ARRAYP (CDR (ASSOC RDTBL (COND
                                     (CLFLG CLISPCASEARRAYS)
                                     (T SEPRCASEARRAYS]
        (LET ((CA (CASEARRAY)))
             [if (READTABLEPROP RDTBL 'CASEINSENSITIVE)
                 then                                    (* ; "map upper into lower case")
                       (for I from (CHARCODE A) to (CHARCODE Z)
                          do (SETCASEARRAY CA I (+ I (- (CHARCODE a)
                                                            (CHARCODE A]
             (for X in (NCONC (AND CLFLG (for Y in CLISPCHARS
                                                    collect (CHCON1 Y)))
                                      (GETSEPR RDTBL)
                                      (GETBRK RDTBL)) do (SETCASEARRAY CA X 0))
             (if *PACKAGE*
                 then                                    (* ; 
                               "symbols qualified with package prefix will otherwise be unfindable")
                       (SETCASEARRAY CA (READTABLEPROP RDTBL 'PACKAGECHAR)
                              0))
             (SETQ CA (CONS RDTBL CA))
             (COND
                (CLFLG (push CLISPCASEARRAYS CA))
                (T (push SEPRCASEARRAYS CA)))
             (CDR CA])
)

(RPAQ? DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL))

(RPAQ? SEPRCASEARRAYS )

(RPAQ? CLISPCASEARRAYS )

(MOVD? 'INFILEP 'FINDFILE)

                                                             (* ; "or else from SPELLFILE")
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
       (NOLINKFNS LOADFROM))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS)
)



(* ; "EXPORT")

(DEFINEQ

(IMPORTFILE
  [LAMBDA (FILE RETURNFLG)                               (* lmm " 6-Jun-86 17:43")
    (RESETLST
        [RESETSAVE NIL (LIST 'CLOSEF (SETQ FILE (OPENSTREAM FILE 'INPUT]
        (RESETSAVE (INPUT FILE))                             (* ; 
                "Reset INPUT in case some form on the file's action is to read the next expression")
        (NCONC [COND
                  ((EQ RETURNFLG T)                          (* ; 
                                           "Just creating EXPORTS.ALL, don't side-effect the world")
                   (IMPORTFILESCAN FILE RETURNFLG))
                  (T (LET (FILEPKGFLG DFNFLG)
                          (IMPORTFILESCAN FILE RETURNFLG]
               (IMPORTEVAL [LIST 'PUTPROP (KWOTE (ROOTFILENAME FILE))
                                     ''IMPORTDATE
                                     (LIST 'IDATE (GETFILEINFO FILE 'CREATIONDATE]
                      RETURNFLG)))])

(IMPORTEVAL
  [LAMBDA (FORM RETURNFLG)                               (* ; "Edited  2-May-87 18:57 by Pavel")

    (* ;; "Ignore DONTEVAL@LOAD'S --- If RETURNFLG is on, return list of forms")

    (AND (LISTP FORM)
         (SELECTQ (CAR FORM)
             (DECLARE%: (FOR Z IN (CDR FORM) JOIN (IMPORTEVAL Z RETURNFLG)))
             (CL:EVAL-WHEN (FOR Z IN (CDDR FORM) JOIN (IMPORTEVAL Z RETURNFLG)))
             (/DECLAREDATATYPE                               (* ; 
                    "Ignore datatype initializations -- we only need the record declaration itself")
                  NIL)
             (PROGN                                          (* ; "default: eval and/or return it")
                    (AND (NEQ RETURNFLG T)
                         (EVAL FORM))
                    (AND RETURNFLG (LIST FORM])

(IMPORTFILESCAN
  [LAMBDA (FILE RETURNFLG)                               (* bvm%: "24-Oct-86 19:31")
    (WITH-READER-ENVIRONMENT (GET-ENVIRONMENT-AND-FILEMAP FILE)
        (while (FFILEPOS BEGINEXPORTDEFSTRING FILE NIL NIL NIL T) bind DEF
           join (until (EQUAL (SETQ DEF (READ FILE))
                                      ENDEXPORTDEFFORM) join (IMPORTEVAL DEF RETURNFLG))))])

(CHECKIMPORTS
  [LAMBDA (FILES NOASKFLG)                               (* rmk%: "19-FEB-83 16:31")
                                                             (* ; 
                                           "Loads exported definitions from new versions of FILES.")
    (COND
       ((AND (SETQ FILES (for FILE inside FILES bind FULLFILENAME DATE
                            when [AND (SETQ FULLFILENAME (FINDFILE FILE T))
                                          (OR [NOT (SETQ DATE (GETPROP (ROOTFILENAME FILE)
                                                                     'IMPORTDATE]
                                              (NOT (IEQP DATE (GETFILEINFO FULLFILENAME 
                                                                     'ICREATIONDATE]
                            collect (LIST FILE FULLFILENAME)))
             (OR NOASKFLG (SELECTQ (ASKUSER 5 'Y (LIST "load new exports from "
                                                       (MAPCAR FILES (FUNCTION CAR)))
                                          '((Y "es
")
                                            (N "o
"))
                                          T)
                              (N NIL)
                              T)))
        (for FILE in FILES do (IMPORTFILE (CADR FILE])

(GATHEREXPORTS
  [LAMBDA (FROMFILES TOFILE FLG)                         (* bvm%: "14-Oct-86 23:12")
                                                             (* ; 
                                        "Copies all exported definitions from FROMFILES to TOFILE.")
    (RESETLST
        [RESETSAVE NIL (LIST (FUNCTION CLOSE-AND-MAYBE-DELETE)
                             (SETQ TOFILE (OPENSTREAM TOFILE 'OUTPUT]
        (RESETSAVE (OUTPUT TOFILE))
        (LET ((ENV *DEFAULT-MAKEFILE-ENVIRONMENT*))
             (SETQ ENV (if ENV
                           then (\DO-DEFINE-FILE-INFO NIL ENV)
                         else *OLD-INTERLISP-READ-ENVIRONMENT*))
             (WITH-READER-ENVIRONMENT ENV
                 (PRINT-READER-ENVIRONMENT ENV)
                 (printout NIL "(LISPXPRIN1 %"EXPORTS GATHERED FROM " (DIRECTORYNAME T)
                        " ON "
                        (DATE)
                        "%"  T)" T "(LISPXTERPRI T)" T)
                 (for F inside FROMFILES do (MAPC (IMPORTFILE F (OR FLG T))
                                                              (FUNCTION PRINT))
                                                       (TERPRI))
                 (PRINT 'STOP)
                 (TERPRI)
                 (FULLNAME TOFILE))))])

(\DUMPEXPORTS
  [NLAMBDA COMS                                          (* bvm%: "24-Oct-86 19:42")

(* ;;; "Dumps an EXPORT form.  IMPORTFILE looks for a string announcing imports, but we must print it in a way that lets the file be loaded ok.")

    (PRIN1 "(")
    (PRIN2 '*)
    (PRIN1 (SUBSTRING BEGINEXPORTDEFSTRING 2))               (* ; 
                                   "BEGINEXPORTDEFSTRING starts with a * for benefit of IMPORTFILE")
    (for TAIL on COMS do (PRETTYCOM (CAR TAIL)))
    (TERPRI)
    (PRINT ENDEXPORTDEFFORM)
    (TERPRI])
)
(PUTDEF (QUOTE EXPORT) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (\DUMPEXPORTS . X])

(RPAQ? BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")

(RPAQ? ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM)
)



(* ; "for GAINSPACE")

(DEFINEQ

(CLEARFILEPKG
  [LAMBDA (FLG)                                          (* bvm%: "29-Aug-86 13:02")
    (PROG NIL
          (COND
             ((SELECTQ FLG
                  ((E T) 
                       T)
                  (Y (TERPRI T)
                     (PRIN1 "you can delete just the filemaps -
" T)
                     (PROG1 [ASKUSER NIL NIL "are you sure you want to delete EVERYTHING ? "
                                   '((Y "es - everything" RETURN T)
                                     (N "o - just the filemaps" RETURN NIL)
                                     (E "verything" RETURN T)
                                     (F "ilemaps only" RETURN NIL]
                            (TERPRI T)))
                  NIL)
              (UPDATEFILES)
              [SETQ FILELST (SUBSET FILELST (FUNCTION (LAMBDA (FILE)
                                                        (COND
                                                           ((fetch TOBEDUMPED
                                                               of (fetch FILEPROP
                                                                         of FILE))
                                                            (PRINT FILE T T)
                                                            (PRIN1 " has changes, not wiped." T)
                                                            (TERPRI T)
                                                            T)
                                                           (T (replace FILEPROP of FILE
                                                                 with NIL)
                                                              (replace FILECHANGES of FILE
                                                                 with NIL)
                                                              (SMASHFILECOMS FILE)
                                                              (NCONC1 SYSFILES FILE)
                                                              NIL]
              (SETQ LOADEDFILELST)))
          (SELECTQ FLG
              ((NIL T))
              (CLRHASH *FILEMAP-HASH*])
)

(ADDTOVAR GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
                                    ((Y "es")
                                     (N "o")
                                     (E . "verything")
                                     (F "ilemaps only
"))))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SMASHPROPSLST1)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT DECLARETAGSLST 
       DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 I.S.OPRLST LISPXCOMS 
       LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS MAKEFILEOPTIONS MAKEFILEREMAKEFLG 
       MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS SYSPROPS USERMACROS USERRECLST USERWORDS 
       FILEPKGTYPEPROPS)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
       (SPECVARS COMSNAME))

(BLOCK%: ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
       (NOLINKFNS . T)
       (SPECVARS COMSNAME)
       (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))

(BLOCK%: INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL INFILECOMSVALS 
       INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE
       (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
       INFILECOMSPROP)

(BLOCK%: NIL MAKEFILE (LOCALVARS . T)
       (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))

(BLOCK%: ADDFILE ADDFILE ADDFILE0)

(BLOCK%: FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))

(BLOCK%: NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
       COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES EDITDEF 
       EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM FILEPKGCOMPROPS FILEPKGTYPE
       FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES 
       MAKEFILESCOMS MAKELISPXMACROSCOMS MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED 
       MOVETOFILE POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
       SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED UNSAVEDEF 
       UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS COMPILE.EXT EDITMACROS 
                          EDITLOADFNSFLG LOADOPTIONS)
       (LOCALVARS . T))

(BLOCK%: DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))

(BLOCK%: GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
       GETDEFSAVED (RETFNS GETDEFCOM)
       (NOLINKFNS . T)
       (GLOBALVARS NOT-FOUNDTAG))
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS 
                          MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS 
                          PRETTYDEFMACROS)

(ADDTOVAR NLAML )

(ADDTOVAR LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES)
)
(PUTPROPS FILEPKG COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 
1990 1991 1992 1993 1995 2018 2020))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (22882 24587 (SEARCHPRETTYTYPELST 22892 . 23871) (PRETTYDEFMACROS 23873 . 24331) (
FILEPKGCOMPROPS 24333 . 24585)) (25389 59512 (CLEANUP 25399 . 26787) (COMPILEFILES 26789 . 27065) (
COMPILEFILES0 27067 . 27787) (CONTINUEDIT 27789 . 29209) (MAKEFILE 29211 . 40853) (FILECHANGES 40855
 . 43190) (FILEPKG.MERGECHANGES 43192 . 44015) (FILEPKG.CHANGEDFNS 44017 . 44329) (MAKEFILE1 44331 . 
48558) (COMPILE-FILE? 48560 . 50117) (MAKEFILES 50119 . 51812) (ADDFILE 51814 . 54335) (ADDFILE0 54337
 . 58473) (LISTFILES 58475 . 59510)) (60200 95440 (FILEPKGCHANGES 60210 . 61560) (GETFILEPKGTYPE 61562
 . 64635) (MARKASCHANGED 64637 . 66274) (FILECOMS 66276 . 66660) (WHEREIS 66662 . 68082) (
SMASHFILECOMS 68084 . 68319) (FILEFNSLST 68321 . 68483) (FILECOMSLST 68485 . 68969) (UPDATEFILES 68971
 . 74271) (INFILECOMS? 74273 . 76176) (INFILECOMTAIL 76178 . 77318) (INFILECOMS 77320 . 77481) (
INFILECOM 77483 . 87692) (INFILECOMSVALS 87694 . 88021) (INFILECOMSVAL 88023 . 89025) (INFILECOMSPROP 
89027 . 89856) (IFCPROPS 89858 . 91119) (IFCEXPRTYPE 91121 . 91632) (IFCPROPSCAN 91634 . 92687) (
IFCDECLARE 92689 . 94000) (INFILEPAIRS 94002 . 94334) (INFILECOMSMACRO 94336 . 95438)) (95475 126251 (
FILES? 95485 . 97678) (FILES?1 97680 . 98330) (FILES?PRINTLST 98332 . 99114) (ADDTOFILES? 99116 . 
109718) (ADDTOFILE 109720 . 110636) (WHATIS 110638 . 112614) (ADDTOCOMS 112616 . 114260) (ADDTOCOM 
114262 . 120809) (ADDTOCOM1 120811 . 121982) (ADDNEWCOM 121984 . 123034) (MAKENEWCOM 123036 . 124879) 
(DEFAULTMAKENEWCOM 124881 . 126249)) (126321 129138 (MERGEINSERT 126331 . 128674) (MERGEINSERT1 128676
 . 129136)) (130657 141569 (DELFROMFILES 130667 . 131517) (DELFROMCOMS 131519 . 133198) (DELFROMCOM 
133200 . 139068) (DELFROMCOM1 139070 . 139867) (REMOVEITEM 139869 . 140743) (MOVETOFILE 140745 . 
141567)) (141783 144152 (SAVEPUT 141793 . 144150)) (144277 152601 (UNMARKASCHANGED 144287 . 145995) (
PREEDITFN 145997 . 148508) (POSTEDITPROPS 148510 . 151011) (POSTEDITALISTS 151013 . 152599)) (152750 
173304 (ALISTS.GETDEF 152760 . 153139) (ALISTS.WHENCHANGED 153141 . 153785) (CLEARCLISPARRAY 153787 . 
154961) (EXPRESSIONS.WHENCHANGED 154963 . 155337) (MAKEALISTCOMS 155339 . 156412) (MAKEFILESCOMS 
156414 . 157851) (MAKELISPXMACROSCOMS 157853 . 159871) (MAKEPROPSCOMS 159873 . 160571) (
MAKEUSERMACROSCOMS 160573 . 162373) (PROPS.WHENCHANGED 162375 . 162996) (FILEGETDEF.LISPXMACROS 162998
 . 164440) (FILEGETDEF.ALISTS 164442 . 165061) (FILEGETDEF.RECORDS 165063 . 165994) (FILEGETDEF.PROPS 
165996 . 166788) (FILEGETDEF.MACROS 166790 . 167850) (FILEGETDEF.VARS 167852 . 168268) (FILEGETDEF.FNS
 168270 . 169634) (FILEPKGCOMS.PUTDEF 169636 . 172076) (FILES.PUTDEF 172078 . 173035) (VARS.PUTDEF 
173037 . 173180) (FILES.WHENCHANGED 173182 . 173302)) (175326 182759 (RENAME 175336 . 176737) (
CHANGECALLERS 176739 . 182757)) (182760 230708 (SHOWDEF 182770 . 183563) (COPYDEF 183565 . 186039) (
GETDEF 186041 . 188317) (GETDEFCOM 188319 . 189285) (GETDEFCOM0 189287 . 190633) (GETDEFCURRENT 190635
 . 197055) (GETDEFERR 197057 . 198358) (GETDEFFROMFILE 198360 . 202640) (GETDEFSAVED 202642 . 203746) 
(PUTDEF 203748 . 204451) (EDITDEF 204453 . 205430) (DEFAULT.EDITDEF 205432 . 208268) (EDITDEF.FILES 
208270 . 208471) (LOADDEF 208473 . 208649) (DWIMDEF 208651 . 209505) (DELDEF 209507 . 212521) (
DELFROMLIST 212523 . 213027) (HASDEF 213029 . 219351) (GETFILEDEF 219353 . 219875) (SAVEDEF 219877 . 
221536) (UNSAVEDEF 221538 . 222434) (COMPAREDEFS 222436 . 225738) (COMPARE 225740 . 226444) (TYPESOF 
226446 . 230706)) (230775 235818 (FIXEDITDATE 230785 . 234288) (EDITDATE? 234290 . 235816)) (236237 
244823 (FILEPKGCOM 236247 . 241180) (FILEPKGTYPE 241182 . 244821)) (256860 271412 (FINDCALLERS 256870
 . 257385) (EDITCALLERS 257387 . 265045) (EDITFROMFILE 265047 . 270727) (FINDATS 270729 . 271001) (
LOOKIN 271003 . 271410)) (271413 273140 (SEPRCASE 271423 . 273138)) (273657 279199 (IMPORTFILE 273667
 . 274641) (IMPORTEVAL 274643 . 275523) (IMPORTFILESCAN 275525 . 275946) (CHECKIMPORTS 275948 . 277284
) (GATHEREXPORTS 277286 . 278609) (\DUMPEXPORTS 278611 . 279197)) (279537 281745 (CLEARFILEPKG 279547
 . 281743)))))
STOP
\ No newline at end of file
